From 59ef2543182e0445979a2245dbaa06d1cdca35fd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 26 Feb 2018 09:18:51 -0700 Subject: [PATCH] switch to a new, Racket-implemented expander & module system This commit merges changes that were developed in the "racket7" repo. See that repo (which is no longer modified) for a more fine-grained change history. The commit includes experimental support for running Racket on Chez Scheme, but that "CS" variant is not built by default. --- INSTALL.txt | 338 +- Makefile | 159 +- README.md | 14 +- pkgs/base/info.rkt | 2 +- .../compiler/commands/decompile.rkt | 4 + pkgs/compiler-lib/compiler/commands/exe.rkt | 12 +- pkgs/compiler-lib/compiler/decompile.rkt | 803 +- .../compiler/demodularizer/alpha.rkt | 20 - .../compiler/demodularizer/batch.rkt | 41 - .../compiler/demodularizer/bundle.rkt | 169 + .../compiler/demodularizer/find.rkt | 164 + .../compiler/demodularizer/gc-toplevels.rkt | 288 - .../compiler/demodularizer/gc.rkt | 164 + .../compiler/demodularizer/import.rkt | 5 + .../compiler/demodularizer/info.rkt | 3 - .../compiler/demodularizer/main.rkt | 128 +- .../compiler/demodularizer/merge.rkt | 343 +- .../compiler/demodularizer/module-path.rkt | 38 + .../compiler/demodularizer/module.rkt | 43 - .../compiler/demodularizer/mpi.rkt | 41 - .../compiler/demodularizer/name.rkt | 61 + .../compiler/demodularizer/nodep.rkt | 228 - .../compiler/demodularizer/remap.rkt | 79 + .../compiler/demodularizer/replace-modidx.rkt | 29 - .../compiler/demodularizer/run.rkt | 5 + .../demodularizer/update-toplevels.rkt | 108 - .../compiler/demodularizer/util.rkt | 79 - .../compiler/demodularizer/write.rkt | 11 + .../compiler/private/deserialize.rkt | 121 + .../compiler/demodularizer/demod-test.rkt | 13 +- .../tests/racket/benchmarks/common/auto.rkt | 60 +- .../tests/racket/benchmarks/rx/auto.rkt | 29 +- .../pkg/scribblings/dirs-catalog.scrbl | 14 +- .../scribblings/foreign/derived.scrbl | 1 + .../scribblings/foreign/os-thread.scrbl | 63 + .../scribblings/foreign/types.scrbl | 9 +- .../scribblings/foreign/unexported.scrbl | 30 +- .../scribblings/guide/performance.scrbl | 6 +- .../scribblings/raco/decompile.scrbl | 9 +- .../racket-doc/scribblings/raco/exe-api.scrbl | 10 +- pkgs/racket-doc/scribblings/raco/exe.scrbl | 4 + .../scribblings/raco/launcher.scrbl | 20 +- pkgs/racket-doc/scribblings/raco/make.scrbl | 19 + pkgs/racket-doc/scribblings/raco/setup.scrbl | 39 +- .../scribblings/raco/zo-parse.scrbl | 21 +- .../scribblings/raco/zo-struct.scrbl | 571 +- .../scribblings/reference/data.scrbl | 12 + .../scribblings/reference/eval.scrbl | 7 +- .../scribblings/reference/linklet.scrbl | 460 + .../scribblings/reference/memory.scrbl | 4 +- .../scribblings/reference/namespaces.scrbl | 22 +- .../scribblings/reference/readtables.scrbl | 10 +- .../scribblings/reference/runtime.scrbl | 8 +- .../scribblings/reference/security.scrbl | 1 + .../scribblings/reference/stx-trans.scrbl | 31 +- .../scribblings/reference/unsafe.scrbl | 1 + .../scribblings/reference/vectors.scrbl | 17 + .../syntax/scribblings/modcode.scrbl | 25 +- pkgs/racket-test-core/tests/racket/basic.rktl | 16 +- .../tests/racket/chaperone.rktl | 2 +- .../tests/racket/core-tests.rktl | 1 + .../tests/racket/expobs-regression.rktd | 9851 ++ .../racket-test-core/tests/racket/expobs.rktl | 185 + .../tests/racket/foreign-test.rktl | 90 +- .../tests/racket/jitinline.rktl | 28 +- pkgs/racket-test-core/tests/racket/macro.rktl | 125 + .../tests/racket/modprot.rktl | 87 +- .../racket-test-core/tests/racket/module.rktl | 251 +- .../tests/racket/namespac.rktl | 4 +- .../tests/racket/numstrs.rktl | 28 +- .../tests/racket/optimize.rktl | 121 +- pkgs/racket-test-core/tests/racket/param.rktl | 6 +- pkgs/racket-test-core/tests/racket/port.rktl | 28 +- pkgs/racket-test-core/tests/racket/procs.rktl | 2 +- .../tests/racket/prompt-tests.rktl | 3 +- .../racket-test-core/tests/racket/prompt.rktl | 2 +- pkgs/racket-test-core/tests/racket/read.rktl | 7 +- .../tests/racket/readtable.rktl | 2 +- pkgs/racket-test-core/tests/racket/rx.rktl | 12 +- .../tests/racket/sandbox.rktl | 6 +- pkgs/racket-test-core/tests/racket/stx.rktl | 39 +- .../tests/racket/submodule.rktl | 4 +- pkgs/racket-test-core/tests/racket/sync.rktl | 13 +- .../racket-test-core/tests/racket/syntax.rktl | 29 +- .../racket-test-core/tests/racket/thread.rktl | 12 +- pkgs/racket-test-core/tests/racket/will.rktl | 51 +- pkgs/zo-lib/compiler/zo-marshal.rkt | 1176 +- pkgs/zo-lib/compiler/zo-parse.rkt | 1253 +- pkgs/zo-lib/compiler/zo-structs.rkt | 203 +- racket/collects/compiler/cm.rkt | 759 +- racket/collects/compiler/depend.rkt | 37 + racket/collects/compiler/distribute.rkt | 67 +- racket/collects/compiler/embed.rkt | 8 +- .../collects/compiler/private/cm-minimal.rkt | 763 + racket/collects/compiler/private/elf.rkt | 10 +- racket/collects/compiler/private/macfw.rkt | 11 +- racket/collects/compiler/private/mach-o.rkt | 11 +- .../collects/compiler/private/windlldir.rkt | 7 +- racket/collects/data/bit-vector.rkt | 3 +- racket/collects/db/private/sqlite3/ffi.rkt | 39 +- racket/collects/ffi/unsafe.rkt | 93 +- racket/collects/ffi/unsafe/objc.rkt | 4 +- racket/collects/ffi/unsafe/os-thread.rkt | 9 + racket/collects/launcher/launcher.rkt | 32 +- racket/collects/net/osx-ssl.rkt | 119 +- racket/collects/openssl/mzssl.rkt | 39 +- racket/collects/pkg/dirs-catalog.rkt | 41 +- racket/collects/pkg/private/catalog-copy.rkt | 54 +- racket/collects/racket/extflonum.rkt | 3 +- racket/collects/racket/fixnum.rkt | 3 +- racket/collects/racket/flonum.rkt | 3 +- racket/collects/racket/gui/dynamic.rkt | 8 +- racket/collects/racket/linklet.rkt | 88 + .../racket/private/class-internal.rkt | 9 +- racket/collects/racket/private/classidmap.rkt | 5 +- racket/collects/racket/private/collect.rkt | 40 +- .../collects/racket/private/define-et-al.rkt | 9 +- .../collects/racket/private/define-struct.rkt | 8 +- racket/collects/racket/private/for.rkt | 97 +- racket/collects/racket/private/kw.rkt | 20 +- racket/collects/racket/private/load.rkt | 35 - racket/collects/racket/private/map.rkt | 124 +- racket/collects/racket/private/misc.rkt | 12 +- .../collects/racket/private/more-scheme.rkt | 2 +- racket/collects/racket/private/path-list.rkt | 12 +- racket/collects/racket/private/pre-base.rkt | 30 +- racket/collects/racket/private/reverse.rkt | 30 +- racket/collects/racket/private/sort.rkt | 38 +- racket/collects/racket/private/string.rkt | 70 +- racket/collects/racket/private/stx.rkt | 4 +- racket/collects/racket/private/stxparam.rkt | 54 +- .../collects/racket/private/stxparamkey.rkt | 191 +- .../collects/racket/private/vector-wraps.rkt | 6 +- racket/collects/racket/splicing.rkt | 110 +- racket/collects/racket/stxparam-exptime.rkt | 9 +- racket/collects/racket/stxparam.rkt | 28 +- racket/collects/raco/main.rkt | 21 +- racket/collects/setup/cross-system.rkt | 11 +- racket/collects/setup/main.rkt | 213 +- .../collects/setup/private/command-name.rkt | 4 +- racket/collects/setup/private/dirs.rkt | 3 + racket/collects/setup/setup-cmdline.rkt | 6 + racket/collects/setup/variant.rkt | 45 +- racket/collects/syntax/modcode.rkt | 259 +- racket/collects/syntax/modread.rkt | 14 +- racket/collects/syntax/modresolve.rkt | 128 +- .../collects/syntax/private/modcode-noctc.rkt | 266 + .../syntax/private/modresolve-noctc.rkt | 130 + racket/src/Makefile.in | 1 + racket/src/README | 312 +- racket/src/cify/README.txt | 47 + racket/src/cify/arg.rkt | 75 + racket/src/cify/debug.rkt | 7 + racket/src/cify/free-var.rkt | 90 + racket/src/cify/function.rkt | 109 + racket/src/cify/generate.rkt | 1114 + racket/src/cify/id.rkt | 78 + racket/src/cify/inline.rkt | 143 + racket/src/cify/lambda.rkt | 58 + racket/src/cify/main.rkt | 129 + racket/src/cify/match.rkt | 4 + racket/src/cify/out.rkt | 46 + racket/src/cify/prim-name.rkt | 72 + racket/src/cify/primitive.rkt | 11 + racket/src/cify/prune.rkt | 87 + racket/src/cify/ref.rkt | 294 + racket/src/cify/return.rkt | 43 + racket/src/cify/runstack.rkt | 287 + racket/src/cify/simple.rkt | 118 + racket/src/cify/sort.rkt | 23 + racket/src/cify/state.rkt | 114 + racket/src/cify/struct.rkt | 109 + racket/src/cify/top-name.rkt | 60 + racket/src/cify/union-find.rkt | 18 + racket/src/cify/union.rkt | 15 + racket/src/cify/unique.rkt | 106 + racket/src/cify/vehicle.rkt | 114 + racket/src/common/check.rkt | 4 + racket/src/common/queue.rkt | 105 + racket/src/configure | 36 + racket/src/cs/.gitignore | 2 + racket/src/cs/Makefile | 310 + racket/src/cs/README.txt | 391 + racket/src/cs/absify.rkt | 40 + racket/src/cs/c/Makefile.in | 226 + racket/src/cs/c/README.txt | 73 + racket/src/cs/c/boot.c | 138 + racket/src/cs/c/boot.h | 4 + racket/src/cs/c/configure | 5202 ++ racket/src/cs/c/configure.ac | 363 + racket/src/cs/c/cs_config.h.in | 1 + racket/src/cs/c/embed-boot.rkt | 58 + racket/src/cs/c/grmain.c | 19 + racket/src/cs/c/main.c | 132 + racket/src/cs/chezpart.sls | 82 + racket/src/cs/compile-file.ss | 102 + racket/src/cs/convert.rkt | 254 + racket/src/cs/demo/chaperone.ss | 458 + racket/src/cs/demo/control.ss | 639 + racket/src/cs/demo/expander.ss | 72 + racket/src/cs/demo/foreign.ss | 73 + racket/src/cs/demo/hash.ss | 425 + racket/src/cs/demo/io-impl.rkt | 101 + racket/src/cs/demo/io.rkt | 64 + racket/src/cs/demo/io.ss | 120 + racket/src/cs/demo/linklet.rkt | 13 + racket/src/cs/demo/linklet.ss | 20 + racket/src/cs/demo/regexp.rkt | 21 + racket/src/cs/demo/regexp.rktl | 51 + racket/src/cs/demo/regexp.ss | 5 + racket/src/cs/demo/struct.ss | 275 + racket/src/cs/demo/thread.ss | 221 + racket/src/cs/demo/will.ss | 46 + racket/src/cs/expander.rkt | 15 + racket/src/cs/expander.sls | 184 + racket/src/cs/include.ss | 8 + racket/src/cs/io.sls | 395 + racket/src/cs/linklet.sls | 1246 + racket/src/cs/main.sps | 484 + racket/src/cs/primitive/extfl.ss | 47 + racket/src/cs/primitive/flfxnum.ss | 73 + racket/src/cs/primitive/foreign.ss | 83 + racket/src/cs/primitive/futures.ss | 17 + racket/src/cs/primitive/internal.ss | 32 + racket/src/cs/primitive/kernel.ss | 978 + racket/src/cs/primitive/linklet.ss | 31 + racket/src/cs/primitive/network.ss | 43 + racket/src/cs/primitive/paramz.ss | 12 + racket/src/cs/primitive/place.ss | 17 + racket/src/cs/primitive/unsafe.ss | 163 + racket/src/cs/regexp.sls | 8 + racket/src/cs/rumble.sls | 738 + racket/src/cs/rumble/arity.ss | 41 + racket/src/cs/rumble/begin0.ss | 16 + racket/src/cs/rumble/boolean.ss | 1 + racket/src/cs/rumble/box.ss | 146 + racket/src/cs/rumble/bytes.ss | 177 + racket/src/cs/rumble/char.ss | 642 + racket/src/cs/rumble/check.ss | 77 + racket/src/cs/rumble/constant.ss | 5 + racket/src/cs/rumble/control.ss | 1845 + racket/src/cs/rumble/correlated.ss | 102 + racket/src/cs/rumble/datum.ss | 22 + racket/src/cs/rumble/define.ss | 480 + racket/src/cs/rumble/engine.ss | 151 + racket/src/cs/rumble/ephemeron.ss | 17 + racket/src/cs/rumble/equal.ss | 225 + racket/src/cs/rumble/error.ss | 747 + racket/src/cs/rumble/extfl.ss | 88 + racket/src/cs/rumble/flvector.ss | 119 + racket/src/cs/rumble/foreign.ss | 1718 + racket/src/cs/rumble/fsemaphore.ss | 20 + racket/src/cs/rumble/future.ss | 14 + racket/src/cs/rumble/graph.ss | 172 + racket/src/cs/rumble/hamt.ss | 932 + racket/src/cs/rumble/hash-code.ss | 150 + racket/src/cs/rumble/hash.ss | 1207 + racket/src/cs/rumble/immutable.ss | 8 + racket/src/cs/rumble/impersonator.ss | 591 + racket/src/cs/rumble/inline.ss | 57 + racket/src/cs/rumble/interrupt.ss | 59 + racket/src/cs/rumble/intmap.ss | 469 + racket/src/cs/rumble/keyword.ss | 38 + racket/src/cs/rumble/list.ss | 110 + racket/src/cs/rumble/lock.ss | 95 + racket/src/cs/rumble/memory.ss | 294 + racket/src/cs/rumble/mpair.ss | 42 + racket/src/cs/rumble/number.ss | 295 + racket/src/cs/rumble/object-name.ss | 62 + racket/src/cs/rumble/parameter.ss | 121 + racket/src/cs/rumble/place.ss | 36 + racket/src/cs/rumble/prefab.ss | 331 + racket/src/cs/rumble/procedure.ss | 755 + racket/src/cs/rumble/pthread.ss | 33 + racket/src/cs/rumble/random.ss | 275 + racket/src/cs/rumble/srcloc.ss | 14 + racket/src/cs/rumble/string.ss | 28 + racket/src/cs/rumble/struct.ss | 1151 + racket/src/cs/rumble/symbol.ss | 53 + racket/src/cs/rumble/syntax-rule.ss | 6 + racket/src/cs/rumble/system.ss | 63 + racket/src/cs/rumble/thread-cell.ss | 38 + racket/src/cs/rumble/time.ss | 136 + racket/src/cs/rumble/unsafe.ss | 147 + racket/src/cs/rumble/variable.ss | 22 + racket/src/cs/rumble/vector.ss | 400 + racket/src/cs/rumble/version.ss | 25 + racket/src/cs/rumble/virtual-register.ss | 34 + racket/src/cs/rumble/will-executor.ss | 93 + racket/src/cs/schemify.sls | 66 + racket/src/cs/strip.ss | 6 + racket/src/cs/thread.sls | 121 + racket/src/expander/Makefile | 80 + racket/src/expander/README.txt | 240 + racket/src/expander/boot/core-primitive.rkt | 201 + racket/src/expander/boot/expobs-primitive.rkt | 7 + racket/src/expander/boot/handler.rkt | 683 + racket/src/expander/boot/kernel.rkt | 120 + .../src/expander/boot/linklet-primitive.rkt | 9 + racket/src/expander/boot/load-handler.rkt | 222 + racket/src/expander/boot/main-primitive.rkt | 90 + racket/src/expander/boot/place-primitive.rkt | 23 + racket/src/expander/boot/read-primitive.rkt | 48 + .../src/expander/boot/runtime-primitive.rkt | 52 + racket/src/expander/boot/utils-primitive.rkt | 37 + racket/src/expander/bootstrap-demo.rkt | 3 + racket/src/expander/bootstrap-run.rkt | 4 + racket/src/expander/common/contract.rkt | 13 + racket/src/expander/common/inline.rkt | 30 + racket/src/expander/common/intern.rkt | 139 + racket/src/expander/common/list-ish.rkt | 42 + racket/src/expander/common/make-match.rkt | 229 + racket/src/expander/common/memo.rkt | 24 + .../expander/common/module-path-intern.rkt | 38 + racket/src/expander/common/module-path.rkt | 470 + .../src/expander/common/parse-module-path.rkt | 445 + racket/src/expander/common/performance.rkt | 197 + racket/src/expander/common/phase.rkt | 45 + racket/src/expander/common/prefab.rkt | 31 + racket/src/expander/common/reflect-hash.rkt | 9 + racket/src/expander/common/set.rkt | 130 + racket/src/expander/common/small-hash.rkt | 25 + racket/src/expander/common/struct-star.rkt | 267 + .../src/expander/compile/built-in-symbol.rkt | 65 + .../expander/compile/compiled-in-memory.rkt | 39 + racket/src/expander/compile/context.rkt | 30 + racket/src/expander/compile/correlate.rkt | 34 + .../src/expander/compile/eager-instance.rkt | 40 + racket/src/expander/compile/expr.rkt | 236 + .../src/expander/compile/extra-inspector.rkt | 142 + racket/src/expander/compile/form.rkt | 463 + racket/src/expander/compile/header.rkt | 329 + racket/src/expander/compile/instance.rkt | 67 + racket/src/expander/compile/known.rkt | 55 + racket/src/expander/compile/main.rkt | 72 + racket/src/expander/compile/module-use.rkt | 11 + racket/src/expander/compile/module.rkt | 420 + .../src/expander/compile/multi-top-data.rkt | 94 + racket/src/expander/compile/multi-top.rkt | 82 + .../src/expander/compile/namespace-scope.rkt | 67 + racket/src/expander/compile/recompile.rkt | 25 + .../src/expander/compile/reserved-symbol.rkt | 34 + racket/src/expander/compile/self-quoting.rkt | 6 + .../expander/compile/serialize-property.rkt | 45 + .../src/expander/compile/serialize-state.rkt | 113 + racket/src/expander/compile/serialize.rkt | 893 + racket/src/expander/compile/side-effect.rkt | 456 + racket/src/expander/compile/top.rkt | 170 + racket/src/expander/compile/vector-ref.rkt | 14 + racket/src/expander/demo.rkt | 1411 + racket/src/expander/eval/api.rkt | 77 + racket/src/expander/eval/collection.rkt | 484 + racket/src/expander/eval/direct.rkt | 76 + racket/src/expander/eval/dynamic-require.rkt | 129 + racket/src/expander/eval/load.rkt | 62 + racket/src/expander/eval/main.rkt | 398 + racket/src/expander/eval/module-cache.rkt | 30 + racket/src/expander/eval/module-read.rkt | 67 + racket/src/expander/eval/module.rkt | 397 + racket/src/expander/eval/multi-top.rkt | 96 + racket/src/expander/eval/parameter.rkt | 133 + racket/src/expander/eval/protect.rkt | 81 + racket/src/expander/eval/reflect-name.rkt | 85 + racket/src/expander/eval/reflect.rkt | 200 + racket/src/expander/eval/root-context.rkt | 51 + .../src/expander/eval/top-level-instance.rkt | 49 + racket/src/expander/eval/top.rkt | 198 + .../src/expander/expand/allowed-context.rkt | 55 + .../src/expander/expand/already-expanded.rkt | 9 + racket/src/expander/expand/append.rkt | 10 + racket/src/expander/expand/bind-top.rkt | 33 + .../expand/binding-for-transformer.rkt | 29 + .../src/expander/expand/binding-to-module.rkt | 43 + racket/src/expander/expand/body.rkt | 451 + racket/src/expander/expand/context.rkt | 198 + racket/src/expander/expand/cross-phase.rkt | 94 + racket/src/expander/expand/def-id.rkt | 101 + .../expander/expand/definition-context.rkt | 268 + racket/src/expander/expand/dup-check.rkt | 28 + racket/src/expander/expand/env.rkt | 154 + .../src/expander/expand/expanded+parsed.rkt | 58 + racket/src/expander/expand/expr.rkt | 756 + racket/src/expander/expand/free-id-set.rkt | 36 + .../src/expander/expand/liberal-def-ctx.rkt | 16 + racket/src/expander/expand/lift-context.rkt | 222 + racket/src/expander/expand/lift-key.rkt | 9 + racket/src/expander/expand/local-expand.rkt | 153 + racket/src/expander/expand/log.rkt | 154 + racket/src/expander/expand/main.rkt | 744 + racket/src/expander/expand/missing-module.rkt | 82 + racket/src/expander/expand/module-path.rkt | 33 + racket/src/expander/expand/module.rkt | 1459 + racket/src/expander/expand/parsed.rkt | 51 + racket/src/expander/expand/prepare.rkt | 12 + racket/src/expander/expand/protect.rkt | 70 + racket/src/expander/expand/provide.rkt | 276 + racket/src/expander/expand/rebuild.rkt | 14 + .../src/expander/expand/reference-record.rkt | 55 + racket/src/expander/expand/rename-trans.rkt | 61 + .../src/expander/expand/require+provide.rkt | 487 + racket/src/expander/expand/require.rkt | 469 + .../expander/expand/root-expand-context.rkt | 115 + .../src/expander/expand/save-and-restore.rkt | 18 + racket/src/expander/expand/set-bang-trans.rkt | 57 + racket/src/expander/expand/stop-ids.rkt | 42 + .../src/expander/expand/syntax-id-error.rkt | 107 + .../expander/expand/syntax-implicit-error.rkt | 34 + racket/src/expander/expand/syntax-local.rkt | 436 + racket/src/expander/expand/top.rkt | 86 + racket/src/expander/expand/use-site.rkt | 20 + racket/src/expander/extract/c-encode.rkt | 21 + .../src/expander/extract/check-and-report.rkt | 69 + racket/src/expander/extract/decompile.rkt | 36 + racket/src/expander/extract/defn-known.rkt | 140 + racket/src/expander/extract/defn.rkt | 12 + racket/src/expander/extract/export.rkt | 29 + racket/src/expander/extract/flatten.rkt | 186 + racket/src/expander/extract/gc-defn.rkt | 115 + racket/src/expander/extract/get-linklet.rkt | 108 + .../src/expander/extract/known-primitive.rkt | 24 + racket/src/expander/extract/link.rkt | 7 + racket/src/expander/extract/linklet-info.rkt | 13 + racket/src/expander/extract/linklet.rkt | 21 + racket/src/expander/extract/main.rkt | 147 + racket/src/expander/extract/module.rkt | 72 + racket/src/expander/extract/needed.rkt | 17 + .../src/expander/extract/primitive-table.rkt | 73 + racket/src/expander/extract/prune-name.rkt | 77 + .../src/expander/extract/save-and-report.rkt | 45 + racket/src/expander/extract/simplify-defn.rkt | 159 + racket/src/expander/extract/symbol.rkt | 38 + racket/src/expander/extract/underscore.rkt | 40 + racket/src/expander/extract/variable.rkt | 8 + racket/src/expander/host/correlate-syntax.rkt | 17 + racket/src/expander/host/correlate.rkt | 111 + racket/src/expander/host/linklet.rkt | 24 + .../expander/host/reader-syntax-to-syntax.rkt | 54 + racket/src/expander/host/reader-syntax.rkt | 19 + racket/src/expander/host/string-to-number.rkt | 11 + .../expander/host/syntax-to-reader-syntax.rkt | 28 + racket/src/expander/info.rkt | 13 + racket/src/expander/main.rkt | 179 + racket/src/expander/namespace/api-module.rkt | 134 + racket/src/expander/namespace/api.rkt | 253 + racket/src/expander/namespace/attach.rkt | 150 + racket/src/expander/namespace/core.rkt | 124 + racket/src/expander/namespace/inspector.rkt | 6 + racket/src/expander/namespace/module.rkt | 549 + racket/src/expander/namespace/namespace.rkt | 207 + .../expander/namespace/primitive-module.rkt | 35 + .../expander/namespace/provide-for-api.rkt | 53 + racket/src/expander/namespace/provided.rkt | 29 + racket/src/expander/namespace/registry.rkt | 40 + .../expander/namespace/variable-reference.rkt | 76 + racket/src/expander/read/accum-string.rkt | 84 + racket/src/expander/read/api.rkt | 59 + racket/src/expander/read/box.rkt | 19 + racket/src/expander/read/char.rkt | 113 + racket/src/expander/read/closer.rkt | 64 + racket/src/expander/read/coerce-key.rkt | 10 + racket/src/expander/read/coerce.rkt | 11 + racket/src/expander/read/config.rkt | 135 + racket/src/expander/read/constant.rkt | 34 + racket/src/expander/read/consume.rkt | 16 + racket/src/expander/read/delimiter.rkt | 33 + racket/src/expander/read/demo.rkt | 186 + racket/src/expander/read/digit.rkt | 63 + racket/src/expander/read/error.rkt | 47 + racket/src/expander/read/extension.rkt | 239 + racket/src/expander/read/fixnum-flonum.rkt | 42 + racket/src/expander/read/graph.rkt | 108 + racket/src/expander/read/hash.rkt | 180 + racket/src/expander/read/indentation.rkt | 97 + racket/src/expander/read/language.rkt | 52 + racket/src/expander/read/location.rkt | 14 + racket/src/expander/read/main.rkt | 405 + racket/src/expander/read/number.rkt | 829 + racket/src/expander/read/parameter.rkt | 55 + .../src/expander/read/primitive-parameter.rkt | 36 + racket/src/expander/read/quote.rkt | 14 + .../src/expander/read/readtable-parameter.rkt | 16 + racket/src/expander/read/readtable.rkt | 199 + racket/src/expander/read/regexp.rkt | 48 + racket/src/expander/read/sequence.rkt | 131 + racket/src/expander/read/special-comment.rkt | 9 + racket/src/expander/read/special.rkt | 20 + racket/src/expander/read/string.rkt | 224 + racket/src/expander/read/struct.rkt | 75 + racket/src/expander/read/symbol-or-number.rkt | 137 + racket/src/expander/read/vector.rkt | 134 + racket/src/expander/read/whitespace.rkt | 112 + racket/src/expander/read/wrap.rkt | 10 + racket/src/expander/run.rkt | 350 + racket/src/expander/run/bootstrap.rkt | 12 + racket/src/expander/run/cache.rkt | 128 + .../run/correlated-to-host-syntax.rkt | 26 + .../expander/run/host-syntax-to-syntax.rkt | 36 + racket/src/expander/run/linklet-operation.rkt | 47 + racket/src/expander/run/linklet.rkt | 510 + racket/src/expander/run/status.rkt | 28 + racket/src/expander/run/submodule.rkt | 31 + racket/src/expander/syntax/api-taint.rkt | 74 + racket/src/expander/syntax/api.rkt | 188 + racket/src/expander/syntax/binding-table.rkt | 290 + racket/src/expander/syntax/binding.rkt | 311 + racket/src/expander/syntax/bulk-binding.rkt | 177 + racket/src/expander/syntax/cache.rkt | 81 + racket/src/expander/syntax/datum-map.rkt | 90 + racket/src/expander/syntax/debug.rkt | 70 + racket/src/expander/syntax/error.rkt | 107 + racket/src/expander/syntax/fallback.rkt | 64 + racket/src/expander/syntax/full-binding.rkt | 23 + racket/src/expander/syntax/local-binding.rkt | 57 + racket/src/expander/syntax/mapped-name.rkt | 14 + racket/src/expander/syntax/match.rkt | 13 + racket/src/expander/syntax/module-binding.rkt | 190 + racket/src/expander/syntax/original.rkt | 7 + racket/src/expander/syntax/preserved.rkt | 40 + racket/src/expander/syntax/property.rkt | 58 + racket/src/expander/syntax/read-syntax.rkt | 161 + racket/src/expander/syntax/scope.rkt | 837 + racket/src/expander/syntax/srcloc.rkt | 57 + racket/src/expander/syntax/syntax.rkt | 297 + racket/src/expander/syntax/taint-dispatch.rkt | 67 + racket/src/expander/syntax/taint.rkt | 117 + racket/src/expander/syntax/tamper.rkt | 60 + racket/src/expander/syntax/to-list.rkt | 15 + racket/src/expander/syntax/track.rkt | 111 + racket/src/foreign/foreign.c | 814 +- racket/src/foreign/foreign.rktc | 294 +- racket/src/gracket/Makefile.in | 5 +- racket/src/gracket/gc2/Makefile.in | 12 +- racket/src/gracket/grmain.c | 108 +- racket/src/io/Makefile | 51 + racket/src/io/README.txt | 16 + racket/src/io/bootstrap-main.rkt | 5 + racket/src/io/bootstrap-thread-main.rkt | 7 + racket/src/io/common/bytes-no-nuls.rkt | 8 + racket/src/io/common/check.rkt | 34 + racket/src/io/common/internal-error.rkt | 7 + racket/src/io/common/resource.rkt | 43 + racket/src/io/common/set-two.rkt | 14 + racket/src/io/converter/encoding.rkt | 17 + racket/src/io/converter/main.rkt | 230 + racket/src/io/converter/utf-8.rkt | 307 + racket/src/io/demo-thread.rkt | 235 + racket/src/io/demo.rkt | 812 + racket/src/io/demo2.rkt | 49 + racket/src/io/envvar/main.rkt | 125 + racket/src/io/envvar/string.rkt | 16 + racket/src/io/error/main.rkt | 63 + racket/src/io/file/error.rkt | 72 + racket/src/io/file/host.rkt | 33 + racket/src/io/file/identity.rkt | 40 + racket/src/io/file/main.rkt | 390 + racket/src/io/file/parameter.rkt | 7 + racket/src/io/filesystem-change-evt/main.rkt | 17 + racket/src/io/foreign/main.rkt | 92 + racket/src/io/format/main.rkt | 30 + racket/src/io/format/printf.rkt | 196 + racket/src/io/host/bootstrap-rktio.rkt | 218 + racket/src/io/host/bootstrap-thread.rkt | 9 + racket/src/io/host/bootstrap.rkt | 114 + racket/src/io/host/error.rkt | 62 + racket/src/io/host/rktio.rkt | 77 + racket/src/io/host/thread.rkt | 86 + racket/src/io/locale/collate.rkt | 158 + racket/src/io/locale/main.rkt | 23 + racket/src/io/locale/nul-char.rkt | 18 + racket/src/io/locale/parameter.rkt | 71 + racket/src/io/locale/recase.rkt | 105 + racket/src/io/locale/string.rkt | 98 + racket/src/io/locale/ucs-4.rkt | 29 + racket/src/io/logger/demo.rkt | 54 + racket/src/io/logger/level.rkt | 89 + racket/src/io/logger/logger.rkt | 46 + racket/src/io/logger/main.rkt | 123 + racket/src/io/logger/receiver.rkt | 126 + racket/src/io/logger/wanted.rkt | 96 + racket/src/io/main.rkt | 43 + racket/src/io/network/address.rkt | 93 + racket/src/io/network/check.rkt | 14 + racket/src/io/network/error.rkt | 39 + racket/src/io/network/evt.rkt | 26 + racket/src/io/network/main.rkt | 6 + racket/src/io/network/port-number.rkt | 12 + racket/src/io/network/tcp-accept.rkt | 128 + racket/src/io/network/tcp-address.rkt | 76 + racket/src/io/network/tcp-connect.rkt | 109 + racket/src/io/network/tcp-listen.rkt | 110 + racket/src/io/network/tcp-port.rkt | 59 + racket/src/io/network/tcp.rkt | 23 + racket/src/io/network/udp-multicast.rkt | 143 + racket/src/io/network/udp-receive.rkt | 155 + racket/src/io/network/udp-send.rkt | 199 + racket/src/io/network/udp-socket.rkt | 145 + racket/src/io/network/udp.rkt | 38 + racket/src/io/path/api.rkt | 53 + racket/src/io/path/build.rkt | 408 + racket/src/io/path/check-path.rkt | 10 + racket/src/io/path/check.rkt | 29 + racket/src/io/path/cleanse.rkt | 94 + racket/src/io/path/complete.rkt | 47 + racket/src/io/path/directory-path.rkt | 76 + racket/src/io/path/ffi.rkt | 15 + racket/src/io/path/main.rkt | 157 + racket/src/io/path/parameter.rkt | 35 + racket/src/io/path/path.rkt | 63 + racket/src/io/path/protect.rkt | 48 + racket/src/io/path/relativity.rkt | 76 + racket/src/io/path/sep.rkt | 7 + racket/src/io/path/simplify.rkt | 124 + racket/src/io/path/split.rkt | 290 + racket/src/io/path/string.rkt | 17 + racket/src/io/path/system.rkt | 70 + racket/src/io/path/windows.rkt | 408 + racket/src/io/port/buffer-mode.rkt | 55 + racket/src/io/port/bytes-input.rkt | 200 + racket/src/io/port/bytes-output.rkt | 89 + racket/src/io/port/bytes-port.rkt | 227 + racket/src/io/port/check.rkt | 25 + racket/src/io/port/close.rkt | 64 + racket/src/io/port/commit-manager.rkt | 139 + racket/src/io/port/count.rkt | 210 + racket/src/io/port/custom-input-port.rkt | 297 + racket/src/io/port/custom-output-port.rkt | 186 + racket/src/io/port/custom-port.rkt | 96 + racket/src/io/port/evt.rkt | 35 + racket/src/io/port/fd-port.rkt | 335 + racket/src/io/port/file-identity.rkt | 22 + racket/src/io/port/file-lock.rkt | 56 + racket/src/io/port/file-port.rkt | 180 + racket/src/io/port/file-position.rkt | 68 + racket/src/io/port/file-stream.rkt | 23 + racket/src/io/port/file-truncate.rkt | 20 + racket/src/io/port/flush-output.rkt | 33 + racket/src/io/port/handler.rkt | 148 + racket/src/io/port/input-port.rkt | 203 + racket/src/io/port/line-input.rkt | 69 + racket/src/io/port/main.rkt | 154 + racket/src/io/port/nowhere.rkt | 13 + racket/src/io/port/output-port.rkt | 159 + racket/src/io/port/parameter.rkt | 48 + racket/src/io/port/peek-via-read-port.rkt | 193 + racket/src/io/port/pipe.rkt | 424 + racket/src/io/port/port.rkt | 34 + racket/src/io/port/prepare-change.rkt | 11 + racket/src/io/port/progress-evt.rkt | 74 + racket/src/io/port/read-and-peek.rkt | 241 + racket/src/io/port/ready.rkt | 57 + racket/src/io/port/special-input.rkt | 94 + racket/src/io/port/special-output.rkt | 64 + racket/src/io/port/string-input.rkt | 362 + racket/src/io/port/string-output.rkt | 31 + racket/src/io/port/string-port.rkt | 22 + racket/src/io/port/write.rkt | 54 + racket/src/io/print/bytes.rkt | 81 + racket/src/io/print/char.rkt | 40 + racket/src/io/print/config.rkt | 15 + racket/src/io/print/custom-write.rkt | 30 + racket/src/io/print/graph.rkt | 211 + racket/src/io/print/hash.rkt | 57 + racket/src/io/print/list.rkt | 57 + racket/src/io/print/main.rkt | 276 + racket/src/io/print/mlist.rkt | 31 + racket/src/io/print/mode.rkt | 18 + racket/src/io/print/named.rkt | 27 + racket/src/io/print/parameter.rkt | 61 + racket/src/io/print/recur-handler.rkt | 16 + racket/src/io/print/string.rkt | 58 + racket/src/io/print/symbol.rkt | 85 + racket/src/io/print/write-with-max.rkt | 69 + racket/src/io/run/main.rkt | 71 + racket/src/io/sandman/lock.rkt | 20 + racket/src/io/sandman/main.rkt | 182 + racket/src/io/security/main.rkt | 89 + racket/src/io/srcloc/main.rkt | 26 + racket/src/io/string/convert.rkt | 189 + racket/src/io/string/integer.rkt | 10 + racket/src/io/string/main.rkt | 6 + racket/src/io/string/number.rkt | 13 + racket/src/io/string/utf-16-decode.rkt | 39 + racket/src/io/string/utf-16-encode.rkt | 26 + racket/src/io/string/utf-8-decode.rkt | 188 + racket/src/io/string/utf-8-encode.rkt | 69 + racket/src/io/subprocess/main.rkt | 279 + racket/src/io/unsafe/main.rkt | 6 + racket/src/io/unsafe/port.rkt | 51 + racket/src/io/unsafe/schedule.rkt | 58 + racket/src/mac/osx_appl.rkt | 2 +- racket/src/mac/rename-app.rkt | 3 +- racket/src/mzcom/mzcom.cxx | 2 +- racket/src/racket/Makefile.in | 70 +- racket/src/racket/cmdline.inc | 449 +- racket/src/racket/configure.ac | 27 + racket/src/racket/dynsrc/Makefile.in | 10 +- racket/src/racket/gc2/Makefile.in | 108 +- racket/src/racket/gc2/check-sdep.rkt | 62 +- racket/src/racket/gc2/gc2_dump.h | 2 + racket/src/racket/gc2/newgc.c | 24 +- racket/src/racket/gc2/setup.rkt | 109 - racket/src/racket/gc2/xform.rkt | 120 - racket/src/racket/include/mzwin.def | 16 +- racket/src/racket/include/mzwin3m.def | 16 +- racket/src/racket/include/racket.exp | 16 +- racket/src/racket/include/racket3m.exp | 16 +- racket/src/racket/include/scheme.h | 68 +- racket/src/racket/include/schthread.h | 81 +- racket/src/racket/make-configure | 5 + racket/src/racket/mksystem.rkt | 4 +- racket/src/racket/src/Makefile.in | 38 +- racket/src/racket/src/bool.c | 103 +- racket/src/racket/src/builtin.c | 78 - racket/src/racket/src/char.c | 96 +- racket/src/racket/src/cify-check.rkt | 12 + racket/src/racket/src/cify-startup.rkt | 98 + racket/src/racket/src/compenv.c | 2278 +- racket/src/racket/src/compile-startup.rkt | 126 + racket/src/racket/src/compile.c | 5442 +- racket/src/racket/src/cstartup.inc | 1569 - racket/src/racket/src/dynext.c | 48 +- racket/src/racket/src/dynext.inc | 2 +- racket/src/racket/src/env.c | 2803 +- racket/src/racket/src/error.c | 452 +- racket/src/racket/src/eval.c | 2889 +- racket/src/racket/src/file.c | 386 +- racket/src/racket/src/fun.c | 682 +- racket/src/racket/src/future.c | 113 +- racket/src/racket/src/hash.c | 126 +- racket/src/racket/src/help-startup.rkt | 40 + racket/src/racket/src/jit.c | 126 +- racket/src/racket/src/jit.h | 13 +- racket/src/racket/src/jit_ts.c | 20 +- racket/src/racket/src/jitcommon.c | 319 +- racket/src/racket/src/jitinline.c | 454 +- racket/src/racket/src/jitprep.c | 190 +- racket/src/racket/src/jitstack.c | 33 +- racket/src/racket/src/jitstate.c | 3 +- racket/src/racket/src/letrec_check.c | 95 +- racket/src/racket/src/linklet.c | 1655 + racket/src/racket/src/list.c | 664 +- racket/src/racket/src/makeexn | 117 +- racket/src/racket/src/marshal.c | 1945 +- racket/src/racket/src/module.c | 13081 --- racket/src/racket/src/mzclpf_post.inc | 22 +- racket/src/racket/src/mzmark_compenv.inc | 54 +- racket/src/racket/src/mzmark_linklet.inc | 2 + racket/src/racket/src/mzmark_optimize.inc | 14 +- racket/src/racket/src/mzmark_portfun.inc | 50 - racket/src/racket/src/mzmark_print.inc | 14 - racket/src/racket/src/mzmark_read.inc | 64 +- racket/src/racket/src/mzmark_resolve.inc | 38 +- racket/src/racket/src/mzmark_syntax.inc | 138 - racket/src/racket/src/mzmark_type.inc | 829 +- racket/src/racket/src/mzmarksrc.c | 413 +- racket/src/racket/src/network.c | 90 +- racket/src/racket/src/numarith.c | 108 +- racket/src/racket/src/number.c | 389 +- racket/src/racket/src/numcomp.c | 175 +- racket/src/racket/src/numstr.c | 280 +- racket/src/racket/src/optimize.c | 2548 +- racket/src/racket/src/place.c | 65 +- racket/src/racket/src/port.c | 107 +- racket/src/racket/src/portfun.c | 1047 +- racket/src/racket/src/print.c | 837 +- racket/src/racket/src/read.c | 4885 +- racket/src/racket/src/read_vector.inc | 97 - racket/src/racket/src/regexp.c | 46 +- racket/src/racket/src/resolve.c | 2059 +- racket/src/racket/src/salloc.c | 191 +- racket/src/racket/src/schcpt.h | 34 +- racket/src/racket/src/schemef.h | 26 +- racket/src/racket/src/schemex.h | 25 +- racket/src/racket/src/schemex.inc | 16 +- racket/src/racket/src/schemexm.h | 16 +- racket/src/racket/src/schexn.h | 52 +- racket/src/racket/src/schexpobs.h | 204 - racket/src/racket/src/schminc.h | 17 +- racket/src/racket/src/schpriv.h | 1522 +- racket/src/racket/src/schvers.h | 6 +- racket/src/racket/src/sema.c | 48 +- racket/src/racket/src/sfs.c | 327 +- racket/src/racket/src/sort.c | 170 + racket/src/racket/src/sstoinc.rkt | 33 - racket/src/racket/src/sstoinct.rkt | 65 - racket/src/racket/src/startup-glue.inc | 789 + racket/src/racket/src/startup-select.rkt | 6 + racket/src/racket/src/startup.c | 74 + racket/src/racket/src/startup.inc | 77109 +++++++++++++++- racket/src/racket/src/startup.rktl | 1688 - racket/src/racket/src/string.c | 287 +- racket/src/racket/src/struct.c | 707 +- racket/src/racket/src/stypes.h | 512 +- racket/src/racket/src/symbol.c | 65 +- racket/src/racket/src/syntax.c | 8194 +- racket/src/racket/src/thread.c | 354 +- racket/src/racket/src/type.c | 160 +- racket/src/racket/src/unwind/libunwind.c | 2 +- racket/src/racket/src/validate.c | 552 +- racket/src/racket/src/vector.c | 250 +- racket/src/regexp/Makefile | 38 + racket/src/regexp/README.txt | 3 + racket/src/regexp/analyze/anchor.rkt | 29 + racket/src/regexp/analyze/convert.rkt | 179 + racket/src/regexp/analyze/must-string.rkt | 120 + racket/src/regexp/analyze/start-range.rkt | 59 + racket/src/regexp/analyze/validate.rkt | 118 + racket/src/regexp/common/error.rkt | 9 + racket/src/regexp/common/range.rkt | 123 + racket/src/regexp/demo.rkt | 178 + racket/src/regexp/main.rkt | 171 + racket/src/regexp/match/compile.rkt | 183 + racket/src/regexp/match/extract.rkt | 65 + racket/src/regexp/match/interp.rkt | 17 + racket/src/regexp/match/lazy-bytes.rkt | 124 + racket/src/regexp/match/main.rkt | 381 + racket/src/regexp/match/match.rkt | 585 + racket/src/regexp/match/port.rkt | 99 + racket/src/regexp/match/regexp.rkt | 80 + racket/src/regexp/match/search.rkt | 91 + racket/src/regexp/match/utf-8.rkt | 71 + racket/src/regexp/parse/ast.rkt | 156 + racket/src/regexp/parse/case.rkt | 27 + racket/src/regexp/parse/chyte-case.rkt | 17 + racket/src/regexp/parse/chyte.rkt | 37 + racket/src/regexp/parse/class.rkt | 122 + racket/src/regexp/parse/config.rkt | 43 + racket/src/regexp/parse/error.rkt | 7 + racket/src/regexp/parse/main.rkt | 391 + racket/src/regexp/parse/range.rkt | 132 + racket/src/regexp/parse/unicode.rkt | 75 + racket/src/regexp/replace/chyte.rkt | 42 + racket/src/regexp/replace/main.rkt | 140 + racket/src/rktio/Makefile.in | 22 +- racket/src/rktio/parse.rkt | 67 +- racket/src/rktio/rktio.def | 192 + racket/src/rktio/rktio.h | 3 +- racket/src/rktio/rktio.inc | 192 + racket/src/rktio/rktio.rktl | 1323 + racket/src/rktio/rktio_convert.c | 2 +- racket/src/rktio/rktio_fd.c | 33 +- racket/src/schemify/Makefile | 48 + racket/src/schemify/README.txt | 6 + racket/src/schemify/equal.rkt | 39 + racket/src/schemify/export.rkt | 4 + racket/src/schemify/find-definition.rkt | 94 + racket/src/schemify/find-known.rkt | 19 + racket/src/schemify/import.rkt | 105 + racket/src/schemify/infer-known.rkt | 115 + racket/src/schemify/inline.rkt | 279 + racket/src/schemify/interp-match.rkt | 41 + racket/src/schemify/interpret.rkt | 480 + racket/src/schemify/jitify.rkt | 771 + racket/src/schemify/known.rkt | 63 + racket/src/schemify/left-to-right.rkt | 127 + racket/src/schemify/let.rkt | 8 + racket/src/schemify/letrec.rkt | 26 + racket/src/schemify/lift.rkt | 701 + racket/src/schemify/literal.rkt | 22 + racket/src/schemify/main.rkt | 22 + racket/src/schemify/match.rkt | 142 + racket/src/schemify/mutated-state.rkt | 54 + racket/src/schemify/mutated.rkt | 191 + racket/src/schemify/optimize.rkt | 56 + racket/src/schemify/pthread-parameter.rkt | 16 + racket/src/schemify/quoted.rkt | 31 + racket/src/schemify/schemify-demo.rkt | 54 + racket/src/schemify/schemify.rkt | 602 + racket/src/schemify/serialize.rkt | 206 + racket/src/schemify/simple.rkt | 54 + racket/src/schemify/size.rkt | 76 + racket/src/schemify/struct-type-info.rkt | 120 + racket/src/schemify/wrap.rkt | 97 + racket/src/setup-go.rkt | 108 + racket/src/start/README.txt | 4 + racket/src/start/config.inc | 458 + racket/src/{racket => start}/delayed.inc | 2 + racket/src/start/gui_filter.inc | 117 + racket/src/{racket/dynsrc => start}/start.c | 0 .../src/{racket/dynsrc => start}/starter-sh | 0 racket/src/{racket/dynsrc => start}/ustart.c | 0 racket/src/thread/Makefile | 33 + racket/src/thread/README.txt | 8 + racket/src/thread/alarm.rkt | 22 + racket/src/thread/api.rkt | 118 + racket/src/thread/atomic.rkt | 86 + racket/src/thread/bootstrap-main.rkt | 6 + racket/src/thread/bootstrap.rkt | 190 + racket/src/thread/channel.rkt | 214 + racket/src/thread/check.rkt | 4 + racket/src/thread/continuation-mark.rkt | 21 + racket/src/thread/custodian.rkt | 206 + racket/src/thread/debug.rkt | 14 + racket/src/thread/demo.rkt | 506 + racket/src/thread/engine.rkt | 75 + racket/src/thread/evt.rkt | 190 + racket/src/thread/exit.rkt | 29 + racket/src/thread/fsemaphore.rkt | 32 + racket/src/thread/future.rkt | 417 + racket/src/thread/impersonator.rkt | 107 + racket/src/thread/instance.rkt | 51 + racket/src/thread/internal-error.rkt | 7 + racket/src/thread/lock.rkt | 52 + racket/src/thread/main.rkt | 188 + racket/src/thread/nested-thread.rkt | 103 + racket/src/thread/os-thread.rkt | 56 + racket/src/thread/parameter.rkt | 6 + racket/src/thread/plumber.rkt | 50 + racket/src/thread/sandman-struct.rkt | 39 + racket/src/thread/sandman.rkt | 218 + racket/src/thread/schedule-info.rkt | 35 + racket/src/thread/schedule.rkt | 212 + racket/src/thread/semaphore.rkt | 173 + racket/src/thread/stack-size.rkt | 12 + racket/src/thread/stats.rkt | 36 + racket/src/thread/sync.rkt | 639 + racket/src/thread/system-idle-evt.rkt | 32 + racket/src/thread/thread-group.rkt | 128 + racket/src/thread/thread.rkt | 979 + racket/src/thread/time.rkt | 20 + racket/src/thread/tree.rkt | 249 + racket/src/thread/unsafe.rkt | 35 + racket/src/thread/waiter.rkt | 42 + racket/src/thread/will-executor.rkt | 60 + racket/src/worksp/.gitignore | 10 + racket/src/worksp/build.bat | 16 +- racket/src/worksp/cs/Makefile | 24 + racket/src/worksp/cs/prep.rkt | 54 + racket/src/worksp/csbuild.rkt | 147 + racket/src/worksp/cstartup.c | 56 + racket/src/worksp/gc2/make.rkt | 22 +- racket/src/worksp/libracket/libracket.vcproj | 30 +- racket/src/worksp/libracket/libracket.vcxproj | 7 +- racket/src/worksp/mrstart/mrstart.vcproj | 2 +- racket/src/worksp/mrstart/mrstart.vcxproj | 2 +- racket/src/worksp/mzcom/xform.rkt | 12 +- racket/src/worksp/mzstart/mzstart.vcproj | 2 +- racket/src/worksp/mzstart/mzstart.vcxproj | 2 +- racket/src/worksp/rktio.bat | 23 + 939 files changed, 204119 insertions(+), 63193 deletions(-) delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/alpha.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/bundle.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/find.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/gc.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/import.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/info.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/module-path.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/module.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/mpi.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/name.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/nodep.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/remap.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/run.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt delete mode 100644 pkgs/compiler-lib/compiler/demodularizer/util.rkt create mode 100644 pkgs/compiler-lib/compiler/demodularizer/write.rkt create mode 100644 pkgs/compiler-lib/compiler/private/deserialize.rkt create mode 100644 pkgs/racket-doc/scribblings/foreign/os-thread.scrbl create mode 100644 pkgs/racket-doc/scribblings/reference/linklet.scrbl create mode 100644 pkgs/racket-test-core/tests/racket/expobs-regression.rktd create mode 100644 pkgs/racket-test-core/tests/racket/expobs.rktl create mode 100644 racket/collects/compiler/depend.rkt create mode 100644 racket/collects/compiler/private/cm-minimal.rkt create mode 100644 racket/collects/ffi/unsafe/os-thread.rkt create mode 100644 racket/collects/racket/linklet.rkt delete mode 100644 racket/collects/racket/private/load.rkt create mode 100644 racket/collects/syntax/private/modcode-noctc.rkt create mode 100644 racket/collects/syntax/private/modresolve-noctc.rkt create mode 100644 racket/src/cify/README.txt create mode 100644 racket/src/cify/arg.rkt create mode 100644 racket/src/cify/debug.rkt create mode 100644 racket/src/cify/free-var.rkt create mode 100644 racket/src/cify/function.rkt create mode 100644 racket/src/cify/generate.rkt create mode 100644 racket/src/cify/id.rkt create mode 100644 racket/src/cify/inline.rkt create mode 100644 racket/src/cify/lambda.rkt create mode 100644 racket/src/cify/main.rkt create mode 100644 racket/src/cify/match.rkt create mode 100644 racket/src/cify/out.rkt create mode 100644 racket/src/cify/prim-name.rkt create mode 100644 racket/src/cify/primitive.rkt create mode 100644 racket/src/cify/prune.rkt create mode 100644 racket/src/cify/ref.rkt create mode 100644 racket/src/cify/return.rkt create mode 100644 racket/src/cify/runstack.rkt create mode 100644 racket/src/cify/simple.rkt create mode 100644 racket/src/cify/sort.rkt create mode 100644 racket/src/cify/state.rkt create mode 100644 racket/src/cify/struct.rkt create mode 100644 racket/src/cify/top-name.rkt create mode 100644 racket/src/cify/union-find.rkt create mode 100644 racket/src/cify/union.rkt create mode 100644 racket/src/cify/unique.rkt create mode 100644 racket/src/cify/vehicle.rkt create mode 100644 racket/src/common/check.rkt create mode 100644 racket/src/common/queue.rkt create mode 100644 racket/src/cs/.gitignore create mode 100644 racket/src/cs/Makefile create mode 100644 racket/src/cs/README.txt create mode 100644 racket/src/cs/absify.rkt create mode 100644 racket/src/cs/c/Makefile.in create mode 100644 racket/src/cs/c/README.txt create mode 100644 racket/src/cs/c/boot.c create mode 100644 racket/src/cs/c/boot.h create mode 100755 racket/src/cs/c/configure create mode 100644 racket/src/cs/c/configure.ac create mode 100644 racket/src/cs/c/cs_config.h.in create mode 100644 racket/src/cs/c/embed-boot.rkt create mode 100644 racket/src/cs/c/grmain.c create mode 100644 racket/src/cs/c/main.c create mode 100644 racket/src/cs/chezpart.sls create mode 100644 racket/src/cs/compile-file.ss create mode 100644 racket/src/cs/convert.rkt create mode 100644 racket/src/cs/demo/chaperone.ss create mode 100644 racket/src/cs/demo/control.ss create mode 100644 racket/src/cs/demo/expander.ss create mode 100644 racket/src/cs/demo/foreign.ss create mode 100644 racket/src/cs/demo/hash.ss create mode 100644 racket/src/cs/demo/io-impl.rkt create mode 100644 racket/src/cs/demo/io.rkt create mode 100644 racket/src/cs/demo/io.ss create mode 100644 racket/src/cs/demo/linklet.rkt create mode 100644 racket/src/cs/demo/linklet.ss create mode 100644 racket/src/cs/demo/regexp.rkt create mode 100644 racket/src/cs/demo/regexp.rktl create mode 100644 racket/src/cs/demo/regexp.ss create mode 100644 racket/src/cs/demo/struct.ss create mode 100644 racket/src/cs/demo/thread.ss create mode 100644 racket/src/cs/demo/will.ss create mode 100644 racket/src/cs/expander.rkt create mode 100644 racket/src/cs/expander.sls create mode 100644 racket/src/cs/include.ss create mode 100644 racket/src/cs/io.sls create mode 100644 racket/src/cs/linklet.sls create mode 100644 racket/src/cs/main.sps create mode 100644 racket/src/cs/primitive/extfl.ss create mode 100644 racket/src/cs/primitive/flfxnum.ss create mode 100644 racket/src/cs/primitive/foreign.ss create mode 100644 racket/src/cs/primitive/futures.ss create mode 100644 racket/src/cs/primitive/internal.ss create mode 100644 racket/src/cs/primitive/kernel.ss create mode 100644 racket/src/cs/primitive/linklet.ss create mode 100644 racket/src/cs/primitive/network.ss create mode 100644 racket/src/cs/primitive/paramz.ss create mode 100644 racket/src/cs/primitive/place.ss create mode 100644 racket/src/cs/primitive/unsafe.ss create mode 100644 racket/src/cs/regexp.sls create mode 100644 racket/src/cs/rumble.sls create mode 100644 racket/src/cs/rumble/arity.ss create mode 100644 racket/src/cs/rumble/begin0.ss create mode 100644 racket/src/cs/rumble/boolean.ss create mode 100644 racket/src/cs/rumble/box.ss create mode 100644 racket/src/cs/rumble/bytes.ss create mode 100644 racket/src/cs/rumble/char.ss create mode 100644 racket/src/cs/rumble/check.ss create mode 100644 racket/src/cs/rumble/constant.ss create mode 100644 racket/src/cs/rumble/control.ss create mode 100644 racket/src/cs/rumble/correlated.ss create mode 100644 racket/src/cs/rumble/datum.ss create mode 100644 racket/src/cs/rumble/define.ss create mode 100644 racket/src/cs/rumble/engine.ss create mode 100644 racket/src/cs/rumble/ephemeron.ss create mode 100644 racket/src/cs/rumble/equal.ss create mode 100644 racket/src/cs/rumble/error.ss create mode 100644 racket/src/cs/rumble/extfl.ss create mode 100644 racket/src/cs/rumble/flvector.ss create mode 100644 racket/src/cs/rumble/foreign.ss create mode 100644 racket/src/cs/rumble/fsemaphore.ss create mode 100644 racket/src/cs/rumble/future.ss create mode 100644 racket/src/cs/rumble/graph.ss create mode 100644 racket/src/cs/rumble/hamt.ss create mode 100644 racket/src/cs/rumble/hash-code.ss create mode 100644 racket/src/cs/rumble/hash.ss create mode 100644 racket/src/cs/rumble/immutable.ss create mode 100644 racket/src/cs/rumble/impersonator.ss create mode 100644 racket/src/cs/rumble/inline.ss create mode 100644 racket/src/cs/rumble/interrupt.ss create mode 100644 racket/src/cs/rumble/intmap.ss create mode 100644 racket/src/cs/rumble/keyword.ss create mode 100644 racket/src/cs/rumble/list.ss create mode 100644 racket/src/cs/rumble/lock.ss create mode 100644 racket/src/cs/rumble/memory.ss create mode 100644 racket/src/cs/rumble/mpair.ss create mode 100644 racket/src/cs/rumble/number.ss create mode 100644 racket/src/cs/rumble/object-name.ss create mode 100644 racket/src/cs/rumble/parameter.ss create mode 100644 racket/src/cs/rumble/place.ss create mode 100644 racket/src/cs/rumble/prefab.ss create mode 100644 racket/src/cs/rumble/procedure.ss create mode 100644 racket/src/cs/rumble/pthread.ss create mode 100644 racket/src/cs/rumble/random.ss create mode 100644 racket/src/cs/rumble/srcloc.ss create mode 100644 racket/src/cs/rumble/string.ss create mode 100644 racket/src/cs/rumble/struct.ss create mode 100644 racket/src/cs/rumble/symbol.ss create mode 100644 racket/src/cs/rumble/syntax-rule.ss create mode 100644 racket/src/cs/rumble/system.ss create mode 100644 racket/src/cs/rumble/thread-cell.ss create mode 100644 racket/src/cs/rumble/time.ss create mode 100644 racket/src/cs/rumble/unsafe.ss create mode 100644 racket/src/cs/rumble/variable.ss create mode 100644 racket/src/cs/rumble/vector.ss create mode 100644 racket/src/cs/rumble/version.ss create mode 100644 racket/src/cs/rumble/virtual-register.ss create mode 100644 racket/src/cs/rumble/will-executor.ss create mode 100644 racket/src/cs/schemify.sls create mode 100644 racket/src/cs/strip.ss create mode 100644 racket/src/cs/thread.sls create mode 100644 racket/src/expander/Makefile create mode 100644 racket/src/expander/README.txt create mode 100644 racket/src/expander/boot/core-primitive.rkt create mode 100644 racket/src/expander/boot/expobs-primitive.rkt create mode 100644 racket/src/expander/boot/handler.rkt create mode 100644 racket/src/expander/boot/kernel.rkt create mode 100644 racket/src/expander/boot/linklet-primitive.rkt create mode 100644 racket/src/expander/boot/load-handler.rkt create mode 100644 racket/src/expander/boot/main-primitive.rkt create mode 100644 racket/src/expander/boot/place-primitive.rkt create mode 100644 racket/src/expander/boot/read-primitive.rkt create mode 100644 racket/src/expander/boot/runtime-primitive.rkt create mode 100644 racket/src/expander/boot/utils-primitive.rkt create mode 100644 racket/src/expander/bootstrap-demo.rkt create mode 100644 racket/src/expander/bootstrap-run.rkt create mode 100644 racket/src/expander/common/contract.rkt create mode 100644 racket/src/expander/common/inline.rkt create mode 100644 racket/src/expander/common/intern.rkt create mode 100644 racket/src/expander/common/list-ish.rkt create mode 100644 racket/src/expander/common/make-match.rkt create mode 100644 racket/src/expander/common/memo.rkt create mode 100644 racket/src/expander/common/module-path-intern.rkt create mode 100644 racket/src/expander/common/module-path.rkt create mode 100644 racket/src/expander/common/parse-module-path.rkt create mode 100644 racket/src/expander/common/performance.rkt create mode 100644 racket/src/expander/common/phase.rkt create mode 100644 racket/src/expander/common/prefab.rkt create mode 100644 racket/src/expander/common/reflect-hash.rkt create mode 100644 racket/src/expander/common/set.rkt create mode 100644 racket/src/expander/common/small-hash.rkt create mode 100644 racket/src/expander/common/struct-star.rkt create mode 100644 racket/src/expander/compile/built-in-symbol.rkt create mode 100644 racket/src/expander/compile/compiled-in-memory.rkt create mode 100644 racket/src/expander/compile/context.rkt create mode 100644 racket/src/expander/compile/correlate.rkt create mode 100644 racket/src/expander/compile/eager-instance.rkt create mode 100644 racket/src/expander/compile/expr.rkt create mode 100644 racket/src/expander/compile/extra-inspector.rkt create mode 100644 racket/src/expander/compile/form.rkt create mode 100644 racket/src/expander/compile/header.rkt create mode 100644 racket/src/expander/compile/instance.rkt create mode 100644 racket/src/expander/compile/known.rkt create mode 100644 racket/src/expander/compile/main.rkt create mode 100644 racket/src/expander/compile/module-use.rkt create mode 100644 racket/src/expander/compile/module.rkt create mode 100644 racket/src/expander/compile/multi-top-data.rkt create mode 100644 racket/src/expander/compile/multi-top.rkt create mode 100644 racket/src/expander/compile/namespace-scope.rkt create mode 100644 racket/src/expander/compile/recompile.rkt create mode 100644 racket/src/expander/compile/reserved-symbol.rkt create mode 100644 racket/src/expander/compile/self-quoting.rkt create mode 100644 racket/src/expander/compile/serialize-property.rkt create mode 100644 racket/src/expander/compile/serialize-state.rkt create mode 100644 racket/src/expander/compile/serialize.rkt create mode 100644 racket/src/expander/compile/side-effect.rkt create mode 100644 racket/src/expander/compile/top.rkt create mode 100644 racket/src/expander/compile/vector-ref.rkt create mode 100644 racket/src/expander/demo.rkt create mode 100644 racket/src/expander/eval/api.rkt create mode 100644 racket/src/expander/eval/collection.rkt create mode 100644 racket/src/expander/eval/direct.rkt create mode 100644 racket/src/expander/eval/dynamic-require.rkt create mode 100644 racket/src/expander/eval/load.rkt create mode 100644 racket/src/expander/eval/main.rkt create mode 100644 racket/src/expander/eval/module-cache.rkt create mode 100644 racket/src/expander/eval/module-read.rkt create mode 100644 racket/src/expander/eval/module.rkt create mode 100644 racket/src/expander/eval/multi-top.rkt create mode 100644 racket/src/expander/eval/parameter.rkt create mode 100644 racket/src/expander/eval/protect.rkt create mode 100644 racket/src/expander/eval/reflect-name.rkt create mode 100644 racket/src/expander/eval/reflect.rkt create mode 100644 racket/src/expander/eval/root-context.rkt create mode 100644 racket/src/expander/eval/top-level-instance.rkt create mode 100644 racket/src/expander/eval/top.rkt create mode 100644 racket/src/expander/expand/allowed-context.rkt create mode 100644 racket/src/expander/expand/already-expanded.rkt create mode 100644 racket/src/expander/expand/append.rkt create mode 100644 racket/src/expander/expand/bind-top.rkt create mode 100644 racket/src/expander/expand/binding-for-transformer.rkt create mode 100644 racket/src/expander/expand/binding-to-module.rkt create mode 100644 racket/src/expander/expand/body.rkt create mode 100644 racket/src/expander/expand/context.rkt create mode 100644 racket/src/expander/expand/cross-phase.rkt create mode 100644 racket/src/expander/expand/def-id.rkt create mode 100644 racket/src/expander/expand/definition-context.rkt create mode 100644 racket/src/expander/expand/dup-check.rkt create mode 100644 racket/src/expander/expand/env.rkt create mode 100644 racket/src/expander/expand/expanded+parsed.rkt create mode 100644 racket/src/expander/expand/expr.rkt create mode 100644 racket/src/expander/expand/free-id-set.rkt create mode 100644 racket/src/expander/expand/liberal-def-ctx.rkt create mode 100644 racket/src/expander/expand/lift-context.rkt create mode 100644 racket/src/expander/expand/lift-key.rkt create mode 100644 racket/src/expander/expand/local-expand.rkt create mode 100644 racket/src/expander/expand/log.rkt create mode 100644 racket/src/expander/expand/main.rkt create mode 100644 racket/src/expander/expand/missing-module.rkt create mode 100644 racket/src/expander/expand/module-path.rkt create mode 100644 racket/src/expander/expand/module.rkt create mode 100644 racket/src/expander/expand/parsed.rkt create mode 100644 racket/src/expander/expand/prepare.rkt create mode 100644 racket/src/expander/expand/protect.rkt create mode 100644 racket/src/expander/expand/provide.rkt create mode 100644 racket/src/expander/expand/rebuild.rkt create mode 100644 racket/src/expander/expand/reference-record.rkt create mode 100644 racket/src/expander/expand/rename-trans.rkt create mode 100644 racket/src/expander/expand/require+provide.rkt create mode 100644 racket/src/expander/expand/require.rkt create mode 100644 racket/src/expander/expand/root-expand-context.rkt create mode 100644 racket/src/expander/expand/save-and-restore.rkt create mode 100644 racket/src/expander/expand/set-bang-trans.rkt create mode 100644 racket/src/expander/expand/stop-ids.rkt create mode 100644 racket/src/expander/expand/syntax-id-error.rkt create mode 100644 racket/src/expander/expand/syntax-implicit-error.rkt create mode 100644 racket/src/expander/expand/syntax-local.rkt create mode 100644 racket/src/expander/expand/top.rkt create mode 100644 racket/src/expander/expand/use-site.rkt create mode 100644 racket/src/expander/extract/c-encode.rkt create mode 100644 racket/src/expander/extract/check-and-report.rkt create mode 100644 racket/src/expander/extract/decompile.rkt create mode 100644 racket/src/expander/extract/defn-known.rkt create mode 100644 racket/src/expander/extract/defn.rkt create mode 100644 racket/src/expander/extract/export.rkt create mode 100644 racket/src/expander/extract/flatten.rkt create mode 100644 racket/src/expander/extract/gc-defn.rkt create mode 100644 racket/src/expander/extract/get-linklet.rkt create mode 100644 racket/src/expander/extract/known-primitive.rkt create mode 100644 racket/src/expander/extract/link.rkt create mode 100644 racket/src/expander/extract/linklet-info.rkt create mode 100644 racket/src/expander/extract/linklet.rkt create mode 100644 racket/src/expander/extract/main.rkt create mode 100644 racket/src/expander/extract/module.rkt create mode 100644 racket/src/expander/extract/needed.rkt create mode 100644 racket/src/expander/extract/primitive-table.rkt create mode 100644 racket/src/expander/extract/prune-name.rkt create mode 100644 racket/src/expander/extract/save-and-report.rkt create mode 100644 racket/src/expander/extract/simplify-defn.rkt create mode 100644 racket/src/expander/extract/symbol.rkt create mode 100644 racket/src/expander/extract/underscore.rkt create mode 100644 racket/src/expander/extract/variable.rkt create mode 100644 racket/src/expander/host/correlate-syntax.rkt create mode 100644 racket/src/expander/host/correlate.rkt create mode 100644 racket/src/expander/host/linklet.rkt create mode 100644 racket/src/expander/host/reader-syntax-to-syntax.rkt create mode 100644 racket/src/expander/host/reader-syntax.rkt create mode 100644 racket/src/expander/host/string-to-number.rkt create mode 100644 racket/src/expander/host/syntax-to-reader-syntax.rkt create mode 100644 racket/src/expander/info.rkt create mode 100644 racket/src/expander/main.rkt create mode 100644 racket/src/expander/namespace/api-module.rkt create mode 100644 racket/src/expander/namespace/api.rkt create mode 100644 racket/src/expander/namespace/attach.rkt create mode 100644 racket/src/expander/namespace/core.rkt create mode 100644 racket/src/expander/namespace/inspector.rkt create mode 100644 racket/src/expander/namespace/module.rkt create mode 100644 racket/src/expander/namespace/namespace.rkt create mode 100644 racket/src/expander/namespace/primitive-module.rkt create mode 100644 racket/src/expander/namespace/provide-for-api.rkt create mode 100644 racket/src/expander/namespace/provided.rkt create mode 100644 racket/src/expander/namespace/registry.rkt create mode 100644 racket/src/expander/namespace/variable-reference.rkt create mode 100644 racket/src/expander/read/accum-string.rkt create mode 100644 racket/src/expander/read/api.rkt create mode 100644 racket/src/expander/read/box.rkt create mode 100644 racket/src/expander/read/char.rkt create mode 100644 racket/src/expander/read/closer.rkt create mode 100644 racket/src/expander/read/coerce-key.rkt create mode 100644 racket/src/expander/read/coerce.rkt create mode 100644 racket/src/expander/read/config.rkt create mode 100644 racket/src/expander/read/constant.rkt create mode 100644 racket/src/expander/read/consume.rkt create mode 100644 racket/src/expander/read/delimiter.rkt create mode 100644 racket/src/expander/read/demo.rkt create mode 100644 racket/src/expander/read/digit.rkt create mode 100644 racket/src/expander/read/error.rkt create mode 100644 racket/src/expander/read/extension.rkt create mode 100644 racket/src/expander/read/fixnum-flonum.rkt create mode 100644 racket/src/expander/read/graph.rkt create mode 100644 racket/src/expander/read/hash.rkt create mode 100644 racket/src/expander/read/indentation.rkt create mode 100644 racket/src/expander/read/language.rkt create mode 100644 racket/src/expander/read/location.rkt create mode 100644 racket/src/expander/read/main.rkt create mode 100644 racket/src/expander/read/number.rkt create mode 100644 racket/src/expander/read/parameter.rkt create mode 100644 racket/src/expander/read/primitive-parameter.rkt create mode 100644 racket/src/expander/read/quote.rkt create mode 100644 racket/src/expander/read/readtable-parameter.rkt create mode 100644 racket/src/expander/read/readtable.rkt create mode 100644 racket/src/expander/read/regexp.rkt create mode 100644 racket/src/expander/read/sequence.rkt create mode 100644 racket/src/expander/read/special-comment.rkt create mode 100644 racket/src/expander/read/special.rkt create mode 100644 racket/src/expander/read/string.rkt create mode 100644 racket/src/expander/read/struct.rkt create mode 100644 racket/src/expander/read/symbol-or-number.rkt create mode 100644 racket/src/expander/read/vector.rkt create mode 100644 racket/src/expander/read/whitespace.rkt create mode 100644 racket/src/expander/read/wrap.rkt create mode 100644 racket/src/expander/run.rkt create mode 100644 racket/src/expander/run/bootstrap.rkt create mode 100644 racket/src/expander/run/cache.rkt create mode 100644 racket/src/expander/run/correlated-to-host-syntax.rkt create mode 100644 racket/src/expander/run/host-syntax-to-syntax.rkt create mode 100644 racket/src/expander/run/linklet-operation.rkt create mode 100644 racket/src/expander/run/linklet.rkt create mode 100644 racket/src/expander/run/status.rkt create mode 100644 racket/src/expander/run/submodule.rkt create mode 100644 racket/src/expander/syntax/api-taint.rkt create mode 100644 racket/src/expander/syntax/api.rkt create mode 100644 racket/src/expander/syntax/binding-table.rkt create mode 100644 racket/src/expander/syntax/binding.rkt create mode 100644 racket/src/expander/syntax/bulk-binding.rkt create mode 100644 racket/src/expander/syntax/cache.rkt create mode 100644 racket/src/expander/syntax/datum-map.rkt create mode 100644 racket/src/expander/syntax/debug.rkt create mode 100644 racket/src/expander/syntax/error.rkt create mode 100644 racket/src/expander/syntax/fallback.rkt create mode 100644 racket/src/expander/syntax/full-binding.rkt create mode 100644 racket/src/expander/syntax/local-binding.rkt create mode 100644 racket/src/expander/syntax/mapped-name.rkt create mode 100644 racket/src/expander/syntax/match.rkt create mode 100644 racket/src/expander/syntax/module-binding.rkt create mode 100644 racket/src/expander/syntax/original.rkt create mode 100644 racket/src/expander/syntax/preserved.rkt create mode 100644 racket/src/expander/syntax/property.rkt create mode 100644 racket/src/expander/syntax/read-syntax.rkt create mode 100644 racket/src/expander/syntax/scope.rkt create mode 100644 racket/src/expander/syntax/srcloc.rkt create mode 100644 racket/src/expander/syntax/syntax.rkt create mode 100644 racket/src/expander/syntax/taint-dispatch.rkt create mode 100644 racket/src/expander/syntax/taint.rkt create mode 100644 racket/src/expander/syntax/tamper.rkt create mode 100644 racket/src/expander/syntax/to-list.rkt create mode 100644 racket/src/expander/syntax/track.rkt create mode 100644 racket/src/io/Makefile create mode 100644 racket/src/io/README.txt create mode 100644 racket/src/io/bootstrap-main.rkt create mode 100644 racket/src/io/bootstrap-thread-main.rkt create mode 100644 racket/src/io/common/bytes-no-nuls.rkt create mode 100644 racket/src/io/common/check.rkt create mode 100644 racket/src/io/common/internal-error.rkt create mode 100644 racket/src/io/common/resource.rkt create mode 100644 racket/src/io/common/set-two.rkt create mode 100644 racket/src/io/converter/encoding.rkt create mode 100644 racket/src/io/converter/main.rkt create mode 100644 racket/src/io/converter/utf-8.rkt create mode 100644 racket/src/io/demo-thread.rkt create mode 100644 racket/src/io/demo.rkt create mode 100644 racket/src/io/demo2.rkt create mode 100644 racket/src/io/envvar/main.rkt create mode 100644 racket/src/io/envvar/string.rkt create mode 100644 racket/src/io/error/main.rkt create mode 100644 racket/src/io/file/error.rkt create mode 100644 racket/src/io/file/host.rkt create mode 100644 racket/src/io/file/identity.rkt create mode 100644 racket/src/io/file/main.rkt create mode 100644 racket/src/io/file/parameter.rkt create mode 100644 racket/src/io/filesystem-change-evt/main.rkt create mode 100644 racket/src/io/foreign/main.rkt create mode 100644 racket/src/io/format/main.rkt create mode 100644 racket/src/io/format/printf.rkt create mode 100644 racket/src/io/host/bootstrap-rktio.rkt create mode 100644 racket/src/io/host/bootstrap-thread.rkt create mode 100644 racket/src/io/host/bootstrap.rkt create mode 100644 racket/src/io/host/error.rkt create mode 100644 racket/src/io/host/rktio.rkt create mode 100644 racket/src/io/host/thread.rkt create mode 100644 racket/src/io/locale/collate.rkt create mode 100644 racket/src/io/locale/main.rkt create mode 100644 racket/src/io/locale/nul-char.rkt create mode 100644 racket/src/io/locale/parameter.rkt create mode 100644 racket/src/io/locale/recase.rkt create mode 100644 racket/src/io/locale/string.rkt create mode 100644 racket/src/io/locale/ucs-4.rkt create mode 100644 racket/src/io/logger/demo.rkt create mode 100644 racket/src/io/logger/level.rkt create mode 100644 racket/src/io/logger/logger.rkt create mode 100644 racket/src/io/logger/main.rkt create mode 100644 racket/src/io/logger/receiver.rkt create mode 100644 racket/src/io/logger/wanted.rkt create mode 100644 racket/src/io/main.rkt create mode 100644 racket/src/io/network/address.rkt create mode 100644 racket/src/io/network/check.rkt create mode 100644 racket/src/io/network/error.rkt create mode 100644 racket/src/io/network/evt.rkt create mode 100644 racket/src/io/network/main.rkt create mode 100644 racket/src/io/network/port-number.rkt create mode 100644 racket/src/io/network/tcp-accept.rkt create mode 100644 racket/src/io/network/tcp-address.rkt create mode 100644 racket/src/io/network/tcp-connect.rkt create mode 100644 racket/src/io/network/tcp-listen.rkt create mode 100644 racket/src/io/network/tcp-port.rkt create mode 100644 racket/src/io/network/tcp.rkt create mode 100644 racket/src/io/network/udp-multicast.rkt create mode 100644 racket/src/io/network/udp-receive.rkt create mode 100644 racket/src/io/network/udp-send.rkt create mode 100644 racket/src/io/network/udp-socket.rkt create mode 100644 racket/src/io/network/udp.rkt create mode 100644 racket/src/io/path/api.rkt create mode 100644 racket/src/io/path/build.rkt create mode 100644 racket/src/io/path/check-path.rkt create mode 100644 racket/src/io/path/check.rkt create mode 100644 racket/src/io/path/cleanse.rkt create mode 100644 racket/src/io/path/complete.rkt create mode 100644 racket/src/io/path/directory-path.rkt create mode 100644 racket/src/io/path/ffi.rkt create mode 100644 racket/src/io/path/main.rkt create mode 100644 racket/src/io/path/parameter.rkt create mode 100644 racket/src/io/path/path.rkt create mode 100644 racket/src/io/path/protect.rkt create mode 100644 racket/src/io/path/relativity.rkt create mode 100644 racket/src/io/path/sep.rkt create mode 100644 racket/src/io/path/simplify.rkt create mode 100644 racket/src/io/path/split.rkt create mode 100644 racket/src/io/path/string.rkt create mode 100644 racket/src/io/path/system.rkt create mode 100644 racket/src/io/path/windows.rkt create mode 100644 racket/src/io/port/buffer-mode.rkt create mode 100644 racket/src/io/port/bytes-input.rkt create mode 100644 racket/src/io/port/bytes-output.rkt create mode 100644 racket/src/io/port/bytes-port.rkt create mode 100644 racket/src/io/port/check.rkt create mode 100644 racket/src/io/port/close.rkt create mode 100644 racket/src/io/port/commit-manager.rkt create mode 100644 racket/src/io/port/count.rkt create mode 100644 racket/src/io/port/custom-input-port.rkt create mode 100644 racket/src/io/port/custom-output-port.rkt create mode 100644 racket/src/io/port/custom-port.rkt create mode 100644 racket/src/io/port/evt.rkt create mode 100644 racket/src/io/port/fd-port.rkt create mode 100644 racket/src/io/port/file-identity.rkt create mode 100644 racket/src/io/port/file-lock.rkt create mode 100644 racket/src/io/port/file-port.rkt create mode 100644 racket/src/io/port/file-position.rkt create mode 100644 racket/src/io/port/file-stream.rkt create mode 100644 racket/src/io/port/file-truncate.rkt create mode 100644 racket/src/io/port/flush-output.rkt create mode 100644 racket/src/io/port/handler.rkt create mode 100644 racket/src/io/port/input-port.rkt create mode 100644 racket/src/io/port/line-input.rkt create mode 100644 racket/src/io/port/main.rkt create mode 100644 racket/src/io/port/nowhere.rkt create mode 100644 racket/src/io/port/output-port.rkt create mode 100644 racket/src/io/port/parameter.rkt create mode 100644 racket/src/io/port/peek-via-read-port.rkt create mode 100644 racket/src/io/port/pipe.rkt create mode 100644 racket/src/io/port/port.rkt create mode 100644 racket/src/io/port/prepare-change.rkt create mode 100644 racket/src/io/port/progress-evt.rkt create mode 100644 racket/src/io/port/read-and-peek.rkt create mode 100644 racket/src/io/port/ready.rkt create mode 100644 racket/src/io/port/special-input.rkt create mode 100644 racket/src/io/port/special-output.rkt create mode 100644 racket/src/io/port/string-input.rkt create mode 100644 racket/src/io/port/string-output.rkt create mode 100644 racket/src/io/port/string-port.rkt create mode 100644 racket/src/io/port/write.rkt create mode 100644 racket/src/io/print/bytes.rkt create mode 100644 racket/src/io/print/char.rkt create mode 100644 racket/src/io/print/config.rkt create mode 100644 racket/src/io/print/custom-write.rkt create mode 100644 racket/src/io/print/graph.rkt create mode 100644 racket/src/io/print/hash.rkt create mode 100644 racket/src/io/print/list.rkt create mode 100644 racket/src/io/print/main.rkt create mode 100644 racket/src/io/print/mlist.rkt create mode 100644 racket/src/io/print/mode.rkt create mode 100644 racket/src/io/print/named.rkt create mode 100644 racket/src/io/print/parameter.rkt create mode 100644 racket/src/io/print/recur-handler.rkt create mode 100644 racket/src/io/print/string.rkt create mode 100644 racket/src/io/print/symbol.rkt create mode 100644 racket/src/io/print/write-with-max.rkt create mode 100644 racket/src/io/run/main.rkt create mode 100644 racket/src/io/sandman/lock.rkt create mode 100644 racket/src/io/sandman/main.rkt create mode 100644 racket/src/io/security/main.rkt create mode 100644 racket/src/io/srcloc/main.rkt create mode 100644 racket/src/io/string/convert.rkt create mode 100644 racket/src/io/string/integer.rkt create mode 100644 racket/src/io/string/main.rkt create mode 100644 racket/src/io/string/number.rkt create mode 100644 racket/src/io/string/utf-16-decode.rkt create mode 100644 racket/src/io/string/utf-16-encode.rkt create mode 100644 racket/src/io/string/utf-8-decode.rkt create mode 100644 racket/src/io/string/utf-8-encode.rkt create mode 100644 racket/src/io/subprocess/main.rkt create mode 100644 racket/src/io/unsafe/main.rkt create mode 100644 racket/src/io/unsafe/port.rkt create mode 100644 racket/src/io/unsafe/schedule.rkt delete mode 100644 racket/src/racket/gc2/setup.rkt delete mode 100644 racket/src/racket/gc2/xform.rkt delete mode 100644 racket/src/racket/src/builtin.c create mode 100644 racket/src/racket/src/cify-check.rkt create mode 100644 racket/src/racket/src/cify-startup.rkt create mode 100644 racket/src/racket/src/compile-startup.rkt delete mode 100644 racket/src/racket/src/cstartup.inc create mode 100644 racket/src/racket/src/help-startup.rkt create mode 100644 racket/src/racket/src/linklet.c delete mode 100644 racket/src/racket/src/module.c create mode 100644 racket/src/racket/src/mzmark_linklet.inc delete mode 100644 racket/src/racket/src/read_vector.inc delete mode 100644 racket/src/racket/src/schexpobs.h create mode 100644 racket/src/racket/src/sort.c delete mode 100644 racket/src/racket/src/sstoinc.rkt delete mode 100644 racket/src/racket/src/sstoinct.rkt create mode 100644 racket/src/racket/src/startup-glue.inc create mode 100644 racket/src/racket/src/startup-select.rkt create mode 100644 racket/src/racket/src/startup.c delete mode 100644 racket/src/racket/src/startup.rktl create mode 100644 racket/src/regexp/Makefile create mode 100644 racket/src/regexp/README.txt create mode 100644 racket/src/regexp/analyze/anchor.rkt create mode 100644 racket/src/regexp/analyze/convert.rkt create mode 100644 racket/src/regexp/analyze/must-string.rkt create mode 100644 racket/src/regexp/analyze/start-range.rkt create mode 100644 racket/src/regexp/analyze/validate.rkt create mode 100644 racket/src/regexp/common/error.rkt create mode 100644 racket/src/regexp/common/range.rkt create mode 100644 racket/src/regexp/demo.rkt create mode 100644 racket/src/regexp/main.rkt create mode 100644 racket/src/regexp/match/compile.rkt create mode 100644 racket/src/regexp/match/extract.rkt create mode 100644 racket/src/regexp/match/interp.rkt create mode 100644 racket/src/regexp/match/lazy-bytes.rkt create mode 100644 racket/src/regexp/match/main.rkt create mode 100644 racket/src/regexp/match/match.rkt create mode 100644 racket/src/regexp/match/port.rkt create mode 100644 racket/src/regexp/match/regexp.rkt create mode 100644 racket/src/regexp/match/search.rkt create mode 100644 racket/src/regexp/match/utf-8.rkt create mode 100644 racket/src/regexp/parse/ast.rkt create mode 100644 racket/src/regexp/parse/case.rkt create mode 100644 racket/src/regexp/parse/chyte-case.rkt create mode 100644 racket/src/regexp/parse/chyte.rkt create mode 100644 racket/src/regexp/parse/class.rkt create mode 100644 racket/src/regexp/parse/config.rkt create mode 100644 racket/src/regexp/parse/error.rkt create mode 100644 racket/src/regexp/parse/main.rkt create mode 100644 racket/src/regexp/parse/range.rkt create mode 100644 racket/src/regexp/parse/unicode.rkt create mode 100644 racket/src/regexp/replace/chyte.rkt create mode 100644 racket/src/regexp/replace/main.rkt create mode 100644 racket/src/rktio/rktio.def create mode 100644 racket/src/rktio/rktio.inc create mode 100644 racket/src/rktio/rktio.rktl create mode 100644 racket/src/schemify/Makefile create mode 100644 racket/src/schemify/README.txt create mode 100644 racket/src/schemify/equal.rkt create mode 100644 racket/src/schemify/export.rkt create mode 100644 racket/src/schemify/find-definition.rkt create mode 100644 racket/src/schemify/find-known.rkt create mode 100644 racket/src/schemify/import.rkt create mode 100644 racket/src/schemify/infer-known.rkt create mode 100644 racket/src/schemify/inline.rkt create mode 100644 racket/src/schemify/interp-match.rkt create mode 100644 racket/src/schemify/interpret.rkt create mode 100644 racket/src/schemify/jitify.rkt create mode 100644 racket/src/schemify/known.rkt create mode 100644 racket/src/schemify/left-to-right.rkt create mode 100644 racket/src/schemify/let.rkt create mode 100644 racket/src/schemify/letrec.rkt create mode 100644 racket/src/schemify/lift.rkt create mode 100644 racket/src/schemify/literal.rkt create mode 100644 racket/src/schemify/main.rkt create mode 100644 racket/src/schemify/match.rkt create mode 100644 racket/src/schemify/mutated-state.rkt create mode 100644 racket/src/schemify/mutated.rkt create mode 100644 racket/src/schemify/optimize.rkt create mode 100644 racket/src/schemify/pthread-parameter.rkt create mode 100644 racket/src/schemify/quoted.rkt create mode 100644 racket/src/schemify/schemify-demo.rkt create mode 100644 racket/src/schemify/schemify.rkt create mode 100644 racket/src/schemify/serialize.rkt create mode 100644 racket/src/schemify/simple.rkt create mode 100644 racket/src/schemify/size.rkt create mode 100644 racket/src/schemify/struct-type-info.rkt create mode 100644 racket/src/schemify/wrap.rkt create mode 100644 racket/src/setup-go.rkt create mode 100644 racket/src/start/README.txt create mode 100644 racket/src/start/config.inc rename racket/src/{racket => start}/delayed.inc (98%) create mode 100644 racket/src/start/gui_filter.inc rename racket/src/{racket/dynsrc => start}/start.c (100%) rename racket/src/{racket/dynsrc => start}/starter-sh (100%) rename racket/src/{racket/dynsrc => start}/ustart.c (100%) create mode 100644 racket/src/thread/Makefile create mode 100644 racket/src/thread/README.txt create mode 100644 racket/src/thread/alarm.rkt create mode 100644 racket/src/thread/api.rkt create mode 100644 racket/src/thread/atomic.rkt create mode 100644 racket/src/thread/bootstrap-main.rkt create mode 100644 racket/src/thread/bootstrap.rkt create mode 100644 racket/src/thread/channel.rkt create mode 100644 racket/src/thread/check.rkt create mode 100644 racket/src/thread/continuation-mark.rkt create mode 100644 racket/src/thread/custodian.rkt create mode 100644 racket/src/thread/debug.rkt create mode 100644 racket/src/thread/demo.rkt create mode 100644 racket/src/thread/engine.rkt create mode 100644 racket/src/thread/evt.rkt create mode 100644 racket/src/thread/exit.rkt create mode 100644 racket/src/thread/fsemaphore.rkt create mode 100644 racket/src/thread/future.rkt create mode 100644 racket/src/thread/impersonator.rkt create mode 100644 racket/src/thread/instance.rkt create mode 100644 racket/src/thread/internal-error.rkt create mode 100644 racket/src/thread/lock.rkt create mode 100644 racket/src/thread/main.rkt create mode 100644 racket/src/thread/nested-thread.rkt create mode 100644 racket/src/thread/os-thread.rkt create mode 100644 racket/src/thread/parameter.rkt create mode 100644 racket/src/thread/plumber.rkt create mode 100644 racket/src/thread/sandman-struct.rkt create mode 100644 racket/src/thread/sandman.rkt create mode 100644 racket/src/thread/schedule-info.rkt create mode 100644 racket/src/thread/schedule.rkt create mode 100644 racket/src/thread/semaphore.rkt create mode 100644 racket/src/thread/stack-size.rkt create mode 100644 racket/src/thread/stats.rkt create mode 100644 racket/src/thread/sync.rkt create mode 100644 racket/src/thread/system-idle-evt.rkt create mode 100644 racket/src/thread/thread-group.rkt create mode 100644 racket/src/thread/thread.rkt create mode 100644 racket/src/thread/time.rkt create mode 100644 racket/src/thread/tree.rkt create mode 100644 racket/src/thread/unsafe.rkt create mode 100644 racket/src/thread/waiter.rkt create mode 100644 racket/src/thread/will-executor.rkt create mode 100644 racket/src/worksp/cs/Makefile create mode 100644 racket/src/worksp/cs/prep.rkt create mode 100644 racket/src/worksp/csbuild.rkt create mode 100644 racket/src/worksp/cstartup.c create mode 100644 racket/src/worksp/rktio.bat diff --git a/INSTALL.txt b/INSTALL.txt index 7c389e522d..dc151a0b84 100644 --- a/INSTALL.txt +++ b/INSTALL.txt @@ -40,35 +40,43 @@ If you stick with this repository, then you have several options: * Minimal --- as described in the "src" subdirectory of "racket" (i.e., ignore this directory and "pkgs"). You can build a minimal - Racket using the usual `configure && make && make install' steps + Racket using the usual `configure && make && make install` steps (or similar for Windows), and then you can install packages from - the catalog server with `raco pkg'. + the catalog server with `raco pkg`. * Installers --- create installers for a variety of platforms by farming out work to machines that run those platforms. This is the way that Racket snapshots and releases are created, and you can create your own. See "Building Installers" below. + * In-place Racket-on-Chez build --- when you use `make cs`. Unless + you use various options described in "More Instructions: Building + Racket-on-Chez" below, this process downloads Chez Scheme from + Github, builds a traditional `racket` with minimal packages, builds + Chez Scheme, and then builds Racket-on-Chez using Racket and Chez + Scheme. Final executables that end in "cs" or "CS" are the + Racket-on-Chez variants. + Quick Instructions: In-place Build ================================== -On Unix (including Linux) and Mac OS, `make' (or `make in-place') +On Unix (including Linux) and Mac OS, `make` (or `make in-place`) creates a build in the "racket" directory. On Windows with Microsoft Visual Studio (any version between 2008/9.0 -and 2015/14.0), `nmake win32-in-place' creates a build in the "racket" +and 2015/14.0), `nmake win32-in-place` creates a build in the "racket" directory. For information on configuring your command-line environment for Visual Studio, see "racket/src/worksp/README". -On Windows with MinGW, `make PLAIN_RACKET=racket/racket', since MinGW +On Windows with MinGW, `make PLAIN_RACKET=racket/racket`, since MinGW uses Unix-style tools but generates a Windows-layout Racket build. In all cases, an in-place build includes (via links) a few packages that are in the "pkgs" directory. To get new versions of those -packages, as well as the Racket core, then use `git pull'. Afterward, -or to get new versions of any other package, use `make in-place' -again, which includes a `raco pkg update' step. +packages, as well as the Racket core, then use `git pull`. Afterward, +or to get new versions of any other package, use `make in-place` +again, which includes a `raco pkg update` step. See "More Instructions: Building Racket" below for more information. @@ -76,12 +84,12 @@ See "More Instructions: Building Racket" below for more information. Quick Instructions: Unix-style Install ====================================== -On Unix (including Linux), `make unix-style PREFIX=' builds and +On Unix (including Linux), `make unix-style PREFIX=` builds and installs into "" (which must be an absolute path) with binaries in "/bin", packages in "/share/racket/pkgs", documentation in "/share/racket/doc", etc. -On Mac OS, `make unix-style PREFIX=' builds and installs into +On Mac OS, `make unix-style PREFIX=` builds and installs into "" (which must be an absolute path) with binaries in "/bin", packages in "/share/pkgs", documentation in "/doc", etc. @@ -90,7 +98,7 @@ On Windows, Unix-style install is not supported. A Unix-style install leaves no reference to this source directory. To split the build and install steps of a Unix-style installation, -supply `DESTDIR=' with `make unix-style PREFIX=', which +supply `DESTDIR=` with `make unix-style PREFIX=`, which assembles the installation in "" (which must be an absolute path). Then, copy the content of "" to the target root "". @@ -102,33 +110,33 @@ More Instructions: Building Racket ================================== The "racket" directory contains minimal Racket, which is just enough -to run `raco pkg' to install everything else. The first step of `make -in-place' or `make unix-style' is to build minimal Racket, and you can +to run `raco pkg` to install everything else. The first step of `make +in-place` or `make unix-style` is to build minimal Racket, and you can read "racket/src/README" for more information. -If you would like to provide arguments to `configure' for the minimal +If you would like to provide arguments to `configure` for the minimal Racket build, then you can supply them with by adding -`CONFIGURE_ARGS_qq="..."' to `make in-place' or `make -unix-style'. (The `_qq' suffix on the variable name is a convention +`CONFIGURE_ARGS_qq="..."` to `make in-place` or `make +unix-style`. (The `_qq` suffix on the variable name is a convention that indicates that single- and double-quote marks are allowed in the value.) The "pkgs" directory contains packages that are tied to the Racket core implementation and are therefore kept in the same Git -repository. A `make in-place' links to the package in-place, while -`make unix-style' copies packages out of "pkgs" to install them. +repository. A `make in-place` links to the package in-place, while +`make unix-style` copies packages out of "pkgs" to install them. -To install a subset of the packages in "pkgs", supply `PKGS' value to -`make'. For example, +To install a subset of the packages in "pkgs", supply `PKGS` value to +`make`. For example, make PKGS="gui-lib readline-lib" links only the "gui-lib" and "readline-lib" packages and their -dependencies. The default value of `PKGS' is "main-distribution -main-distribution-test". If you run `make' a second time, all +dependencies. The default value of `PKGS` is "main-distribution +main-distribution-test". If you run `make` a second time, all previously installed packages remain installed and are updated, while new packages are added. To uninstall previously selected package, use -`raco pkg remove'. +`raco pkg remove`. To build anything other than the latest sources in the repository (e.g., when building from the "v6.2.1" tag), you need a catalog @@ -136,40 +144,65 @@ that's compatible with those sources. Note that a release distribution is configured to use a catalog specific to that release, so you can extract the catalog's URL from there. -Using `make' (or `make in-place') sets the installation's name to +Using `make` (or `make in-place`) sets the installation's name to "development", unless the installation has been previously configured (i.e., unless the "racket/etc/config.rktd" file exists). The installation name affects, for example, the directory where -user-specific documentation is installed. Using `make' also sets the -default package scope to `installation', which means that +user-specific documentation is installed. Using `make` also sets the +default package scope to `installation`, which means that packages are installed by default into the installation's space instead of user-specific space. The name and/or default-scope configuration -can be changed through `raco pkg config'. +can be changed through `raco pkg config`. -Note that `make -j ' controls parallelism for the makefile part of -a build, but not for the `raco setup' part. To control both the -makefile and the `raco setup' part, use +Note that `make -j ` controls parallelism for the makefile part of +a build, but not for the `raco setup` part. To control both the +makefile and the `raco setup` part, use make CPUS= -which recurs with `make -j JOB_OPTIONS="-j "'. Setting `CPUS' -also works with `make unix-style'. +which recurs with `make -j JOB_OPTIONS="-j "`. Setting `CPUS` +also works with `make unix-style`. -Use `make as-is' (or `nmake win32-as-is') to perform the same build +Use `make as-is` (or `nmake win32-as-is`) to perform the same build actions as `make in-place`, but without consulting any package catalogs or package sources to install or update packages. In other -words, use `make as-is' to rebuild after local changes that could +words, use `make as-is` to rebuild after local changes that could include changes to the Racket core. (If you change only packages, then -`raco setup' should suffice.) +`raco setup` should suffice.) If you need even more control over the build, carry on to "Even More -Instructions: Building Racket Pieces". +Instructions: Building Racket Pieces" further below. + + +More Instructions: Building Racket-on-Chez +========================================== + +The `make cs` target (or `make cs-as-is` for a rebuild) builds an +experimental variant of Racket that runs on Chez Scheme. The +executables for the Racket-on-Chez variant all have a "cs" or "CS" +suffix, so they coexist with a traditional Racket build. (One day, if +the experiment goes well, there will be an option or default to build +Racket-on-Chez as `racket` instead of `racketcs`.) + +Building Racket-on-Chez requires an existing Racket and Chez Scheme. +If you use `make cs` with no further arguments, then the build process +will bootstrap by building a traditional variant of Racket and by +downloading and building Chez Scheme. + +If you have a sufficiently recent Racket installation already with at +least the "compiler-lib" and "parser-tools-libs" packages installed, +you can supply `RACKET=...` with `make cs` to skip that part of the +bootstrap. And if you have a Chez Scheme source directory already, you +can supply that with `SCHEME_SRC=...` instead of downloading a new +copy. + + make cs RACKET=racket SCHEME_SRC=path/to/ChezScheme Even More Instructions: Building Racket Pieces ============================================== -Instead of just using `make in-place' or `make unix-style', you can +Instead of just using `make in-place` or `make unix-style`, you can take more control over the build by understand how the pieces fit together. @@ -181,25 +214,25 @@ and follow the "README" there, which gives you more configuration options. If you don't want any special configuration and you just want the base -build, you can use `make base' (or `nmake win32-base') with the +build, you can use `make base` (or `nmake win32-base`) with the top-level makefile. Minimal Racket does not require additional native libraries to run, but under Windows, encoding-conversion, extflonum, and SSL functionality is hobbled until native libraries from the -`racket-win32-i386' or `racket-win32-x86_64' package are installed. +`racket-win32-i386` or `racket-win32-x86_64` package are installed. -On all platforms, fom the top-level makefile, `JOB_OPTIONS' as a -makefile variable and `PLT_SETUP_OPTIONS' as an environment variable -are passed on to the `raco setup' that is used to build minimal-Racket -libraries. See the documentation for `raco setup' for information on +On all platforms, fom the top-level makefile, `JOB_OPTIONS` as a +makefile variable and `PLT_SETUP_OPTIONS` as an environment variable +are passed on to the `raco setup` that is used to build minimal-Racket +libraries. See the documentation for `raco setup` for information on the options. For cross compilation, add configuration options to -`CONFIGURE_ARGS_qq="..."' as described in the "README" of -"racket/src", but also add a `PLAIN_RACKET=...' argument for the +`CONFIGURE_ARGS_qq="..."` as described in the "README" of +"racket/src", but also add a `PLAIN_RACKET=...` argument for the top-level makefile to specify the same executable as in an -`--enable-racket=...' for `configure'. In general, the `PLAIN_RACKET` +`--enable-racket=...` for `configure`. In general, the `PLAIN_RACKET` setting should have the form `PLAIN_RACKET="... -C"` to ensure that cross-compilation mode is used and that any foreign libraries needed for build time can be found, but many cross-compilation scenarios work @@ -213,15 +246,15 @@ packages via the package-catalog server, completely ignoring the content of "pkgs". If you want to install packages manually out of the "pkgs" directory, -the `local-catalog' target creates a catalog as "racket/local/catalog" +the `local-catalog` target creates a catalog as "racket/local/catalog" that merges the currently configured catalog's content with pointers to the packages in "pkgs". A Unix-style build works that way: it builds and installs minimal Racket, and then it installs packages out -of a catalog that is created by `make local-catalog'. +of a catalog that is created by `make local-catalog`. To add a package catalog that is used after the content of "pkgs" but before the default package catalogs, specify the catalog's URL as the -`SRC_CATALOG' makefile variable: +`SRC_CATALOG` makefile variable: make .... SRC_CATALOG= @@ -229,19 +262,19 @@ Linking Packages for In-place Development Mode ---------------------------------------------- With an in-place build, you can edit packages within "pkgs" directly -or update those packages with `git pull' plus `raco setup', since the +or update those packages with `git pull` plus `raco setup`, since the packages are installed with the equivalent of `raco pkg install -i ---static-link ...'. +--static-link ...`. Instead of actually using `raco pkg install --static-link ...`, the -`pkgs-catalog' makefile target creates a catalog that points to the +`pkgs-catalog` makefile target creates a catalog that points to the packages in "pkgs", and the catalog indicates that the packages are to -be installed as links. The `pkgs-catalog' target further configures +be installed as links. The `pkgs-catalog` target further configures the new catalog as the first one to check when installing packages. The configuration adjustment is made only if no configuration file "racket/etc/config.rktd" exists already. -All other packages (as specified by `PKGS') are installed via the +All other packages (as specified by `PKGS`) are installed via the configured package catalog. They are installed in installation scope, but the content of "racket/share/pkgs" is not meant to be edited. To reinstall a package in a mode suitable for editing and manipulation @@ -257,7 +290,7 @@ The Whole Enchilada: Building Installers ======================================== To build installers that can be distributed to other users, do not use -`make in-place' or `make unix-style', but instead start from a clean +`make in-place` or `make unix-style`, but instead start from a clean repository. Use one non-Windows machine as a server, where packages will be @@ -266,24 +299,20 @@ installers on N client machines, each of which contacts the server machine to obtain pre-built packages. The server can act as a client, naturally, to create an installer for the server's platform. -GNU `make' is required on the server machine, `nmake' is required on -Windows client machines, and any `make' should work on other client +GNU `make` is required on the server machine, `nmake` is required on +Windows client machines, and any `make` should work on other client machines. Running Build Farms ------------------- -The `installers' target of the makefile will do everything to generate +The `installers` target of the makefile will do everything to generate installers: build a server on the current machine, run clients on hosts specified via CONFIG, and start/stop VirtualBox virtual machines that act as client machines. -See - - pkgs/distro-build-pkgs/distro-build-client/doc.txt - -for a description of the site-configuration module and requirements on -client hosts. +See the documentation of the "distro-build" package for a description +of the site-configuration module and requirements on client hosts. If "my-site-config.rkt" is a configuration module, then @@ -295,21 +324,22 @@ installer filenames in "build/installer/table.rktd". A log file for each client is written to "build/log". The default CONFIG path is "build/site.rkt", so you could put your -configuration file there and omit the `CONFIG' argument to -`make'. Supply `CONFIG_MODE=...' to pass a configuration mode on to -your site-configuration module (accessible via the `current-mode' -parameter). Supply `CLEAN_MODE=--clean' to make the default `#:clean?' +configuration file there and omit the `CONFIG` argument to `make`. A +default configuration file is created there automatically. Supply +`CONFIG_MODE=...` to pass a configuration mode on to your +site-configuration module (accessible via the `current-mode` +parameter). Supply `CLEAN_MODE=--clean` to make the default `#:clean?` configuration for a client #t instead of #f, supply -`RELEASE_MODE=--release' to make the default `#:release?' +`RELEASE_MODE=--release` to make the default `#:release?` configuration #t, supply `SOURCE_MODE=--source` to make the default -`#:source?' configuration #t, and supply `VERSIONLESS_MODE=--version` -to make the default `#:versionless?' configuration #t. +`#:source?` configuration #t, and supply `VERSIONLESS_MODE=--version` +to make the default `#:versionless?` configuration #t. A configuration file can specify the packages to include, host address of the server, distribution name, installer directory, and -documentation search URL, but defaults can be provided as `make' -arguments via `PKGS', `SERVER' plus `SERVER_PORT` plus `SERVER_HOSTS`, -`DIST_NAME', `DIST_BASE', and `DIST_DIR', `DOC_SEARCH', +documentation search URL, but defaults can be provided as `make` +arguments via `PKGS`, `SERVER` plus `SERVER_PORT` plus `SERVER_HOSTS`, +`DIST_NAME`, `DIST_BASE`, and `DIST_DIR`, `DOC_SEARCH`, respectively. The site configuration's top-level options for packages and documentation search URL are used to configure the set of packages that are available to client machines to include in installers. @@ -320,9 +350,9 @@ is ---. where defaults to "racket" (but can be set via -`DIST_BASE'), is from `(system-library-subpath #f)' but +`DIST_BASE`), is from `(system-library-subpath #f)` but normalizing the Windows results to "i386-win32" and "x86_63-win32", -- is omitted unless a `#:dist-suffix' string is specified +- is omitted unless a `#:dist-suffix` string is specified for the client in the site configuration, and is platform-specific: ".sh" for Unix (including Linux), ".dmg" or ".pkg" for Mac OS, and ".exe" for Windows. @@ -330,58 +360,58 @@ for Mac OS, and ".exe" for Windows. Generating Installer Web Sites ------------------------------ -The `site' target of the makefile uses the `installers' target to +The `site` target of the makefile uses the `installers` target to generate a set of installers, and then it combines the installers, packages, a package catalog, and log files into a directory that is suitable for access via a web server. -Supply the same `CONFIG=...' and `CONFIG_MODE=...' arguments for -`site' as for `installers'. The configuration file should have a -`#:dist-base-url' entry for the URL where installers and packages will -be made available; the `installers' target uses `#:dist-base-url' to +Supply the same `CONFIG=...` and `CONFIG_MODE=...` arguments for +`site` as for `installers`. The configuration file should have a +`#:dist-base-url` entry for the URL where installers and packages will +be made available; the `installers` target uses `#:dist-base-url` to embed suitable configuration into the installers. Specifically, installers are configured to access pre-built packages and -documentation from the site indicated by `#:dist-base-url'. +documentation from the site indicated by `#:dist-base-url`. -Note that `#:dist-base-url' should almost always end with "/", since -others URLs will be constructed as relative to `#:dist-base-url'. +Note that `#:dist-base-url` should almost always end with "/", since +others URLs will be constructed as relative to `#:dist-base-url`. -The site is generated as "build/site" by default. A `#:site-dest' +The site is generated as "build/site" by default. A `#:site-dest` entry in the configuration file can select an alternate destination. -Use the `site-from-installers' makefile target to perform the part of -`site' that happens after `installers' (i.e., to generate a `site' +Use the `site-from-installers` makefile target to perform the part of +`site` that happens after `installers` (i.e., to generate a `site` from an already-generated set of installers). Managing Snapshot Web Sites --------------------------- -The `snapshot-site' makefile target uses `site' (so supply the same -`CONFIG=...' and `CONFIG_MODE=...' arguments), and then treats the +The `snapshot-site` makefile target uses `site` (so supply the same +`CONFIG=...` and `CONFIG_MODE=...` arguments), and then treats the resulting site as a snapshot with additional snapshot-management tasks. For snapshot management, the destination of the files generated for -`site' (as specified by `#:site-dest') should be within a directory of -snapshots. The configuration file can use `(current-stamp)' to get a +`site` (as specified by `#:site-dest`) should be within a directory of +snapshots. The configuration file can use `(current-stamp)` to get a string that represents the current build, and then use the string both -for `#:dist-base-url' and `#:site-dest'. Normally, the stamp string is +for `#:dist-base-url` and `#:site-dest`. Normally, the stamp string is a combination of the date and Git commit hash. Snapshot management includes creating an "index.html" file in the snapshots directory (essentially a copy of the snapshot's own "index.html") and pruning snapshot subdirectories to keep the number -of snapshots at the amount specified by `#:max-snapshots' +of snapshots at the amount specified by `#:max-snapshots` configuration-file entry (with a default value of 5). -Use the `snapshot-at-site' makefile target to perform the part of +Use the `snapshot-at-site` makefile target to perform the part of `snapshot-site that happens after `site (i.e., to manage snapshots around an already-generated site). Separate Server and Clients --------------------------- -Instead of using the `installers' makefile target and a site +Instead of using the `installers` makefile target and a site configuration file, you can run server and client processes manually. Roughly, the steps are @@ -389,50 +419,50 @@ Roughly, the steps are 1. On the server machine: make server PKGS="..." - See 1b below for more information on variables other than `PKGS' - that you can provide with `make'. + See 1b below for more information on variables other than `PKGS` + that you can provide with `make`. 2. On each client machine: make client SERVER=... PKGS="..." or nmake win32-client SERVER=... PKGS="..." - See 2b below for more information on variables other than `SERVER' - and `PKGS' that you can provide with `make'. + See 2b below for more information on variables other than `SERVER` + and `PKGS` that you can provide with `make`. In more detail: 1a. Build "racket" on a server. - The `base' target of the makefile will do that, if you haven't + The `base` target of the makefile will do that, if you haven't done it already. (The server only works on non-Windows platforms, currently.) 1b. On the server, build packages and start a catalog server. - The `server-from-base' target of the makefile will do that. + The `server-from-base` target of the makefile will do that. - Alternatively, use the `server' target, which combines `base' and - `server-from-base' (i.e., steps 1a and 1b). + Alternatively, use the `server` target, which combines `base` and + `server-from-base` (i.e., steps 1a and 1b). - The `SERVER_PORT' variable of the makefile choose the port on + The `SERVER_PORT` variable of the makefile choose the port on which the server listens to clients. The default is port 9440. - The `SERVER_HOSTS' variable of the makefile determines the + The `SERVER_HOSTS` variable of the makefile determines the interfaces at which the server listens. The default is "localhost" which listens only on the loopback device (for security). Supply the empty string to listen on all interfaces. Supply multiple addresses by separating them with a comma. - The `PKGS' variable of the makefile determines which packages are + The `PKGS` variable of the makefile determines which packages are built for potential inclusion in a distribution. - The `DOC_SEARCH' variable of the makefile determine a URL that is + The `DOC_SEARCH` variable of the makefile determine a URL that is embedded in rendered documentation for cases where a remote search is needed (because other documentation is not installed). - The `SRC_CATALOG' variable determines the catalog that is used to + The `SRC_CATALOG` variable determines the catalog that is used to get package sources and native-library packages. The default is "http://pkgs.racket-lang.org". @@ -442,8 +472,8 @@ In more detail: "README.txt" by default). If you stop the server and want to restart it, use the - `built-package-server' makefile target instead of starting over - with the `server' target. + `built-package-server` makefile target instead of starting over + with the `server` target. 2a. On each client (one for each platform to bundle), build "racket". @@ -452,94 +482,94 @@ In more detail: 2b. On each client, create an installer. - The `client' (or `win32-client') target of the makefile will do + The `client` (or `win32-client`) target of the makefile will do that. - Provide `SERVER' as the hostname of the server machine, but a + Provide `SERVER` as the hostname of the server machine, but a "localhost"-based tunnel back to the server is more secure and - avoids the need to specify `SERVER_HOSTS' when starting the - server in step 1b. Also, provide `SERVER_PORT' if an alternate + avoids the need to specify `SERVER_HOSTS` when starting the + server in step 1b. Also, provide `SERVER_PORT` if an alternate port was specified in step 1b. - Provide the same `PKGS' (or a subset) as in step 1b if you want a + Provide the same `PKGS` (or a subset) as in step 1b if you want a different set than the ones listed in the makefile. Similarly, - `DOC_SEARCH' normally should be the same as in step 1b, but for a + `DOC_SEARCH` normally should be the same as in step 1b, but for a client, it affects future documentation builds in the installation. - Alternatively, use the `client' target, which combines `base' and - `client-from-base' (i.e., steps 2a and 2b). + Alternatively, use the `client` target, which combines `base` and + `client-from-base` (i.e., steps 2a and 2b). On Windows, you need NSIS installed, either in the usual location - or with `makensis' in your command-line path. + or with `makensis` in your command-line path. - To create a release installer, provide `RELEASE_MODE' as - "--release" to `make'. A release installer has slightly different + To create a release installer, provide `RELEASE_MODE` as + "--release" to `make`. A release installer has slightly different defaults that are suitable for infrequently updated release installations, as opposed to frequently updated snapshot installations. - To create a source archive, provide `SOURCE_MODE' as "--source" - to `make'. + To create a source archive, provide `SOURCE_MODE` as "--source" + to `make`. To create an archive that omits the version number and also omit - and version number in installer paths, provide `VERSIONLESS_MODE' as - "--versionless" to `make'. + and version number in installer paths, provide `VERSIONLESS_MODE` as + "--versionless" to `make`. To change the human-readable name of the distribution as embedded - in the installer, provide `DIST_NAME' to `make'. The default + in the installer, provide `DIST_NAME` to `make`. The default distribution name is "Racket". Whatever name you pick, the Racket version number is automatically added for various contexts. - To change the base name of the installer file, provide `DIST_BASE' - to `make'. The default is "racket". + To change the base name of the installer file, provide `DIST_BASE` + to `make`. The default is "racket". To change the directory name for installation on Unix (including - Linux), provide `DIST_DIR' to `make'. The default is "racket". + Linux), provide `DIST_DIR` to `make`. The default is "racket". To add an extra piece to the installer's name, such as an - identifier for a variant of Linux, provide `DIST_SUFFIX' to - `make'. The default is "", which omits the prefix and its + identifier for a variant of Linux, provide `DIST_SUFFIX` to + `make`. The default is "", which omits the prefix and its preceding hyphen. To set the description string for the installer, provide - `DIST_DESC' to `make'. The description string is recorded + `DIST_DESC` to `make`. The description string is recorded alongside the installer. To set the initial package catalogs URLs for an installation, - provide `DIST_CATALOGS_q' to `make'. Separate multiple URLs with + provide `DIST_CATALOGS_q` to `make`. Separate multiple URLs with a space, and use an empty string in place of a URL to indicate that the default catalogs should be used. The "_q" in the variable name indicates that its value can include double quotes (but not single quotes) --- which are needed to specify an empty string, for example. - To select a "README" file for the client, provide `README' to - `make'. The `README' value is used as a file name to download + To select a "README" file for the client, provide `README` to + `make`. The `README` value is used as a file name to download from the server. To create a ".tgz" archive instead of an installer (or any - platform), set `TGZ_MODE' to "--tgz". + platform), set `TGZ_MODE` to "--tgz". - For a Mac OS installer, set `SIGN_IDENTITY' as the name to - which the signing certificate is associated. Set `MAC_PKG_MODE' + For a Mac OS installer, set `SIGN_IDENTITY` as the name to + which the signing certificate is associated. Set `MAC_PKG_MODE` to "--mac-pkg" to create a ".pkg" installer instead of a ".dmg" image. For a Windows installer, set `OSSLSIGNCODE_ARGS_BASE64` as a Base64 encoding of an S-expression for a list of argument strings - for `osslsigncode`. The `-n', `-t', `-in', and `-out' arguments + for `osslsigncode`. The `-n`, `-t`, `-in`, and `-out` arguments are provided to `osslsigncode` automatically, so supply the others. - The `SERVER_CATALOG_PATH' and `SERVER_COLLECTS_PATH' makefile - variables specify paths at `SERVER' plus `SERVER_PORT' to access + The `SERVER_CATALOG_PATH` and `SERVER_COLLECTS_PATH` makefile + variables specify paths at `SERVER` plus `SERVER_PORT` to access the package catalog and pre-built "collects" tree needed for a client, but those paths should be empty for a server started with - `make server', and they are used mainly by `make - client-from-site' (described below). + `make server`, and they are used mainly by `make + client-from-site` (described below). - The `UPLOAD' makefile variable specifies a URL to use as an + The `UPLOAD` makefile variable specifies a URL to use as an upload destination for the created installed, where the installer's name is added to the end of the URL, or leave as empty for no upload. @@ -551,26 +581,26 @@ the server, which leaves the installer in a "build/installers" directory and records a mapping from the installer's description to its filename in "build/installers/table.rktd". -If you provide `JOB_OPTIONS=...' for either a client or server build, -the options are used both for `raco setup' and `raco pkg -install'. Normally, `JOB_OPTIONS' is used to control parallelism. +If you provide `JOB_OPTIONS=...` for either a client or server build, +the options are used both for `raco setup` and `raco pkg +install`. Normally, `JOB_OPTIONS` is used to control parallelism. Creating a Client from an Installer Web Site -------------------------------------------- If you (or someone else) previously created an installer site with -`make site', then `make client-from-site` in a clean repository +`make site`, then `make client-from-site` in a clean repository creates an installer for the current platform drawing packages from the site. -At a minimum, provide `SERVER', `SERVER_PORT' (usually 80), and -`SITE_PATH' (if not empty, include a trailing "/") makefile variables +At a minimum, provide `SERVER`, `SERVER_PORT` (usually 80), and +`SITE_PATH` (if not empty, include a trailing "/") makefile variables to access a site at http://$(SERVER):$(SERVER_PORT)/$(SITE_PATH) -The `client-from-site' makefile target chains to `make client' while +The `client-from-site` makefile target chains to `make client` while passing suitable values for `DIST_CATALOGS_q`, `DOC_SEARCH`, -`SERVER_CATALOG_PATH', and `SERVER_COLLECTS_PATH'. Supply any other -suitable variables, such as `DIST_NAME' or `RELEASE_MODE', the same as -for `make client'. +`SERVER_CATALOG_PATH`, and `SERVER_COLLECTS_PATH`. Supply any other +suitable variables, such as `DIST_NAME` or `RELEASE_MODE`, the same as +for `make client`. diff --git a/Makefile b/Makefile index 1731e8aa85..68fdff1df1 100644 --- a/Makefile +++ b/Makefile @@ -64,11 +64,24 @@ INSTALL_PKGS_ARGS = $(JOB_OPTIONS) --no-setup --pkgs \ ALL_PLT_SETUP_OPTIONS = $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS) plain-in-place: + $(MAKE) plain-minimal-in-place + $(MAKE) in-place-setup + +plain-in-place-after-base: + $(MAKE) plain-minimal-in-place-after-base + $(MAKE) in-place-setup + +plain-minimal-in-place: $(MAKE) plain-base + $(MAKE) plain-minimal-in-place-after-base + +plain-minimal-in-place-after-base: $(MAKE) pkgs-catalog $(RUN_RACO) pkg update $(UPDATE_PKGS_ARGS) $(RUN_RACO) pkg install $(INSTALL_PKGS_ARGS) $(RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS) + +in-place-setup: $(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS) win32-in-place: @@ -91,7 +104,7 @@ cpus-as-is: plain-as-is: $(MAKE) base - $(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS) + $(MAKE) in-place-setup win32-as-is: $(MAKE) win32-base @@ -148,7 +161,9 @@ set-src-catalog: CONFIGURE_ARGS_qq = -SELF_FLAGS_qq = SELF_RACKET_FLAGS="-G `cd ../../../build/config; pwd`" +SELF_UP = +SELF_FLAGS_qq = SELF_RACKET_FLAGS="-G `cd $(SELF_UP)../../../build/config; pwd`" +INSTALL_SETUP_ARGS = $(SELF_FLAGS_qq) PLT_SETUP_OPTIONS="$(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)" base: if [ "$(CPUS)" = "" ] ; \ @@ -159,13 +174,16 @@ cpus-base: $(MAKE) -j $(CPUS) plain-base JOB_OPTIONS="-j $(CPUS)" plain-base: - mkdir -p build/config - echo '#hash((links-search-files . ()))' > build/config/config.rktd + $(MAKE) base-config mkdir -p racket/src/build $(MAKE) racket/src/build/Makefile cd racket/src/build; $(MAKE) reconfigure cd racket/src/build; $(MAKE) $(SELF_FLAGS_qq) - cd racket/src/build; $(MAKE) install $(SELF_FLAGS_qq) PLT_SETUP_OPTIONS="$(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)" + cd racket/src/build; $(MAKE) install $(INSTALL_SETUP_ARGS) + +base-config: + mkdir -p build/config + echo '#hash((links-search-files . ()))' > build/config/config.rktd win32-base: $(MAKE) win32-remove-setup-dlls @@ -195,6 +213,77 @@ native-for-cross: racket/src/build/cross/Makefile: racket/src/configure racket/src/Makefile.in cd racket/src/build/cross; ../../configure +# ------------------------------------------------------------ +# Racket-on-Chez build + +# If `RACKET` is not set, then we bootstrap by first building the +# traditional virtual machine +RACKET = + +# If `SCHEME_SRC` is not set, then we'll download a copy of +# Chez Scheme from `CHEZ_SCHEME_REPO` +SCHEME_SRC = +DEFAULT_SCHEME_SRC = racket/src/build/ChezScheme + +CHEZ_SCHEME_REPO = https://github.com/mflatt/ChezScheme + +# Redirected for "as-is": +BASE_TARGET = plain-minimal-in-place +CS_SETUP_TARGET = plain-in-place-after-base + +cs: + if [ "$(SCHEME_SRC)" = "" ] ; \ + then $(MAKE) scheme-src ; fi + if [ "$(RACKET)" = "" ] ; \ + then $(MAKE) racket-then-cs ; \ + else $(MAKE) cs-after-racket-with-racket RACKET="$(RACKET)" ; fi + +cs-as-is: + $(MAKE) cs BASE_TARGET=plain-base CS_SETUP_TARGET=in-place-setup + +cs-after-racket: + if [ "$(RACKET)" = "" ] ; \ + then $(MAKE) cs-after-racket-with-racket RACKET="$(PLAIN_RACKET)" ; \ + else $(MAKE) cs-after-racket-with-racket RACKET="$(RACKET)" ; fi + +racket-then-cs: + $(MAKE) $(BASE_TARGET) PKGS="compiler-lib parser-tools-lib" + $(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS) -D -l compiler parser-tools + $(MAKE) cs-after-racket-with-racket RACKET="$(PLAIN_RACKET)" + +ABS_RACKET = "`$(RACKET) racket/src/cs/absify.rkt --exec $(RACKET)`" +ABS_SCHEME_SRC = "`$(RACKET) racket/src/cs/absify.rkt $(SCHEME_SRC)`" + +cs-after-racket-with-racket: + if [ "$(SCHEME_SRC)" = "" ] ; \ + then $(MAKE) cs-after-racket-with-racket-and-scheme-src RACKET="$(RACKET)" SCHEME_SRC="$(DEFAULT_SCHEME_SRC)" ; \ + else $(MAKE) cs-after-racket-with-racket-and-scheme-src RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)" ; fi + +cs-after-racket-with-racket-and-scheme-src: + $(MAKE) cs-after-racket-with-abs-paths RACKET="$(ABS_RACKET)" SCHEME_SRC="$(ABS_SCHEME_SRC)" SELF_UP=../ + +cs-after-racket-with-abs-paths: + $(MAKE) racket/src/build/cs/Makefile + cd racket/src/build/cs; $(MAKE) RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)" + $(MAKE) base-config + cd racket/src/build/cs; $(MAKE) install RACKET="$(RACKET)" $(INSTALL_SETUP_ARGS) + $(MAKE) $(CS_SETUP_TARGET) PLAIN_RACKET=racket/bin/racketcs + +racket/src/build/cs/Makefile: racket/src/cs/c/configure racket/src/cs/c/Makefile.in + mkdir -p cd racket/src/build/cs + cd racket/src/build/cs; ../../cs/c/configure + +scheme-src: + $(MAKE) racket/src/build/ChezScheme + $(MAKE) update-ChezScheme + +racket/src/build/ChezScheme: + mkdir -p racket/src/build + cd racket/src/build && git clone $(CHEZ_SCHEME_REPO) + +update-ChezScheme: + cd racket/src/build/ChezScheme && git pull && git submodule update + # ------------------------------------------------------------ # Configuration options for building installers @@ -331,8 +420,8 @@ SVR_CAT = http://$(SVR_PRT)/$(SERVER_CATALOG_PATH) # Helper macros: USER_CONFIG = -G build/user/config -X racket/collects -A build/user -RACKET = $(PLAIN_RACKET) $(USER_CONFIG) -RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco +USER_RACKET = $(PLAIN_RACKET) $(USER_CONFIG) +USER_RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco WIN32_RACKET = $(WIN32_PLAIN_RACKET) $(USER_CONFIG) WIN32_RACO = $(WIN32_PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco X_AUTO_OPTIONS = --skip-installed --deps search-auto --pkgs $(JOB_OPTIONS) @@ -352,11 +441,11 @@ WIN32_IN_BUNDLE_RACO = bundle\racket\raco # ------------------------------------------------------------ # Linking all packages (development mode; not an installer build) -PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata +PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata --immediate PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt pkgs-catalog: - $(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs + $(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander $(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)" $(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog @@ -409,47 +498,47 @@ stamp-from-date: build-from-catalog: rm -rf build/user rm -rf build/catalog-copy - $(RACO) pkg catalog-copy "$(SRC_CATALOG)" build/catalog-copy + $(USER_RACO) pkg catalog-copy "$(SRC_CATALOG)" build/catalog-copy $(MAKE) server-cache-config - $(RACO) pkg install --all-platforms $(SOURCE_USER_AUTO_q) $(REQUIRED_PKGS) $(DISTRO_BUILD_PKGS) + $(USER_RACO) pkg install --all-platforms $(SOURCE_USER_AUTO_q) $(REQUIRED_PKGS) $(DISTRO_BUILD_PKGS) $(MAKE) set-server-config - $(RACKET) -l- distro-build/pkg-info -o build/pkgs.rktd build/catalog-copy - $(RACKET) -l distro-build/install-pkgs $(CONFIG_MODE_q) "$(PKGS) $(TEST_PKGS)" $(SOURCE_USER_AUTO_q) --all-platforms - $(RACO) setup --avoid-main $(JOB_OPTIONS) + $(USER_RACKET) -l- distro-build/pkg-info -o build/pkgs.rktd build/catalog-copy + $(USER_RACKET) -l distro-build/install-pkgs $(CONFIG_MODE_q) "$(PKGS) $(TEST_PKGS)" $(SOURCE_USER_AUTO_q) --all-platforms + $(USER_RACO) setup --avoid-main $(JOB_OPTIONS) server-cache-config: - $(RACO) pkg config -i --set download-cache-dir build/cache - $(RACO) pkg config -i --set download-cache-max-files 1023 - $(RACO) pkg config -i --set download-cache-max-bytes 671088640 + $(USER_RACO) pkg config -i --set download-cache-dir build/cache + $(USER_RACO) pkg config -i --set download-cache-max-files 1023 + $(USER_RACO) pkg config -i --set download-cache-max-bytes 671088640 set-server-config: - $(RACKET) -l distro-build/set-server-config build/user/config/config.rktd $(CONFIG_MODE_q) "" "" "$(DOC_SEARCH)" "" + $(USER_RACKET) -l distro-build/set-server-config build/user/config/config.rktd $(CONFIG_MODE_q) "" "" "$(DOC_SEARCH)" "" # Although a client will build its own "collects", pack up the # server's version to be used by each client, so that every client has # exactly the same bytecode (which matters for SHA1-based dependency # tracking): origin-collects: - $(RACKET) -l distro-build/pack-collects + $(USER_RACKET) -l distro-build/pack-collects # Now that we've built packages from local sources, create "built" # versions of the packages from the installation into "build/user": built-catalog: - $(RACKET) -l distro-build/pack-built build/pkgs.rktd + $(USER_RACKET) -l distro-build/pack-built build/pkgs.rktd # Run a catalog server to provide pre-built packages, as well # as the copy of the server's "collects" tree: built-catalog-server: if [ -d ".git" ]; then git update-server-info ; fi - $(RACKET) -l distro-build/serve-catalog $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) $(SERVE_DURING_CMD_qq) + $(USER_RACKET) -l distro-build/serve-catalog $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) $(SERVE_DURING_CMD_qq) # Demonstrate how a catalog server for binary packages works, # which involves creating package archives in "binary" mode # instead of "built" mode: binary-catalog: - $(RACKET) -l- distro-build/pack-built --mode binary build/pkgs.rktd + $(USER_RACKET) -l- distro-build/pack-built --mode binary build/pkgs.rktd binary-catalog-server: - $(RACKET) -l- distro-build/serve-catalog --mode binary $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) + $(USER_RACKET) -l- distro-build/serve-catalog --mode binary $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) # ------------------------------------------------------------ # On each supported platform (for an installer build): @@ -485,7 +574,7 @@ client: $(MAKE) base $(COPY_ARGS) $(MAKE) distro-build-from-server $(COPY_ARGS) $(MAKE) bundle-from-server $(COPY_ARGS) - $(RACKET) -l distro-build/set-config $(SET_BUNDLE_CONFIG_q) + $(USER_RACKET) -l distro-build/set-config $(SET_BUNDLE_CONFIG_q) $(MAKE) installer-from-bundle $(COPY_ARGS) win32-client: @@ -499,7 +588,7 @@ win32-client: # Install the "distro-build" package from the server into # a local build: distro-build-from-server: - $(RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client + $(USER_RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client # Copy our local build into a "bundle/racket" build, dropping in the # process things that should not be in an installer (such as the "src" @@ -511,13 +600,13 @@ distro-build-from-server: bundle-from-server: rm -rf bundle mkdir -p bundle/racket - $(RACKET) -l setup/unixstyle-install bundle racket bundle/racket - $(RACKET) -l setup/winstrip bundle/racket - $(RACKET) -l setup/winvers-change bundle/racket - $(RACKET) -l distro-build/unpack-collects http://$(SVR_PRT)/$(SERVER_COLLECTS_PATH) + $(USER_RACKET) -l setup/unixstyle-install bundle racket bundle/racket + $(USER_RACKET) -l setup/winstrip bundle/racket + $(USER_RACKET) -l setup/winvers-change bundle/racket + $(USER_RACKET) -l distro-build/unpack-collects http://$(SVR_PRT)/$(SERVER_COLLECTS_PATH) $(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(REQUIRED_PKGS) $(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(PKGS) - $(RACKET) -l setup/unixstyle-install post-adjust "$(SOURCE_MODE)" "$(PKG_SOURCE_MODE)" racket bundle/racket + $(USER_RACKET) -l setup/unixstyle-install post-adjust "$(SOURCE_MODE)" "$(PKG_SOURCE_MODE)" racket bundle/racket UPLOAD_q = --readme "$(README)" --upload "$(UPLOAD)" --desc "$(DIST_DESC)" DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) \ @@ -528,7 +617,7 @@ DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) \ # Create an installer from the build (with installed packages) that's # in "bundle/racket": installer-from-bundle: - $(RACKET) -l- distro-build/installer $(DIST_ARGS_q) + $(USER_RACKET) -l- distro-build/installer $(DIST_ARGS_q) win32-distro-build-from-server: $(WIN32_RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client @@ -589,7 +678,7 @@ DRIVE_ARGS_q = $(RELEASE_MODE) $(VERSIONLESS_MODE) $(SOURCE_MODE) \ $(CLEAN_MODE) "$(CONFIG)" "$(CONFIG_MODE)" \ $(SERVER) $(SERVER_PORT) "$(SERVER_HOSTS)" \ "$(PKGS)" "$(DOC_SEARCH)" "$(DIST_NAME)" $(DIST_BASE) $(DIST_DIR) -DRIVE_CMD_q = $(RACKET) -l- distro-build/drive-clients $(DRIVE_ARGS_q) +DRIVE_CMD_q = $(USER_RACKET) -l- distro-build/drive-clients $(DRIVE_ARGS_q) # Full server build and clients drive, based on `CONFIG': installers: @@ -615,8 +704,8 @@ DOC_CATALOGS = build/built/catalog build/native/catalog site-from-installers: rm -rf build/docs - $(RACKET) -l- distro-build/install-for-docs build/docs $(CONFIG_MODE_q) "$(PKGS)" $(DOC_CATALOGS) - $(RACKET) -l- distro-build/assemble-site $(CONFIG_MODE_q) + $(USER_RACKET) -l- distro-build/install-for-docs build/docs $(CONFIG_MODE_q) "$(PKGS)" $(DOC_CATALOGS) + $(USER_RACKET) -l- distro-build/assemble-site $(CONFIG_MODE_q) # ------------------------------------------------------------ # Create a snapshot site: @@ -626,4 +715,4 @@ snapshot-site: $(MAKE) snapshot-at-site snapshot-at-site: - $(RACKET) -l- distro-build/manage-snapshots $(CONFIG_MODE_q) + $(USER_RACKET) -l- distro-build/manage-snapshots $(CONFIG_MODE_q) diff --git a/README.md b/README.md index 9bb291b7af..c79e0f76c8 100644 --- a/README.md +++ b/README.md @@ -1,17 +1,11 @@ -[![Linux/Mac Build -Status](https://travis-ci.org/racket/racket.svg?branch=master)](https://travis-ci.org/racket/racket) -[![Windows build status](https://ci.appveyor.com/api/projects/status/hqir4eib0okk6xar?svg=true)](https://ci.appveyor.com/project/plt/racket) - - -This is the source code for the core of Racket. See -"INSTALL.txt" for full information on building Racket. +This is the source code for the core of Racket. See "INSTALL.txt" for +full information on building Racket. To build the full Racket distribution from this repository, run `make` -in the top-level directory. To build the Minimal Racket, run `make -base`. +in the top-level directory. To build minimal Racket, run `make base`. The rest of the Racket distribution source code is in other -repositories under [the Racket GitHub +repositories, mostly under [the Racket GitHub organization](https://github.com/racket). Contribute to Racket by submitting a pull request, joining the diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 9c03de7cea..29949c2dba 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.12.0.4") +(define version "6.90.0.16") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/compiler-lib/compiler/commands/decompile.rkt b/pkgs/compiler-lib/compiler/commands/decompile.rkt index 1a4d058032..39818bfdab 100644 --- a/pkgs/compiler-lib/compiler/commands/decompile.rkt +++ b/pkgs/compiler-lib/compiler/commands/decompile.rkt @@ -11,6 +11,7 @@ (string->symbol (short-program+command-name))) (define force? #f) +(define to-linklets? #f) (define source-files (command-line @@ -24,6 +25,8 @@ (raise-user-error (get-name) "not a valid column count: ~a" n)) (pretty-print-columns num))] + [("--linklet") "Decompile to linklets" + (set! to-linklets? #t)] #:args source-or-bytecode-file source-or-bytecode-file)) @@ -85,6 +88,7 @@ [print-graph #t]) (pretty-write (decompile + #:to-linklets? to-linklets? (call-with-input-file* (if (file-exists? alt-file) alt-file zo-file) (lambda (in) diff --git a/pkgs/compiler-lib/compiler/commands/exe.rkt b/pkgs/compiler-lib/compiler/commands/exe.rkt index 7a178ccf34..5470f289eb 100644 --- a/pkgs/compiler-lib/compiler/commands/exe.rkt +++ b/pkgs/compiler-lib/compiler/commands/exe.rkt @@ -10,7 +10,7 @@ (define very-verbose (make-parameter #f)) (define gui (make-parameter #f)) -(define 3m (make-parameter #t)) +(define variant (make-parameter (system-type 'gc))) (define launcher (make-parameter #f)) (define exe-output (make-parameter #f)) @@ -54,9 +54,11 @@ [("--orig-exe") "Use original executable instead of stub" (exe-aux (cons (cons 'original-exe? #t) (exe-aux)))] [("--3m") "Generate using 3m variant" - (3m #t)] + (variant '3m)] [("--cgc") "Generate using CGC variant" - (3m #f)] + (variant 'cgc)] + [("--cs") "Generate using CS variant" + (variant 'cs)] #:multi [("++aux") aux-file "Extra executable info (based on suffix)" (let ([auxes (extract-aux-from-path (path->complete-path aux-file))]) @@ -106,7 +108,7 @@ dest))))))) (cond [(launcher) - (parameterize ([current-launcher-variant (if (3m) '3m 'cgc)]) + (parameterize ([current-launcher-variant (variant)]) ((if (gui) make-gracket-launcher make-racket-launcher) @@ -123,7 +125,7 @@ (mzc:create-embedding-executable dest #:mred? (gui) - #:variant (if (3m) '3m 'cgc) + #:variant (variant) #:verbose? (very-verbose) #:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime)) (map (lambda (l) `(#t (lib ,l))) diff --git a/pkgs/compiler-lib/compiler/decompile.rkt b/pkgs/compiler-lib/compiler/decompile.rkt index a393218fff..631c53c0ae 100644 --- a/pkgs/compiler-lib/compiler/decompile.rkt +++ b/pkgs/compiler-lib/compiler/decompile.rkt @@ -1,42 +1,37 @@ #lang racket/base -(require compiler/zo-parse +(require racket/linklet + compiler/zo-parse + compiler/zo-marshal syntax/modcollapse racket/port racket/match racket/list racket/set - racket/path) + racket/path + (only-in '#%linklet compiled-position->primitive) + "private/deserialize.rkt") (provide decompile) ;; ---------------------------------------- (define primitive-table - ;; Figure out number-to-id mapping for kernel functions in `primitive' - (let ([bindings - (let ([ns (make-base-empty-namespace)]) - (parameterize ([current-namespace ns]) - (namespace-require ''#%kernel) - (namespace-require ''#%unsafe) - (namespace-require ''#%flfxnum) - (namespace-require ''#%extfl) - (namespace-require ''#%futures) - (namespace-require ''#%foreign) - (for/list ([l (namespace-mapped-symbols)]) - (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) - (compile l))))))] - [table (make-hash)]) - (for ([b (in-list bindings)]) - (let ([v (and (cdr b) - (zo-parse - (open-input-bytes - (with-output-to-bytes - (λ () (write (cdr b)))))))]) - (let ([n (match v - [(struct compilation-top (_ _ prefix (struct primval (n)))) n] - [else #f])]) - (hash-set! table n (car b))))) - table)) + (let ([value-names (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require ''#%kernel) + (namespace-require ''#%unsafe) + (namespace-require ''#%flfxnum) + (namespace-require ''#%extfl) + (namespace-require ''#%futures) + (namespace-require ''#%foreign) + (namespace-require ''#%paramz) + (for/hasheq ([name (in-list (namespace-mapped-symbols))]) + (values (namespace-variable-value name #t (lambda () #f)) + name))))]) + (for/hash ([i (in-naturals)] + #:break (not (compiled-position->primitive i))) + (define v (compiled-position->primitive i)) + (values i (or (hash-ref value-names v #f) `',v))))) (define (list-ref/protect l pos who) (list-ref l pos) @@ -47,291 +42,194 @@ ;; ---------------------------------------- -(define-struct glob-desc (vars num-tls num-stxs num-lifts)) +(define-struct glob-desc (vars)) ;; Main entry: -(define (decompile top) - (let ([stx-ht (make-hasheq)]) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - (expose-module-path-indexes - `(begin - ,@defns - ,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht))))] - [else (error 'decompile "unrecognized: ~e" top)]))) - -(define (expose-module-path-indexes e) - ;; This is a nearly general replace-in-graph function. (It seems like a lot - ;; of work to expose module path index content and sharing, though.) - (define ht (make-hasheq)) - (define mconses null) - (define (x-mcons a b) - (define m (mcons a b)) - (set! mconses (cons (cons m (cons a b)) mconses)) - m) - (define main - (let loop ([e e]) - (cond - [(hash-ref ht e #f)] - [(module-path-index? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (define-values (name base) (module-path-index-split e)) - (placeholder-set! ph (x-mcons '#%modidx - (x-mcons (loop name) - (x-mcons (loop base) - null)))) - ph] - [(pair? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph (cons (loop (car e)) - (loop (cdr e)))) - ph] - [(mpair? e) - (define m (mcons #f #f)) - (hash-set! ht e m) - (set! mconses (cons (cons m (cons (loop (mcar e)) - (loop (mcdr e)))) - mconses)) - m] - [(box? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph (box (loop (unbox e)))) - ph] - [(vector? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph - (for/vector #:length (vector-length e) ([i (in-vector e)]) - (loop i))) - ph] - [(hash? e) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph - ((cond - [(hash-eq? ht) - make-hasheq-placeholder] - [(hash-eqv? ht) - make-hasheqv-placeholder] - [else make-hash-placeholder]) - (for/list ([(k v) (in-hash e)]) - (cons (loop k) (loop v))))) - ph] - [(prefab-struct-key e) - => (lambda (k) - (define ph (make-placeholder #f)) - (hash-set! ht e ph) - (placeholder-set! ph - (apply make-prefab-struct - k - (map loop - (cdr (vector->list (struct->vector e)))))) - ph)] - [else - e]))) - (define l (make-reader-graph (cons main mconses))) - (for ([i (in-list (cdr l))]) - (set-mcar! (car i) (cadr i)) - (set-mcdr! (car i) (cddr i))) - (car l)) - -(define (decompile-prefix a-prefix stx-ht) - (match a-prefix - [(struct prefix (num-lifts toplevels stxs src-insp-desc)) - (let ([lift-ids (for/list ([i (in-range num-lifts)]) - (gensym 'lift))] - [stx-ids (map (lambda (i) (gensym 'stx)) - stxs)]) - (values (glob-desc - (append - (map (lambda (tl) - (match tl - [#f '#%linkage] - [(? symbol?) (string->symbol (format "_~a" tl))] - [(struct global-bucket (name)) - (string->symbol (format "_~a" name))] - [(struct module-variable (modidx sym pos phase constantness)) - (if (and (module-path-index? modidx) - (let-values ([(n b) (module-path-index-split modidx)]) - (and (not n) (not b)))) - (string->symbol (format "_~a" sym)) - (string->symbol (format "_~s~a@~s~a" - sym - (match constantness - ['constant ":c"] - ['fixed ":f"] - [(function-shape a pm?) - (if pm? ":P" ":p")] - [(struct-type-shape c) ":t"] - [(constructor-shape a) ":mk"] - [(predicate-shape) ":?"] - [(accessor-shape c) ":ref"] - [(mutator-shape c) ":set!"] - [else ""]) - (mpi->string modidx) - (if (zero? phase) - "" - (format "/~a" phase)))))] - [else (error 'decompile-prefix "bad toplevel: ~e" tl)])) - toplevels) - stx-ids - (if (null? stx-ids) null '(#%stx-array)) - lift-ids) - (length toplevels) - (length stxs) - num-lifts) - (list* - `(quote inspector ,src-insp-desc) - ;; `(quote tls ,toplevels) - (map (lambda (stx id) - `(define ,id ,(if stx - `(#%decode-syntax - ,(decompile-stx (stx-content stx) stx-ht)) - #f))) - stxs stx-ids))))] - [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) - -(define (decompile-stx stx stx-ht) - (or (hash-ref stx-ht stx #f) - (let ([p (mcons #f #f)]) - (hash-set! stx-ht stx p) - (match stx - [(stx-obj datum wrap srcloc props tamper-status) - (set-mcar! p (case tamper-status - [(clean) 'wrap] - [(tainted) 'wrap-tainted] - [(armed) 'wrap-armed])) - (set-mcdr! p (mcons - (cond - [(pair? datum) - (cons (decompile-stx (car datum) stx-ht) - (let loop ([l (cdr datum)]) - (cond - [(null? l) null] - [(pair? l) - (cons (decompile-stx (car l) stx-ht) - (loop (cdr l)))] - [else - (decompile-stx l stx-ht)])))] - [(vector? datum) - (for/vector ([e (in-vector datum)]) - (decompile-stx e stx-ht))] - [(box? datum) - (box (decompile-stx (unbox datum) stx-ht))] - [else datum]) - (let* ([l (mcons wrap null)] - [l (if (hash-count props) - (mcons props l) - l)] - [l (if srcloc - (mcons srcloc l) - l)]) - l))) - p])))) - -(define (mpi->string modidx) +(define (decompile top #:to-linklets? [to-linklets? #f]) (cond - [(symbol? modidx) modidx] - [else - (collapse-module-path-index modidx)])) + [(linkl-directory? top) + (cond + [to-linklets? + (cons + 'linklet-directory + (apply + append + (for/list ([(k v) (in-hash (linkl-directory-table top))]) + (list '#:name k '#:bundle (decompile v #:to-linklets? to-linklets?)))))] + [else + (define main (hash-ref (linkl-directory-table top) '() #f)) + (unless main (error 'decompile "cannot find main module")) + (decompile-module-with-submodules top '() main)])] + [(linkl-bundle? top) + (cond + [to-linklets? + (cons + 'linklet-bundle + (apply + append + (for/list ([(k v) (in-hash (linkl-bundle-table top))]) + (case (and (not to-linklets?) k) + [(stx-data) + (list '#:stx-data (decompile-data-linklet v))] + [else + (list '#:key k '#:value (decompile v #:to-linklets? to-linklets?))]))))] + [else + (decompile-module top)])] + [(linkl? top) + (decompile-linklet top)] + [else `(quote ,top)])) -(define (decompile-module mod-form orig-stack stx-ht mod-name) - (match mod-form - [(struct mod (name srcname self-modidx - prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] - [(stack) (append '(#%modvars) orig-stack)] - [(closed) (make-hasheq)]) - `(,mod-name ,(if (symbol? name) name (last name)) .... - (quote self ,self-modidx) - (quote internal-context - ,(if (stx? internal-context) - `(#%decode-syntax - ,(decompile-stx (stx-content internal-context) stx-ht)) - internal-context)) - (quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)]) - (values phase - (for/hash ([(sym id) (in-hash ht)]) - (values sym - (if (eq? id #t) - #t - `(#%decode-syntax - ,(decompile-stx (stx-content id) stx-ht)))))))) - (quote language-info ,lang-info) - ,@(if (null? flags) '() (list `(quote ,flags))) - ,@(let ([l (apply - append - (for/list ([req (in-list requires)] - #:when (pair? (cdr req))) - (define l (for/list ([mpi (in-list (cdr req))]) - (define p (mpi->string mpi)) - (if (path? p) - (let ([d (current-load-relative-directory)]) - (path->string (if d - (find-relative-path (simplify-path d #t) - (simplify-path p #f) - #:more-than-root? #t) - p))) - p))) - (if (eq? 0 (car req)) - l - `((,@(case (car req) - [(#f) `(for-label)] - [(1) `(for-syntax)] - [else `(for-meta ,(car req))]) - ,@l)))))]) - (if (null? l) - null - `((require ,@l)))) - (provide ,@(apply - append - (for/list ([p (in-list provides)]) - (define phase (car p)) - (define l - (for/list ([pv (in-list (append (cadr p) (caddr p)))]) - (match pv - [(struct provided (name src src-name nom-src src-phase protected?)) - (define n (if (eq? name src-name) - name - `(rename-out [,src-name ,name]))) - (if protected? - `(protect-out ,n) - n)]))) - (if (or (null? l) (eq? phase 0)) - l - `((,@(case phase - [(#f) `(for-label)] - [(1) `(for-syntax)] - [else `(for-meta ,phase)]) - ,@l)))))) - ,@defns - ,@(for/list ([submod (in-list pre-submodules)]) - (decompile-module submod orig-stack stx-ht 'module)) - ,@(for/list ([b (in-list syntax-bodies)]) - (let loop ([n (sub1 (car b))]) - (if (zero? n) - (cons 'begin - (for/list ([form (in-list (cdr b))]) - (decompile-form form globs stack closed stx-ht))) - (list 'begin-for-syntax (loop (sub1 n)))))) - ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) - body) - ,@(for/list ([submod (in-list post-submodules)]) - (decompile-module submod orig-stack stx-ht 'module*))))] - [else (error 'decompile-module "huh?: ~e" mod-form)])) +(define (decompile-module-with-submodules l-dir name-list main-l) + (decompile-module main-l + (lambda () + (for/list ([(k l) (in-hash (linkl-directory-table l-dir))] + #:when (and (list? k) + (= (length k) (add1 (length name-list))) + (for/and ([s1 (in-list name-list)] + [s2 (in-list k)]) + (eq? s1 s2)))) + (decompile-module-with-submodules l-dir k l))))) -(define (decompile-form form globs stack closed stx-ht) +(define (decompile-module l [get-nested (lambda () '())]) + (define ht (linkl-bundle-table l)) + (define phases (sort (for/list ([k (in-hash-keys ht)] + #:when (exact-integer? k)) + k) + <)) + (define-values (mpi-vector requires provides) + (let ([data-l (hash-ref ht 'data #f)] + [decl-l (hash-ref ht 'decl #f)]) + (define (zo->linklet l) + (let ([o (open-output-bytes)]) + (zo-marshal-to (linkl-bundle (hasheq 'data l)) o) + (parameterize ([read-accept-compiled #t]) + (define b (read (open-input-bytes (get-output-bytes o)))) + (hash-ref (linklet-bundle->hash b) 'data)))) + (cond + [(and data-l + decl-l) + (define data-i (instantiate-linklet (zo->linklet data-l) + (list deserialize-instance))) + (define decl-i (instantiate-linklet (zo->linklet decl-l) + (list deserialize-instance + data-i))) + (values (instance-variable-value data-i '.mpi-vector) + (instance-variable-value decl-i 'requires) + (instance-variable-value decl-i 'provides))] + [else (values '#() '() '())]))) + (define (phase-wrap phase l) + (case phase + [(0) l] + [(1) `((for-syntax ,@l))] + [(-1) `((for-template ,@l))] + [(#f) `((for-label ,@l))] + [else `((for-meta ,phase ,@l))])) + `(module ,(hash-ref ht 'name 'unknown) .... + (require ,@(apply + append + (for/list ([phase+mpis (in-list requires)]) + (phase-wrap (car phase+mpis) + (map collapse-module-path-index (cdr phase+mpis)))))) + (provide ,@(apply + append + (for/list ([(phase ht) (in-hash provides)]) + (phase-wrap phase (hash-keys ht))))) + ,@(let loop ([phases phases] [depth 0]) + (cond + [(null? phases) '()] + [(= depth (car phases)) + (append + (decompile-linklet (hash-ref ht (car phases)) #:just-body? #t) + (loop (cdr phases) depth))] + [else + (define l (loop phases (add1 depth))) + (define (convert-syntax-definition s wrap) + (match s + [`(let ,bindings ,body) + (convert-syntax-definition body + (lambda (rhs) + `(let ,bindings + ,rhs)))] + [`(begin (.set-transformer! ',id ,rhs) ',(? void?)) + `(define-syntaxes ,id ,(wrap rhs))] + [`(begin (.set-transformer! ',ids ,rhss) ... ',(? void?)) + `(define-syntaxes ,ids ,(wrap `(values . ,rhss)))] + [_ #f])) + (let loop ([l l] [accum '()]) + (cond + [(null? l) (if (null? accum) + '() + `((begin-for-syntax ,@(reverse accum))))] + [(convert-syntax-definition (car l) values) + => (lambda (s) + (append (loop null accum) + (cons s (loop (cdr l) null))))] + [else + (loop (cdr l) (cons (car l) accum))]))])) + ,@(get-nested) + ,@(let ([l (hash-ref ht 'stx-data #f)]) + (if l + `((begin-for-all + (define (.get-syntax-literal! pos) + .... + ,(decompile-data-linklet l) + ....))) + null)))) + + +(define (decompile-linklet l #:just-body? [just-body? #f]) + (match l + [(struct linkl (name importss import-shapess exports internals lifts source-names body max-let-depth needs-instance?)) + (define closed (make-hasheq)) + (define globs (glob-desc + (append + (list 'root) + (apply append importss) + exports + internals + lifts))) + (define body-l + (for/list ([form (in-list body)]) + (decompile-form form globs '(#%globals) closed))) + (if just-body? + body-l + `(linklet + ,importss + ,exports + '(import-shapes: ,@(for/list ([imports (in-list importss)] + [import-shapes (in-list import-shapess)] + #:when #t + [import (in-list imports)] + [import-shape (in-list import-shapes)] + #:when import-shape) + `[,import ,import-shape])) + ,@body-l))])) + +(define (decompile-data-linklet l) + (match l + [(struct linkl (_ _ _ _ _ _ _ (list vec-def (struct def-values (_ deser-lam))) _ _)) + (match deser-lam + [(struct lam (_ _ _ _ _ _ _ _ _ (struct seq ((list vec-copy! _))))) + (match vec-copy! + [(struct application (_ (list _ _ (struct application (_ (list mpi-vector inspector bulk-binding-registry + num-mutables mutable-vec + num-shares share-vec + mutable-fill-vec + result-vec)))))) + (decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry + num-mutables mutable-vec + num-shares share-vec + mutable-fill-vec + result-vec)] + [else + (decompile-linklet l)])] + [else + (decompile-linklet l)])] + [else + (decompile-linklet l)])) + +(define (decompile-form form globs stack closed) (match form - [(? mod?) - (decompile-module form stack stx-ht 'module)] [(struct def-values (ids rhs)) `(define-values ,(map (lambda (tl) (match tl @@ -344,29 +242,10 @@ ,(decompile-expr (inline-variant-inline rhs) globs stack closed) ,(decompile-expr (inline-variant-direct rhs) globs stack closed)) (decompile-expr rhs globs stack closed)))] - [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) - `(define-syntaxes ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(let () - ,@defns - ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] - [(struct seq-for-syntax (exprs prefix max-let-depth dummy)) - `(begin-for-syntax - ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(let () - ,@defns - ,@(for/list ([rhs (in-list exprs)]) - (decompile-form rhs globs '(#%globals) closed stx-ht)))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) + (decompile-form form globs stack closed)) forms))] - [(struct splice (forms)) - `(begin ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) - forms))] - [(struct req (reqs dummy)) - `(#%require . (#%decode-syntax ,reqs))] [else (decompile-expr form globs stack closed)])) @@ -417,12 +296,12 @@ (match expr [(struct toplevel (depth pos const? ready?)) (decompile-tl expr globs stack closed #f)] - [(struct varref (tl dummy)) - `(#%variable-reference ,(if (eq? tl #t) - ' - (decompile-tl tl globs stack closed #t)))] - [(struct topsyntax (depth pos midpt)) - (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] + [(struct varref (tl dummy constant? from-unsafe?)) + `(#%variable-reference . ,(cond + [(not tl) '()] + [(eq? tl #t) '()] + [(symbol? tl) (list tl)] ; primitive + [else (list (decompile-tl tl globs stack closed #t))]))] [(struct primval (id)) (hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))] [(struct assign (id rhs undef-ok?)) @@ -558,20 +437,9 @@ '() (list (for/list ([pos (in-list (sort (set->list tl-map) <))]) - (define tl-pos - (cond - [(or (pos . < . (glob-desc-num-tls globs)) - (zero? (glob-desc-num-stxs globs))) - pos] - [(= pos (glob-desc-num-tls globs)) - 'stx] - [else - (+ pos (glob-desc-num-stxs globs))])) - (if (eq? tl-pos 'stx) - '#%syntax - (list-ref/protect (glob-desc-vars globs) - tl-pos - 'lam)))))))) + (list-ref/protect (glob-desc-vars globs) + pos + 'lam))))))) ,(decompile-expr body globs (append captures (append vars rest-vars)) @@ -585,6 +453,249 @@ ;; ---------------------------------------- +(define (decompile-deserialize mpis inspector bulk-binding-registry + num-mutables mutable-vec + num-shares share-vec + mutable-fill-vec + result-vec) + ;; Names for shared values: + (define shared (for/vector ([i (in-range (+ num-mutables num-shares))]) + (string->symbol (format "~a:~a" + (if (i . < . num-mutables) + 'mutable + 'shared) + i)))) + (define (infer-name! d i) + (when (pair? d) + (define new-name + (case (car d) + [(deserialize-scope) 'scope] + [(srcloc) 'srcloc] + [else #f])) + (when new-name + (vector-set! shared i (string->symbol (format "~a:~a" new-name i)))))) + + (define mutables (make-vector num-mutables #f)) + ;; Make mutable shells + (for/fold ([pos 0]) ([i (in-range num-mutables)]) + (define-values (d next-pos) + (decode-shell mutable-vec pos mpis inspector bulk-binding-registry shared)) + (vector-set! mutables i d) + (infer-name! d i) + next-pos) + + ;; Construct shared values + (define shareds (make-vector num-shares #f)) + (for/fold ([pos 0]) ([i (in-range num-shares)]) + (define-values (d next-pos) + (decode share-vec pos mpis inspector bulk-binding-registry shared)) + (vector-set! shareds i d) + (infer-name! d (+ i num-mutables)) + next-pos) + + ;; Fill in mutable shells + (define-values (fill-pos rev-fills) + (for/fold ([pos 0] [rev-fills null]) ([i (in-range num-mutables)] + [v (in-vector shared)]) + (define-values (fill next-pos) + (decode-fill! v mutable-fill-vec pos mpis inspector bulk-binding-registry shared)) + (values next-pos (if fill + (cons fill rev-fills) + rev-fills)))) + + ;; Construct the final result + (define-values (result done-pos) + (decode result-vec 0 mpis inspector bulk-binding-registry shared)) + + `(let (,(for/list ([i (in-range num-mutables)]) + `(,(vector-ref shared i) ,(vector-ref mutables i)))) + (let* (,(for/list ([i (in-range num-shares)]) + `(,(vector-ref shared (+ i num-mutables)) ,(vector-ref shareds i)))) + ,@(reverse rev-fills) + ,result))) + +;; Decode the construction of a mutable variable +(define (decode-shell vec pos mpis inspector bulk-binding-registry shared) + (case (vector-ref vec pos) + [(#:box) (values (list 'box #f) (add1 pos))] + [(#:vector) (values `(make-vector ,(vector-ref vec (add1 pos))) (+ pos 2))] + [(#:hash) (values (list 'make-hasheq) (add1 pos))] + [(#:hasheq) (values (list 'make-hasheq) (add1 pos))] + [(#:hasheqv) (values (list 'make-hasheqv) (add1 pos))] + [else (decode vec pos mpis inspector bulk-binding-registry shared)])) + +;; The decoder that is used for most purposes +(define (decode vec pos mpis inspector bulk-binding-registry shared) + (define-syntax decodes + (syntax-rules () + [(_ (id ...) rhs) (decodes #:pos (add1 pos) (id ...) rhs)] + [(_ #:pos pos () rhs) (values rhs pos)] + [(_ #:pos pos ([#:ref id0] id ...) rhs) + (let-values ([(id0 next-pos) (let ([i (vector-ref vec pos)]) + (if (exact-integer? i) + (values (vector-ref shared i) (add1 pos)) + (decode vec pos mpis inspector bulk-binding-registry shared)))]) + (decodes #:pos next-pos (id ...) rhs))] + [(_ #:pos pos (id0 id ...) rhs) + (let-values ([(id0 next-pos) (decode vec pos mpis inspector bulk-binding-registry shared)]) + (decodes #:pos next-pos (id ...) rhs))])) + (define-syntax-rule (decode* (deser id ...)) + (decodes (id ...) `(deser ,id ...))) + (case (vector-ref vec pos) + [(#:ref) + (values (vector-ref shared (vector-ref vec (add1 pos))) + (+ pos 2))] + [(#:inspector) (values inspector (add1 pos))] + [(#:bulk-binding-registry) (values bulk-binding-registry (add1 pos))] + [(#:syntax #:datum->syntax) + (decodes + (content [#:ref context] [#:ref srcloc]) + `(deserialize-syntax + ,content + ,context + ,srcloc + #f + #f + ,inspector))] + [(#:syntax+props) + (decodes + (content [#:ref context] [#:ref srcloc] props tamper) + `(deserialize-syntax + ,content + ,context + ,srcloc + ,props + ,tamper + ,inspector))] + [(#:srcloc) + (decode* (srcloc source line column position span))] + [(#:quote) + (values (vector-ref vec (add1 pos)) (+ pos 2))] + [(#:mpi) + (values `(vector-ref ,mpis ,(vector-ref vec (add1 pos))) + (+ pos 2))] + [(#:box) + (decode* (box-immutable v))] + [(#:cons) + (decode* (cons a d))] + [(#:list #:vector #:set #:seteq #:seteqv) + (define len (vector-ref vec (add1 pos))) + (define r (make-vector len)) + (define next-pos + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (v next-pos) (decodes #:pos pos (v) v)) + (vector-set! r i v) + next-pos)) + (values `(,(case (vector-ref vec pos) + [(#:list) 'list] + [(#:vector) 'vector] + [(#:set) 'set] + [(#:seteq) 'seteq] + [(#:seteqv) 'seteqv]) + ,@(vector->list r)) + next-pos)] + [(#:hash #:hasheq #:hasheqv) + (define len (vector-ref vec (add1 pos))) + (define-values (l next-pos) + (for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)]) + (decodes #:pos pos (k v) (list* v k l)))) + (values `(,(case (vector-ref vec pos) + [(#:hash) 'hash] + [(#:hasheq) 'hasheq] + [(#:hasheqv) 'hasheqv]) + ,@(reverse l)) + next-pos)] + [(#:prefab) + (define-values (key next-pos) (decodes #:pos (add1 pos) (k) k)) + (define len (vector-ref vec next-pos)) + (define-values (r done-pos) + (for/fold ([r null] [pos (add1 next-pos)]) ([i (in-range len)]) + (decodes #:pos pos (v) (cons v r)))) + (values `(make-prefab-struct ',key ,@(reverse r)) + done-pos)] + [(#:scope) + (decode* (deserialize-scope))] + [(#:scope+kind) + (decode* (deserialize-scope kind))] + [(#:multi-scope) + (decode* (deserialize-multi-scope name scopes))] + [(#:shifted-multi-scope) + (decode* (deserialize-shifted-multi-scope phase multi-scope))] + [(#:table-with-bulk-bindings) + (decode* (deserialize-table-with-bulk-bindings syms bulk-bindings))] + [(#:bulk-binding-at) + (decode* (deserialize-bulk-binding-at scopes bulk))] + [(#:representative-scope) + (decode* (deserialize-representative-scope kind phase))] + [(#:module-binding) + (decode* (deserialize-full-module-binding + module sym phase + nominal-module + nominal-phase + nominal-sym + nominal-require-phase + free=id + extra-inspector + extra-nominal-bindings))] + [(#:simple-module-binding) + (decode* (deserialize-simple-module-binding module sym phase nominal-module))] + [(#:local-binding) + (decode* (deserialize-full-local-binding key free=id))] + [(#:bulk-binding) + (decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))] + [(#:provided) + (decode* (deserialize-provided binding protected? syntax?))] + [else + (values `(quote ,(vector-ref vec pos)) (add1 pos))])) + +;; Decode the filling of mutable values, which has its own encoding +;; variant +(define (decode-fill! v vec pos mpis inspector bulk-binding-registry shared) + (case (vector-ref vec pos) + [(#f) (values #f (add1 pos))] + [(#:set-box!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (values `(set-box! ,v ,c) + next-pos)] + [(#:set-vector!) + (define len (vector-ref vec (add1 pos))) + (define-values (l next-pos) + (for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)]) + (define-values (c next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (values (cons `(vector-set! ,v ,i ,c) l) + next-pos))) + (values `(begin ,@(reverse l)) next-pos)] + [(#:set-hash!) + (define len (vector-ref vec (add1 pos))) + (define-values (l next-pos) + (for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)]) + (define-values (key next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (define-values (val done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (values (cons `(hash-set! ,v ,key ,val) l) + done-pos))) + (values `(begin ,@(reverse l)) next-pos)] + [(#:scope-fill!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (values `(deserialize-scope-fill! ,v ,c) + next-pos)] + [(#:representative-scope-fill!) + (define-values (a next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (define-values (d done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (values `(deserialize-representative-scope-fill! ,v ,a ,d) + done-pos)] + [else + (error 'deserialize "bad fill encoding: ~v" (vector-ref vec pos))])) + + +;; ---------------------------------------- + #; (begin (require scheme/pretty) diff --git a/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt b/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt deleted file mode 100644 index 63dc5508a8..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/alpha.rkt +++ /dev/null @@ -1,20 +0,0 @@ -#lang racket/base - -(require racket/match racket/contract compiler/zo-parse) - -(define (alpha-vary-ctop top) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (make-compilation-top max-let-depth binding-namess (alpha-vary-prefix prefix) form)])) -(define (alpha-vary-prefix p) - (struct-copy prefix p - [toplevels - (map (match-lambda - [(and sym (? symbol?)) - (gensym sym)] - [other - other]) - (prefix-toplevels p))])) - -(provide/contract - [alpha-vary-ctop (compilation-top? . -> . compilation-top?)]) diff --git a/pkgs/compiler-lib/compiler/demodularizer/batch.rkt b/pkgs/compiler-lib/compiler/demodularizer/batch.rkt index 47e6d3b0d1..9d869b5481 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/batch.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/batch.rkt @@ -1,50 +1,9 @@ #lang racket/base - -#| -Here's the idea: - -- Take a module's bytecode -- Recursively get all the bytecode for modules that the target requires -- After reading it, prune everything that isn't at phase 0 (the runtime phase) - -- Now that we have all the modules, the next step is to merge them into a single - module --- Although actually we collapse them into the top-level, not a module -- To do that, we iterate through all the modules doing two things as we go: --- Incrementing all the global variable references by all the references in all - the modules ---- So if A has 5, then B's start at index 5 and so on --- Replacing module variable references with the actual global variables - corresponding to those variables ---- So if A's variable 'x' is in global slot 4, then if B refers to it, it - directly uses slot 4, rather than a module-variable slot - -- At that point we have all the module code in a single top-level, but many - toplevels won't be used because a library function isn't really used -- So, we do a "garbage collection" on elements of the prefix -- First, we create a dependency graph of all toplevels and the initial scope -- Then, we do a DFS on the initial scope and keep all those toplevels, throwing - away the construction of everything else - [XXX: This may be broken because of side-effects.] - -- Now we have a small amount code, but because we want to go back to source, - we need to fix it up a bit; because different modules may've used the same - names -- So, we do alpha-renaming, but it's easy because names are only used in the - compilation-top prefix structure - -[TODO] - -- Next, we decompile -- Then, it will pay to do dead code elimination and inlining, etc. -|# - (require racket/cmdline racket/set raco/command-name "main.rkt") - (let ([output-file (make-parameter #f)]) (command-line #:program (short-program+command-name) #:multi diff --git a/pkgs/compiler-lib/compiler/demodularizer/bundle.rkt b/pkgs/compiler-lib/compiler/demodularizer/bundle.rkt new file mode 100644 index 0000000000..d085f4ea01 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/bundle.rkt @@ -0,0 +1,169 @@ +#lang racket/base +(require (only-in '#%linklet primitive->compiled-position) + racket/set + compiler/zo-structs + "run.rkt" + "name.rkt") + +(provide wrap-bundle) + +(define (wrap-bundle body internals lifts excluded-module-mpis get-merge-info) + (define-values (runs + import-keys + ordered-importss + import-shapess + any-syntax-literals? + any-transformer-registers? + saw-zero-pos-toplevel?) + (get-merge-info)) + + (define module-name 'demodularized) + (define (primitive v) + (primval (or (primitive->compiled-position v) + (error "cannot find primitive" v)))) + + (define new-linkl + (linkl module-name + (list* (if any-syntax-literals? '(.get-syntax-literal!) '()) + (if any-transformer-registers? '(.set-transformer!) '()) + ordered-importss) + (list* (if any-syntax-literals? (list (function-shape 1 #f)) '()) + (if any-transformer-registers? (list (function-shape 2 #f)) '()) + import-shapess) + '() ; exports + internals + lifts + #hasheq() + body + (for/fold ([m 0]) ([r (in-list runs)]) + (max m (linkl-max-let-depth (run-linkl r)))) + saw-zero-pos-toplevel?)) + + (define data-linkl + (linkl 'data + '((deserialize-module-path-indexes)) + '((#f)) + '(.mpi-vector) + '() + '() + #hasheq() + (list + (def-values (list (toplevel 0 2 #f #f)) ; .mpi-vector + (application (toplevel 2 1 #f #f) ; deserialize-module-path-indexes + ;; Construct two vectors: one for mpi construction, and + ;; another for selecting the slots that are externally referenced + ;; mpis (where the selection vector matches th `import-keys` order). + ;; If all import keys are primitive modules, then we just make + ;; a vector with those specs in order, but if there's a more + ;; complex mpi, then we have to insert extra slots in the first + ;; vector to hold intermediate mpi constructions. + ;; We could do better here by sharing common tails. + (let loop ([import-keys import-keys] + [specs (list (box module-name))] + [results (list 0)]) + (cond + [(null? import-keys) + (list (list->vector (reverse specs)) + (list->vector (reverse results)))] + [else + (define path/submod+phase (car import-keys)) + (define path (car path/submod+phase)) + (cond + [(symbol? path) + (loop (cdr import-keys) + (cons (vector `(quote ,path)) specs) + (cons (length specs) results))] + [(path? path) + (define-values (i new-specs) + (begin + (let mpi-loop ([mpi (hash-ref excluded-module-mpis path)]) + (define-values (name base) (module-path-index-split mpi)) + (cond + [(and (not name) (not base)) + (values 0 specs)] + [(not base) + (values (length specs) (cons (vector name) specs))] + [else + (define-values (next-i next-specs) (mpi-loop base)) + (values (length next-specs) (cons (vector name next-i) next-specs))])))) + (loop (cdr import-keys) + new-specs + (cons i results))] + [else + (error 'wrap-bundle "unrecognized import path shape: ~s" path)])]))))) + 16 + #f)) + + (define decl-linkl + (let ([deserialize-pos 1] + [module-use-pos 2] + [mpi-vector-pos 3] + [exports-pos 4]) + (linkl 'decl + '((deserialize + module-use) + (.mpi-vector)) + '((#f) + (#f)) + '(self-mpi requires provides phase-to-link-modules) + '() + '() + #hasheq() + (list + (def-values (list (toplevel 0 (+ exports-pos 0) #f #f)) ; .self-mpi + (application (primitive vector-ref) + (list (toplevel 2 mpi-vector-pos #f #f) + '0))) + (def-values (list (toplevel 0 (+ exports-pos 1) #f #f)) ; requires + (let ([arg-count 9]) + (application (toplevel arg-count deserialize-pos #f #f) + (list + (toplevel arg-count mpi-vector-pos #f #f) + #f #f 0 '#() 0 '#() '#() + (list->vector + (let loop ([phases (sort (set->list + (for/set ([path/submod+phase (in-list import-keys)]) + (cdr path/submod+phase))) + <)]) + (cond + [(null? phases) (list '())] + [else + (define phase (car phases)) + (define n (for/sum ([path/submod+phase (in-list import-keys)]) + (if (eqv? phase (cdr path/submod+phase)) 1 0))) + (append `(#:cons #:list ,(add1 n) ,(- 0 phase)) + (apply + append + (for/list ([path/submod+phase (in-list import-keys)] + [i (in-naturals 1)] + #:when (eqv? phase (cdr path/submod+phase))) + `(#:mpi ,i))) + (loop (cdr phases)))]))))))) + (def-values (list (toplevel 0 (+ exports-pos 2) #f #f)) ; provides + (application (primitive hasheqv) null)) + (def-values (list (toplevel 0 (+ exports-pos 3) #f #f)) ; phase-to-link-modules + (let ([depth 2]) + (application (primitive hasheqv) + (list 0 + (let ([depth (+ depth (length import-keys))]) + (application (primitive list) + (for/list ([path/submod+phase (in-list import-keys)] + [i (in-naturals 1)]) + (let ([depth (+ depth 2)]) + (application (toplevel depth module-use-pos #f #f) + (list + (let ([depth (+ depth 2)]) + (application (primitive vector-ref) + (list + (toplevel depth mpi-vector-pos #f #f) + i))) + (cdr path/submod+phase)))))))))))) + (+ 32 (length import-keys)) + #f))) + + ;; By not including a 'stx-data linklet, we get a default + ;; linklet that supplies #f for any syntax-literal reference. + + (linkl-bundle (hasheq 0 new-linkl + 'data data-linkl + 'decl decl-linkl))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/find.rkt b/pkgs/compiler-lib/compiler/demodularizer/find.rkt new file mode 100644 index 0000000000..826c08bba1 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/find.rkt @@ -0,0 +1,164 @@ +#lang racket/base +(require racket/set + compiler/zo-parse + syntax/modcode + racket/linklet + "../private/deserialize.rkt" + "module-path.rkt" + "run.rkt") + +(provide find-modules + current-excluded-modules) + +(struct mod (compiled zo)) ; includes submodules; `zo` is #f for excluded +(struct one-mod (compiled zo decl)) ; module without submodules + +(define current-excluded-modules (make-parameter (set))) + +(define (find-modules orig-path #:submodule [submod '()]) + (define mods (make-hash)) ; path -> mod + (define one-mods (make-hash)) ; path+submod -> one-mod + (define runs-done (make-hash)) ; path+submod+phase -> #t + (define runs null) ; list of `run` + (define excluded-module-mpis (make-hash)) ; path -> mpi + + (define (find-modules! orig-path+submod exclude?) + (define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod)) + (define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '())) + (define path (normal-case-path (simplify-path (path->complete-path orig-path)))) + + (unless (hash-ref mods path #f) + (define-values (zo-path kind) (get-module-path path)) + (unless (eq? kind 'zo) + (error 'demodularize "not available in bytecode form\n path: ~a" path)) + (define zo (and (not exclude?) + (call-with-input-file zo-path zo-parse))) + (define compiled (parameterize ([read-accept-compiled #t] + [current-load-relative-directory + (let-values ([(dir file-name dir?) (split-path path)]) + dir)]) + (call-with-input-file zo-path read))) + (hash-set! mods path (mod compiled zo))) + + (unless (hash-ref one-mods (cons path submod) #f) + (define m (hash-ref mods path)) + (define compiled (mod-compiled m)) + (define zo (mod-zo m)) + + (define (raise-no-submod) + (error 'demodularize "no such submodule\n path: ~a\n submod: ~a" + path submod)) + (define one-compiled + (let loop ([compiled compiled] [submod submod]) + (cond + [(linklet-bundle? compiled) + (unless (null? submod) (raise-no-submod)) + compiled] + [else + (cond + [(null? submod) + (or (hash-ref (linklet-directory->hash compiled) #f #f) + (raise-no-submod))] + [else + (loop (or (hash-ref (linklet-directory->hash compiled) (car submod) #f) + (raise-no-submod)) + (cdr submod))])]))) + (define one-zo + (cond + [(not zo) #f] + [(linkl-bundle? zo) + (unless (null? submod) (raise-no-submod)) + zo] + [else + (or (hash-ref (linkl-directory-table zo) submod #f) + (raise-no-submod))])) + + (define h (linklet-bundle->hash one-compiled)) + (define data-linklet (hash-ref h 'data #f)) + (define decl-linklet (hash-ref h 'decl #f)) + (unless data-linklet + (error 'demodularize "could not find module path metadata\n path: ~a\n submod: ~a" + path submod)) + (unless decl-linklet + (error 'demodularize "could not find module metadata\n path: ~a\n submod: ~a" + path submod)) + + (define data-instance (instantiate-linklet data-linklet + (list deserialize-instance))) + (define decl (instantiate-linklet decl-linklet + (list deserialize-instance + data-instance))) + + (hash-set! one-mods (cons path submod) (one-mod one-compiled one-zo decl)) + + ;; Transitive requires + + (define reqs (instance-variable-value decl 'requires)) + + (for ([phase+reqs (in-list reqs)] + #:when (car phase+reqs) + [req (in-list (cdr phase+reqs))]) + (define path/submod (module-path-index->path req path submod)) + (define req-path (if (pair? path/submod) (car path/submod) path/submod)) + (unless (symbol? req-path) + (find-modules! path/submod + ;; Even if this module is excluded, traverse it to get all + ;; modules that it requires, so that we don't duplicate those + ;; modules by accessing them directly + (or exclude? (set-member? (current-excluded-modules) req-path))))))) + + (define (find-phase-runs! orig-path+submod orig-mpi #:phase [phase 0]) + (define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod)) + (define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '())) + (define path (normal-case-path (simplify-path (path->complete-path orig-path)))) + (define path/submod (if (pair? submod) (cons path submod) path)) + + (unless (hash-ref runs-done (cons (cons path submod) phase) #f) + (define one-m (hash-ref one-mods (cons path submod) #f)) + (when (one-mod-zo one-m) ; not excluded + (define decl (one-mod-decl one-m)) + + (define linkl (hash-ref (linkl-bundle-table (one-mod-zo one-m)) phase #f)) + (define uses + (list* + ;; The first implicit import might get used for syntax literals; + ;; recognize it with a 'syntax-literals "phase" + (cons path/submod 'syntax-literals) + ;; The second implicit import might get used to register a macro; + ;; we'll map those registrations to the same implicit import: + '(#%transformer-register . transformer-register) + (for/list ([u (hash-ref (instance-variable-value decl 'phase-to-link-modules) + phase + null)]) + (define path/submod (module-path-index->path (module-use-module u) path submod)) + + ;; In case the import turns out to stay imported: + (define req-path (if (pair? path/submod) (car path/submod) path/submod)) + (hash-set! excluded-module-mpis req-path (module-path-index-reroot (module-use-module u) orig-mpi)) + + (cons path/submod (module-use-phase u))))) + + (define r (run (if (null? submod) path (cons path submod)) phase linkl uses)) + (hash-set! runs-done (cons (cons path submod) phase) #t) + + (define reqs (instance-variable-value decl 'requires)) + (for* ([phase+reqs (in-list reqs)] + #:when (car phase+reqs) + [req (in-list (cdr phase+reqs))]) + (define at-phase (- phase (car phase+reqs))) + (define path/submod (module-path-index->path req path submod)) + (define full-mpi (module-path-index-reroot req orig-mpi)) + (define req-path (if (pair? path/submod) (car path/submod) path/submod)) + (unless (or (symbol? req-path) + (set-member? (current-excluded-modules) req-path)) + (find-phase-runs! path/submod full-mpi #:phase at-phase))) + + ;; Adding after requires, so that `runs` ends up in the + ;; reverse order that we want to emit code + (when linkl (set! runs (cons r runs)))))) + + (find-modules! (cons orig-path submod) #f) + (find-phase-runs! (cons orig-path submod) (module-path-index-join #f #f)) + + (values (reverse runs) + excluded-module-mpis)) diff --git a/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt b/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt deleted file mode 100644 index 6f4987bd2d..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt +++ /dev/null @@ -1,288 +0,0 @@ -#lang racket/base - -(require racket/match - racket/list - racket/dict - racket/contract - compiler/zo-parse - "util.rkt") - -; XXX Use efficient set structure -(define (gc-toplevels top) - (match top - [(struct compilation-top (max-let-depth binding-namess top-prefix form)) - (define lift-start - (prefix-lift-start top-prefix)) - (define max-depgraph-index - (+ (prefix-num-lifts top-prefix) - lift-start)) - (define top-node max-depgraph-index) - (define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty))) - (define build-graph! (make-build-graph! DEP-GRAPH)) - (define _void (build-graph! (list top-node) form)) - (define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node)) - (define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node - (define ordered-stxs (sort stxs <=)) - (define (lift? i) (lift-start . <= . i)) - (define-values (lifts normal-tls) (partition lift? ordered-used-tls)) - (define new-prefix - (make-prefix - (length lifts) - (for/list ([i normal-tls]) - (list-ref (prefix-toplevels top-prefix) i)) - (for/list ([i ordered-stxs]) - (list-ref (prefix-stxs top-prefix) i)))) - (define new-lift-start - (prefix-lift-start new-prefix)) - ; XXX This probably breaks max-let-depth - (define new-form - ((gc-toplevels-form - (lambda (pos) (index<=? pos ordered-used-tls)) - (lambda (pos) - (if (lift? pos) - (+ new-lift-start (index<=? pos lifts)) - (index<=? pos normal-tls))) - (lambda (stx-pos) - (index<=? stx-pos ordered-stxs)) - (prefix-syntax-start new-prefix)) - form)) - (log-debug (format "Total TLS: ~S" (length normal-tls))) - (log-debug (format "Used TLS: ~S" normal-tls)) - (log-debug (format "Total lifts: ~S" (length lifts))) - (log-debug (format "Used lifts: ~S" lifts)) - (log-debug (format "Total stxs: ~S" (length stxs))) - (log-debug (format "Used stxs: ~S" ordered-stxs)) - (make-compilation-top - max-let-depth - #hash() - new-prefix - new-form)])) - -(define-struct refs (tl stx) #:transparent) - -(define (make-build-graph! DEP-GRAPH) - (define (build-graph!* form lhs) - (match form - [(struct def-values (ids rhs)) - (define new-lhs (map toplevel-pos ids)) - ; If we require one, we should require all, so make them reference each other - (for-each (lambda (tl) (build-graph! new-lhs tl)) ids) - (build-graph! new-lhs rhs)] - [(? def-syntaxes?) - (error 'build-graph "Doesn't handle syntax")] - [(? seq-for-syntax?) - (error 'build-graph "Doesn't handle syntax")] - [(struct inline-variant (direct inline)) - (build-graph! lhs direct)] - [(struct req (reqs dummy)) - (build-graph! lhs dummy)] - [(? mod?) - (error 'build-graph "Doesn't handle modules")] - [(struct seq (forms)) - (for-each (lambda (f) (build-graph! lhs f)) forms)] - [(struct splice (forms)) - (for-each (lambda (f) (build-graph! lhs f)) forms)] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) - (build-graph! lhs body)] - [(and c (struct closure (code gen-id))) - (build-graph! lhs code)] - [(and cl (struct case-lam (name clauses))) - (for-each (lambda (l) (build-graph! lhs l)) - clauses)] - [(struct let-one (rhs body flonum? unused?)) - (build-graph! lhs rhs) - (build-graph! lhs body)] - [(and f (struct let-void (count boxes? body))) - (build-graph! lhs body)] - [(and f (struct install-value (_ _ _ rhs body))) - (build-graph! lhs rhs) - (build-graph! lhs body)] - [(struct let-rec (procs body)) - (for-each (lambda (l) (build-graph! lhs l)) procs) - (build-graph! lhs body)] - [(and f (struct boxenv (_ body))) - (build-graph! lhs body)] - [(and f (struct toplevel (_ pos _ _))) - (for-each (lambda (lhs) - (dict-update! DEP-GRAPH lhs - (match-lambda - [(struct refs (tls stxs)) - (make-refs (list* pos tls) stxs)]))) - lhs)] - [(and f (struct topsyntax (_ pos _))) - (for-each (lambda (lhs) - (dict-update! DEP-GRAPH lhs - (match-lambda - [(struct refs (tls stxs)) - (make-refs tls (list* pos stxs))]))) - lhs)] - [(struct application (rator rands)) - (for-each (lambda (f) (build-graph! lhs f)) - (list* rator rands))] - [(struct branch (test then else)) - (for-each (lambda (f) (build-graph! lhs f)) - (list test then else))] - [(struct with-cont-mark (key val body)) - (for-each (lambda (f) (build-graph! lhs f)) - (list key val body))] - [(struct with-immed-mark (key val body)) - (for-each (lambda (f) (build-graph! lhs f)) - (list key val body))] - [(struct beg0 (seq)) - (for-each (lambda (f) (build-graph! lhs f)) - seq)] - [(struct varref (tl dummy)) - (build-graph! lhs tl) - (build-graph! lhs dummy)] - [(and f (struct assign (id rhs undef-ok?))) - (build-graph! lhs id) - (build-graph! lhs rhs)] - [(struct apply-values (proc args-expr)) - (build-graph! lhs proc) - (build-graph! lhs args-expr)] - [(and f (struct primval (id))) - (void)] - [(and f (struct localref (unbox? pos clear? other-clears? type))) - (void)] - [(and v (not (? form?))) - (void)])) - (define-values (first-build-graph!** build-graph!**) - (build-form-memo build-graph!* #:void? #t)) - (define (build-graph! lhs form) (first-build-graph!** form lhs)) - build-graph!) - -(define (graph-dfs g start-node) - (define visited? (make-hasheq)) - (define (visit-tl n tls stxs) - (if (hash-has-key? visited? n) - (values tls stxs) - (match (dict-ref g n) - [(struct refs (n-tls n-stxs)) - (hash-set! visited? n #t) - (define-values (new-tls1 new-stxs1) - (for/fold ([new-tls tls] - [new-stxs stxs]) - ([tl (in-list n-tls)]) - (visit-tl tl new-tls new-stxs))) - (define new-stxs2 - (for/fold ([new-stxs new-stxs1]) - ([stx (in-list n-stxs)]) - (define this-stx (visit-stx stx)) - (if this-stx - (list* this-stx new-stxs) - new-stxs))) - (values (list* n new-tls1) - new-stxs2)]))) - (define stx-visited? (make-hasheq)) - (define (visit-stx n) - (if (hash-has-key? stx-visited? n) - #f - (begin (hash-set! stx-visited? n #t) - n))) - (visit-tl start-node empty empty)) - -; index<=? : number? (listof number?) -> (or/c number? false/c) -; returns the index of n in l and assumes that l is sorted by <= -(define (index<=? n l) - (match l - [(list) #f] - [(list-rest f l) - (cond - [(= n f) - 0] - [(< n f) - #f] - [else - (let ([rec (index<=? n l)]) - (if rec (add1 rec) rec))])])) - -(define (identity x) x) -(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt) - (define (inner-update form) - (match form - [(struct def-values (ids rhs)) - (if (ormap (compose keep? toplevel-pos) ids) - (make-def-values (map update ids) - (update rhs)) - #f)] - [(? def-syntaxes?) - (error 'gc-tls "Doesn't handle syntax")] - [(? seq-for-syntax?) - (error 'gc-tls "Doesn't handle syntax")] - [(struct req (reqs dummy)) - (make-req reqs (update dummy))] - [(? mod?) - (error 'gc-tls "Doesn't handle modules")] - [(struct seq (forms)) - (make-seq (filter identity (map update forms)))] - [(struct splice (forms)) - (make-splice (filter identity (map update forms)))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) - (struct-copy lam l - [toplevel-map #f] ; consevrative - [body (update body)])] - [(and c (struct closure (code gen-id))) - (struct-copy closure c - [code (update code)])] - [(and cl (struct case-lam (name clauses))) - (struct-copy case-lam cl - [clauses (map update clauses)])] - [(struct let-one (rhs body type unused?)) - (make-let-one (update rhs) (update body) type unused?)] - [(and f (struct let-void (count boxes? body))) - (struct-copy let-void f - [body (update body)])] - [(and f (struct install-value (_ _ _ rhs body))) - (struct-copy install-value f - [rhs (update rhs)] - [body (update body)])] - [(struct let-rec (procs body)) - (make-let-rec (map update procs) (update body))] - [(and f (struct boxenv (_ body))) - (struct-copy boxenv f [body (update body)])] - [(and f (struct toplevel (_ pos _ _))) - (struct-copy toplevel f - [pos (update-tl pos)])] - [(and f (struct topsyntax (_ pos _))) - (struct-copy topsyntax f - [pos (update-ts pos)] - [midpt new-ts-midpt])] - [(struct application (rator rands)) - (make-application - (update rator) - (map update rands))] - [(struct branch (test then else)) - (make-branch - (update test) - (update then) - (update else))] - [(struct with-cont-mark (key val body)) - (make-with-cont-mark - (update key) - (update val) - (update body))] - [(struct beg0 (seq)) - (make-beg0 (map update seq))] - [(struct varref (tl dummy)) - (make-varref (update tl) (update dummy))] - [(and f (struct assign (id rhs undef-ok?))) - (struct-copy assign f - [id (update id)] - [rhs (update rhs)])] - [(struct apply-values (proc args-expr)) - (make-apply-values - (update proc) - (update args-expr))] - [(and f (struct primval (id))) - f] - [(and f (struct localref (unbox? pos clear? other-clears? type))) - f] - [(and v (not (? form?))) - v] - )) - (define-values (first-update update) - (build-form-memo inner-update)) - first-update) - -(provide/contract - [gc-toplevels (compilation-top? . -> . compilation-top?)]) diff --git a/pkgs/compiler-lib/compiler/demodularizer/gc.rkt b/pkgs/compiler-lib/compiler/demodularizer/gc.rkt new file mode 100644 index 0000000000..a2c1fad191 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/gc.rkt @@ -0,0 +1,164 @@ +#lang racket/base +(require racket/match + racket/set + compiler/zo-structs + "remap.rkt") + +;; Prune unnused definitions, +;; * soundly, with a simple approximation of `pure?`, by default +;; * unsoundly, assuming all definitions are pure, optionally + +(provide gc-definitions) + +(define (gc-definitions body internals lifts internals-pos + #:assume-pure? assume-pure?) + (define used (make-hasheqv)) ; pos -> 'used or thunk + (define graph (make-hasheq)) + + (define (used-pos! pos) + (when (pos . >= . internals-pos) + (define v (hash-ref used pos #f)) + (hash-set! used pos 'used) + (when (procedure? v) + (v)))) + + (define (used! b) + (match b + [(toplevel depth pos const? ready?) + (used-pos! pos)] + [(inline-variant direct inline) + (used! direct) + (used! inline)] + [(closure code gen-id) + (unless (hash-ref graph gen-id #f) + (hash-set! graph gen-id #t) + (used! code))] + [(let-one rhs body type unused?) + (used! rhs) + (used! body)] + [(let-void count boxes? body) + (used! body)] + [(install-value count pos boxes? rhs body) + (used! rhs) + (used! body)] + [(let-rec procs body) + (for-each used! procs) + (used! body)] + [(boxenv pos body) + (used! body)] + [(application rator rands) + (used! rator) + (for-each used! rands)] + [(branch tst thn els) + (used! tst) + (used! thn) + (used! els)] + [(with-cont-mark key val body) + (used! key) + (used! val) + (used! body)] + [(beg0 forms) + (for-each used! forms)] + [(seq forms) + (for-each used! forms)] + [(varref toplevel dummy constant? unsafe?) + (used! toplevel) + (used! dummy)] + [(assign id rhs undef-ok?) + (used! id) + (used! rhs)] + [(apply-values proc args-expr) + (used! proc) + (used! args-expr)] + [(with-immed-mark key def-val body) + (used! key) + (used! def-val) + (used! body)] + [(case-lam name clauses) + (for-each used! clauses)] + [_ + (cond + [(lam? b) + (define tl-map (lam-toplevel-map b)) + (when tl-map + (for/set ([pos (in-set tl-map)]) + (when (pos . >= . internals-pos) + (used-pos! pos)))) + (used! (lam-body b))] + [else (void)])])) + + (define (pure? b) + (match b + [(closure code gen-id) #t] + [(inline-variant direct inline) #t] + [(case-lam name clauses) #t] + [_ (lam? b)])) + + (for ([b (in-list body)]) + (match b + [(def-values ids rhs) + (define done? #f) + (define (used-rhs!) + (unless done? + (set! done? #t) + (used! rhs)) + ;; All in group are used together: + (for-each used! ids)) + (for ([id (in-list ids)]) + (define pos (toplevel-pos id)) + (cond + [(eq? 'used (hash-ref used pos #f)) + (used-rhs!)] + [else + (hash-set! used pos used-rhs!)])) + (unless (or assume-pure? + (pure? rhs)) + (used-rhs!))] + [_ (used! b)])) + + ;; Anything not marked as used at this point can be dropped + (define new-internals + (for/list ([name (in-list internals)] + [pos (in-naturals internals-pos)] + #:when (or (eq? 'used (hash-ref used pos #f)) + (begin + (log-debug "drop ~s" name) + #f))) + name)) + + (define lifts-pos (+ internals-pos (length internals))) + (define new-lifts + (for/list ([name (in-list lifts)] + [pos (in-naturals lifts-pos)] + #:when (or (eq? 'used (hash-ref used pos #f)) + (begin + (log-debug "drop ~s" name) + #f))) + name)) + + (define old-pos-to-new-pos (make-hasheqv)) + (for/fold ([new-pos internals-pos]) ([name (in-list (append internals lifts))] + [pos (in-naturals internals-pos)]) + (cond + [(eq? 'used (hash-ref used pos #f)) + (hash-set! old-pos-to-new-pos pos new-pos) + (add1 new-pos)] + [else new-pos])) + + (define used-body + ;; Drop unused definitions + (for/list ([b (in-list body)] + #:when (match b + [(def-values ids rhs) + (for/or ([id (in-list ids)]) + (eq? 'used (hash-ref used (toplevel-pos id) #f)))] + [else (not (void? b))])) + b)) + + (define new-body (remap-positions used-body + (lambda (pos) + (if (pos . < . internals-pos) + pos + (hash-ref old-pos-to-new-pos pos))))) + + (values new-body new-internals new-lifts)) diff --git a/pkgs/compiler-lib/compiler/demodularizer/import.rkt b/pkgs/compiler-lib/compiler/demodularizer/import.rkt new file mode 100644 index 0000000000..1cfc48f730 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/import.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(provide (struct-out import)) + +(struct import (name shape [pos #:mutable])) diff --git a/pkgs/compiler-lib/compiler/demodularizer/info.rkt b/pkgs/compiler-lib/compiler/demodularizer/info.rkt deleted file mode 100644 index 84ad0ac2d5..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/info.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang info - -(define test-responsibles '((all jay))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/main.rkt b/pkgs/compiler-lib/compiler/demodularizer/main.rkt index b818b36957..e23df0ed51 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/main.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/main.rkt @@ -1,91 +1,63 @@ #lang racket/base -(require compiler/cm - compiler/zo-marshal - "alpha.rkt" - "gc-toplevels.rkt" +(require racket/set + compiler/cm + "find.rkt" + "name.rkt" "merge.rkt" - "module.rkt" - "mpi.rkt" - "nodep.rkt" - "replace-modidx.rkt") + "gc.rkt" + "bundle.rkt" + "write.rkt") + +(provide demodularize -(provide current-excluded-modules garbage-collect-toplevels-enabled - recompile-enabled - demodularize) + current-excluded-modules + recompile-enabled) (define garbage-collect-toplevels-enabled (make-parameter #f)) (define recompile-enabled (make-parameter #f)) (define logger (make-logger 'demodularizer (current-logger))) -(define (demodularize file-to-batch [output-file #f]) - (parameterize ([current-logger logger]) - (define-values (base name must-be-dir?) (split-path file-to-batch)) - (when must-be-dir? - (error 'demodularize "Cannot run on directory: ~a" file-to-batch)) - (unless (file-exists? file-to-batch) - (error 'demodularize "File does not exist: ~a" file-to-batch)) - - ;; Compile +(define (demodularize input-file [given-output-file #f]) + (parameterize ([current-logger logger] + [current-excluded-modules (for/set ([path (in-set (current-excluded-modules))]) + (normal-case-path (simplify-path (path->complete-path path))))]) + (log-info "Compiling module") (parameterize ([current-namespace (make-base-empty-namespace)]) - (managed-compile-zo file-to-batch)) - - (define merged-zo-path - (or output-file - (path-add-suffix file-to-batch #"_merged.zo"))) - - ;; Transformations - (define path-cache (make-hasheq)) - - (log-info "Removing dependencies") - (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) - (parameterize ([MODULE-PATHS path-cache]) - (nodep-file file-to-batch))) - - (log-info "Merging modules") - (define batch-merge - (parameterize ([MODULE-PATHS path-cache]) - (merge-compilation-top get-modvar-rewrite batch-nodep))) - - (define batch-gcd - (if (garbage-collect-toplevels-enabled) - (begin - (log-info "GC-ing top-levels") - (gc-toplevels batch-merge)) - batch-merge)) - - (log-info "Alpha-varying top-levels") - (define batch-alpha - (alpha-vary-ctop batch-gcd)) - - (log-info "Replacing self-modidx") - (define batch-replace-modidx - (replace-modidx batch-alpha top-self-modidx)) - - (define batch-modname - (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) - (log-info (format "Modularizing into ~a" batch-modname)) - (define batch-mod - (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) - - (log-info "Writing merged zo") - (void - (with-output-to-file - merged-zo-path - (lambda () - (zo-marshal-to batch-mod (current-output-port))) - #:exists 'replace)) - - (void - (when (recompile-enabled) - (define recomp - (compiled-expression-recompile - (parameterize ([read-accept-compiled #t]) - (call-with-input-file merged-zo-path read)))) - (call-with-output-file merged-zo-path - (lambda (out) - (write recomp out)) - #:exists 'replace))))) + (managed-compile-zo input-file)) + (log-info "Finding modules") + (define-values (runs excluded-module-mpis) (find-modules input-file)) + + (log-info "Selecting names") + (define-values (names internals lifts imports) (select-names runs)) + + (log-info "Merging linklets") + (define-values (body first-internal-pos get-merge-info) + (merge-linklets runs names internals lifts imports)) + + (log-info "GCing definitions") + (define-values (new-body new-internals new-lifts) + (gc-definitions body internals lifts first-internal-pos + #:assume-pure? (garbage-collect-toplevels-enabled))) + + (log-info "Bundling linklet") + (define bundle (wrap-bundle new-body new-internals new-lifts + excluded-module-mpis + get-merge-info)) + + (log-info "Writing bytecode") + (define output-file (or given-output-file + (path-add-suffix input-file #"_merged.zo"))) + (write-module output-file bundle) + + (when (recompile-enabled) + (log-info "Recompiling and rewriting bytecode") + (define zo (compiled-expression-recompile + (parameterize ([read-accept-compiled #t]) + (call-with-input-file* output-file read)))) + (call-with-output-file* output-file + #:exists 'replace + (lambda (out) (write zo out)))))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt index fd7ddff67f..4502defb09 100644 --- a/pkgs/compiler-lib/compiler/demodularizer/merge.rkt +++ b/pkgs/compiler-lib/compiler/demodularizer/merge.rkt @@ -1,229 +1,144 @@ #lang racket/base +(require compiler/zo-structs + "run.rkt" + "name.rkt" + "import.rkt" + "remap.rkt") -(require racket/list - racket/match - racket/contract - compiler/zo-parse - "util.rkt" - "mpi.rkt" - "nodep.rkt" - "update-toplevels.rkt") +(provide merge-linklets) -(define MODULE-TOPLEVEL-OFFSETS (make-hasheq)) +(define (merge-linklets runs names internals lifts imports) + (define (syntax-literals-import? path/submod+phase) + (eq? (cdr path/submod+phase) 'syntax-literals)) + (define (transformer-register-import? path/submod+phase) + (eq? (cdr path/submod+phase) 'transformer-register)) -(define current-get-modvar-rewrite (make-parameter #f)) -(define (merge-compilation-top get-modvar-rewrite top) - (parameterize ([current-get-modvar-rewrite get-modvar-rewrite]) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (define-values (new-max-let-depth new-prefix gen-new-forms) - (merge-form max-let-depth prefix form)) - (define total-tls (length (prefix-toplevels new-prefix))) - (define total-stxs (length (prefix-stxs new-prefix))) - (define total-lifts (prefix-num-lifts new-prefix)) - (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) - (log-debug (format "total toplevels ~S" total-tls)) - (log-debug (format "total stxs ~S" total-stxs)) - (log-debug (format "num-lifts ~S" total-lifts)) - (for ([i (in-naturals)] - [p (in-list (prefix-toplevels new-prefix))]) - (log-debug (format "new-prefix tls\t~v ~v" i p))) - (make-compilation-top - new-max-let-depth #hash() new-prefix - (make-splice (gen-new-forms new-prefix)))] - [else (error 'merge "unrecognized: ~e" top)]))) + ;; Pick an order for the remaining imports: + (define import-keys (for/list ([path/submod+phase (in-hash-keys imports)] + ;; References to a 'syntax-literals "phase" are + ;; references to the implicit syntax-literals + ;; module; drop those: + #:unless (or (syntax-literals-import? path/submod+phase) + (transformer-register-import? path/submod+phase))) + path/submod+phase)) -(define (merge-forms max-let-depth prefix forms) - (if (empty? forms) - (values max-let-depth prefix (lambda _ empty)) - (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] - [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) - (values rmax-let-depth - rprefix - (lambda args - (append (apply gen-fform args) - (apply gen-rforms args))))))) + (define any-syntax-literals? + (for/or ([path/submod+phase (in-hash-keys imports)]) + (syntax-literals-import? path/submod+phase))) + (define any-transformer-registers? + (for/or ([path/submod+phase (in-hash-keys imports)]) + (transformer-register-import? path/submod+phase))) + (define syntax-literals-pos 1) + (define transformer-register-pos (+ (if any-syntax-literals? 1 0) + syntax-literals-pos)) + (define import-counter (+ (if any-transformer-registers? 1 0) + transformer-register-pos)) -(define (merge-form max-let-depth prefix form) - (match form - [(? mod?) - (merge-module max-let-depth prefix form)] - [(struct seq (forms)) - (merge-forms max-let-depth prefix forms)] - [(struct splice (forms)) - (merge-forms max-let-depth prefix forms)] - [else - (values max-let-depth prefix (lambda _ (list form)))])) + ;; Map each remaining import to its position + (define ordered-importss + (for/list ([key (in-list import-keys)]) + (define ordered-imports (hash-ref imports key)) + (for ([name (in-list ordered-imports)]) + (define i (hash-ref names (cons key name))) + (set-import-pos! i import-counter) + (set! import-counter (add1 import-counter))) + ordered-imports)) + ;; Keep all the same import shapes + (define import-shapess + (for/list ([key (in-list import-keys)]) + (for/list ([name (in-list (hash-ref imports key))]) + (import-shape (hash-ref names (cons key name)))))) -(define (index-of v l) - (for/or ([e (in-list l)] - [i (in-naturals)] - #:when (eq? e v)) - i)) + ;; Map all syntax-literal references to the same import. + ;; We could update each call to the access to use a suitable + ;; vector index. + (for ([(path/submod+phase imports) (in-hash imports)] + #:when (syntax-literals-import? path/submod+phase) + [name (in-list imports)]) + (define i (hash-ref names (cons path/submod+phase name))) + (set-import-pos! i syntax-literals-pos)) -(define (merge-prefix root-prefix mod-prefix) - (match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix) - (match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix) - (make-prefix (+ root-num-lifts mod-num-lifts) - (append root-toplevels mod-toplevels) - (append root-stxs mod-stxs) - root-src-insp-desc)) + ;; Map the transformer-register import, if any + (let* ([path/submod+phase '(#%transformer-register . transformer-register)] + [imports (hash-ref imports path/submod+phase null)]) + (for ([name (in-list imports)]) + (define i (hash-ref names (cons path/submod+phase name))) + (set-import-pos! i transformer-register-pos))) -(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) + ;; Map internals and lifts to positions + (define first-internal-pos import-counter) + (define positions + (for/hash ([name (in-list (append internals lifts))] + [i (in-naturals first-internal-pos)]) + (values name i))) -(define (compute-new-modvar mv rw) - (match mv - [(struct module-variable (modidx sym pos phase constantness)) - (match rw - [(struct modvar-rewrite (self-modidx provide->toplevel)) - (log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx))) - (define tl (provide->toplevel sym pos)) - (log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl)) - (match-define (toplevel-offset-rewriter rewrite-fun meta) - (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx - (lambda () - (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) - (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta)) - (define res (rewrite-fun tl)) - (log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S" - sym pos (mpi->path* modidx) tl meta res)) - res])])) + ;; For each linklet that we merge, make a mapping from + ;; the linklet's old position to new names (which can + ;; then be mapped to new positions): + (define (make-position-mapping r) + (define h (make-hasheqv)) + (define linkl (run-linkl r)) + (define importss (linkl-importss linkl)) + (define pos 1) + (for ([imports (in-list importss)] + [use (in-list (run-uses r))]) + (for ([name (in-list imports)]) + (hash-set! h pos (find-name names use name)) + (set! pos (add1 pos)))) + (define path/submod+phase (cons (run-path/submod r) (run-phase r))) + (for ([name (in-list (append (linkl-exports linkl) + (linkl-internals linkl) + (linkl-lifts linkl)))] + [pos (in-naturals pos)]) + (hash-set! h pos (find-name names path/submod+phase name))) + h) -(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels) - (define-values - (i new-toplevels remap) - (for/fold ([i 0] - [new-toplevels empty] - [remap empty]) - ([tl (in-list mod-toplevels)] - [idx (in-naturals)]) - (log-debug (format "[~S] mod-prefix tls\t~v ~v" - name idx tl)) - (match tl - [(and mv (struct module-variable (modidx sym pos phase constantness))) - (define rw ((current-get-modvar-rewrite) modidx)) - ;; XXX We probably don't need to deal with #f phase - (unless (or (not phase) (zero? phase)) - (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) + ;; Do we need the implicit initial variable for `(#%variable-reference)`? + ;; The slot will be reserved whether we use it or not, but the + ;; slot is not necessarily initialized if we don't need it. + (define saw-zero-pos-toplevel? #f) + + (define body + (apply + append + (for/list ([r (in-list runs)]) + (define pos-to-name/import (make-position-mapping r)) + (define (remap-toplevel-pos pos) (cond - ; Primitive module like #%paramz - [(symbol? rw) - (log-debug (format "~S from ~S" sym rw)) - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))] - [(module-path-index? rw) - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))] - [(modvar-rewrite? rw) - (values i - new-toplevels - (list* (compute-new-modvar mv rw) remap))] + [(zero? pos) + ;; Implicit variable for `(#%variable-reference)` stays in place: + (set! saw-zero-pos-toplevel? #t) + 0] [else - (error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])] - [tl - (cond - [(and new-#f-idx (not tl)) - (log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v" - name idx (+ i toplevel-offset) new-#f-idx)) - (values i - new-toplevels - (list* new-#f-idx remap))] - [else - (values (add1 i) - (list* tl new-toplevels) - (list* (+ i toplevel-offset) remap))])]))) - ; XXX This would be more efficient as a vector - (values (reverse new-toplevels) - (reverse remap))) + (define new-name/import (hash-ref pos-to-name/import pos)) + (if (import? new-name/import) + (import-pos new-name/import) + (hash-ref positions new-name/import))])) -(define (merge-module max-let-depth top-prefix mod-form) - (match mod-form - [(struct mod (name srcname self-modidx - mod-prefix provides requires body syntax-bodies - unexported mod-max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (define top-toplevels (prefix-toplevels top-prefix)) - (define toplevel-offset (length top-toplevels)) - (define topsyntax-offset (length (prefix-stxs top-prefix))) - (define lift-offset (prefix-num-lifts top-prefix)) - (define mod-toplevels (prefix-toplevels mod-prefix)) - (define new-#f-idx - (index-of #f top-toplevels)) - (when new-#f-idx - (log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing" - name new-#f-idx))) - (define-values (new-mod-toplevels toplevel-remap) - (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels)) - (define num-mod-toplevels - (length toplevel-remap)) - (define mod-stxs - (length (prefix-stxs mod-prefix))) - (define mod-num-lifts - (prefix-num-lifts mod-prefix)) - (define new-mod-prefix - (struct-copy prefix mod-prefix - [toplevels new-mod-toplevels])) - (define offset-meta (vector name srcname self-modidx)) - (log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S" - offset-meta - (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f)) - (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx - (toplevel-offset-rewriter - (lambda (n) - (log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta) - (list-ref toplevel-remap n)) - offset-meta)) - (unless (= (length toplevel-remap) - (length mod-toplevels)) - (error 'merge-module "Not remapping everything: ~S ~S" - mod-toplevels toplevel-remap)) - (log-debug (format "[~S] Incrementing toplevels by ~a" - name - toplevel-offset)) - (log-debug (format "[~S] Incrementing lifts by ~a" - name - lift-offset)) - (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" - name - (length mod-toplevels) - (length new-mod-toplevels))) - (values (max max-let-depth mod-max-let-depth) - (merge-prefix top-prefix new-mod-prefix) - (lambda (top-prefix) - (log-debug (format "[~S] Updating top-levels" name)) - (define top-lift-start (prefix-lift-start top-prefix)) - (define mod-lift-start (prefix-lift-start mod-prefix)) - (define total-lifts (prefix-num-lifts top-prefix)) - (define max-toplevel (+ top-lift-start total-lifts)) - (define update - (update-toplevels - (lambda (n) - (define new-idx - (cond - [(mod-lift-start . <= . n) - (log-debug (format "[~S] ~v is a lift" - name n)) - (define which-lift (- n mod-lift-start)) - (define lift-tl (+ top-lift-start lift-offset which-lift)) - (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl] - [else - ;; xxx maybe change this to a vector after it is made to make this efficient - (list-ref toplevel-remap n)])) - (log-debug (format "[~S] ~v is remapped to ~v" - name n new-idx)) - new-idx) - (lambda (n) - (+ n topsyntax-offset)) - (prefix-syntax-start top-prefix))) - (map update body)))])) + (remap-positions (linkl-body (run-linkl r)) + remap-toplevel-pos + #:application-hook + (lambda (rator rands remap) + ;; Check for a `(.get-syntax-literal! ')` call + (cond + [(and (toplevel? rator) + (let ([i (hash-ref pos-to-name/import (toplevel-pos rator))]) + (and (import? i) + (eqv? syntax-literals-pos (import-pos i))))) + ;; This is a `(.get-syntax-literal! ')` call + (application (remap rator) + ;; To support syntax objects, change the offset + rands)] + [else #f])))))) -(provide/contract - [merge-compilation-top (-> get-modvar-rewrite/c - compilation-top? - compilation-top?)]) + (values body + first-internal-pos + ;; Communicates into to `wrap-bundle`: + (lambda () + (values runs + import-keys + ordered-importss + import-shapess + any-syntax-literals? + any-transformer-registers? + saw-zero-pos-toplevel?)))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/module-path.rkt b/pkgs/compiler-lib/compiler/demodularizer/module-path.rkt new file mode 100644 index 0000000000..80a1b070f0 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/module-path.rkt @@ -0,0 +1,38 @@ +#lang racket/base +(require syntax/modresolve) + +(provide module-path-index->path + module-path-index-reroot) + +(define (module-path-index->path req path submod) + (define mpi (module-path-index-build req path submod)) + + (define p (resolve-module-path-index mpi path)) + + ;; Make sure a path name is normalized + (define p-path (if (pair? p) (cadr p) p)) + (define p-submod (if (pair? p) (cddr p) '())) + (define p-simple-path (if (path? p-path) + (normal-case-path (simplify-path p-path)) + p-path)) + + ;; Combine path back with submod + (if (null? p-submod) + p-simple-path + (cons p-simple-path p-submod))) + +(define (module-path-index-build req path submod) + (module-path-index-reroot req + (if (null? submod) + (module-path-index-join #f #f) + (module-path-index-join `(submod "." ,@submod) + (module-path-index-join #f #f))))) + +(define (module-path-index-reroot req root-mpi) + (let loop ([req req]) + (define-values (mod-path base) (module-path-index-split req)) + (cond + [(not mod-path) root-mpi] + [else + (module-path-index-join mod-path + (and base (loop base)))]))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/module.rkt b/pkgs/compiler-lib/compiler/demodularizer/module.rkt deleted file mode 100644 index 4f984c27af..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/module.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket/base - -(require racket/list - racket/match - racket/contract - compiler/zo-parse - "util.rkt") - -(define (->module-path-index s) - (if (module-path-index? s) - s - (module-path-index-join `(quote ,s) #f))) - -(define (wrap-in-kernel-module name srcname lang-info self-modidx top) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (define-values (reqs new-forms) - (partition req? (splice-forms form))) - (define requires - (map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs)) - (make-compilation-top - 0 - #hash() - (make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix)) - (make-mod name srcname - self-modidx - prefix - empty ; provides - (list (cons 0 requires)) - new-forms - empty ; syntax-body - (list) ; unexported - max-let-depth - (make-toplevel 0 0 #f #f) ; dummy - lang-info - #t - (hash) ; no names visible via `module->namespace` - empty - empty - empty))])) - -(provide/contract - [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)]) diff --git a/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt b/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt deleted file mode 100644 index 65c0b76ad7..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/mpi.rkt +++ /dev/null @@ -1,41 +0,0 @@ -#lang racket/base - -(require racket/contract - syntax/modresolve) - -(define current-module-path (make-parameter #f)) - -(define (mpi->string modidx) - (cond - [(symbol? modidx) modidx] - [else - (mpi->path! modidx)])) - -(define MODULE-PATHS (make-parameter #f)) -(define (mpi->path! mpi) - (hash-ref! - (MODULE-PATHS) mpi - (lambda () - (define _pth - (resolve-module-path-index mpi (current-module-path))) - (cond - [(path? _pth) (simplify-path _pth #t)] - [(and (pair? _pth) - (path? (cadr _pth))) - (list* 'submod (simplify-path (cadr _pth) #t) (cddr _pth))] - [else _pth])))) -(define (mpi->path* mpi) - (hash-ref (MODULE-PATHS) mpi - (lambda () - (error 'mpi->path* "Cannot locate cache of path for ~S" mpi)))) - -(define submod-path/c - (cons/c 'submod - (cons/c (or/c symbol? path?) - (listof symbol?)))) - -(provide/contract - [MODULE-PATHS (parameter/c (or/c false/c hash?))] - [current-module-path (parameter/c (or/c path-string? submod-path/c))] - [mpi->path! (module-path-index? . -> . (or/c symbol? path? submod-path/c))] - [mpi->path* (module-path-index? . -> . (or/c symbol? path? pair? submod-path/c))]) diff --git a/pkgs/compiler-lib/compiler/demodularizer/name.rkt b/pkgs/compiler-lib/compiler/demodularizer/name.rkt new file mode 100644 index 0000000000..6cfda4f254 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/name.rkt @@ -0,0 +1,61 @@ +#lang racket/base +(require compiler/zo-structs + "run.rkt" + "import.rkt") + +(provide select-names + find-name) + +(define (select-names runs) + (define names (make-hash)) ; path/submod+phase+sym -> symbol + (define used-names (make-hasheq)) + (define internals (box '())) + (define lifts (box '())) + (define imports (make-hash)) ; path/submod+phase -> list-of-sym + + ;; Reserve the syntax-literals and transformer-register names: + (hash-set! used-names '.get-syntax-literal! #t) + (hash-set! used-names '.set-transformer! #t) + + (define (pick-name name) + (let loop ([try-name name] [i 0]) + (cond + [(hash-ref used-names try-name #f) + (let ([i (add1 i)]) + (loop (string->symbol (format "~a_~a" name i)) i))] + [else + (hash-set! used-names try-name #t) + try-name]))) + + (for ([r (in-list (reverse runs))]) ; biases names to starting module + (define linkl (run-linkl r)) + (define path/submod+phase (cons (run-path/submod r) (run-phase r))) + + ;; Process local definitions, first + (define (select-names! name-list category) + (for ([name (in-list name-list)]) + (define new-name (pick-name name)) + (hash-set! names (cons path/submod+phase name) new-name) + (set-box! category (cons new-name (unbox category))))) + + (select-names! (linkl-exports linkl) internals) + (select-names! (linkl-internals linkl) internals) + (select-names! (linkl-lifts linkl) lifts)) + + ;; Record any imports that will remain as imports; anything + ;; not yet mapped must be a leftover import + (for ([r (in-list runs)]) + (define linkl (run-linkl r)) + (for ([import-names (in-list (linkl-importss linkl))] + [import-shapes (in-list (linkl-import-shapess linkl))] + [use (in-list (run-uses r))]) + (for ([name (in-list import-names)] + [shape (in-list import-shapes)]) + (unless (hash-ref names (cons use name) #f) + (hash-set! imports use (cons name (hash-ref imports use null))) + (hash-set! names (cons use name) (import name shape #f)))))) + + (values names (unbox internals) (unbox lifts) imports)) + +(define (find-name names use name) + (hash-ref names (cons use name))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt b/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt deleted file mode 100644 index b5dd91eb3d..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/nodep.rkt +++ /dev/null @@ -1,228 +0,0 @@ -#lang racket/base - -(require racket/list - racket/match - racket/contract - compiler/zo-parse - "util.rkt" - "mpi.rkt" - racket/set) - -(define current-excluded-modules (make-parameter (set))) - -(define ZOS (make-parameter #f)) -(define MODULE-IDX-MAP (make-parameter #f)) -(define PHASE*MODULE-CACHE (make-parameter #f)) - -(define (nodep-file file-to-batch) - (define idx-map (make-hash)) - (parameterize ([ZOS (make-hash)] - [MODULE-IDX-MAP idx-map] - [PHASE*MODULE-CACHE (make-hasheq)]) - (define (get-modvar-rewrite modidx) - (define pth (mpi->path* modidx)) - (hash-ref idx-map pth - (lambda () - (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) - (match (get-nodep-module-code/path file-to-batch 0) - [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) - (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)]))) - -(define (path->comp-top pth submod) - (hash-ref! (ZOS) (cons pth submod) - (λ () - (define zo (call-with-input-file pth zo-parse)) - (if submod - (extract-submod zo submod) - zo)))) - -(define (extract-submod zo submod) - (define m (compilation-top-code zo)) - (struct-copy compilation-top - zo - [code (let loop ([m m]) - (if (and (pair? (mod-name m)) - (equal? submod (cdr (mod-name m)))) - m - (or (ormap loop (mod-pre-submodules m)) - (ormap loop (mod-post-submodules m)))))])) - -(define (excluded? pth) - (and (path? pth) - (set-member? (current-excluded-modules) (path->string pth)))) - -(define (get-nodep-module-code/index mpi phase) - (define pth (mpi->path! mpi)) - (cond - [(symbol? pth) - (hash-set! (MODULE-IDX-MAP) pth pth) - pth] - [(excluded? pth) - (hash-set! (MODULE-IDX-MAP) pth mpi) - mpi] - [else - (get-nodep-module-code/path pth phase)])) - -(define-struct @phase (phase code)) -(define-struct modvar-rewrite (modidx provide->toplevel)) -(define-struct module-code (modvar-rewrite lang-info ctop)) -(define @phase-ctop (compose module-code-ctop @phase-code)) - -(define (get-nodep-module-code/path pth phase) - (define MODULE-CACHE - (hash-ref! (PHASE*MODULE-CACHE) phase make-hash)) - (if (hash-ref MODULE-CACHE pth #f) - #f - (hash-ref! - MODULE-CACHE pth - (lambda () - (define-values (base file dir?) (split-path (if (path-string? pth) - pth - (cadr pth)))) - (define base-directory - (if (path? base) - (path->complete-path base (current-directory)) - (current-directory))) - (define-values (modvar-rewrite lang-info ctop) - (begin - (log-debug (format "Load ~S @ ~S" pth phase)) - (nodep/dir - (parameterize ([current-load-relative-directory base-directory]) - (path->comp-top - (build-compiled-path - base - (path-add-suffix file #".zo")) - (and (pair? pth) (cddr pth)))) - pth - phase))) - (when (and phase (zero? phase)) - (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite)) - (make-@phase - phase - (make-module-code modvar-rewrite lang-info ctop)))))) - -(define (nodep/dir top pth phase) - (define pth* - (cond - [(string? pth) (string->path pth)] - [(list? pth) (cadr pth)] - [else pth])) - (parameterize ([current-module-path pth*]) - (nodep top phase))) - -(define (nodep top phase) - (match top - [(struct compilation-top (max-let-depth binding-namess prefix form)) - (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase)) - (values modvar-rewrite lang-info (make-compilation-top max-let-depth #hash() prefix new-form))] - [else (error 'nodep "unrecognized: ~e" top)])) - -(define (nodep-form form phase) - (if (mod? form) - (let-values ([(modvar-rewrite lang-info mods) - (nodep-module form phase)]) - (values modvar-rewrite lang-info (make-splice mods))) - (error 'nodep-form "Doesn't support non mod forms"))) - -; XXX interning is hack to fix test/add04.ss and provide/contract renaming -(define (intern s) (string->symbol (symbol->string s))) -(define (construct-provide->toplevel prefix provides) - (define provide-ht (make-hasheq)) - (for ([tl (prefix-toplevels prefix)] - [i (in-naturals)]) - (when (symbol? tl) - (hash-set! provide-ht (intern tl) i))) - (lambda (sym pos) - (define isym (intern sym)) - (log-debug (format "Looking up ~S@~a [~S] in ~S" sym pos isym prefix)) - (define res - (hash-ref provide-ht isym - (lambda () - (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix)))) - (log-debug (format "Looked up ~S@~a and got ~v" sym pos res)) - res)) - -(define (nodep-module mod-form phase) - (match mod-form - [(struct mod (name srcname self-modidx - prefix provides requires body syntax-bodies - unexported max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (define new-prefix prefix) - ;; Cache all the mpi paths - (for-each (match-lambda - [(and mv (struct module-variable (modidx sym pos phase constantness))) - (mpi->path! modidx)] - [tl - (void)]) - (prefix-toplevels new-prefix)) - (define mvs (filter module-variable? (prefix-toplevels new-prefix))) - (log-debug (format "[~S] module-variables: ~S - ~S" name (length mvs) mvs)) - (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides)) - lang-info - (append (requires->modlist requires phase) - (if (and phase (zero? phase)) - (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx - new-prefix provides requires body empty - unexported max-let-depth dummy lang-info internal-context #hash() - empty empty empty))) - (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) - empty))))] - [else (error 'nodep-module "huh?: ~e" mod-form)])) - -(define (+* l r) - (if (and l r) (+ l r) #f)) - -(define (requires->modlist requires current-phase) - (apply append - (map - (match-lambda - [(list-rest req-phase mpis) - (define phase (+* current-phase req-phase)) - (apply append - (map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))]) - requires))) - -(define (all-but-last l) - (reverse (rest (reverse l)))) - -(define REQUIRED (make-hasheq)) -(define (extract-modules ct) - (cond - [(compilation-top? ct) - (match (compilation-top-code ct) - [(and m (? mod?)) - (list m)] - [(struct splice (mods)) - mods])] - [(symbol? ct) - (if (hash-has-key? REQUIRED ct) - empty - (begin - (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))] - [(module-path-index? ct) - (if (hash-has-key? REQUIRED ct) - empty - (begin - (hash-set! REQUIRED ct #t) - (list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))] - [(not ct) - empty] - [(@phase? ct) - (extract-modules (@phase-ctop ct))] - [else - (error 'extract-modules "Unknown extraction: ~S" ct)])) - -(define get-modvar-rewrite/c - (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))) -(provide/contract - [struct modvar-rewrite - ([modidx module-path-index?] - [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] - [get-modvar-rewrite/c contract?] - [current-excluded-modules (parameter/c generic-set?)] - [nodep-file (-> path-string? - (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) diff --git a/pkgs/compiler-lib/compiler/demodularizer/remap.rkt b/pkgs/compiler-lib/compiler/demodularizer/remap.rkt new file mode 100644 index 0000000000..85a4961d13 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/remap.rkt @@ -0,0 +1,79 @@ +#lang racket/base +(require racket/match + racket/set + compiler/zo-structs) + +(provide remap-positions) + +(define (remap-positions body + remap-toplevel-pos ; integer -> integer + #:application-hook [application-hook (lambda (rator rands remap) #f)]) + (define graph (make-hasheq)) + (make-reader-graph + (for/list ([b (in-list body)]) + (let remap ([b b]) + (match b + [(toplevel depth pos const? ready?) + (define new-pos (remap-toplevel-pos pos)) + (toplevel depth new-pos const? ready?)] + [(def-values ids rhs) + (def-values (map remap ids) (remap rhs))] + [(inline-variant direct inline) + (inline-variant (remap direct) (remap inline))] + [(closure code gen-id) + (cond + [(hash-ref graph gen-id #f) + => (lambda (ph) ph)] + [else + (define ph (make-placeholder #f)) + (hash-set! graph gen-id ph) + (define cl (closure (remap code) gen-id)) + (placeholder-set! ph cl) + cl])] + [(let-one rhs body type unused?) + (let-one (remap rhs) (remap body) type unused?)] + [(let-void count boxes? body) + (let-void count boxes? (remap body))] + [(install-value count pos boxes? rhs body) + (install-value count pos boxes? (remap rhs) (remap body))] + [(let-rec procs body) + (let-rec (map remap procs) (remap body))] + [(boxenv pos body) + (boxenv pos (remap body))] + [(application rator rands) + (cond + [(application-hook rator rands (lambda (b) (remap b))) + => (lambda (v) v)] + [else + ;; Any other application + (application (remap rator) (map remap rands))])] + [(branch tst thn els) + (branch (remap tst) (remap thn) (remap els))] + [(with-cont-mark key val body) + (with-cont-mark (remap key) (remap val) (remap body))] + [(beg0 forms) + (beg0 (map remap forms))] + [(seq forms) + (seq (map remap forms))] + [(varref toplevel dummy constant? unsafe?) + (varref (remap toplevel) (remap dummy) constant? unsafe?)] + [(assign id rhs undef-ok?) + (assign (remap id) (remap rhs) undef-ok?)] + [(apply-values proc args-expr) + (apply-values (remap proc) (remap args-expr))] + [(with-immed-mark key def-val body) + (with-immed-mark (remap key) (remap def-val) (remap body))] + [(case-lam name clauses) + (case-lam name (map remap clauses))] + [_ + (cond + [(lam? b) + (define tl-map (lam-toplevel-map b)) + (define new-tl-map + (and tl-map + (for/set ([pos (in-set tl-map)]) + (remap-toplevel-pos pos)))) + (struct-copy lam b + [body (remap (lam-body b))] + [toplevel-map new-tl-map])] + [else b])]))))) diff --git a/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt b/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt deleted file mode 100644 index 4cd6fc698a..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt +++ /dev/null @@ -1,29 +0,0 @@ -#lang racket/base - -(require racket/match - racket/vector - racket/struct - "util.rkt") - -(provide replace-modidx) - -(define (replace-modidx expr self-modidx) - (define (inner-update e) - (match e - [(app prefab-struct-key (and key (not #f))) - (apply make-prefab-struct key - (map update - (struct->list e)))] - [(? module-path-index?) - (define-values (path mpi) (module-path-index-split e)) - (if (not path) - self-modidx - (module-path-index-join path (update mpi)))] - [(cons a b) - (cons (update a) (update b))] - [(? vector?) - (vector-map update e)] - [else e])) - (define-values (first-update update) - (build-form-memo inner-update)) - (first-update expr)) diff --git a/pkgs/compiler-lib/compiler/demodularizer/run.rkt b/pkgs/compiler-lib/compiler/demodularizer/run.rkt new file mode 100644 index 0000000000..c7d8031abb --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/run.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(provide (struct-out run)) + +(struct run (path/submod phase linkl uses)) diff --git a/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt b/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt deleted file mode 100644 index c122511649..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt +++ /dev/null @@ -1,108 +0,0 @@ -#lang racket/base - -(require racket/match - racket/contract - compiler/zo-structs - "util.rkt") - -(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) - (define (inner-update form) - (match form - [(struct def-values (ids rhs)) - (make-def-values (map update ids) - (update rhs))] - [(? def-syntaxes?) - (error 'increment "Doesn't handle syntax")] - [(? seq-for-syntax?) - (error 'increment "Doesn't handle syntax")] - [(struct inline-variant (direct inline)) - (update direct)] - [(struct req (reqs dummy)) - (make-req reqs (update dummy))] - [(? mod?) - (error 'increment "Doesn't handle modules")] - [(struct seq (forms)) - (make-seq (map update forms))] - [(struct splice (forms)) - (make-splice (map update forms))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) - (struct-copy lam l - [toplevel-map #f] ; conservative - [body (update body)])] - [(and c (struct closure (code gen-id))) - (struct-copy closure c - [code (update code)])] - [(and cl (struct case-lam (name clauses))) - (define new-clauses - (map update clauses)) - (struct-copy case-lam cl - [clauses new-clauses])] - [(struct let-one (rhs body type unused?)) - (make-let-one (update rhs) (update body) type unused?)] - [(and f (struct let-void (count boxes? body))) - (struct-copy let-void f - [body (update body)])] - [(and f (struct install-value (_ _ _ rhs body))) - (struct-copy install-value f - [rhs (update rhs)] - [body (update body)])] - [(struct let-rec (procs body)) - (make-let-rec (map update procs) (update body))] - [(and f (struct boxenv (_ body))) - (struct-copy boxenv f [body (update body)])] - [(and f (struct toplevel (_ pos _ _))) - (struct-copy toplevel f - [pos (toplevel-updater pos)])] - [(and f (struct topsyntax (_ pos _))) - (struct-copy topsyntax f - [pos (topsyntax-updater pos)] - [midpt topsyntax-new-midpt])] - [(struct application (rator rands)) - (make-application - (update rator) - (map update rands))] - [(struct branch (test then else)) - (make-branch - (update test) - (update then) - (update else))] - [(struct with-cont-mark (key val body)) - (make-with-cont-mark - (update key) - (update val) - (update body))] - [(struct with-immed-mark (key val body)) - (make-with-immed-mark - (update key) - (update val) - (update body))] - [(struct beg0 (seq)) - (make-beg0 (map update seq))] - [(struct varref (tl dummy)) - (make-varref (update tl) (update dummy))] - [(and f (struct assign (id rhs undef-ok?))) - (struct-copy assign f - [id (update id)] - [rhs (update rhs)])] - [(struct apply-values (proc args-expr)) - (make-apply-values - (update proc) - (update args-expr))] - [(and f (struct primval (id))) - f] - [(and f (struct localref (unbox? pos clear? other-clears? type))) - f] - [(and f (not (? form?))) - f] - )) - (define-values (first-update update) - (build-form-memo inner-update)) - first-update) - -(provide/contract - [update-toplevels - ((exact-nonnegative-integer? . -> . exact-nonnegative-integer?) - (exact-nonnegative-integer? . -> . exact-nonnegative-integer?) - exact-nonnegative-integer? - . -> . - (form? . -> . form?))]) diff --git a/pkgs/compiler-lib/compiler/demodularizer/util.rkt b/pkgs/compiler-lib/compiler/demodularizer/util.rkt deleted file mode 100644 index e18966798e..0000000000 --- a/pkgs/compiler-lib/compiler/demodularizer/util.rkt +++ /dev/null @@ -1,79 +0,0 @@ -#lang racket/base - -(require racket/contract - compiler/zo-parse) - -(define (prefix-syntax-start pre) - (length (prefix-toplevels pre))) - -(define (prefix-lift-start pre) - (define syntax-start (prefix-syntax-start pre)) - (define total-stxs (length (prefix-stxs pre))) - (+ syntax-start total-stxs (if (zero? total-stxs) 0 1))) - -(struct nothing ()) - -(define-syntax-rule (eprintf* . args) (void)) - -(define (build-form-memo inner-update #:void? [void? #f]) - (define memo (make-hasheq)) - (define (update form . args) - (eprintf* "Updating on ~a\n" form) - (define fin - (cond - [(hash-ref memo form #f) - => (λ (x) - (eprintf* "Found in memo table\n") - x)] - [else - (eprintf* "Not in memo table\n") - (let () - (define ph (make-placeholder (nothing))) - (hash-set! memo form ph) - (define nv (nothing)) - (dynamic-wind void - (λ () - (set! nv (apply inner-update form args))) - (λ () - (if (nothing? nv) - (eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form) - (begin - (placeholder-set! ph nv) - (hash-set! memo form nv))))) - nv)])) - (eprintf* "Updating on ~a ---->\n ~a\n" form fin) - fin) - (define (first-update form . args) - (eprintf* "Top level update on ~a\n" form) - (define final (apply update form args)) - (eprintf* "Top level update on ~a ---->\n ~a\n" form final) - (define fin (make-reader-graph final)) - (eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin) - fin) - (values first-update update)) - -(define lang-info/c - (or/c #f (vector/c module-path? symbol? any/c))) - - -(define (build-compiled-path base name) - (build-path - (cond [(path? base) base] - [(eq? base 'relative) 'same] - [(eq? base #f) (error 'batch "Impossible")]) - "compiled" - name)) - - -(provide/contract - [prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)] - [prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)] - [eprintf ((string?) () #:rest (listof any/c) . ->* . void)] - [build-form-memo - (((unconstrained-domain-> any/c)) - (#:void? boolean?) - . ->* . - (values (unconstrained-domain-> any/c) - (unconstrained-domain-> any/c)))] - [lang-info/c contract?] - [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) diff --git a/pkgs/compiler-lib/compiler/demodularizer/write.rkt b/pkgs/compiler-lib/compiler/demodularizer/write.rkt new file mode 100644 index 0000000000..68ea7c1188 --- /dev/null +++ b/pkgs/compiler-lib/compiler/demodularizer/write.rkt @@ -0,0 +1,11 @@ +#lang racket/base +(require compiler/zo-marshal) + +(provide write-module) + +(define (write-module output-file bundle) + (call-with-output-file* + output-file + #:exists 'truncate/replace + (lambda (o) + (zo-marshal-to bundle o)))) diff --git a/pkgs/compiler-lib/compiler/private/deserialize.rkt b/pkgs/compiler-lib/compiler/private/deserialize.rkt new file mode 100644 index 0000000000..c8b614fed0 --- /dev/null +++ b/pkgs/compiler-lib/compiler/private/deserialize.rkt @@ -0,0 +1,121 @@ +#lang racket/base +(require racket/linklet) + +;; Re-implement just enough deserialization to deal with 'decl +;; linklets, so we can get `required`, etc. + +(provide deserialize-instance + (struct-out module-use)) + +(struct module-use (module phase)) +(struct provided (binding protected? syntax?)) + +(define (deserialize-module-path-indexes gen-vec order-vec) + (define gen (make-vector (vector-length gen-vec) #f)) + (for ([d (in-vector gen-vec)] + [i (in-naturals)]) + (vector-set! + gen + i + (cond + [(eq? d 'top) (error 'deserialize-module-path-indexes "expected top")] + [(box? d) (module-path-index-join #f #f)] + [else + (module-path-index-join (vector-ref d 0) + (and ((vector-length d) . > . 1) + (vector-ref gen (vector-ref d 1))))]))) + (for/vector #:length (vector-length order-vec) ([p (in-vector order-vec)]) + (vector-ref gen p))) + +(define (deserialize mpis inspector bulk-binding-registry + num-mutables mutable-vec + num-shared shared-vec + mutable-fill-vec + result-vec) + (unless (zero? num-mutables) (error 'deserialize "mutables not supported")) + + (define shared-vs (make-vector num-shared #f)) + (define shared-rest + (for/fold ([r (vector->list shared-vec)]) ([i (in-range num-shared)]) + (define-values (v rest) (decode r mpis shared-vs)) + (vector-set! shared-vs i v) + rest)) + (unless (null? shared-rest) + (error 'deserialize "unexpected leftover serialized form for shared: ~s" shared-rest)) + + (define-values (v v-rest) (decode (vector->list result-vec) mpis shared-vs)) + (unless (null? v-rest) + (error 'deserialize "unexpected leftover serialized form: ~s" v-rest)) + + v) + +(define (decode r mpis shared-vs) + (let loop ([r r]) + (define (discard r n) + (for/fold ([r (cdr r)]) ([i (in-range n)]) + (define-values (v v-rest) (loop r)) + v-rest)) + (cond + [(null? r) (error 'deserialize "unexpected end of serialized form")] + [else + (define i (car r)) + (case i + [(#:ref) + (values (vector-ref shared-vs (cadr r)) (cddr r))] + [(#:inspector) + (values 'inspector (cdr r))] + [(#:cons) + (define-values (a a-rest) (loop (cdr r))) + (define-values (d d-rest) (loop a-rest)) + (values (cons a d) d-rest)] + [(#:list) + (define-values (rev rest) + (for/fold ([accum '()] [r (cddr r)]) ([i (in-range (cadr r))]) + (define-values (a a-rest) (loop r)) + (values (cons a accum) a-rest))) + (values (reverse rev) rest)] + [(#:mpi) + (values (vector-ref mpis (cadr r)) (cddr r))] + [(#:hash #:hasheq #:hasheqv) + (define ht (case i + [(#:hash) (hash)] + [(#:hasheq) (hasheq)] + [(#:hasheqv) (hasheqv)])) + (for/fold ([ht ht] [r (cddr r)]) ([i (in-range (cadr r))]) + (define-values (k k-rest) (loop r)) + (define-values (v v-rest) (loop k-rest)) + (values (hash-set ht k v) v-rest))] + [(#:provided) + (define-values (bdg bdg-rest) (loop (cdr r))) + (define-values (prot? prot?-rest) (loop bdg-rest)) + (define-values (stx? stx?-rest) (loop prot?-rest)) + (values (provided bdg prot? stx?) stx?-rest)] + [(#:module-binding) + (values 'binding (discard r 10))] + [(#:simple-module-binding) + (values 'binding (discard r 4))] + [else + (cond + [(or (symbol? i) + (number? i) + (string? i) + (null? i) + (hash? i) + (boolean? i)) + (values i (cdr r))] + [else + (error 'deserialize "unsupported instruction: ~s" i)])])]))) + +(define (syntax-module-path-index-shift . args) + (error 'syntax-module-path-index-shift "not supported")) + +(define (syntax-shift-phase-level . args) + (error 'syntax-shift-phase-level "not supported")) + +(define deserialize-instance + (make-instance 'deserialize #f 'constant + 'deserialize-module-path-indexes deserialize-module-path-indexes + 'syntax-module-path-index-shift syntax-module-path-index-shift + 'syntax-shift-phase-level syntax-shift-phase-level + 'module-use module-use + 'deserialize deserialize)) diff --git a/pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt b/pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt index 0fd5b24fa8..35db7ac7ea 100644 --- a/pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt +++ b/pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt @@ -12,7 +12,7 @@ (apply system* command args)) (values (get-output-string o) (get-output-string e))) -(define (test-on-program filename) +(define (test-on-program filename [exceptions null]) ;; run modular program, capture output (define-values (modular-output modular-error) (capture-output (find-exe) filename)) @@ -26,7 +26,9 @@ ;; demodularize (parameterize ([current-input-port (open-input-string "")]) - (system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename)) + (apply system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename + (append exceptions + (list filename)))) ;; run whole program (define-values (whole-output whole-error) @@ -50,4 +52,9 @@ (define ip (build-path tests i)) (when (modular-program? ip) (printf "Checking ~a\n" ip) - (test-on-program (path->string ip))))) + (test-on-program (path->string ip)) + (printf "Checking ~a, skip racket/private/pre-base\n" ip) + (test-on-program (path->string ip) + (list "-e" + (path->string + (collection-file-path "pre-base.rkt" "racket/private"))))))) diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/common/auto.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/common/auto.rkt index 27eb7e4617..2c903cd5a4 100755 --- a/pkgs/racket-benchmarks/tests/racket/benchmarks/common/auto.rkt +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/common/auto.rkt @@ -252,6 +252,18 @@ exec racket -qu "$0" ${1+"$@"} (bytes->number (caddr m)) (bytes->number (cadddr m))))) + (define (mk-chez bm) + (parameterize ([current-input-port + (open-input-string + (format + "(compile-file \"~a.sch\")\n(exit)\n" + bm))] + [current-output-port (open-output-nowhere)]) + (system "scheme -q"))) + + (define (run-chez bm) + (system (format "scheme --script ~a.so" bm))) + (define (run-petite bm) (parameterize ([current-input-port (open-input-string @@ -260,11 +272,33 @@ exec racket -qu "$0" ${1+"$@"} bm))]) (system "petite"))) - (define (extract-petite-times bm str) - (let ([m (regexp-match #rx#"([0-9]+) ms elapsed cpu time(?:, including ([0-9]+) ms collecting)?[ \n]* ([0-9]+) ms elapsed real time" str)]) - (list (bytes->number (cadr m)) - (bytes->number (cadddr m)) - (if (caddr m) (bytes->number (caddr m)) 0)))) + (define (extract-chez-times bm str) + (let ([m (regexp-match #rx#"([0-9.]+)s elapsed cpu time(?:, including ([0-9.]+)s collecting)?[ \n]* ([0-9.]+)s elapsed real time" str)]) + (define (s n) (inexact->exact (floor (* n 1000)))) + (list (s (bytes->number (cadr m))) + (s (bytes->number (cadddr m))) + (if (caddr m) (s (bytes->number (caddr m))) 0)))) + + (define (setup-chez-sps bm) + (setup-sps bm "(only (chezscheme) time)")) + + (define (mk-chez-sps bm) + (parameterize ([current-input-port + (open-input-string + (format (string-append + "(compile-file \"~a.sls\")\n") + bm))] + [current-output-port (open-output-bytes)]) + (system "scheme") + ;; Make sure compiled version is used: + (delete-file (format "~a.sls" bm)))) + + (define (run-chez-sps bm) + (system "scheme --script prog.sps")) + + (define (clean-up-chez-sps bm) + (clean-up-sps bm) + (delete-file (format "~a.so" bm))) ;; requires guile 2.0.2 or higher (define (mk-guile bm) @@ -537,9 +571,23 @@ exec racket -qu "$0" ${1+"$@"} void void run-petite - extract-petite-times + extract-chez-times void racket-specific-progs) + (make-impl 'chez + void + mk-chez + run-chez + extract-chez-times + void + racket-specific-progs) + (make-impl 'chez-sps + setup-chez-sps + mk-chez-sps + run-chez-sps + extract-chez-times + clean-up-chez-sps + racket-specific-progs) (make-impl 'guile void mk-guile diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/rx/auto.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/rx/auto.rkt index 2fd29d849f..78d41e4059 100755 --- a/pkgs/racket-benchmarks/tests/racket/benchmarks/rx/auto.rkt +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/rx/auto.rkt @@ -11,6 +11,7 @@ exec racket -qu "$0" ${1+"$@"} "../common/cmdline.rkt") ;; Needed for rxmzold, comment out otherwise: + #; (begin (define pregexp regexp) (define byte-pregexp byte-regexp)) @@ -224,21 +225,21 @@ exec racket -qu "$0" ${1+"$@"} (list 'stress-xs (make-bytes 1000 (char->integer #\x)) #"x*" 100000 '()) (list 'stress-xs (make-bytes 10000 (char->integer #\x)) #"x*" 10000 '()) (list 'stress-xs (make-bytes 100000 (char->integer #\x)) #"x*" 1000 '()) - (list 'stress-xy (make-bytes 100 (char->integer #\x)) #"[xy]*" 100000 '()) - (list 'stress-xy (make-bytes 1000 (char->integer #\x)) #"[xy]*" 10000 '()) - (list 'stress-xy (make-bytes 10000 (char->integer #\x)) #"[xy]*" 1000 '()) - (list 'stress-xy (make-bytes 100000 (char->integer #\x)) #"[xy]*" 100 '()) + (list 'stress-xy (make-bytes 100 (char->integer #\x)) #"[xy]*" 1000000 '()) + (list 'stress-xy (make-bytes 1000 (char->integer #\x)) #"[xy]*" 100000 '()) + (list 'stress-xy (make-bytes 10000 (char->integer #\x)) #"[xy]*" 10000 '()) + (list 'stress-xy (make-bytes 100000 (char->integer #\x)) #"[xy]*" 1000 '()) (list 'stress-xysave (make-bytes 100 (char->integer #\x)) #"([xy])*" 100000 '()) - (list 'stress-xory (make-bytes 100 (char->integer #\x)) #"(?:y|x)*" 10000 '()) - (list 'stress-xory (make-bytes 1000 (char->integer #\x)) #"(?:y|x)*" 1000 '(python)) - (list 'stress-xory (make-bytes 10000 (char->integer #\x)) #"(?:y|x)*" 100 '(python)) - (list 'stress-xory (make-bytes 100000 (char->integer #\x)) #"(?:y|x)*" 10 '(pcre python)) - (list 'stress-xorysave (make-bytes 100 (char->integer #\x)) #"(y|x)*" 10000 '()) - (list 'stress-yzorx (make-bytes 100 (char->integer #\x)) #"(?:[yz]|x)*" 10000 '()) - (list 'stress-yzorx (make-bytes 1000 (char->integer #\x)) #"(?:[yz]|x)*" 1000 '(python)) - (list 'stress-yzorx (make-bytes 10000 (char->integer #\x)) #"(?:[yz]|x)*" 100 '(python)) - (list 'stress-yzorx (make-bytes 100000 (char->integer #\x)) #"(?:[yz]|x)*" 10 '(pcre python)) - (list 'stress-yzorxsave (make-bytes 100 (char->integer #\x)) #"([yz]|x)*" 10000 '()) + (list 'stress-xory (make-bytes 100 (char->integer #\x)) #"(?:y|x)*" 100000 '()) + (list 'stress-xory (make-bytes 1000 (char->integer #\x)) #"(?:y|x)*" 10000 '(python)) + (list 'stress-xory (make-bytes 10000 (char->integer #\x)) #"(?:y|x)*" 1000 '(python)) + (list 'stress-xory (make-bytes 100000 (char->integer #\x)) #"(?:y|x)*" 100 '(pcre python)) + (list 'stress-xorysave (make-bytes 100 (char->integer #\x)) #"(y|x)*" 100000 '()) + (list 'stress-yzorx (make-bytes 100 (char->integer #\x)) #"(?:[yz]|x)*" 100000 '()) + (list 'stress-yzorx (make-bytes 1000 (char->integer #\x)) #"(?:[yz]|x)*" 10000 '(python)) + (list 'stress-yzorx (make-bytes 10000 (char->integer #\x)) #"(?:[yz]|x)*" 1000 '(python)) + (list 'stress-yzorx (make-bytes 100000 (char->integer #\x)) #"(?:[yz]|x)*" 100 '(pcre python)) + (list 'stress-yzorxsave (make-bytes 100 (char->integer #\x)) #"([yz]|x)*" 100000 '()) (list 'stress-x2 (make-bytes 100 (char->integer #\x)) #"(?:x{2})*" 10000 '(rxmzold)) (list 'stress-x2 (make-bytes 1000 (char->integer #\x)) #"(?:x{2})*" 10000 '(python rxmzold)) (list 'stress-x2 (make-bytes 10000 (char->integer #\x)) #"(?:x{2})*" 100 '(python rxmzold)) diff --git a/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl b/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl index f6ca5ccadb..69c2e5f5da 100644 --- a/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl @@ -25,14 +25,16 @@ hold packages: @commandline{racket -l- pkg/dirs-catalog @nonterm{dest-catalog} @nonterm{dir} ...} -The @DFlag{link}, @DFlag{merge}, @DFlag{check-metadata}, and +The @DFlag{immediate}, @DFlag{link}, @DFlag{merge}, @DFlag{check-metadata}, and @DFlag{quiet} flags correspond to optional keyword arguments of @racket[create-dirs-catalog]. -@history[#:added "6.1.1.6"] +@history[#:added "6.1.1.6" + #:changed "6.90.0.4" @elem{Added @DFlag{immediate}.}] @defproc[(create-dirs-catalog [catalog-path path-string?] [dirs (listof path-string?)] + [#:immediate? immediate? any/c #f] [#:link? link? any/c #f] [#:merge? merge? any/c #f] [#:check-metadata? check-metadata? any/c #f] @@ -43,7 +45,9 @@ Creates or modifies @racket[catalog-path] as a directory that works as a catalog (see @secref["catalog-protocol"]) to list the packages that are contained in each directory specified by @racket[dirs]. Packages are discovered in @racket[dirs] as subdirectories that have an -@filepath{info.rkt} file. +@filepath{info.rkt} file; if @racket[immediate?] is true, then each +directory is @racket[dirs] is checked for an immediate @filepath{info.rkt} +file before checking subdirectories. If @racket[link?] is true, then the catalog specifies that the package should be installed as a directory link, as opposed to copies. @@ -56,4 +60,6 @@ To create author and description information for each package in the catalog, @racket[create-dirs-catalog] looks for a @racket[pkg-authors] and @racket[pkg-desc] definition in each package's @filepath{info.rkt} file. If either definition is missing and @racket[check-metadata?] is -true, an error is reported.} +true, an error is reported. + +@history[#:changed "6.90.0.4" @elem{Added the @racket[#:immediate] argument.}]} diff --git a/pkgs/racket-doc/scribblings/foreign/derived.scrbl b/pkgs/racket-doc/scribblings/foreign/derived.scrbl index e113bf8464..8942e74149 100644 --- a/pkgs/racket-doc/scribblings/foreign/derived.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/derived.scrbl @@ -17,6 +17,7 @@ @include-section["schedule.scrbl"] @include-section["port.scrbl"] @include-section["global.scrbl"] +@include-section["os-thread.scrbl"] @include-section["objc.scrbl"] @include-section["ns.scrbl"] @include-section["com.scrbl"] diff --git a/pkgs/racket-doc/scribblings/foreign/os-thread.scrbl b/pkgs/racket-doc/scribblings/foreign/os-thread.scrbl new file mode 100644 index 0000000000..7ced9b72b2 --- /dev/null +++ b/pkgs/racket-doc/scribblings/foreign/os-thread.scrbl @@ -0,0 +1,63 @@ +#lang scribble/doc +@(require "utils.rkt" + (for-label ffi/unsafe/os-thread)) + +@title{Operating System Threads} + +@defmodule[ffi/unsafe/os-thread]{The +@racketmodname[ffi/unsafe/os-thread] library provides functions for +running constrained Racket code in a separate thread at the +operating-system level. Except for @racket[os-thread-enabled?], the +functions of @racketmodname[ffi/unsafe/os-thread] are currently +supported only when @racket[(system-type 'vm)] returns +@racket['chez-scheme], and even then only in certain build modes. The +functions raise @racket[exn:fail:unsupported] when not supported.} + +@history[#:added "6.90.0.9"] + + +@defproc[(os-thread-enabled?) boolean?]{ + +Returns @racket[#t] if the other functions of +@racketmodname[ffi/unsafe/os-thread] work without raising +@racket[exn:fail:unsupported], @racket[#f] otherwise.} + + +@defproc[(call-in-os-thread [thunk (-> any)]) void?]{ + +Runs @racket[thunk] in a separate operating-system thread, which runs +concurrently to all Racket threads. + +The @racket[thunk] is run in @tech{atomic mode}, and it must not +inspect its continuation or use any Racket thread functions (such as +@racket[thread] or @racket[current-thread]), any Racket +synchronization functions (such as @racket[semaphore-post] or +@racket[sync]), or any parameters (such as +@racket[current-output-port]). Variables may be safely mutated with +@racket[set!], and vectors, mutable pairs, boxes, mutable structure +fields, and @racket[eq?]- and @racket[eqv?]-based hash tables can be +mutated, but the visibility of mutations to other threads is +unspecified except as synchronized through @racket[os-semaphore-wait] +and @racket[os-semaphore-post].} + + +@defproc[(make-os-semaphore) any]{ + +Creates a semaphore that can be used with @racket[os-semaphore-wait] +and @racket[os-semaphore-post] to synchronize an operating-system +thread with Racket threads and other operating-system threads.} + + +@defproc[(os-semaphore-post [sema any/c]) void?]{ + +Analogous to @racket[semaphore-post], but posts to a semaphore created +by @racket[make-os-semaphore].} + + +@defproc[(os-semaphore-wait [sema any/c]) void?]{ + +Analogous to @racket[semaphore-wait], but waits on a semaphore created +by @racket[make-os-semaphore]. Waiting blocks the current thread; if +the current thread is a Racket thread, then waiting also blocks all +Racket threads.} + diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index 8a43715b94..53b488c170 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -553,10 +553,11 @@ For @tech{callouts} to foreign functions with the generated type: @item{If @racket[blocking?] is true, then a foreign @tech{callout} deactivates tracking of the calling OS thread---to the degree - supported by the Racket variant---during the foreign call. - Currently the value of @racket[blocking?] has no effect, but it - may enable activity such as concurrent garbage collection in - future variants of Racket. If the blocking @tech{callout} can + supported by the Racket variant---during the foreign call. The + value of @racket[blocking?] affects only the @tech[#:doc + guide.scrbl]{CS} variant of Racket, where it enable activity + such as garbage collection in other OS threads while the + @tech{callout} blocks. If the blocking @tech{callout} can invoke any @tech{callbacks} back to Racket, those @tech{callbacks} must be constructed with a non-@racket[#f] value of @racket[async-apply], even if they are always applied diff --git a/pkgs/racket-doc/scribblings/foreign/unexported.scrbl b/pkgs/racket-doc/scribblings/foreign/unexported.scrbl index 8d30bdc15f..8d618329df 100644 --- a/pkgs/racket-doc/scribblings/foreign/unexported.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/unexported.scrbl @@ -45,25 +45,47 @@ cstructs, and another ctype for user-defined ctypes.} @defproc[(ffi-call [ptr cpointer?] [in-types (listof ctype?)] [out-type ctype?] [abi (or/c #f 'default 'stdcall 'sysv) #f] [save-errno? any/c] - [orig-place? any/c]) + [orig-place? any/c] + [lock-name (or/c #f string?) #f] + [blocking? any/c #f]) procedure?]{ -The primitive mechanism that creates Racket ``callout'' values for +The primitive mechanism that creates Racket @tech{callout} values for @racket[_cprocedure]. The given @racket[ptr] is wrapped in a Racket-callable primitive function that uses the types to specify how values are marshaled.} +@defproc[(ffi-call-maker [in-types (listof ctype?)] [out-type ctype?] + [abi (or/c #f 'default 'stdcall 'sysv) #f] + [save-errno? any/c] + [orig-place? any/c] + [lock-name (or/c #f string?) #f] + [blocking? any/c #f]) + (cpointer . -> . procedure?)]{ -@defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c] +A curried variant of @racket[ffi-call] that takes the foreign-procedure pointer +separately.} + + +@defproc[(ffi-callback [proc procedure?] [in-types any/c] [out-type any/c] [abi (or/c #f 'default 'stdcall 'sysv) #f] [atomic? any/c #f] [async-apply (or/c #f ((-> any) . -> . any)) #f]) ffi-callback?]{ The symmetric counterpart of @racket[ffi-call]. It receives a Racket -procedure and creates a callback object, which can also be used as a +procedure and creates a @tech{callback} object, which can also be used as a C pointer.} +@defproc[(ffi-callback-maker [in-types any/c] [out-type any/c] + [abi (or/c #f 'default 'stdcall 'sysv) #f] + [atomic? any/c #f] + [async-apply (or/c #f ((-> any) . -> . any)) #f]) + (procedure? . -> . ffi-callback?)]{ + +A curried variant of @racket[ffi-callback] that takes the callback procedure +separately.} + @defproc[(ffi-callback? [x any/c]) boolean?]{ diff --git a/pkgs/racket-doc/scribblings/guide/performance.scrbl b/pkgs/racket-doc/scribblings/guide/performance.scrbl index 3e2e8bbfd6..c91ab9feaa 100644 --- a/pkgs/racket-doc/scribblings/guide/performance.scrbl +++ b/pkgs/racket-doc/scribblings/guide/performance.scrbl @@ -419,13 +419,13 @@ string or byte string, write a constant @tech{regexp} using an @section[#:tag "gc-perf"]{Memory Management} -The Racket implementation is available in two variants: @deftech{3m} and -@deftech{CGC}. The @tech{3m} variant uses a modern, +The Racket implementation is available in three variants: @deftech{3m}, +@deftech{CGC}, and @deftech{CS}. The @tech{3m} and @tech{CS} variants use a modern, @deftech{generational garbage collector} that makes allocation relatively cheap for short-lived objects. The @tech{CGC} variant uses a @deftech{conservative garbage collector} which facilitates interaction with C code at the expense of both precision and speed for -Racket memory management. The 3m variant is the standard one. +Racket memory management. The @tech{3m} variant is currently the standard one. Although memory allocation is reasonably cheap, avoiding allocation altogether is normally faster. One particular place where allocation diff --git a/pkgs/racket-doc/scribblings/raco/decompile.scrbl b/pkgs/racket-doc/scribblings/raco/decompile.scrbl index 8cb9d9c4e1..d6281e367a 100644 --- a/pkgs/racket-doc/scribblings/raco/decompile.scrbl +++ b/pkgs/racket-doc/scribblings/raco/decompile.scrbl @@ -4,7 +4,7 @@ "common.rkt" (for-label racket/base compiler/decompile - (only-in compiler/zo-parse compilation-top? req) + (only-in compiler/zo-parse linkl-directory? linkl-bundle? linkl?) compiler/zo-marshal)) @title[#:tag "decompile"]{@exec{raco decompile}: Decompiling Bytecode} @@ -133,7 +133,7 @@ Many forms in the decompiled code, such as @racket[module], @defmodule[compiler/decompile] -@defproc[(decompile [top compilation-top?]) any/c]{ +@defproc[(decompile [top (or/c linkl-directory? linkl-bundle? linkl?)]) any/c]{ Consumes the result of parsing bytecode and returns an S-expression (as described above) that represents the compiled code.} @@ -148,11 +148,11 @@ Consumes the result of parsing bytecode and returns an S-expression @defmodule[compiler/zo-marshal] -@defproc[(zo-marshal-to [top compilation-top?] [out output-port?]) void?]{ +@defproc[(zo-marshal-to [top (or/c linkl-directory? linkl-bundle?)] [out output-port?]) void?]{ Consumes a representation of bytecode and writes it to @racket[out].} -@defproc[(zo-marshal [top compilation-top?]) bytes?]{ +@defproc[(zo-marshal [top (or/c linkl-directory? linkl-bundle?)]) bytes?]{ Consumes a representation of bytecode and generates a byte string for the marshaled bytecode.} @@ -160,4 +160,3 @@ the marshaled bytecode.} @; ------------------------------------------------------------ @include-section["zo-struct.scrbl"] - diff --git a/pkgs/racket-doc/scribblings/raco/exe-api.scrbl b/pkgs/racket-doc/scribblings/raco/exe-api.scrbl index f9928fc74f..318a252f67 100644 --- a/pkgs/racket-doc/scribblings/raco/exe-api.scrbl +++ b/pkgs/racket-doc/scribblings/raco/exe-api.scrbl @@ -71,7 +71,7 @@ parameter is true. null] [#:gracket? gracket? any/c #f] [#:mred? mred? any/c #f] - [#:variant variant (or/c 'cgc '3m) + [#:variant variant (or/c 'cgc '3m 'cs) (system-type 'gc)] [#:aux aux (listof (cons/c symbol? any/c)) null] [#:collects-path collects-path @@ -384,7 +384,7 @@ have been applied as needed to refer to the existing file).} [cmdline (listof string?)] [aux (listof (cons/c symbol? any/c)) null] [launcher? any/c #f] - [variant (one-of/c 'cgc '3m) (system-type 'gc)] + [variant (one-of/c 'cgc '3m'cs) (system-type 'gc)] [collects-path (or/c #f path-string? (listof path-string?)) @@ -477,9 +477,9 @@ A unit that imports nothing and exports @racket[compiler:embed^].} @defproc[(find-exe [#:cross? cross? any/c #f] [#:untetherd? untethered? any/c #f] [gracket? any/c #f] - [variant (or/c 'cgc '3m) (if cross? - (cross-system-type 'gc) - (system-type 'gc))]) + [variant (or/c 'cgc '3m 'cs) (if cross? + (cross-system-type 'gc) + (system-type 'gc))]) path?]{ Finds the path to the @exec{racket} or @exec{gracket} (when diff --git a/pkgs/racket-doc/scribblings/raco/exe.scrbl b/pkgs/racket-doc/scribblings/raco/exe.scrbl index bb794d8eb1..168b8b6a8d 100644 --- a/pkgs/racket-doc/scribblings/raco/exe.scrbl +++ b/pkgs/racket-doc/scribblings/raco/exe.scrbl @@ -146,6 +146,10 @@ The @exec{raco exe} command accepts the following command-line flags: variant of Racket, which is the default only when running a @exec{raco exe} that is based on the @gtech{CGC} variant.} + @item{@DFlag{cs} --- generate an executable based on the @gtech{cs} + variant of Racket, which is the default unless running a @exec{raco + exe} that is based on the @gtech{CS} variant.} + @item{@DPFlag{aux} @nonterm{file} --- attach information to the executable based on @nonterm{file}'s suffix; see @racket[extract-aux-from-path] for a list of recognized suffixes diff --git a/pkgs/racket-doc/scribblings/raco/launcher.scrbl b/pkgs/racket-doc/scribblings/raco/launcher.scrbl index 297532f8da..daece40c57 100644 --- a/pkgs/racket-doc/scribblings/raco/launcher.scrbl +++ b/pkgs/racket-doc/scribblings/raco/launcher.scrbl @@ -55,9 +55,9 @@ the following additional associations apply to launchers: Racket or GRacket binary, like @exec{raco.exe}. No other @racket[aux] associations are used for an old-style launcher.} - @item{@racket['exe-name] (Mac OS, @racket['script-3m] or - @racket['script-cgc] variant) --- provides the base name for a - @racket['3m]-/@racket['cgc]-variant launcher, which the script + @item{@racket['exe-name] (Mac OS, @racket['script-3m], + @racket['script-cgc] or @racket['script-cs] variant) --- provides the base name for a + @racket['3m]-/@racket['cgc]-/@racket['cs]-variant launcher, which the script will call ignoring @racket[args]. If this name is not provided, the script will go through the GRacket executable as usual.} @@ -527,24 +527,24 @@ are as follows: A parameter that indicates a variant of Racket or GRacket to use for launcher creation and for generating launcher names. The default is the result of @racket[(system-type 'gc)]. On Unix and Windows, the -possibilities are @racket['cgc] and @racket['3m]. On Mac OS, the -@racket['script-3m] and @racket['script-cgc] variants are also +possibilities are @racket['cgc], @racket['3m], and @racket['cs]. On Mac OS, the +@racket['script-cgc], @racket['script-3m], and @racket['script-cs] variants are also available for GRacket launchers.} @defproc[(available-gracket-variants) (listof symbol?)]{ Returns a list of symbols corresponding to available variants of GRacket in the current Racket installation. The list normally includes at -least one of @racket['3m] or @racket['cgc]--- whichever is the result -of @racket[(system-type 'gc)]---and may include the other, as well as -@racket['script-3m] and/or @racket['script-cgc] on Mac OS.} +least one of @racket['3m], @racket['cgc], or @racket['cs]--- whichever is the result +of @racket[(system-type 'gc)]---and may include the others, as well as +@racket['script-3m], @racket['script-cgc], and/or @racket['script-cs] on Mac OS.} @defproc[(available-racket-variants) (listof symbol?)]{ Returns a list of symbols corresponding to available variants of Racket in the current Racket installation. The list normally -includes at least one of @racket['3m] or @racket['cgc]---whichever is -the result of @racket[(system-type 'gc)]---and may include the other.} +includes at least one of @racket['3m], @racket['cgc], or @racket['cs]---whichever is +the result of @racket[(system-type 'gc)]---and may include the others.} @deftogether[( @defproc[(mred-launcher-up-to-date? [dest path-string?] diff --git a/pkgs/racket-doc/scribblings/raco/make.scrbl b/pkgs/racket-doc/scribblings/raco/make.scrbl index a87482ca0b..bec9f1269c 100644 --- a/pkgs/racket-doc/scribblings/raco/make.scrbl +++ b/pkgs/racket-doc/scribblings/raco/make.scrbl @@ -830,4 +830,23 @@ module and use @exec{raco make} in its default mode. @(close-eval cm-eval) @; ---------------------------------------------------------------------- + @include-section["api.scrbl"] + +@; ---------------------------------------------------------------------- + +@section{API for Reading Compilation Dependencies} + +@defmodule[compiler/depend]{The @racketmodname[compiler/depend] module +provides a function to inspect and traverse the dependency information +generated by @exec{raco make}, @exec{raco setup}, or @racketmodname[compiler/cm].} + +@history[#:added "6.90.0.13"] + +@defproc[(module-recorded-dependencies [module-file path?]) + (listof (and path? (complete-path? path?)))]{ + +Given a @racket[module-file] for a file that has been compiled with +@exec{raco make}, @exec{raco setup}, or @racketmodname[compiler/cm], +returns a list of dependencies for @racket[module-file] by reading and +traversing dependency-information files left behind by compilation.} diff --git a/pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-doc/scribblings/raco/setup.scrbl index c6077f25a5..628eeb8843 100644 --- a/pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/pkgs/racket-doc/scribblings/raco/setup.scrbl @@ -285,6 +285,28 @@ flags: install archive into the installation instead of a user-specific location.} +]} +@item{Bootstrapping: +@itemize[ + + @item{@DFlag{boot} @nonterm{module-file} @nonterm{build-dir} --- For + use by directly running @racketmodname[setup] instead of + through @exec{raco setup}, loads @nonterm{module-file} in the + same way that @exec{raco setup} normally loads itself, + auto-detecting the need to start from sources and rebuild the + compiled files---even for the compilation manager itself. The + @nonterm{build-dir} path is installed as the only path in + @racket[current-compiled-file-roots], so all compiled files + go there.} + + @item{@DFlag{chain} @nonterm{module-file} @nonterm{build-dir} --- + Like @DFlag{boot}, but adds @nonterm{build-dir} to the start of + @racket[current-compiled-file-roots] instead of replacing the + current value, which means that libraries already built in the + normal location (including the compilation manager itself) will + be used instead of rebuilt. This mode makes sense for + cross-compilation.} + ]} ] @@ -1174,6 +1196,19 @@ form.} } +@; ---------------------------------------- + +@subsection{Setup Start Module} + +@defmodule[setup]{The @racketmodname[setup] library implements +@exec{raco setup}, including the part that bootstraps @exec{raco setup} +if its own implementation needs to be compiled.} + +When running @racketmodname[setup] via @exec{racket}, supply the +@exec{@Flag{N} raco} to ensure that command-line arguments are parsed +the same way as for @exec{raco setup}, as opposed to a legacy +command-line mode. + @; ------------------------------------------------------------------------ @section[#:tag ".plt-archives"]{API for Installing @filepath{.plt} Archives} @@ -2019,7 +2054,7 @@ platform's installation already includes those libraries. @history[#:added "6.3"] -@defproc[(cross-system-type [mode (or/c 'os 'word 'gc 'link 'machine +@defproc[(cross-system-type [mode (or/c 'os 'word 'gc 'vm 'link 'machine 'so-suffix 'so-mode 'fs-change) 'os]) (or/c symbol? string? bytes? exact-positive-integer? vector?)]{ @@ -2032,7 +2067,7 @@ cross-installation mode, the results are the same as for See also @racket['cross] mode for @racket[system-type].} -@defproc[(cross-system-library-subpath [mode (or/c 'cgc '3m #f) +@defproc[(cross-system-library-subpath [mode (or/c 'cgc '3m 'cs #f) (system-type 'gc)]) path-for-some-system?]{ diff --git a/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl b/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl index 8f3b305c4b..0423edbc6f 100644 --- a/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl +++ b/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl @@ -16,19 +16,17 @@ The @racketmodname[compiler/zo-parse] module re-exports @racketmodname[compiler/zo-structs] in addition to @racket[zo-parse]. -@defproc[(zo-parse [in input-port? (current-input-port)]) compilation-top?]{ +@defproc[(zo-parse [in input-port? (current-input-port)]) (or/c linkl-directory? linkl-bundle?)]{ Parses a port (typically the result of opening a @filepath{.zo} file) containing bytecode. Beware that the structure types used to represent the bytecode are subject to frequent changes across Racket versons. - The parsed bytecode is returned in a @racket[compilation-top] - structure. For a compiled module, the @racket[compilation-top] - structure will contain a @racket[mod] structure. For a top-level - sequence, it will normally contain a @racket[seq] or @racket[splice] - structure with a list of top-level declarations and expressions. + The parsed bytecode is returned in a @racket[link-directory] or + @racket[link-bundle] structure---the latter only for the compilation + of a module that contains no submodules. - The bytecode representation of an expression is closer to an + Within a linklet, the bytecode representation of an expression is closer to an S-expression than a traditional, flat control string. For example, an @racket[if] form is represented by a @racket[branch] structure that has three fields: a test expression, a ``then'' expression, and an @@ -67,14 +65,7 @@ The @racketmodname[compiler/zo-parse] module re-exports bucket array in the same way that it captured and restores a local variable. Mutable local variables are boxed similarly to global variables, but individual boxes are referenced from the stack and - closures. - - Quoted syntax (in the sense of @racket[quote-syntax]) is treated like - a global variable, because it must be instantiated for an appropriate - phase. A @racket[prefix] structure within a @racket[compilation-top] - or @racket[mod] structure indicates the list of global variables and - quoted syntax that need to be instantiated (and put into an array on - the stack) before evaluating expressions that might use them.} + closures.} @defproc[(decode-module-binding [binding module-binding?] diff --git a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl b/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl index e74a57376a..21357b5cdc 100644 --- a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl +++ b/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl @@ -34,96 +34,99 @@ structures that are produced by @racket[zo-parse] and consumed by @; -------------------------------------------------- @section{Prefix} -@defstruct+[(compilation-top zo) - ([max-let-depth exact-nonnegative-integer?] - [binding-namess (hash/c exact-nonnegative-integer? - (hash/c symbol? stx?))] - [prefix prefix?] - [code (or/c form? any/c)])]{ +@deftogether[( +@defstruct+[(linkl-directory zo) + ([table (hash/c (listof symbol?) linkl-bundle?)])] +@defstruct+[(linkl-bundle zo) + ([table (hash/c (or/c symbol? fixnum?) (or linkl? any/c))])] +)]{ Wraps compiled code. - The @racket[max-let-depth] field indicates the - maximum stack depth that @racket[code] creates (not counting the - @racket[prefix] array). + Module and top-level compilation produce one or more linklets that + represent independent evaluation in a specific phase. Even a single + top-level expression or a module with only run-time code will + generate multiple linklets to implement metadata and syntax data. A + module with no submodules is represented directly by a + @racket[linkl-bundle], while any other compiled form is represented + by a @racket[linkl-directory]. - The @racket[binding-namess] field provides a per-phase mapping from - symbols that appear in @racket[prefix] for top-level - @racket[def-values] forms and in top-level @racket[def-syntaxes] - forms. Each symbol is mapped to an identifier that will be bound - (after introduction into the namespace) by the definition. + A linklet bundle maps an integer to a linklet representing forms to + evaluate at the integer-indicated phase. Symbols are mapped to + metadata, such as a module's name as compiled or a linklet + implementing literal syntax objects. A linklet directory normally + maps @racket['()] to the main linklet bundle for a module or a single + top-level form; for a linklet directory that corresponds to a + sequence of top-level forms, however, there is no ``main'' linklet + bundle, and symbol forms of integers are used to order the linkets. + + For a module with submodules, the linklet directory maps submodule + paths (as lists of symbols) to linklet bundles for the corresponding + submodules.} - The @racket[prefix] field describes top-level variables, - module-level variables, and quoted syntax-objects accessed by - @racket[code]. +@defstruct+[(linkl zo) + ([name symbol?] + [importss (listof (listof symbol?))] + [import-shapess (listof (listof (or/c #f 'constant 'fixed + function-shape? + struct-shape?)))] + [exports (listof symbol?)] + [internals (listof (or/c symbol? #f))] + [lifts (listof symbol?)] + [source-names (hash/c symbol? symbol?)] + [body (listof (or/c form? any/c))] + [max-let-depth exact-nonnegative-integer?] + [need-instance-access? boolean?])]{ - The @racket[code] field contains executable code; it is normally a - @racket[form], but a literal value is represented as itself.} + Represents a linklet, which corresponds to a module body or a + top-level sequence at a single phase. -@defstruct+[(prefix zo) - ([num-lifts exact-nonnegative-integer?] - [toplevels (listof (or/c #f symbol? global-bucket? - module-variable?))] - [stxs (listof (or stx? #f))] - [src-inspector-desc symbol?])]{ - Represents a ``prefix'' that is pushed onto the stack to initiate - evaluation. The prefix is an array, where buckets holding the - values for @racket[toplevels] are first, then the buckets for the - @racket[stxs], then a bucket for another array if @racket[stxs] is - non-empty, then @racket[num-lifts] extra buckets for lifted local - procedures. + The @racket[name] of a linklet is for debugging purposes, similar to + the inferred name of a @racket[lambda] form. - In @racket[toplevels], each element is one of the following: - @itemize[ - @item{a @racket[#f], which indicates a dummy variable that is used - to access the enclosing module/namespace at run time;} - @item{a symbol, which is a reference to a variable defined in the - enclosing module;} - @item{a @racket[global-bucket], which is a top-level variable (appears - only outside of modules); or} - @item{a @racket[module-variable], which indicates a variable imported - from another module.} - ] + The @racket[importss] list of lists describes the linklet's imports. + Each of the elements of the out list corresponds to an import + source, and each element of an inner list is the symbolic name of an + export from that source. The @racket[import-shapess] list is in + parallel to @racket[imports]; it reflects optimization assumptions + by the compiler that are used by the bytecode validator and checked + when the linklet is instantiated. - The variable buckets and syntax objects that are recorded in a prefix - are accessed by @racket[toplevel] and @racket[topsyntax] expression - forms. - - When an element of @racket[stxs] is @racket[#f], it coresponds to a - syntax object that was optimized away at the last minute. The slot - must not be referenced by a @racket[topsyntax] form. + The @racket[exports] list describes the linklet's defined names that + are exported. The @racket[internals] list describes additional + definitions within the linket, but they are not accessible from the + outside of a linklet or one of its instances; a @racket[#f] can appear + in place of an unreferenced internal definition that has been removed. + The @racket[lifts] list + is an extension of @racket[internals] for procedures that are lifted + by the compiler; these procedures have certain properties that can be + checked by the bytecode validator. - The @racket[src-inspector-desc] field provides an inspector name that - is used within syntax-object bindings. At run time, the prefix gets - an inspector, and bindings that reference the same inspector name are - granted access capabilities through that inspector.} + Each symbol in @racket[exports], + @racket[internals], and @racket[lifts] must be distinct from any + other symbol in those lists. The @racket[source-names] table maps + symbols in @racket[exports], @racket[internals], and @racket[lifts] + to other symbols, potentially not distinct, that correspond to + original source names for the definition. The @racket[source-names] + table is used only for debugging. -@defstruct+[(global-bucket zo) ([name symbol?])]{ - Represents a top-level variable, and used only in a - @racket[prefix]. Because modules cannot require top-level - variables, these will only appear in the top level - @racket[prefix]. Additionally, symbols in the top-level - prefix are an alias for @racket[global-bucket] structs, - making them redundant.} + When a linklet is instantiated, variables correponding to the + flattening of the lists @racket[importss], @racket[exports], + @racket[internals], and @racket[lifts] are placed in an array (in + that order) for access via @racket[toplevel] references. The initial + slot is reserved for a variable-like reference that strongly retains + a connection to an instance of its enclosing linklet. -@defstruct+[(module-variable zo) - ([modidx module-path-index?] - [sym symbol?] - [pos exact-integer?] - [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed - function-shape? struct-shape?)])]{ - Represents a top-level variable, and used only in a @racket[prefix]. - The @racket[pos] may record the variable's offset within its module, - or it can be @racket[-1] if the variable is always located by name. - The @racket[phase] indicates the phase level of the definition within - its module. The @racket[constantness] field is either @racket['constant], - a @racket[function-shape] value, or a @racket[struct-shape] value - to indicate that - variable's value is always the same for every instantiation of its module; - @racket['fixed] to indicate - that it doesn't change within a particular instantiation of the module; - or @racket[#f] to indicate that the variable's value - can change even for one particular instantiation of its module.} + The @racket[bodys] list is the executable content of the linklet. The + value of the last element in @racket[bodys] may be returned when the + linklet is instantiated, depending on the way that it's instantiated. + + The @racket[max-let-depth] field indicates the maximum size of the + stack that will be created by any @racket[body]. + + The @racket[need-instance-access?] boolean indicates whether the + linklet contains a @racket[toplevel] for position 0. A @racket[#t] is + allowed (but suboptimal) if not such reference is present in the + linklet body.} @defstruct+[function-shape ([arity procedure-arity?] @@ -137,11 +140,11 @@ returns.} @deftogether[( @defstruct+[struct-shape ()] -@defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])] +@defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])] @defstruct+[(constructor-shape struct-shape) ([arity exact-nonnegative-integer?])] -@defstruct+[(predicate-shape struct-shape) ()] -@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])] -@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])] +@defstruct+[(predicate-shape struct-shape) ([authentic? boolean?])] +@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])] +@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])] @defstruct+[(struct-type-property-shape struct-shape) ([has-guard? boolean?])] @defstruct+[(property-predicate-shape struct-shape) ()] @defstruct+[(property-accessor-shape struct-shape) ()] @@ -156,10 +159,10 @@ binding, constructor, etc.} @; -------------------------------------------------- -@section{Forms} +@section{Forms and Inline Variants} @defstruct+[(form zo) ()]{ - A supertype for all forms that can appear in compiled code (including + A supertype for all forms that can appear in a linklet body (including @racket[expr]s), except for literals that are represented as themselves.} @@ -167,170 +170,24 @@ binding, constructor, etc.} ([ids (listof toplevel?)] [rhs (or/c expr? seq? inline-variant? any/c)])]{ Represents a @racket[define-values] form. Each element of - @racket[ids] will reference via the prefix either a top-level variable - or a local module variable. + @racket[ids] references a defined variable in the enclosing linklet. After @racket[rhs] is evaluated, the stack is restored to its depth from before evaluating @racket[rhs].} -@deftogether[( -@defstruct+[(def-syntaxes form) ([ids (listof symbol?)] - [rhs (or/c expr? seq? any/c)] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])] -@defstruct+[(seq-for-syntax form) - ([forms (listof (or/c form? any/c))] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])] -)]{ - Represents a @racket[define-syntaxes] or - @racket[begin-for-syntax] form. The @racket[rhs] expression or set of - @racket[forms] forms has its own @racket[prefix], which is pushed before evaluating - @racket[rhs] or the @racket[forms]; the stack is restored after obtaining the result values. - The @racket[max-let-depth] field indicates the maximum size of the - stack that will be created by @racket[rhs] (not counting - @racket[prefix]). The @racket[dummy] variable is used to access the enclosing - namespace.} - -@defstruct+[(req form) ([reqs stx?] - [dummy toplevel?])]{ - Represents a top-level @racket[#%require] form (but not one in a - @racket[module] form) with a sequence of specifications @racket[reqs]. - The @racket[dummy] variable is used to access the top-level - namespace.} - -@defstruct+[(seq form) ([forms (listof (or/c form? any/c))])]{ - Represents a @racket[begin] form, either as an expression or at the - top level (though the latter is more commonly a @racket[splice] form). - When a @racket[seq] appears in an expression position, its - @racket[forms] are expressions. - - After each form in @racket[forms] is evaluated, the stack is restored - to its depth from before evaluating the form.} - -@defstruct+[(splice form) ([forms (listof (or/c form? any/c))])]{ - Represents a top-level @racket[begin] form where each evaluation is - wrapped with a continuation prompt. - - After each form in @racket[forms] is evaluated, the stack is restored - to its depth from before evaluating the form.} - -@defstruct+[(inline-variant form) ([direct expr?] - [inline expr?])]{ +@defstruct+[(inline-variant zo) ([direct expr?] + [inline expr?])]{ Represents a function that is bound by @racket[define-values], where the function has two variants. The first variant is used for normal calls to the function. The second may be used for cross-module inlining of the function.} -@defstruct+[(mod form) - ([name (or/c symbol? (listof symbol?))] - [srcname symbol?] - [self-modidx module-path-index?] - [prefix prefix?] - [provides (listof (list/c (or/c exact-integer? #f) - (listof provided?) - (listof provided?)))] - [requires (listof (cons/c (or/c exact-integer? #f) - (listof module-path-index?)))] - [body (listof (or/c form? any/c))] - [syntax-bodies (listof (cons/c exact-positive-integer? - (listof (or/c def-syntaxes? - seq-for-syntax?))))] - [unexported (listof (list/c exact-nonnegative-integer? - (listof symbol?) - (listof symbol?)))] - [max-let-depth exact-nonnegative-integer?] - [dummy toplevel?] - [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx? (vectorof stx?))] - [binding-names (hash/c exact-integer? - (hash/c symbol? (or/c #t stx?)))] - [flags (listof (or/c 'cross-phase))] - [pre-submodules (listof mod?)] - [post-submodules (listof mod?)])]{ - Represents a @racket[module] declaration. - - The @racket[provides] and @racket[requires] lists are each an - association list from phases to exports or imports. In the case of - @racket[provides], each phase maps to two lists: one for exported - variables, and another for exported syntax. In the case of - @racket[requires], each phase maps to a list of imported module paths. - - The @racket[body] field contains the module's run-time (i.e., phase - 0) code. The @racket[syntax-bodies] list has a list of forms for - each higher phase in the module body; the phases are in order - starting with phase 1. The @racket[body] forms use @racket[prefix], - rather than any prefix in place for the module declaration itself, - while members of lists in @racket[syntax-bodies] have their own - prefixes. After each form in @racket[body] or @racket[syntax-bodies] - is evaluated, the stack is restored to its depth from before - evaluating the form. - - The @racket[unexported] list contains lists of symbols for - unexported definitions that can be accessed through macro expansion - and that are implemented through the forms in @racket[body] and - @racket[syntax-bodies]. Each list in @racket[unexported] starts - with a phase level. - - The @racket[max-let-depth] field indicates the maximum stack depth - created by @racket[body] forms (not counting the @racket[prefix] - array). - - The @racket[dummy] variable is used to access the top-level - namespace. - - The @racket[lang-info] value specifies an optional module path that - provides information about the module's implementation language. - - The @racket[internal-context] value describes the lexical context of - the body of the module. This value is used by - @racket[module->namespace]. A @racket[#f] value means that the - context is unavailable or empty. A @racket[#t] value means that the - context is computed by re-importing all required modules. A - syntax-object value embeds lexical information; the syntax object - should contain a vector of two elements, where the first element of - the vector is a syntax object for the module's body, which includes - the outside-edge and inside-edge scopes, and the second element of - the vector is a syntax object that has just the module's inside-edge - scope. - - The @racket[binding-names] value provides additional information to - @racket[module->namespace] to correlate symbol names for variables - and syntax definitions to identifiers that map to those variables. A - separate table of names exists for each phase, and a @racket[#t] - mapping for a name indicates that it is mapped but inaccessible - (because the relevant scopes are inaccessible). - - The @racket[flags] field records certain properties of the module. - The @racket['cross-phase] flag indicates that the module body is - evaluated once and the results shared across instances for all phases; such a - module contains only definitions of functions, structure types, and - structure type properties. - - The @racket[pre-submodules] field records @racket[module]-declared - submodules, while the @racket[post-submodules] field records - @racket[module*]-declared submodules.} - -@defstruct+[(provided zo) - ([name symbol?] - [src (or/c module-path-index? #f)] - [src-name symbol?] - [nom-src (or/c module-path-index? #f)] - [src-phase exact-nonnegative-integer?] - [protected? boolean?])]{ - Describes an individual provided identifier within a @racket[mod] - instance.} - @; -------------------------------------------------- @section{Expressions} @defstruct+[(expr form) ()]{ A supertype for all expression forms that can appear in compiled code, - except for literals that are represented as themselves and some - @racket[seq] structures (which can appear as an expression as long as - it contains only other things that can be expressions).} + except for literals that are represented as themselves.} @defstruct+[(lam expr) ([name (or/c symbol? vector?)] @@ -367,7 +224,7 @@ binding, constructor, etc.} refers to a syntax-object constant, the variables and constants are represented in the closure by capturing a prefix (in the sense of @racket[prefix]). The @racket[toplevel-map] field indicates - which top-level and lifted variables are actually used by the + which top-level variables (i.e., linklet imports and definitions) are actually used by the closure (so that variables in a prefix can be pruned by the run-time system if they become unused) and whether any syntax objects are used (so that the syntax objects as a group can be similarly @@ -497,8 +354,8 @@ binding, constructor, etc.} [pos exact-nonnegative-integer?] [const? boolean?] [ready? boolean?])]{ - Represents a reference to a top-level or imported variable via the - @racket[prefix] array. The @racket[depth] field indicates the number + Represents a reference to an imported or defined variable within + a linklet. The @racket[depth] field indicates the number of stack slots to skip to reach the prefix array, and @racket[pos] is the offset into the array. @@ -513,21 +370,11 @@ binding, constructor, etc.} @racket[#f], then a check is needed to determine whether the variable is defined. - When the @racket[toplevel] is the right-hand side for - @racket[def-values], then @racket[const?] is @racket[#f]. If + When the @racket[toplevel] is the left-hand side for + @racket[def-values], then @racket[const?] is @racket[#f]. If @racket[ready?] is @racket[#t], the variable is marked as immutable after it is defined.} -@defstruct+[(topsyntax expr) - ([depth exact-nonnegative-integer?] - [pos exact-nonnegative-integer?] - [midpt exact-nonnegative-integer?])]{ - Represents a reference to a quoted syntax object via the - @racket[prefix] array. The @racket[depth] field indicates the number - of stack slots to skip to reach the prefix array, and @racket[pos] is - the offset into the array. The @racket[midpt] value is used - internally for lazy calculation of syntax information.} - @defstruct+[(application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])]{ @@ -556,6 +403,12 @@ binding, constructor, etc.} restored to its depth from before evaluating @racket[key] or @racket[val].} +@defstruct+[(seq expr) ([forms (listof (or/c expr? any/c))])]{ + Represents a @racket[begin] form. + + After each form in @racket[forms] is evaluated, the stack is restored + to its depth from before evaluating the form.} + @defstruct+[(beg0 expr) ([seq (listof (or/c expr? seq? any/c))])]{ Represents a @racket[begin0] expression. @@ -567,13 +420,20 @@ binding, constructor, etc.} expression in the list.} @defstruct+[(varref expr) ([toplevel (or/c toplevel? #t)] - [dummy (or/c toplevel? #f)])]{ + [dummy (or/c toplevel? #f)] + [constant? boolean?] + [from-unsafe? boolean?])]{ Represents a @racket[#%variable-reference] form. The @racket[toplevel] field is @racket[#t] if the original reference was to a constant local binding. The @racket[dummy] field accesses a variable bucket that strongly references its namespace (as opposed to a normal variable bucket, which only weakly references its - namespace); it can be @racket[#f].} + namespace); it can be @racket[#f]. + + The value of @racket[constant?] is true when the @racket[toplevel] + field is not @racket[#t] but the referenced variable is known to be + constant. The value of @racket[from-unsafe?] is true when the module + that created the reference was compiled in unsafe mode.} @defstruct+[(assign expr) ([id toplevel?] @@ -616,210 +476,3 @@ binding, constructor, etc.} Represents a direct reference to a variable imported from the run-time kernel.} -@; -------------------------------------------------- -@section{Syntax Objects} - -@defstruct+[(stx-obj zo) - ([datum any/c] - [wrap wrap?] - [srcloc (or/c #f srcloc?)] - [props (hash/c symbol? any/c)] - [tamper-status (or/c 'clean 'armed 'tainted)])]{ - Represents a syntax object, where @racket[wrap] contains lexical - information, @racket[srcloc] is the source location, - @racket[props] contains preserved properties, - and @racket[tamper-status] is taint information. When the - @racket[datum] part is itself compound, its pieces are wrapped - as @racket[stx-obj]s, too. - - The content of @racket[wrap] is typically cyclic, since it includes - scopes that contain bindings that refer to scopes.} - -@defstruct+[(wrap zo) ([shifts (listof module-shift?)] - [simple-scopes (listof scope?)] - [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))])]{ - Lexical information for a syntax object. The @racket[shifts] field - allows binding information to be relative to the enclosing module's - run-time path. The @racket[simple-scopes] field records scopes that - are attached to the syntax object at all phases, and @racket[multi-scopes] - records phase-specific scopes (which are always attached as a group) - along with a phase shift for every scope within the group.} - -@defstruct+[(module-shift zo) ([from (or/c #f module-path-index?)] - [to (or/c #f module-path-index?)] - [from-inspector-desc (or/c #f symbol?)] - [to-inspector-desc (or/c #f symbol?)])]{ - -Records a history of module path index replacements. These replacements -are applied in reverse order, and a module instantiation typically adds -one more shift to replace the current ``self'' module path index -with a run-time module path. The @racket[from] and @racket[to] -fields should be both @racket[#f] or both non-@racket[#f]. - -The @racket[from-inspector-desc] and @racket[to-inspector-desc] fields -similarly should be both @racket[#f] or both non-@racket[#f]. They -record a history of code-inspector replacements.} - - -@defstruct+[(scope zo) ([name (or/c 'root exact-nonnegative-integer?)] - [kind symbol?] - [bindings (listof (list/c symbol? (listof scope?) binding?)) #;#:mutable] - [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #;#:mutable] - [multi-owner (or/c #f multi-scope?) #;#:mutable])]{ - -Represents a scope. When @racket[name] is @racket['root] then the -scope represents the unique all-phases scope that is shared among -non-module namespaces. Otherwise, @racket[name] is intended to be -distinct for each @racket[scope] instance within a module or top-level -compilation, but the @racket[eq?]-identity of the @racket[scope] -instance ultimately determines its identity. The @racket[kind] symbol -similarly acts as a debugging hint in the same way as for -@racket[syntax-debug-info]. - -The @racket[bindings] list indicates some bindings that are associated -with the scope. Each element of the list includes a symbolic name, a -list of scopes (including the enclosing one), and the binding for the -combination of name and scope set. A given symbol can appear in -multiple elements of @racket[bindings], but the combination of the -symbol and scope set are unique within @racket[bindings] and across -all scopes. The mapping of a symbol and scope set to a binding is -recorded with an arbitrary member of the scope set. - -The @racket[bulk-bindings] field lists bindings of all exports from a -given module, which is an optimization over including each export in -@racket[bindings]. Elements of @racket[bindings] take precedence over -elements of @racket[bulk-bindings], and earlier elements of -@racket[bulk-bindings] take precedence over later elements. - -If the @racket[scope] represents a scope at a particular phase for a -group of phase-specific scopes, @racket[mark-owner] refers to the -group.} - - -@defstruct+[(multi-scope zo) ([name exact-nonnegative-integer?] - [src-name any/c] - [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #;#:mutable])]{ - -Represents a set of phase-specific scopes that are added or removed -from lexical information as a group. As for @racket[scope], the -@racket[name] field is intended to be distinct for different groups, -but the @racket[eq?] identity of the @racket[multi-scope] record -ultimately determines its identity. The @racket[src-name] field -similarly acts as a debugging hint in the same way as for -@racket[syntax-debug-info]. - -Scopes within the group are instantiated at different phases on -demand. The @racket[scopes] field lists all of the scopes instantiated -for the group, and the phase at which it is instantiated. Each element -of @racket[scopes] must have a @racketidfont{multi-owner} field -value that refers back to the @racket[multi-scope].} - - -@defstruct+[(binding zo) ()]{ - -A supertype for all binding representations.} - - -@defstruct+[(module-binding binding) ([encoded any/c])]{ - -Represents a binding to a module or top-level definition. The -@racket[encoded] field can be unpacked using -@racket[decode-module-binding], providing the symbol name for which -the binding is the target (since @racket[encoded] can be relative to -that name).} - - -@defstruct+[(decoded-module-binding binding) ([path (or/c #f module-path-index?)] - [name symbol?] - [phase exact-integer?] - [nominal-path (or/c #f module-path-index?)] - [nominal-export-name symbol?] - [nominal-phase (or/c #f exact-integer?)] - [import-phase (or/c #f exact-integer?)] - [inspector-desc (or/c #f symbol?)])]{ - -Represents a binding to a module or top-level definition---like -@racket[module-binding], but in normalized form: - -@itemlist[ - - @item{@racket[path]: the referenced module.} - - @item{@racket[name]: the referenced definition within its module.} - - @item{@racket[phase]: the phase of the referenced definition within - its module.} - - @item{@racket[nominal-path]: the module that was explicitly imported - into the binding context; this path can be different from - @racket[path] when a definition is re-exported.} - - @item{@racket[nominal-export-name]: the name of the binding as - exported from @racket[nominal-path], which can be different from - @racket[name] due to renaming on export.} - - @item{@racket[nominal-phase]: the phase of the export from - @racket[nominal-path], which can be different from @racket[phase] - due to re-export from a module that imports at a phase level other - than @racket[0].} - - @item{@racket[import-phase]: the phase of the import of - @racket[nominal-path], which shifted (if non-@racket[0]) the - binding phase relative to the export phase from - @racket[nominal-path].} - - @item{@racket[inspector-desc]: a name for an inspector (mapped to a - specific inspector at run time) that determines access to the - definition.} - -]} - -@defstruct+[(local-binding binding) ([name symbol?])]{ - -Represents a local binding (i.e., not at the top level or module level). -Such bindings rarely appear in bytecode, since @racket[quote-syntax] -prunes them.} - - -@defstruct+[(free-id=?-binding binding) ([base (and/c binding? - (not/c free-id=?-binding?))] - [id stx-obj?] - [phase (or/c #f exact-integer?)])]{ - -Represents a binding that includes a @racket[free-identifier=?] alias -(to an identifier with a particular phase shift) as well as a base binding.} - - -@defstruct+[(all-from-module zo) ([path module-path-index?] - [phase (or/c exact-integer? #f)] - [src-phase (or/c exact-integer? #f)] - [inspector-desc symbol?] - [exceptions (listof symbol?)] - [prefix (or/c symbol? #f)])]{ - -Describes a bulk import as an optimization over individual imports of -a module's exports: - -@itemlist[ - - @item{@racket[path]: the imported module.} - - @item{@racket[phase]: the phase of the import module's exports.} - - @item{@racket[src-phase]: the phase at which @racket[path] was - imported; @racket[src-phase] combined with @racket[phase] - determines the phase of the bindings.} - - @item{@racket[inspector-desc]: a name for an inspector (mapped to a - specific inspector at run time) that determines access to the - definition.} - - @item{@racket[exceptions]: exports of @racket[path] that are omitted - from the bulk import.} - - @item{@racket[prefix]: a prefix, if any, applied (after - @racket[exceptions]) to each of the imported names.} - -]} - - diff --git a/pkgs/racket-doc/scribblings/reference/data.scrbl b/pkgs/racket-doc/scribblings/reference/data.scrbl index 01eef58bcc..3a2a0086d2 100644 --- a/pkgs/racket-doc/scribblings/reference/data.scrbl +++ b/pkgs/racket-doc/scribblings/reference/data.scrbl @@ -119,6 +119,18 @@ For any @racket[v], @racket[(unbox (box v))] returns @racket[v]. Sets the content of @racket[box] to @racket[v].} +@deftogether[( +@defproc[(unbox* [box (and box? (not/c impersonator?))]) any/c] +@defproc[(set-box*! [box (and/c box? (not/c immutable?) (not/c impersonator?))] + [v any/c]) void?] +)]{ + +Like @racket[unbox] and @racket[set-box!], but constrained to work on +boxes that are not @tech{impersonators}. + +@history[#:added "6.90.0.15"]} + + @defproc[(box-cas! [box (and/c box? (not/c immutable?) (not/c impersonator?))] [old any/c] [new any/c]) diff --git a/pkgs/racket-doc/scribblings/reference/eval.scrbl b/pkgs/racket-doc/scribblings/reference/eval.scrbl index 1c0a926b80..870055c171 100644 --- a/pkgs/racket-doc/scribblings/reference/eval.scrbl +++ b/pkgs/racket-doc/scribblings/reference/eval.scrbl @@ -205,7 +205,12 @@ Like @racket[load], but @racket[load/cd] sets both handler}.} -@defparam[current-load-extension proc (path? (or/c symbol? #f) . -> . any)]{ +@defparam[current-load-extension proc (path? (or/c #f + symbol? + (cons/c (or/c #f symbol?) + (non-empty-listof symbol?))) + . -> . + any)]{ A @tech{parameter} that determines a @deftech{extension-load handler}, which is called by @racket[load-extension] and the default @tech{compiled-load diff --git a/pkgs/racket-doc/scribblings/reference/linklet.scrbl b/pkgs/racket-doc/scribblings/reference/linklet.scrbl new file mode 100644 index 0000000000..e52f9261bd --- /dev/null +++ b/pkgs/racket-doc/scribblings/reference/linklet.scrbl @@ -0,0 +1,460 @@ +#lang scribble/doc +@(require "mz.rkt" + (for-label racket/linklet + racket/unsafe/ops)) + +@title[#:tag "linklets"]{Linklets and the Core Compiler} + +@defmodule[racket/linklet] + +A @deftech{linklet} is a primitive element of compilation, bytecode +marshaling, and evaluation. Racket's implementations of modules, +macros, and top-level evaluation are all built on linklets. Racket +programmers generally do not encounter linklets directly, but the +@racketmodname[racket/linklet] library provides access to linklet +facilities. + +A single Racket module (or collection of top-level forms) is typically +implemented by multiple linklets. For example, each phase of +evaluation that exists in a module is implemented in a separate +linklet. A linklet is also used for metadata such as the @tech{module +path index}es for a module's @racket[require]s. These linklets, plus +some other metadata, are combined to form a @deftech{linklet bundle}. +Information in a @tech{linklet bundle} is keyed by either a symbol or +a @tech{fixnum}. A @tech{linklet directory} contiaining +@tech{linklet}s can be marshaled to and from a byte stream by +@racket[write] and (with @racket[read-accept-compiled] is enabled) +@racket[read]. + +When a Racket module has submodules, the @tech{linklet bundles} for +the module and the submodules are grouped together in a +@deftech{linklet directory}. A @tech{linklet directory} can have +nested linklet directories. Information in a linklet directory is +keyed by @racket[#f] or a symbol, where @racket[#f] must be mapped to +a @tech{linklet bundle} (if anything) and each symbol must be mapped +to a @tech{linklet directory}. A @tech{linklet directory} can be +equivalently viewed as a mapping from a lists of symbols to a +@tech{linklet bundle}. Like @tech{linklet bundles}, a @tech{linklet +directory} can be marshaled to and from a byte stream by +@racket[write] and @racket[read]; the marshaled form allows individual +@tech{linklet bundles} to be loaded independently. + +A linklet consists of a set of variable definitions and expressions, +an exported subset of the defined variable names, a set of variables to export +from the linklet despite having no corresponding definition, and a set +of imports that provide other variables for the linklet to use. To run +a linklet, it is instantiated as as @deftech{linklet instance} (or +just @defterm{instance}, for short). When a linklet is instantiated, +it receives other @tech{linklet instances} for its imports, and it +extracts a specified set of variables that are exported from each of +the given instances. The newly created @tech{linklet instance} +provides its exported variables for use by other linklets or for +direct access via @racket[instance-variable-value]. A @tech{linklet +instance} can be synthesized directly with @racket[make-instance]. + +A linklet is created by compiling an enriched S-expression +representation of its source. Since linklets exist below the layer of +macros and syntax objects, linklet compilation does not use +@tech{syntax objects}. Instead, linklet compilation uses +@deftech{correlated objects}, which are like @tech{syntax objects} +without lexical-context information and without the constraint that +content is coerced to correlated objects. Using an S-expression or +@tech{correlated object}, the grammar of a linklet as recognized by +@racket[compile-linklet] is + +@specform[(linklet [[imported-id/renamed ...] ...] + [exported-id/renamed ...] + defn-or-expr ...) + #:grammar + ([imported-id/renamed imported-id + (external-imported-id internal-imported-id)] + [exported-id/renamed exported-id + (internal-exported-id external-exported-id)])] + +Each import set @racket[[_imported-id/renamed ...]] refers to a single +imported instance, and each @racket[_import-id/renamed] corresponds to +a variable from that instance. If separate +@racket[_external-imported-id] and @racket[_internal-imported-id] are +specified, then @racket[_external-imported-id] is the name of the +variable as exported by the instance, and +@racket[_internal-imported-id] is the name used to refer to the +variable in the @racket[_defn-or-expr]s. For exports, separate +@racket[_internal-exported-id] and @racket[_external-exported-id] +names corresponds to the variable name as exported as referenced +in the @racket[_defn-or-expr]s, respectively. + +The grammar of an @racket[_defn-or-expr] is similar to the expander's +grammar of fully expanded expressions (see @secref["fully-expanded"]) +with some exceptions: @racket[quote-syntax] and @racket[#%top] are not allowed; +@racket[#%plain-lambda] is spelled @racket[lambda]; +@racket[#%plain-app] is omitted (i.e., application is implicit); +@racket[lambda], @racket[case-lambda], @racket[let-values], and +@racket[letrec-values] can have only a single body expression; and +numbers, booleans, strings, and byte strings are self-quoting. +Primitives are accessed directly by name, and shadowing is not allowed +within a @racketidfont{linklet} form for primitive names, imported +variables, defined variables, or local variables. + +When a @racket[_exported-id/renamed] has no corresponding definition +among the @racket[_defn-or-expr]s, then the variable is effectively +defined as uninitialized; referencing the variable will trigger +@racket[exn:fail:contract:variable], the same as referencing a +variable before it is defined. When a target instance is provided to +@racket[instantiate-linklet], any existing variable with the same name +will be left as-is, instead of set to undefined. This treatment of +uninitialized variables provides core support for top-level evaluation +where variables may be referenced and then defined in a separate +element of compilation. + +@history[#:added "6.6.1"] + +@; -------------------------------------------------- + +@defproc[(linklet? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet}, @racket[#f] +otherwise.} + + +@defproc*[([(compile-linklet [form (or/c correlated? any/c)] + [name any/c #f] + [import-keys #f #f] + [get-import #f #f] + [serializable? any/c #t] + [unsafe-mode? any/c #f]) + linklet?] + [(compile-linklet [form (or/c correlated? any/c)] + [name any/c] + [import-keys vector?] + [get-import (or/c #f (any/c . -> . (values (or/c linklet? instance? #f) + (or/c vector? #f)))) + #f] + [serializable? any/c #t] + [unsafe-mode? any/c #f]) + (values linklet? vector?)])]{ + +Takes an S-expression or @tech{correlated object} for a +@schemeidfont{linklet} form and produces a @tech{linklet}. +As long as @racket[serializable?] is true, the +resulting linklet can be marshaled to and from a byte stream when it is +part of a @tech{linklet bundle}. + +The optional @racket[name] is associated to the linklet for debugging +purposes and as the default name of the linklet's instance. + +The optional @racket[import-keys] and @racket[get-import] arguments +support cross-linklet optimization. If @racket[import-keys] is a +vector, it must have as many elements as sets of imports in +@racket[form]. If the compiler becomes interested in optimizing a +reference to an imported variable, it passes back to +@racket[get-import] (if non-@racket[#f]) the element of @racket[import-keys] that +corresponds to the variable's import set. The @racket[get-import] +function can then return a linklet or instance that represents an instance to be +provided to the compiled linklet when it is eventually instantiated; +ensuring consistency between reported linklet or instance and the eventual +instance is up to the caller of @racket[compile-linklet]. If +@racket[get-import] returns @racket[#f] as its first value, the +compiler will be prevented from make any assumptions about the +imported instance. The second result from @racket[get-import] is an +optional vector of keys to provide transitive information on a +returned linklet's imports (and is not allowed for a returned instance); +the returned vector must have the same +number of elements as the linklet has imports. When vector elements +are @racket[eq?] and non-@racket[#f], the compiler can assume that +they correspond to the same run-time instance. A @racket[#f] +value for @racket[get-import] is equivalent to a function that +always returns two @racket[#f] results. + +When @racket[import-keys] is not @racket[#f], then the compiler is +allowed to grow or shrink the set of imported instances for the +linklet. The result vector specifies the keys of the imports for the +returned linklet. Any key that is @racket[#f] or a @tech{linklet instance} +must be preserved intact, however. + +If @racket[unsafe-mode?] is true, then the linklet is compiled in +@deftech{unsafe mode}: uses of safe operations within the linklet can +be converted to unsafe operations on the assumption that the relevant +contracts are satisfied. For example, @racket[car] is converted to +@racket[unsafe-car]. Some substituted unsafe operations may not have +directly accessible names, such as the unsafe variant of +@racket[in-list] that can be substituted in @tech{unsafe mode}. An +unsafe operation is substituted only if its (unchecked) contract is +subsumed by the safe operation's contract. The fact that the linklet +is compiled in @tech{unsafe mode} can be exposed through +@racket[variable-reference-from-unsafe?] using a variable reference +produced by a @racket[#%variable-reference] form within the module +body.} + + +@defproc*[([(recompile-linklet [linklet linklet?] + [name any/c #f] + [import-keys #f #f] + [get-import (any/c . -> . (values (or/c linklet? #f) + (or/c vector? #f))) + (lambda (import-key) (values #f #f))]) + linklet?] + [(recompile-linklet [linklet linklet?] + [name any/c] + [import-keys vector?] + [get-import (any/c . -> . (values (or/c linklet? #f) + (or/c vector? #f))) + (lambda (import-key) (values #f #f))]) + (values linklet? vector?)])]{ + +Like @racket[compile-linklet], but takes an already-compiled linklet +and potentially optimizes it further.} + + +@defproc[(eval-linklet [linklet linklet?]) linklet?]{ + +Returns a variant of a @racket[linklet] that is prepared for JIT +compilation such that every later use of the result linklet with +@racket[instantiate-linklet] shares the JIT-generated code. However, +the result of @racket[eval-linklet] cannot be marshaled to a byte +stream as part of a @tech{linklet bundle}, and it cannot be used with +@racket[recompile-linklet].} + + + +@defproc*[([(instantiate-linklet [linklet linklet?] + [import-instances (listof instance?)] + [target-instance? #f #f] + [use-prompt? any/c #t]) + instance?] + [(instantiate-linklet [linklet linklet?] + [import-instances (listof instance?)] + [target-instance instance?] + [use-prompt? any/c #t]) + any])]{ + +Instantiates @racket[linklet] by running its definitions and +expressions, using the given @racket[import-instances] for its +imports. The number of instances in @racket[import-instances] must +match the number of import sets in @racket[linklet]. + +If @racket[target-instance] is @racket[#f] or not provided, the result +is a fresh instance for the linklet. If @racket[target-instance] is an +instance, then the instance is used and modified for the linklet +definitions and expressions, and the result is the value of the last +expression in the linklet. + +The linklet's exported variables are accessible in the result instance +or in @racket[target-instance] using the linklet's external name for +each export. If @racket[target-instance] is provided as +non-@racket[#f], its existing variables remain intact if they are not +modified by a linklet definition. + +If @racket[use-prompt?] is true, then the evaluation each definition +and expression in the linklet is wrapped in a @tech{prompt} in the +same ways as an expression in a module body.} + + +@defproc[(linklet-import-variables [linklet linklet?]) + (listof (listof symbol?))]{ + +Returns a description of a linklet's imports. Each element of the +result list corresponds to an import set as satisfied by a single +instance on instantiation, and each member of the set is a variable +name that is used from the corresponding imported instance.} + +@defproc[(linklet-export-variables [linklet linklet?]) + (listof symbol?)]{ + +Returns a description of a linklet's exports. Each element of the list +corresponds to a variable that is made available by the linklet in its +instance.} + + +@defproc[(linklet-directory? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet directory}, +@racket[#f] otherwise.} + + +@defproc[(hash->linklet-directory [content (and/c hash? hash-eq? immutable? (not/c impersonator?))]) + linklet-directory?]{ + +Constructs a @tech{linklet directory} given mappings in the form of a +@tech{hash table}. Each key of @racket[content] must be either a +symbol or @racket[#f], each symbol must be mapped to a @tech{linklet +directory}, and @racket[#f] must be mapped to a @tech{linklet bundle} +or not mapped.} + + +@defproc[(linklet-directory->hash [linklet-directory linklet-directory?]) + (and/c hash? hash-eq? immutable? (not/c impersonator?))]{ + +Extracts the content of a @tech{linklet directory} into a @tech{hash +table}.} + + +@defproc[(linklet-bundle? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet bundle}, +@racket[#f] otherwise.} + + +@defproc[(hash->linklet-bundle [content (and/c hash? hash-eq? immutable? (not/c impersonator?))]) + linklet-bundle?]{ + +Constructs a @tech{linklet bundle} given mappings in the form of a +@tech{hash table}. Each key of @racket[content] must be either a +symbol or a @tech{fixnum}. Values in the hash table are unconstrained, +but the intent is that they are all @tech{linklets} or values that can +be recovered from @racket[write] output by @racket[read].} + + +@defproc[(linklet-bundle->hash [linklet-bundle linklet-bundle?]) + (and/c hash? hash-eq? immutable? (not/c impersonator?))]{ + +Extracts the content of a @tech{linklet bundle} into a @tech{hash +table}.} + + +@defproc[(instance? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @tech{linklet instance}, +@racket[#f] otherwise.} + + +@defproc[(make-instance [name any/c] + [data any/c #f] + [mode (or/c #f 'constant 'consistent) #f] + [variable-name symbol?] + [variable-value any/c] ... ...) + instance?]{ + +Constructs a @tech{linklet instance} directly. Besides associating an +arbitrary @racket[name] and @racket[data] value to the instance, the +instance is populated with variables as specified by +@racket[variable-name] and @racket[variable-value]. + +The optional @racket[data] and @racket[mode] arguments must be +provided if any @racket[variable-name] and @racket[variable-value] +arguments are provided. The @racket[mode] argument is used as in +@racket[instance-set-variable-value!] for every +@racket[variable-name].} + + +@defproc[(instance-name [instance instance?]) any/c]{ + +Returns the value associated to @racket[instance] as its name---either +the first value provided to @racket[make-instance] or the name of a +linklet that was instantiated to create the instance.} + + +@defproc[(instance-data [instance instance?]) any/c]{ + +Returns the value associated to @racket[instance] as its data---either +the second value provided to @racket[make-instance] or the default +@racket[#f].} + + +@defproc[(instance-variable-names [instance instance?]) (list symbol?)]{ + +Returns a list of all names for all variables accessible from +@racket[instance].} + + +@defproc[(instance-variable-value [instance instance?] + [name symbol?] + [fail-k any/c (lambda () (error ....))]) + any]{ + +Returns the value of the variable exported as @racket[name] from +@racket[instance]. If no such variable is exported, then +@racket[fail-k] is used in the same way as by @racket[hash-ref].} + + +@defproc[(instance-set-variable-value! [instance instance?] + [name symbol?] + [v any/c] + [mode (or/c #f 'constant 'consistent) #f]) + void?]{ + +Sets or creates the variable exported as @racket[name] in +@racket[instance] so that its value is @racket[v], as long as the +variable does not exist already as constant. If a variable for +@racket[name] exists as constant, the @exnraise[exn:fail:contract]. + +If @racket[mode] is a single, then the variable is created or changed +to be constant. If @racket[mode] is @racket['consistent], then +the optimizer can assume that the value has the same shape in all +instances that are used to satisfy a linklet's imports.} + + +@defproc[(instance-unset-variable! [instance instance?] + [name symbol?]) + void?]{ + +Changes @racket[instance] so taht it does not export a variable as +@racket[name], as long as @racket[name] does not exist as a constant +variable. If a variable for @racket[name] exists as constant, the +@exnraise[exn:fail:contract].} + + +@defproc[(variable-reference->instance [varref variable-reference?] + [ref-site? any/c #f]) + (if ref-site? (or/c instance? #f symbol?) instance?)]{ + +Extracts the instance where the variable of @racket[varref] is defined +if @var[ref-site?] is @racket[#f], and returns the instance where +@racket[varref] itself resides if @racket[ref-site?] is true. This +notion of @tech{variable reference} is the same as at the module level +and can reflect the linklet instance that implements a particular +phase of a module instance. + +When @var[ref-site?] is @racket[#f], the result is @racket[#f] when +@racket[varref] is from @racket[(#%variable-reference)] with no +identifier. The result is a symbol if @racket[varref] refers to a +primitive.} + +@deftogether[( +@defproc[(correlated? [v any/c]) boolean?] +@defproc[(correlated-source [stx correlated?]) any] +@defproc[(correlated-line [stx correlated?]) + (or/c exact-positive-integer? #f)] +@defproc[(correlated-column [stx correlated?]) + (or/c exact-nonnegative-integer? #f)] +@defproc[(correlated-position [stx correlated?]) + (or/c exact-positive-integer? #f)] +@defproc[(correlated-span [stx correlated?]) + (or/c exact-nonnegative-integer? #f)] +@defproc[(correlated-e [stx correlated?]) any] +@defproc[(correlated->datum [stx (or/c correlated? any/c)]) any] +@defproc[(datum->correlated [v any/c] + [srcloc (or/c correlated? #f + (list/c any/c + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f)) + (vector/c any/c + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f))) + #f]) + correlated?] +@defproc*[([(correlated-property [stx correlated?] + [key any/c] + [val any/c]) + correlated?] + [(correlated-property [stx correlated?] [key any/c]) any/c])] +@defproc[(correlated-property-symbol-keys [stx correlated?]) list?] +)]{ + +Like @racket[syntax?], @racket[syntax-source], @racket[syntax-line], +@racket[syntax-column], @racket[syntax-position], +@racket[syntax-span], @racket[syntax-e], @racket[syntax->datum], +@racket[datum->syntax], @racket[syntax-property], and +@racket[syntax-property-symbol-keys], but for @tech{correlated +objects}. + +Unlike @racket[datum->syntax], @racket[datum->correlated] does not +recur through the given S-expression and convert pieces to +@tech{correlated objects}. Instead, a @tech{correlated object} is +simply wrapped around the immediate value. In contrast, +@racket[correlated->datum] recurs through its argument (which is not +necessarily a @tech{correlated object}) to discover any +@tech{correlated objects} and convert them to plain S-expressions.} diff --git a/pkgs/racket-doc/scribblings/reference/memory.scrbl b/pkgs/racket-doc/scribblings/reference/memory.scrbl index 091dd64fdd..86afc3d2f5 100644 --- a/pkgs/racket-doc/scribblings/reference/memory.scrbl +++ b/pkgs/racket-doc/scribblings/reference/memory.scrbl @@ -193,7 +193,9 @@ call. If no will is ready for immediate execution, @defproc[(will-try-execute [executor any/c]) any]{ Like @racket[will-execute] if a will is ready for immediate -execution. Otherwise, @racket[#f] is returned.} +execution. Otherwise, @racket[v] is returned. + +@history[#:changed "6.90.0.4" @elem{Added the @racket[v] argument.}]} @;------------------------------------------------------------------------ @section[#:tag "garbagecollection"]{Garbage Collection} diff --git a/pkgs/racket-doc/scribblings/reference/namespaces.scrbl b/pkgs/racket-doc/scribblings/reference/namespaces.scrbl index c71f37170e..f3315f8c03 100644 --- a/pkgs/racket-doc/scribblings/reference/namespaces.scrbl +++ b/pkgs/racket-doc/scribblings/reference/namespaces.scrbl @@ -170,7 +170,8 @@ exception.} @defproc[(namespace-set-variable-value! [sym symbol?] [v any/c] [map? any/c #f] - [namespace namespace? (current-namespace)]) + [namespace namespace? (current-namespace)] + [as-constant? any/c #f]) void?]{ Sets the value of @racket[sym] in the top-level environment of @@ -180,7 +181,13 @@ it is not already defined. If @racket[map?] is supplied as true, then the namespace's @tech{identifier} mapping is also adjusted (see @secref["namespace-model"]) in the @tech{phase level} corresponding to -the @tech{base phase}, so that @racket[sym] maps to the variable.} +the @tech{base phase}, so that @racket[sym] maps to the variable. + +If @racket[as-constant?] is true, then the variable is made a constant +(so future assignments are rejected) after @racket[v] is installed as +the value. + +@history[#:changed "6.6.1" @elem{Added the @racket[as-constant?] argument.}]} @defproc[(namespace-undefine-variable! [sym symbol?] @@ -502,8 +509,7 @@ an anonymous module variable as produced by Returns @racket[#t] if the module of the variable reference itself (not necessarily a referenced variable) is compiled in unsafe mode, -@racket[#f] otherwise. Since unsafe-mode compilation is not currently -supported, the result is always @racket[#f]. +@racket[#f] otherwise. The @racket[variable-reference-from-unsafe?] procedure is intended for use as @@ -512,6 +518,12 @@ use as (variable-reference-from-unsafe? (#%variable-reference)) ] -which the compiler can currently optimize to a literal @racket[#f]. +which the compiler can optimize to a literal @racket[#t] or +@racket[#f] (since the enclosing module is being compiled in +@tech{unsafe mode} or not). + +Currently @tech{unsafe mode} can be controlled only through the +@tech{linklet} interface, but future changes may make @tech{unsafe +mode} more accessible at the module level. @history[#:added "6.12.0.4"]} diff --git a/pkgs/racket-doc/scribblings/reference/readtables.scrbl b/pkgs/racket-doc/scribblings/reference/readtables.scrbl index 2f32fc32ae..4ccfd02bdd 100644 --- a/pkgs/racket-doc/scribblings/reference/readtables.scrbl +++ b/pkgs/racket-doc/scribblings/reference/readtables.scrbl @@ -150,7 +150,7 @@ already-consumed character(s): the source name, a line number or @racket[#f]. When the reader macro is triggered by @racket[read] (or @racket[read/recursive]), the procedure is passed only two arguments if it accepts two arguments, otherwise it is passed six arguments -where the last four are all @racket[#f]. See @secref["reader-procs"] +where the third is always @racket[#f]. See @secref["reader-procs"] for information on the procedure's results. A reader macro normally reads characters from the given input port to @@ -264,7 +264,7 @@ character and the @racket[#f] readtable.} ((if (eof-object? v) raise-read-eof-error raise-read-error) - "expected `,' or `>'" src l c p 1)]))])) + "expected `,` or `>`" src l c p 1)]))])) (define (make-delims-table) ;; Table to use for recursive reads to disallow delimiters @@ -274,7 +274,7 @@ character and the @racket[#f] readtable.} [(ch port) (misplaced-delimiter ch port #f #f #f #f)] [(ch port src line col pos) (raise-read-error - (format "misplaced `~a' in tuple" ch) + (format "misplaced `~a` in tuple" ch) src line col pos 1)])]) (make-readtable (current-readtable) #\, 'terminating-macro misplaced-delimiter @@ -286,14 +286,14 @@ character and the @racket[#f] readtable.} (define parse-open-tuple (case-lambda [(ch port) - ;; `read' mode + ;; `read` mode (wrap (parse port (lambda () (read/recursive port #f (make-delims-table))) (object-name port)))] [(ch port src line col pos) - ;; `read-syntax' mode + ;; `read-syntax` mode (datum->syntax #f (wrap (parse port diff --git a/pkgs/racket-doc/scribblings/reference/runtime.scrbl b/pkgs/racket-doc/scribblings/reference/runtime.scrbl index d5a8bdb2d2..a39ca8321c 100644 --- a/pkgs/racket-doc/scribblings/reference/runtime.scrbl +++ b/pkgs/racket-doc/scribblings/reference/runtime.scrbl @@ -27,18 +27,20 @@ In @indexed-racket['word] mode, the result is either @racket[32] or or 64-bit program. In @indexed-racket['vm] mode, -the only possible symbol result is: +the possible symbol results are: @itemize[ @item{@indexed-racket['racket]} +@item{@indexed-racket['chez-scheme]} ] In @indexed-racket['gc] mode, the possible symbol results are: @itemize[ -@item{@indexed-racket['cgc]} -@item{@indexed-racket['3m]} +@item{@indexed-racket['cgc] --- when @racket[(system-type 'vm)] is @racket['racket]} +@item{@indexed-racket['3m] --- when @racket[(system-type 'vm)] is @racket['racket]} +@item{@indexed-racket['cs] --- when @racket[(system-type 'vm)] is @racket['chez-scheme]} ] In @indexed-racket['link] mode, the possible symbol results are: diff --git a/pkgs/racket-doc/scribblings/reference/security.scrbl b/pkgs/racket-doc/scribblings/reference/security.scrbl index 37ebef00a6..5f14a7a306 100644 --- a/pkgs/racket-doc/scribblings/reference/security.scrbl +++ b/pkgs/racket-doc/scribblings/reference/security.scrbl @@ -18,3 +18,4 @@ @include-section["code-inspectors.scrbl"] @include-section["plumbers.scrbl"] @include-section["sandbox.scrbl"] +@include-section["linklet.scrbl"] diff --git a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl index 67a7780306..436cbf0de0 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl @@ -269,7 +269,10 @@ recursively (i.e., expansion proceeds to sub-expressions). If @racket[stop-ids] is @racket[#f] instead of a list, then @racket[stx] is expanded only as long as the outermost form of @racket[stx] is a macro (i.e., expansion does not -proceed to sub-expressions). +proceed to sub-expressions). Independent of @racket[stop-ids], when +@racket[local-expand] encounters an identifier that has a local binding +but no binding in the current expansion context, the variable is left +as-is (as opposed to triggering an ``out of context'' syntax error). A fully expanded form can include the bindings listed in @secref["fully-expanded"] plus the @@ -346,23 +349,31 @@ expansion history to external tools. an explicit wrapper.}]} -@defproc[(syntax-local-expand-expression [stx any/c]) - (values syntax? syntax?)]{ +@defproc[(syntax-local-expand-expression [stx any/c] [opaque-only? #f]) + (values (if opaque-only? #f syntax?) syntax?)]{ Like @racket[local-expand] given @racket['expression] and an empty stop list, but with two results: a syntax object for the fully -expanded expression, and a syntax object whose content is opaque. The -latter can be used in place of the former (perhaps in a larger +expanded expression, and a syntax object whose content is opaque. + +The latter can be used in place of the former (perhaps in a larger expression produced by a macro transformer), and when the macro expander encounters the opaque object, it substitutes the fully expanded expression without re-expanding it; the @exnraise[exn:fail:syntax] if the expansion context includes -@tech{scopes} that were not present for the original expansion, in which -case re-expansion might produce different results. Consistent use of -@racket[syntax-local-expand-expression] and the opaque object thus -avoids quadratic expansion times when local expansions are nested. +@tech{scopes} that were not present for the original expansion, in +which case re-expansion might produce different results. Consistent +use of @racket[syntax-local-expand-expression] and the opaque object +thus avoids quadratic expansion times when local expansions are +nested. -@transform-time[]} +If @racket[opaque-only?] is true, then the first result is @racket[#f] +instead of the expanded expression. Obtaining only the second, opaque +result can be more efficient in some expansion contexts. + +@transform-time[] + +@history[#:changed "6.90.0.13" @elem{Added the @racket[opaque-only?] argument.}]} @defproc[(local-transformer-expand [stx any/c] diff --git a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl index 2895feea4e..2abe0b40db 100644 --- a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl +++ b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl @@ -655,6 +655,7 @@ fixnum).} @history[#:added "6.9.0.2"] } + @; ------------------------------------------------------------------------ @include-section["unsafe-undefined.scrbl"] diff --git a/pkgs/racket-doc/scribblings/reference/vectors.scrbl b/pkgs/racket-doc/scribblings/reference/vectors.scrbl index 49a9db22de..0441d27ecb 100644 --- a/pkgs/racket-doc/scribblings/reference/vectors.scrbl +++ b/pkgs/racket-doc/scribblings/reference/vectors.scrbl @@ -72,6 +72,23 @@ slot is position @racket[0], and the last slot is one less than Updates the slot @racket[pos] of @racket[vec] to contain @racket[v].} + +@deftogether[( +@defproc[(vector*-length [vec (and/c vector? (not/c impersonator?))]) exact-nonnegative-integer?] +@defproc[(vector*-ref [vec (and/c vector? (not/c impersonator?))] [pos exact-nonnegative-integer?]) any/c] +@defproc[(vector*-set! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))] + [pos exact-nonnegative-integer?] + [v any/c]) + void?] +)]{ + +Like @racket[vector-length], @racket[vector-ref], and +@racket[vector-set!], but constrained to work on vectors that are not +@tech{impersonators}. + +@history[#:added "6.90.0.15"]} + + @defproc[(vector-cas! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))] [pos exact-nonnegative-integer?] [old-v any/c] diff --git a/pkgs/racket-doc/syntax/scribblings/modcode.scrbl b/pkgs/racket-doc/syntax/scribblings/modcode.scrbl index 66ab8a7759..23d2e672bd 100644 --- a/pkgs/racket-doc/syntax/scribblings/modcode.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/modcode.scrbl @@ -7,7 +7,7 @@ @defproc[(get-module-code [path path-string?] [#:submodule-path submodule-path (listof symbol?) '()] - [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) "compiled"] + [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) (get-default-compiled-sub-path)] [compiled-subdir (and/c path-string? relative-path?) compiled-subdir0] [#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)] [#:compile compile-proc0 (any/c . -> . any) compile] @@ -31,7 +31,7 @@ specified by @racket[path] and @racket[submodule-path], where @racket[submodule-path] is empty for a root module or a list for a submodule. -The @racket[compiled-subdir] argument defaults to @racket["compiled"]; +The @racket[compiled-subdir] argument defaults to @racket[(get-default-compiled-sub-path)]; it specifies the sub-directory to search for a compiled version of the module. The @racket[roots] list specifies a compiled-file search path in the same way as the @racket[current-compiled-file-roots] parameter. @@ -77,11 +77,14 @@ If @racket[notify-proc] is supplied, it is called for the file (source, @filepath{.zo} or extension) that is chosen. If @racket[read-syntax-proc] is provided, it is used to read the -module from a source file (but not from a bytecode file).} +module from a source file (but not from a bytecode file). + +@history[#:changed "6.90.0.7" @elem{Use @racket[(get-default-compiled-sub-path)] + for the default value of @racket[compiled-subdir].}]} @defproc[(get-module-path [path path-string?] [#:submodule? submodule? boolean?] - [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) "compiled"] + [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) (get-default-compiled-sub-path)] [compiled-subdir (and/c path-string? relative-path?) compiled-subdir0] [#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)] [#:choose choose-proc @@ -107,7 +110,18 @@ The @racket[submodule?] argument represents whether the desired module is a submodule of the one specified by @racket[path]. When @racket[submodule?] is true, the result is never a @racket['so] path, as native libraries cannot provide submodules. -} + +@history[#:changed "6.90.0.7" @elem{Use @racket[(get-default-compiled-sub-path)] + for the default value of @racket[compiled-subdir].}]} + + +@defproc[(get-default-compiled-sub-path) path-string?]{ + +If @racket[(use-compiled-file-paths)] is not @racket['()], returns the +first element of the list. Otherwise, results @racket["compiled"]. + +@history[#:added "6.90.0.7"]} + @defproc[(get-metadata-path [path path-string?] [#:roots roots (listof (or/c path-string? 'same)) @@ -131,7 +145,6 @@ file for @filepath{/path/to/source.rkt} might be stored in A parameter whose value is used like @racket[open-input-file] to read a module source or @filepath{.zo} file.} - @defstruct[(exn:get-module-code exn:fail) ([path path?])]{ An exception structure type for exceptions raised by diff --git a/pkgs/racket-test-core/tests/racket/basic.rktl b/pkgs/racket-test-core/tests/racket/basic.rktl index 6eb15b5077..f941872456 100644 --- a/pkgs/racket-test-core/tests/racket/basic.rktl +++ b/pkgs/racket-test-core/tests/racket/basic.rktl @@ -227,7 +227,7 @@ (box-tests make-weak-box weak-box-value weak-box? #f #f 'weak-box-value #t) ;; test clearing weak boxes -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (let* ([s (gensym)] [b (make-weak-box s)]) (test s weak-box-value b) @@ -2898,17 +2898,21 @@ (cons 1 (loop (sub1 i)))))) exn:fail:contract?))) not-inc))) - (list proc (procedure-reduce-arity proc ar))))]) + (list proc (procedure-reduce-arity proc ar))))] + [representable-arity? (lambda (a) + (or (not (eq? 'chez-scheme (system-type 'vm))) + (a . < . 4096)))]) (let ([check-all-but-one (lambda (+) (check-ok + 0 '(0) '(1)) (check-ok + 2 '(2) '(0 1 3 4)) - (check-ok + 10 '(10) (list 0 11 (expt 2 70))) - (check-ok + (expt 2 70) (list (expt 2 70)) (list 0 10 (add1 (expt 2 70)))) - (check-ok + (make-arity-at-least 2) (list 2 5 (expt 2 70)) (list 0 1)) + (check-ok + 10 '(10) (filter representable-arity? (list 0 11 (expt 2 70)))) + (when (representable-arity? (expt 2 70)) + (check-ok + (expt 2 70) (list (expt 2 70)) (filter representable-arity? (list 0 10 (add1 (expt 2 70)))))) + (check-ok + (make-arity-at-least 2) (filter representable-arity? (list 2 5 (expt 2 70))) (list 0 1)) (check-ok + (list 2 4) '(2 4) '(0 3)) (check-ok + (list 2 4) '(4 2) '(0 3)) - (check-ok + (list 0 (make-arity-at-least 2)) (list 0 2 5 (expt 2 70)) (list 1)) + (check-ok + (list 0 (make-arity-at-least 2)) (filter representable-arity? (list 0 2 5 (expt 2 70))) (list 1)) (check-ok + (list 4 (make-arity-at-least 2)) '(2 3 4 10) '(0 1)) (check-ok + (list 2 (make-arity-at-least 4)) '(2 4 10) '(0 1 3)))]) (check-all-but-one +) diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index f6c740f80a..d87b2be495 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -1922,7 +1922,7 @@ (set! access-k k) k))] [test (lambda (val proc . args) - ;; Avoid printign hash-table argument, which implicitly uses `ref': + ;; Avoid printing hash-table argument, which implicitly uses `ref': (let ([got (apply proc args)]) (test #t (format "~s ~s ~s" proc val got) (equal? val got))))]) (test #f hash-iterate-first h1) diff --git a/pkgs/racket-test-core/tests/racket/core-tests.rktl b/pkgs/racket-test-core/tests/racket/core-tests.rktl index 759a4072f7..166d889236 100644 --- a/pkgs/racket-test-core/tests/racket/core-tests.rktl +++ b/pkgs/racket-test-core/tests/racket/core-tests.rktl @@ -27,6 +27,7 @@ (load-relative "prompt.rktl") (load-relative "will.rktl") (load-relative "namespac.rktl") +(load-relative "expobs.rktl") (load-relative "collects.rktl") (load-relative "modprot.rktl") (load-relative "chaperone.rktl") diff --git a/pkgs/racket-test-core/tests/racket/expobs-regression.rktd b/pkgs/racket-test-core/tests/racket/expobs-regression.rktd new file mode 100644 index 0000000000..14a442e1a2 --- /dev/null +++ b/pkgs/racket-test-core/tests/racket/expobs-regression.rktd @@ -0,0 +1,9851 @@ +#hash((__x + . + ((141 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (138 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (7 . #s(stx-boundary (s0 (s1 . s2)))) + (2 . #s(stx-boundary (s0 (s1 . s2)))))) + ((#%stratified-body + (define (first z) z) + (define (ok x) (second x)) + (define (second y) 8) + (ok (first 5)) + (define more 'oops)) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 + (s2 (s3 s4) s4) + (s2 (s5 s6) (s7 s6)) + (s2 (s7 s8) 8) + (s5 (s3 5)) + (s2 s9 (s10 s11)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 + (s2 (s3 s4) s4) + (s2 (s5 s6) (s7 s6)) + (s2 (s7 s8) 8) + (s5 (s3 5)) + (s2 s9 (s10 s11)))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s1 (s6 s7) 8) + (s4 (s2 5)) + (s1 s8 (s9 s10))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s1 (s6 s7) 8) + (s4 (s2 5)) + (s1 s8 (s9 s10))))) + (155 . #f) + (10 + . + #s(stx-boundary + ((s0 (s1 s2) s2) + (s0 (s3 s4) (s5 s4)) + (s0 (s5 s6) 8) + (s3 (s1 5)) + (s0 s7 (s8 s9))))) + (24 + #s(stx-boundary + ((s0 (s1 s2) s2) + (s0 (s3 s4) (s5 s4)) + (s0 (s5 s6) 8) + (s3 (s1 5)) + (s0 s7 (s8 s9)))) + . + #s(stx-boundary + ((s0 (s1 s2) s2) + (s0 (s3 s4) (s5 s4)) + (s0 (s5 s6) 8) + (s3 (s1 5)) + (s0 s7 (s8 s9))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) s2))) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) s3))) + . + #s(stx-boundary (s0 (s1 s3) s3))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + . + #s(stx-boundary (s4 s1 (s2 (s3) s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) s2)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s0 (s1 s3) (s4 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s5 s1 (s2 (s3) (s4 s3))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 s2))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) 8))) + (0 . #s(stx-boundary (s0 (s1 s2) 8))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) 8))) + (21 . #s(stx-boundary (s0 (s1 s2) 8))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) 8))) + . + #s(stx-boundary (s0 (s1 s3) 8))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) 8))) + . + #s(stx-boundary (s4 s1 (s2 (s3) 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 5)))) + (127 . #s(stx-boundary (s0 (s1 5)))) + (14 + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) ((s4) (s2 (s5) (s6 s5))) ((s6) (s2 (s7) 8))) + (s8 (s4 (s1 5)) (s9 s10 (s11 s12)))))) + (0 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) ((s4) (s2 (s5) (s6 s5))) ((s6) (s2 (s7) 8))) + (s8 (s4 (s1 5)) (s9 s10 (s11 s12)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) ((s4) (s2 (s5) (s6 s5))) ((s6) (s2 (s7) 8))) + (s8 (s4 (s1 5)) (s9 s10 (s11 s12)))))) + (113 . #f) + (16 + (#s(stx-boundary ((s0) (s1 (s2) s2))) + #s(stx-boundary ((s3) (s1 (s4) (s5 s4)))) + #s(stx-boundary ((s5) (s1 (s6) 8)))) + . + #s(stx-boundary ((s7 (s3 (s0 5)) (s8 s9 (s10 s11)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s1))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s1))) + (2 . #s(stx-boundary (s0 (s1) s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 s0)))) + (10 . #s(stx-boundary ((s0 s1)))) + (24 #s(stx-boundary ((s0 s1))) . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1))) + (127 . #s(stx-boundary (s0 s1))) + (12 . #s(stx-boundary ((s0 s1)))) + (4 . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (22 #s(stx-boundary (s0 s1 s2)) . #s(stx-boundary (s0 s1 s2))) + (9 . #s(stx-boundary (s0 s1 s2))) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary ((s0 s1 s2)))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) 8))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (8))) + (10 . #s(stx-boundary (8))) + (24 #s(stx-boundary (8)) . #s(stx-boundary (8))) + (3 . #f) + (126 . #s(stx-boundary 8)) + (127 . #s(stx-boundary 8)) + (12 . #s(stx-boundary (8))) + (4 . #s(stx-boundary (8))) + (3 . #f) + (0 . #s(stx-boundary 8)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 8))) + (6 . #s(stx-boundary (s0 . 8))) + (115 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (13 . #f) + (4 . #s(stx-boundary ((s0 (s1 (s2 5)) (s3 s4 (s5 s6)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 5)) (s3 s4 (s5 s6))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 5)) (s3 s4 (s5 s6))))) + (155 . #f) + (10 . #s(stx-boundary ((s0 (s1 5)) (s2 s3 (s4 s5))))) + (24 + #s(stx-boundary ((s0 (s1 5)) (s2 s3 (s4 s5)))) + . + #s(stx-boundary ((s0 (s1 5)) (s2 s3 (s4 s5))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 5)))) + (127 . #s(stx-boundary (s0 (s1 5)))) + (12 . #s(stx-boundary ((s0 (s1 5)) (s2 s3 (s4 s5))))) + (4 . #s(stx-boundary ((s0 (s1 5)) (s2 s3 (s4 s5))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 5)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 5)))) + (8 . #s(stx-boundary (s0 s1 (s2 5)))) + (21 . #s(stx-boundary (s0 s1 (s2 5)))) + (22 #s(stx-boundary (s0 s1 (s2 5))) . #s(stx-boundary (s0 s1 (s2 5)))) + (9 . #s(stx-boundary (s0 s1 (s2 5)))) + (0 . #s(stx-boundary (s0 s1 (s2 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 5)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 5)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 5))) + (8 . #s(stx-boundary (s0 s1 5))) + (21 . #s(stx-boundary (s0 s1 5))) + (22 #s(stx-boundary (s0 s1 5)) . #s(stx-boundary (s0 s1 5))) + (9 . #s(stx-boundary (s0 s1 5))) + (0 . #s(stx-boundary (s0 s1 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 5))) + (109 . #f) + (4 . #s(stx-boundary (s0 5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary (s0 (s1 5)))) + (7 . #s(stx-boundary (s0 s1 (s2 5)))) + (2 . #s(stx-boundary (s0 s1 (s2 5)))) + (5 . #s(stx-boundary (s0 (s1 s2 (s3 5))))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3)))))) + ((quote-syntax (stx-quoted)) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2))))) + (138 . #f) + (0 . #s(stx-boundary (s0 (s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1)))) + (118 . #f) + (7 . #s(stx-boundary (s0 (s1)))) + (2 . #s(stx-boundary (s0 (s1)))) + (7 . #s(stx-boundary (s0 (s1 (s2))))) + (2 . #s(stx-boundary (s0 (s1 (s2))))))) + ((module m racket/base + (define-syntax (ok stx) + (syntax-local-lift-require 'racket/list #'foldl)) + (ok)) + . + ((141 . #f) + (0 + . + #s(stx-boundary (s0 s1 s2 (s3 (s4 s5) (s6 (s7 s8) (s9 s10))) (s4)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary (s0 s1 s2 (s3 (s4 s5) (s6 (s7 s8) (s9 s10))) (s4)))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (148 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (126 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (0 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (21 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (22 + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 (s3 s12) (s13 s14))) + (s9))) + . + #s(stx-boundary (s15 (s8 (s9 s10) (s11 (s3 s12) (s13 s14))) (s9)))) + (9 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 (s3 s12) (s13 s14))) + (s9)))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 (s3 s12) (s13 s14))) + (s9)))) + (0 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 (s3 s12) (s13 s14))) + (s9)))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 (s3 s12) (s13 s14))) + (s9)))) + (21 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 (s3 s12) (s13 s14))) + (s9)))) + (22 + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 (s5 s14) (s15 s16)))) + (s1 s2 (s11)))) + . + #s(stx-boundary + (s17 + (s3 s4 (s5 s6) (s7 s8) (s9 #f)) + (s10 (s11 s12) (s13 (s5 s14) (s15 s16))) + (s11)))) + (9 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 (s5 s14) (s15 s16)))) + (s1 s2 (s11))))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 (s5 s14) (s15 s16)))) + (s1 s2 (s11))))) + (127 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 (s5 s14) (s15 s16)))) + (s1 s2 (s11))))) + (0 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 (s5 s14) (s15 s16)))) + (s1 s2 (s11))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 (s5 s14) (s15 s16)))) + (s1 s2 (s11))))) + (102 . #f) + (148 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 (s5 s14) (s15 s16)))) + (s1 s2 (s11))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (21 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (130 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (132 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (133 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (131 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (22 + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)))) + . + #s(stx-boundary (s8 s9 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (9 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (0 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (148 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (11 + #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f))) + #s(stx-boundary (s7 s8 (s9 (s10 s11) (s12 (s2 s13) (s14 s15))))) + #s(stx-boundary (s7 s8 (s10)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (158 . #f) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (102 . #f) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (148 . #s(stx-boundary (s0 s1))) + (6 . #s(stx-boundary (s0 s1))) + (119 . #f) + (7 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 #f))) + (100 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (148 . #s(stx-boundary (s0 #f))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 #f))) + (6 . #s(stx-boundary (s0 s1 #f))) + (109 . #f) + (4 . #s(stx-boundary (s0 #f))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (5 . #s(stx-boundary (s0 (s1 #f)))) + (7 . #s(stx-boundary (s0 s1 (s2 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 #f)))) + (135) + (13 . #f) + (3 . #f) + (7 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 s4) (s5 (s6 s7) (s8 s9)))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3 s4) (s5 (s6 s7) (s8 s9)))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3 s4) (s5 (s6 s7) (s8 s9)))))) + (130 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (132 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (141 . #f) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8))))) + . + #s(stx-boundary (s9 (s1 s3) (s4 (s5 s6) (s7 s8))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (133 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (131 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (22 + #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 (s6 s7) (s8 s9)))))) + . + #s(stx-boundary (s10 s11 (s12 (s2 s4) (s5 (s6 s7) (s8 s9)))))) + (9 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 (s6 s7) (s8 s9))))))) + (0 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 (s6 s7) (s8 s9))))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 (s6 s7) (s8 s9))))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 (s6 s7) (s8 s9))))))) + (2 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 (s6 s7) (s8 s9))))))) + (148 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 (s6 s7) (s8 s9))))))) + (11 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8))))) + #s(stx-boundary (s9 s10 (s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (148 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (103 . #f) + (157 . #f) + (20 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (21 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6)))) + . + #s(stx-boundary (s7 (s1) (s2 (s3 s4) (s5 s6))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 (s2 s3) (s4 s5))))) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 s4)))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (12 . #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (4 . #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)))) + ((module m racket/base (define (proc x) x) (provide proc)) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 s1 s2 (s3 (s4 s5) s5) (s6 s4)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2 (s3 (s4 s5) s5) (s6 s4)))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 (s2 s3) s3) (s4 s2)))) + (148 . #s(stx-boundary (s0 (s1 (s2 s3) s3) (s4 s2)))) + (126 . #s(stx-boundary (s0 (s1 (s2 s3) s3) (s4 s2)))) + (0 . #s(stx-boundary (s0 (s1 (s2 s3) s3) (s4 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 (s2 s3) s3) (s4 s2)))) + (21 . #s(stx-boundary (s0 (s1 (s2 s3) s3) (s4 s2)))) + (22 + #s(stx-boundary + (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 (s9 s10) s10) (s11 s9))) + . + #s(stx-boundary (s12 (s8 (s9 s10) s10) (s11 s9)))) + (9 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 (s9 s10) s10) (s11 s9)))) + (2 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 (s9 s10) s10) (s11 s9)))) + (0 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 (s9 s10) s10) (s11 s9)))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 (s9 s10) s10) (s11 s9)))) + (21 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 (s9 s10) s10) (s11 s9)))) + (22 + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) s12)) + (s1 s2 (s13 s11)))) + . + #s(stx-boundary + (s14 + (s3 s4 (s5 s6) (s7 s8) (s9 #f)) + (s10 (s11 s12) s12) + (s13 s11)))) + (9 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) s12)) + (s1 s2 (s13 s11))))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) s12)) + (s1 s2 (s13 s11))))) + (127 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) s12)) + (s1 s2 (s13 s11))))) + (0 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) s12)) + (s1 s2 (s13 s11))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) s12)) + (s1 s2 (s13 s11))))) + (102 . #f) + (148 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) s12)) + (s1 s2 (s13 s11))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (21 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (130 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (132 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (133 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (131 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (22 + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)))) + . + #s(stx-boundary (s8 s9 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (9 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (0 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (148 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (11 + #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f))) + #s(stx-boundary (s7 s8 (s9 (s10 s11) s11))) + #s(stx-boundary (s7 s8 (s12 s10)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (158 . #f) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (102 . #f) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (148 . #s(stx-boundary (s0 s1))) + (6 . #s(stx-boundary (s0 s1))) + (119 . #f) + (7 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 #f))) + (100 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (148 . #s(stx-boundary (s0 #f))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 #f))) + (6 . #s(stx-boundary (s0 s1 #f))) + (109 . #f) + (4 . #s(stx-boundary (s0 #f))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (5 . #s(stx-boundary (s0 (s1 #f)))) + (7 . #s(stx-boundary (s0 s1 (s2 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 #f)))) + (135) + (13 . #f) + (3 . #f) + (7 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 s4) s4)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3 s4) s4)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3 s4) s4)))) + (130 . #s(stx-boundary (s0 (s1 s2) s2))) + (132 . #s(stx-boundary (s0 (s1 s2) s2))) + (141 . #f) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) s3))) + . + #s(stx-boundary (s0 (s1 s3) s3))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + . + #s(stx-boundary (s4 s1 (s2 (s3) s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (133 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (131 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1 (s2) (s3 (s4) s4)))) + . + #s(stx-boundary (s5 s6 (s7 (s2 s4) s4)))) + (9 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) s4))))) + (0 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) s4))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) s4))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) s4))))) + (2 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) s4))))) + (148 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) s4))))) + (11 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + #s(stx-boundary (s4 s5 (s6 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (148 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3)))) + (130 . #s(stx-boundary (s0 s1))) + (132 . #s(stx-boundary (s0 s1))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1))) + (21 . #s(stx-boundary (s0 s1))) + (22 #s(stx-boundary (s0 (s1 (s2 s3)))) . #s(stx-boundary (s4 s3))) + (9 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (0 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (2 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (133 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (131 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (22 + #s(stx-boundary (s0 (s1 (s2 (s3 s4))))) + . + #s(stx-boundary (s5 s6 (s7 s4)))) + (9 . #s(stx-boundary (s0 (s1 (s2 (s3 s4)))))) + (0 . #s(stx-boundary (s0 (s1 (s2 (s3 s4)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 (s3 s4)))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 (s2 (s3 s4)))))) + (2 . #s(stx-boundary (s0 (s1 (s2 (s3 s4)))))) + (148 . #s(stx-boundary (s0 (s1 (s2 (s3 s4)))))) + (11 #s(stx-boundary (s0 (s1 (s2 s3))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (2 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (148 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (0 . #s(stx-boundary (s0 (s1) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s1))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s1))) + (2 . #s(stx-boundary (s0 (s1) s1))) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (3 . #f) + (135) + (13 . #f) + (6 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (122 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1))) + (21 . #s(stx-boundary (s0 s1))) + (22 #s(stx-boundary (s0 s1)) . #s(stx-boundary (s2 s1))) + (9 . #s(stx-boundary (s0 s1))) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (7 . #f) + (3 . #f) + (7 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s0 (s5 s6) (s7 s8 (s3 #f)))) + (s9 (s10) (s11 (s12) s12)) + (s13 s10)))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s0 (s5 s6) (s7 s8 (s3 #f)))) + (s9 (s10) (s11 (s12) s12)) + (s13 s10)))) + (148 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s11 (s12) (s13 (s14) s14)) + (s15 s12))))) + (7 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s11 (s12) (s13 (s14) s14)) + (s15 s12))))) + (2 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s11 (s12) (s13 (s14) s14)) + (s15 s12))))))) + ((module m racket/base 'done) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 s1 s2 (s3 s4)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2 (s3 s4)))) + (101 . #f) + (157 . #f) + (148 . #s(stx-boundary (s0 s1))) + (126 . #s(stx-boundary (s0 s1))) + (127 . #s(stx-boundary (s0 s1))) + (142 . #s(stx-boundary (s0 (s1 s2)))) + (126 . #s(stx-boundary (s0 (s1 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2)))) + (21 . #s(stx-boundary (s0 (s1 s2)))) + (22 + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s3 s8))) + . + #s(stx-boundary (s9 (s3 s8)))) + (9 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s3 s8)))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s3 s8)))) + (0 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s3 s8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s3 s8)))) + (21 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s3 s8)))) + (22 + #s(stx-boundary + (s0 (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) (s1 s2 (s5 s10)))) + . + #s(stx-boundary (s11 (s3 s4 (s5 s6) (s7 s8) (s9 #f)) (s5 s10)))) + (9 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) (s1 s2 (s5 s10))))) + (2 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) (s1 s2 (s5 s10))))) + (127 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) (s1 s2 (s5 s10))))) + (0 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) (s1 s2 (s5 s10))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) (s1 s2 (s5 s10))))) + (102 . #f) + (148 + . + #s(stx-boundary + (s0 (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) (s1 s2 (s5 s10))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (21 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (130 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (132 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (133 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (131 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (22 + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)))) + . + #s(stx-boundary (s8 s9 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (9 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (0 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (148 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (11 + #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f))) + #s(stx-boundary (s7 s8 (s2 s9)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (158 . #f) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (102 . #f) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (148 . #s(stx-boundary (s0 s1))) + (6 . #s(stx-boundary (s0 s1))) + (119 . #f) + (7 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 #f))) + (100 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (148 . #s(stx-boundary (s0 #f))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 #f))) + (6 . #s(stx-boundary (s0 s1 #f))) + (109 . #f) + (4 . #s(stx-boundary (s0 #f))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (5 . #s(stx-boundary (s0 (s1 #f)))) + (7 . #s(stx-boundary (s0 s1 (s2 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 #f)))) + (135) + (13 . #f) + (3 . #f) + (7 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3)))) + (130 . #s(stx-boundary (s0 s1))) + (132 . #s(stx-boundary (s0 s1))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (133 . #s(stx-boundary (s0 s1))) + (131 . #s(stx-boundary (s0 s1))) + (22 + #s(stx-boundary (s0 (s1 (s2 s3)))) + . + #s(stx-boundary (s4 s1 (s2 s3)))) + (9 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (0 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (2 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (148 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (11 #s(stx-boundary (s0 (s1 s2)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2)))) + (21 . #s(stx-boundary (s0 (s1 s2)))) + (22 + #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5)) + . + #s(stx-boundary (s6 (s3 s4)))) + (9 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (0 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (2 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (148 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 () (s2 s3)) s4))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 () (s1 s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 s2)))) + (110 . #f) + (17 #s(stx-boundary ()) . #s(stx-boundary ((s0 s1)))) + (10 . #s(stx-boundary ((s0 s1)))) + (24 #s(stx-boundary ((s0 s1))) . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1))) + (127 . #s(stx-boundary (s0 s1))) + (12 . #s(stx-boundary ((s0 s1)))) + (4 . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (117 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (5 . #s(stx-boundary ((s0 s1)))) + (7 . #s(stx-boundary (s0 () (s1 s2)))) + (2 . #s(stx-boundary (s0 () (s1 s2)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 (s1 () (s2 s3)) s4))) + (7 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (2 . #s(stx-boundary (s0 s1 (s2 () (s3 s4)) s5))) + (135) + (13 . #f) + (3 . #f) + (7 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s0 (s5 s6) (s7 s8 (s3 #f)))) + (s7 s9 (s10 () (s3 s11)) s12)))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s0 (s5 s6) (s7 s8 (s3 #f)))) + (s7 s9 (s10 () (s3 s11)) s12)))) + (148 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s9 s11 (s12 () (s5 s13)) s14))))) + (7 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s9 s11 (s12 () (s5 s13)) s14))))) + (2 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s9 s11 (s12 () (s5 s13)) s14))))))) + ((let () (define-syntax (ok stx) (quote-syntax 8)) (ok 5)) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 8)) (s3 5))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 8)) (s3 5))))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (21 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (22 + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5))) + . + #s(stx-boundary (s5 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (9 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s5 (s1 s3) (s4 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 8)))) + (21 . #s(stx-boundary (s0 (s1) (s2 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 8))) + . + #s(stx-boundary (s3 (s1) (s2 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 8)))) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 8)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 8)))) + (10 . #s(stx-boundary ((s0 8)))) + (24 #s(stx-boundary ((s0 8))) . #s(stx-boundary ((s0 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 8))) + (127 . #s(stx-boundary (s0 8))) + (12 . #s(stx-boundary ((s0 8)))) + (4 . #s(stx-boundary ((s0 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 8))) + (118 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 5))) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 5))) + (21 . #s(stx-boundary (s0 5))) + (22 #s(stx-boundary 8) . #s(stx-boundary (s0 5))) + (9 . #s(stx-boundary 8)) + (2 . #s(stx-boundary 8)) + (127 . #s(stx-boundary 8)) + (14 #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) () 8))) + (0 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) () 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) () 8))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + () + . + #s(stx-boundary (8))) + (157 . #f) + (13 . #f) + (4 . #s(stx-boundary (8))) + (3 . #f) + (0 . #s(stx-boundary 8)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 8))) + (6 . #s(stx-boundary (s0 . 8))) + (115 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (142 . #s(stx-boundary (s0 () (s1 8)))) + (7 . #s(stx-boundary (s0 () (s1 8)))) + (2 . #s(stx-boundary (s0 () (s1 8)))) + (7 . #s(stx-boundary (s0 () (s0 () (s1 8))))) + (2 . #s(stx-boundary (s0 () (s0 () (s1 8))))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () (s2 8)))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () (s2 8)))))))) + ((with-continuation-mark __x __y __z) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 s2 s3 s4)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2 s3 s4)))) + (138 . #f) + (0 . #s(stx-boundary (s0 s1 s2 s3))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2 s3))) + (106 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (7 . #s(stx-boundary (s0 (s1 . s2) (s1 . s3) (s1 . s4)))) + (2 . #s(stx-boundary (s0 (s1 . s2) (s1 . s3) (s1 . s4)))) + (7 . #s(stx-boundary (s0 (s1 (s2 . s3) (s2 . s4) (s2 . s5))))) + (2 . #s(stx-boundary (s0 (s1 (s2 . s3) (s2 . s4) (s2 . s5))))))) + ((#%top . __x) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 . s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 . s2)))) + (138 . #f) + (0 . #s(stx-boundary (s0 . s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (7 . #s(stx-boundary (s0 (s1 . s2)))) + (2 . #s(stx-boundary (s0 (s1 . s2)))))) + ((let () (define-syntax-rule (ok x) x) (ok 5)) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 () (s2 (s3 s4) s4) (s3 5))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 () (s2 (s3 s4) s4) (s3 5))))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) s3) (s2 5)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 () (s1 (s2 s3) s3) (s2 5)))) + (21 . #s(stx-boundary (s0 () (s1 (s2 s3) s3) (s2 5)))) + (22 + #s(stx-boundary (s0 () (s1 (s2 s3) s3) (s2 5))) + . + #s(stx-boundary (s4 () (s1 (s2 s3) s3) (s2 5)))) + (9 . #s(stx-boundary (s0 () (s1 (s2 s3) s3) (s2 5)))) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) s3) (s2 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 (s2 s3) s3) (s2 5)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 (s1 s2) s2) (s1 5)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2) s2) (s1 5)))) + (24 + #s(stx-boundary ((s0 (s1 s2) s2) (s1 5))) + . + #s(stx-boundary ((s0 (s1 s2) s2) (s1 5)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) s2))) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary + (s0 + s1 + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8)))))))) + . + #s(stx-boundary (s5 (s1 s8) s8))) + (9 + . + #s(stx-boundary + (s0 + s1 + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (2 + . + #s(stx-boundary + (s0 + s1 + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (0 + . + #s(stx-boundary + (s0 + s1 + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + s1 + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (21 + . + #s(stx-boundary + (s0 + s1 + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (22 + #s(stx-boundary + (s0 + (s1) + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8)))))))) + . + #s(stx-boundary + (s13 + s1 + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (9 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (2 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (127 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8))))))))) + (103 . #f) + (148 + . + #s(stx-boundary + ((s0) + (s1 + (s2) + (s3 + s4 + #t + s2 + () + s5 + #f + ((s6 s7) (s8 (s9 s2 s7))) + (s6 (s10 s2 (s11 (s7))))))))) + (157 . #f) + (144 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1) + (s2 + s3 + #t + s1 + () + s4 + #f + ((s5 s6) (s7 (s8 s1 s6))) + (s5 (s9 s1 (s10 (s6)))))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1) + (s2 + s3 + #t + s1 + () + s4 + #f + ((s5 s6) (s7 (s8 s1 s6))) + (s5 (s9 s1 (s10 (s6)))))))) + (110 . #f) + (17 + #s(stx-boundary (s0)) + . + #s(stx-boundary + ((s1 + s2 + #t + s0 + () + s3 + #f + ((s4 s5) (s6 (s7 s0 s5))) + (s4 (s8 s0 (s9 (s5)))))))) + (10 + . + #s(stx-boundary + ((s0 + s1 + #t + s2 + () + s3 + #f + ((s4 s5) (s6 (s7 s2 s5))) + (s4 (s8 s2 (s9 (s5)))))))) + (24 + #s(stx-boundary + ((s0 + s1 + #t + s2 + () + s3 + #f + ((s4 s5) (s6 (s7 s2 s5))) + (s4 (s8 s2 (s9 (s5))))))) + . + #s(stx-boundary + ((s0 + s1 + #t + s2 + () + s3 + #f + ((s4 s5) (s6 (s7 s2 s5))) + (s4 (s8 s2 (s9 (s5)))))))) + (3 . #f) + (126 + . + #s(stx-boundary + (s0 + s1 + #t + s2 + () + s3 + #f + ((s4 s5) (s6 (s7 s2 s5))) + (s4 (s8 s2 (s9 (s5))))))) + (0 + . + #s(stx-boundary + (s0 + s1 + #t + s2 + () + s3 + #f + ((s4 s5) (s6 (s7 s2 s5))) + (s4 (s8 s2 (s9 (s5))))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + s1 + #t + s2 + () + s3 + #f + ((s4 s5) (s6 (s7 s2 s5))) + (s4 (s8 s2 (s9 (s5))))))) + (21 + . + #s(stx-boundary + (s0 + s1 + #t + s2 + () + s3 + #f + ((s4 s5) (s6 (s7 s2 s5))) + (s4 (s8 s2 (s9 (s5))))))) + (22 + #s(stx-boundary + (s0 + ((s1 s2)) + (s0 + ((s3 + ((s4 + (s5) + (s6 + (s7 s5) + (s6 + ((s4 (s5) s8) (s9 s5)) + ((s4 + (s5) + (s6 + (s7 s5) + (s0 ((s10 (s9 s5))) (s11 s10 (s12 (s13 s5)) s10)) + #f)) + (s13 s5)) + #f) + #f)) + s1))) + (s6 + s3 + (s0 + ((s14 s3)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s2 s16)))) + (s0 + ((s3 ((s4 (s5) s8) s1))) + (s6 + s3 + (s0 () (s15 () () (s21 s2 (s22 (s16))))) + (s23 #f #:opaque s1))))))) + . + #s(stx-boundary + (s24 + s25 + #t + s2 + () + s26 + #f + ((s27 s16) (s19 (s20 s2 s16))) + (s27 (s21 s2 (s22 (s16))))))) + (9 + . + #s(stx-boundary + (s0 + ((s1 s2)) + (s0 + ((s3 + ((s4 + (s5) + (s6 + (s7 s5) + (s6 + ((s4 (s5) s8) (s9 s5)) + ((s4 + (s5) + (s6 + (s7 s5) + (s0 ((s10 (s9 s5))) (s11 s10 (s12 (s13 s5)) s10)) + #f)) + (s13 s5)) + #f) + #f)) + s1))) + (s6 + s3 + (s0 + ((s14 s3)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s2 s16)))) + (s0 + ((s3 ((s4 (s5) s8) s1))) + (s6 + s3 + (s0 () (s15 () () (s21 s2 (s22 (s16))))) + (s23 #f #:opaque s1)))))))) + (2 + . + #s(stx-boundary + (s0 + ((s1 s2)) + (s0 + ((s3 + ((s4 + (s5) + (s6 + (s7 s5) + (s6 + ((s4 (s5) s8) (s9 s5)) + ((s4 + (s5) + (s6 + (s7 s5) + (s0 ((s10 (s9 s5))) (s11 s10 (s12 (s13 s5)) s10)) + #f)) + (s13 s5)) + #f) + #f)) + s1))) + (s6 + s3 + (s0 + ((s14 s3)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s2 s16)))) + (s0 + ((s3 ((s4 (s5) s8) s1))) + (s6 + s3 + (s0 () (s15 () () (s21 s2 (s22 (s16))))) + (s23 #f #:opaque s1)))))))) + (0 + . + #s(stx-boundary + (s0 + ((s1 s2)) + (s0 + ((s3 + ((s4 + (s5) + (s6 + (s7 s5) + (s6 + ((s4 (s5) s8) (s9 s5)) + ((s4 + (s5) + (s6 + (s7 s5) + (s0 ((s10 (s9 s5))) (s11 s10 (s12 (s13 s5)) s10)) + #f)) + (s13 s5)) + #f) + #f)) + s1))) + (s6 + s3 + (s0 + ((s14 s3)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s2 s16)))) + (s0 + ((s3 ((s4 (s5) s8) s1))) + (s6 + s3 + (s0 () (s15 () () (s21 s2 (s22 (s16))))) + (s23 #f #:opaque s1)))))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + ((s1 s2)) + (s0 + ((s3 + ((s4 + (s5) + (s6 + (s7 s5) + (s6 + ((s4 (s5) s8) (s9 s5)) + ((s4 + (s5) + (s6 + (s7 s5) + (s0 ((s10 (s9 s5))) (s11 s10 (s12 (s13 s5)) s10)) + #f)) + (s13 s5)) + #f) + #f)) + s1))) + (s6 + s3 + (s0 + ((s14 s3)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s2 s16)))) + (s0 + ((s3 ((s4 (s5) s8) s1))) + (s6 + s3 + (s0 () (s15 () () (s21 s2 (s22 (s16))))) + (s23 #f #:opaque s1)))))))) + (21 + . + #s(stx-boundary + (s0 + ((s1 s2)) + (s0 + ((s3 + ((s4 + (s5) + (s6 + (s7 s5) + (s6 + ((s4 (s5) s8) (s9 s5)) + ((s4 + (s5) + (s6 + (s7 s5) + (s0 ((s10 (s9 s5))) (s11 s10 (s12 (s13 s5)) s10)) + #f)) + (s13 s5)) + #f) + #f)) + s1))) + (s6 + s3 + (s0 + ((s14 s3)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s2 s16)))) + (s0 + ((s3 ((s4 (s5) s8) s1))) + (s6 + s3 + (s0 () (s15 () () (s21 s2 (s22 (s16))))) + (s23 #f #:opaque s1)))))))) + (22 + #s(stx-boundary + (s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1))))))) + . + #s(stx-boundary + (s3 + ((s1 s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1)))))))) + (9 + . + #s(stx-boundary + (s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1)))))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1)))))))) + (127 + . + #s(stx-boundary + (s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1)))))))) + (12 + . + #s(stx-boundary + ((s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1))))))))) + (4 + . + #s(stx-boundary + ((s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1))))))))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1)))))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) s2)) + (s3 + ((s4 + ((s5 + (s6) + (s7 + (s8 s6) + (s7 + ((s5 (s6) s9) (s10 s6)) + ((s5 + (s6) + (s7 + (s8 s6) + (s3 ((s11 (s10 s6))) (s12 s11 (s13 (s14 s6)) s11)) + #f)) + (s14 s6)) + #f) + #f)) + s1))) + (s7 + s4 + (s3 + ((s15 s4)) + (s16 (((s17) (s18 0 (s19 s15)))) () (s20 (s21 s2 s17)))) + (s3 + ((s4 ((s5 (s6) s9) s1))) + (s7 + s4 + (s3 () (s16 () () (s22 s2 (s23 (s17))))) + (s24 #f #:opaque s1)))))))) + (112 . #f) + (16 + (#s(stx-boundary ((s0) s1))) + . + #s(stx-boundary + ((s2 + ((s3 + ((s4 + (s5) + (s6 + (s7 s5) + (s6 + ((s4 (s5) s8) (s9 s5)) + ((s4 + (s5) + (s6 + (s7 s5) + (s2 ((s10 (s9 s5))) (s11 s10 (s12 (s13 s5)) s10)) + #f)) + (s13 s5)) + #f) + #f)) + s0))) + (s6 + s3 + (s2 + ((s14 s3)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s1 s16)))) + (s2 + ((s3 ((s4 (s5) s8) s0))) + (s6 + s3 + (s2 () (s15 () () (s21 s1 (s22 (s16))))) + (s23 #f #:opaque s0)))))))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (13 . #f) + (10 + . + #s(stx-boundary + ((s0 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s0 ((s8 (s7 s3))) (s9 s8 (s10 (s11 s3)) s8)) + #f)) + (s11 s3)) + #f) + #f)) + s12))) + (s4 + s1 + (s0 + ((s13 s1)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s0 + ((s1 ((s2 (s3) s6) s12))) + (s4 + s1 + (s0 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12)))))))) + (24 + #s(stx-boundary + ((s0 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s0 ((s8 (s7 s3))) (s9 s8 (s10 (s11 s3)) s8)) + #f)) + (s11 s3)) + #f) + #f)) + s12))) + (s4 + s1 + (s0 + ((s13 s1)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s0 + ((s1 ((s2 (s3) s6) s12))) + (s4 + s1 + (s0 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12))))))) + . + #s(stx-boundary + ((s0 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s0 ((s8 (s7 s3))) (s9 s8 (s10 (s11 s3)) s8)) + #f)) + (s11 s3)) + #f) + #f)) + s12))) + (s4 + s1 + (s0 + ((s13 s1)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s0 + ((s1 ((s2 (s3) s6) s12))) + (s4 + s1 + (s0 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12)))))))) + (3 . #f) + (126 + . + #s(stx-boundary + (s0 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s0 ((s8 (s7 s3))) (s9 s8 (s10 (s11 s3)) s8)) + #f)) + (s11 s3)) + #f) + #f)) + s12))) + (s4 + s1 + (s0 + ((s13 s1)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s0 + ((s1 ((s2 (s3) s6) s12))) + (s4 + s1 + (s0 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12))))))) + (0 + . + #s(stx-boundary + (s0 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s0 ((s8 (s7 s3))) (s9 s8 (s10 (s11 s3)) s8)) + #f)) + (s11 s3)) + #f) + #f)) + s12))) + (s4 + s1 + (s0 + ((s13 s1)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s0 + ((s1 ((s2 (s3) s6) s12))) + (s4 + s1 + (s0 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12))))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s0 ((s8 (s7 s3))) (s9 s8 (s10 (s11 s3)) s8)) + #f)) + (s11 s3)) + #f) + #f)) + s12))) + (s4 + s1 + (s0 + ((s13 s1)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s0 + ((s1 ((s2 (s3) s6) s12))) + (s4 + s1 + (s0 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12))))))) + (21 + . + #s(stx-boundary + (s0 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s0 ((s8 (s7 s3))) (s9 s8 (s10 (s11 s3)) s8)) + #f)) + (s11 s3)) + #f) + #f)) + s12))) + (s4 + s1 + (s0 + ((s13 s1)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s0 + ((s1 ((s2 (s3) s6) s12))) + (s4 + s1 + (s0 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12))))))) + (22 + #s(stx-boundary + (s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13)))))) + . + #s(stx-boundary + (s8 + ((s1 + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13))))))) + (9 + . + #s(stx-boundary + (s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13))))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13))))))) + (127 + . + #s(stx-boundary + (s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13))))))) + (12 + . + #s(stx-boundary + ((s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13)))))))) + (4 + . + #s(stx-boundary + ((s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13)))))))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13))))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) + ((s2 + (s3) + (s4 + (s5 s3) + (s4 + ((s2 (s3) s6) (s7 s3)) + ((s2 + (s3) + (s4 + (s5 s3) + (s8 ((s9 (s7 s3))) (s10 s9 (s11 (s12 s3)) s9)) + #f)) + (s12 s3)) + #f) + #f)) + s13))) + (s4 + s1 + (s8 + ((s14 s1)) + (s15 (((s16) (s17 0 (s18 s14)))) () (s19 (s20 s21 s16)))) + (s8 + ((s1 ((s2 (s3) s6) s13))) + (s4 + s1 + (s8 () (s15 () () (s22 s21 (s23 (s16))))) + (s24 #f #:opaque s13))))))) + (112 . #f) + (16 + (#s(stx-boundary + ((s0) + ((s1 + (s2) + (s3 + (s4 s2) + (s3 + ((s1 (s2) s5) (s6 s2)) + ((s1 + (s2) + (s3 + (s4 s2) + (s7 ((s8 (s6 s2))) (s9 s8 (s10 (s11 s2)) s8)) + #f)) + (s11 s2)) + #f) + #f)) + s12)))) + . + #s(stx-boundary + ((s3 + s0 + (s7 + ((s13 s0)) + (s14 (((s15) (s16 0 (s17 s13)))) () (s18 (s19 s20 s15)))) + (s7 + ((s0 ((s1 (s2) s5) s12))) + (s3 + s0 + (s7 () (s14 () () (s21 s20 (s22 (s15))))) + (s23 #f #:opaque s12))))))) + (3 . #f) + (0 + . + #s(stx-boundary + ((s0 + (s1) + (s2 + (s3 s1) + (s2 + ((s0 (s1) s4) (s5 s1)) + ((s0 + (s1) + (s2 (s3 s1) (s6 ((s7 (s5 s1))) (s8 s7 (s9 (s10 s1)) s7)) #f)) + (s10 s1)) + #f) + #f)) + s11))) + (1 . #s(stx-boundary s0)) + (142 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 + (s4 s2) + (s3 + ((s1 (s2) s5) (s6 s2)) + ((s1 + (s2) + (s3 + (s4 s2) + (s7 ((s8 (s6 s2))) (s9 s8 (s10 (s11 s2)) s8)) + #f)) + (s11 s2)) + #f) + #f)) + s12))) + (6 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 + (s4 s2) + (s3 + ((s1 (s2) s5) (s6 s2)) + ((s1 + (s2) + (s3 + (s4 s2) + (s7 ((s8 (s6 s2))) (s9 s8 (s10 (s11 s2)) s8)) + #f)) + (s11 s2)) + #f) + #f)) + s12))) + (109 . #f) + (4 + . + #s(stx-boundary + ((s0 + (s1) + (s2 + (s3 s1) + (s2 + ((s0 (s1) s4) (s5 s1)) + ((s0 + (s1) + (s2 (s3 s1) (s6 ((s7 (s5 s1))) (s8 s7 (s9 (s10 s1)) s7)) #f)) + (s10 s1)) + #f) + #f)) + s11))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3 s1) + (s2 + ((s0 (s1) s4) (s5 s1)) + ((s0 + (s1) + (s2 (s3 s1) (s6 ((s7 (s5 s1))) (s8 s7 (s9 (s10 s1)) s7)) #f)) + (s10 s1)) + #f) + #f)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3 s1) + (s2 + ((s0 (s1) s4) (s5 s1)) + ((s0 + (s1) + (s2 (s3 s1) (s6 ((s7 (s5 s1))) (s8 s7 (s9 (s10 s1)) s7)) #f)) + (s10 s1)) + #f) + #f)))) + (110 . #f) + (17 + #s(stx-boundary (s0)) + . + #s(stx-boundary + ((s1 + (s2 s0) + (s1 + ((s3 (s0) s4) (s5 s0)) + ((s3 + (s0) + (s1 (s2 s0) (s6 ((s7 (s5 s0))) (s8 s7 (s9 (s10 s0)) s7)) #f)) + (s10 s0)) + #f) + #f)))) + (10 + . + #s(stx-boundary + ((s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f)))) + (24 + #s(stx-boundary + ((s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f))) + . + #s(stx-boundary + ((s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f)))) + (3 . #f) + (126 + . + #s(stx-boundary + (s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f))) + (127 + . + #s(stx-boundary + (s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f))) + (12 + . + #s(stx-boundary + ((s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f)))) + (4 + . + #s(stx-boundary + ((s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f)))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 s2) + (s0 + ((s3 (s2) s4) (s5 s2)) + ((s3 + (s2) + (s0 (s1 s2) (s6 ((s7 (s5 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f) + #f))) + (105 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + ((s1 (s2) s3) (s4 s2)) + ((s1 + (s2) + (s0 (s5 s2) (s6 ((s7 (s4 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + ((s1 (s2) s3) (s4 s2)) + ((s1 + (s2) + (s0 (s5 s2) (s6 ((s7 (s4 s2))) (s8 s7 (s9 (s10 s2)) s7)) #f)) + (s10 s2)) + #f))) + (105 . #f) + (0 . #s(stx-boundary ((s0 (s1) s2) (s3 s1)))) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 (s1 (s2) s3) (s4 s2)))) + (6 . #s(stx-boundary (s0 (s1 (s2) s3) (s4 s2)))) + (109 . #f) + (4 . #s(stx-boundary ((s0 (s1) s2) (s3 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s2))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s1))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s2))) + (2 . #s(stx-boundary (s0 (s1) s2))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary ((s0 (s1) s2) (s3 s4 s1)))) + (7 . #s(stx-boundary (s0 (s1 (s2) s3) (s0 s4 s2)))) + (2 . #s(stx-boundary (s0 (s1 (s2) s3) (s0 s4 s2)))) + (3 . #f) + (0 + . + #s(stx-boundary + ((s0 + (s1) + (s2 (s3 s1) (s4 ((s5 (s6 s1))) (s7 s5 (s8 (s9 s1)) s5)) #f)) + (s9 s1)))) + (1 . #s(stx-boundary s0)) + (142 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 (s4 s2) (s5 ((s6 (s7 s2))) (s8 s6 (s9 (s10 s2)) s6)) #f)) + (s10 s2)))) + (6 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 (s4 s2) (s5 ((s6 (s7 s2))) (s8 s6 (s9 (s10 s2)) s6)) #f)) + (s10 s2)))) + (109 . #f) + (4 + . + #s(stx-boundary + ((s0 + (s1) + (s2 (s3 s1) (s4 ((s5 (s6 s1))) (s7 s5 (s8 (s9 s1)) s5)) #f)) + (s9 s1)))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1) + (s2 (s3 s1) (s4 ((s5 (s6 s1))) (s7 s5 (s8 (s9 s1)) s5)) #f)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1) + (s2 (s3 s1) (s4 ((s5 (s6 s1))) (s7 s5 (s8 (s9 s1)) s5)) #f)))) + (110 . #f) + (17 + #s(stx-boundary (s0)) + . + #s(stx-boundary + ((s1 (s2 s0) (s3 ((s4 (s5 s0))) (s6 s4 (s7 (s8 s0)) s4)) #f)))) + (10 + . + #s(stx-boundary + ((s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f)))) + (24 + #s(stx-boundary + ((s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f))) + . + #s(stx-boundary + ((s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f)))) + (3 . #f) + (126 + . + #s(stx-boundary + (s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f))) + (127 + . + #s(stx-boundary + (s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f))) + (12 + . + #s(stx-boundary + ((s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f)))) + (4 + . + #s(stx-boundary + ((s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f)))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (s1 s2) (s3 ((s4 (s5 s2))) (s6 s4 (s7 (s8 s2)) s4)) #f))) + (105 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (3 . #f) + (0 . #s(stx-boundary (s0 ((s1 (s2 s3))) (s4 s1 (s5 (s6 s3)) s1)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 ((s1 (s2 s3))) (s4 s1 (s5 (s6 s3)) s1)))) + (21 . #s(stx-boundary (s0 ((s1 (s2 s3))) (s4 s1 (s5 (s6 s3)) s1)))) + (22 + #s(stx-boundary (s0 (((s1) (s2 s3))) (s4 s1 (s5 (s6 s3)) s1))) + . + #s(stx-boundary (s7 ((s1 (s2 s3))) (s4 s1 (s5 (s6 s3)) s1)))) + (9 . #s(stx-boundary (s0 (((s1) (s2 s3))) (s4 s1 (s5 (s6 s3)) s1)))) + (0 . #s(stx-boundary (s0 (((s1) (s2 s3))) (s4 s1 (s5 (s6 s3)) s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) (s2 s3))) (s4 s1 (s5 (s6 s3)) s1)))) + (112 . #f) + (16 + (#s(stx-boundary ((s0) (s1 s2)))) + . + #s(stx-boundary ((s3 s0 (s4 (s5 s2)) s0)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (13 . #f) + (10 . #s(stx-boundary ((s0 s1 (s2 (s3 s4)) s1)))) + (24 + #s(stx-boundary ((s0 s1 (s2 (s3 s4)) s1))) + . + #s(stx-boundary ((s0 s1 (s2 (s3 s4)) s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) s1))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) s1))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) s1))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3 (s4 s5)) s1) #f)) + . + #s(stx-boundary (s2 s1 (s3 (s4 s5)) s1))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3 (s4 s5)) s1) #f))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3 (s4 s5)) s1) #f))) + (127 . #s(stx-boundary (s0 s1 (s2 (s3 (s4 s5)) s1) #f))) + (12 . #s(stx-boundary ((s0 s1 (s2 (s3 (s4 s5)) s1) #f)))) + (4 . #s(stx-boundary ((s0 s1 (s2 (s3 (s4 s5)) s1) #f)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 (s4 s5)) s1) #f))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 (s3 (s4 s5)) s1) #f))) + (105 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 s3)) s4))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 (s2 s3)) s4))) + (21 . #s(stx-boundary (s0 (s1 (s2 s3)) s4))) + (22 + #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f)) + . + #s(stx-boundary (s4 (s1 (s2 s3)) s5))) + (9 . #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f))) + (0 . #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f))) + (105 . #f) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 s3)))) + (6 . #s(stx-boundary (s0 s1 (s2 s3)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 s2)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary (s0 (s1 s2 s3)))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 s3)))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 s3)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1))) + (21 . #s(stx-boundary (s0 s1))) + (22 #s(stx-boundary (s0 s1)) . #s(stx-boundary (s2 s1))) + (9 . #s(stx-boundary (s0 s1))) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (138 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (142 . #s(stx-boundary s0)) + (7 . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (7 . #s(stx-boundary (s0 (s1 s2 (s1 s3 s4)) s5 (s6 #f)))) + (2 . #s(stx-boundary (s0 (s1 s2 (s1 s3 s4)) s5 (s6 #f)))) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (7 + . + #s(stx-boundary (s0 s1 (s0 (s2 s3 (s2 s4 s5)) s1 (s6 #f)) (s6 #f)))) + (2 + . + #s(stx-boundary (s0 s1 (s0 (s2 s3 (s2 s4 s5)) s1 (s6 #f)) (s6 #f)))) + (5 + . + #s(stx-boundary ((s0 s1 (s0 (s2 s3 (s2 s4 s5)) s1 (s6 #f)) (s6 #f))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 s3 s4))) + (s5 s1 (s5 (s2 s6 (s2 s7 s4)) s1 (s8 #f)) (s8 #f))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 s3 s4))) + (s5 s1 (s5 (s2 s6 (s2 s7 s4)) s1 (s8 #f)) (s8 #f))))) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (7 + . + #s(stx-boundary + (s0 + (s1 s2 s3) + (s4 + (((s5) (s1 s6 s3))) + (s0 s5 (s0 (s1 s7 (s1 s8 s3)) s5 (s9 #f)) (s9 #f))) + (s9 #f)))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 s3) + (s4 + (((s5) (s1 s6 s3))) + (s0 s5 (s0 (s1 s7 (s1 s8 s3)) s5 (s9 #f)) (s9 #f))) + (s9 #f)))) + (5 + . + #s(stx-boundary + ((s0 + (s1 s2 s3) + (s4 + (((s5) (s1 s6 s3))) + (s0 s5 (s0 (s1 s7 (s1 s8 s3)) s5 (s9 #f)) (s9 #f))) + (s9 #f))))) + (7 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3 s4 s1) + (s5 + (((s6) (s3 s7 s1))) + (s2 s6 (s2 (s3 s8 (s3 s9 s1)) s6 (s10 #f)) (s10 #f))) + (s10 #f))))) + (2 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3 s4 s1) + (s5 + (((s6) (s3 s7 s1))) + (s2 s6 (s2 (s3 s8 (s3 s9 s1)) s6 (s10 #f)) (s10 #f))) + (s10 #f))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 + . + #s(stx-boundary + ((s0 + (s1) + (s2 + (s3 s4 s1) + (s5 + (((s6) (s3 s7 s1))) + (s2 s6 (s2 (s3 s8 (s3 s9 s1)) s6 (s10 #f)) (s10 #f))) + (s10 #f))) + (s3 s9 s1)))) + (7 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 + (s0 s4 s2) + (s5 + (((s6) (s0 s7 s2))) + (s3 s6 (s3 (s0 s8 (s0 s9 s2)) s6 (s10 #f)) (s10 #f))) + (s10 #f))) + (s0 s9 s2)))) + (2 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 + (s0 s4 s2) + (s5 + (((s6) (s0 s7 s2))) + (s3 s6 (s3 (s0 s8 (s0 s9 s2)) s6 (s10 #f)) (s10 #f))) + (s10 #f))) + (s0 s9 s2)))) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (7 + . + #s(stx-boundary + (s0 + (s1 (s2 (s3) s4) (s1 s5 s3)) + (s1 + (s2 + (s3) + (s0 + (s1 s6 s3) + (s7 + (((s8) (s1 s5 s3))) + (s0 s8 (s0 (s1 s9 (s1 s10 s3)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s1 s10 s3)) + (s11 #f)))) + (2 + . + #s(stx-boundary + (s0 + (s1 (s2 (s3) s4) (s1 s5 s3)) + (s1 + (s2 + (s3) + (s0 + (s1 s6 s3) + (s7 + (((s8) (s1 s5 s3))) + (s0 s8 (s0 (s1 s9 (s1 s10 s3)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s1 s10 s3)) + (s11 #f)))) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (7 + . + #s(stx-boundary + (s0 + (s1 s2 s3) + (s0 + (s1 (s4 (s3) s5) (s1 s6 s3)) + (s1 + (s4 + (s3) + (s0 + (s1 s2 s3) + (s7 + (((s8) (s1 s6 s3))) + (s0 s8 (s0 (s1 s9 (s1 s10 s3)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s1 s10 s3)) + (s11 #f)) + (s11 #f)))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 s3) + (s0 + (s1 (s4 (s3) s5) (s1 s6 s3)) + (s1 + (s4 + (s3) + (s0 + (s1 s2 s3) + (s7 + (((s8) (s1 s6 s3))) + (s0 s8 (s0 (s1 s9 (s1 s10 s3)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s1 s10 s3)) + (s11 #f)) + (s11 #f)))) + (5 + . + #s(stx-boundary + ((s0 + (s1 s2 s3) + (s0 + (s1 (s4 (s3) s5) (s1 s6 s3)) + (s1 + (s4 + (s3) + (s0 + (s1 s2 s3) + (s7 + (((s8) (s1 s6 s3))) + (s0 s8 (s0 (s1 s9 (s1 s10 s3)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s1 s10 s3)) + (s11 #f)) + (s11 #f))))) + (7 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3 s4 s1) + (s2 + (s3 (s0 (s1) s5) (s3 s6 s1)) + (s3 + (s0 + (s1) + (s2 + (s3 s4 s1) + (s7 + (((s8) (s3 s6 s1))) + (s2 s8 (s2 (s3 s9 (s3 s10 s1)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s3 s10 s1)) + (s11 #f)) + (s11 #f))))) + (2 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (s3 s4 s1) + (s2 + (s3 (s0 (s1) s5) (s3 s6 s1)) + (s3 + (s0 + (s1) + (s2 + (s3 s4 s1) + (s7 + (((s8) (s3 s6 s1))) + (s2 s8 (s2 (s3 s9 (s3 s10 s1)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s3 s10 s1)) + (s11 #f)) + (s11 #f))))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 + . + #s(stx-boundary + ((s0 + (s1) + (s2 + (s3 s4 s1) + (s2 + (s3 (s0 (s1) s5) (s3 s6 s1)) + (s3 + (s0 + (s1) + (s2 + (s3 s4 s1) + (s7 + (((s8) (s3 s6 s1))) + (s2 s8 (s2 (s3 s9 (s3 s10 s1)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s3 s10 s1)) + (s11 #f)) + (s11 #f))) + s12))) + (7 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 + (s0 s4 s2) + (s3 + (s0 (s1 (s2) s5) (s0 s6 s2)) + (s0 + (s1 + (s2) + (s3 + (s0 s4 s2) + (s7 + (((s8) (s0 s6 s2))) + (s3 s8 (s3 (s0 s9 (s0 s10 s2)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s0 s10 s2)) + (s11 #f)) + (s11 #f))) + s12))) + (2 + . + #s(stx-boundary + (s0 + (s1 + (s2) + (s3 + (s0 s4 s2) + (s3 + (s0 (s1 (s2) s5) (s0 s6 s2)) + (s0 + (s1 + (s2) + (s3 + (s0 s4 s2) + (s7 + (((s8) (s0 s6 s2))) + (s3 s8 (s3 (s0 s9 (s0 s10 s2)) s8 (s11 #f)) (s11 #f))) + (s11 #f))) + (s0 s10 s2)) + (s11 #f)) + (s11 #f))) + s12))) + (13 . #f) + (10 + . + #s(stx-boundary + ((s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14))))))) + (24 + #s(stx-boundary + ((s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14)))))) + . + #s(stx-boundary + ((s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14))))))) + (3 . #f) + (126 + . + #s(stx-boundary + (s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14)))))) + (127 + . + #s(stx-boundary + (s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14)))))) + (12 + . + #s(stx-boundary + ((s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14))))))) + (4 + . + #s(stx-boundary + ((s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14))))))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + s1 + (s2 ((s3 s1)) (s4 (((s5) (s6 0 (s7 s3)))) () (s8 (s9 s10 s5)))) + (s2 + ((s1 ((s11 (s12) s13) s14))) + (s0 + s1 + (s2 () (s4 () () (s15 s10 (s16 (s5))))) + (s17 #f #:opaque s14)))))) + (105 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 ((s1 s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4)))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 ((s1 s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4)))))) + (21 + . + #s(stx-boundary + (s0 ((s1 s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4)))))) + (22 + #s(stx-boundary + (s0 (((s1) s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4))))) + . + #s(stx-boundary + (s10 ((s1 s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4)))))) + (9 + . + #s(stx-boundary + (s0 (((s1) s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4)))))) + (0 + . + #s(stx-boundary + (s0 (((s1) s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (((s1) s2)) (s3 (((s4) (s5 0 (s6 s1)))) () (s7 (s8 s9 s4)))))) + (112 . #f) + (16 + (#s(stx-boundary ((s0) s1))) + . + #s(stx-boundary ((s2 (((s3) (s4 0 (s5 s0)))) () (s6 (s7 s8 s3)))))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (13 . #f) + (10 + . + #s(stx-boundary ((s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1)))))) + (24 + #s(stx-boundary ((s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1))))) + . + #s(stx-boundary ((s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1)))))) + (3 . #f) + (126 + . + #s(stx-boundary (s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1))))) + (127 + . + #s(stx-boundary (s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1))))) + (12 + . + #s(stx-boundary ((s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1)))))) + (4 + . + #s(stx-boundary ((s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) (s2 0 (s3 s4)))) () (s5 (s6 s7 s1))))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 0 (s2 s3))))) + () + . + #s(stx-boundary ((s4 (s5 s6 s0))))) + (157 . #f) + (3 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 0 (s2 s3)))) + (6 . #s(stx-boundary (s0 s1 0 (s2 s3)))) + (109 . #f) + (4 . #s(stx-boundary (s0 0 (s1 s2)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 0))) + (6 . #s(stx-boundary (s0 . 0))) + (115 . #f) + (7 . #s(stx-boundary (s0 0))) + (2 . #s(stx-boundary (s0 0))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (118 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (5 . #s(stx-boundary (s0 (s1 0) (s2 s3)))) + (7 . #s(stx-boundary (s0 s1 (s2 0) (s3 s4)))) + (2 . #s(stx-boundary (s0 s1 (s2 0) (s3 s4)))) + (3 . #f) + (145 . #f) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2 s3))))) + (24 + #s(stx-boundary ((s0 (s1 s2 s3)))) + . + #s(stx-boundary ((s0 (s1 s2 s3))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2 s3)))) + (127 . #s(stx-boundary (s0 (s1 s2 s3)))) + (12 . #s(stx-boundary ((s0 (s1 s2 s3))))) + (4 . #s(stx-boundary ((s0 (s1 s2 s3))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 s2 s3)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 s3 s4)))) + (6 . #s(stx-boundary (s0 s1 (s2 s3 s4)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 s2 s3)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (153 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (154 . #t) + (22 #s(stx-boundary (s0 s1)) . #s(stx-boundary (s2 s3 s1))) + (9 . #s(stx-boundary (s0 s1))) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1))) + (21 . #s(stx-boundary (s0 s1))) + (153 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (154 . #t) + (22 #s(stx-boundary s0) . #s(stx-boundary (s1 s2))) + (9 . #s(stx-boundary s0)) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary ((s0 s1 s2)))) + (142 . #s(stx-boundary (s0 () (s1 s2 s3)))) + (7 . #s(stx-boundary (s0 () (s1 s2 s3)))) + (2 . #s(stx-boundary (s0 () (s1 s2 s3)))) + (5 . #s(stx-boundary ((s0 () (s1 s2 s3))))) + (7 . #s(stx-boundary (s0 (((s1) s2)) (s0 () (s3 s4 s1))))) + (2 . #s(stx-boundary (s0 (((s1) s2)) (s0 () (s3 s4 s1))))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 + ((s1 ((s2 (s3) s4) s5))) + (s6 + s1 + (s0 () (s7 () () (s8 s9 (s10 (s11))))) + (s12 #f #:opaque s5))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + ((s1 ((s2 (s3) s4) s5))) + (s6 + s1 + (s0 () (s7 () () (s8 s9 (s10 (s11))))) + (s12 #f #:opaque s5))))) + (21 + . + #s(stx-boundary + (s0 + ((s1 ((s2 (s3) s4) s5))) + (s6 + s1 + (s0 () (s7 () () (s8 s9 (s10 (s11))))) + (s12 #f #:opaque s5))))) + (22 + #s(stx-boundary + (s0 + (((s1) ((s2 (s3) s4) s5))) + (s6 + s1 + (s7 () (s8 () () (s9 s10 (s11 (s12))))) + (s13 #f #:opaque s5)))) + . + #s(stx-boundary + (s7 + ((s1 ((s2 (s3) s4) s5))) + (s6 + s1 + (s7 () (s8 () () (s9 s10 (s11 (s12))))) + (s13 #f #:opaque s5))))) + (9 + . + #s(stx-boundary + (s0 + (((s1) ((s2 (s3) s4) s5))) + (s6 + s1 + (s7 () (s8 () () (s9 s10 (s11 (s12))))) + (s13 #f #:opaque s5))))) + (0 + . + #s(stx-boundary + (s0 + (((s1) ((s2 (s3) s4) s5))) + (s6 + s1 + (s7 () (s8 () () (s9 s10 (s11 (s12))))) + (s13 #f #:opaque s5))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) ((s2 (s3) s4) s5))) + (s6 + s1 + (s7 () (s8 () () (s9 s10 (s11 (s12))))) + (s13 #f #:opaque s5))))) + (112 . #f) + (16 + (#s(stx-boundary ((s0) ((s1 (s2) s3) s4)))) + . + #s(stx-boundary + ((s5 + s0 + (s6 () (s7 () () (s8 s9 (s10 (s11))))) + (s12 #f #:opaque s4))))) + (3 . #f) + (0 . #s(stx-boundary ((s0 (s1) s2) s3))) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 (s1 (s2) s3) s4))) + (6 . #s(stx-boundary (s0 (s1 (s2) s3) s4))) + (109 . #f) + (4 . #s(stx-boundary ((s0 (s1) s2) s3))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s2))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s1))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s2))) + (2 . #s(stx-boundary (s0 (s1) s2))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary ((s0 (s1) s2) s3))) + (7 . #s(stx-boundary (s0 (s1 (s2) s3) s4))) + (2 . #s(stx-boundary (s0 (s1 (s2) s3) s4))) + (13 . #f) + (10 + . + #s(stx-boundary + ((s0 + s1 + (s2 () (s3 () () (s4 s5 (s6 (s7))))) + (s8 #f #:opaque s9))))) + (24 + #s(stx-boundary + ((s0 s1 (s2 () (s3 () () (s4 s5 (s6 (s7))))) (s8 #f #:opaque s9)))) + . + #s(stx-boundary + ((s0 + s1 + (s2 () (s3 () () (s4 s5 (s6 (s7))))) + (s8 #f #:opaque s9))))) + (3 . #f) + (126 + . + #s(stx-boundary + (s0 s1 (s2 () (s3 () () (s4 s5 (s6 (s7))))) (s8 #f #:opaque s9)))) + (127 + . + #s(stx-boundary + (s0 s1 (s2 () (s3 () () (s4 s5 (s6 (s7))))) (s8 #f #:opaque s9)))) + (12 + . + #s(stx-boundary + ((s0 + s1 + (s2 () (s3 () () (s4 s5 (s6 (s7))))) + (s8 #f #:opaque s9))))) + (4 + . + #s(stx-boundary + ((s0 + s1 + (s2 () (s3 () () (s4 s5 (s6 (s7))))) + (s8 #f #:opaque s9))))) + (3 . #f) + (0 + . + #s(stx-boundary + (s0 s1 (s2 () (s3 () () (s4 s5 (s6 (s7))))) (s8 #f #:opaque s9)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 s1 (s2 () (s3 () () (s4 s5 (s6 (s7))))) (s8 #f #:opaque s9)))) + (105 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 () (s1 () () (s2 s3 (s4 (s5))))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 () (s1 () () (s2 s3 (s4 (s5))))))) + (21 . #s(stx-boundary (s0 () (s1 () () (s2 s3 (s4 (s5))))))) + (22 + #s(stx-boundary (s0 () (s1 () () (s2 s3 (s4 (s5)))))) + . + #s(stx-boundary (s6 () (s1 () () (s2 s3 (s4 (s5))))))) + (9 . #s(stx-boundary (s0 () (s1 () () (s2 s3 (s4 (s5))))))) + (0 . #s(stx-boundary (s0 () (s1 () () (s2 s3 (s4 (s5))))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 () () (s2 s3 (s4 (s5))))))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 () () (s1 s2 (s3 (s4))))))) + (13 . #f) + (10 . #s(stx-boundary ((s0 () () (s1 s2 (s3 (s4))))))) + (24 + #s(stx-boundary ((s0 () () (s1 s2 (s3 (s4)))))) + . + #s(stx-boundary ((s0 () () (s1 s2 (s3 (s4))))))) + (3 . #f) + (126 . #s(stx-boundary (s0 () () (s1 s2 (s3 (s4)))))) + (127 . #s(stx-boundary (s0 () () (s1 s2 (s3 (s4)))))) + (12 . #s(stx-boundary ((s0 () () (s1 s2 (s3 (s4))))))) + (4 . #s(stx-boundary ((s0 () () (s1 s2 (s3 (s4))))))) + (3 . #f) + (0 . #s(stx-boundary (s0 () () (s1 s2 (s3 (s4)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () () (s1 s2 (s3 (s4)))))) + (114 . #f) + (19 () () . #s(stx-boundary ((s0 s1 (s2 (s3)))))) + (157 . #f) + (13 . #f) + (10 . #s(stx-boundary ((s0 s1 (s2 (s3)))))) + (24 + #s(stx-boundary ((s0 s1 (s2 (s3))))) + . + #s(stx-boundary ((s0 s1 (s2 (s3)))))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (127 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (12 . #s(stx-boundary ((s0 s1 (s2 (s3)))))) + (4 . #s(stx-boundary ((s0 s1 (s2 (s3)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2 (s3 (s4))))) + (6 . #s(stx-boundary (s0 s1 s2 (s3 (s4))))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1)))) + (117 . #f) + (7 . #s(stx-boundary (s0 (s1)))) + (2 . #s(stx-boundary (s0 (s1)))) + (5 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (7 . #s(stx-boundary (s0 s1 s2 (s3 (s4))))) + (2 . #s(stx-boundary (s0 s1 s2 (s3 (s4))))) + (5 . #s(stx-boundary ((s0 s1 s2 (s3 (s4)))))) + (142 . #s(stx-boundary (s0 () (s1 s2 s3 (s4 (s5)))))) + (7 . #s(stx-boundary (s0 () (s1 s2 s3 (s4 (s5)))))) + (2 . #s(stx-boundary (s0 () (s1 s2 s3 (s4 (s5)))))) + (5 . #s(stx-boundary ((s0 () (s1 s2 s3 (s4 (s5))))))) + (7 . #s(stx-boundary (s0 () (s0 () (s1 s2 s3 (s4 (s5))))))) + (2 . #s(stx-boundary (s0 () (s0 () (s1 s2 s3 (s4 (s5))))))) + (3 . #f) + (0 . #s(stx-boundary (s0 #f #:opaque s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 #f #:opaque s2))) + (6 . #s(stx-boundary (s0 s1 #f #:opaque s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 #f #:opaque s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (3 . #f) + (0 . #s(stx-boundary #:opaque)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #:opaque))) + (6 . #s(stx-boundary (s0 . #:opaque))) + (115 . #f) + (7 . #s(stx-boundary (s0 #:opaque))) + (2 . #s(stx-boundary (s0 #:opaque))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 (s1 #f) (s1 #:opaque) s2))) + (7 . #s(stx-boundary (s0 s1 (s2 #f) (s2 #:opaque) s3))) + (2 . #s(stx-boundary (s0 s1 (s2 #f) (s2 #:opaque) s3))) + (7 + . + #s(stx-boundary + (s0 + s1 + (s2 () (s2 () (s3 s4 s5 (s6 (s7))))) + (s3 s8 (s6 #f) (s6 #:opaque) s9)))) + (2 + . + #s(stx-boundary + (s0 + s1 + (s2 () (s2 () (s3 s4 s5 (s6 (s7))))) + (s3 s8 (s6 #f) (s6 #:opaque) s9)))) + (5 + . + #s(stx-boundary + ((s0 + s1 + (s2 () (s2 () (s3 s4 s5 (s6 (s7))))) + (s3 s8 (s6 #f) (s6 #:opaque) s9))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3 (s4) s5) s6))) + (s7 + s1 + (s0 () (s0 () (s2 s8 s9 (s10 (s11))))) + (s2 s12 (s10 #f) (s10 #:opaque) s6))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3 (s4) s5) s6))) + (s7 + s1 + (s0 () (s0 () (s2 s8 s9 (s10 (s11))))) + (s2 s12 (s10 #f) (s10 #:opaque) s6))))) + (7 + . + #s(stx-boundary + (s0 + s1 + (s2 (((s3) s1)) (s2 () (s4 s5 s3))) + (s2 + (((s1) (s4 (s6 (s7) s8) s9))) + (s0 + s1 + (s2 () (s2 () (s4 s10 s11 (s12 (s13))))) + (s4 s14 (s12 #f) (s12 #:opaque) s9)))))) + (2 + . + #s(stx-boundary + (s0 + s1 + (s2 (((s3) s1)) (s2 () (s4 s5 s3))) + (s2 + (((s1) (s4 (s6 (s7) s8) s9))) + (s0 + s1 + (s2 () (s2 () (s4 s10 s11 (s12 (s13))))) + (s4 s14 (s12 #f) (s12 #:opaque) s9)))))) + (5 + . + #s(stx-boundary + ((s0 + s1 + (s2 (((s3) s1)) (s2 () (s4 s5 s3))) + (s2 + (((s1) (s4 (s6 (s7) s8) s9))) + (s0 + s1 + (s2 () (s2 () (s4 s10 s11 (s12 (s13))))) + (s4 s14 (s12 #f) (s12 #:opaque) s9))))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) + (s2 + (s3 + (s4) + (s5 + (s2 s6 s4) + (s5 + (s2 (s3 (s4) s7) (s2 s8 s4)) + (s2 + (s3 + (s4) + (s5 + (s2 s6 s4) + (s0 + (((s9) (s2 s8 s4))) + (s5 s9 (s5 (s2 s10 (s2 s11 s4)) s9 (s12 #f)) (s12 #f))) + (s12 #f))) + (s2 s11 s4)) + (s12 #f)) + (s12 #f))) + s13))) + (s5 + s1 + (s0 (((s14) s1)) (s0 () (s2 s15 s14))) + (s0 + (((s1) (s2 (s3 (s4) s7) s13))) + (s5 + s1 + (s0 () (s0 () (s2 s16 s17 (s12 (s18))))) + (s2 s19 (s12 #f) (s12 #:opaque) s13))))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) + (s2 + (s3 + (s4) + (s5 + (s2 s6 s4) + (s5 + (s2 (s3 (s4) s7) (s2 s8 s4)) + (s2 + (s3 + (s4) + (s5 + (s2 s6 s4) + (s0 + (((s9) (s2 s8 s4))) + (s5 s9 (s5 (s2 s10 (s2 s11 s4)) s9 (s12 #f)) (s12 #f))) + (s12 #f))) + (s2 s11 s4)) + (s12 #f)) + (s12 #f))) + s13))) + (s5 + s1 + (s0 (((s14) s1)) (s0 () (s2 s15 s14))) + (s0 + (((s1) (s2 (s3 (s4) s7) s13))) + (s5 + s1 + (s0 () (s0 () (s2 s16 s17 (s12 (s18))))) + (s2 s19 (s12 #f) (s12 #:opaque) s13))))))) + (5 + . + #s(stx-boundary + ((s0 + (((s1) + (s2 + (s3 + (s4) + (s5 + (s2 s6 s4) + (s5 + (s2 (s3 (s4) s7) (s2 s8 s4)) + (s2 + (s3 + (s4) + (s5 + (s2 s6 s4) + (s0 + (((s9) (s2 s8 s4))) + (s5 s9 (s5 (s2 s10 (s2 s11 s4)) s9 (s12 #f)) (s12 #f))) + (s12 #f))) + (s2 s11 s4)) + (s12 #f)) + (s12 #f))) + s13))) + (s5 + s1 + (s0 (((s14) s1)) (s0 () (s2 s15 s14))) + (s0 + (((s1) (s2 (s3 (s4) s7) s13))) + (s5 + s1 + (s0 () (s0 () (s2 s16 s17 (s12 (s18))))) + (s2 s19 (s12 #f) (s12 #:opaque) s13)))))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) s2)) + (s0 + (((s3) + (s4 + (s5 + (s6) + (s7 + (s4 s8 s6) + (s7 + (s4 (s5 (s6) s9) (s4 s10 s6)) + (s4 + (s5 + (s6) + (s7 + (s4 s8 s6) + (s0 + (((s11) (s4 s10 s6))) + (s7 + s11 + (s7 (s4 s12 (s4 s13 s6)) s11 (s14 #f)) + (s14 #f))) + (s14 #f))) + (s4 s13 s6)) + (s14 #f)) + (s14 #f))) + s1))) + (s7 + s3 + (s0 (((s15) s3)) (s0 () (s4 s16 s15))) + (s0 + (((s3) (s4 (s5 (s6) s9) s1))) + (s7 + s3 + (s0 () (s0 () (s4 s17 s2 (s14 (s18))))) + (s4 s19 (s14 #f) (s14 #:opaque) s1)))))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) s2)) + (s0 + (((s3) + (s4 + (s5 + (s6) + (s7 + (s4 s8 s6) + (s7 + (s4 (s5 (s6) s9) (s4 s10 s6)) + (s4 + (s5 + (s6) + (s7 + (s4 s8 s6) + (s0 + (((s11) (s4 s10 s6))) + (s7 + s11 + (s7 (s4 s12 (s4 s13 s6)) s11 (s14 #f)) + (s14 #f))) + (s14 #f))) + (s4 s13 s6)) + (s14 #f)) + (s14 #f))) + s1))) + (s7 + s3 + (s0 (((s15) s3)) (s0 () (s4 s16 s15))) + (s0 + (((s3) (s4 (s5 (s6) s9) s1))) + (s7 + s3 + (s0 () (s0 () (s4 s17 s2 (s14 (s18))))) + (s4 s19 (s14 #f) (s14 #:opaque) s1)))))))) + (5 + . + #s(stx-boundary + ((s0 + (((s1) s2)) + (s0 + (((s3) + (s4 + (s5 + (s6) + (s7 + (s4 s8 s6) + (s7 + (s4 (s5 (s6) s9) (s4 s10 s6)) + (s4 + (s5 + (s6) + (s7 + (s4 s8 s6) + (s0 + (((s11) (s4 s10 s6))) + (s7 + s11 + (s7 (s4 s12 (s4 s13 s6)) s11 (s14 #f)) + (s14 #f))) + (s14 #f))) + (s4 s13 s6)) + (s14 #f)) + (s14 #f))) + s1))) + (s7 + s3 + (s0 (((s15) s3)) (s0 () (s4 s16 s15))) + (s0 + (((s3) (s4 (s5 (s6) s9) s1))) + (s7 + s3 + (s0 () (s0 () (s4 s17 s2 (s14 (s18))))) + (s4 s19 (s14 #f) (s14 #:opaque) s1))))))))) + (7 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (((s3) s1)) + (s2 + (((s4) + (s5 + (s0 + (s6) + (s7 + (s5 s8 s6) + (s7 + (s5 (s0 (s6) s9) (s5 s10 s6)) + (s5 + (s0 + (s6) + (s7 + (s5 s8 s6) + (s2 + (((s11) (s5 s10 s6))) + (s7 + s11 + (s7 (s5 s12 (s5 s13 s6)) s11 (s14 #f)) + (s14 #f))) + (s14 #f))) + (s5 s13 s6)) + (s14 #f)) + (s14 #f))) + s3))) + (s7 + s4 + (s2 (((s15) s4)) (s2 () (s5 s16 s15))) + (s2 + (((s4) (s5 (s0 (s6) s9) s3))) + (s7 + s4 + (s2 () (s2 () (s5 s17 s1 (s14 (s18))))) + (s5 s19 (s14 #f) (s14 #:opaque) s3))))))))) + (2 + . + #s(stx-boundary + (s0 + (s1) + (s2 + (((s3) s1)) + (s2 + (((s4) + (s5 + (s0 + (s6) + (s7 + (s5 s8 s6) + (s7 + (s5 (s0 (s6) s9) (s5 s10 s6)) + (s5 + (s0 + (s6) + (s7 + (s5 s8 s6) + (s2 + (((s11) (s5 s10 s6))) + (s7 + s11 + (s7 (s5 s12 (s5 s13 s6)) s11 (s14 #f)) + (s14 #f))) + (s14 #f))) + (s5 s13 s6)) + (s14 #f)) + (s14 #f))) + s3))) + (s7 + s4 + (s2 (((s15) s4)) (s2 () (s5 s16 s15))) + (s2 + (((s4) (s5 (s0 (s6) s9) s3))) + (s7 + s4 + (s2 () (s2 () (s5 s17 s1 (s14 (s18))))) + (s5 s19 (s14 #f) (s14 #:opaque) s3))))))))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 5))) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 5))) + (21 . #s(stx-boundary (s0 5))) + (22 #s(stx-boundary 5) . #s(stx-boundary (s0 5))) + (9 . #s(stx-boundary 5)) + (2 . #s(stx-boundary 5)) + (127 . #s(stx-boundary 5)) + (14 + #s(stx-boundary + (s0 + (((s1) + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8)))))))) + () + 5))) + (0 + . + #s(stx-boundary + (s0 + (((s1) + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8)))))))) + () + 5))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) + (s2 + (s3) + (s4 + s5 + #t + s3 + () + s6 + #f + ((s7 s8) (s9 (s10 s3 s8))) + (s7 (s11 s3 (s12 (s8)))))))) + () + 5))) + (114 . #f) + (19 + (#s(stx-boundary + ((s0) + (s1 + (s2) + (s3 + s4 + #t + s2 + () + s5 + #f + ((s6 s7) (s8 (s9 s2 s7))) + (s6 (s10 s2 (s11 (s7))))))))) + () + . + #s(stx-boundary (5))) + (157 . #f) + (13 . #f) + (4 . #s(stx-boundary (5))) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary ((s0 5)))) + (142 . #s(stx-boundary (s0 () (s1 5)))) + (7 . #s(stx-boundary (s0 () (s1 5)))) + (2 . #s(stx-boundary (s0 () (s1 5)))) + (7 . #s(stx-boundary (s0 () (s0 () (s1 5))))) + (2 . #s(stx-boundary (s0 () (s0 () (s1 5))))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () (s2 5)))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () (s2 5)))))))) + ((let () (define (ok x) (second x)) (define (second y) 8) (ok 5)) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 s4)) (s2 (s5 s6) 8) (s3 5))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 s4)) (s2 (s5 s6) 8) (s3 5))))) + (138 . #f) + (0 + . + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5)))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5)))) + (21 + . + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5)))) + (22 + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5))) + . + #s(stx-boundary (s6 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5)))) + (9 + . + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5)))) + (0 + . + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 s3)) (s1 (s4 s5) 8) (s2 5)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 (s1 s2) (s3 s2)) (s0 (s3 s4) 8) (s1 5)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 s2)) (s0 (s3 s4) 8) (s1 5)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 s2)) (s0 (s3 s4) 8) (s1 5))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 s2)) (s0 (s3 s4) 8) (s1 5)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s0 (s1 s3) (s4 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s5 s1 (s2 (s3) (s4 s3))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 s2))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) 8))) + (0 . #s(stx-boundary (s0 (s1 s2) 8))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) 8))) + (21 . #s(stx-boundary (s0 (s1 s2) 8))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) 8))) + . + #s(stx-boundary (s0 (s1 s3) 8))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) 8))) + . + #s(stx-boundary (s4 s1 (s2 (s3) 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 5))) + (127 . #s(stx-boundary (s0 5))) + (14 + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 s3))) ((s4) (s2 (s5) 8))) (s1 5)))) + (0 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 s3))) ((s4) (s2 (s5) 8))) (s1 5)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 s3))) ((s4) (s2 (s5) 8))) (s1 5)))) + (113 . #f) + (16 + (#s(stx-boundary ((s0) (s1 (s2) (s3 s2)))) + #s(stx-boundary ((s3) (s1 (s4) 8)))) + . + #s(stx-boundary ((s0 5)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 s0)))) + (10 . #s(stx-boundary ((s0 s1)))) + (24 #s(stx-boundary ((s0 s1))) . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1))) + (127 . #s(stx-boundary (s0 s1))) + (12 . #s(stx-boundary ((s0 s1)))) + (4 . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (22 #s(stx-boundary (s0 s1 s2)) . #s(stx-boundary (s0 s1 s2))) + (9 . #s(stx-boundary (s0 s1 s2))) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary ((s0 s1 s2)))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) 8))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (8))) + (10 . #s(stx-boundary (8))) + (24 #s(stx-boundary (8)) . #s(stx-boundary (8))) + (3 . #f) + (126 . #s(stx-boundary 8)) + (127 . #s(stx-boundary 8)) + (12 . #s(stx-boundary (8))) + (4 . #s(stx-boundary (8))) + (3 . #f) + (0 . #s(stx-boundary 8)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 8))) + (6 . #s(stx-boundary (s0 . 8))) + (115 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (13 . #f) + (4 . #s(stx-boundary ((s0 5)))) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 5))) + (8 . #s(stx-boundary (s0 s1 5))) + (21 . #s(stx-boundary (s0 s1 5))) + (22 #s(stx-boundary (s0 s1 5)) . #s(stx-boundary (s0 s1 5))) + (9 . #s(stx-boundary (s0 s1 5))) + (0 . #s(stx-boundary (s0 s1 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 5))) + (109 . #f) + (4 . #s(stx-boundary (s0 5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary (s0 (s1 5)))) + (7 . #s(stx-boundary (s0 s1 (s2 5)))) + (2 . #s(stx-boundary (s0 s1 (s2 5)))) + (5 . #s(stx-boundary ((s0 s1 (s2 5))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 s5 s3))) ((s5) (s2 (s6) (s7 8)))) + (s4 s1 (s7 5))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 s5 s3))) ((s5) (s2 (s6) (s7 8)))) + (s4 s1 (s7 5))))) + (7 + . + #s(stx-boundary + (s0 + () + (s1 + (((s2) (s3 (s4) (s5 s6 s4))) ((s6) (s3 (s7) (s8 8)))) + (s5 s2 (s8 5)))))) + (2 + . + #s(stx-boundary + (s0 + () + (s1 + (((s2) (s3 (s4) (s5 s6 s4))) ((s6) (s3 (s7) (s8 8)))) + (s5 s2 (s8 5)))))) + (7 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 + (((s3) (s4 (s5) (s6 s7 s5))) ((s7) (s4 (s8) (s9 8)))) + (s6 s3 (s9 5))))))) + (2 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 + (((s3) (s4 (s5) (s6 s7 s5))) ((s7) (s4 (s8) (s9 8)))) + (s6 s3 (s9 5))))))))) + ((module m racket/base (require racket/list) foldl) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 s1 s2 (s3 s4) s5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2 (s3 s4) s5))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 s2) s3))) + (148 . #s(stx-boundary (s0 (s1 s2) s3))) + (126 . #s(stx-boundary (s0 (s1 s2) s3))) + (0 . #s(stx-boundary (s0 (s1 s2) s3))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s3))) + (21 . #s(stx-boundary (s0 (s1 s2) s3))) + (22 + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 s9) s10)) + . + #s(stx-boundary (s11 (s8 s9) s10))) + (9 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 s9) s10))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 s9) s10))) + (0 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 s9) s10))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 s9) s10))) + (21 + . + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)) (s8 s9) s10))) + (22 + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 s11)) + (s1 s2 s12))) + . + #s(stx-boundary (s13 (s3 s4 (s5 s6) (s7 s8) (s9 #f)) (s10 s11) s12))) + (9 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 s11)) + (s1 s2 s12)))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 s11)) + (s1 s2 s12)))) + (127 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 s11)) + (s1 s2 s12)))) + (0 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 s11)) + (s1 s2 s12)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 s11)) + (s1 s2 s12)))) + (102 . #f) + (148 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 s11)) + (s1 s2 s12)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (21 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (130 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (132 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (133 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (131 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (22 + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)))) + . + #s(stx-boundary (s8 s9 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (9 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (0 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (148 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (11 + #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f))) + #s(stx-boundary (s7 s8 (s9 s10))) + #s(stx-boundary (s7 s8 s11))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (158 . #f) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (102 . #f) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (148 . #s(stx-boundary (s0 s1))) + (6 . #s(stx-boundary (s0 s1))) + (119 . #f) + (7 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 #f))) + (100 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (148 . #s(stx-boundary (s0 #f))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 #f))) + (6 . #s(stx-boundary (s0 s1 #f))) + (109 . #f) + (4 . #s(stx-boundary (s0 #f))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (5 . #s(stx-boundary (s0 (s1 #f)))) + (7 . #s(stx-boundary (s0 s1 (s2 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 #f)))) + (135) + (13 . #f) + (3 . #f) + (7 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3)))) + (130 . #s(stx-boundary (s0 s1))) + (132 . #s(stx-boundary (s0 s1))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1))) + (21 . #s(stx-boundary (s0 s1))) + (22 #s(stx-boundary (s0 s1)) . #s(stx-boundary (s2 s1))) + (9 . #s(stx-boundary (s0 s1))) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (133 . #s(stx-boundary (s0 s1))) + (131 . #s(stx-boundary (s0 s1))) + (22 #s(stx-boundary (s0 (s1 s2))) . #s(stx-boundary (s3 s4 (s5 s2)))) + (9 . #s(stx-boundary (s0 (s1 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2)))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 s2)))) + (2 . #s(stx-boundary (s0 (s1 s2)))) + (148 . #s(stx-boundary (s0 (s1 s2)))) + (11 #s(stx-boundary (s0 s1)) #s(stx-boundary (s2 s3 s4))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (148 . #s(stx-boundary (s0 s1))) + (6 . #s(stx-boundary (s0 s1))) + (119 . #f) + (7 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (130 . #s(stx-boundary s0)) + (132 . #s(stx-boundary s0)) + (141 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (133 . #s(stx-boundary s0)) + (131 . #s(stx-boundary s0)) + (22 #s(stx-boundary (s0 (s1 s2))) . #s(stx-boundary (s3 s1 s2))) + (9 . #s(stx-boundary (s0 (s1 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2)))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 s2)))) + (2 . #s(stx-boundary (s0 (s1 s2)))) + (148 . #s(stx-boundary (s0 (s1 s2)))) + (11 #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1))) + (21 . #s(stx-boundary (s0 s1))) + (22 #s(stx-boundary (s0 s1 (s2 () s3) s4)) . #s(stx-boundary (s5 s3))) + (9 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (0 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (2 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (148 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 () s2) s3))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 () s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () s1))) + (110 . #f) + (17 #s(stx-boundary ()) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 () s1))) + (2 . #s(stx-boundary (s0 () s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 (s1 () s2) s3))) + (7 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (2 . #s(stx-boundary (s0 s1 (s2 () s3) s4))) + (135) + (13 . #f) + (3 . #f) + (7 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s0 (s5 s6) (s7 s8 (s3 #f)))) + (s5 s9) + (s7 s10 (s11 () s12) s13)))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s0 (s5 s6) (s7 s8 (s3 #f)))) + (s5 s9) + (s7 s10 (s11 () s12) s13)))) + (148 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s7 s11) + (s9 s12 (s13 () s14) s15))))) + (7 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s7 s11) + (s9 s12 (s13 () s14) s15))))) + (2 + . + #s(stx-boundary + (s0 + s1 + s2 + (s3 + (s0 s4 (s5 s6) (s3 (s7 s8) (s9 s10 (s5 #f)))) + (s7 s11) + (s9 s12 (s13 () s14) s15))))))) + ('quoted + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2)))) + (138 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (117 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 (s1 s2)))) + (2 . #s(stx-boundary (s0 (s1 s2)))))) + ((module m '#%kernel 5) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) 5))) + (101 . #f) + (157 . #f) + (148 . #s(stx-boundary 5)) + (126 . #s(stx-boundary 5)) + (127 . #s(stx-boundary 5)) + (142 . #s(stx-boundary (s0 5))) + (126 . #s(stx-boundary (s0 5))) + (127 . #s(stx-boundary (s0 5))) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 5))) + (102 . #f) + (148 . #s(stx-boundary (s0 5))) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (148 . #s(stx-boundary (s0 5))) + (135) + (13 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 5))) + (117 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (135) + (13 . #f) + (3 . #f) + (7 . #s(stx-boundary (s0 (s1 5)))) + (2 . #s(stx-boundary (s0 (s1 5)))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s2 5))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s2 5))))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s2 5))))))) + ((let-values (((x) __y) ((y z) __w)) __x) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 (((s2) s3) ((s4 s5) s6)) s7)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (((s2) s3) ((s4 s5) s6)) s7)))) + (138 . #f) + (0 . #s(stx-boundary (s0 (((s1) s2) ((s3 s4) s5)) s6))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) s2) ((s3 s4) s5)) s6))) + (112 . #f) + (16 + (#s(stx-boundary ((s0) s1)) #s(stx-boundary ((s2 s3) s4))) + . + #s(stx-boundary (s5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (13 . #f) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (5 . #s(stx-boundary ((s0 . s1)))) + (7 + . + #s(stx-boundary + (s0 (((s1) (s2 . s3)) ((s4 s5) (s2 . s6))) (s2 . s7)))) + (2 + . + #s(stx-boundary + (s0 (((s1) (s2 . s3)) ((s4 s5) (s2 . s6))) (s2 . s7)))) + (7 + . + #s(stx-boundary + (s0 (s1 (((s2) (s3 . s4)) ((s5 s6) (s3 . s7))) (s3 . s8))))) + (2 + . + #s(stx-boundary + (s0 (s1 (((s2) (s3 . s4)) ((s5 s6) (s3 . s7))) (s3 . s8))))))) + ((module m racket/base + (define-syntax (ok stx) (quote-syntax 8)) + (ok) + (list (ok) (ok))) + . + ((141 . #f) + (0 + . + #s(stx-boundary (s0 s1 s2 (s3 (s4 s5) (s6 8)) (s4) (s7 (s4) (s4))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary (s0 s1 s2 (s3 (s4 s5) (s6 8)) (s4) (s7 (s4) (s4))))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 8)) (s2) (s5 (s2) (s2))))) + (148 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 8)) (s2) (s5 (s2) (s2))))) + (126 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 8)) (s2) (s5 (s2) (s2))))) + (0 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 8)) (s2) (s5 (s2) (s2))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 8)) (s2) (s5 (s2) (s2))))) + (21 . #s(stx-boundary (s0 (s1 (s2 s3) (s4 8)) (s2) (s5 (s2) (s2))))) + (22 + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 8)) + (s9) + (s12 (s9) (s9)))) + . + #s(stx-boundary (s13 (s8 (s9 s10) (s11 8)) (s9) (s12 (s9) (s9))))) + (9 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 8)) + (s9) + (s12 (s9) (s9))))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 8)) + (s9) + (s12 (s9) (s9))))) + (0 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 8)) + (s9) + (s12 (s9) (s9))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 8)) + (s9) + (s12 (s9) (s9))))) + (21 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4) (s5 s6) (s7 #f)) + (s8 (s9 s10) (s11 8)) + (s9) + (s12 (s9) (s9))))) + (22 + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 8))) + (s1 s2 (s11)) + (s1 s2 (s14 (s11) (s11))))) + . + #s(stx-boundary + (s15 + (s3 s4 (s5 s6) (s7 s8) (s9 #f)) + (s10 (s11 s12) (s13 8)) + (s11) + (s14 (s11) (s11))))) + (9 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 8))) + (s1 s2 (s11)) + (s1 s2 (s14 (s11) (s11)))))) + (2 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 8))) + (s1 s2 (s11)) + (s1 s2 (s14 (s11) (s11)))))) + (127 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 8))) + (s1 s2 (s11)) + (s1 s2 (s14 (s11) (s11)))))) + (0 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 8))) + (s1 s2 (s11)) + (s1 s2 (s14 (s11) (s11)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 8))) + (s1 s2 (s11)) + (s1 s2 (s14 (s11) (s11)))))) + (102 . #f) + (148 + . + #s(stx-boundary + (s0 + (s1 s2 (s3 s4 (s5 s6) (s7 s8) (s9 #f))) + (s1 s2 (s10 (s11 s12) (s13 8))) + (s1 s2 (s11)) + (s1 s2 (s14 (s11) (s11)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (21 . #s(stx-boundary (s0 s1 (s2 s3 (s4 s5) (s6 s7) (s8 #f))))) + (130 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (132 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (141 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (133 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (131 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (22 + #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f)))) + . + #s(stx-boundary (s8 s9 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (9 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (0 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (148 . #s(stx-boundary (s0 (s1 s2 (s3 s4) (s5 s6) (s7 #f))))) + (11 + #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f))) + #s(stx-boundary (s7 s8 (s9 (s10 s11) (s12 8)))) + #s(stx-boundary (s7 s8 (s10))) + #s(stx-boundary (s7 s8 (s13 (s10) (s10))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (158 . #f) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5) (s6 #f)))) + (101 . #f) + (157 . #f) + (142 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (102 . #f) + (148 . #s(stx-boundary (s0 (s1 s2) (s3 #f)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (100 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (148 . #s(stx-boundary (s0 s1))) + (6 . #s(stx-boundary (s0 s1))) + (119 . #f) + (7 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 #f))) + (100 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (148 . #s(stx-boundary (s0 #f))) + (135) + (13 . #f) + (3 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 #f))) + (6 . #s(stx-boundary (s0 s1 #f))) + (109 . #f) + (4 . #s(stx-boundary (s0 #f))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (5 . #s(stx-boundary (s0 (s1 #f)))) + (7 . #s(stx-boundary (s0 s1 (s2 #f)))) + (2 . #s(stx-boundary (s0 s1 (s2 #f)))) + (135) + (13 . #f) + (3 . #f) + (7 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (2 . #s(stx-boundary (s0 (s1 s2) (s3 s4 (s5 #f))))) + (148 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 (s5 s6) (s7 s8 (s2 #f)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 s4) (s5 8))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3 s4) (s5 8))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3 s4) (s5 8))))) + (130 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (132 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (141 . #f) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s5 (s1 s3) (s4 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (133 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (131 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (22 + #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 8))))) + . + #s(stx-boundary (s6 s7 (s8 (s2 s4) (s5 8))))) + (9 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 8)))))) + (0 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 8)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 8)))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 8)))))) + (2 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 8)))))) + (148 . #s(stx-boundary (s0 (s1 (s2) (s3 (s4) (s5 8)))))) + (11 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + #s(stx-boundary (s5 s6 (s1))) + #s(stx-boundary (s5 s6 (s7 (s1) (s1))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (100 . #f) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (148 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (103 . #f) + (157 . #f) + (20 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 8)))) + (21 . #s(stx-boundary (s0 (s1) (s2 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 8))) + . + #s(stx-boundary (s3 (s1) (s2 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 8)))) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 8)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 8)))) + (10 . #s(stx-boundary ((s0 8)))) + (24 #s(stx-boundary ((s0 8))) . #s(stx-boundary ((s0 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 8))) + (127 . #s(stx-boundary (s0 8))) + (12 . #s(stx-boundary ((s0 8)))) + (4 . #s(stx-boundary ((s0 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 8))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)))) + ((let () + (define-syntax (ok stx) (quote-syntax 8)) + (define (ident x) x) + 9) + . + ((141 . #f) + (0 + . + #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 8)) (s6 (s7 s8) s8) 9)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 8)) (s6 (s7 s8) s8) 9)))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9))) + (21 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9))) + (22 + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9)) + . + #s(stx-boundary (s8 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9))) + (9 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9))) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s5 (s6 s7) s7) 9))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s4 (s5 s6) s6) 9))) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s4 (s5 s6) s6) 9))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s4 (s5 s6) s6) 9)) + . + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s4 (s5 s6) s6) 9))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s5 (s1 s3) (s4 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 8)))) + (21 . #s(stx-boundary (s0 (s1) (s2 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 8))) + . + #s(stx-boundary (s3 (s1) (s2 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 8)))) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 8)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 8)))) + (10 . #s(stx-boundary ((s0 8)))) + (24 #s(stx-boundary ((s0 8))) . #s(stx-boundary ((s0 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 8))) + (127 . #s(stx-boundary (s0 8))) + (12 . #s(stx-boundary ((s0 8)))) + (4 . #s(stx-boundary ((s0 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 8))) + (118 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) s2))) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) s3))) + . + #s(stx-boundary (s0 (s1 s3) s3))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + . + #s(stx-boundary (s4 s1 (s2 (s3) s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) s2)))) + (3 . #f) + (126 . #s(stx-boundary 9)) + (127 . #s(stx-boundary 9)) + (14 + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8)))) (((s5) (s6 (s7) s7))) 9))) + (0 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8)))) (((s5) (s6 (s7) s7))) 9))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8)))) (((s5) (s6 (s7) s7))) 9))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + (#s(stx-boundary ((s4) (s5 (s6) s6)))) + . + #s(stx-boundary (9))) + (157 . #f) + (13 . #f) + (113 . #f) + (16 (#s(stx-boundary ((s0) (s1 (s2) s2)))) . #s(stx-boundary (9))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s1))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s1))) + (2 . #s(stx-boundary (s0 (s1) s1))) + (13 . #f) + (4 . #s(stx-boundary (9))) + (3 . #f) + (0 . #s(stx-boundary 9)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 9))) + (6 . #s(stx-boundary (s0 . 9))) + (115 . #f) + (7 . #s(stx-boundary (s0 9))) + (2 . #s(stx-boundary (s0 9))) + (5 . #s(stx-boundary ((s0 9)))) + (142 . #s(stx-boundary (s0 (((s1) (s2 (s3) s3))) (s4 9)))) + (7 . #s(stx-boundary (s0 (((s1) (s2 (s3) s3))) (s4 9)))) + (2 . #s(stx-boundary (s0 (((s1) (s2 (s3) s3))) (s4 9)))) + (7 . #s(stx-boundary (s0 () (s0 (((s1) (s2 (s3) s3))) (s4 9))))) + (2 . #s(stx-boundary (s0 () (s0 (((s1) (s2 (s3) s3))) (s4 9))))) + (7 . #s(stx-boundary (s0 (s1 () (s1 (((s2) (s3 (s4) s4))) (s5 9)))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 (((s2) (s3 (s4) s4))) (s5 9)))))))) + ((set! __x 99) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 s2 99)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2 99)))) + (138 . #f) + (0 . #s(stx-boundary (s0 s1 99))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 99))) + (123 . #f) + (1 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 99)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 99))) + (6 . #s(stx-boundary (s0 . 99))) + (115 . #f) + (7 . #s(stx-boundary (s0 99))) + (2 . #s(stx-boundary (s0 99))) + (7 . #s(stx-boundary (s0 s1 (s2 99)))) + (2 . #s(stx-boundary (s0 s1 (s2 99)))) + (7 . #s(stx-boundary (s0 (s1 s2 (s3 99))))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 99))))))) + ((let () + (define-syntax (lift stx) (syntax-local-lift-expression #'(+ 1 2))) + (lift)) + . + ((141 . #f) + (0 + . + #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 (s6 (s7 1 2)))) (s3))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 (s6 (s7 1 2)))) (s3))))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2)))) + (21 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2)))) + (22 + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2))) + . + #s(stx-boundary (s7 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2)))) + (9 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2)))) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 (s6 1 2)))) (s2)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 1 2)))) (s1)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 1 2)))) (s1)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 1 2)))) (s1))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 1 2)))) (s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 1 2)))))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 1 2)))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 1 2)))))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 1 2)))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 1 2)))))) + . + #s(stx-boundary (s7 (s1 s3) (s4 (s5 (s6 1 2)))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 1 2))))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 1 2))))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 1 2))))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 (s4 (s5 1 2))))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 1 2)))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 1 2)))))) + (21 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 1 2)))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3 (s4 1 2))))) + . + #s(stx-boundary (s5 (s1) (s2 (s3 (s4 1 2)))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 1 2)))))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 1 2)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 1 2)))))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 (s2 (s3 1 2)))))) + (10 . #s(stx-boundary ((s0 (s1 (s2 1 2)))))) + (24 + #s(stx-boundary ((s0 (s1 (s2 1 2))))) + . + #s(stx-boundary ((s0 (s1 (s2 1 2)))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 (s2 1 2))))) + (127 . #s(stx-boundary (s0 (s1 (s2 1 2))))) + (12 . #s(stx-boundary ((s0 (s1 (s2 1 2)))))) + (4 . #s(stx-boundary ((s0 (s1 (s2 1 2)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 1 2))))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (8 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3 1 2)))) + . + #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 (s2 1 2))))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 1 2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 1 2)))) + (21 . #s(stx-boundary (s0 (s1 1 2)))) + (153 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (154 . #f) + (22 #s(stx-boundary (s0 (s1 1 2))) . #s(stx-boundary (s2 (s1 1 2)))) + (9 . #s(stx-boundary (s0 (s1 1 2)))) + (0 . #s(stx-boundary (s0 (s1 1 2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 1 2)))) + (118 . #f) + (7 . #s(stx-boundary (s0 (s1 1 2)))) + (2 . #s(stx-boundary (s0 (s1 1 2)))) + (5 . #s(stx-boundary (s0 (s1 (s2 1 2))))) + (7 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3 1 2))))) + (5 . #s(stx-boundary ((s0 s1 (s2 (s3 1 2)))))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 (s5 1 2)))))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 (s5 1 2)))))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0))) + (0 . #s(stx-boundary (s0))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0))) + (21 . #s(stx-boundary (s0))) + (129 (#s(stx-boundary s0)) . #s(stx-boundary (s1 1 2))) + (22 #s(stx-boundary s0) . #s(stx-boundary (s1))) + (9 . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (14 #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 (s5 (s6 1 2)))))) () s7))) + (0 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 (s5 (s6 1 2)))))) () s7))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 (s5 (s6 1 2)))))) () s7))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 (s4 (s5 1 2))))))) + () + . + #s(stx-boundary (s6))) + (157 . #f) + (13 . #f) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (142 . #s(stx-boundary (s0 () s1))) + (7 . #s(stx-boundary (s0 () s1))) + (2 . #s(stx-boundary (s0 () s1))) + (7 . #s(stx-boundary (s0 () (s0 () s1)))) + (2 . #s(stx-boundary (s0 () (s0 () s1)))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (128 + . + #s(stx-boundary (s0 (s1 (s2) (s3 1 2)) (s4 (s5 () (s5 () s2)))))) + (0 . #s(stx-boundary (s0 (s1 (s2) (s3 1 2)) (s4 (s5 () (s5 () s2)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2) (s3 1 2)) (s4 (s5 () (s5 () s2)))))) + (107 . #f) + (4 . #s(stx-boundary ((s0 (s1) (s2 1 2)) (s3 (s4 () (s4 () s1)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 1 2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 1 2)))) + (104 . #f) + (0 . #s(stx-boundary (s0 1 2))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 1 2))) + (8 . #s(stx-boundary (s0 s1 1 2))) + (21 . #s(stx-boundary (s0 s1 1 2))) + (22 #s(stx-boundary (s0 s1 1 2)) . #s(stx-boundary (s0 s1 1 2))) + (9 . #s(stx-boundary (s0 s1 1 2))) + (0 . #s(stx-boundary (s0 s1 1 2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 1 2))) + (109 . #f) + (4 . #s(stx-boundary (s0 1 2))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 1)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 1))) + (6 . #s(stx-boundary (s0 . 1))) + (115 . #f) + (7 . #s(stx-boundary (s0 1))) + (2 . #s(stx-boundary (s0 1))) + (3 . #f) + (0 . #s(stx-boundary 2)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 2))) + (6 . #s(stx-boundary (s0 . 2))) + (115 . #f) + (7 . #s(stx-boundary (s0 2))) + (2 . #s(stx-boundary (s0 2))) + (5 . #s(stx-boundary (s0 (s1 1) (s1 2)))) + (7 . #s(stx-boundary (s0 s1 (s2 1) (s2 2)))) + (2 . #s(stx-boundary (s0 s1 (s2 1) (s2 2)))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 1) (s4 2))))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 1) (s4 2))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s0 () s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s0 () s1)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 () s1)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 () s1)))) + (24 #s(stx-boundary ((s0 () s1))) . #s(stx-boundary ((s0 () s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 () s1))) + (127 . #s(stx-boundary (s0 () s1))) + (12 . #s(stx-boundary ((s0 () s1)))) + (4 . #s(stx-boundary ((s0 () s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 () s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () s1))) + (112 . #f) + (16 () . #s(stx-boundary (s0))) + (13 . #f) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 () s1))) + (2 . #s(stx-boundary (s0 () s1))) + (5 . #s(stx-boundary ((s0 () s1)))) + (7 . #s(stx-boundary (s0 () (s0 () s1)))) + (2 . #s(stx-boundary (s0 () (s0 () s1)))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (5 + . + #s(stx-boundary + ((s0 (s1) (s2 s3 (s4 1) (s4 2))) (s5 (s6 () (s6 () s1)))))) + (7 + . + #s(stx-boundary + (s0 (s1 (s2) (s3 s4 (s5 1) (s5 2))) (s6 (s7 () (s7 () s2)))))) + (2 + . + #s(stx-boundary + (s0 (s1 (s2) (s3 s4 (s5 1) (s5 2))) (s6 (s7 () (s7 () s2)))))))) + ((let () (define (ok x) '8) (ok 5)) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 8)) (s3 5))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 8)) (s3 5))))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (21 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (22 + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5))) + . + #s(stx-boundary (s5 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (9 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 8)) (s2 5)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s1 5)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s0 (s1 s3) (s4 8)))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s5 s1 (s2 (s3) (s4 8))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + (3 . #f) + (126 . #s(stx-boundary (s0 5))) + (127 . #s(stx-boundary (s0 5))) + (14 #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) (s1 5)))) + (0 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) (s1 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) (s1 5)))) + (113 . #f) + (16 + (#s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + . + #s(stx-boundary ((s0 5)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 8)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 8)))) + (10 . #s(stx-boundary ((s0 8)))) + (24 #s(stx-boundary ((s0 8))) . #s(stx-boundary ((s0 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 8))) + (127 . #s(stx-boundary (s0 8))) + (12 . #s(stx-boundary ((s0 8)))) + (4 . #s(stx-boundary ((s0 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 8))) + (117 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (13 . #f) + (4 . #s(stx-boundary ((s0 5)))) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 5))) + (8 . #s(stx-boundary (s0 s1 5))) + (21 . #s(stx-boundary (s0 s1 5))) + (22 #s(stx-boundary (s0 s1 5)) . #s(stx-boundary (s0 s1 5))) + (9 . #s(stx-boundary (s0 s1 5))) + (0 . #s(stx-boundary (s0 s1 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 5))) + (109 . #f) + (4 . #s(stx-boundary (s0 5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary (s0 (s1 5)))) + (7 . #s(stx-boundary (s0 s1 (s2 5)))) + (2 . #s(stx-boundary (s0 s1 (s2 5)))) + (5 . #s(stx-boundary ((s0 s1 (s2 5))))) + (7 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) (s5 s1 (s4 5))))) + (2 . #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 8)))) (s5 s1 (s4 5))))) + (7 + . + #s(stx-boundary + (s0 () (s0 (((s1) (s2 (s3) (s4 8)))) (s5 s1 (s4 5)))))) + (2 + . + #s(stx-boundary + (s0 () (s0 (((s1) (s2 (s3) (s4 8)))) (s5 s1 (s4 5)))))) + (7 + . + #s(stx-boundary + (s0 (s1 () (s1 (((s2) (s3 (s4) (s5 8)))) (s6 s2 (s5 5))))))) + (2 + . + #s(stx-boundary + (s0 (s1 () (s1 (((s2) (s3 (s4) (s5 8)))) (s6 s2 (s5 5))))))))) + ((begin0 '3 '5) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 3) (s2 5))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 3) (s2 5))))) + (138 . #f) + (0 . #s(stx-boundary (s0 (s1 3) (s1 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 3) (s1 5)))) + (108 . #f) + (3 . #f) + (0 . #s(stx-boundary (s0 3))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 3))) + (117 . #f) + (7 . #s(stx-boundary (s0 3))) + (2 . #s(stx-boundary (s0 3))) + (3 . #f) + (4 . #s(stx-boundary ((s0 5)))) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 5))) + (117 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary ((s0 5)))) + (7 . #s(stx-boundary (s0 (s1 3) (s1 5)))) + (2 . #s(stx-boundary (s0 (s1 3) (s1 5)))) + (7 . #s(stx-boundary (s0 (s1 (s2 3) (s2 5))))) + (2 . #s(stx-boundary (s0 (s1 (s2 3) (s2 5))))))) + ((case-lambda ((x) x) ((x y) (+ x y))) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 ((s2) s2) ((s2 s3) (s4 s2 s3)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 ((s2) s2) ((s2 s3) (s4 s2 s3)))))) + (138 . #f) + (0 . #s(stx-boundary (s0 ((s1) s1) ((s1 s2) (s3 s1 s2))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 ((s1) s1) ((s1 s2) (s3 s1 s2))))) + (111 . #f) + (3 . #f) + (18 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (3 . #f) + (18 #s(stx-boundary (s0 s1)) . #s(stx-boundary ((s2 s0 s1)))) + (10 . #s(stx-boundary ((s0 s1 s2)))) + (24 #s(stx-boundary ((s0 s1 s2))) . #s(stx-boundary ((s0 s1 s2)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1 s2))) + (127 . #s(stx-boundary (s0 s1 s2))) + (12 . #s(stx-boundary ((s0 s1 s2)))) + (4 . #s(stx-boundary ((s0 s1 s2)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2 s3))) + (8 . #s(stx-boundary (s0 s1 s2 s3))) + (21 . #s(stx-boundary (s0 s1 s2 s3))) + (22 #s(stx-boundary (s0 s1 s2 s3)) . #s(stx-boundary (s0 s1 s2 s3))) + (9 . #s(stx-boundary (s0 s1 s2 s3))) + (0 . #s(stx-boundary (s0 s1 s2 s3))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2 s3))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1 s2))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1 s2))) + (7 . #s(stx-boundary (s0 s1 s2 s3))) + (2 . #s(stx-boundary (s0 s1 s2 s3))) + (5 . #s(stx-boundary ((s0 s1 s2 s3)))) + (7 . #s(stx-boundary (s0 ((s1) s1) ((s1 s2) (s3 s4 s1 s2))))) + (2 . #s(stx-boundary (s0 ((s1) s1) ((s1 s2) (s3 s4 s1 s2))))) + (7 . #s(stx-boundary (s0 (s1 ((s2) s2) ((s2 s3) (s4 s5 s2 s3)))))) + (2 . #s(stx-boundary (s0 (s1 ((s2) s2) ((s2 s3) (s4 s5 s2 s3)))))))) + ((let () + (define-syntax (ok stx) + (define-values + (exp opaque) + (syntax-local-expand-expression (cadr (syntax-e stx)))) + opaque) + (#%expression (ok 9))) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 (s3 s4) (s5 (s6 s7) (s8 (s9 (s10 s4)))) s7) + (s0 (s3 9)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 (s3 s4) (s5 (s6 s7) (s8 (s9 (s10 s4)))) s7) + (s0 (s3 9)))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9))))) + (21 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9))))) + (22 + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9)))) + . + #s(stx-boundary + (s11 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9))))) + (9 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9))))) + (0 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6) + (s10 (s2 9))))) + (112 . #f) + (16 + () + . + #s(stx-boundary + ((s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5) (s9 (s1 9))))) + (13 . #f) + (10 + . + #s(stx-boundary + ((s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5) (s9 (s1 9))))) + (24 + #s(stx-boundary + ((s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5) (s9 (s1 9)))) + . + #s(stx-boundary + ((s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5) (s9 (s1 9))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6))) + . + #s(stx-boundary (s10 (s1 s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6))) + (9 + . + #s(stx-boundary + (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6)))) + (2 + . + #s(stx-boundary + (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6)))) + (127 + . + #s(stx-boundary + (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6)))) + (103 . #f) + (148 + . + #s(stx-boundary ((s0) (s1 (s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5)))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4))) + (21 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4)) + . + #s(stx-boundary (s8 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 (s6 (s7 s1)))) s4))) + (110 . #f) + (17 + #s(stx-boundary (s0)) + . + #s(stx-boundary ((s1 (s2 s3) (s4 (s5 (s6 s0)))) s3))) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 s6)))) s2))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 s6)))) s2)) + . + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 s6)))) s2))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 s6)))))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 s6)))))) + (104 . #f) + (148 . #s(stx-boundary ((s0 s1) (s2 (s3 (s4 s5)))))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (14 #s(stx-boundary (s0 (((s1 s2) (s3 (s4 (s5 s6))))) s2))) + (0 . #s(stx-boundary (s0 (((s1 s2) (s3 (s4 (s5 s6))))) s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1 s2) (s3 (s4 (s5 s6))))) s2))) + (113 . #f) + (16 + (#s(stx-boundary ((s0 s1) (s2 (s3 (s4 s5)))))) + . + #s(stx-boundary (s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 (s3 s4))))) + (8 . #s(stx-boundary (s0 s1 (s2 (s3 s4))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3 s4))))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3 s4)))) + . + #s(stx-boundary (s0 s1 (s2 (s3 s4))))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3 s4))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 s4))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 (s3 s4))))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 (s2 s3))))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 s3)))) + (8 . #s(stx-boundary (s0 s1 (s2 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3)))) + (22 + #s(stx-boundary (s0 s1 (s2 s3))) + . + #s(stx-boundary (s0 s1 (s2 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 s3)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 s2)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (22 #s(stx-boundary (s0 s1 s2)) . #s(stx-boundary (s0 s1 s2))) + (9 . #s(stx-boundary (s0 s1 s2))) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary (s0 (s1 s2 s3)))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 s3)))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 s3)))) + (5 . #s(stx-boundary (s0 (s1 s2 (s1 s3 s4))))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 (s0 s3 s4))))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 (s0 s3 s4))))) + (13 . #f) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (((s1 s2) (s3 s4 (s3 s5 (s3 s6 s7))))) s2))) + (2 . #s(stx-boundary (s0 (((s1 s2) (s3 s4 (s3 s5 (s3 s6 s7))))) s2))) + (7 + . + #s(stx-boundary + (s0 (s1) (s2 (((s3 s4) (s5 s6 (s5 s7 (s5 s8 s1))))) s4)))) + (2 + . + #s(stx-boundary + (s0 (s1) (s2 (((s3 s4) (s5 s6 (s5 s7 (s5 s8 s1))))) s4)))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 9)))) + (127 . #s(stx-boundary (s0 (s1 9)))) + (14 + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6))) + () + (s10 (s1 9))))) + (0 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6))) + () + (s10 (s1 9))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 (s5 s6) (s7 (s8 (s9 s3)))) s6))) + () + (s10 (s1 9))))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 (s4 s5) (s6 (s7 (s8 s2)))) s5)))) + () + . + #s(stx-boundary ((s9 (s0 9))))) + (157 . #f) + (13 . #f) + (4 . #s(stx-boundary ((s0 (s1 9))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 9)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 9)))) + (138 . #f) + (0 . #s(stx-boundary (s0 9))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 9))) + (21 . #s(stx-boundary (s0 9))) + (130 . #s(stx-boundary 9)) + (132 . #s(stx-boundary 9)) + (141 . #f) + (0 . #s(stx-boundary 9)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 9))) + (6 . #s(stx-boundary (s0 . 9))) + (115 . #f) + (7 . #s(stx-boundary (s0 9))) + (2 . #s(stx-boundary (s0 9))) + (133 . #s(stx-boundary (s0 9))) + (146 . #s(stx-boundary #:opaque)) + (131 . #s(stx-boundary (s0 9))) + (22 #s(stx-boundary #:opaque) . #s(stx-boundary (s0 9))) + (9 . #s(stx-boundary #:opaque)) + (0 . #s(stx-boundary #:opaque)) + (146 . #s(stx-boundary (s0 9))) + (142 . #s(stx-boundary (s0 9))) + (7 . #s(stx-boundary (s0 9))) + (2 . #s(stx-boundary (s0 9))) + (5 . #s(stx-boundary ((s0 9)))) + (142 . #s(stx-boundary (s0 () (s1 9)))) + (7 . #s(stx-boundary (s0 () (s1 9)))) + (2 . #s(stx-boundary (s0 () (s1 9)))) + (7 . #s(stx-boundary (s0 () (s0 () (s1 9))))) + (2 . #s(stx-boundary (s0 () (s0 () (s1 9))))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () (s2 9)))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () (s2 9)))))))) + ((let () + (define (first z) z) + (define (ok x) (second x)) + (printf "extra expression\n") + (define (second y) 8) + (ok (first 5))) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 (s3 s4) s4) + (s2 (s5 s6) (s7 s6)) + (s8 #:opaque) + (s2 (s7 s9) 8) + (s5 (s3 5)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 (s3 s4) s4) + (s2 (s5 s6) (s7 s6)) + (s8 #:opaque) + (s2 (s7 s9) 8) + (s5 (s3 5)))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5))))) + (21 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5))))) + (22 + #s(stx-boundary + (s0 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5)))) + . + #s(stx-boundary + (s9 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5))))) + (9 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5))))) + (0 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s7 #:opaque) + (s1 (s6 s8) 8) + (s4 (s2 5))))) + (112 . #f) + (16 + () + . + #s(stx-boundary + ((s0 (s1 s2) s2) + (s0 (s3 s4) (s5 s4)) + (s6 #:opaque) + (s0 (s5 s7) 8) + (s3 (s1 5))))) + (13 . #f) + (10 + . + #s(stx-boundary + ((s0 (s1 s2) s2) + (s0 (s3 s4) (s5 s4)) + (s6 #:opaque) + (s0 (s5 s7) 8) + (s3 (s1 5))))) + (24 + #s(stx-boundary + ((s0 (s1 s2) s2) + (s0 (s3 s4) (s5 s4)) + (s6 #:opaque) + (s0 (s5 s7) 8) + (s3 (s1 5)))) + . + #s(stx-boundary + ((s0 (s1 s2) s2) + (s0 (s3 s4) (s5 s4)) + (s6 #:opaque) + (s0 (s5 s7) 8) + (s3 (s1 5))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) s2))) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) s3))) + . + #s(stx-boundary (s0 (s1 s3) s3))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + . + #s(stx-boundary (s4 s1 (s2 (s3) s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) s2)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s0 (s1 s3) (s4 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s5 s1 (s2 (s3) (s4 s3))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 s2))))) + (3 . #f) + (126 . #s(stx-boundary (s0 #:opaque))) + (127 . #s(stx-boundary (s0 #:opaque))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) 8))) + (0 . #s(stx-boundary (s0 (s1 s2) 8))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) 8))) + (21 . #s(stx-boundary (s0 (s1 s2) 8))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) 8))) + . + #s(stx-boundary (s0 (s1 s3) 8))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) 8))) + . + #s(stx-boundary (s4 s1 (s2 (s3) 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 5)))) + (127 . #s(stx-boundary (s0 (s1 5)))) + (14 + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) + ((s4) (s2 (s5) (s6 s5))) + (() (s7 (s8 #:opaque) (s9))) + ((s6) (s2 (s10) 8))) + (s4 (s1 5))))) + (0 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) + ((s4) (s2 (s5) (s6 s5))) + (() (s7 (s8 #:opaque) (s9))) + ((s6) (s2 (s10) 8))) + (s4 (s1 5))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) + ((s4) (s2 (s5) (s6 s5))) + (() (s7 (s8 #:opaque) (s9))) + ((s6) (s2 (s10) 8))) + (s4 (s1 5))))) + (113 . #f) + (16 + (#s(stx-boundary ((s0) (s1 (s2) s2))) + #s(stx-boundary ((s3) (s1 (s4) (s5 s4)))) + #s(stx-boundary (() (s6 (s7 #:opaque) (s8)))) + #s(stx-boundary ((s5) (s1 (s9) 8)))) + . + #s(stx-boundary ((s3 (s0 5))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s1))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s1))) + (2 . #s(stx-boundary (s0 (s1) s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 s0)))) + (10 . #s(stx-boundary ((s0 s1)))) + (24 #s(stx-boundary ((s0 s1))) . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1))) + (127 . #s(stx-boundary (s0 s1))) + (12 . #s(stx-boundary ((s0 s1)))) + (4 . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (22 #s(stx-boundary (s0 s1 s2)) . #s(stx-boundary (s0 s1 s2))) + (9 . #s(stx-boundary (s0 s1 s2))) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary ((s0 s1 s2)))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 #:opaque) (s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 #:opaque) (s2)))) + (107 . #f) + (4 . #s(stx-boundary ((s0 #:opaque) (s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 #:opaque))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 #:opaque))) + (8 . #s(stx-boundary (s0 s1 #:opaque))) + (21 . #s(stx-boundary (s0 s1 #:opaque))) + (22 + #s(stx-boundary (s0 s1 #:opaque)) + . + #s(stx-boundary (s0 s1 #:opaque))) + (9 . #s(stx-boundary (s0 s1 #:opaque))) + (0 . #s(stx-boundary (s0 s1 #:opaque))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 #:opaque))) + (109 . #f) + (4 . #s(stx-boundary (s0 #:opaque))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary #:opaque)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #:opaque))) + (6 . #s(stx-boundary (s0 . #:opaque))) + (115 . #f) + (7 . #s(stx-boundary (s0 #:opaque))) + (2 . #s(stx-boundary (s0 #:opaque))) + (5 . #s(stx-boundary (s0 (s1 #:opaque)))) + (7 . #s(stx-boundary (s0 s1 (s2 #:opaque)))) + (2 . #s(stx-boundary (s0 s1 (s2 #:opaque)))) + (3 . #f) + (0 . #s(stx-boundary (s0))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1))) + (6 . #s(stx-boundary (s0 s1))) + (109 . #f) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (5 . #s(stx-boundary ((s0 s1 (s2 #:opaque)) (s0 s3)))) + (7 . #s(stx-boundary (s0 (s1 s2 (s3 #:opaque)) (s1 s4)))) + (2 . #s(stx-boundary (s0 (s1 s2 (s3 #:opaque)) (s1 s4)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) 8))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (8))) + (10 . #s(stx-boundary (8))) + (24 #s(stx-boundary (8)) . #s(stx-boundary (8))) + (3 . #f) + (126 . #s(stx-boundary 8)) + (127 . #s(stx-boundary 8)) + (12 . #s(stx-boundary (8))) + (4 . #s(stx-boundary (8))) + (3 . #f) + (0 . #s(stx-boundary 8)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 8))) + (6 . #s(stx-boundary (s0 . 8))) + (115 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (13 . #f) + (4 . #s(stx-boundary ((s0 (s1 5))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 5)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 5)))) + (8 . #s(stx-boundary (s0 s1 (s2 5)))) + (21 . #s(stx-boundary (s0 s1 (s2 5)))) + (22 #s(stx-boundary (s0 s1 (s2 5))) . #s(stx-boundary (s0 s1 (s2 5)))) + (9 . #s(stx-boundary (s0 s1 (s2 5)))) + (0 . #s(stx-boundary (s0 s1 (s2 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 5)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 5)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 5))) + (8 . #s(stx-boundary (s0 s1 5))) + (21 . #s(stx-boundary (s0 s1 5))) + (22 #s(stx-boundary (s0 s1 5)) . #s(stx-boundary (s0 s1 5))) + (9 . #s(stx-boundary (s0 s1 5))) + (0 . #s(stx-boundary (s0 s1 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 5))) + (109 . #f) + (4 . #s(stx-boundary (s0 5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary (s0 (s1 5)))) + (7 . #s(stx-boundary (s0 s1 (s2 5)))) + (2 . #s(stx-boundary (s0 s1 (s2 5)))) + (5 . #s(stx-boundary (s0 (s1 s2 (s3 5))))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (5 . #s(stx-boundary ((s0 s1 (s0 s2 (s3 5)))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3))) + (s4 + (((s5) (s2 (s6) (s7 s8 s6))) + (() (s9 (s7 s10 (s11 #:opaque)) (s7 s12))) + ((s8) (s2 (s13) (s11 8)))) + (s7 s5 (s7 s1 (s11 5))))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3))) + (s4 + (((s5) (s2 (s6) (s7 s8 s6))) + (() (s9 (s7 s10 (s11 #:opaque)) (s7 s12))) + ((s8) (s2 (s13) (s11 8)))) + (s7 s5 (s7 s1 (s11 5))))))) + (7 + . + #s(stx-boundary + (s0 + () + (s0 + (((s1) (s2 (s3) s3))) + (s4 + (((s5) (s2 (s6) (s7 s8 s6))) + (() (s9 (s7 s10 (s11 #:opaque)) (s7 s12))) + ((s8) (s2 (s13) (s11 8)))) + (s7 s5 (s7 s1 (s11 5)))))))) + (2 + . + #s(stx-boundary + (s0 + () + (s0 + (((s1) (s2 (s3) s3))) + (s4 + (((s5) (s2 (s6) (s7 s8 s6))) + (() (s9 (s7 s10 (s11 #:opaque)) (s7 s12))) + ((s8) (s2 (s13) (s11 8)))) + (s7 s5 (s7 s1 (s11 5)))))))) + (7 + . + #s(stx-boundary + (s0 + (s1 + () + (s1 + (((s2) (s3 (s4) s4))) + (s5 + (((s6) (s3 (s7) (s8 s9 s7))) + (() (s10 (s8 s11 (s12 #:opaque)) (s8 s13))) + ((s9) (s3 (s14) (s12 8)))) + (s8 s6 (s8 s2 (s12 5))))))))) + (2 + . + #s(stx-boundary + (s0 + (s1 + () + (s1 + (((s2) (s3 (s4) s4))) + (s5 + (((s6) (s3 (s7) (s8 s9 s7))) + (() (s10 (s8 s11 (s12 #:opaque)) (s8 s13))) + ((s9) (s3 (s14) (s12 8)))) + (s8 s6 (s8 s2 (s12 5))))))))))) + ((#%variable-reference __z) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2)))) + (138 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (149 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 (s1 s2)))) + (2 . #s(stx-boundary (s0 (s1 s2)))))) + ((let () + (define-syntax (lift stx) + (syntax-local-lift-require 'racket/list #'foldl)) + (lift)) + . + ((141 . #f) + (0 + . + #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 (s6 s7) (s8 s9))) (s3))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary (s0 (s1 () (s2 (s3 s4) (s5 (s6 s7) (s8 s9))) (s3))))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (21 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (22 + #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2))) + . + #s(stx-boundary (s9 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (9 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (0 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s1 (s2 s3) (s4 (s5 s6) (s7 s8))) (s2)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 (s1 s2) (s3 (s4 s5) (s6 s7))) (s1)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 (s4 s5) (s6 s7))) (s1)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 s5) (s6 s7))) (s1))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 s5) (s6 s7))) (s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 s5) (s6 s7))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8))))) + . + #s(stx-boundary (s9 (s1 s3) (s4 (s5 s6) (s7 s8))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 s6) (s7 s8)))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 (s4 s5) (s6 s7)))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (21 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6)))) + . + #s(stx-boundary (s7 (s1) (s2 (s3 s4) (s5 s6))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3 s4) (s5 s6))))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 (s2 s3) (s4 s5))))) + (10 . #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 s4)))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (127 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (12 . #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (4 . #s(stx-boundary ((s0 (s1 s2) (s3 s4))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (8 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (22 + #s(stx-boundary (s0 s1 (s2 s3) (s4 s5))) + . + #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (9 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (0 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (117 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1))) + (21 . #s(stx-boundary (s0 s1))) + (153 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (154 . #f) + (22 #s(stx-boundary (s0 s1)) . #s(stx-boundary (s2 s1))) + (9 . #s(stx-boundary (s0 s1))) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (118 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (5 . #s(stx-boundary (s0 (s1 s2) (s3 s4)))) + (7 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3) (s4 s5)))) + (5 . #s(stx-boundary ((s0 s1 (s2 s3) (s4 s5))))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s5) (s6 s7))))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s5) (s6 s7))))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0))) + (0 . #s(stx-boundary (s0))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0))) + (21 . #s(stx-boundary (s0))) + (150 + #s(stx-boundary (s0 s1)) + #s(stx-boundary s2) + . + #s(stx-boundary s2)) + (22 #s(stx-boundary s0) . #s(stx-boundary (s1))) + (9 . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (14 + #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 (s5 s6) (s7 s8))))) () s8))) + (0 + . + #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 (s5 s6) (s7 s8))))) () s8))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary (s0 (((s1) (s2 (s3) (s4 (s5 s6) (s7 s8))))) () s8))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 (s4 s5) (s6 s7)))))) + () + . + #s(stx-boundary (s7))) + (157 . #f) + (13 . #f) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (142 . #s(stx-boundary (s0 () s1))) + (7 . #s(stx-boundary (s0 () s1))) + (2 . #s(stx-boundary (s0 () s1))) + (7 . #s(stx-boundary (s0 () (s0 () s1)))) + (2 . #s(stx-boundary (s0 () (s0 () s1)))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (128 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 () (s4 () s5)))))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 () (s4 () s5)))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 () (s4 () s5)))))) + (107 . #f) + (4 . #s(stx-boundary ((s0 s1) (s2 (s3 () (s3 () s4)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (119 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (138 . #f) + (0 . #s(stx-boundary (s0 () (s0 () s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () (s0 () s1)))) + (112 . #f) + (16 () . #s(stx-boundary ((s0 () s1)))) + (13 . #f) + (10 . #s(stx-boundary ((s0 () s1)))) + (24 #s(stx-boundary ((s0 () s1))) . #s(stx-boundary ((s0 () s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 () s1))) + (127 . #s(stx-boundary (s0 () s1))) + (12 . #s(stx-boundary ((s0 () s1)))) + (4 . #s(stx-boundary ((s0 () s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 () s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 () s1))) + (112 . #f) + (16 () . #s(stx-boundary (s0))) + (13 . #f) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 () s1))) + (2 . #s(stx-boundary (s0 () s1))) + (5 . #s(stx-boundary ((s0 () s1)))) + (7 . #s(stx-boundary (s0 () (s0 () s1)))) + (2 . #s(stx-boundary (s0 () (s0 () s1)))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () s2))))) + (5 . #s(stx-boundary ((s0 s1) (s2 (s3 () (s3 () s4)))))) + (7 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 () (s4 () s5)))))) + (2 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 () (s4 () s5)))))))) + ((letrec-values (((x) __y) ((y z) __w)) __x) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 (((s2) s3) ((s4 s5) s6)) s7)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (((s2) s3) ((s4 s5) s6)) s7)))) + (138 . #f) + (0 . #s(stx-boundary (s0 (((s1) s2) ((s3 s4) s5)) s6))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) s2) ((s3 s4) s5)) s6))) + (113 . #f) + (16 + (#s(stx-boundary ((s0) s1)) #s(stx-boundary ((s2 s3) s4))) + . + #s(stx-boundary (s5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (13 . #f) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (5 . #s(stx-boundary ((s0 . s1)))) + (7 + . + #s(stx-boundary + (s0 (((s1) (s2 . s3)) ((s4 s5) (s2 . s6))) (s2 . s7)))) + (2 + . + #s(stx-boundary + (s0 (((s1) (s2 . s3)) ((s4 s5) (s2 . s6))) (s2 . s7)))) + (7 + . + #s(stx-boundary + (s0 (s1 (((s2) (s3 . s4)) ((s5 s6) (s3 . s7))) (s3 . s8))))) + (2 + . + #s(stx-boundary + (s0 (s1 (((s2) (s3 . s4)) ((s5 s6) (s3 . s7))) (s3 . s8))))))) + ((let () + (define-syntax (ok stx) + (local-expand (cadr (syntax-e stx)) 'expression #f)) + (ok 9)) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 (s6 (s7 s4)) (s8 s9) #f)) (s3 9))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 (s6 (s7 s4)) (s8 s9) #f)) (s3 9))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9)))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9)))) + (21 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9)))) + (22 + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9))) + . + #s(stx-boundary + (s9 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9)))) + (9 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9)))) + (0 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)) (s2 9)))) + (112 . #f) + (16 + () + . + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)) (s1 9)))) + (13 . #f) + (10 + . + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)) (s1 9)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)) (s1 9))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)) (s1 9)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 (s5 s2)) (s6 s7) #f)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 s3)) (s7 s8) #f)))) + . + #s(stx-boundary (s9 (s1 s3) (s4 (s5 (s6 s3)) (s7 s8) #f)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 s3)) (s7 s8) #f))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 s3)) (s7 s8) #f))))) + (127 + . + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 (s6 s3)) (s7 s8) #f))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 (s4 (s5 s2)) (s6 s7) #f))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f)))) + (21 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f))) + . + #s(stx-boundary (s7 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f)))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3 (s4 s1)) (s5 s6) #f)))) + (110 . #f) + (17 + #s(stx-boundary (s0)) + . + #s(stx-boundary ((s1 (s2 (s3 s0)) (s4 s5) #f)))) + (10 . #s(stx-boundary ((s0 (s1 (s2 s3)) (s4 s5) #f)))) + (24 + #s(stx-boundary ((s0 (s1 (s2 s3)) (s4 s5) #f))) + . + #s(stx-boundary ((s0 (s1 (s2 s3)) (s4 s5) #f)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f))) + (127 . #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f))) + (12 . #s(stx-boundary ((s0 (s1 (s2 s3)) (s4 s5) #f)))) + (4 . #s(stx-boundary ((s0 (s1 (s2 s3)) (s4 s5) #f)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f))) + (8 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f)) + . + #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 (s3 s4)) (s5 s6) #f))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 (s2 s3)) (s4 s5) #f))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 s2)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 s3)))) + (8 . #s(stx-boundary (s0 s1 (s2 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3)))) + (22 + #s(stx-boundary (s0 s1 (s2 s3))) + . + #s(stx-boundary (s0 s1 (s2 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 s3)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 s3)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 s2)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (22 #s(stx-boundary (s0 s1 s2)) . #s(stx-boundary (s0 s1 s2))) + (9 . #s(stx-boundary (s0 s1 s2))) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary (s0 (s1 s2 s3)))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 s3)))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 s3)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1))) + (117 . #f) + (7 . #s(stx-boundary (s0 s1))) + (2 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary #f)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . #f))) + (6 . #s(stx-boundary (s0 . #f))) + (115 . #f) + (7 . #s(stx-boundary (s0 #f))) + (2 . #s(stx-boundary (s0 #f))) + (5 . #s(stx-boundary (s0 (s1 s2 (s1 s3 s4)) (s5 s6) (s5 #f)))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 (s0 s3 s4)) (s5 s6) (s5 #f)))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 (s0 s3 s4)) (s5 s6) (s5 #f)))) + (5 . #s(stx-boundary ((s0 s1 (s0 s2 (s0 s3 s4)) (s5 s6) (s5 #f))))) + (7 + . + #s(stx-boundary (s0 (s1) (s2 s3 (s2 s4 (s2 s5 s1)) (s6 s7) (s6 #f))))) + (2 + . + #s(stx-boundary (s0 (s1) (s2 s3 (s2 s4 (s2 s5 s1)) (s6 s7) (s6 #f))))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 9))) + (0 . #s(stx-boundary (s0 9))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 9))) + (21 . #s(stx-boundary (s0 9))) + (130 . #s(stx-boundary 9)) + (132 . #s(stx-boundary 9)) + (126 . #s(stx-boundary 9)) + (127 . #s(stx-boundary 9)) + (133 . #s(stx-boundary 9)) + (131 . #s(stx-boundary 9)) + (22 #s(stx-boundary 9) . #s(stx-boundary (s0 9))) + (9 . #s(stx-boundary 9)) + (2 . #s(stx-boundary 9)) + (127 . #s(stx-boundary 9)) + (14 + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 (s5 (s6 s3)) (s7 s8) #f)))) () 9))) + (0 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 (s5 (s6 s3)) (s7 s8) #f)))) () 9))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 (s5 (s6 s3)) (s7 s8) #f)))) () 9))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 (s4 (s5 s2)) (s6 s7) #f))))) + () + . + #s(stx-boundary (9))) + (157 . #f) + (13 . #f) + (4 . #s(stx-boundary (9))) + (3 . #f) + (0 . #s(stx-boundary 9)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 9))) + (6 . #s(stx-boundary (s0 . 9))) + (115 . #f) + (7 . #s(stx-boundary (s0 9))) + (2 . #s(stx-boundary (s0 9))) + (5 . #s(stx-boundary ((s0 9)))) + (142 . #s(stx-boundary (s0 () (s1 9)))) + (7 . #s(stx-boundary (s0 () (s1 9)))) + (2 . #s(stx-boundary (s0 () (s1 9)))) + (7 . #s(stx-boundary (s0 () (s0 () (s1 9))))) + (2 . #s(stx-boundary (s0 () (s0 () (s1 9))))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () (s2 9)))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () (s2 9)))))))) + ((lambda (x) (define y (+ x x)) y) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2) (s3 s4 (s5 s2 s2)) s4)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2) (s3 s4 (s5 s2 s2)) s4)))) + (138 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3))) + (21 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3))) + (22 + #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3)) + . + #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3))) + (9 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3))) + (0 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 s3 (s4 s1 s1)) s3))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 s2 (s3 s0 s0)) s2))) + (10 . #s(stx-boundary ((s0 s1 (s2 s3 s3)) s1))) + (24 + #s(stx-boundary ((s0 s1 (s2 s3 s3)) s1)) + . + #s(stx-boundary ((s0 s1 (s2 s3 s3)) s1))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (22 + #s(stx-boundary (s0 s1 (s2 s3 s3))) + . + #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (2 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 s3 s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 s3 s3))) + . + #s(stx-boundary (s4 s1 (s2 s3 s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 s3 s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 s3)))) + (127 . #s(stx-boundary (s0 (s1) (s2 s3 s3)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 s2 s2)))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (14 #s(stx-boundary (s0 (((s1) (s2 s3 s3))) s1))) + (0 . #s(stx-boundary (s0 (((s1) (s2 s3 s3))) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (((s1) (s2 s3 s3))) s1))) + (113 . #f) + (16 (#s(stx-boundary ((s0) (s1 s2 s2)))) . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2 s2))) + (8 . #s(stx-boundary (s0 s1 s2 s2))) + (21 . #s(stx-boundary (s0 s1 s2 s2))) + (22 #s(stx-boundary (s0 s1 s2 s2)) . #s(stx-boundary (s0 s1 s2 s2))) + (9 . #s(stx-boundary (s0 s1 s2 s2))) + (0 . #s(stx-boundary (s0 s1 s2 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1 s1))) + (7 . #s(stx-boundary (s0 s1 s2 s2))) + (2 . #s(stx-boundary (s0 s1 s2 s2))) + (13 . #f) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (((s1) (s2 s3 s4 s4))) s1))) + (2 . #s(stx-boundary (s0 (((s1) (s2 s3 s4 s4))) s1))) + (7 . #s(stx-boundary (s0 (s1) (s2 (((s3) (s4 s5 s1 s1))) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (((s3) (s4 s5 s1 s1))) s3)))) + (7 . #s(stx-boundary (s0 (s1 (s2) (s3 (((s4) (s5 s6 s2 s2))) s4))))) + (2 . #s(stx-boundary (s0 (s1 (s2) (s3 (((s4) (s5 s6 s2 s2))) s4))))))) + ((if 1 2 3) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 1 2 3)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 1 2 3)))) + (138 . #f) + (0 . #s(stx-boundary (s0 1 2 3))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 1 2 3))) + (105 . #f) + (0 . #s(stx-boundary 1)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 1))) + (6 . #s(stx-boundary (s0 . 1))) + (115 . #f) + (7 . #s(stx-boundary (s0 1))) + (2 . #s(stx-boundary (s0 1))) + (3 . #f) + (0 . #s(stx-boundary 2)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 2))) + (6 . #s(stx-boundary (s0 . 2))) + (115 . #f) + (7 . #s(stx-boundary (s0 2))) + (2 . #s(stx-boundary (s0 2))) + (3 . #f) + (0 . #s(stx-boundary 3)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 3))) + (6 . #s(stx-boundary (s0 . 3))) + (115 . #f) + (7 . #s(stx-boundary (s0 3))) + (2 . #s(stx-boundary (s0 3))) + (7 . #s(stx-boundary (s0 (s1 1) (s1 2) (s1 3)))) + (2 . #s(stx-boundary (s0 (s1 1) (s1 2) (s1 3)))) + (7 . #s(stx-boundary (s0 (s1 (s2 1) (s2 2) (s2 3))))) + (2 . #s(stx-boundary (s0 (s1 (s2 1) (s2 2) (s2 3))))))) + ((begin 1 __x (+ 3 4)) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 1 s2 (s3 3 4))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 1 s2 (s3 3 4))))) + (138 . #f) + (0 . #s(stx-boundary (s0 1 s1 (s2 3 4)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 1 s1 (s2 3 4)))) + (107 . #f) + (4 . #s(stx-boundary (1 s0 (s1 3 4)))) + (3 . #f) + (0 . #s(stx-boundary 1)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 1))) + (6 . #s(stx-boundary (s0 . 1))) + (115 . #f) + (7 . #s(stx-boundary (s0 1))) + (2 . #s(stx-boundary (s0 1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . s1))) + (6 . #s(stx-boundary (s0 . s1))) + (116 . #f) + (7 . #s(stx-boundary (s0 . s1))) + (2 . #s(stx-boundary (s0 . s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 3 4))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 3 4))) + (8 . #s(stx-boundary (s0 s1 3 4))) + (21 . #s(stx-boundary (s0 s1 3 4))) + (22 #s(stx-boundary (s0 s1 3 4)) . #s(stx-boundary (s0 s1 3 4))) + (9 . #s(stx-boundary (s0 s1 3 4))) + (0 . #s(stx-boundary (s0 s1 3 4))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 3 4))) + (109 . #f) + (4 . #s(stx-boundary (s0 3 4))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 3)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 3))) + (6 . #s(stx-boundary (s0 . 3))) + (115 . #f) + (7 . #s(stx-boundary (s0 3))) + (2 . #s(stx-boundary (s0 3))) + (3 . #f) + (0 . #s(stx-boundary 4)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 4))) + (6 . #s(stx-boundary (s0 . 4))) + (115 . #f) + (7 . #s(stx-boundary (s0 4))) + (2 . #s(stx-boundary (s0 4))) + (5 . #s(stx-boundary (s0 (s1 3) (s1 4)))) + (7 . #s(stx-boundary (s0 s1 (s2 3) (s2 4)))) + (2 . #s(stx-boundary (s0 s1 (s2 3) (s2 4)))) + (5 . #s(stx-boundary ((s0 1) (s1 . s2) (s3 s4 (s0 3) (s0 4))))) + (7 . #s(stx-boundary (s0 (s1 1) (s2 . s3) (s4 s5 (s1 3) (s1 4))))) + (2 . #s(stx-boundary (s0 (s1 1) (s2 . s3) (s4 s5 (s1 3) (s1 4))))) + (7 . #s(stx-boundary (s0 (s1 (s2 1) (s3 . s4) (s5 s6 (s2 3) (s2 4)))))) + (2 + . + #s(stx-boundary (s0 (s1 (s2 1) (s3 . s4) (s5 s6 (s2 3) (s2 4)))))))) + ((#%stratified-body + (define (first z) z) + (define (ok x) (second x)) + (define (second y) 8) + (ok (first 5))) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 + (s2 (s3 s4) s4) + (s2 (s5 s6) (s7 s6)) + (s2 (s7 s8) 8) + (s5 (s3 5)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 + (s2 (s3 s4) s4) + (s2 (s5 s6) (s7 s6)) + (s2 (s7 s8) 8) + (s5 (s3 5)))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s1 (s6 s7) 8) + (s4 (s2 5))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 (s2 s3) s3) + (s1 (s4 s5) (s6 s5)) + (s1 (s6 s7) 8) + (s4 (s2 5))))) + (155 . #f) + (10 + . + #s(stx-boundary + ((s0 (s1 s2) s2) (s0 (s3 s4) (s5 s4)) (s0 (s5 s6) 8) (s3 (s1 5))))) + (24 + #s(stx-boundary + ((s0 (s1 s2) s2) (s0 (s3 s4) (s5 s4)) (s0 (s5 s6) 8) (s3 (s1 5)))) + . + #s(stx-boundary + ((s0 (s1 s2) s2) (s0 (s3 s4) (s5 s4)) (s0 (s5 s6) 8) (s3 (s1 5))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) s2))) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) s3))) + . + #s(stx-boundary (s0 (s1 s3) s3))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + . + #s(stx-boundary (s4 s1 (s2 (s3) s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) s2)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s0 (s1 s3) (s4 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s5 s1 (s2 (s3) (s4 s3))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 s2))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) 8))) + (0 . #s(stx-boundary (s0 (s1 s2) 8))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) 8))) + (21 . #s(stx-boundary (s0 (s1 s2) 8))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) 8))) + . + #s(stx-boundary (s0 (s1 s3) 8))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) 8))) + . + #s(stx-boundary (s4 s1 (s2 (s3) 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) 8)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 5)))) + (127 . #s(stx-boundary (s0 (s1 5)))) + (14 + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) ((s4) (s2 (s5) (s6 s5))) ((s6) (s2 (s7) 8))) + (s8 (s4 (s1 5)))))) + (0 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) ((s4) (s2 (s5) (s6 s5))) ((s6) (s2 (s7) 8))) + (s8 (s4 (s1 5)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) ((s4) (s2 (s5) (s6 s5))) ((s6) (s2 (s7) 8))) + (s8 (s4 (s1 5)))))) + (113 . #f) + (16 + (#s(stx-boundary ((s0) (s1 (s2) s2))) + #s(stx-boundary ((s3) (s1 (s4) (s5 s4)))) + #s(stx-boundary ((s5) (s1 (s6) 8)))) + . + #s(stx-boundary ((s7 (s3 (s0 5)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s1))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s1))) + (2 . #s(stx-boundary (s0 (s1) s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 s0)))) + (10 . #s(stx-boundary ((s0 s1)))) + (24 #s(stx-boundary ((s0 s1))) . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1))) + (127 . #s(stx-boundary (s0 s1))) + (12 . #s(stx-boundary ((s0 s1)))) + (4 . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (22 #s(stx-boundary (s0 s1 s2)) . #s(stx-boundary (s0 s1 s2))) + (9 . #s(stx-boundary (s0 s1 s2))) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary ((s0 s1 s2)))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) 8))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (8))) + (10 . #s(stx-boundary (8))) + (24 #s(stx-boundary (8)) . #s(stx-boundary (8))) + (3 . #f) + (126 . #s(stx-boundary 8)) + (127 . #s(stx-boundary 8)) + (12 . #s(stx-boundary (8))) + (4 . #s(stx-boundary (8))) + (3 . #f) + (0 . #s(stx-boundary 8)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 8))) + (6 . #s(stx-boundary (s0 . 8))) + (115 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (13 . #f) + (4 . #s(stx-boundary ((s0 (s1 (s2 5)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2 5))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 (s2 5))))) + (155 . #f) + (10 . #s(stx-boundary ((s0 (s1 5))))) + (24 #s(stx-boundary ((s0 (s1 5)))) . #s(stx-boundary ((s0 (s1 5))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 5)))) + (127 . #s(stx-boundary (s0 (s1 5)))) + (12 . #s(stx-boundary ((s0 (s1 5))))) + (4 . #s(stx-boundary ((s0 (s1 5))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 5)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 5)))) + (8 . #s(stx-boundary (s0 s1 (s2 5)))) + (21 . #s(stx-boundary (s0 s1 (s2 5)))) + (22 #s(stx-boundary (s0 s1 (s2 5))) . #s(stx-boundary (s0 s1 (s2 5)))) + (9 . #s(stx-boundary (s0 s1 (s2 5)))) + (0 . #s(stx-boundary (s0 s1 (s2 5)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 5)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 5)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 5))) + (8 . #s(stx-boundary (s0 s1 5))) + (21 . #s(stx-boundary (s0 s1 5))) + (22 #s(stx-boundary (s0 s1 5)) . #s(stx-boundary (s0 s1 5))) + (9 . #s(stx-boundary (s0 s1 5))) + (0 . #s(stx-boundary (s0 s1 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 5))) + (109 . #f) + (4 . #s(stx-boundary (s0 5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary (s0 (s1 5)))) + (7 . #s(stx-boundary (s0 s1 (s2 5)))) + (2 . #s(stx-boundary (s0 s1 (s2 5)))) + (5 . #s(stx-boundary (s0 (s1 s2 (s3 5))))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (5 . #s(stx-boundary ((s0 s1 (s0 s2 (s3 5)))))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 (s3 5))))) + (5 . #s(stx-boundary ((s0 s1 (s0 s2 (s3 5)))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) + ((s4) (s2 (s5) (s6 s7 s5))) + ((s7) (s2 (s8) (s9 8)))) + (s6 s4 (s6 s1 (s9 5)))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) + ((s4) (s2 (s5) (s6 s7 s5))) + ((s7) (s2 (s8) (s9 8)))) + (s6 s4 (s6 s1 (s9 5)))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) + ((s4) (s2 (s5) (s6 s7 s5))) + ((s7) (s2 (s8) (s9 8)))) + (s6 s4 (s6 s1 (s9 5)))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3)) + ((s4) (s2 (s5) (s6 s7 s5))) + ((s7) (s2 (s8) (s9 8)))) + (s6 s4 (s6 s1 (s9 5)))))) + (7 + . + #s(stx-boundary + (s0 + (s1 + (((s2) (s3 (s4) s4)) + ((s5) (s3 (s6) (s7 s8 s6))) + ((s8) (s3 (s9) (s10 8)))) + (s7 s5 (s7 s2 (s10 5))))))) + (2 + . + #s(stx-boundary + (s0 + (s1 + (((s2) (s3 (s4) s4)) + ((s5) (s3 (s6) (s7 s8 s6))) + ((s8) (s3 (s9) (s10 8)))) + (s7 s5 (s7 s2 (s10 5))))))))) + ((let () (define (ok x) '8) (define (second y) (ok y)) (second 5)) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 8)) (s2 (s6 s7) (s3 s7)) (s6 5))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 8)) (s2 (s6 s7) (s3 s7)) (s6 5))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5)))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5)))) + (21 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5)))) + (22 + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5))) + . + #s(stx-boundary + (s7 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5)))) + (9 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5)))) + (0 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s6) (s2 s6)) (s5 5)))) + (112 . #f) + (16 + () + . + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s0 (s4 s5) (s1 s5)) (s4 5)))) + (13 . #f) + (10 + . + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s0 (s4 s5) (s1 s5)) (s4 5)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s0 (s4 s5) (s1 s5)) (s4 5))) + . + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s0 (s4 s5) (s1 s5)) (s4 5)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s0 (s1 s3) (s4 8)))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 8))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s5 s1 (s2 (s3) (s4 8))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 s2)))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s0 (s1 s3) (s4 s3)))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) (s4 s3))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3)))) + . + #s(stx-boundary (s5 s1 (s2 (s3) (s4 s3))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 s3))))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 s2))))) + (3 . #f) + (126 . #s(stx-boundary (s0 5))) + (127 . #s(stx-boundary (s0 5))) + (14 + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s6) (s1 s6)))) (s5 5)))) + (0 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s6) (s1 s6)))) (s5 5)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s6) (s1 s6)))) (s5 5)))) + (113 . #f) + (16 + (#s(stx-boundary ((s0) (s1 (s2) (s3 8)))) + #s(stx-boundary ((s4) (s1 (s5) (s0 s5))))) + . + #s(stx-boundary ((s4 5)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 8)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 8)))) + (10 . #s(stx-boundary ((s0 8)))) + (24 #s(stx-boundary ((s0 8))) . #s(stx-boundary ((s0 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 8))) + (127 . #s(stx-boundary (s0 8))) + (12 . #s(stx-boundary ((s0 8)))) + (4 . #s(stx-boundary ((s0 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 8))) + (117 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 s1)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 s0)))) + (10 . #s(stx-boundary ((s0 s1)))) + (24 #s(stx-boundary ((s0 s1))) . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (126 . #s(stx-boundary (s0 s1))) + (127 . #s(stx-boundary (s0 s1))) + (12 . #s(stx-boundary ((s0 s1)))) + (4 . #s(stx-boundary ((s0 s1)))) + (3 . #f) + (0 . #s(stx-boundary (s0 s1))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 s2))) + (8 . #s(stx-boundary (s0 s1 s2))) + (21 . #s(stx-boundary (s0 s1 s2))) + (22 #s(stx-boundary (s0 s1 s2)) . #s(stx-boundary (s0 s1 s2))) + (9 . #s(stx-boundary (s0 s1 s2))) + (0 . #s(stx-boundary (s0 s1 s2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 s2))) + (109 . #f) + (4 . #s(stx-boundary (s0 s1))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0 s1))) + (7 . #s(stx-boundary (s0 s1 s2))) + (2 . #s(stx-boundary (s0 s1 s2))) + (5 . #s(stx-boundary ((s0 s1 s2)))) + (7 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (2 . #s(stx-boundary (s0 (s1) (s2 s3 s1)))) + (13 . #f) + (4 . #s(stx-boundary ((s0 5)))) + (3 . #f) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 5))) + (8 . #s(stx-boundary (s0 s1 5))) + (21 . #s(stx-boundary (s0 s1 5))) + (22 #s(stx-boundary (s0 s1 5)) . #s(stx-boundary (s0 s1 5))) + (9 . #s(stx-boundary (s0 s1 5))) + (0 . #s(stx-boundary (s0 s1 5))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 5))) + (109 . #f) + (4 . #s(stx-boundary (s0 5))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary 5)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 5))) + (6 . #s(stx-boundary (s0 . 5))) + (115 . #f) + (7 . #s(stx-boundary (s0 5))) + (2 . #s(stx-boundary (s0 5))) + (5 . #s(stx-boundary (s0 (s1 5)))) + (7 . #s(stx-boundary (s0 s1 (s2 5)))) + (2 . #s(stx-boundary (s0 s1 (s2 5)))) + (5 . #s(stx-boundary ((s0 s1 (s2 5))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 8)))) + (s0 (((s5) (s2 (s6) (s7 s1 s6)))) (s7 s5 (s4 5)))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 8)))) + (s0 (((s5) (s2 (s6) (s7 s1 s6)))) (s7 s5 (s4 5)))))) + (7 + . + #s(stx-boundary + (s0 + () + (s0 + (((s1) (s2 (s3) (s4 8)))) + (s0 (((s5) (s2 (s6) (s7 s1 s6)))) (s7 s5 (s4 5))))))) + (2 + . + #s(stx-boundary + (s0 + () + (s0 + (((s1) (s2 (s3) (s4 8)))) + (s0 (((s5) (s2 (s6) (s7 s1 s6)))) (s7 s5 (s4 5))))))) + (7 + . + #s(stx-boundary + (s0 + (s1 + () + (s1 + (((s2) (s3 (s4) (s5 8)))) + (s1 (((s6) (s3 (s7) (s8 s2 s7)))) (s8 s6 (s5 5)))))))) + (2 + . + #s(stx-boundary + (s0 + (s1 + () + (s1 + (((s2) (s3 (s4) (s5 8)))) + (s1 (((s6) (s3 (s7) (s8 s2 s7)))) (s8 s6 (s5 5)))))))))) + ((#%plain-app 1 2) + . + ((141 . #f) + (0 . #s(stx-boundary (s0 (s1 1 2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 1 2)))) + (138 . #f) + (0 . #s(stx-boundary (s0 1 2))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 1 2))) + (109 . #f) + (4 . #s(stx-boundary (1 2))) + (3 . #f) + (0 . #s(stx-boundary 1)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 1))) + (6 . #s(stx-boundary (s0 . 1))) + (115 . #f) + (7 . #s(stx-boundary (s0 1))) + (2 . #s(stx-boundary (s0 1))) + (3 . #f) + (0 . #s(stx-boundary 2)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 2))) + (6 . #s(stx-boundary (s0 . 2))) + (115 . #f) + (7 . #s(stx-boundary (s0 2))) + (2 . #s(stx-boundary (s0 2))) + (5 . #s(stx-boundary ((s0 1) (s0 2)))) + (7 . #s(stx-boundary (s0 (s1 1) (s1 2)))) + (2 . #s(stx-boundary (s0 (s1 1) (s1 2)))) + (7 . #s(stx-boundary (s0 (s1 (s2 1) (s2 2))))) + (2 . #s(stx-boundary (s0 (s1 (s2 1) (s2 2))))))) + ((let () + (define-syntax (ok stx) (quote-syntax 8)) + (define-syntax (second stx) (quote-syntax (ok 6))) + (second 5)) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 8)) (s2 (s6 s4) (s5 (s3 6))) (s6 5))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (s1 () (s2 (s3 s4) (s5 8)) (s2 (s6 s4) (s5 (s3 6))) (s6 5))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5)))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5)))) + (21 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5)))) + (22 + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5))) + . + #s(stx-boundary + (s6 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5)))) + (9 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5)))) + (0 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5)))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 () (s1 (s2 s3) (s4 8)) (s1 (s5 s3) (s4 (s2 6))) (s5 5)))) + (112 . #f) + (16 + () + . + #s(stx-boundary + ((s0 (s1 s2) (s3 8)) (s0 (s4 s2) (s3 (s1 6))) (s4 5)))) + (13 . #f) + (10 + . + #s(stx-boundary + ((s0 (s1 s2) (s3 8)) (s0 (s4 s2) (s3 (s1 6))) (s4 5)))) + (24 + #s(stx-boundary ((s0 (s1 s2) (s3 8)) (s0 (s4 s2) (s3 (s1 6))) (s4 5))) + . + #s(stx-boundary + ((s0 (s1 s2) (s3 8)) (s0 (s4 s2) (s3 (s1 6))) (s4 5)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s5 (s1 s3) (s4 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 8)))) + (21 . #s(stx-boundary (s0 (s1) (s2 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 8))) + . + #s(stx-boundary (s3 (s1) (s2 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 8)))) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 8)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 8)))) + (10 . #s(stx-boundary ((s0 8)))) + (24 #s(stx-boundary ((s0 8))) . #s(stx-boundary ((s0 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 8))) + (127 . #s(stx-boundary (s0 8))) + (12 . #s(stx-boundary ((s0 8)))) + (4 . #s(stx-boundary ((s0 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 8))) + (118 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6))))) + . + #s(stx-boundary (s6 (s1 s3) (s4 (s5 6))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6)))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6)))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6)))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 (s4 6)))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (21 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3 6)))) + . + #s(stx-boundary (s4 (s1) (s2 (s3 6))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 (s2 6))))) + (10 . #s(stx-boundary ((s0 (s1 6))))) + (24 #s(stx-boundary ((s0 (s1 6)))) . #s(stx-boundary ((s0 (s1 6))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 6)))) + (127 . #s(stx-boundary (s0 (s1 6)))) + (12 . #s(stx-boundary ((s0 (s1 6))))) + (4 . #s(stx-boundary ((s0 (s1 6))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 6)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 6)))) + (118 . #f) + (7 . #s(stx-boundary (s0 (s1 6)))) + (2 . #s(stx-boundary (s0 (s1 6)))) + (5 . #s(stx-boundary ((s0 (s1 6))))) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 5))) + (0 . #s(stx-boundary (s0 5))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 5))) + (21 . #s(stx-boundary (s0 5))) + (22 #s(stx-boundary (s0 6)) . #s(stx-boundary (s1 5))) + (9 . #s(stx-boundary (s0 6))) + (2 . #s(stx-boundary (s0 6))) + (0 . #s(stx-boundary (s0 6))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 6))) + (21 . #s(stx-boundary (s0 6))) + (22 #s(stx-boundary 8) . #s(stx-boundary (s0 6))) + (9 . #s(stx-boundary 8)) + (2 . #s(stx-boundary 8)) + (127 . #s(stx-boundary 8)) + (14 + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s3) (s4 (s1 6))))) () 8))) + (0 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s3) (s4 (s1 6))))) () 8))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s3) (s4 (s1 6))))) () 8))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 8)))) + #s(stx-boundary ((s4) (s1 (s2) (s3 (s0 6)))))) + () + . + #s(stx-boundary (8))) + (157 . #f) + (13 . #f) + (4 . #s(stx-boundary (8))) + (3 . #f) + (0 . #s(stx-boundary 8)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 8))) + (6 . #s(stx-boundary (s0 . 8))) + (115 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (142 . #s(stx-boundary (s0 () (s1 8)))) + (7 . #s(stx-boundary (s0 () (s1 8)))) + (2 . #s(stx-boundary (s0 () (s1 8)))) + (7 . #s(stx-boundary (s0 () (s0 () (s1 8))))) + (2 . #s(stx-boundary (s0 () (s0 () (s1 8))))) + (7 . #s(stx-boundary (s0 (s1 () (s1 () (s2 8)))))) + (2 . #s(stx-boundary (s0 (s1 () (s1 () (s2 8)))))))) + ((let () + (define-syntax (ok stx) (quote-syntax 8)) + (define-syntax (second stx) (quote-syntax (ok 6))) + (define (ident x) x) + (define (second-ident y) y) + (ident (second-ident (second)))) + . + ((141 . #f) + (0 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 (s3 s4) (s5 8)) + (s2 (s6 s4) (s5 (s3 6))) + (s7 (s8 s9) s9) + (s7 (s10 s11) s11) + (s8 (s10 (s6))))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (s1 + () + (s2 (s3 s4) (s5 8)) + (s2 (s6 s4) (s5 (s3 6))) + (s7 (s8 s9) s9) + (s7 (s10 s11) s11) + (s8 (s10 (s6))))))) + (138 . #f) + (0 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5)))))) + (1 . #s(stx-boundary s0)) + (8 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5)))))) + (21 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5)))))) + (22 + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5))))) + . + #s(stx-boundary + (s11 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5)))))) + (9 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5)))))) + (0 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + () + (s1 (s2 s3) (s4 8)) + (s1 (s5 s3) (s4 (s2 6))) + (s6 (s7 s8) s8) + (s6 (s9 s10) s10) + (s7 (s9 (s5)))))) + (112 . #f) + (16 + () + . + #s(stx-boundary + ((s0 (s1 s2) (s3 8)) + (s0 (s4 s2) (s3 (s1 6))) + (s5 (s6 s7) s7) + (s5 (s8 s9) s9) + (s6 (s8 (s4)))))) + (13 . #f) + (10 + . + #s(stx-boundary + ((s0 (s1 s2) (s3 8)) + (s0 (s4 s2) (s3 (s1 6))) + (s5 (s6 s7) s7) + (s5 (s8 s9) s9) + (s6 (s8 (s4)))))) + (24 + #s(stx-boundary + ((s0 (s1 s2) (s3 8)) + (s0 (s4 s2) (s3 (s1 6))) + (s5 (s6 s7) s7) + (s5 (s8 s9) s9) + (s6 (s8 (s4))))) + . + #s(stx-boundary + ((s0 (s1 s2) (s3 8)) + (s0 (s4 s2) (s3 (s1 6))) + (s5 (s6 s7) s7) + (s5 (s8 s9) s9) + (s6 (s8 (s4)))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8)))) + . + #s(stx-boundary (s5 (s1 s3) (s4 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 8))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 8))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 8)))) + (21 . #s(stx-boundary (s0 (s1) (s2 8)))) + (22 + #s(stx-boundary (s0 (s1) (s2 8))) + . + #s(stx-boundary (s3 (s1) (s2 8)))) + (9 . #s(stx-boundary (s0 (s1) (s2 8)))) + (0 . #s(stx-boundary (s0 (s1) (s2 8)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 8)))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 8)))) + (10 . #s(stx-boundary ((s0 8)))) + (24 #s(stx-boundary ((s0 8))) . #s(stx-boundary ((s0 8)))) + (3 . #f) + (126 . #s(stx-boundary (s0 8))) + (127 . #s(stx-boundary (s0 8))) + (12 . #s(stx-boundary ((s0 8)))) + (4 . #s(stx-boundary ((s0 8)))) + (3 . #f) + (0 . #s(stx-boundary (s0 8))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 8))) + (118 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary ((s0 8)))) + (7 . #s(stx-boundary (s0 (s1) (s2 8)))) + (2 . #s(stx-boundary (s0 (s1) (s2 8)))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (0 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (21 . #s(stx-boundary (s0 (s1 s2) (s3 (s4 6))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6))))) + . + #s(stx-boundary (s6 (s1 s3) (s4 (s5 6))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6)))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6)))))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) (s4 (s5 6)))))) + (103 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) (s3 (s4 6)))))) + (157 . #f) + (144 . #f) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (21 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3 6)))) + . + #s(stx-boundary (s4 (s1) (s2 (s3 6))))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (0 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary ((s1 (s2 6))))) + (10 . #s(stx-boundary ((s0 (s1 6))))) + (24 #s(stx-boundary ((s0 (s1 6)))) . #s(stx-boundary ((s0 (s1 6))))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 6)))) + (127 . #s(stx-boundary (s0 (s1 6)))) + (12 . #s(stx-boundary ((s0 (s1 6))))) + (4 . #s(stx-boundary ((s0 (s1 6))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 6)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1 6)))) + (118 . #f) + (7 . #s(stx-boundary (s0 (s1 6)))) + (2 . #s(stx-boundary (s0 (s1 6)))) + (5 . #s(stx-boundary ((s0 (s1 6))))) + (7 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3 6))))) + (3 . #f) + (145 . #f) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) s2))) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) s3))) + . + #s(stx-boundary (s0 (s1 s3) s3))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + . + #s(stx-boundary (s4 s1 (s2 (s3) s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) s2)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 s2) s2))) + (0 . #s(stx-boundary (s0 (s1 s2) s2))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 (s1 s2) s2))) + (21 . #s(stx-boundary (s0 (s1 s2) s2))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3) s3))) + . + #s(stx-boundary (s0 (s1 s3) s3))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3) s3)))) + (22 + #s(stx-boundary (s0 (s1) (s2 (s3) s3))) + . + #s(stx-boundary (s4 s1 (s2 (s3) s3)))) + (9 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (2 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (127 . #s(stx-boundary (s0 (s1) (s2 (s3) s3)))) + (104 . #f) + (148 . #s(stx-boundary ((s0) (s1 (s2) s2)))) + (3 . #f) + (126 . #s(stx-boundary (s0 (s1 (s2))))) + (127 . #s(stx-boundary (s0 (s1 (s2))))) + (14 + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s3) (s4 (s1 6))))) + (((s6) (s7 (s8) s8)) ((s9) (s7 (s10) s10))) + (s6 (s9 (s5)))))) + (0 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s3) (s4 (s1 6))))) + (((s6) (s7 (s8) s8)) ((s9) (s7 (s10) s10))) + (s6 (s9 (s5)))))) + (1 . #s(stx-boundary s0)) + (6 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) (s4 8))) ((s5) (s2 (s3) (s4 (s1 6))))) + (((s6) (s7 (s8) s8)) ((s9) (s7 (s10) s10))) + (s6 (s9 (s5)))))) + (114 . #f) + (19 + (#s(stx-boundary ((s0) (s1 (s2) (s3 8)))) + #s(stx-boundary ((s4) (s1 (s2) (s3 (s0 6)))))) + (#s(stx-boundary ((s5) (s6 (s7) s7))) + #s(stx-boundary ((s8) (s6 (s9) s9)))) + . + #s(stx-boundary ((s5 (s8 (s4)))))) + (157 . #f) + (13 . #f) + (113 . #f) + (16 + (#s(stx-boundary ((s0) (s1 (s2) s2))) + #s(stx-boundary ((s3) (s1 (s4) s4)))) + . + #s(stx-boundary ((s0 (s3 (s5)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s1))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s1))) + (2 . #s(stx-boundary (s0 (s1) s1))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1) s1))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 (s1) s1))) + (110 . #f) + (17 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (10 . #s(stx-boundary (s0))) + (24 #s(stx-boundary (s0)) . #s(stx-boundary (s0))) + (3 . #f) + (126 . #s(stx-boundary s0)) + (127 . #s(stx-boundary s0)) + (12 . #s(stx-boundary (s0))) + (4 . #s(stx-boundary (s0))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (5 . #s(stx-boundary (s0))) + (7 . #s(stx-boundary (s0 (s1) s1))) + (2 . #s(stx-boundary (s0 (s1) s1))) + (13 . #f) + (4 . #s(stx-boundary ((s0 (s1 (s2)))))) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1 (s2))))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (8 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (21 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (22 + #s(stx-boundary (s0 s1 (s2 (s3)))) + . + #s(stx-boundary (s0 s1 (s2 (s3))))) + (9 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (0 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2 (s3))))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1 (s2))))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0 (s1)))) + (1 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 s1 (s2)))) + (8 . #s(stx-boundary (s0 s1 (s2)))) + (21 . #s(stx-boundary (s0 s1 (s2)))) + (22 #s(stx-boundary (s0 s1 (s2))) . #s(stx-boundary (s0 s1 (s2)))) + (9 . #s(stx-boundary (s0 s1 (s2)))) + (0 . #s(stx-boundary (s0 s1 (s2)))) + (1 . #s(stx-boundary s0)) + (6 . #s(stx-boundary (s0 s1 (s2)))) + (109 . #f) + (4 . #s(stx-boundary (s0 (s1)))) + (3 . #f) + (0 . #s(stx-boundary s0)) + (1 . #s(stx-boundary s0)) + (125 #s(stx-boundary s0) . #s(stx-boundary s0)) + (2 . #s(stx-boundary s0)) + (3 . #f) + (0 . #s(stx-boundary (s0))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0))) + (21 . #s(stx-boundary (s0))) + (22 #s(stx-boundary (s0 6)) . #s(stx-boundary (s1))) + (9 . #s(stx-boundary (s0 6))) + (0 . #s(stx-boundary (s0 6))) + (1 . #s(stx-boundary s0)) + (8 . #s(stx-boundary (s0 6))) + (21 . #s(stx-boundary (s0 6))) + (22 #s(stx-boundary 8) . #s(stx-boundary (s0 6))) + (9 . #s(stx-boundary 8)) + (0 . #s(stx-boundary 8)) + (1 . #s(stx-boundary s0)) + (142 . #s(stx-boundary (s0 . 8))) + (6 . #s(stx-boundary (s0 . 8))) + (115 . #f) + (7 . #s(stx-boundary (s0 8))) + (2 . #s(stx-boundary (s0 8))) + (5 . #s(stx-boundary (s0 (s1 8)))) + (7 . #s(stx-boundary (s0 s1 (s2 8)))) + (2 . #s(stx-boundary (s0 s1 (s2 8)))) + (5 . #s(stx-boundary (s0 (s1 s2 (s3 8))))) + (7 . #s(stx-boundary (s0 s1 (s0 s2 (s3 8))))) + (2 . #s(stx-boundary (s0 s1 (s0 s2 (s3 8))))) + (5 . #s(stx-boundary ((s0 s1 (s0 s2 (s3 8)))))) + (142 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3))) + (s0 (((s4) (s2 (s5) s5))) (s6 s1 (s6 s4 (s7 8))))))) + (7 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3))) + (s0 (((s4) (s2 (s5) s5))) (s6 s1 (s6 s4 (s7 8))))))) + (2 + . + #s(stx-boundary + (s0 + (((s1) (s2 (s3) s3))) + (s0 (((s4) (s2 (s5) s5))) (s6 s1 (s6 s4 (s7 8))))))) + (7 + . + #s(stx-boundary + (s0 + () + (s0 + (((s1) (s2 (s3) s3))) + (s0 (((s4) (s2 (s5) s5))) (s6 s1 (s6 s4 (s7 8)))))))) + (2 + . + #s(stx-boundary + (s0 + () + (s0 + (((s1) (s2 (s3) s3))) + (s0 (((s4) (s2 (s5) s5))) (s6 s1 (s6 s4 (s7 8)))))))) + (7 + . + #s(stx-boundary + (s0 + (s1 + () + (s1 + (((s2) (s3 (s4) s4))) + (s1 (((s5) (s3 (s6) s6))) (s7 s2 (s7 s5 (s8 8))))))))) + (2 + . + #s(stx-boundary + (s0 + (s1 + () + (s1 + (((s2) (s3 (s4) s4))) + (s1 (((s5) (s3 (s6) s6))) (s7 s2 (s7 s5 (s8 8)))))))))))) diff --git a/pkgs/racket-test-core/tests/racket/expobs.rktl b/pkgs/racket-test-core/tests/racket/expobs.rktl new file mode 100644 index 0000000000..2d721c7720 --- /dev/null +++ b/pkgs/racket-test-core/tests/racket/expobs.rktl @@ -0,0 +1,185 @@ +(load-relative "loadtest.rktl") + +(Section 'expobs) + +(require '#%expobs) + +(define generate-expobs-regression? #f) +(define checking-against-old-expander? #f) + +(define expobs-traces-path + (build-path (current-load-relative-directory) + "expobs-regression.rktd")) + +(define (get-trace e) + (struct stx-boundary (v) #:prefab) + + (define (stx-essence s) + (define syms (make-hasheq)) + (define (stx-essence s) + (cond + [(syntax? s) + (if checking-against-old-expander? + (stx-essence (syntax->datum s)) + ;; We care about the outer countour of pairs versus syntax objects, + ;; but not the interior details: + (stx-boundary (stx-essence (syntax->datum s))))] + [(pair? s) (cons (stx-essence (car s)) + (stx-essence (cdr s)))] + [(symbol? s) (or (hash-ref syms s #f) + (let ([new-s (string->symbol (format "s~a" (hash-count syms)))]) + (hash-set! syms s new-s) + new-s))] + [(or (number? s) (boolean? s) (keyword? s) (null? s)) s] + [else '#:opaque])) + (stx-essence s)) + + (define trace '()) + (parameterize ([current-expand-observe (lambda (num args) + (set! trace (cons (cons num (stx-essence args)) trace)))]) + (with-handlers ([exn:fail:syntax? void]) ; syntax error ok: check trace up to error + (expand (if (and (pair? e) (eq? 'module (car e))) + e + `(#%expression ,e))))) + (let ([l (reverse trace)]) + l)) + +;; ---------------------------------------- + +(when generate-expobs-regression? + (define new-expected-traces (make-hash)) + + (define (generate-trace e) + (hash-set! new-expected-traces e (get-trace e))) + + (for-each generate-trace + '((#%top . __x) + __x + (#%plain-app 1 2) + (quote-syntax (stx-quoted)) + (quote quoted) + (set! __x 99) + (letrec-values ([(x) __y] [(y z) __w]) __x) + (let-values ([(x) __y] [(y z) __w]) __x) + (begin 1 __x (+ 3 4)) + (case-lambda [(x) x] [(x y) (+ x y)]) + (#%variable-reference __z) + (begin0 '3 '5) + (with-continuation-mark __x __y __z) + (if 1 2 3) + (lambda (x) + (define y (+ x x)) + y) + (let () + (define (ok x) '8) + (ok 5)) + (let () + (define (ok x) '8) + (define (second y) (ok y)) + (second 5)) + (let () + (define (ok x) (second x)) + (define (second y) 8) + (ok 5)) + (let () + (define (first z) z) + (define (ok x) (second x)) + (printf "extra expression\n") + (define (second y) 8) + (ok (first 5))) + (#%stratified-body + (define (first z) z) + (define (ok x) (second x)) + (define (second y) 8) + (ok (first 5))) + (#%stratified-body + (define (first z) z) + (define (ok x) (second x)) + (define (second y) 8) + (ok (first 5)) + ;; syntax error: + (define more 'oops)) + (let () + (define-syntax (ok stx) (quote-syntax 8)) + (ok 5)) + (let () + (define-syntax (ok stx) (quote-syntax 8)) + (define-syntax (second stx) (quote-syntax (ok 6))) + (second 5)) + (let () + (define-syntax (ok stx) (quote-syntax 8)) + (define (ident x) x) + 9) + (let () + (define-syntax (ok stx) (quote-syntax 8)) + (define-syntax (second stx) (quote-syntax (ok 6))) + (define (ident x) x) + (define (second-ident y) y) + (ident (second-ident (second)))) + (let () + (define-syntax-rule (ok x) x) + (ok 5)) + (let () + (define-syntax (ok stx) + (local-expand (cadr (syntax-e stx)) 'expression #f)) + (ok 9)) + (let () + (define-syntax (ok stx) + (define-values (exp opaque) + (syntax-local-expand-expression (cadr (syntax-e stx)))) + opaque) + (#%expression (ok 9))) + (let () + (define-syntax (lift stx) + (syntax-local-lift-expression #'(+ 1 2))) + (lift)) + (let () + (define-syntax (lift stx) + (syntax-local-lift-require 'racket/list #'foldl)) + (lift)) + (module m '#%kernel + 5) + (module m racket/base + 'done) + (module m racket/base + (define (proc x) x) + (provide proc)) + (module m racket/base + (define-syntax (ok stx) (quote-syntax 8)) + (ok) + (list (ok) (ok))) + (module m racket/base + (require racket/list) + foldl) + (module m racket/base + (define-syntax (ok stx) + (syntax-local-lift-require 'racket/list #'foldl)) + (ok)) + )) + + (call-with-output-file expobs-traces-path + #:exists 'truncate + (lambda (o) + ((dynamic-require 'racket/pretty 'pretty-write) new-expected-traces o)))) + +;; ---------------------------------------- + +(define expected-traces + (call-with-input-file expobs-traces-path read)) + +(define (trace-equal? t1 t2) + (unless (= (length t1) (length t2)) + (printf "trace lengths differ\n")) + (for ([v1 (in-list t1)] + [v2 (in-list t2)] + [i (in-naturals)]) + (unless (equal? v1 v2) + (printf "different at ~a: ~s ~s\n" i v1 v2))) + (equal? t1 t2)) + +(for ([(e trace) (in-hash expected-traces)]) + (test #t `(trace ,e) (trace-equal? (get-trace e) trace))) + +;; ---------------------------------------- + +(report-errs) diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index f594e81408..f68ab3c7ac 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -18,7 +18,8 @@ (test #f malloc 0 _int) (test #f malloc _int 0) -(test 0 bytes-length (make-sized-byte-string #f 0)) +(unless (eq? 'cs (system-type 'gc)) + (test 0 bytes-length (make-sized-byte-string #f 0))) ;; Check integer-range checking: (let () @@ -323,9 +324,10 @@ (set-box! b #f))) ;; --- ;; test exposing internal mzscheme functionality - (test '(1 2) - (get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme)) - 1 '(2)) + (when (eq? 'racket (system-type 'vm)) + (test '(1 2) + (get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme)) + 1 '(2))) ;; --- ;; test arrays (let ([p (malloc _c7_list)]) ;; should allocate the right size @@ -573,7 +575,7 @@ (test 'hello hash-ref ht seventeen3 #f))) ;; Check proper handling of offsets: -(let () +(when (eq? 'racket (system-type 'vm)) (define scheme_make_sized_byte_string (get-ffi-obj 'scheme_make_sized_byte_string #f (_fun _pointer _intptr _int -> _scheme))) ;; Non-gcable: @@ -605,7 +607,7 @@ (define _stuff-pointer (_cpointer 'stuff)) (define p (cast (ptr-add (malloc 10) 5) _pointer _thing-pointer)) - (cpointer-gcable? p) + (test #t cpointer-gcable? p) (define q (cast p _thing-pointer _stuff-pointer)) (test (cast p _pointer _intptr) cast q _pointer _intptr) @@ -647,7 +649,7 @@ (define ENOENT 2) (define ERANGE 34) (define _getcwd ;; sets errno = ERANGE if path longer than buffer - (get-ffi-obj '_getcwd msvcrt (_fun #:save-errno 'posix _bytes _int -> _void))) + (get-ffi-obj '_getcwd msvcrt (_fun #:save-errno 'posix _bytes/nul-terminated _int -> _void))) (define _chdir ;; sets errno = ENOENT if path doesn't exist (get-ffi-obj '_chdir msvcrt (_fun #:save-errno 'posix _string -> _int))) (define (bad/ERANGE) (_getcwd (make-bytes 1) 1)) @@ -664,7 +666,7 @@ (delete-test-files) -(let () +(when (eq? 'racket (system-type 'vm)) (define _values (get-ffi-obj 'scheme_values #f (_fun _int (_list i _racket) -> _racket))) (test-values '(1 "b" three) (lambda () (_values 3 (list 1 "b" 'three))))) @@ -679,8 +681,9 @@ (test 4.4t0 extflvector-ref v 2) (test 2.2t0 ptr-ref (ptr-add (extflvector->cpointer v) (ctype-sizeof _longdouble)) _longdouble)) -;; Check a corner of UTF-16 conversion: -(test "\U171D3" cast (cast "\U171D3" _string/utf-16 _gcpointer) _gcpointer _string/utf-16) +(when (eq? 'racket (system-type 'vm)) + ;; Check a corner of UTF-16 conversion: + (test "\U171D3" cast (cast "\U171D3" _string/utf-16 _gcpointer) _gcpointer _string/utf-16)) ;; check async: (when test-async? @@ -1000,6 +1003,8 @@ ;; --- inplace tests + (define can-in-place? (not (eq? 'chez-scheme (system-type 'vm)))) + (define-serializable-cstruct _NOIN ([a _int])) (define-serializable-cstruct _INS ([a _int]) #:serialize-inplace) @@ -1008,7 +1013,7 @@ (define-serializable-cstruct _INSD ([a _int]) #:serialize-inplace #:deserialize-inplace - #:malloc-mode (if (eq? 'racket (system-type 'vm)) + #:malloc-mode (if can-in-place? (lambda (_) (error "should not get here")) malloc/register)) @@ -1041,7 +1046,7 @@ ;; modified (set-INS-a! ins 456) (define ds2 (deserialize s)) - (check-equal? 456 (INS-a ds2))) + (check-equal? (if can-in-place? 456 123) (INS-a ds2))) ;; inplace deser (let () @@ -1208,44 +1213,45 @@ ;; ---------------------------------------- -(define scheme_make_type - (get-ffi-obj 'scheme_make_type #f (_fun _string -> _short))) -(define scheme_register_type_gc_shape - (get-ffi-obj 'scheme_register_type_gc_shape #f (_fun _short (_list i _intptr) -> _void))) +(when (eq? 'racket (system-type 'vm)) + (define scheme_make_type + (get-ffi-obj 'scheme_make_type #f (_fun _string -> _short))) + (define scheme_register_type_gc_shape + (get-ffi-obj 'scheme_register_type_gc_shape #f (_fun _short (_list i _intptr) -> _void))) -(define SHAPE_STR_TERM 0) -(define SHAPE_STR_PTR_OFFSET 1) + (define SHAPE_STR_TERM 0) + (define SHAPE_STR_PTR_OFFSET 1) -(define-cstruct _tagged ([type-tag _short] - [obj1 _racket] - [non2 _intptr] - [obj3 _racket] - [non4 _intptr]) - #:define-unsafe - #:malloc-mode 'tagged) -(test #t cpointer-predicate-procedure? tagged?) + (define-cstruct _tagged ([type-tag _short] + [obj1 _racket] + [non2 _intptr] + [obj3 _racket] + [non4 _intptr]) + #:define-unsafe + #:malloc-mode 'tagged) + (test #t cpointer-predicate-procedure? tagged?) -(define t (scheme_make_type "new-type")) -(scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset - SHAPE_STR_PTR_OFFSET tagged-obj3-offset - SHAPE_STR_TERM)) + (define t (scheme_make_type "new-type")) + (scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset + SHAPE_STR_PTR_OFFSET tagged-obj3-offset + SHAPE_STR_TERM)) -(define obj1 (make-string 10)) -(define obj2 (make-bytes 12)) -(define obj3 (make-bytes 14)) -(define obj4 (make-string 16)) + (define obj1 (make-string 10)) + (define obj2 (make-bytes 12)) + (define obj3 (make-bytes 14)) + (define obj4 (make-string 16)) -(define obj2-addr (cast obj2 _racket _intptr)) -(define obj4-addr (cast obj4 _racket _intptr)) + (define obj2-addr (cast obj2 _racket _intptr)) + (define obj4-addr (cast obj4 _racket _intptr)) -(define o (make-tagged t obj1 obj2-addr obj3 obj4-addr)) + (define o (make-tagged t obj1 obj2-addr obj3 obj4-addr)) -(collect-garbage) + (collect-garbage) -(eq? (tagged-obj1 o) obj1) -(eq? (tagged-obj3 o) obj3) -(= (tagged-non2 o) obj2-addr) -(= (tagged-non4 o) obj4-addr) + (eq? (tagged-obj1 o) obj1) + (eq? (tagged-obj3 o) obj3) + (= (tagged-non2 o) obj2-addr) + (= (tagged-non4 o) obj4-addr)) ;; ---------------------------------------- diff --git a/pkgs/racket-test-core/tests/racket/jitinline.rktl b/pkgs/racket-test-core/tests/racket/jitinline.rktl index fb2f12beed..567fdd9123 100644 --- a/pkgs/racket-test-core/tests/racket/jitinline.rktl +++ b/pkgs/racket-test-core/tests/racket/jitinline.rktl @@ -47,7 +47,9 @@ thing? rock? stone? continuation-mark-set-first)) (let ([s (with-handlers ([exn? exn-message]) - (let ([bad bad-value]) + (let ([bad (if (eq? bad-value 'unsafe-undefined) + unsafe-undefined + bad-value)]) (cond [first-arg (proc first-arg bad)] [second-arg (proc bad second-arg)] @@ -702,8 +704,14 @@ (bin-exact 'b 'vector-ref #(a b c) 1) (bin-exact 'c 'vector-ref #(a b c) 2) + (bin-exact 'a 'vector*-ref #(a b c) 0 #t) + (bin-exact 'b 'vector*-ref #(a b c) 1) + (bin-exact 'c 'vector*-ref #(a b c) 2) + (un-exact 'a 'unbox (box 'a) #t) + (un-exact 'a 'unbox* (box 'a) #t) (un-exact 3 'vector-length (vector 'a 'b 'c) #t) + (un-exact 3 'vector*-length (vector 'a 'b 'c) #t) (bin-exact 1.1 'flvector-ref (flvector 1.1 2.2 3.3) 0 #t) (bin-exact 3.3 'flvector-ref (flvector 1.1 2.2 3.3) 2) @@ -837,7 +845,7 @@ (bin-exact 3.3t0 'extflvector-ref (extflvector 1.1t0 2.2t0 3.3t0) 2) (un-exact 3 'extflvector-length (extflvector 1.1t0 2.2t0 3.3t0) #t) - (bin-exact 5 'check-not-unsafe-undefined 5 'check-not-unsafe-undefined #:bad-value unsafe-undefined) + (bin-exact 5 'check-not-unsafe-undefined 5 'check-not-unsafe-undefined #:bad-value 'unsafe-undefined) ) (let ([test-setter @@ -857,6 +865,7 @@ 3rd-all-ok?)) '(0 1 2))))]) (test-setter make-vector #f 7 'vector-set! vector-set! vector-ref #t) + (test-setter make-vector #f 7 'vector*-set! vector*-set! vector*-ref #t) (test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref #f) (test-setter make-string #\a #\7 'string-set! string-set! string-ref #f) (test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f) @@ -869,14 +878,29 @@ (test-setter (lambda (n v) (chap-vec (chap-vec (make-vector n v)))) #f 7 'vector-set! vector-set! vector-ref #t))) + (err/rt-test (apply (list-ref (list (lambda (v) (vector*-length v))) (random 1)) + (list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val))))) + (err/rt-test (apply (list-ref (list (lambda (v) (vector*-ref v 0))) (random 1)) + (list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val))))) + (err/rt-test (apply (list-ref (list (lambda (v) (unbox* v))) (random 1)) + (list (chaperone-box (box 1) (lambda (b v) v) (lambda (b v) v))))) + (err/rt-test (apply (list-ref (list (lambda (v) (vector-set! v 0 #t))) (random 1)) (list (vector-immutable 1 2 3)))) + (err/rt-test (apply (list-ref (list (lambda (v) (vector*-set! v 0 #t))) (random 1)) + (list (vector-immutable 1 2 3)))) + (err/rt-test (apply (list-ref (list (lambda (v) (vector*-set! v 0 #t))) (random 1)) + (list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val))))) (err/rt-test (apply (list-ref (list (lambda (s) (string-set! s 0 #\a))) (random 1)) (list "123"))) (err/rt-test (apply (list-ref (list (lambda (s) (bytes-set! s 0 0))) (random 1)) (list #"123"))) (err/rt-test (apply (list-ref (list (lambda (b) (set-box! b #t))) (random 1)) (list (box-immutable 1)))) + (err/rt-test (apply (list-ref (list (lambda (b) (set-box*! b #t))) (random 1)) + (list (box-immutable 1)))) + (err/rt-test (apply (list-ref (list (lambda (v) (set-box*! v 'no))) (random 1)) + (list (chaperone-box (box 1) (lambda (b v) v) (lambda (b v) v))))) (let ([v (box 1)]) (check-error-message 'set-box! (eval `(lambda (x) (set-box! x 10)))) diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index 92ed5487b1..8b26d35674 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/pkgs/racket-test-core/tests/racket/macro.rktl @@ -1675,6 +1675,95 @@ (test '(1 2 3) dynamic-require ''uses-local-lift-values-at-expansion-time 'l) +;; ---------------------------------------- +;; Check that `local-expand` tentatively allows out-of-context identifiers + +(module tentatively-out-of-context racket/base + (require (for-syntax racket/base)) + + (define-syntax (new-lam stx) + (syntax-case stx () + [(_ x body) + (with-syntax ([(_ (x+) body+) + (local-expand #'(lambda (x) body) 'expression null)]) + (with-syntax ([body++ ;; double-expand body + (local-expand #'body+ 'expression null)]) + #'(lambda (x+) body++)))])) + + ((new-lam X X) 100)) + +;; ---------------------------------------- +;; Check that properties interact properly with the rename transformer +;; that is used to implement `let-syntax` [example from Stephen Chang] + +(define-syntax (test-key-property-as-val stx) + (syntax-case stx () + [(_ x) + (with-syntax ([x/prop (syntax-property #'x 'key 'val)]) + (with-syntax ([(lam _ (lv1 _ (lv2 _ x+))) + (local-expand + #'(lambda (x) + (let-syntax ([x (lambda (stx) #'x)]) + x/prop)) + 'expression null)]) + #`'#,(syntax-property #'x+ 'key)))])) + +(test 'val 'let-syntax-rename-transformer-property (test-key-property-as-val stx)) + +;; ---------------------------------------- +;; Check that a chain of rename transformers maintains properties correctly + +(module chains-properties-through-two-rename-transformer racket/base + (require (for-syntax racket/base)) + + (define a 'a) + + (define-syntax b (make-rename-transformer (syntax-property #'a 'ids 'b))) + (define-syntax c (make-rename-transformer (syntax-property #'b 'ids 'c))) + + (define-syntax (inspect stx) + (syntax-case stx () + [(_ e) + (let ([e (local-expand #'e 'expression null)]) + #`(quote #,(syntax-property e 'ids)))])) + + (provide prop-val) + (define prop-val (inspect c))) + +(test '(b . c) dynamic-require ''chains-properties-through-two-rename-transformer 'prop-val) + +;; ---------------------------------------- +;; Check that the wrong properties are *not* added when a rename transformer is involed + +(module inner-and-outer-properties-around-rename-transformers racket/base + (require (for-syntax racket/base)) + + (define-syntax (some-define stx) + (syntax-case stx () + [(_ x) + #'(define-syntax x + (make-rename-transformer + (syntax-property #'void 'prop 'inner)))])) + + (some-define x) + + (define-syntax (wrapper stx) + (syntax-case stx () + [(_ e) + (local-expand + (syntax-property #'e 'prop 'outer) + 'expression null)])) + + (define-syntax (#%app stx) + (syntax-case stx () + [(_ f) + #`(quote #,(syntax-property #'f 'prop))])) + + (provide prop-val) + (define prop-val (wrapper (x)))) + +(test 'inner dynamic-require ''inner-and-outer-properties-around-rename-transformers 'prop-val) + ;; ---------------------------------------- ;; Check that a `prop:rename-transformer` procedure is called in a ;; `syntax-transforming?` mode when used as an expression @@ -1707,6 +1796,13 @@ (ax))]) (test 'two values also-x))) +;; ---------------------------------------- +;; Make sure top-level definition replaces a macro binding + +(define-syntax-rule (something-previously-bound-as-syntax) 1) +(define something-previously-bound-as-syntax 5) +(test 5 values something-previously-bound-as-syntax) + ;; ---------------------------------------- ;; Check that ellipsis-counts errors are reported when a single ;; pattern variable is used at different depths @@ -1716,6 +1812,35 @@ #'([(b (b ...)) ...] ...))) (lambda (exn) (regexp-match? #rx"incompatible ellipsis" (exn-message exn)))) +;; ---------------------------------------- +;; Check `local-expand` for a `#%module-begin` that +;; routes `require`s through a macro (which involves use-site +;; scopes) + +(module module-begin-check/mb racket/base + (require (for-syntax racket/base)) + + (provide (except-out (all-from-out racket/base) + #%module-begin) + (rename-out [mb #%module-begin])) + + (define-syntax (mb stx) + (syntax-case stx () + [(_ f ... last) + (local-expand #'(#%module-begin f ... last) + 'module-begin + (list #'module*))]))) + +(module module-begin-check/y racket/base + (provide y) + (define y 'y)) + +(module x 'module-begin-check/mb + (define-syntax-rule (req mod ...) + (require mod ...)) + (req 'module-begin-check/y) + (void y)) + ;; ---------------------------------------- ;; Check that expansion to `#%module-begin` is prepared to handle ;; definition contexts diff --git a/pkgs/racket-test-core/tests/racket/modprot.rktl b/pkgs/racket-test-core/tests/racket/modprot.rktl index 0bc821aaa4..1fc17e3d04 100644 --- a/pkgs/racket-test-core/tests/racket/modprot.rktl +++ b/pkgs/racket-test-core/tests/racket/modprot.rktl @@ -212,45 +212,10 @@ (#%require '#%unsafe) (display unsafe-car))) -(require compiler/zo-structs - compiler/zo-marshal) - -(define unsafe-synth-zo - (let ([bstr - (zo-marshal - (compilation-top - 10 - #hash() - (prefix 0 - (list 'dummy) - null - 'insp0) - (mod 'unsafe - 'unsafe - (module-path-index-join #f #f) - (prefix 0 - (list (module-variable (module-path-index-join ''#%unsafe #f) - 'unsafe-car - -1 - 0 - #f)) - null - 'insp0) - null - null - null ; body - null - null - 0 - (toplevel 0 0 #f #f) - #f - #f - #hash() - null - null - null)))]) - (parameterize ([read-accept-compiled #t]) - (read (open-input-bytes bstr))))) +(require (only-in racket/unsafe/ops unsafe-car) + compiler/zo-structs + compiler/zo-marshal + (only-in '#%linklet primitive->compiled-position)) ;; - - - - - - - - - - - - - - - - - - - - @@ -268,7 +233,10 @@ (define (mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed three/normal - get-one-inspector get-three-inspector fail-pnab? fail-prot? fail-three? np-ok? fail-three-comp?) + get-one-inspector get-three-inspector fail-pnab? fail-prot? fail-three? np-ok? fail-three-comp? + #:via-2-ok? [via-2-ok? #f] + #:unprot-ok? [unprot-ok? #f] + #:early-ok? [early-ok? #f]) (let ([try (lambda (two three v fail-three?) (let ([ns (make-base-namespace)] @@ -291,17 +259,17 @@ (test #t regexp-match? (if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v)))) (get-output-bytes p))))]) - (try two/no-protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one .5.") fail-three?) - (try two/no-protect three/nfnabbed (if (and fail-prot? (not np-ok?)) #rx#"unexported .* unexp" #rx#"two .5.") fail-three?) - (try two/no-protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero .8.") fail-three?) - (try two/no-protect three/nfpnabbed (if (and fail-pnab? (not np-ok?)) #rx#"protected .* prot" #rx#"two .8.") (or fail-three? fail-three-comp?)) - (try two/no-protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one .13.") fail-three?) + (try two/no-protect three/nabbed (if (and fail-prot? (not early-ok?)) #rx#"unexported" #rx#"one .5.") fail-three?) + (try two/no-protect three/nfnabbed (if (and fail-prot? (not np-ok?) (not unprot-ok?)) #rx#"unexported .* unexp" #rx#"two .5.") fail-three?) + (try two/no-protect three/pnabbed (if (and fail-pnab? (not early-ok?)) #rx#"protected" #rx#"zero .8.") fail-three?) + (try two/no-protect three/nfpnabbed (if (and fail-pnab? (not np-ok?) (not unprot-ok?)) #rx#"protected .* prot" #rx#"two .8.") (or fail-three? fail-three-comp?)) + (try two/no-protect three/snabbed (if (and fail-prot? (not np-ok?) (not via-2-ok?) (not early-ok?)) #rx#"unexported .* stx" #rx#"one .13.") fail-three?) (try two/no-protect three/nfsnabbed #rx#"two .13." fail-three?) (try two/no-protect three/normal #rx#"two .10." fail-three?) - (try two/protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one .5.") fail-three?) - (try two/protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero .8.") fail-three?) - (try two/protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one .13.") fail-three?) - (try two/protect three/normal (if fail-prot? #rx#"protected .* normal" #rx#"two .10.") fail-three?))) + (try two/protect three/nabbed (if fail-prot? #rx#"unexported" #rx#"one .5.") fail-three?) + (try two/protect three/pnabbed (if fail-pnab? #rx#"protected" #rx#"zero .8.") fail-three?) + (try two/protect three/snabbed (if (and fail-prot? (not np-ok?) (not via-2-ok?)) #rx#"unexported .* stx" #rx#"one .13.") fail-three?) + (try two/protect three/normal (if fail-prot? #rx#"protected" #rx#"two .10.") fail-three?))) (define (unsafe-try unsafe get-inspector unsafe-fail? unsafe-ref-fail? read-fail?) (let ([ns (make-base-namespace)] @@ -408,26 +376,26 @@ three/normal-zo make-inspector current-code-inspector #t #f #f #f #t) (unsafe-try unsafe-zo make-inspector #f #f #t) -(unsafe-try unsafe-synth-zo make-inspector #f #t #f) -(displayln "zo and source, second:") +(displayln "source and zo, change inspector:") (mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed-zo three/nfnabbed three/nfpnabbed three/nfsnabbed-zo three/normal - make-inspector current-code-inspector #t #f #t #f #t) + current-code-inspector make-inspector #t #t #t #t #t + #:early-ok? #t) (unsafe-try unsafe make-inspector #t #t #f) -(displayln "zo and source, third:") +(displayln "zo, change inspector:") (mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/nfnabbed-zo three/nfpnabbed-zo three/nfsnabbed-zo three/normal-zo - current-code-inspector make-inspector #t #t #f #f #f) + make-inspector make-inspector #t #t #f #f #f #:via-2-ok? #t) (displayln "just source, weaken inspector:") (mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed three/normal - current-code-inspector make-inspector #t #t #t #t #f) + current-code-inspector make-inspector #t #t #t #f #f #:unprot-ok? #t #:early-ok? #t) ;; ---------------------------------------- @@ -450,4 +418,13 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(parameterize ([current-namespace (make-base-namespace)] + [current-code-inspector (make-inspector)]) + (eval + ;; This compilation is intended to inline a call to `gen-for-each`, + ;; and the test is meant to ensure that the reference is allowed + (compile '(lambda (f) (for-each f '(1 2 3 4 5)))))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index a84f8bba65..06e4797f2a 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -118,14 +118,14 @@ (syntax-test #'(module m racket/base (#%require (all-except n . n)))) (syntax-test #'(module m racket/base (#%require (rename)))) (syntax-test #'(module m racket/base (#%require (rename . n)))) -(syntax-test #'(module m racket/base (#%require (rename n)))) -(syntax-test #'(module m racket/base (#%require (rename n . n)))) -(syntax-test #'(module m racket/base (#%require (rename n n)))) -(syntax-test #'(module m racket/base (#%require (rename n n . m)))) -(syntax-test #'(module m racket/base (#%require (rename n 1 m)))) -(syntax-test #'(module m racket/base (#%require (rename n n 1)))) -(syntax-test #'(module m racket/base (#%require (rename n n not-there)))) -(syntax-test #'(module m racket/base (#%require (rename n n m extra)))) +(syntax-test #'(module m racket/base (#%require (rename 'n)))) +(syntax-test #'(module m racket/base (#%require (rename 'n . n)))) +(syntax-test #'(module m racket/base (#%require (rename 'n n)))) +(syntax-test #'(module m racket/base (#%require (rename 'n n . m)))) +(syntax-test #'(module m racket/base (#%require (rename 'n 1 m)))) +(syntax-test #'(module m racket/base (#%require (rename 'n n 1)))) +(syntax-test #'(module m racket/base (#%require (rename 'n n not-there)))) +(syntax-test #'(module m racket/base (#%require (rename 'n n m extra)))) (syntax-test #'(module m racket/base (define x 6) (define x 5))) (syntax-test #'(module m racket/base (define x 10) (define-syntax x 10))) @@ -971,7 +971,7 @@ (define b-s (compile-m b-expr (list a-s))) (define temp-dir (find-system-path 'temp-dir)) - (define dir (build-path temp-dir "compiled")) + (define dir (build-path temp-dir (car (use-compiled-file-paths)))) (define dir-existed? (directory-exists? dir)) (unless dir-existed? (make-directory dir)) @@ -1132,7 +1132,7 @@ '(rename-out [z x]) "x" ;; slow: - "exp\nexp\nrun\nexp\nexp\n"))]) + "exp\nexp\nrun\nexp\n"))]) (define ns (make-base-namespace)) (define o (open-output-string)) (parameterize ([current-output-port o]) @@ -1279,7 +1279,7 @@ case of module-leve bindings; it doesn't cover local bindings. (define vlen (bytes-ref s (+ start 2))) (define mode (integer->char (bytes-ref s (+ start 3 vlen)))) (case mode - [(#\T) + [(#\B) (define h (make-bytes 20 (+ 42 c))) (bytes-copy! s (+ start 4 vlen) h)] [(#\D) @@ -1303,8 +1303,8 @@ case of module-leve bindings; it doesn't cover local bindings. (module s racket/base (provide x) (define x 1))))) - (make-directory* (build-path dir "compiled")) - (define zo-path (build-path dir "compiled" "tmx_rkt.zo")) + (make-directory* (build-path dir (car (use-compiled-file-paths)))) + (define zo-path (build-path dir (car (use-compiled-file-paths)) "tmx_rkt.zo")) (define bstr (let ([b (open-output-bytes)]) @@ -1335,8 +1335,8 @@ case of module-leve bindings; it doesn't cover local bindings. (define e (compile '(module tmx2 racket/kernel (#%provide x) (define-values (x) 1)))) - (make-directory* (build-path dir "compiled")) - (define zo-path (build-path dir "compiled" "tmx2_rkt.zo")) + (make-directory* (build-path dir (car (use-compiled-file-paths)))) + (define zo-path (build-path dir (car (use-compiled-file-paths)) "tmx2_rkt.zo")) (define bstr (let ([b (open-output-bytes)]) @@ -1478,6 +1478,46 @@ case of module-leve bindings; it doesn't cover local bindings. (test 11 dynamic-require ''module-lift-example-3 'out) +(module module-lift-example-4 racket/base + (require (for-syntax racket/base)) + + (define-syntax (main stx) + (syntax-case stx () + [(_ body ...) + (syntax-local-lift-module #`(module* main #f (main-method))) + #'(define (main-method) + body ...)])) + + (provide out) + (define out #f) + + (main (set! out 12))) + +(test (void) dynamic-require '(submod 'module-lift-example-4 main) #f) +(test 12 dynamic-require ''module-lift-example-4 'out) + +(module module-lift-example-5 racket/base + (module a racket/base + (require (for-syntax racket/base)) + + (provide main) + + (define-syntax (main stx) + (syntax-case stx () + [(_ body ...) + (syntax-local-lift-module #`(module* main #f (main-method))) + #'(define (main-method) + body ...)]))) + + (module b racket/base + (require (submod ".." a)) + (provide out) + (define out #f) + (main (set! out 13)))) + +(test (void) dynamic-require '(submod 'module-lift-example-5 b main) #f) +(test 13 dynamic-require '(submod 'module-lift-example-5 b) 'out) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check addition of 'disappeared-use by `provide` @@ -1677,23 +1717,23 @@ case of module-leve bindings; it doesn't cover local bindings. (define tmp (make-temporary-file "~a-module-test" 'directory)) (parameterize ([current-directory tmp] [current-load-relative-directory tmp]) - (make-directory "compiled") + (make-directory* (car (use-compiled-file-paths))) (call-with-output-file* - "compiled/a_rkt.zo" + (build-path (car (use-compiled-file-paths)) "a_rkt.zo") (lambda (o) (write (compile '(module a racket/base - (provide (all-defined-out)) - (define a 1) - (define b 2) - (define c 3))) - o))) + (provide (all-defined-out)) + (define a 1) + (define b 2) + (define c 3))) + o))) (call-with-output-file* - "compiled/b_rkt.zo" + (build-path (car (use-compiled-file-paths)) "b_rkt.zo") (lambda (o) (write (compile '(module b racket/base - (require "a.rkt" - ;; Force saving of context, instead of - ;; reconstruction: - (only-in racket/base [car extra-car])))) - o)))) + (require "a.rkt" + ;; Force saving of context, instead of + ;; reconstruction: + (only-in racket/base [car extra-car])))) + o)))) (dynamic-require (build-path tmp "b.rkt") #f) (define ns (module->namespace (build-path tmp "b.rkt"))) (test #t @@ -1905,6 +1945,42 @@ case of module-leve bindings; it doesn't cover local bindings. (namespace-syntax-introduce (dynamic-require ''provide-the-x-identifier 'x-id)))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that `all-defined` exports at only the right phase + +(module module-that-exports-at-phase-0-only racket/kernel + (#%require (for-syntax racket/kernel)) + (#%provide (all-defined)) + (define-values (x) 1) + (begin-for-syntax + (define-values (x) 2))) + +(module module-that-imports-at-multiple-phases racket/kernel + (#%require 'module-that-exports-at-phase-0-only + ;; Causes a collsion if the module exports too much + (for-syntax 'module-that-exports-at-phase-0-only))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that a top-level binding doesn't interefere +;; with reference + +(define very-confused-x 1) + +(module m-that-defines-very-confused-x racket + ;; this line is necessary, but you can require anything + ;;(require (only-in racket/base)) + + (define very-confused-x 10)) + +(require 'm-that-defines-very-confused-x) + +(test 10 + 'very-confused-x + (parameterize ([current-namespace (module->namespace ''m-that-defines-very-confused-x)]) + ;; Note: #'very-confused-x will have top-level context + ;; as well as the module context + (eval #'very-confused-x))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Make sure that re-expansion of a simple (in the sense of `require` ;; information kept for `module->namspace`) module body is ok @@ -2067,6 +2143,125 @@ case of module-leve bindings; it doesn't cover local bindings. (eval '(f m) ns) (eval '(m) ns))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Make sure a module can exports syntax bound to a rename transformer +;; to an unbound identifier + +(let ([decl + '(module provides-rename-transformer-to-nowhere '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide x) + (define-syntaxes (x) (make-rename-transformer (quote-syntax y))))]) + (define o (open-output-bytes)) + (write (compile decl) o) + (eval (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes (get-output-bytes o)))))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Make sure `variable-reference->namespace` at phase 1 +;; doesn't interfere with re-expansion when trigged +;; by a submodule +;; +;; This test is by William Bowman, Michael Ballantyne, and +;; Leif Andersen. + +(let ([m '(module namespace-mismatch racket/base + (#%plain-module-begin + + (#%require (for-syntax racket/base)) + + (begin-for-syntax + (let ([ns (variable-reference->namespace (#%variable-reference))]) + ;; The top level at phase 1 ... + (eval #'(define-syntax-rule (m) (begin (define x 2) x)) ns) + ;; The expander will have to find the right macro-introduced `x`: + (eval #'(m) ns)) + (#%plain-lambda () foo)) + + (begin-for-syntax + (define-values (foo) #f)) + + (module* f #f + (#%plain-module-begin))))]) + (expand (expand m))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Make sure that prefixing a submodule require doesn't +;; run into trouble related to the expand-time submodule +;; instance not being registered in the bulk-binding +;; provides table + +(module check-prefixed-bulk-provides-from-submodules racket/base + (module a racket/base + (provide a1 a2 a3) + (define a1 'a1) + (define a2 'a2) + (define a3 'a3)) + + (require (prefix-in a: 'a)) + + (define another 'x)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Allow a reference to a never-defined variable in a `local-expand` +;; or `syntax-local-bind-syntaxes` on the grounds that the result is +;; not necessarily in the module's expansion. But keep track of +;; missing variables encountered during +;; `syntax-local-expand-expression`, since the opqaue result can be +;; included without further inspection. + +(module im-ok-and-your-ok-local-expand racket/base + (require (for-syntax racket/base) + (for-meta 2 racket/base)) + (begin-for-syntax + (define-syntax (m stx) + (local-expand #'(lambda () nonesuch) 'expression '()) + #''ok) + (m))) + +(module im-ok-and-your-ok-syntax-local-bind-syntaxes racket/base + (require (for-syntax racket/base)) + (define-syntax (m stx) + (syntax-local-bind-syntaxes (list #'x) + #'(lambda () nonesuch) + (syntax-local-make-definition-context)) + #''ok) + (m)) + +(syntax-test #'(module im-ok-and-your-ok-local-expand racket/base + (require (for-syntax racket/base) + (for-meta 2 racket/base)) + (begin-for-syntax + (define-syntax (m stx) + (syntax-local-expand-expression #'(lambda () nonesuch)) + #''ok) + (m)))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Make sure that shadowing in phase 1 doesn't +;; prevent `all-from-out` from providing the same +;; binding unshadowed at phase 0 + +(module check-shadowing-in-other-phase-d racket/base + (provide b) + (define b 'd)) + +(module check-shadowing-in-other-phase-c racket/base + (require (for-syntax racket/base)) + (provide b (all-from-out racket/base) + (for-syntax b)) + (define b 'c) + (define-for-syntax b 'c1)) + +(module check-shadowing-in-other-phase-b 'check-shadowing-in-other-phase-c + (require (for-syntax 'check-shadowing-in-other-phase-d)) + (provide (all-from-out 'check-shadowing-in-other-phase-c) + (for-syntax (all-from-out 'check-shadowing-in-other-phase-d)))) + +(module check-shadowing-in-other-phase-a racket/base + (require 'check-shadowing-in-other-phase-b) + b) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/namespac.rktl b/pkgs/racket-test-core/tests/racket/namespac.rktl index f3ed3618af..e5cf9c851b 100644 --- a/pkgs/racket-test-core/tests/racket/namespac.rktl +++ b/pkgs/racket-test-core/tests/racket/namespac.rktl @@ -109,7 +109,7 @@ (arity-test namespace-mapped-symbols 0 1) (arity-test namespace-variable-value 1 4) -(arity-test namespace-set-variable-value! 2 4) +(arity-test namespace-set-variable-value! 2 5) (arity-test namespace-undefine-variable! 1 2) (define n (make-base-namespace)) @@ -147,7 +147,7 @@ (test #f variable-reference->module-path-index (#%variable-reference test)) -(test (module-path-index-join ''#%kernel #f) +(test (module-path-index-join ''#%runtime #f) variable-reference->module-path-index (#%variable-reference +)) (require (only-in racket/unsafe/ops [unsafe-fx+ $$unsafe-fx+])) diff --git a/pkgs/racket-test-core/tests/racket/numstrs.rktl b/pkgs/racket-test-core/tests/racket/numstrs.rktl index 061229bf23..b6e0edaf6c 100644 --- a/pkgs/racket-test-core/tests/racket/numstrs.rktl +++ b/pkgs/racket-test-core/tests/racket/numstrs.rktl @@ -6,6 +6,7 @@ (define number-table `((,(+ 1/2 +i) "1/2+i") + (1.2+1i "1.2+i") (100 "100") (100 "#d100") (0.1 ".1") @@ -28,6 +29,8 @@ (0.0 "0e13") (0.0 "#i0") (-0.0 "#i-0") + (0.0 "0#") + (-0.0 "-0#") (+inf.0 ".3e2666666666") (+inf.0 "+INF.0") (+nan.0 "+NaN.0") @@ -78,6 +81,10 @@ (1/20 "#e0.5e-1") (1/20 "#e0.005e1") (1.0+0.5i "1+0.5i") + (0+1i "+i") + (0-1i "-i") + (1.0-0.0i "#i1-0i") + (1 "1-0i") (1/2 "1/2@0") (-1/2 "-1/2@0") (1/2 "1/2@-0") @@ -111,6 +118,8 @@ (X "#d1#/#3") (+inf.0 "1/0#") (-inf.0 "-1/0#") + (DBZ "1#/0") + (DBZ "-1#/0") (NOE "#e+inf.0") (NOE "#e-inf.0") (NOE "#e+nan.0") @@ -176,6 +185,10 @@ (#f "-+1") (#f "-1+3-4") (#f "1\0002") + (#f "1/2+3") + (#f "1.2+3") + (#f "2+1/2") + (#f "3+1.2") (X "#xg") (X "#x") (X "#xa#a") @@ -251,4 +264,17 @@ (DBZ "1/0@+inf.0") (DBZ "+inf.0@1/0") (#f "1e1/0") - (#f "011111122222222223333333333444444x"))) + (#f "011111122222222223333333333444444x") + (#f "t") + (#f "s2") + (#f "2e") + (#f ".e1") + (#f "+.e1") + (#f "+#e1") + (#f "1e#") + (#f "1e+") + (#f "1e+-") + (#f ".#e1") + (#f "/2") + (#f "-#/2") + (X "#/2"))) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 3e43555e87..02541a2da3 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -530,13 +530,13 @@ (test-comp '(lambda (w z) (pair? (list w (random) w))) '(lambda (w z) (random) #t)) (test-comp '(lambda (w z) (pair? (list (read) (random) w))) - '(lambda (w z) (read) (random) #t)) + '(lambda (w z) (values (read)) (random) #t)) (test-comp '(lambda (w z) (pair? (list z (random) (read)))) - '(lambda (w z) (random) (read) #t)) + '(lambda (w z) (random) (values (read)) #t)) (test-comp '(lambda (w z) (pair? (list (if z (random) (error 'e)) (read)))) - '(lambda (w z) (if z (random) (error 'e)) (read) #t)) + '(lambda (w z) (if z (random) (error 'e)) (values (read)) #t)) (test-comp '(lambda (w z) (pair? (list (with-continuation-mark 'k 'v (read)) (random)))) - '(lambda (w z) (with-continuation-mark 'k 'v (read)) (random) #t)) + '(lambda (w z) (values (with-continuation-mark 'k 'v (read))) (random) #t)) (test-comp '(lambda (w z) (vector? (vector w z))) '(lambda (w z) #t)) (test-comp '(lambda (w z) (vector? (vector-immutable w z))) @@ -713,8 +713,11 @@ ;The optimizer is not capable of figuring out that the result of map is a list? (test-arg-types '(k:map procedure? list?) 'list?) (test-arg-types '(k:map procedure? list? list?) 'list?) -(test-arg-types '(map procedure? list?) #f) ;should be list? -(test-arg-types '(map procedure? list? list?) #f) ;should be list? + +;Non-inlined slow-path means that the optimizer cannot infer for +;non-built-in `map`: +;(test-arg-types '(map procedure? list?) #f) ;should be list? +;(test-arg-types '(map procedure? list? list?) #f) ;should be list? (test-comp '(lambda (w z) (let ([x (list* w z)] @@ -1186,6 +1189,9 @@ (begin (quote-syntax foo) 3))]) x) '3) + +;; The compiler doens't currently recognize the expansion of `quote-syntax` +#; (test-comp '(if (lambda () 10) 'ok (quote-syntax no!)) @@ -2140,6 +2146,8 @@ (void 10)) '(module m racket/base)) +;; The compiler doens't currently recognize the expansion of `quote-syntax` +#; (test-comp '(module m racket/base (void (quote-syntax unused!))) '(module m racket/base)) @@ -3003,6 +3011,7 @@ (require (submod ".." a)) (list b c (c))))) + (test-comp `(module m racket/base (module a racket/base (provide b c) @@ -3032,6 +3041,36 @@ (require (submod ".." a)) (list b c (c 1))))) +;; Use of `c` added to `a` via `b` +(test-comp `(module m racket/base + (module c racket/base + (provide c) + (define c 'c) + (set! c c)) + (module b racket/base + (require (submod ".." c)) + (provide b) + (define (b) c)) + (module a racket/base + (require (submod ".." b) + (submod ".." c)) + c + (b))) + `(module m racket/base + (module c racket/base + (provide c) + (define c 'c) + (set! c c)) + (module b racket/base + (require (submod ".." c)) + (provide b) + (define (b) c)) + (module a racket/base + (require (submod ".." b) + (submod ".." c)) + c + c))) + (module check-inline-request racket/base (require racket/performance-hint) (provide loop) @@ -4053,19 +4092,19 @@ (test-comp '(letrec-values ([(x y) (error "oops")]) 11) '(error "oops")) (test-comp '(let-values (((y) (read)) (() (error "oops"))) 11) - '(let () (begin (read) (error "oops")))) + '(let () (begin (values (read)) (error "oops")))) (test-comp '(let-values (((y) (read)) (() (error "oops"))) 11) - '(let () (begin (read) (error "oops")))) + '(let () (begin (values (read)) (error "oops")))) (test-comp '(let-values ((() (error "oops")) ((x) 9)) 11) '(error "oops")) (test-comp '(let-values ((() (error "oops")) (() (values))) 11) '(error "oops")) (test-comp '(let-values (((y) (read)) (() (error "oops")) ((x) 9)) 11) - '(let () (begin (read) (error "oops")))) + '(let () (begin (values (read)) (error "oops")))) (test-comp '(let-values (((y) (read)) (() (error "oops")) (() (values))) 11) - '(let () (begin (read) (error "oops")))) + '(let () (begin (values (read)) (error "oops")))) (test-comp '(error "oops") - '(let () (begin (read) (error "oops"))) + '(let () (begin (values (read)) (error "oops"))) #f) (test-comp '(with-continuation-mark @@ -5013,24 +5052,28 @@ (write-bytes (zo-marshal (match m - [(compilation-top max-let-depth binding-namess prefix code) - (compilation-top max-let-depth binding-namess prefix - (let ([body (mod-body code)]) - (struct-copy mod code [body - (match body - [(list a b) - (list (match a - [(application rator (list rand)) - (application - rator - (list - (struct-copy - lam rand - [body - (match (lam-body rand) - [(toplevel depth pos const? ready?) - (toplevel depth pos #t #t)])])))]) - b)])])))])) + [(linkl-bundle t) + (linkl-bundle + (hash-set t + 0 + (let* ([l (hash-ref t 0)] + [body (linkl-body l)]) + (struct-copy linkl l [body + (match body + [(list a b c) + (list (match a + [(application rator (list rand)) + (application + rator + (list + (struct-copy + lam rand + [body + (match (lam-body rand) + [(toplevel depth pos const? ready?) + (toplevel depth pos #t #t)])])))]) + b + c)])]))))])) o2)) ;; validator should reject this at read or eval time (depending on how lazy validation is): @@ -5058,7 +5101,8 @@ ; extract the content of the begin0 expression (define (analyze-beg0 m) - (define def-z (car (mod-body (compilation-top-code m)))) + (define lb (hash-ref (linkl-directory-table m)'())) + (define def-z (car (linkl-body (hash-ref (linkl-bundle-table lb) 0)))) (define body-z (let-one-body (def-values-rhs def-z))) (define expr-z (car (beg0-seq body-z))) (cond @@ -5272,8 +5316,9 @@ (write (compile l) o) (parameterize ([read-accept-compiled #t]) (zo-parse (open-input-bytes (get-output-bytes o)))))) - (let* ([m (compilation-top-code b)] - [d (car (mod-body m))] + (let* ([lb (hash-ref (linkl-directory-table b) '())] + [m (hash-ref (linkl-bundle-table lb) 0)] + [d (car (linkl-body m))] [b (closure-code (def-values-rhs d))] [c (application-rator (lam-body b))] [l (closure-code c)] @@ -5294,8 +5339,9 @@ (write (compile l) o) (parameterize ([read-accept-compiled #t]) (zo-parse (open-input-bytes (get-output-bytes o)))))) - (let* ([m (compilation-top-code b)] - [d (car (mod-body m))] + (let* ([lb (hash-ref (linkl-directory-table b) '())] + [m (hash-ref (linkl-bundle-table lb) 0)] + [d (car (linkl-body m))] [rhs (def-values-rhs d)] [b (inline-variant-direct rhs)] [v (application-rator (lam-body b))]) @@ -5313,8 +5359,9 @@ (write (compile l) o) (parameterize ([read-accept-compiled #t]) (zo-parse (open-input-bytes (get-output-bytes o)))))) - (let* ([m (compilation-top-code b)] - [d (cadr (mod-body m))] + (let* ([lb (hash-ref (linkl-directory-table b) '())] + [m (hash-ref (linkl-bundle-table lb) 0)] + [d (cadr (linkl-body m))] [rhs (def-values-rhs d)] [b (inline-variant-direct rhs)] [v (application-rator (lam-body b))]) @@ -5409,7 +5456,7 @@ (lambda () (with-handlers ([exn:fail:out-of-memory? void]) (arithmetic-shift 1 30070458541082))))))) -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (void (dynamic-require ''uses-too-much-memory-for-shift #f))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/pkgs/racket-test-core/tests/racket/param.rktl b/pkgs/racket-test-core/tests/racket/param.rktl index 20c44b83c2..79626332d9 100644 --- a/pkgs/racket-test-core/tests/racket/param.rktl +++ b/pkgs/racket-test-core/tests/racket/param.rktl @@ -35,7 +35,7 @@ (if erroring-set? (begin (set! erroring-set? #f) - (error 'output)) + (error 'output "~s" s)) (display (subbytes s start end) orig)) (- end start))) void)) @@ -267,7 +267,7 @@ (list current-output-port (list (current-output-port) erroring-port) - '(begin + '(let () (set! erroring-set? #t) (display 5) (set! erroring-set? #f)) @@ -420,7 +420,7 @@ [expr (caddr d)] [exn? (cadddr d)]) (parameterize ([param alt1]) - (test (void) void (teval expr))) + (test (void) void (eval expr))) (parameterize ([param alt2]) (error-test (datum->syntax #f expr #f) exn?)))) params) diff --git a/pkgs/racket-test-core/tests/racket/port.rktl b/pkgs/racket-test-core/tests/racket/port.rktl index c9f71f63ee..abba3a0e2c 100644 --- a/pkgs/racket-test-core/tests/racket/port.rktl +++ b/pkgs/racket-test-core/tests/racket/port.rktl @@ -150,6 +150,7 @@ ;; This port produces 0, 1, 2, 0, 1, 2, etc, ;; but it is not thread-safe, because multiple ;; threads might read and change n +(define mod3-peeked? #f) (define mod3-cycle/one-thread (let* ([n 2] [mod! (lambda (s delta) @@ -157,14 +158,16 @@ 1)]) (make-input-port 'mod3-cycle/not-thread-safe - (lambda (s) + (lambda (s) (set! n (modulo (add1 n) 3)) (mod! s 0)) - (lambda (s skip progress-evt) - (mod! s skip)) + (lambda (s skip progress-evt) + (set! mod3-peeked? #t) + (mod! s (add1 skip))) void))) (test "01201" read-string 5 mod3-cycle/one-thread) -(test "20120" peek-string 5 (expt 2 5000) mod3-cycle/one-thread) +(test #f values mod3-peeked?) +(test "20120" peek-string 5 (sub1 (expt 2 5000)) mod3-cycle/one-thread) ;; Same thing, but thread-safe and kill-safe, and with progress ;; events. Only the server thread touches the stateful part @@ -520,7 +523,12 @@ (let ([s (make-bytes 6 (char->integer #\-))]) (test 5 read-bytes-avail! s in) (test #"12311-" values s)) - (test 3 write-bytes-avail #"1234" out)) + (test 3 values + (let loop ([n 0]) + (define v (write-bytes-avail* #"1234" out)) + (if (zero? v) + n + (loop (+ n v)))))) ;; Further test of peeking in a limited pipe (shouldn't get stuck): (let-values ([(i o) (make-pipe 50)] @@ -633,11 +641,13 @@ (peek-byte r) (let ([t (thread (lambda () (port-commit-peeked 1 (port-progress-evt r) ch r)))]) - (sleep 0.01) + (sync (system-idle-evt)) (let ([t2 (thread (lambda () (port-commit-peeked 1 (port-progress-evt r) ch r)))]) - (sleep 0.01) + (sync (system-idle-evt)) + (test #t thread-running? t) + (test #t thread-running? t2) (thread-suspend t2) (break-thread t2) (kill-thread t) @@ -657,9 +667,9 @@ void)]) (let ([t (thread (lambda () (with-handlers ([exn:break? void]) (read-char p))))]) - (sleep 0.1) + (sync (system-idle-evt)) (break-thread t) - (sleep 0.1) + (sync (system-idle-evt)) (test #f thread-running? t))))]) (try sync) (try sync/enable-break) diff --git a/pkgs/racket-test-core/tests/racket/procs.rktl b/pkgs/racket-test-core/tests/racket/procs.rktl index 5ec739d07f..3d55041358 100644 --- a/pkgs/racket-test-core/tests/racket/procs.rktl +++ b/pkgs/racket-test-core/tests/racket/procs.rktl @@ -288,7 +288,7 @@ (list allowed))) (begin (when (procedure-arity-includes? p 1 #t) - (err/rt-test (procedure-reduce-arity p 1) #rx"has required keyword arguments")) + (err/rt-test (procedure-reduce-arity p 1) exn:fail? #rx"has required keyword arguments")) (list (procedure-reduce-arity p '()) '() '() '() method? p)))))) procs) ;; reduce to arity 0 or nothing --- no keywords: diff --git a/pkgs/racket-test-core/tests/racket/prompt-tests.rktl b/pkgs/racket-test-core/tests/racket/prompt-tests.rktl index 5f7411d455..ef74e8773c 100644 --- a/pkgs/racket-test-core/tests/racket/prompt-tests.rktl +++ b/pkgs/racket-test-core/tests/racket/prompt-tests.rktl @@ -798,7 +798,6 @@ p2)) (lambda () (out 'post1)))) p1)) - (printf "here ~a\n" count) (set! count (add1 count)) (unless (= count 3) (call-with-continuation-prompt @@ -1989,7 +1988,7 @@ ;; the C stack. Eventually, the relevant segment wraps around, ;; with an overflow. Push a little deeper and then capture ;; that. - (let loop ([n 0][fuel #f]) + (let loop ([n 0] [fuel (if (eq? (system-type 'vm) 'chez-scheme) 500 #f)]) (vector-set-performance-stats! v) (cond [(and (not fuel) diff --git a/pkgs/racket-test-core/tests/racket/prompt.rktl b/pkgs/racket-test-core/tests/racket/prompt.rktl index b99831f63f..3e255abd3c 100644 --- a/pkgs/racket-test-core/tests/racket/prompt.rktl +++ b/pkgs/racket-test-core/tests/racket/prompt.rktl @@ -450,7 +450,7 @@ ;; Check that a continuation doesn't retain the arguments ;; to the call to `call/cc` that created the continuation. -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (let ([ht (make-weak-hasheq)]) (define l (for/list ([i 100]) diff --git a/pkgs/racket-test-core/tests/racket/read.rktl b/pkgs/racket-test-core/tests/racket/read.rktl index 920951a1e9..253adfe7bd 100644 --- a/pkgs/racket-test-core/tests/racket/read.rktl +++ b/pkgs/racket-test-core/tests/racket/read.rktl @@ -483,7 +483,7 @@ (test 0 syntax->datum (vector-ref (syntax-e (read-syntax #f (open-input-string "#2()"))) 1)) (err/rt-test (readstr "#2(1 2 3)") exn:fail:read?) -(err/rt-test (readstr "#200000000000(1 2 3)") (readerrtype exn:fail:out-of-memory?)) +(err/rt-test (readstr "#2000000000000000(1 2 3)") (readerrtype exn:fail:out-of-memory?)) (err/rt-test (readstr "#111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111x1(1 2 3)") exn:fail:read?) (test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#1=(1 2) . #0001#)")) @@ -574,6 +574,7 @@ ;; Test mid-stream EOF (define (test-mid-stream-eof use-peek?) +(define no-peek? #f) (define chars (map (lambda (x) (if (char? x) (char->integer x) x)) (append @@ -1181,7 +1182,7 @@ (test (void) read-language (open-input-string ";;\n;\n#xa") void) ;; Check error-message formatting: (err/rt-test (read (open-input-string "#l")) - (lambda (exn) (regexp-match? #rx"`#l'" (exn-message exn)))) + (lambda (exn) (regexp-match? #rx"`#l`" (exn-message exn)))) ;; Make sure read-language error here is this can comes from read-language ;; and not from an ill-formed srcloc construction: (let () @@ -1190,6 +1191,8 @@ (err/rt-test (read-language p) (lambda (exn) (regexp-match? #rx"read-language" (exn-message exn))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (require racket/flonum racket/fixnum) (test #t flvector? (readstr "#fl(1.5 0.33 0.3)")) diff --git a/pkgs/racket-test-core/tests/racket/readtable.rktl b/pkgs/racket-test-core/tests/racket/readtable.rktl index d2ebe3fa2d..dd2760dc57 100644 --- a/pkgs/racket-test-core/tests/racket/readtable.rktl +++ b/pkgs/racket-test-core/tests/racket/readtable.rktl @@ -157,7 +157,7 @@ (let ([s1 (format "a~ab" ch)] [s2 (format "~aab~a" ch ch)]) (test-read s1 (list (string->symbol s1))) - (test-read s2 (list (string->symbol s2)) #f) + (test-read s2 (list (string->symbol s2)) #f) (let ([blank (if (char=? ch #\space) #\newline #\space)]) diff --git a/pkgs/racket-test-core/tests/racket/rx.rktl b/pkgs/racket-test-core/tests/racket/rx.rktl index ee9e79c024..13db7a54c0 100644 --- a/pkgs/racket-test-core/tests/racket/rx.rktl +++ b/pkgs/racket-test-core/tests/racket/rx.rktl @@ -1787,10 +1787,12 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test failure handlers -(test "`+' follows nothing in pattern" regexp "+" (λ (s) s)) -(test "`+' follows nothing in pattern" pregexp "+" (λ (s) s)) -(test "`+' follows nothing in pattern" byte-regexp #"+" (λ (s) s)) -(test "`+' follows nothing in pattern" byte-pregexp #"+" (λ (s) s)) +(define (requote s) (regexp-replace* #rx"'" s "`")) + +(test "`+` follows nothing in pattern" regexp "+" requote) +(test "`+` follows nothing in pattern" pregexp "+" requote) +(test "`+` follows nothing in pattern" byte-regexp #"+" requote) +(test "`+` follows nothing in pattern" byte-pregexp #"+" requote) (test 3 regexp "+" (λ (s) (+ 1 2))) (test 3 pregexp "+" (λ (s) (+ 1 2))) (test 3 byte-regexp #"+" (λ (s) (+ 1 2))) @@ -1798,7 +1800,7 @@ (test-values '(1 2 3) (lambda () (byte-pregexp #"+" (λ (s) (values 1 2 3))))) -(err/rt-test (regexp "+" #f) (lambda (exn) (regexp-match? "`[+]' follows nothing in pattern" (exn-message exn)))) +(err/rt-test (regexp "+" #f) (lambda (exn) (regexp-match? "`[+]. follows nothing in pattern" (exn-message exn)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Make sure that negated patterns as literal strings are not recorded diff --git a/pkgs/racket-test-core/tests/racket/sandbox.rktl b/pkgs/racket-test-core/tests/racket/sandbox.rktl index 5c4174aea4..e5cc0e540c 100644 --- a/pkgs/racket-test-core/tests/racket/sandbox.rktl +++ b/pkgs/racket-test-core/tests/racket/sandbox.rktl @@ -459,7 +459,9 @@ (copy-file ,test-zo ,list-zo) =err> "access denied" ;; timestamp .zo file (needed under Windows): (file-or-directory-modify-seconds ,test-zo (current-seconds)) - ;; loading test gets 'list module declaration via ".zo": + ;; loading test gets 'list module declaration via ".zo", thanks + ;; to delayed parsing of the bytecode (so this test doesn't work + ;; if delay-loading is disabled): (load/use-compiled ,test-lib) => (void) ;; but the module declaration can't execute due to the inspector: (require 'list) =err> "access disallowed by code inspector" @@ -671,7 +673,7 @@ (define r1 (try 'racket/base)) (define r2 (try '(begin))) (test #t regexp-match? - #rx"access disallowed by code inspector to protected variable" + #rx"access disallowed by code inspector to protected" r1) (test #t equal? r1 r2)) diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index 9d461a82b5..09c807253b 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -39,6 +39,16 @@ (syntax-test #'(quote-syntax)) (syntax-test #'(quote-syntax . 7)) +;; Property is attached only to immediate syntax object: +(test #f + syntax-property + (car (syntax-e (datum->syntax #f '(a) #f (syntax-property #'x 'ok 'value)))) + 'ok) +(test 'value + syntax-property + (datum->syntax #f '(a) #f (syntax-property #'x 'ok 'value)) + 'ok) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; some syntax-case patterns ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -542,14 +552,14 @@ (define base-lib (caddr (identifier-binding* #'lambda))) -(test `('#%kernel case-lambda ,base-lib case-lambda 0 0 0) +(test `('#%core case-lambda ,base-lib case-lambda 0 0 0) identifier-binding* #'case-lambda) (test `("private/promise.rkt" delay* ,base-lib delay 0 0 0) identifier-binding* #'delay) -(test `('#%kernel #%module-begin ,base-lib #%plain-module-begin 0 0 0) +(test `('#%core #%module-begin ,base-lib #%plain-module-begin 0 0 0) identifier-binding* #'#%plain-module-begin) (require (only-in racket/base [#%plain-module-begin #%pmb])) -(test '('#%kernel #%module-begin racket/base #%plain-module-begin 0 0 0) +(test '('#%core #%module-begin racket/base #%plain-module-begin 0 0 0) identifier-binding* #'#%pmb) (let ([b (identifier-binding @@ -1535,7 +1545,7 @@ (test '(10 20 #t) '@!$get @!$get) |# -(test '(12) +(test '(1) ; old expander produced 12 eval (expand #'(let ([b 12]) @@ -1858,6 +1868,21 @@ (syntax-arm #'(begin (define-values (x y z) (values 1 2 3))) #f #t))))))) +(let () + (define i1 (make-inspector)) + (define i2 (make-inspector)) + + (define x (syntax-arm #'(x) i1)) + + (test #f syntax-tainted? (car (syntax-e (syntax-disarm x i1)))) + (test #t syntax-tainted? (car (syntax-e (syntax-disarm x i2)))) + + (define y (syntax-rearm (syntax-arm #'(y) i2) x)) + + (test #t syntax-tainted? (car (syntax-e (syntax-disarm y i1)))) + (test #t syntax-tainted? (car (syntax-e (syntax-disarm y i2)))) + (test #f syntax-tainted? (car (syntax-e (syntax-disarm (syntax-disarm y i1) i2))))) + (let ([round-trip (lambda (stx) (parameterize ([current-namespace (make-base-namespace)]) @@ -1969,7 +1994,7 @@ (require (for-syntax racket/base)) (begin-for-syntax (displayln (syntax-transforming-module-expression?)))))) - (test "#t\n#f\n" get-output-string o)) + (test "#t\n#t\n" get-output-string o)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check that a common wraps encoding that is detected only @@ -2477,7 +2502,7 @@ (err/rt-test (syntax-property #'+ 1 #'+ #t) (lambda (exn) (regexp-match - #rx"expected an interned symbol key for a preserved property" + #rx"key for a perserved property must be an interned symbol" (exn-message exn)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2495,7 +2520,7 @@ (write (compile (read-syntax path p)) out) (eval (read in)) (define src (syntax-source ((dynamic-require path 'f)))) - (test (path->string path) values src))) + (test path values src))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/pkgs/racket-test-core/tests/racket/submodule.rktl b/pkgs/racket-test-core/tests/racket/submodule.rktl index 0912757c6a..73d515f16c 100644 --- a/pkgs/racket-test-core/tests/racket/submodule.rktl +++ b/pkgs/racket-test-core/tests/racket/submodule.rktl @@ -147,8 +147,8 @@ (write also-c s) (parameterize ([read-accept-compiled #t]) (read (open-input-bytes (get-output-bytes s)))))) - ;; Marshaling flips the order, which is ok: - (test '(subm-example-0 b) values (module-compiled-name (car (module-compiled-submodules re-c #f))))) + ;; Marshaling preserves the order: + (test '(subm-example-0 a) values (module-compiled-name (car (module-compiled-submodules re-c #f))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/pkgs/racket-test-core/tests/racket/sync.rktl b/pkgs/racket-test-core/tests/racket/sync.rktl index 5b7600d6fd..44f0df8250 100644 --- a/pkgs/racket-test-core/tests/racket/sync.rktl +++ b/pkgs/racket-test-core/tests/racket/sync.rktl @@ -200,7 +200,7 @@ (semaphore-post s3) (test s3 sync/timeout SYNC-SLEEP-DELAY set) (test #f sync/timeout SYNC-SLEEP-DELAY set)) - + (let* ([c (make-channel)] [set (choice-evt s1 s2 c)]) (test #f sync/timeout SYNC-SLEEP-DELAY set) @@ -1191,21 +1191,17 @@ (break-enabled #f)) (init ;; init function gets to decide whether to do the normal body: (lambda () - (printf "here ~s\n" (procedure? capture-pre)) (dynamic-wind (lambda () - (printf "here3 ~s\n" (procedure? capture-pre)) (capture-pre reset (lambda () - (printf "here4\n") (set! did-pre1 #t) (semaphore-post p) (pre-thunk) (pre-semaphore-wait s) (set! did-pre2 #t)))) (lambda () - (printf "here2\n") (capture-act reset (lambda () @@ -1340,9 +1336,6 @@ (body))]) ;; Grab a continuation for the dyn-wind's pre/act/post (go (lambda args - (printf "here???\n") - (printf "??? ~s\n" k+reset) - (printf "??? ~s\n" capture) (apply mk-t (lambda (f) (f)) (if (eq? which 'pre) capture no-capture) @@ -1372,9 +1365,9 @@ 'test (lambda (bstr) never-evt) (lambda (bstr skip-count progress-evt) - (wrap-evt always-evt (lambda (_) 17))) + (wrap-evt always-evt (lambda (_) 1))) void)]) - ;; Make sure we don't get 17 + ;; Make sure we don't get 1 (test p sync p)) ;; ---------------------------------------- diff --git a/pkgs/racket-test-core/tests/racket/syntax.rktl b/pkgs/racket-test-core/tests/racket/syntax.rktl index 988d57a635..5f830136c4 100644 --- a/pkgs/racket-test-core/tests/racket/syntax.rktl +++ b/pkgs/racket-test-core/tests/racket/syntax.rktl @@ -868,7 +868,20 @@ (test 5 'implicit-begin (let () (begin) 10 5)) -(error-test #'(begin (define foo (let/cc k k)) (foo 10)) exn:application:type?) ; not exn:application:continuation? +;; Weird test: check that `eval` does not wrap its last argument +;; in a prompt, which means that `(foo 10)` replaces the continuation +;; that would check for an error +(error-test #'(begin (define foo (let/cc k k)) (foo 10)) (lambda (x) #f)) + +;; Check that `eval` does wrap a prompt around non-tail expressions +(test 10 + (lambda (e) (call-with-continuation-prompt (lambda () (eval e)))) + #'(begin (define foo (let/cc k k)) (foo 10) foo)) + +;; Check that `eval` doesn't add a prompt around definitions: +(eval #'(define foo (let/cc k k))) +(eval #'(define never-gets-defined (eval #'(foo 9)))) +(err/rt-test (eval #'never-gets-defined) exn:fail:contract:variable?) (define f-check #t) (define f (delay (begin (set! f-check #f) 5))) @@ -1845,7 +1858,7 @@ free-identifier=? f-id (eval '(extract (f #:x 8) - (lv ([(proc) f2] . _) (if const? (app f3 . _) . _)) + (lv _ (if const? (app f3 . _) . _)) f3 #f))) (test @@ -1853,17 +1866,17 @@ free-identifier=? f-id (eval '(extract (f #:x 8) - (lv ([(proc) f2] . _) (if const? (app f3 . _) . _)) - f2 - #t))) + (lv _ (if const? (app f3 . _) (app2 (app3 check&extract _ f2 . _) . _))) + f2 + #t))) (test #t free-identifier=? f-id (eval '(extract (f #:y 9) - (lv ([(proc) f2] . _) . _) - f2 - #t))) + (lv _ (app2 (app3 check&extract _ f2 . _) . _)) + f2 + #t))) (test #t free-identifier=? diff --git a/pkgs/racket-test-core/tests/racket/thread.rktl b/pkgs/racket-test-core/tests/racket/thread.rktl index 29b3b62433..7b3dba7c1e 100644 --- a/pkgs/racket-test-core/tests/racket/thread.rktl +++ b/pkgs/racket-test-core/tests/racket/thread.rktl @@ -557,6 +557,9 @@ (sleep) 'not-void))) +(err/rt-test (call-with-continuation-barrier + (lambda () + (let/cc k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?))) (test 1 call-with-continuation-prompt (lambda () (let/cc k (call-in-nested-thread (lambda () (k 1)))))) (err/rt-test (let/ec k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?) @@ -999,9 +1002,10 @@ [loop (lambda () (let loop () (set! v (add1 v)) - (sync (car all-ticks)) - (set! all-ticks (cdr all-ticks)) - (loop)))] + (unless (null? all-ticks) + (sync (car all-ticks)) + (set! all-ticks (cdr all-ticks)) + (loop))))] [c0 (make-custodian)]) (let ([try (lambda (resumable?) @@ -1254,7 +1258,7 @@ (collect-garbage) (plumber-flush-all c) (test 6 values done) - (set! h #f) + (test #t plumber-flush-handle? h) (collect-garbage) (plumber-flush-all c) (test 6 values done)))) diff --git a/pkgs/racket-test-core/tests/racket/will.rktl b/pkgs/racket-test-core/tests/racket/will.rktl index e9120e0ce5..847e0a42a3 100644 --- a/pkgs/racket-test-core/tests/racket/will.rktl +++ b/pkgs/racket-test-core/tests/racket/will.rktl @@ -16,6 +16,9 @@ (define we (make-will-executor)) +(test #f will-try-execute we) +(test 'no will-try-execute we 'no) + ;; Never GC this one: (test (void) will-register we test (lambda (x) (error 'bad-will-call))) @@ -61,7 +64,7 @@ (arity-test will-executor? 1 1) (arity-test will-register 3 3) (arity-test will-execute 1 1) -(arity-test will-try-execute 1 1) +(arity-test will-try-execute 1 2) ;; ---------------------------------------- ;; Test custodian boxes @@ -192,7 +195,7 @@ ;; ---------------------------------------- ;; Phantom bytes: -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (define s (make-semaphore)) (define c (make-custodian)) (define t (parameterize ([current-custodian c]) @@ -238,7 +241,7 @@ ;; Check that local variables are cleared for space safety ;; before a tail `sync' or `thread-wait': -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (define weak-syms (make-weak-hash)) (define thds @@ -267,7 +270,7 @@ ;; a reference can be important to the expansion to a call to a keyword-accepting ;; function. -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (define (mk) (parameterize ([current-namespace (make-base-namespace)]) (eval '(module module-with-unoptimized-varref-constant racket/base @@ -356,11 +359,47 @@ (kill-thread watcher-t) (test #t 'many-vectors-in-reasonable-space? done?)) +;; ---------------------------------------- +;; Check that a thread that has a reference to +;; module-level variables doesn't retain the +;; namespace strongly + +(unless (eq? 'cgc (system-type 'gc)) + (define-values (f w) + (parameterize ([current-namespace (make-base-namespace)]) + (define g (gensym 'gensym-via-namespace)) + (eval `(module n racket/base + ;; If the namespace is retained strongly, then + ;; the symbol is reachable through this definition: + (define anchor (quote ,g)))) + (eval `(module m racket/base + (require 'n) + (provide f sema) + (define sema (make-semaphore)) + (define (f) + (thread + (lambda () + ;; Ideally, this loop retains only `loop` + ;; and `sema`. If it retains everything refereneced + ;; or defined in the module, though, at least make + ;; sure it doesn't retain the whole namespace + (let loop () (sync sema) (loop))))))) + (namespace-require ''m) + (values (dynamic-require ''m 'f) + (make-weak-box g)))) + + (define t (f)) + (sync (system-idle-evt)) + + (collect-garbage) + (test #f weak-box-value w) + (kill-thread t)) + ;; ---------------------------------------- ;; Check that ephemeron chains do not lead ;; to O(N^2) behavior with 3m -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (define (wrapper v) (list 1 2 3 4 5 v)) ;; Create a chain of ephemerons where we have all @@ -423,7 +462,7 @@ ;; ---------------------------------------- ;; Check that `apply` doesn't retain its argument -(when (eq? '3m (system-type 'gc)) +(unless (eq? 'cgc (system-type 'gc)) (define retained 0) diff --git a/pkgs/zo-lib/compiler/zo-marshal.rkt b/pkgs/zo-lib/compiler/zo-marshal.rkt index 13c2c65fa4..ece6a8453e 100644 --- a/pkgs/zo-lib/compiler/zo-marshal.rkt +++ b/pkgs/zo-lib/compiler/zo-marshal.rkt @@ -14,8 +14,8 @@ racket/extflonum) (provide/contract - [zo-marshal (compilation-top? . -> . bytes?)] - [zo-marshal-to (compilation-top? output-port? . -> . void?)]) + [zo-marshal ((or/c linkl-directory? linkl-bundle?) . -> . bytes?)] + [zo-marshal-to ((or/c linkl-directory? linkl-bundle?) output-port? . -> . void?)]) (struct not-ready ()) @@ -27,15 +27,17 @@ (get-output-bytes bs)) (define (zo-marshal-to top outp) - (if (and (mod? (compilation-top-code top)) - (or (pair? (mod-pre-submodules (compilation-top-code top))) - (pair? (mod-post-submodules (compilation-top-code top))))) - ;; module directory and submodules: - (zo-marshal-modules-to top outp) - ;; single module or other: - (zo-marshal-top-to top outp))) + (match top + [(linkl-directory table) + ;; linklet directory: + (zo-marshal-directory-to table outp)] + [(linkl-bundle table) + ;; single linklet bundle: + (zo-marshal-bundle-to table outp)] + [else + (error 'zo-marshal-top "not a linklet bundle or directory:" top)])) -(define (zo-marshal-modules-to top outp) +(define (zo-marshal-directory-to top outp) ;; Write the compiled form header (write-bytes #"#~" outp) ;; Write the version: @@ -45,80 +47,78 @@ (write-byte (char->integer #\D) outp) - (struct mod-bytes (code-bstr name-bstr offset)) - ;; bytestring encodings of the modules and module names - ;; --- in the order that they must be written: - (define pre-mod-bytess - (reverse - (let loop ([m (compilation-top-code top)] [pre-accum null]) - (define (encode-module-name name) - (if (symbol? name) - #"" - (apply bytes-append - (for/list ([sym (in-list (cdr name))]) - (define b (string->bytes/utf-8 (symbol->string sym))) - (define len (bytes-length b)) - (bytes-append (if (len . < . 255) - (bytes len) - (bytes-append - (bytes 255) - (integer->integer-bytes len 4 #f #f))) - b))))) - (define accum - (let iloop ([accum pre-accum] [subm (mod-pre-submodules m)]) - (if (null? subm) - accum - (iloop (loop (car subm) accum) (cdr subm))))) - (define o (open-output-bytes)) - (zo-marshal-top-to (struct-copy compilation-top top - [code (struct-copy mod m - [pre-submodules null] - [post-submodules null])]) - o) - (define new-accum - (cons (mod-bytes (get-output-bytes o) - (encode-module-name (mod-name m)) - 0) - accum)) - (let iloop ([accum new-accum] [subm (mod-post-submodules m)]) - (if (null? subm) - accum - (iloop (loop (car subm) accum) (cdr subm))))))) - (write-bytes (int->bytes (length pre-mod-bytess)) outp) + (struct bundle-bytes (code-bstr name-list name-bstr offset)) + ;; bytestring encodings of the bundles and bundle names + (define unsorted-pre-bundle-bytess + (for/list ([(name bundle) (in-hash top)]) + (define name-bstr + (if (null? name) + #"" + (apply bytes-append + (for/list ([sym (in-list name)]) + (define b (string->bytes/utf-8 (symbol->string sym))) + (define len (bytes-length b)) + (bytes-append (if (len . < . 255) + (bytes len) + (bytes-append + (bytes 255) + (integer->integer-bytes len 4 #f #f))) + b))))) + (define o (open-output-bytes)) + (zo-marshal-bundle-to (linkl-bundle-table bundle) o) + (bundle-bytes (get-output-bytes o) + name + name-bstr + 0))) + ;; Write order must correspond to a post-order traversal + ;; of the tree, so write + (define pre-bundle-bytess + (sort unsorted-pre-bundle-bytess + (lambda (a b) + (let loop ([a (bundle-bytes-name-list a)] [b (bundle-bytes-name-list b)]) + (cond + [(null? a) #f] + [(null? b) #t] + [(eq? (car a) (car b)) (loop (cdr a) (cdr b))] + [(symbolbytes (length pre-bundle-bytess)) outp) ;; Size of btree: (define header-size (+ 8 (string-length (version)))) (define btree-size (+ header-size - (apply + (for/list ([mb (in-list pre-mod-bytess)]) - (+ (bytes-length (mod-bytes-name-bstr mb)) + (apply + (for/list ([mb (in-list pre-bundle-bytess)]) + (+ (bytes-length (bundle-bytes-name-bstr mb)) 20))))) - ;; Add offsets to mod-bytess: - (define mod-bytess (let loop ([offset btree-size] [mod-bytess pre-mod-bytess]) - (if (null? mod-bytess) + ;; Add offsets to bundle-bytess: + (define bundle-bytess (let loop ([offset btree-size] [bundle-bytess pre-bundle-bytess]) + (if (null? bundle-bytess) null - (let ([mb (car mod-bytess)]) - (cons (mod-bytes (mod-bytes-code-bstr mb) - (mod-bytes-name-bstr mb) - offset) + (let ([mb (car bundle-bytess)]) + (cons (bundle-bytes (bundle-bytes-code-bstr mb) + (bundle-bytes-name-list mb) + (bundle-bytes-name-bstr mb) + offset) (loop (+ offset - (bytes-length (mod-bytes-code-bstr mb))) - (cdr mod-bytess))))))) + (bytes-length (bundle-bytes-code-bstr mb))) + (cdr bundle-bytess))))))) ;; Sort by name for btree order: - (define sorted-mod-bytess - (list->vector (sort mod-bytess bytesvector (sort bundle-bytess bytesbytes name-len) outp) - (write-bytes (mod-bytes-name-bstr mb) outp) - (write-bytes (int->bytes (mod-bytes-offset mb)) outp) - (write-bytes (int->bytes (bytes-length (mod-bytes-code-bstr mb))) outp) + (write-bytes (bundle-bytes-name-bstr mb) outp) + (write-bytes (int->bytes (bundle-bytes-offset mb)) outp) + (write-bytes (int->bytes (bytes-length (bundle-bytes-code-bstr mb))) outp) (define left-pos (+ pos name-len 20)) (write-bytes (int->bytes (if (= lo mid) 0 @@ -137,31 +137,16 @@ (loop (add1 mid) hi right-pos)))) (write-btree void) ; to fill `right-offsets' (write-btree write-bytes) ; to actually write the btree - ;; write modules: - (for ([mb (in-list mod-bytess)]) - (write-bytes (mod-bytes-code-bstr mb) outp))) + ;; Write bundles: + (for ([mb (in-list bundle-bytess)]) + (write-bytes (bundle-bytes-code-bstr mb) outp))) -(define (zo-marshal-top-to top outp) - - ; For detecting sharing in wraps: - (define stx-objs (make-hasheq)) - (define wraps (make-hasheq)) - (define hash-consed (make-hash)) - (define hash-consed-results (make-hasheq)) - +(define (zo-marshal-bundle-to top outp) ; (obj -> (or pos #f)) output-port -> number ; writes top to outp using shared-obj-pos to determine symref ; returns the file position at the end of the compilation top (define (out-compilation-top shared-obj-pos shared-obj-pos-any counting? outp) - (define ct - (match top - [(compilation-top max-let-depth binding-namess prefix form) - (list* max-let-depth - (binding-namess-hash->list binding-namess) - prefix - (protect-quote form))])) - (out-anything ct (make-out outp shared-obj-pos shared-obj-pos-any counting? - stx-objs wraps hash-consed hash-consed-results)) + (out-anything top (make-out outp shared-obj-pos shared-obj-pos-any counting?)) (file-position outp)) ; -> vector @@ -231,8 +216,7 @@ [i (in-naturals)]) (begin0 (file-position outp) - (out-anything v (make-out outp (shared-obj-pos/modulo-v v) shared-obj-pos #f - stx-objs wraps hash-consed hash-consed-results)))) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) shared-obj-pos #f)))) (file-position outp))) ; Calculate file positions @@ -248,7 +232,8 @@ (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) - (write-byte (char->integer #\T) outp) + ;; "B" is for linklet "bundle" (as opposed to a linklet directory) + (write-byte (char->integer #\B) outp) ; Write empty hash code (write-bytes (make-bytes 20 0) outp) @@ -260,7 +245,7 @@ (write-bytes (bytes (if all-short? 1 0)) outp) (for ([o (in-list offsets)]) (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) - ; Post-shared is where the ctop actually starts + ; Post-shared is where the top actually starts (write-bytes (int->bytes post-shared) outp) ; This is where the file should end (write-bytes (int->bytes all-forms-length) outp) @@ -278,23 +263,16 @@ (define let-void-type-num 10) (define letrec-type-num 11) (define wcm-type-num 13) -(define quote-syntax-type-num 14) -(define define-values-type-num 15) -(define define-syntaxes-type-num 16) -(define begin-for-syntax-type-num 17) -(define set-bang-type-num 18) -(define boxenv-type-num 19) -(define begin0-sequence-type-num 20) -(define splice-sequence-type-num 21) -(define require-form-type-num 22) -(define varref-form-type-num 23) -(define apply-values-type-num 24) -(define with-immed-mark-type-num 25) -(define case-lambda-sequence-type-num 26) -(define module-type-num 27) -(define inline-variants-type-num 28) -(define variable-type-num 37) -(define prefix-type-num 122) +(define define-values-type-num 14) +(define set-bang-type-num 15) +(define boxenv-type-num 16) +(define begin0-sequence-type-num 17) +(define varref-form-type-num 18) +(define apply-values-type-num 19) +(define with-immed-mark-type-num 20) +(define case-lambda-sequence-type-num 21) +(define inline-variants-type-num 22) +(define linklet-type-num 24) (define-syntax define-enum (syntax-rules () @@ -324,9 +302,8 @@ CPT_LIST CPT_VECTOR CPT_HASH_TABLE - CPT_STX CPT_LET_ONE_TYPED - CPT_MARSHALLED + CPT_LINKLET CPT_QUOTE CPT_REFERENCE CPT_LOCAL @@ -335,25 +312,30 @@ CPT_APPLICATION CPT_LET_ONE CPT_BRANCH - CPT_MODULE_INDEX - CPT_MODULE_VAR CPT_PATH CPT_CLOSURE - CPT_DELAY_REF ; XXX should be used to delay loading of syntax objects and lambda bodies + CPT_DELAY_REF ; used to delay loading of syntax objects and lambda bodies CPT_PREFAB CPT_LET_ONE_UNUSED - CPT_SCOPE - CPT_ROOT_SCOPE - CPT_SHARED) + CPT_SHARED + CPT_TOPLEVEL + CPT_BEGIN + CPT_BEGIN0 + CPT_LET_VALUE + CPT_LET_VOID + CPT_LETREC + CPT_WCM + CPT_DEFINE_VALUES + CPT_SET_BANG + CPT_VARREF + CPT_APPLY_VALUES + CPT_OTHER_FORM) -(define CPT_SMALL_NUMBER_START 39) -(define CPT_SMALL_NUMBER_END 62) +(define CPT_SMALL_NUMBER_START 46) +(define CPT_SMALL_NUMBER_END 74) -(define CPT_SMALL_SYMBOL_START 62) -(define CPT_SMALL_SYMBOL_END 80) - -(define CPT_SMALL_MARSHALLED_START 80) -(define CPT_SMALL_MARSHALLED_END 92) +(define CPT_SMALL_SYMBOL_START 74) +(define CPT_SMALL_SYMBOL_END 92) (define CPT_SMALL_LIST_MAX 50) (define CPT_SMALL_PROPER_LIST_START 92) @@ -391,90 +373,6 @@ (define-struct protected-symref (val)) -(define (encode-stx-obj w out) - (match w - [(struct stx-obj (datum wraps srcloc props tamper-status)) - (let* ([enc-datum - (match datum - [(cons a b) - (let ([p (cons (encode-stx-obj a out) - (let bloop ([b b]) - (match b - ['() null] - [(cons b1 b2) - (cons (encode-stx-obj b1 out) - (bloop b2))] - [else - (encode-stx-obj b out)])))] - [len (let loop ([datum datum][len 0]) - (cond - [(null? datum) #f] - [(pair? datum) (loop (cdr datum) (add1 len))] - [else len]))]) - ;; for improper lists, we need to include the length so the - ;; parser knows where the end of the improper list is - (if len - (cons len p) - p))] - [(box x) - (box (encode-stx-obj x out))] - [(? vector? v) - (vector-map (lambda (e) (encode-stx-obj e out)) v)] - [(? prefab-struct-key) - (define l (vector->list (struct->vector datum))) - (apply - make-prefab-struct - (car l) - (map (lambda (e) (encode-stx-obj e out)) (cdr l)))] - [_ datum])] - [e-wraps (share-everywhere (encode-wrap wraps (out-wraps out)) out)] - [esrcloc (let () - (define (avail? n) (n . >= . 0)) - (define (xvector a b c d e) - ;; Add paren-shape info, if any: - (case (hash-ref props 'paren-shape #f) - [(#\[) (yvector a b c d e #\[)] - [(#\{) (yvector a b c d e #\{)] - [else (if (or a (avail? b) (avail? c) (avail? d)) - (yvector a b c d e #f) - #f)])) - (define (yvector a b c d e f) - ;; Add properties, if any: - (if (positive? (- (hash-count props) (if f 1 0))) - (vector a b c d e f - (sort (for/list ([(k v) (in-hash props)] - #:unless (and f - (eq? k 'paren-shape))) - (cons k v)) - symbolbytes n) out)])) -(define (out-marshaled type-num val out) - (if (type-num . < . (- CPT_SMALL_MARSHALLED_END CPT_SMALL_MARSHALLED_START)) - (out-byte (+ CPT_SMALL_MARSHALLED_START type-num) out) - (begin - (out-byte CPT_MARSHALLED out) - (out-number type-num out))) - (out-anything val out)) - (define (or-pred? v . ps) (ormap (lambda (?) (? v)) ps)) @@ -561,9 +431,7 @@ (define (shareable? v) (define never-share-this? - (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? - ;; For root scope: - scope?)) + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?)) (define always-share-this? (or-pred? v closure?)) (or always-share-this? @@ -624,135 +492,40 @@ (out-byte CPT_FALSE out)] [(? void?) (out-byte CPT_VOID out)] - [(? (lambda (s) (and (scope? s) (eq? (scope-name s) 'root)))) - (out-byte CPT_ROOT_SCOPE out)] - [(struct module-variable (modidx sym pos phase constantness)) - (define (to-sym #:prefix [prefix "struct"] n) - (string->symbol (format "~a~a" prefix n))) - (out-byte CPT_MODULE_VAR out) - (out-anything modidx out) - (out-anything sym out) - (out-anything (cond - [(function-shape? constantness) - (let ([a (function-shape-arity constantness)]) - (cond - [(arity-at-least? a) - (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) - (if (function-shape-preserves-marks? constantness) 1 0))] - [(list? a) - (string->symbol (apply - string-append - (add-between - (for/list ([a (in-list a)]) - (define n (if (arity-at-least? a) - (- (add1 (arity-at-least-value a))) - a)) - (number->string n)) - ":")))] - [else - (bitwise-ior (arithmetic-shift a 1) - (if (function-shape-preserves-marks? constantness) 1 0))]))] - [(struct-type-shape? constantness) - (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) - 3))] - [(constructor-shape? constantness) - (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) - 3)))] - [(predicate-shape? constantness) (to-sym 2)] - [(accessor-shape? constantness) - (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) - 3)))] - [(mutator-shape? constantness) - (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) - 3)))] - [(struct-type-property-shape? constantness) - (to-sym #:prefix "prop" - (if (struct-type-property-shape-has-guard? constantness) - 1 - 0))] - [(property-predicate-shape? constantness) - (to-sym #:prefix "prop" 2)] - [(property-accessor-shape? constantness) - (to-sym #:prefix "prop" 3)] - [(struct-other-shape? constantness) - (to-sym 5)] - [else #f]) - out) - (case constantness - [(#f) (void)] - [(fixed) (out-number -5 out)] - [else (out-number -4 out)]) - (unless (zero? phase) - (out-number -2 out) - (out-number phase out)) - (out-number pos out)] [(struct closure (lam gen-id)) (out-byte CPT_CLOSURE out) (let ([pos ((out-shared-index out) v #:error? #t)]) (out-number pos out) (out-anything lam out))] - [(struct prefix (num-lifts toplevels stxs src-insp-desc)) - (out-marshaled - prefix-type-num - (list* src-insp-desc - num-lifts - (list->vector toplevels) - (list->vector stxs)) - out)] - [(struct global-bucket (name)) - (out-marshaled variable-type-num name out)] - [(? mod?) - (out-module v out)] + [(? linkl?) + (out-linklet v out)] [(struct def-values (ids rhs)) - (out-marshaled define-values-type-num - (list->vector (cons (protect-quote rhs) ids)) - out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) - (out-marshaled define-syntaxes-type-num - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - dummy - ids)) - out)] - [(struct seq-for-syntax (rhs prefix max-let-depth dummy)) - (out-marshaled begin-for-syntax-type-num - (vector (map protect-quote rhs) - prefix - max-let-depth - dummy) - out)] + (out-byte CPT_DEFINE_VALUES out) + (out-anything (list->vector (cons (protect-quote rhs) ids)) out)] [(struct beg0 (forms)) - (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] + (out-byte CPT_BEGIN0 out) + (out-number (length forms) out) + (for ([form (in-list forms)]) (out-anything (protect-quote form) out))] [(struct seq (forms)) - (out-marshaled sequence-type-num (map protect-quote forms) out)] - [(struct splice (forms)) - (out-marshaled splice-sequence-type-num forms out)] - [(struct req (reqs dummy)) - (out-marshaled require-form-type-num (cons dummy reqs) out)] + (out-byte CPT_BEGIN out) + (out-number (length forms) out) + (for ([form (in-list forms)]) (out-anything (protect-quote form) out))] [(struct toplevel (depth pos const? ready?)) - (out-marshaled toplevel-type-num - (cons - depth - (if (or const? ready?) - (cons pos - (bitwise-ior - (if const? #x2 0) - (if ready? #x1 0))) - pos)) - out)] - [(struct topsyntax (depth pos midpt)) - (out-marshaled quote-syntax-type-num - (cons depth - (cons pos midpt)) - out)] + (out-byte CPT_TOPLEVEL out) + (out-number (bitwise-ior + (if const? #x2 0) + (if ready? #x1 0)) + out) + (out-number pos out) + (out-number depth out)] [(struct primval (id)) (out-byte CPT_REFERENCE out) (out-number id out)] [(struct assign (id rhs undef-ok?)) - (out-marshaled set-bang-type-num - (cons undef-ok? (cons id (protect-quote rhs))) - out)] + (out-byte CPT_SET_BANG out) + (out-number (if undef-ok? 1 0) out) + (out-anything id out) + (out-anything (protect-quote rhs) out)] [(struct localref (unbox? offset clear? other-clears? type)) (if (and (not clear?) (not other-clears?) (not flonum?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) @@ -775,10 +548,11 @@ [(? lam?) (out-lam v out)] [(struct case-lam (name lams)) - (out-marshaled case-lambda-sequence-type-num - (cons (or name null) - lams) - out)] + (out-byte CPT_OTHER_FORM out) + (out-number case-lambda-sequence-type-num out) + (out-number (length lams) out) + (out-anything name out) + (for ([lam (in-list lams)]) (out-anything lam out))] [(struct let-one (rhs body type unused?)) (out-byte (cond [type CPT_LET_ONE_TYPED] @@ -790,34 +564,27 @@ (when type (out-number (type->index type) out))] [(struct let-void (count boxes? body)) - (out-marshaled let-void-type-num - (list* - count - boxes? - (protect-quote body)) - out)] + (out-byte CPT_LET_VOID out) + (out-number count out) + (out-number (if boxes? 1 0) out) + (out-anything (protect-quote body) out)] [(struct let-rec (procs body)) - (out-marshaled letrec-type-num - (list* - (length procs) - (protect-quote body) - procs) - out)] + (out-byte CPT_LETREC out) + (out-number (length procs) out) + (for ([proc (in-list procs)]) (out-anything proc out)) + (out-anything (protect-quote body) out)] [(struct install-value (count pos boxes? rhs body)) - (out-marshaled let-value-type-num - (list* - count - pos - boxes? - (protect-quote rhs) - (protect-quote body)) - out)] + (out-byte CPT_LET_VALUE out) + (out-number count out) + (out-number pos out) + (out-number (if boxes? 1 0) out) + (out-anything (protect-quote rhs) out) + (out-anything (protect-quote body) out)] [(struct boxenv (pos body)) - (out-marshaled boxenv-type-num - (cons - pos - (protect-quote body)) - out)] + (out-byte CPT_OTHER_FORM out) + (out-number boxenv-type-num out) + (out-anything pos out) + (out-anything (protect-quote body) out)] [(struct branch (test then else)) (out-byte CPT_BRANCH out) (out-anything (protect-quote test) out) @@ -834,28 +601,32 @@ (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) - (out-marshaled apply-values-type-num - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] + (out-byte CPT_APPLY_VALUES out) + (out-anything (protect-quote proc) out) + (out-anything (protect-quote args-expr) out)] [(struct with-immed-mark (key val body)) - (out-marshaled with-immed-mark-type-num - (vector - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] + (out-byte CPT_OTHER_FORM out) + (out-number with-immed-mark-type-num out) + (out-anything (protect-quote key) out) + (out-anything (protect-quote val) out) + (out-anything (protect-quote body) out)] [(struct with-cont-mark (key val body)) - (out-marshaled wcm-type-num - (list* - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] - [(struct varref (expr dummy)) - (out-marshaled varref-form-type-num - (cons expr dummy) - out)] + (out-byte CPT_WCM out) + (out-anything (protect-quote key) out) + (out-anything (protect-quote val) out) + (out-anything (protect-quote body) out)] + [(struct varref (expr dummy constant? from-unsafe?)) + (out-byte CPT_VARREF out) + (out-number (bitwise-ior (if constant? 1 0) + (if from-unsafe? 2 0)) + out) + (out-anything expr out) + (out-anything dummy out)] + [(struct inline-variant (direct inline)) + (out-byte CPT_OTHER_FORM out) + (out-number inline-variants-type-num out) + (out-anything (protect-quote direct) out) + (out-anything (protect-quote inline) out)] [(protected-symref v) (out-anything ((out-shared-index out) v #:error? #t) out)] [(and (? symbol?) (not (? symbol-interned?))) @@ -963,27 +734,6 @@ (out-number len out))) (for ([n (in-range (sub1 len) -1 -1)]) (out-number (vector-ref vec n) out)))] - [(? module-path-index?) - ;; XXX should add interning of module path indices - (out-byte CPT_MODULE_INDEX out) - (let-values ([(name base) (module-path-index-split v)]) - (out-anything name out) - (out-anything base out) - (unless (or name base) - (out-anything (module-path-index-submodule v) out)))] - [(stx content) - (out-byte CPT_STX out) - (out-anything content out)] - [(encoded-scope relative-id content) - (out-byte CPT_SCOPE out) - ;; The `out-shared` wrapper already called `((out-shared-index out) v)` - ;; once, so `pos` will defintely be a number: - (let ([pos ((out-shared-index out) v)]) - (out-number pos out)) - (out-number relative-id out) - (out-anything (share-everywhere content out) out)] - [(? stx-obj?) - (out-anything (lookup-encoded-stx-obj v out) out)] [(? prefab-struct-key) (define pre-v (struct->vector v)) (vector-set! pre-v 0 (prefab-struct-key v)) @@ -1052,202 +802,98 @@ (out-bytes bstr out)] [else (error 'out-anything "~s" (current-type-trace))]))))) -(define (out-module mod-form out) - (out-marshaled module-type-num - (convert-module mod-form) - out)) +(define (out-linklet linklet-form out) + (out-byte CPT_LINKLET out) + (out-anything (convert-linklet linklet-form) out)) -(define (convert-module mod-form) - (match mod-form - [(struct mod (name srcname self-modidx - prefix provides requires body syntax-bodies unexported - max-let-depth dummy lang-info - internal-context binding-names - flags pre-submodules post-submodules)) - (let* ([lookup-req (lambda (phase) - (let ([a (assq phase requires)]) - (if a - (cdr a) - null)))] - [other-requires (filter (lambda (l) - (not (memq (car l) '(#f -1 0 1)))) - requires)] - [extract-protects - (lambda (phase) - (let ([a (assq phase provides)]) - (and a - (let ([p (map provided-protected? (append (cadr a) - (caddr a)))]) - (if (ormap values p) - (list->vector p) - #f)))))] - [extract-unexported - (lambda (phase) - (let ([a (assq phase unexported)]) - (and a - (cdr a))))] - [list->vector/#f (lambda (default l) - (if (andmap (lambda (x) (equal? x default)) l) - #f - (list->vector l)))] - [l - (let loop ([l other-requires]) - (match l - [(list) - empty] - [(list-rest (cons phase reqs) rst) - (list* phase reqs (loop rst))]))] - [l (cons (length other-requires) l)] - [l (cons (lookup-req #f) l)] ; dt-requires - [l (cons (lookup-req -1) l)] ; tt-requires - [l (cons (lookup-req 1) l)] ; et-requires - [l (cons (lookup-req 0) l)] ; requires - [l (cons (list->vector body) l)] - [l (append (reverse - (for/list ([b (in-list syntax-bodies)]) - (for/vector ([i (in-list (cdr b))]) - (define (maybe-one l) ;; a single symbol is ok - (if (and (pair? l) (null? (cdr l))) - (car l) - l)) - (match i - [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) - (vector (maybe-one ids) rhs max-let-depth prefix #f)] - [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy)) - (vector #f rhs max-let-depth prefix #t)])))) - l)] - [l (append (apply - append - (map (lambda (l) - (let* ([phase (car l)] - [all (append (cadr l) (caddr l))] - [protects (extract-protects phase)] - [unexported (extract-unexported phase)]) - (append - (list phase) - (if (and (not protects) - (not unexported)) - (list (void)) - (let ([unexported (or unexported - '(() ()))]) - (list (list->vector (cadr unexported)) - (length (cadr unexported)) - (list->vector (car unexported)) - (length (car unexported)) - protects))) - (list (list->vector/#f 0 (map provided-src-phase all)) - (list->vector/#f #f (map (lambda (p) - (if (eq? (provided-nom-src p) - (provided-src p)) - #f ; #f means "same as src" - (provided-nom-src p))) - all)) - (list->vector (map provided-src-name all)) - (list->vector (map provided-src all)) - (list->vector (map provided-name all)) - (length (cadr l)) - (length all))))) - provides)) - l)] - [l (cons (length provides) l)] ; number of provide sets - [l (cons (add1 (length syntax-bodies)) l)] - [l (cons prefix l)] - [l (cons dummy l)] - [l (cons max-let-depth l)] - [l (cons internal-context l)] ; module->namespace syntax - [l (list* #f #f l)] ; obsolete `functional?' info - [l (cons (protect-quote lang-info) l)] ; lang-info - [l (cons (map convert-module post-submodules) l)] - [l (cons (map convert-module pre-submodules) l)] - [l (cons (if (memq 'cross-phase flags) #t #f) l)] - [l (append (pack-binding-names binding-names) l)] - [l (cons self-modidx l)] - [l (cons srcname l)] - [l (cons (if (pair? name) (car name) name) l)] - [l (cons (if (pair? name) (cdr name) null) l)]) - l)])) - -(define (lookup-encoded-stx-obj w out) - (hash-ref! (out-stx-objs out) w - (λ () - (encode-stx-obj w out)))) - -(define (pack-binding-names binding-names) - (define (ht-to-vector ht) - (and ht (list->vector (apply append (hash-map ht list))))) - (list (ht-to-vector (hash-ref binding-names 0 #f)) - (ht-to-vector (hash-ref binding-names 1 #f)) - (list->vector - (apply append - (for/list ([(phase ht) (in-hash binding-names)] - #:unless (or (= phase 0) (= phase 1))) - (list phase (ht-to-vector ht))))))) +(define (convert-linklet linklet-form) + (match linklet-form + [(struct linkl (name importss import-shapess exports internals lifts + source-names body max-let-depth need-instance-access?)) + (define names-count (* 2 (hash-count source-names))) + (list name + need-instance-access? + max-let-depth + (length lifts) + (length exports) + (list->vector body) + (for*/vector #:length names-count ([(k v) (in-hash source-names)] + [(n) (in-list (list k v))]) + n) + (list->vector (append exports internals lifts)) + (list->vector (map list->vector importss)) + (if (not (for*/or ([import-shapes (in-list import-shapess)] + [import-shape (in-list import-shapes)]) + import-shape)) + #f + (for*/vector ([import-shapes (in-list import-shapess)] + [import-shape (in-list import-shapes)]) + (encode-shape import-shape))))])) (define (out-lam expr out) (match expr [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) - (let* ([l (protect-quote body)] - [any-refs? (or (not (andmap (lambda (t) (eq? t 'val)) param-types)) + (let* ([any-refs? (or (not (andmap (lambda (t) (eq? t 'val)) param-types)) (not (andmap (lambda (t) (eq? t 'val/ref)) closure-types)))] [num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags))) (add1 num-params) num-params)] - [l (cons (make-svector (if any-refs? - (list->vector - (append - (vector->list closure-map) - (let* ([v (make-vector (ceiling - (/ (* BITS_PER_ARG (+ num-all-params (vector-length closure-map))) - BITS_PER_MZSHORT)))] - [set-bit! (lambda (i bit) - (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)]) - (vector-set! v pos - (bitwise-ior (vector-ref v pos) - (arithmetic-shift - bit - (modulo (* BITS_PER_ARG i) BITS_PER_MZSHORT))))))]) - (for ([t (in-list param-types)] - [i (in-naturals)]) - (case t - [(val) (void)] - [(ref) (set-bit! i 1)] - [else (set-bit! i (+ 1 (type->index t)))])) - (for ([t (in-list closure-types)] - [i (in-naturals num-all-params)]) - (case t - [(val/ref) (void)] - [else (set-bit! i (+ 1 (type->index t)))])) - (vector->list v)))) - closure-map)) - l)] - [l (if any-refs? - (cons (vector-length closure-map) l) - l)] + [cl-map (make-svector (if any-refs? + (list->vector + (append + (vector->list closure-map) + (let* ([v (make-vector (ceiling + (/ (* BITS_PER_ARG (+ num-all-params (vector-length closure-map))) + BITS_PER_MZSHORT)))] + [set-bit! (lambda (i bit) + (let ([pos (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)]) + (vector-set! v pos + (bitwise-ior (vector-ref v pos) + (arithmetic-shift + bit + (modulo (* BITS_PER_ARG i) BITS_PER_MZSHORT))))))]) + (for ([t (in-list param-types)] + [i (in-naturals)]) + (case t + [(val) (void)] + [(ref) (set-bit! i 1)] + [else (set-bit! i (+ 1 (type->index t)))])) + (for ([t (in-list closure-types)] + [i (in-naturals num-all-params)]) + (case t + [(val/ref) (void)] + [else (set-bit! i (+ 1 (type->index t)))])) + (vector->list v)))) + closure-map))] [tl-map (and toplevel-map (for/fold ([v 0]) ([i (in-set toplevel-map)]) (bitwise-ior v (arithmetic-shift 1 i))))]) - (out-marshaled unclosed-procedure-type-num - (list* - (+ (if rest? CLOS_HAS_REST 0) - (if any-refs? CLOS_HAS_REF_ARGS 0) - (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) - (if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0) - (if (memq 'is-method flags) CLOS_IS_METHOD 0) - (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) - num-all-params - max-let-depth - (and tl-map - (if (tl-map . <= . #xFFFFFFF) - ;; Encode as a fixnum: - tl-map - ;; Encode as an even-sized vector of 16-bit integers: - (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) - (for/vector ([i (in-range len)]) - (let ([s (* i 16)]) - (bitwise-bit-field tl-map s (+ s 16))))))) - name - l) - out))])) + (out-byte CPT_OTHER_FORM out) + (out-number unclosed-procedure-type-num out) + (out-number (+ (if rest? CLOS_HAS_REST 0) + (if any-refs? CLOS_HAS_REF_ARGS 0) + (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) + (if (memq 'sfs-clear-rest-args flags) CLOS_NEED_REST_CLEAR 0) + (if (memq 'is-method flags) CLOS_IS_METHOD 0) + (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) + out) + (when any-refs? + (out-number (vector-length closure-map) out)) + (out-number num-all-params out) + (out-number max-let-depth out) + (out-anything name out) + (out-anything (protect-quote body) out) + (out-anything cl-map out) + (out-anything (and tl-map + (if (tl-map . <= . #xFFFFFFF) + ;; Encode as a fixnum: + tl-map + ;; Encode as an even-sized vector of 16-bit integers: + (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) + (for/vector ([i (in-range len)]) + (let ([s (* i 16)]) + (bitwise-bit-field tl-map s (+ s 16))))))) + out))])) (define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f]) (define s (->bytes expr)) @@ -1273,260 +919,56 @@ (find-relative-path r v) v))) -(define (binding-namess-hash->list binding-namess) - (for/list ([(phase t) (in-hash binding-namess)]) - (cons phase - (list->vector - (apply append (for/list ([(id sym) (in-hash t)]) - (list id sym))))))) - -;; ---------------------------------------- - -;; We want to hash-cons syntax-object wraps, but a normal `equal?`-based -;; table would equate different "self" modidxes that we need to keep -;; separate. So, roll a `simple-equal?` that inspects wraps. We don't -;; have to deal with cycles, since cycles would always go through a scope, -;; and we recur into scopes. - -(struct modidx-must-be-eq (content) - #:property prop:equal+hash - (list (lambda (a b eql?) - (simple-equal? (modidx-must-be-eq-content a) - (modidx-must-be-eq-content b))) - (lambda (a h) (h (modidx-must-be-eq-content a))) - (lambda (a h) (h (modidx-must-be-eq-content a))))) - -(define (simple-equal? a b) +(define (encode-shape constantness) + (define (to-sym #:prefix [prefix "struct"] n) + (string->symbol (format "~a~a" prefix n))) + (define (struct-count-shift n) (arithmetic-shift n 5)) + (define (add-authentic n authentic?) (bitwise-ior n (if authentic? #x10 0))) (cond - [(eqv? a b) #t] - [(pair? a) - (and (pair? b) - (simple-equal? (car a) (car b)) - (simple-equal? (cdr a) (cdr b)))] - [(vector? a) - (and (vector? b) - (= (vector-length a) (vector-length b)) - (for/and ([ae (in-vector a)] - [be (in-vector b)]) - (simple-equal? ae be)))] - [(box? a) - (and (box? b) - (simple-equal? (unbox a) (unbox b)))] - [(module-path-index? a) - (and (module-path-index? b) - (let-values ([(a-name a-base) (module-path-index-split a)] - [(b-name b-base) (module-path-index-split b)]) - (and a-name - a-base - (simple-equal? a-name b-name) - (simple-equal? a-base b-base))))] + [(eq? constantness 'constant) #t] + [(eq? constantness 'fixed) (void)] + [(function-shape? constantness) + (let ([a (function-shape-arity constantness)]) + (cond + [(arity-at-least? a) + (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) + (if (function-shape-preserves-marks? constantness) 1 0))] + [(list? a) + (string->symbol (apply + string-append + (add-between + (for/list ([a (in-list a)]) + (define n (if (arity-at-least? a) + (- (add1 (arity-at-least-value a))) + a)) + (number->string n)) + ":")))] + [else + (bitwise-ior (arithmetic-shift a 1) + (if (function-shape-preserves-marks? constantness) 1 0))]))] + [(struct-type-shape? constantness) + (to-sym (add-authentic (struct-count-shift (struct-type-shape-field-count constantness)) + (struct-type-shape-authentic? constantness)))] + [(constructor-shape? constantness) + (to-sym (bitwise-ior 1 (struct-count-shift (constructor-shape-arity constantness))))] + [(predicate-shape? constantness) (to-sym (add-authentic 2 (predicate-shape-authentic? constantness)))] + [(accessor-shape? constantness) + (to-sym (bitwise-ior 3 (add-authentic + (struct-count-shift (accessor-shape-field-count constantness)) + (accessor-shape-authentic? constantness))))] + [(mutator-shape? constantness) + (to-sym (bitwise-ior 4 (add-authentic + (struct-count-shift (mutator-shape-field-count constantness)) + (mutator-shape-authentic? constantness))))] + [(struct-type-property-shape? constantness) + (to-sym #:prefix "prop" + (if (struct-type-property-shape-has-guard? constantness) + 1 + 0))] + [(property-predicate-shape? constantness) + (to-sym #:prefix "prop" 2)] + [(property-accessor-shape? constantness) + (to-sym #:prefix "prop" 3)] + [(struct-other-shape? constantness) + (to-sym 5)] [else #f])) - -(define (share-everywhere v out) - (define (register r) - (hash-set! (out-hash-consed-results out) r #t) - r) - (hash-ref! (out-hash-consed out) - (modidx-must-be-eq v) - (lambda () - (cond - [(pair? v) - (register - (cons (share-everywhere (car v) out) - (share-everywhere (cdr v) out)))] - [(vector? v) - (register - (for/vector #:length (vector-length v) ([e (in-vector v)]) - (share-everywhere e out)))] - [(box? v) - (register - (box (share-everywhere (unbox v) out)))] - [else v])))) - -;; ---------------------------------------- - -(define (encode-wrap w ht) - (hash-ref! ht w - (lambda () - (vector (map-encode encode-shift (wrap-shifts w) ht) - (encode-scope-list (wrap-simple-scopes w) ht) - (map-encode encode-multi-scope (wrap-multi-scopes w) ht))))) - -(define (map-encode encode l ht) - (cond - [(null? l) l] - [else - (hash-ref! ht l - (lambda () - (cons (encode (car l) ht) - (map-encode encode (cdr l) ht))))])) - -(define (encode-shift s ht) - (hash-ref! ht s - (lambda () - (if (module-shift-from-inspector-desc s) - (vector (module-shift-to s) - (module-shift-from s) - (module-shift-from-inspector-desc s) - (module-shift-to-inspector-desc s)) - (vector (module-shift-to s) - (module-shift-from s)))))) - -(define (encode-scope s ht) - (if (eq? 'root (scope-name s)) - s - (hash-ref ht s - (lambda () - (define es (encoded-scope (scope-name s) #f)) - (hash-set! ht s es) - (define kind - (case (scope-kind s) - [(module) (if (scope-multi-owner s) - 1 - 0)] - [(macro) 2] - [(local) 3] - [(intdef) 4] - [else 5])) - (cond - [(and (null? (scope-bindings s)) - (null? (scope-bulk-bindings s))) - (set-encoded-scope-content! es kind)] - [else - (define binding-table - (for/fold ([bt (hasheq)]) ([b (in-list (scope-bindings s))]) - (hash-set bt - (car b) - (cons (cons (encode-scope-list (cadr b) ht) - (encode-binding (caddr b) (car b) ht)) - (hash-ref bt (car b) null))))) - (define bindings - (list->vector - (apply - append - (sort (hash-map binding-table list) - symbol #:key (lambda (s) - (if (eq? 'root (scope-name s)) - -1 - (scope-name s)))) - ht)) - -(define (encode-multi-scope ms+phase ht) - (define ms (car ms+phase)) - (cons (hash-ref ht ms - (lambda () - (define v (make-vector (add1 (* 2 (length (multi-scope-scopes ms)))))) - (hash-set! ht ms v) - (vector-copy! - v - 0 - (list->vector - (append (apply - append - (for/list ([e (in-list (multi-scope-scopes ms))]) - (list (car e) - (encode-scope (cadr e) ht)))) - (list (multi-scope-src-name ms))))) - v)) - (cadr ms+phase))) - -(define (encode-binding b name ht) - (match b - [(free-id=?-binding base id phase) - (hash-ref ht b - (lambda () - (match b - [(free-id=?-binding base id phase) - (define bx (box #f)) - (hash-set! ht b bx) - (set-box! bx - (cons - (cons (encode-binding base name ht) - (cons (stx-obj-datum id) - (stx-obj-wrap id))) - phase))])))] - [_ - (hash-ref! ht b - (lambda () - (match b - [(local-binding name) - name] - [(module-binding encoded) - encoded] - [(? decoded-module-binding?) - (encode-module-binding b name ht)])))])) - - -(define (encode-module-binding b name ht) - (hash-ref! ht (cons name b) - (lambda () - (match b - [(decoded-module-binding path export-name phase - nominal-path nominal-export-name nominal-phase - import-phase inspector-desc) - (define l - (cond - [(and (eq? path nominal-path) - (eq? export-name nominal-export-name) - (eqv? phase 0) - (eqv? import-phase 0) - (eqv? nominal-phase phase)) - (if (eq? name export-name) - path - (cons path export-name))] - [(and (eq? export-name nominal-export-name) - (eq? name export-name) - (eqv? 0 phase) - (eqv? import-phase 0) - (eqv? nominal-phase phase)) - (cons path nominal-path)] - [else - (define nom-mod+phase - (if (eqv? nominal-phase phase) - (if (eqv? 0 import-phase) - nominal-path - (cons nominal-path import-phase)) - (cons nominal-path (cons import-phase nominal-phase)))) - (define l (list* export-name nom-mod+phase nominal-export-name)) - (if (zero? phase) - l - (cons phase l))])) - (if inspector-desc - (cons inspector-desc l) - l)])))) - -(define (encode-bulk-binding p ht) - (cons (encode-scope-list (car p) ht) - (encode-all-from-module (cadr p) ht))) - -(define (encode-all-from-module b ht) - (hash-ref! ht b - (lambda () - (match b - [(all-from-module path phase src-phase inspector-desc exceptions prefix) - (vector path src-phase - (cond - [(and (not prefix) (null? exceptions)) - phase] - [(not prefix) - (cons phase (list->vector exceptions))] - [(null? exceptions) - (cons phase prefix)] - [else - (cons phase (cons (list->vector exceptions) prefix))]) - inspector-desc)])))) - diff --git a/pkgs/zo-lib/compiler/zo-parse.rkt b/pkgs/zo-lib/compiler/zo-parse.rkt index 62dc0d48e1..ec905c5aa6 100644 --- a/pkgs/zo-lib/compiler/zo-parse.rkt +++ b/pkgs/zo-lib/compiler/zo-parse.rkt @@ -7,65 +7,24 @@ racket/dict racket/set) -(provide zo-parse - decode-module-binding) +(provide zo-parse) (provide (all-from-out compiler/zo-structs)) ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms -(define (read-toplevel v) +(define (read-toplevel flags pos depth) (define SCHEME_TOPLEVEL_CONST #x02) (define SCHEME_TOPLEVEL_READY #x01) - (match v - [(cons depth (cons pos flags)) - ;; In the VM, the two flag bits are actually interpreted - ;; as a number when the toplevel is a reference, but we - ;; interpret the bits as flags here for backward compatibility. - (make-toplevel depth pos - (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) - (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))] - [(cons depth pos) - (make-toplevel depth pos #f #f)])) + ;; In the VM, the two flag bits are actually interpreted + ;; as a number when the toplevel is a reference, but we + ;; interpret the bits as flags here for backward compatibility. + (make-toplevel depth pos + (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) + (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))) -(define (read-topsyntax v) - (match v - [`(,depth ,pos . ,midpt) - (make-topsyntax depth pos midpt)])) - -(define (read-variable v) - (if (symbol? v) - (make-global-bucket v) - (error "expected a symbol"))) - -(define (do-not-read-variable v) - (error "should not get here")) - -(define (read-compilation-top v) - (match v - [`(,ld ,binding-namess ,prefix . ,code) - (unless (prefix? prefix) - (error 'bad "not prefix ~a" prefix)) - (make-compilation-top ld - (binding-namess-list->hash binding-namess) - prefix - code)])) - -(define (binding-namess-list->hash binding-namess) - (for/hash ([e (in-list binding-namess)]) - (values (car e) - (let ([vec (cdr e)]) - (for/hash ([i (in-range 0 (vector-length vec) 2)]) - (values (vector-ref vec i) - (vector-ref vec (add1 i)))))))) - -(define (read-resolve-prefix v) - (match v - [`(,src-insp-desc ,i ,tv . ,sv) - ;; XXX Why not leave them as vectors and change the contract? - (make-prefix i (vector->list tv) (vector->list sv) src-insp-desc)])) - -(define (read-unclosed-procedure v) +(define (read-unclosed-procedure flags maybe-closure-size num-params max-let-depth + name body closed-over tl-map) (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) (define CLOS_PRESERVES_MARKS 4) @@ -74,140 +33,78 @@ (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) (define BITS_PER_ARG 4) - (match v - [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) - (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) - (let*-values ([(closure-size closed-over body) - (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - (values (vector-length v) v rest) - (values v (car rest) (cdr rest)))] - [(get-flags) (lambda (i) - (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - 0 - (let ([byte (vector-ref closed-over - (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) - (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) - (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] - [(num->type) (lambda (n) - (case n - [(2) 'flonum] - [(3) 'fixnum] - [(4) 'extflonum] - [else (error "invaid type flag")]))] - [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) - (for/list ([i (in-range num-params)]) - (define v (get-flags i)) - (case v - [(0) 'val] - [(1) 'ref] - [else (num->type v)])))] - [(closure-types) (for/list ([i (in-range closure-size)] - [j (in-naturals num-params)]) - (define v (get-flags j)) - (case v - [(0) 'val/ref] - [(1) (error "invalid 'ref closure variable")] - [else (num->type v)]))]) - (make-lam name - (append - (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) - (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) - (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) - (if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args)) - (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) - (if (and rest? (num-params . > . 0)) - (sub1 num-params) - num-params) - arg-types - rest? - (if (= closure-size (vector-length closed-over)) - closed-over - (let ([v2 (make-vector closure-size)]) - (vector-copy! v2 0 closed-over 0 closure-size) - v2)) - closure-types - (and tl-map - (let* ([bits (if (exact-integer? tl-map) - tl-map - (for/fold ([i 0]) ([v (in-vector tl-map)] - [s (in-naturals)]) - (bitwise-ior i (arithmetic-shift v (* s 16)))))] - [len (integer-length bits)]) - (list->set - (let loop ([bit 0]) - (cond - [(bit . >= . len) null] - [(bitwise-bit-set? bits bit) - (cons bit (loop (add1 bit)))] - [else (loop (add1 bit))]))))) - max-let-depth - body)))])) + (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) + (let*-values ([(closure-size) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + (vector-length closed-over) + maybe-closure-size)] + [(get-flags) (lambda (i) + (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) + 0 + (let ([byte (vector-ref closed-over + (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) + (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) + (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] + [(num->type) (lambda (n) + (case n + [(2) 'flonum] + [(3) 'fixnum] + [(4) 'extflonum] + [else (error "invaid type flag")]))] + [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + (for/list ([i (in-range num-params)]) + (define v (get-flags i)) + (case v + [(0) 'val] + [(1) 'ref] + [else (num->type v)])))] + [(closure-types) (for/list ([i (in-range closure-size)] + [j (in-naturals num-params)]) + (define v (get-flags j)) + (case v + [(0) 'val/ref] + [(1) (error "invalid 'ref closure variable")] + [else (num->type v)]))]) + (make-lam name + (append + (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) + (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) + (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) + (if (zero? (bitwise-and flags flags CLOS_NEED_REST_CLEAR)) null '(sfs-clear-rest-args)) + (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) + (if (and rest? (num-params . > . 0)) + (sub1 num-params) + num-params) + arg-types + rest? + (if (= closure-size (vector-length closed-over)) + closed-over + (let ([v2 (make-vector closure-size)]) + (vector-copy! v2 0 closed-over 0 closure-size) + v2)) + closure-types + (and tl-map + (let* ([bits (if (exact-integer? tl-map) + tl-map + (for/fold ([i 0]) ([v (in-vector tl-map)] + [s (in-naturals)]) + (bitwise-ior i (arithmetic-shift v (* s 16)))))] + [len (integer-length bits)]) + (list->set + (let loop ([bit 0]) + (cond + [(bit . >= . len) null] + [(bitwise-bit-set? bits bit) + (cons bit (loop (add1 bit)))] + [else (loop (add1 bit))]))))) + max-let-depth + body)))) -(define (read-let-value v) - (match v - [`(,count ,pos ,boxes? ,rhs . ,body) - (make-install-value count pos boxes? rhs body)])) - -(define (read-let-void v) - (match v - [`(,count ,boxes? . ,body) - (make-let-void count boxes? body)])) - -(define (read-letrec v) - (match v - [`(,count ,body . ,procs) - (make-let-rec procs body)])) - -(define (read-with-cont-mark v) - (match v - [`(,key ,val . ,body) - (make-with-cont-mark key val body)])) - -(define (read-sequence v) - (make-seq v)) - -; XXX Allocates unnessary list (define (read-define-values v) (make-def-values (cdr (vector->list v)) (vector-ref v 0))) -(define (read-define-syntax v) - (make-def-syntaxes (list-tail (vector->list v) 4) - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3))) - -(define (read-begin-for-syntax v) - (make-seq-for-syntax - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3))) - -(define (read-set! v) - (make-assign (cadr v) (cddr v) (car v))) - -(define (read-case-lambda v) - (make-case-lam (car v) (cdr v))) - -(define (read-begin0 v) - (make-beg0 v)) - -(define (read-boxenv v) - (make-boxenv (car v) (cdr v))) -(define (read-require v) - (make-req (cdr v) (car v))) -(define (read-#%variable-ref v) - (make-varref (car v) (cdr v))) -(define (read-apply-values v) - (make-apply-values (car v) (cdr v))) -(define (read-with-immed-mark v) - (make-with-immed-mark (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) -(define (read-splice v) - (make-splice v)) - (define (in-list* l n) (make-do-sequence (lambda () @@ -217,149 +114,74 @@ (lambda (l) (>= (length l) n)) (lambda _ #t) (lambda _ #t))))) - -(define (split-phase-data rest n) - (let loop ([n n] [rest rest] [phase-accum null]) - (cond - [(zero? n) - (values (reverse phase-accum) rest)] - [else - (let ([maybe-indirect (list-ref rest 1)]) - (if (void? maybe-indirect) - ;; no indirect or protect info: - (loop (sub1 n) - (list-tail rest 9) - (cons (take rest 9) phase-accum)) - ;; has indirect or protect info: - (loop (sub1 n) - (list-tail rest (+ 5 8)) - (cons (take rest (+ 5 8)) phase-accum))))]))) -(define (read-module v) +(define (read-linklet v) (match v - [`(,submod-path - ,name ,srcname ,self-modidx - ,rt-binding-names ,et-binding-names ,other-binding-names - ,cross-phase? - ,pre-submods ,post-submods - ,lang-info ,functional? ,et-functional? - ,rename ,max-let-depth ,dummy - ,prefix ,num-phases - ,provide-phase-count . ,rest) - (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)] - [(bodies rest-module) (values (take rest-module num-phases) - (drop rest-module num-phases))]) - (match rest-module - [`(,requires ,syntax-requires ,template-requires ,label-requires - ,more-requires-count . ,more-requires) - (make-mod (if (null? submod-path) - name - (if (symbol? name) - (cons name submod-path) - (cons (car name) submod-path))) - srcname self-modidx - prefix - ;; provides: - (for/list ([l (in-list phase-data)]) - (let* ([phase (list-ref l 0)] - [has-info? (not (void? (list-ref l 1)))] - [delta (if has-info? 5 1)] - [num-vars (list-ref l (+ delta 6))] - [num-all (list-ref l (+ delta 7))] - [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))] - [src (in-vector (list-ref l (+ delta 4)))] - [src-name (in-vector (list-ref l (+ delta 3)))] - [nom-src (or (list-ref l (+ delta 2)) - (in-cycle (in-value #f)))] - [src-phase (or (list-ref l (+ delta 1)) - (in-cycle (in-value 0)))] - [protected? (cond - [(or (not has-info?) - (not (list-ref l 5))) - (in-cycle (in-value #f))] - [else (list-ref l 5)])]) - (make-provided name src src-name - (or nom-src src) - src-phase - protected?))]) - (list - phase - (take ps num-vars) - (drop ps num-vars)))) - ;; requires: - (list* - (cons 0 requires) - (cons 1 syntax-requires) - (cons -1 template-requires) - (cons #f label-requires) - (for/list ([(phase reqs) (in-list* more-requires 2)]) - (cons phase reqs))) - ;; body: - (vector->list (last bodies)) - ;; syntax-bodies: add phase to each list, break apart - (for/list ([b (cdr (reverse bodies))] - [i (in-naturals 1)]) - (cons i - (for/list ([sb (in-vector b)]) - (match sb - [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) - (if for-stx? - (make-seq-for-syntax (list expr) prefix max-let-depth #f) - (make-def-syntaxes - (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))] - [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)])))) - ;; unexported: - (for/list ([l (in-list phase-data)] - #:unless (void? (list-ref l 1))) - (let* ([phase (list-ref l 0)] - [indirect-syntax - ;; could check: (list-ref l 2) should be size of vector: - (list-ref l 1)] - [indirect - ;; could check: (list-ref l 4) should be size of vector: - (list-ref l 3)]) - (list - phase - (vector->list indirect) - (vector->list indirect-syntax)))) - max-let-depth - dummy - lang-info - rename - (assemble-binding-names rt-binding-names - et-binding-names - other-binding-names) - (if cross-phase? '(cross-phase) '()) - (map read-module pre-submods) - (map read-module post-submods))]))])) -(define (read-module-wrap v) - v) + [`(,name ,need-instance-access? ,max-let-depth ,num-lifts ,num-exports + ,body + ,source-names ,defns-vec ,imports-vec ,shapes-vec) + (define defns (vector->list defns-vec)) + (linkl name + (map vector->list (vector->list imports-vec)) + (if (not shapes-vec) + (for/list ([imports (in-vector imports-vec)]) + (for/list ([i (in-vector imports)]) + #f)) + (let ([pos 0]) + (for/list ([imports (in-vector imports-vec)]) + (for/list ([i (in-vector imports)]) + (begin0 + (parse-shape (vector-ref shapes-vec pos)) + (set! pos (add1 pos))))))) + (take defns num-exports) + (take (list-tail defns num-exports) (- (length defns) num-exports num-lifts)) + (drop defns (- (length defns) num-lifts)) + (for/hasheq ([i (in-range 0 (vector-length source-names) 2)]) + (values (vector-ref source-names i) + (vector-ref source-names (add1 i)))) + (vector->list body) + max-let-depth + need-instance-access?)])) - -(define (read-inline-variant v) - (make-inline-variant (car v) (cdr v))) - -(define (assemble-binding-names rt-binding-names - et-binding-names - other-binding-names) - (define (vector-to-ht vec) - (define sz (vector-length vec)) - (let loop ([i 0] [ht #hasheq()]) - (cond - [(= i sz) ht] - [else (loop (+ i 2) - (hash-set ht (vector-ref vec i) (vector-ref vec (add1 i))))]))) - (for/hash ([(phase vec) (let* ([ht (if other-binding-names - (vector-to-ht other-binding-names) - #hash())] - [ht (if rt-binding-names - (hash-set ht 0 rt-binding-names) - ht)] - [ht (if et-binding-names - (hash-set ht 0 et-binding-names) - ht)]) - ht)]) - (values phase (vector-to-ht vec)))) +(define (parse-shape shape) + (cond + [(not shape) #f] + [(eq? shape #t) 'constant] + [(eq? shape (void)) 'fixed] + [(number? shape) + (define n (arithmetic-shift shape -1)) + (make-function-shape (if (negative? n) + (make-arity-at-least (sub1 (- n))) + n) + (odd? shape))] + [(and (symbol? shape) + (regexp-match? #rx"^struct" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 6))) + (define (authentic-shape? n) (bitwise-bit-set? n 4)) + (define (shape-count-shift n) (arithmetic-shift n -5)) + (case (bitwise-and n #x7) + [(0) (make-struct-type-shape (shape-count-shift n) (authentic-shape? n))] + [(1) (make-constructor-shape (shape-count-shift n))] + [(2) (make-predicate-shape (authentic-shape? n))] + [(3) (make-accessor-shape (shape-count-shift n) (authentic-shape? n))] + [(4) (make-mutator-shape (shape-count-shift n) (authentic-shape? n))] + [else (make-struct-other-shape)])] + [(and (symbol? shape) + (regexp-match? #rx"^prop" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 4))) + (case n + [(0 1) (make-struct-type-property-shape (= n 1))] + [(2) (make-property-predicate-shape)] + [else (make-property-accessor-shape)])] + [else + ;; parse symbol as ":"-separated sequence of arities + (make-function-shape + (for/list ([s (regexp-split #rx":" (symbol->string shape))]) + (define i (string->number s)) + (if (negative? i) + (make-arity-at-least (sub1 (- i))) + i)) + #f)])) ;; ---------------------------------------- ;; Unmarshal dispatch for various types @@ -374,61 +196,18 @@ [(10) 'let-void-type] [(11) 'letrec-type] [(13) 'with-cont-mark-type] - [(14) 'quote-syntax-type] - [(15) 'define-values-type] - [(16) 'define-syntaxes-type] - [(17) 'begin-for-syntax-type] - [(18) 'set-bang-type] - [(19) 'boxenv-type] - [(20) 'begin0-sequence-type] - [(21) 'splice-sequence-type] - [(22) 'require-form-type] - [(23) 'varref-form-type] - [(24) 'apply-values-type] - [(25) 'with-immed-mark-type] - [(26) 'case-lambda-sequence-type] - [(27) 'module-type] - [(28) 'inline-variant-type] - [(37) 'variable-type] - [(38) 'module-variable-type] - [(122) 'resolve-prefix-type] + [(14) 'define-values-type] + [(15) 'set-bang-type] + [(16) 'boxenv-type] + [(17) 'begin0-sequence-type] + [(18) 'varref-form-type] + [(19) 'apply-values-type] + [(20) 'with-immed-mark-type] + [(21) 'case-lambda-sequence-type] + [(22) 'inline-variant-type] + [(24) 'linklet-type] [else (error 'int->type "unknown type: ~e" i)])) -(define type-readers - (make-immutable-hash - (list - (cons 'toplevel-type read-toplevel) - (cons 'sequence-type read-sequence) - (cons 'unclosed-procedure-type read-unclosed-procedure) - (cons 'let-value-type read-let-value) - (cons 'let-void-type read-let-void) - (cons 'letrec-type read-letrec) - (cons 'with-cont-mark-type read-with-cont-mark) - (cons 'quote-syntax-type read-topsyntax) - (cons 'variable-type read-variable) - (cons 'module-variable-type do-not-read-variable) - (cons 'compilation-top-type read-compilation-top) - (cons 'case-lambda-sequence-type read-case-lambda) - (cons 'begin0-sequence-type read-begin0) - (cons 'module-type read-module) - (cons 'inline-variant-type read-inline-variant) - (cons 'resolve-prefix-type read-resolve-prefix) - (cons 'define-values-type read-define-values) - (cons 'define-syntaxes-type read-define-syntax) - (cons 'begin-for-syntax-type read-begin-for-syntax) - (cons 'set-bang-type read-set!) - (cons 'boxenv-type read-boxenv) - (cons 'require-form-type read-require) - (cons 'varref-form-type read-#%variable-ref) - (cons 'apply-values-type read-apply-values) - (cons 'with-immed-mark-type read-with-immed-mark) - (cons 'splice-sequence-type read-splice)))) - -(define (get-reader type) - (hash-ref type-readers type - (λ () - (error 'read-marshalled "reader for ~a not implemented" type)))) - ;; ---------------------------------------- ;; Lowest layer of bytecode parsing @@ -443,7 +222,7 @@ (define (read-simple-number p) (integer-bytes->integer (read-bytes 4 p) #f #f)) -(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets decoded rns mpis)) +(define-struct cport ([pos #:mutable] shared-start orig-port size bytes-start symtab shared-offsets)) (define (cport-get-bytes cp len) (define port (cport-orig-port cp)) (define pos (cport-pos cp)) @@ -485,30 +264,36 @@ [15 list] [16 vector] [17 hash-table] - [18 stx] - [19 let-one-typed] - [20 marshalled] - [21 quote] - [22 reference] - [23 local] - [24 local-unbox] - [25 svector] - [26 application] - [27 let-one] - [28 branch] - [29 module-index] - [30 module-var] - [31 path] - [32 closure] - [33 delayed] - [34 prefab] - [35 let-one-unused] - [36 scope] - [37 root-scope] - [38 shared] - [39 62 small-number] - [62 80 small-symbol] - [80 92 small-marshalled] + [18 let-one-typed] + [19 linklet] + [20 quote] + [21 reference] + [22 local] + [23 local-unbox] + [24 svector] + [25 application] + [26 let-one] + [27 branch] + [28 path] + [29 closure] + [30 delayed] + [31 prefab] + [32 let-one-unused] + [33 shared] + [34 toplevel] + [35 begin] + [36 begin0] + [37 let-value] + [38 let-void] + [39 letrec] + [40 wcm] + [41 define-values] + [42 set-bang] + [43 varref] + [44 apply-values] + [45 other-form] + [46 74 small-number] + [74 92 small-symbol] [92 ,(+ 92 small-list-max) small-proper-list] [,(+ 92 small-list-max) 192 small-list] [192 207 small-local] @@ -518,8 +303,6 @@ [249 small-application3] [247 255 small-application])) -(define root-scope (scope 'root 'module null null #f)) - ;; To accelerate cpt-table lookup, we flatten out the above ;; list into a vector: (define cpt-table (make-vector 256 #f)) @@ -568,12 +351,6 @@ (vector-set! v (sub1 (- n i)) (read-compact-number port))) v) -(define (read-marshalled type port) - (let* ([type (if (number? type) (int->type type) type)] - [l (read-compact port)] - [reader (get-reader type)]) - (reader l))) - (define SCHEME_LOCAL_TYPE_FLONUM 1) (define SCHEME_LOCAL_TYPE_FIXNUM 2) (define SCHEME_LOCAL_TYPE_EXTFLONUM 3) @@ -598,95 +375,6 @@ (define-struct not-ready ()) (define-struct in-progress ()) -;; ---------------------------------------- -;; Syntax unmarshaling -(define (make-memo) (make-weak-hash)) -(define (with-memo* mt arg thnk) - (hash-ref! mt arg thnk)) -(define-syntax-rule (with-memo mt arg body ...) - (with-memo* mt arg (λ () body ...))) - -;; placeholder for a `scope` decoded in a second pass: -(struct encoded-scope (relative-id content) #:prefab) - -(define (decode-wrapped cp v) - (let loop ([v v]) - (let-values ([(tamper-status v encoded-wraps esrcloc) - (match v - [`#(,datum ,wraps 1) (values 'tainted datum wraps #f)] - [`#(,datum ,wraps 2) (values 'armed datum wraps #f)] - [`#(,datum ,wraps ,esrcloc 1) (values 'tainted datum wraps esrcloc)] - [`#(,datum ,wraps ,esrcloc 2) (values 'armed datum wraps esrcloc)] - [`#(,datum ,wraps ,esrcloc) (values 'clean datum wraps esrcloc)] - [`(,datum . ,wraps) (values 'clean datum wraps #f)] - [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) - (let* ([wrapped-memo (make-memo)] - [add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps esrcloc #hasheq() tamper-status)))]) - (cond - [(pair? v) - (if (eq? #t (car v)) - ;; Share decoded wraps with all nested parts. - (let iloop ([v (cdr v)]) - (cond - [(pair? v) - (let ploop ([v v]) - (cond - [(null? v) null] - [(pair? v) (add-wrap (cons (iloop (car v)) (ploop (cdr v))))] - [else (iloop v)]))] - [(box? v) (add-wrap (box (iloop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map iloop (vector->list v))))] - [(hash? v) - (add-wrap (for/hash ([(k v) (in-hash v)]) - (values k (iloop v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map iloop (struct->list v)))))] - [else (add-wrap v)])) - ;; Decode sub-elements that have their own wraps: - (let-values ([(v counter) (if (exact-integer? (car v)) - (values (cdr v) (car v)) - (values v -1))]) - (add-wrap - (let ploop ([v v][counter counter]) - (cond - [(null? v) null] - [(or (not (pair? v)) (zero? counter)) (loop v)] - [(pair? v) (cons (loop (car v)) - (ploop (cdr v) (sub1 counter)))])))))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(hash? v) - (add-wrap (for/hash ([(k v) (in-hash v)]) - (values k (loop v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)]))))) - -(define (in-vector* v n) - (make-do-sequence - (λ () - (values (λ (i) (vector->values v i (+ i n))) - (λ (i) (+ i n)) - 0 - (λ (i) (>= (vector-length v) (+ i n))) - (λ _ #t) - (λ _ #t))))) - -(define (parse-module-path-index cp s) - s) - ;; ---------------------------------------- ;; Main parsing loop @@ -755,66 +443,6 @@ (eq? cpt-tag 'let-one-unused))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] - [(module-index) - (define name (read-compact cp)) - (define base (read-compact cp)) - (if (or name base) - (module-path-index-join name base) - (module-path-index-join #f #f (read-compact cp)))] - [(module-var) - (let ([mod (read-compact cp)] - [var (read-compact cp)] - [shape (read-compact cp)] - [pos (read-compact-number cp)]) - (let-values ([(flags mod-phase pos) - (let loop ([pos pos]) - (cond - [(pos . < . -3) - (let ([real-pos (read-compact-number cp)]) - (define-values (_ m p) (loop real-pos)) - (values (- (+ pos 3)) m p))] - [(= pos -2) - (values 0 (read-compact-number cp) (read-compact-number cp))] - [else (values 0 0 pos)]))]) - (make-module-variable mod var pos mod-phase - (cond - [shape - (cond - [(number? shape) - (define n (arithmetic-shift shape -1)) - (make-function-shape (if (negative? n) - (make-arity-at-least (sub1 (- n))) - n) - (odd? shape))] - [(and (symbol? shape) - (regexp-match? #rx"^struct" (symbol->string shape))) - (define n (string->number (substring (symbol->string shape) 6))) - (case (bitwise-and n #x7) - [(0) (make-struct-type-shape (arithmetic-shift n -3))] - [(1) (make-constructor-shape (arithmetic-shift n -3))] - [(2) (make-predicate-shape)] - [(3) (make-accessor-shape (arithmetic-shift n -3))] - [(4) (make-mutator-shape (arithmetic-shift n -3))] - [else (make-struct-other-shape)])] - [(and (symbol? shape) - (regexp-match? #rx"^prop" (symbol->string shape))) - (define n (string->number (substring (symbol->string shape) 4))) - (case n - [(0 1) (make-struct-type-property-shape (= n 1))] - [(2) (make-property-predicate-shape)] - [else (make-property-accessor-shape)])] - [else - ;; parse symbol as ":"-separated sequence of arities - (make-function-shape - (for/list ([s (regexp-split #rx":" (symbol->string shape))]) - (define i (string->number s)) - (if (negative? i) - (make-arity-at-least (sub1 (- i))) - i)) - #f)])] - [(not (zero? (bitwise-and #x1 flags))) 'constant] - [(not (zero? (bitwise-and #x2 flags))) 'fixed] - [else #f]))))] [(local-unbox) (let* ([p* (read-compact-number cp)] [p (if (< p* 0) (- (add1 p*)) p*)] @@ -874,10 +502,8 @@ (for/list ([i (in-range len)]) (cons (read-compact cp) (read-compact cp)))))] - [(marshalled) (read-marshalled (read-compact-number cp) cp)] - [(stx) - (let ([v (read-compact cp)]) - (make-stx (decode-wrapped cp v)))] + [(linklet) + (read-linklet (read-compact cp))] [(local local-unbox) (let ([c (read-compact-number cp)] [unbox? (eq? cpt-tag 'local-unbox)]) @@ -931,8 +557,6 @@ (string->uninterned-symbol str) ; unreadable is equivalent to parallel in the C implementation (string->unreadable-symbol str)))] - [(small-marshalled) - (read-marshalled (- ch cpt-start) cp)] [(small-application2) (make-application (read-compact cp) (list (read-compact cp)))] @@ -970,19 +594,81 @@ (read-compact-svector cp (read-compact-number cp))] [(small-svector) (read-compact-svector cp (- ch cpt-start))] - [(scope) - (let ([pos (read-compact-number cp)] - [relative-id (read-compact-number cp)]) - (if (zero? pos) - (encoded-scope relative-id (read-compact cp)) - (read-cyclic cp pos 'scope (lambda (v) - (encoded-scope relative-id - v)))))] - [(root-scope) - root-scope] [(shared) (let ([pos (read-compact-number cp)]) (read-cyclic cp pos 'shared))] + [(toplevel) + (read-toplevel (read-compact-number cp) (read-compact-number cp) (read-compact-number cp))] + [(begin begin0) + (define len (read-compact-number cp)) + (define l (for/list ([i (in-range len)]) (read-compact cp))) + (if (eq? cpt-tag 'begin) + (make-seq l) + (make-beg0 l))] + [(let-value) + (define count (read-compact-number cp)) + (define pos (read-compact-number cp)) + (define boxes? (not (zero? (read-compact-number cp)))) + (define rhs (read-compact cp)) + (define body (read-compact cp)) + (make-install-value count pos boxes? rhs body)] + [(let-void) + (define count (read-compact-number cp)) + (define boxes? (not (zero? (read-compact-number cp)))) + (define body (read-compact cp)) + (make-let-void count boxes? body)] + [(letrec) + (define len (read-compact-number cp)) + (define procs (for/list ([i (in-range len)]) (read-compact cp))) + (define body (read-compact cp)) + (make-let-rec procs body)] + [(wcm) + (make-with-cont-mark (read-compact cp) (read-compact cp) (read-compact cp))] + [(define-values) + (define v (read-compact cp)) + (make-def-values + (cdr (vector->list v)) + (vector-ref v 0))] + [(set-bang) + (define undef-ok? (not (zero? (read-compact-number cp)))) + (make-assign (read-compact cp) (read-compact cp) undef-ok?)] + [(varref) + (define flags (read-compact-number cp)) + (make-varref (read-compact cp) (read-compact cp) + (bitwise-bit-set? flags 1) + (bitwise-bit-set? flags 2))] + [(apply-values) + (make-apply-values (read-compact cp) (read-compact cp))] + [(other-form) + (define type (read-compact-number cp)) + (case (int->type type) + [(boxenv-type) + (make-boxenv (read-compact cp) (read-compact cp))] + [(with-immed-mark-type) + (make-with-immed-mark (read-compact cp) (read-compact cp) (read-compact cp))] + [(inline-variant-type) + (make-inline-variant (read-compact cp) (read-compact cp))] + [(case-lambda-sequence-type) + (define count (read-compact-number cp)) + (define name (read-compact cp)) + (define l (for/list ([i (in-range count)]) (read-compact cp))) + (make-case-lam name l)] + [(unclosed-procedure-type) + (define flags (read-compact-number cp)) + (define CLOS_HAS_TYPED_ARGS 2) + (define maybe-closure-size (if (positive? (bitwise-and flags CLOS_HAS_TYPED_ARGS)) + (read-compact-number cp) + -1)) + (define num-params (read-compact-number cp)) + (define max-let-depth (read-compact-number cp)) + (define name (read-compact cp)) + (define body (read-compact cp)) + (define closure-map (read-compact cp)) + (define tl-map (read-compact cp)) + (read-unclosed-procedure flags maybe-closure-size num-params max-let-depth + name body closure-map tl-map)] + [else + (error 'read-compact "unknown other-form type ~a" type)])] [else (error 'read-compact "unknown tag ~a" cpt-tag)])) (cond [(zero? need-car) v] @@ -1021,27 +707,31 @@ (error who "unexpected cycle in input")] [else v])) -(define (read-prefix port) +(define (read-prefix port can-be-false?) ;; skip the "#~" - (unless (equal? #"#~" (read-bytes 2 port)) + (define tag (read-bytes 2 port)) + (unless (or (equal? #"#~" tag) + (and can-be-false? (equal? #"#f" tag))) (error 'zo-parse "not a bytecode stream")) - (define version (read-bytes (min 63 (read-byte port)) port)) - - (read-char port)) + (cond + [(equal? #"#f" tag) #f] + [else + (define version (read-bytes (min 63 (read-byte port)) port)) + (read-char port)])) ;; path -> bytes ;; implementes read.c:read_compiled (define (zo-parse [port (current-input-port)]) (define init-pos (file-position port)) - (define mode (read-prefix port)) + (define mode (read-prefix port #f)) (case mode - [(#\T) (zo-parse-top port)] + [(#\B) (linkl-bundle (zo-parse-top port))] [(#\D) - (struct mod-info (name start len)) - (define mod-infos + (struct sub-info (name start len)) + (define sub-infos (sort (for/list ([i (in-range (read-simple-number port))]) (define size (read-simple-number port)) @@ -1051,7 +741,7 @@ (define left (read-simple-number port)) (define right (read-simple-number port)) (define name-p (open-input-bytes name)) - (mod-info (let loop () + (sub-info (let loop () (define c (read-byte name-p)) (if (eof-object? c) null @@ -1064,53 +754,26 @@ start len)) < - #:key mod-info-start)) - (define tops - (for/list ([mod-info (in-list mod-infos)]) - (define pos (file-position port)) - (unless (= (- pos init-pos) (mod-info-start mod-info)) - (error 'zo-parse - "next module expected at ~a, currently at ~a" - (+ init-pos (mod-info-start mod-info)) pos)) - (unless (eq? (read-prefix port) #\T) - (error 'zo-parse "expected a module")) - (define top (zo-parse-top port #f)) - (define m (compilation-top-code top)) - (unless (mod? m) - (error 'zo-parse "expected a module")) - (unless (equal? (mod-info-name mod-info) - (if (symbol? (mod-name m)) - '() - (cdr (mod-name m)))) - (error 'zo-parse "module name mismatch")) - top)) - (define avail (for/hash ([mod-info (in-list mod-infos)] - [top (in-list tops)]) - (values (mod-info-name mod-info) top))) - (unless (hash-ref avail '() #f) - (error 'zo-parse "no root module in directory")) - (define-values (pre-subs post-subs seen) - (for/fold ([pre-subs (hash)] [post-subs (hash)] [seen (hash)]) ([mod-info (in-list mod-infos)]) - (if (null? (mod-info-name mod-info)) - (values pre-subs post-subs (hash-set seen '() #t)) - (let () - (define name (mod-info-name mod-info)) - (define prefix (take name (sub1 (length name)))) - (unless (hash-ref avail prefix #f) - (error 'zo-parse "no parent module for ~s" name)) - (define (add subs) - (hash-set subs prefix (cons name (hash-ref subs prefix '())))) - (define new-seen (hash-set seen name #t)) - (if (hash-ref seen prefix #f) - (values pre-subs (add post-subs) new-seen) - (values (add pre-subs) post-subs new-seen)))))) - (define (get-all prefix) - (struct-copy mod - (compilation-top-code (hash-ref avail prefix)) - [pre-submodules (map get-all (reverse (hash-ref pre-subs prefix '())))] - [post-submodules (map get-all (reverse (hash-ref post-subs prefix '())))])) - (struct-copy compilation-top (hash-ref avail '()) - [code (get-all '())])] + #:key sub-info-start)) + (linkl-directory + (for/hash ([sub-info (in-list sub-infos)]) + (define pos (file-position port)) + (unless (= (- pos init-pos) (sub-info-start sub-info)) + (error 'zo-parse + "next bundle expected at ~a, currently at ~a" + (+ init-pos (sub-info-start sub-info)) pos)) + (define tag (read-prefix port #t)) + (define sub + (cond + [(not tag) #f] + [else + (unless (eq? tag #\B) + (error 'zo-parse "expected a bundle")) + (define sub (and tag (zo-parse-top port #f))) + (unless (hash? sub) + (error 'zo-parse "expected a bundle hash")) + (linkl-bundle sub)])) + (values (sub-info-name sub-info) sub)))] [else (error 'zo-parse "bad file format specifier")])) @@ -1147,8 +810,7 @@ (define symtab (make-vector symtabsize (not-ready))) (define cp - (make-cport 0 shared-size port size* rst-start symtab so* - (make-vector symtabsize (not-ready)) (make-hash) (make-hash))) + (make-cport 0 shared-size port size* rst-start symtab so*)) (for ([i (in-range 1 symtabsize)]) (read-symref cp i #f 'table)) @@ -1158,338 +820,7 @@ (printf "~a = ~a\n" i (placeholder-get v))) (set-cport-pos! cp shared-size) - (define decoded-except-for-stx - (make-reader-graph (read-marshalled 'compilation-top-type cp))) - - (decode-stxes decoded-except-for-stx)) - -;; ---------------------------------------- - -(define (decode-stxes v) - ;; Walk `v` to find `stx-obj` instances and decode the `wrap` field. - ;; We do this after building a graph from the input, and `decode-wrap` - ;; preserves graph structure. - (define decode-ht (make-hasheq)) - (define srcloc-ht (make-hasheq)) - (let walk ([p v]) - (match p - [(compilation-top _ binding-namess pfx c) - (struct-copy compilation-top p - [binding-namess (walk binding-namess)] - [prefix (walk pfx)] - [code (walk c)])] - [(prefix _ _ s _) - (struct-copy prefix p [stxs (map walk s)])] - [(req rs _) - (struct-copy req p - [reqs (walk rs)])] - [(? mod?) - (struct-copy mod p - [prefix (walk (mod-prefix p))] - [syntax-bodies - (for/list ([e (in-list (mod-syntax-bodies p))]) - (cons (car e) - (map walk (cdr e))))] - [internal-context - (walk (mod-internal-context p))] - [binding-names - (for/hash ([(p ht) (in-hash (mod-binding-names p))]) - (values p - (for/hash ([(k v) (in-hash ht)]) - (values k (walk v)))))] - [pre-submodules - (map walk (mod-pre-submodules p))] - [post-submodules - (map walk (mod-post-submodules p))])] - [(stx c) - (struct-copy stx p [content (walk c)])] - [(def-syntaxes _ _ pfx _ _) - (struct-copy def-syntaxes p - [prefix (walk pfx)])] - [(seq-for-syntax _ pfx _ _) - (struct-copy seq-for-syntax p - [prefix (walk pfx)])] - [(stx-obj d w esrcloc _ _) - (define-values (srcloc props) (decode-srcloc+props esrcloc srcloc-ht)) - (struct-copy stx-obj p - [datum (walk d)] - [wrap (decode-wrap w decode-ht)] - [srcloc srcloc] - [props props])] - [(? zo?) p] - ;; Generic constructors happen inside the `datum` of `stx-obj`, - ;; for example (with no cycles): - [(cons a d) - (cons (walk a) (walk d))] - [(? vector?) - (vector->immutable-vector - (for/vector #:length (vector-length p) ([e (in-vector p)]) - (walk e)))] - [(box v) - (box-immutable (walk v))] - [(? prefab-struct-key) - (apply make-prefab-struct - (prefab-struct-key p) - (cdr (for/list ([e (in-vector (struct->vector p))]) - (walk e))))] - [(? hash?) - (cond - [(hash-eq? p) - (for/hasheq ([(k v) (in-hash p)]) - (values k (walk v)))] - [(hash-eqv? p) - (for/hasheqv ([(k v) (in-hash p)]) - (values k (walk v)))] - [else - (for/hash ([(k v) (in-hash p)]) - (values k (walk v)))])] - [_ p]))) - -;; ---------------------------------------- - -(define (decode-srcloc+props esrcloc ht) - (define (norm v) (if (v . < . 0) #f v)) - (define p - (hash-ref! ht - esrcloc - (lambda () - (cons (and esrcloc - ;; We could reduce this srcloc to #f if - ;; there's no source, line, column, or position - ;; information, but we want to expose the actual - ;; content of a bytecode stream: - (srcloc (vector-ref esrcloc 0) - (norm (vector-ref esrcloc 1)) - (norm (vector-ref esrcloc 2)) - (norm (vector-ref esrcloc 3)) - (norm (vector-ref esrcloc 4)))) - (let ([props - (if (and esrcloc ((vector-length esrcloc) . > . 5)) - (case (vector-ref esrcloc 5) - [(#\[) #hasheq((paren-shape . #\[))] - [(#\{) #hasheq((paren-shape . #\{))] - [else #hasheq()]) - #hasheq())]) - (if (and esrcloc ((vector-length esrcloc) . > . 6)) - (for/fold ([props props]) ([p (in-list (vector-ref esrcloc 6))]) - (hash-set props (car p) (cdr p))) - props)))))) - (values (car p) (cdr p))) - -;; ---------------------------------------- - -(define (decode-wrap encoded-wrap ht) - (hash-ref! ht - encoded-wrap - (lambda () - (match encoded-wrap - [(vector shifts simple-scopes multi-scopes) - (make-wrap (decode-map decode-shift shifts ht) - (decode-map decode-scope simple-scopes ht) - (decode-map decode-shifted-multi-scope multi-scopes ht))] - [_ (error 'decode-wrap "bad wrap")])))) - -(define (decode-map decode-one l ht) - (cond - [(null? l) l] - [(not (pair? l)) - (error 'decode-wrap "bad list")] - [else (hash-ref! ht l - (lambda () - (cons (decode-one (car l) ht) - (decode-map decode-one (cdr l) ht))))])) - -(define (decode-shift s ht) - (hash-ref! ht s - (lambda () - (match s - [(vector to from) - (module-shift to from #f #f)] - [(vector to from i-to i-from) - (module-shift to from i-to i-from)] - [_ (error 'decode-wrap "bad shift")])))) - -(define (decode-scope s ht) - (or - (and (eq? s root-scope) - s) - (hash-ref ht s - (lambda () - (unless (encoded-scope? s) - (error 'decode-wrap "bad scope: ~e" s)) - (define v (encoded-scope-content s)) - (define kind - (match v - [(? number?) v] - [(cons (? number?) _) - (car v)] - [else (error 'decode-wrap "bad scope")])) - (define sc (scope (encoded-scope-relative-id s) - (case kind - [(0 1) 'module] - [(2) 'macro] - [(3) 'local] - [(4) 'intdef] - [else 'use-site]) - null - null - #f)) - (hash-set! ht s sc) - (unless (number? v) - (define-values (bulk-bindings end) - (let loop ([l (cdr v)] [bulk-bindings null]) - (cond - [(pair? l) - (loop (cdr l) (cons (list (decode-scope-set (caar l) ht) - (decode-bulk-import (cdar l) ht)) - bulk-bindings))] - [else (values (reverse bulk-bindings) l)]))) - (set-scope-bulk-bindings! sc bulk-bindings) - (unless (and (vector? end) - (even? (vector-length end))) - (error 'decode-wrap "bad scope")) - (define bindings - (let loop ([i 0]) - (cond - [(= i (vector-length end)) null] - [else - (append (for/list ([p (in-list (vector-ref end (add1 i)))]) - (list (vector-ref end i) - (decode-scope-set (car p) ht) - (decode-binding (cdr p) ht))) - (loop (+ i 2)))]))) - (set-scope-bindings! sc bindings)) - sc)))) - -(define (decode-scope-set l ht) - (decode-map decode-scope l ht)) - -(define (decode-binding b ht) - (hash-ref! ht b - (lambda () - (match b - [(box (cons base-b (cons (cons sym wraps) phase))) - (free-id=?-binding - (decode-binding base-b ht) - (stx-obj sym (decode-wrap wraps ht) #f #hasheq() 'clean) - phase)] - [(? symbol?) - (local-binding b)] - [else - ;; Leave it encoded, so that the compactness (or not) - ;; of the encoding is visible; clients decode further - ;; with `decode-module-binding` - (module-binding b)])))) - -(define (decode-module-binding b name) - (define-values (insp-desc rest-b) - (match b - [(cons (? symbol?) _) - (values (car b) (cdr b))] - [else - (values #f b)])) - (define (decode-nominal-modidx-plus-phase n mod-phase) - (match n - [(? module-path-index?) - (values n mod-phase 0)] - [(cons nom-modix (cons import-phase nom-phase)) - (values nom-modix nom-phase import-phase)] - [(cons nom-modix import-phase) - (values nom-modix mod-phase import-phase)] - [_ - (error 'decode-module-binding "bad encoding")])) - (match rest-b - [(and modidx (? module-path-index?)) - (decoded-module-binding modidx name 0 - modidx name 0 - 0 insp-desc)] - [(cons (and modidx (? module-path-index?)) - (and name (? symbol?))) - (decoded-module-binding modidx name 0 - modidx name 0 - 0 insp-desc)] - [(cons (and modidx (? module-path-index?)) - (and nom-modidx (? module-path-index?))) - (decoded-module-binding modidx name 0 - nom-modidx name 0 - 0 insp-desc)] - [(list* modidx (and name (? symbol?)) - nominal-modidx-plus-phase nom-name) - (define-values (nom-modidx nom-phase import-phase) - (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase 0)) - (decoded-module-binding modidx name 0 - nom-modidx nom-name nom-phase - import-phase insp-desc)] - [(list* modidx mod-phase (and name (? symbol?)) - nominal-modidx-plus-phase nom-name) - (define-values (nom-modidx nom-phase import-phase) - (decode-nominal-modidx-plus-phase nominal-modidx-plus-phase mod-phase)) - (decoded-module-binding modidx name mod-phase - nom-modidx nom-name nom-phase - import-phase insp-desc)] - [_ (error 'decode-module-binding "bad encoding")])) - -(define (decode-bulk-import l ht) - (hash-ref! ht l - (lambda () - (match l - [(vector (and modidx (? module-path-index?)) - src-phase - info - (and insp-desc (or #f (? symbol?)))) - (define-values (phase prefix excepts) - (match info - [(or #f (? exact-integer?)) - (values info #f '#())] - [(cons phase (and prefix (? symbol?))) - (values phase prefix '#())] - [(cons phase (cons excepts prefix)) - (values phase prefix excepts)] - [(cons phase excepts) - (values phase #f excepts)] - [_ (error 'decode-wrap "bad bulk import info")])) - (all-from-module modidx - phase - src-phase - insp-desc - (if excepts - (vector->list excepts) - null) - prefix)] - [_ (error 'decode-wrap "bad bulk import")])))) - -(define (decode-shifted-multi-scope sms ht) - (unless (pair? sms) - (error 'decode-wrap "bad multi-scope pair")) - (list (decode-multi-scope (car sms) ht) - (cdr sms))) - -(define (decode-multi-scope ms ht) - (unless (and (vector? ms) - (odd? (vector-length ms))) - (error 'decode-wrap "bad multi scope")) - (hash-ref ht ms - (lambda () - (define multi (multi-scope (hash-count ht) - (vector-ref ms (sub1 (vector-length ms))) - null)) - (hash-set! ht ms multi) - (define scopes - (let loop ([i 0]) - (cond - [(= (add1 i) (vector-length ms)) null] - [else - (define s (decode-scope (vector-ref ms (add1 i)) ht)) - (when (scope-multi-owner s) - (error 'decode-wrap "bad scope owner: ~e while reading ~e" - (scope-multi-owner s) - multi)) - (set-scope-multi-owner! s multi) - (cons (list (vector-ref ms i) - s) - (loop (+ i 2)))]))) - (set-multi-scope-scopes! multi scopes) - multi))) + (make-reader-graph (read-compact cp))) ;; ---------------------------------------- diff --git a/pkgs/zo-lib/compiler/zo-structs.rkt b/pkgs/zo-lib/compiler/zo-structs.rkt index 251e41c752..b50acf2a8e 100644 --- a/pkgs/zo-lib/compiler/zo-structs.rkt +++ b/pkgs/zo-lib/compiler/zo-structs.rkt @@ -4,19 +4,6 @@ racket/list racket/set) -#| Unresolved issues - - what are the booleans in lexical-rename? - - contracts that are probably too generous: - prefix-stxs - provided-nom-src - lam-num-params - lexical-rename-alist - all-from-module - -|# - ;; ---------------------------------------- ;; Structures to represent bytecode @@ -42,94 +29,51 @@ (define-form-struct struct-shape ()) (define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) -(define-form-struct (predicate-shape struct-shape) ()) -(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) -(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) -(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (predicate-shape struct-shape) ([authentic? boolean?])) +(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?] + [authentic? boolean?])) +(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?] + [authentic? boolean?])) +(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?] + [authentic? boolean?])) (define-form-struct (struct-type-property-shape struct-shape) ([has-guard? boolean?])) (define-form-struct (property-predicate-shape struct-shape) ()) (define-form-struct (property-accessor-shape struct-shape) ()) (define-form-struct (struct-other-shape struct-shape) ()) -;; In toplevels of resove prefix: -(define-form-struct global-bucket ([name symbol?])) ; top-level binding -(define-form-struct module-variable ([modidx module-path-index?] - [sym symbol?] - [pos exact-integer?] - [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed - function-shape? - struct-shape?)])) - -(define-form-struct prefix ([num-lifts exact-nonnegative-integer?] - [toplevels (listof (or/c #f symbol? global-bucket? module-variable?))] - [stxs (listof (or/c #f stx?))] ; #f is unusual, but it can happen when one is optimized away at the last moment - [src-inspector-desc symbol?])) - (define-form-struct form ()) (define-form-struct (expr form) ()) -(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] - [binding-namess (hash/c exact-nonnegative-integer? - (hash/c symbol? stx?))] - [prefix prefix?] - [code (or/c form? any/c)])) ; compiled code always wrapped with this - -;; A provided identifier -(define-form-struct provided ([name symbol?] - [src (or/c module-path-index? #f)] - [src-name symbol?] - [nom-src any/c] ; should be (or/c module-path-index? #f) - [src-phase exact-nonnegative-integer?] - [protected? boolean?])) - (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [const? boolean?] [ready? boolean?])) ; access binding via prefix array (which is on stack) -(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' -(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax' - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])) +(define-form-struct (seq expr) ([forms (listof (or/c expr? any/c))])) ; `begin' -(define-form-struct (inline-variant form) ([direct expr?] - [inline expr?])) +(define-form-struct (inline-variant zo) ([direct expr?] + [inline expr?])) ;; Definitions (top level or within module): (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] - [rhs (or/c expr? seq? inline-variant? any/c)])) -(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] - [rhs (or/c expr? seq? any/c)] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?] - [dummy (or/c toplevel? #f)])) + [rhs (or/c expr? seq? inline-variant? any/c)])) -(define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))] - [srcname symbol?] - [self-modidx module-path-index?] - [prefix prefix?] - [provides (listof (list/c (or/c exact-integer? #f) - (listof provided?) - (listof provided?)))] - [requires (listof (cons/c (or/c exact-integer? #f) - (listof module-path-index?)))] +(define-form-struct (linkl zo) ([name symbol?] + [importss (listof (listof symbol?))] + [import-shapess (listof (listof (or/c #f 'constant 'fixed + function-shape? + struct-shape?)))] + [exports (listof symbol?)] + [internals (listof (or/c symbol? #f))] + [lifts (listof symbol?)] + [source-names (hash/c symbol? symbol?)] [body (listof (or/c form? any/c))] - [syntax-bodies (listof (cons/c exact-positive-integer? - (listof (or/c def-syntaxes? seq-for-syntax?))))] - [unexported (listof (list/c exact-nonnegative-integer? - (listof symbol?) - (listof symbol?)))] [max-let-depth exact-nonnegative-integer?] - [dummy toplevel?] - [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx? (vectorof stx?))] - [binding-names (hash/c exact-integer? - (hash/c symbol? (or/c #t stx?)))] - [flags (listof (or/c 'cross-phase))] - [pre-submodules (listof mod?)] - [post-submodules (listof mod?)])) + [need-instance-access? boolean?])) + +(define-form-struct (linkl-directory zo) ([table (hash/c (listof symbol?) linkl-bundle?)])) +(define-form-struct (linkl-bundle zo) ([table (hash/c (or/c symbol? fixnum?) + any/c)])) ; can be anythingv, but especially a linklet (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] [flags (listof (or/c 'preserves-marks 'is-method 'single-result @@ -165,16 +109,16 @@ [type (or/c #f 'flonum 'fixnum 'extflonum)])) ; access local via stack -(define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) - (define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call (define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if' (define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)] [val (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' (define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' -(define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' -(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' +(define-form-struct (varref expr) ([toplevel (or/c toplevel? #f #t symbol?)] + [dummy (or/c toplevel? #f)] + [constant? boolean?] + [from-unsafe? boolean?])) (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)] @@ -182,58 +126,37 @@ [body (or/c expr? seq? any/c)])) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive -;; Top-level `require' -(define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) - - -;; Syntax objects - -(define-form-struct stx ([content stx-obj?])) - -(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components - [wrap any/c] ; should be `wrap?`, but encoded form appears initially - [srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially - [props (hash/c symbol? any/c)] - [tamper-status (or/c 'clean 'armed 'tainted)])) - -(define-form-struct wrap ([shifts (listof module-shift?)] - [simple-scopes (listof scope?)] - [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))])) - -(define-form-struct module-shift ([from (or/c #f module-path-index?)] - [to (or/c #f module-path-index?)] - [from-inspector-desc (or/c #f symbol?)] - [to-inspector-desc (or/c #f symbol?)])) - -(define-form-struct scope ([name (or/c 'root exact-nonnegative-integer?)] ; 'root is special; otherwise, just for printing - [kind symbol?] - [bindings (listof (list/c symbol? (listof scope?) binding?)) #:mutable] - [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #:mutable] - [multi-owner (or/c #f multi-scope?) #:mutable])) -(define-form-struct multi-scope ([name exact-nonnegative-integer?] - [src-name any/c] ; debugging info, such as module name - [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #:mutable])) - -(define-form-struct binding ()) -(define-form-struct (free-id=?-binding binding) ([base (and/c binding? - (not/c free-id=?-binding?))] - [id stx-obj?] - [phase (or/c #f exact-integer?)])) -(define-form-struct (local-binding binding) ([name symbol?])) -(define-form-struct (module-binding binding) ([encoded any/c])) -;; Convert `module-binding` to `decoded-module-binding` with `decode-module-binding`: -(define-form-struct (decoded-module-binding binding) ([path (or/c #f module-path-index?)] - [name symbol?] - [phase exact-integer?] - [nominal-path (or/c #f module-path-index?)] - [nominal-export-name symbol?] - [nominal-phase (or/c #f exact-integer?)] - [import-phase (or/c #f exact-integer?)] - [inspector-desc (or/c #f symbol?)])) - -(define-form-struct all-from-module ([path module-path-index?] - [phase (or/c exact-integer? #f)] - [src-phase (or/c exact-integer? #f)] - [inspector-desc symbol?] - [exceptions (listof symbol?)] - [prefix (or/c symbol? #f)])) +;; For backward compatibility, provide limited matching support as `compilation-top`: +(provide compilation-top) +(require (for-syntax racket/base)) +(define-match-expander compilation-top + (lambda (stx) + (syntax-case stx () + [(_ max-let-depth binding-namess prefix code) + #'(linkl-directory (hash-table ('() (linkl-bundle + (hash-table (0 (linkl _ ; name + _ ; imports + _ ; import shapes + _ ; exports + _ ; internals + _ ; lifts + _ ; source-names + (list code) ; body + max-let-depth + _)) + _ (... ...)))) + _ (... ...)))])) + (lambda (stx) + (syntax-case stx () + [(_ max-let-depth binding-namess prefix code) + #'(linkl-directory (hash '() (linkl-bundle + (hasheq 0 (linkl 'top + '() + '() + '() + '() + '() + #hasheq() + (list code) + (add1 max-let-depth) + #f)))))]))) diff --git a/racket/collects/compiler/cm.rkt b/racket/collects/compiler/cm.rkt index 634a2dc558..4d4c01f541 100644 --- a/racket/collects/compiler/cm.rkt +++ b/racket/collects/compiler/cm.rkt @@ -1,92 +1,27 @@ #lang racket/base -(require syntax/modcode - syntax/modresolve - syntax/modread - setup/dirs - racket/file - racket/list - racket/path - racket/promise - openssl/sha1 +(require "private/cm-minimal.rkt" + (submod "private/cm-minimal.rkt" cm-internal) + racket/contract/base racket/place - setup/collects - compiler/compilation-path - compiler/private/dep - racket/contract/base) + racket/path + racket/promise) + +(provide (except-out (all-from-out "private/cm-minimal.rkt") + current-path->mode) -(provide make-compilation-manager-load/use-compiled-handler - managed-compile-zo - make-caching-managed-compile-zo - trust-existing-zos - manager-compile-notify-handler - manager-skip-file-handler file-stamp-in-collection file-stamp-in-paths - manager-trace-handler - get-file-sha1 - get-compiled-file-sha1 - with-compile-output - - managed-compiled-context-key - make-compilation-context-error-display-handler - - parallel-lock-client + make-compile-lock compile-lock->parallel-lock-client - - install-module-hashes! (contract-out [current-path->mode (parameter/c (or/c #f (-> path? (and/c path? relative-path?))))])) -(define current-path->mode (make-parameter #f)) - -(define cm-logger (make-logger 'compiler/cm (current-logger))) -(define (default-manager-trace-handler str) - (when (log-level? cm-logger 'debug) - (log-message cm-logger 'debug str (current-inexact-milliseconds)))) - -(struct compile-event (timestamp path action) #:prefab) -(define (log-compile-event path action) - (when (log-level? cm-logger 'info 'compiler/cm) - (log-message cm-logger 'info (format "~a~a: ~a" (get-indent-string) action path) - (compile-event (current-inexact-milliseconds) path action)))) - -(define manager-compile-notify-handler (make-parameter void)) -(define manager-trace-handler (make-parameter default-manager-trace-handler)) -(define indent (make-parameter 0)) -(define trust-existing-zos (make-parameter #f)) -(define manager-skip-file-handler (make-parameter (λ (x) #f))) -(define depth (make-parameter 0)) -(define parallel-lock-client (make-parameter #f)) - -(define managed-compiled-context-key (gensym)) -(define (make-compilation-context-error-display-handler orig) - (lambda (str exn) - (define l (continuation-mark-set->list - (exn-continuation-marks exn) - managed-compiled-context-key)) - (orig (if (null? l) - str - (apply - string-append - str - "\n compilation context...:" - (for/list ([i (in-list l)]) - (format "\n ~a" i)))) - exn))) - (define (file-stamp-in-collection p) (file-stamp-in-paths p (current-library-collection-paths))) -(define (try-file-time p) - (let ([s (file-or-directory-modify-seconds p #f (lambda () #f))]) - (and s - (if (eq? (use-compiled-file-check) 'modify-seconds) - s - 0)))) - (define (file-stamp-in-paths p paths) (let ([p-eles (explode-path (simple-form-path p))]) (let c-loop ([paths paths]) @@ -163,19 +98,6 @@ [else (c-loop (cdr paths))])]))])))) -(define (path*->collects-relative p) - (if (bytes? p) - (let ([q (path->collects-relative (bytes->path p))]) - (if (path? q) - (path->bytes q) - q)) - (path->collects-relative p))) - -(define (collects-relative*->path p cache) - (if (bytes? p) - (bytes->path p) - (hash-ref! cache p (lambda () (collects-relative->path p))))) - (define (reroot-path* base root) (cond [(eq? root 'same) base] @@ -184,668 +106,7 @@ [else (reroot-path base root)])) -(define (trace-printf fmt . args) - (let ([t (manager-trace-handler)]) - (unless (or (eq? t void) - (and (equal? t default-manager-trace-handler) - (not (log-level? cm-logger 'debug)))) - (t (string-append (get-indent-string) - (apply format fmt args)))))) - -(define (get-indent-string) - (build-string (indent) - (λ (x) - (if (and (= 2 (modulo x 3)) - (not (= x (- (indent) 1)))) - #\| - #\space)))) - -(define (get-deps code path) - (define ht - (let loop ([code code] [ht (hash)]) - (define new-ht - (for*/fold ([ht ht]) ([imports (in-list (module-compiled-imports code))] - [x (in-list (cdr imports))]) - (let* ([r (resolve-module-path-index x path)] - [r (if (pair? r) (cadr r) r)]) - (if (and (path? r) - (not (equal? path r)) - (not (equal? path r)) - (not (equal? path (rkt->ss r)))) - (hash-set ht (path->bytes r) #t) - ht)))) - (for*/fold ([ht new-ht]) ([non-star? (in-list '(#f #t))] - [subcode (in-list (module-compiled-submodules code non-star?))]) - (loop subcode ht)))) - (for/list ([k (in-hash-keys ht)]) k)) - -(define (get-compilation-path path->mode roots path) - (let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)]) - (build-path dir name))) - -(define (touch path) - (when (eq? 'modify-seconds (use-compiled-file-check)) - (with-compiler-security-guard - (file-or-directory-modify-seconds - path - (current-seconds) - (lambda () - (close-output-port (open-output-file path #:exists 'append))))))) - -(define (try-delete-file path [noisy? #t]) - ;; Attempt to delete, but give up if it doesn't work: - (with-handlers ([exn:fail:filesystem? void]) - (when noisy? (trace-printf "deleting ~a" path)) - (with-compiler-security-guard (delete-file path)))) - -(define (compilation-failure path->mode roots path zo-name date-path reason) - (try-delete-file zo-name) - (trace-printf "failure")) - -;; with-compile-output : path (output-port path -> alpha) -> alpha -(define (with-compile-output path proc) - (call-with-atomic-output-file - path - #:security-guard (pick-security-guard) - proc)) - -(define-syntax-rule - (with-compiler-security-guard expr) - (parameterize ([current-security-guard (pick-security-guard)]) - expr)) - -(define compiler-security-guard (make-parameter #f)) - -(define (pick-security-guard) - (or (compiler-security-guard) - (current-security-guard))) - -(define (get-source-sha1 p) - (with-handlers ([exn:fail:filesystem? (lambda (exn) - (and (path-has-extension? p #".rkt") - (get-source-sha1 (path-replace-extension p #".ss"))))]) - (call-with-input-file* p sha1))) - -(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen) - (let ([l (for/fold ([l null]) ([dep (in-list deps)]) - (and l - (let* ([ext? (external-dep? dep)] - [p (collects-relative*->path (dep->encoded-path dep) collection-cache)]) - (cond - [ext? (let ([v (get-source-sha1 p)]) - (cond - [v (cons (cons (delay v) dep) l)] - [must-exist? (error 'cm "cannot find external-dependency file: ~v" p)] - [else #f]))] - [(or (hash-ref up-to-date (simple-form-path p) #f) - ;; Use `compile-root' with `sha1-only?' as #t: - (compile-root path->mode roots p up-to-date collection-cache read-src-syntax #t seen)) - => (lambda (sh) - (cons (cons (cdr sh) dep) l))] - [must-exist? - ;; apparently, we're forced to use the source of the module, - ;; so compute a sha1 from it instead of the bytecode - (cons (cons (get-source-sha1 p) dep) l)] - [else #f]))))]) - (and l - (let ([p (open-output-string)] - [l (map (lambda (v) - (let ([sha1 (force (car v))] - [dep (cdr v)]) - (unless sha1 - (error 'cm "no SHA-1 for dependency: ~s" dep)) - (cons sha1 dep))) - l)]) - ;; sort by sha1s so that order doesn't matter - (write (sort l stringmode roots path src-sha1 - external-deps external-module-deps reader-deps - up-to-date collection-cache read-src-syntax) - (let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")] - [deps (remove-duplicates (append (get-deps code path) - external-module-deps ; can create cycles if misused! - reader-deps))] - [external-deps (remove-duplicates external-deps)]) - (define (path*->collects-relative/maybe-indirect dep) - (if (and (pair? dep) (eq? 'indirect (car dep))) - (cons 'indirect (path*->collects-relative (cdr dep))) - (path*->collects-relative dep))) - (with-compile-output dep-path - (lambda (op tmp-path) - (let ([deps (append - (map path*->collects-relative/maybe-indirect deps) - (map (lambda (x) - (define d (path*->collects-relative/maybe-indirect x)) - (if (and (pair? d) (eq? 'indirect d)) - (cons 'indirect (cons 'ext (cdr d))) - (cons 'ext d))) - external-deps))]) - (write (list* (version) - (cons (or src-sha1 (get-source-sha1 path)) - (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash())) - (sort deps s-expdate sec)]) - (format "~a-~a-~a ~a:~a:~a" - (date-year d) (date-month d) (date-day d) - (date-hour d) (date-minute d) (date-second d)))) - -(define (verify-times ss-name zo-name) - (when (eq? 'modify-seconds (use-compiled-file-check)) - (define ss-sec (file-or-directory-modify-seconds ss-name)) - (define zo-sec (try-file-time zo-name)) - (cond [(not ss-sec) (error 'compile-zo "internal error")] - [(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a" - zo-name ss-name)] - [(< zo-sec ss-sec) (error 'compile-zo - "date for newly created .zo file (~a @ ~a) ~ - is before source-file date (~a @ ~a)~a" - zo-name (format-time zo-sec) - ss-name (format-time ss-sec) - (if (> ss-sec (current-seconds)) - ", which appears to be in the future" - ""))]))) - -(define-struct ext-reader-guard (proc top) - #:property prop:procedure (struct-field-index proc)) -(define-struct file-dependency (path module?) #:prefab) -(define-struct (file-dependency/options file-dependency) (table) #:prefab) - -(define (compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache) - ;; The `path' argument has been converted to .rkt or .ss form, - ;; as appropriate. - ;; External dependencies registered through reader guard and - ;; accomplice-logged events: - (define external-deps null) - (define external-module-deps null) - (define reader-deps null) - (define deps-sema (make-semaphore 1)) - (define done-key (gensym)) - (define (external-dep! p module? indirect?) - (define bstr (path->bytes p)) - (define dep (if indirect? - (cons 'indirect bstr) - bstr)) - (if module? - (set! external-module-deps (cons dep external-module-deps)) - (set! external-deps (cons dep external-deps)))) - (define (reader-dep! p) - (call-with-semaphore - deps-sema - (lambda () - (set! reader-deps (cons (path->bytes p) reader-deps))))) - - ;; Set up a logger to receive and filter accomplice events: - (define accomplice-logger (make-logger #f (current-logger) - ;; Don't propoagate 'cm-accomplice events, so that - ;; enclosing compilations don't see events intended - ;; for this one: - 'none 'cm-accomplice - ;; Propagate everything else: - 'debug)) - (define receiver (make-log-receiver accomplice-logger 'info 'cm-accomplice)) - - ;; Compile the code: - (define code - (parameterize ([current-reader-guard - (let* ([rg (current-reader-guard)] - [rg (if (ext-reader-guard? rg) - (ext-reader-guard-top rg) - rg)]) - (make-ext-reader-guard - (lambda (d) - ;; Start by calling the top installed guard to - ;; transform the module path, avoiding redundant - ;; dependencies by avoiding accumulation of these - ;; guards. - (let ([d (rg d)]) - (when (module-path? d) - (let* ([p (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join d #f)))] - [p (if (pair? p) - ;; Create a dependency only if - ;; the corresponding submodule is - ;; declared: - (if (module-declared? d #t) - (car p) - #f) - p)]) - (when (path? p) (reader-dep! p)))) - d)) - rg))] - [current-logger accomplice-logger]) - (with-continuation-mark - managed-compiled-context-key - path - (get-module-code path (path->mode path) compile - (lambda (a b) #f) ; extension handler - #:source-reader read-src-syntax)))) - (define dest-roots (list (car roots))) - (define code-dir (get-compilation-dir path #:modes (list (path->mode path)) #:roots dest-roots)) - - ;; Get all accomplice data: - (let loop () - (let ([l (sync/timeout 0 receiver)]) - (when l - (when (and (eq? (vector-ref l 0) 'info) - (file-dependency? (vector-ref l 2)) - (path? (file-dependency-path (vector-ref l 2)))) - (external-dep! (file-dependency-path (vector-ref l 2)) - (file-dependency-module? (vector-ref l 2)) - (and (file-dependency/options? (vector-ref l 2)) - (hash-ref (file-dependency/options-table (vector-ref l 2)) - 'indirect - #f)))) - (loop)))) - - ;; Write the code and dependencies: - (when code - (with-compiler-security-guard (make-directory* code-dir)) - (with-compile-output zo-name - (lambda (out tmp-name) - (with-handlers ([exn:fail? - (lambda (ex) - (close-output-port out) - (compilation-failure path->mode dest-roots path zo-name #f - (exn-message ex)) - (raise ex))]) - (parameterize ([current-write-relative-directory - (let* ([dir - (let-values ([(base name dir?) (split-path path)]) - (if (eq? base 'relative) - (current-directory) - (path->complete-path base (current-directory))))] - [collects-dir (find-collects-dir)] - [e-dir (explode-path dir)] - [e-collects-dir (explode-path collects-dir)]) - (if (and ((length e-dir) . > . (length e-collects-dir)) - (for/and ([a (in-list e-dir)] - [b (in-list e-collects-dir)]) - (equal? a b))) - ;; `dir' extends `collects-dir': - (cons dir collects-dir) - ;; `dir' doesn't extend `collects-dir': - dir))]) - (let ([b (open-output-bytes)]) - ;; Write bytecode into string - (write code b) - ;; Compute SHA1 over modules within bytecode - (let* ([s (get-output-bytes b)]) - (install-module-hashes! s) - ;; Write out the bytecode with module hash - (write-bytes s out))))) - ;; redundant, but close as early as possible: - (close-output-port out) - ;; Note that we check time and write .deps before returning from - ;; with-compile-output... - (verify-times path tmp-name) - (write-deps code path->mode dest-roots path src-sha1 - external-deps external-module-deps reader-deps - up-to-date collection-cache read-src-syntax))) - (trace-printf "wrote zo file: ~a" zo-name))) - -(define (install-module-hashes! s [start 0] [len (bytes-length s)]) - (define vlen (bytes-ref s (+ start 2))) - (define mode (integer->char (bytes-ref s (+ start 3 vlen)))) - (case mode - [(#\T) - ;; A single module: - (define h (sha1-bytes (open-input-bytes (if (and (zero? start) - (= len (bytes-length s))) - s - (subbytes s start (+ start len)))))) - ;; Write sha1 for module hash: - (bytes-copy! s (+ start 4 vlen) h)] - [(#\D) - ;; A directory form modules and submodules. The format starts with , - ;; and then it's records of the format: - ;; - (define (read-num rel-pos) - (define pos (+ start rel-pos)) - (integer-bytes->integer s #t #f pos (+ pos 4))) - (define count (read-num (+ 4 vlen))) - (for/fold ([pos (+ 8 vlen)]) ([i (in-range count)]) - (define pos-pos (+ pos 4 (read-num pos))) - (define mod-start (read-num pos-pos)) - (define mod-len (read-num (+ pos-pos 4))) - (install-module-hashes! s (+ start mod-start) mod-len) - (+ pos-pos 16)) - (void)] - [else - ;; ?? unknown mode - (void)])) - -(define (actual-source-path path) - (if (file-exists? path) - path - (let ([alt-path (rkt->ss path)]) - (if (file-exists? alt-path) - alt-path - path)))) - -(define (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen) - (let ([actual-path (actual-source-path orig-path)]) - (unless sha1-only? - ((manager-compile-notify-handler) actual-path) - (trace-printf "maybe-compile-zo starting ~a" actual-path)) - (begin0 - (parameterize ([indent (+ 2 (indent))]) - (let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")] - [zo-exists? (file-exists? zo-name)]) - (if (and zo-exists? (trust-existing-zos)) - (begin - (trace-printf "trusting: ~a" zo-name) - (touch zo-name) - #f) - (let ([src-sha1 (and zo-exists? - deps - (cadr deps) - (get-source-sha1 path))]) - (if (and zo-exists? - src-sha1 - (equal? src-sha1 (and (pair? (cadr deps)) - (caadr deps))) - (equal? (get-dep-sha1s (cddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen) - (cdadr deps))) - (begin - (trace-printf "hash-equivalent: ~a" zo-name) - (touch zo-name) - #f) - ((if sha1-only? values (lambda (build) (build) #f)) - (lambda () - (let* ([lc (parallel-lock-client)] - [_ (when lc (log-compile-event path 'locking))] - [locked? (and lc (lc 'lock zo-name))] - [ok-to-compile? (or (not lc) locked?)]) - (dynamic-wind - (lambda () (void)) - (lambda () - (when ok-to-compile? - (log-compile-event path 'start-compile) - (when zo-exists? (try-delete-file zo-name #f)) - (trace-printf "compiling ~a" actual-path) - (parameterize ([depth (+ (depth) 1)]) - (with-handlers - ([exn:get-module-code? - (lambda (ex) - (compilation-failure path->mode roots path zo-name - (exn:get-module-code-path ex) - (exn-message ex)) - (raise ex))]) - (compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache))) - (trace-printf "compiled ~a" actual-path))) - (lambda () - (when lc - (log-compile-event path (if locked? 'finish-compile 'already-done))) - (when locked? - (lc 'unlock zo-name)))))))))))) - (unless sha1-only? - (trace-printf "maybe-compile-zo finished ~a" actual-path))))) - -(define (get-compiled-time path->mode roots path) - (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) - (or (try-file-time (build-path dir "native" (system-library-subpath) - (path-add-extension name (system-type - 'so-suffix)))) - (try-file-time (build-path dir (path-add-extension name #".zo"))))) - -(define (try-file-sha1 path dep-path) - (with-module-reading-parameterization - (lambda () - (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) - (string-append - (call-with-input-file* path sha1) - (with-handlers ([exn:fail:filesystem? (lambda (exn) "")]) - (call-with-input-file* dep-path (lambda (p) (cdadr (read p)))))))))) - -(define (get-compiled-sha1 path->mode roots path) - (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) - (let ([dep-path (build-path dir (path-add-extension name #".dep"))]) - (or (try-file-sha1 (build-path dir "native" (system-library-subpath) - (path-add-extension name (system-type - 'so-suffix))) - dep-path) - (try-file-sha1 (build-path dir (path-add-extension name #".zo")) - dep-path) - ""))) - -(define (different-source-sha1-and-dep-recorded path deps) - (define src-hash (get-source-sha1 path)) - (define recorded-hash (and (pair? (cadr deps)) - (caadr deps))) - (if (equal? src-hash recorded-hash) - #f - (list src-hash recorded-hash))) - -(define (rkt->ss p) - (if (path-has-extension? p #".rkt") - (path-replace-extension p #".ss") - p)) - -(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen) - (define orig-path (simple-form-path path0)) - (define (read-deps path) - (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))]) - (with-module-reading-parameterization - (lambda () - (call-with-input-file* - (path-add-extension (get-compilation-path path->mode roots path) #".dep") - read))))) - (define (do-check) - (let* ([main-path orig-path] - [alt-path (rkt->ss orig-path)] - [main-path-time (try-file-time main-path)] - [alt-path-time (and (not main-path-time) - (not (eq? alt-path main-path)) - (try-file-time alt-path))] - [path (if alt-path-time alt-path main-path)] - [path-time (or main-path-time alt-path-time)] - [path-zo-time (get-compiled-time path->mode roots path)]) - (cond - [(hash-ref seen path #f) - (error 'compile-zo - "dependency cycle\n involves module: ~a" - path) - #f] - [(not path-time) - (trace-printf "~a does not exist" orig-path) - (or (hash-ref up-to-date orig-path #f) - (let ([stamp (cons (or path-zo-time +inf.0) - (delay (get-compiled-sha1 path->mode roots path)))]) - (hash-set! up-to-date main-path stamp) - (unless (eq? main-path alt-path) - (hash-set! up-to-date alt-path stamp)) - stamp))] - [else - (let ([deps (read-deps path)] - [new-seen (hash-set seen path #t)]) - (define build - (cond - [(not (and (pair? deps) (equal? (version) (car deps)))) - (lambda () - (trace-printf "newer version...") - (maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] - [(> path-time (or path-zo-time -inf.0)) - (trace-printf "newer src... ~a > ~a" path-time path-zo-time) - ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: - (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] - [(different-source-sha1-and-dep-recorded path deps) - => (lambda (difference) - (trace-printf "different src hash... ~a" difference) - ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: - (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] - [(ormap-strict - (lambda (p) - (define ext? (external-dep? p)) - (define d (collects-relative*->path (dep->encoded-path p) collection-cache)) - (define t - (if ext? - (cons (or (try-file-time d) +inf.0) #f) - (compile-root path->mode roots d up-to-date collection-cache read-src-syntax #f new-seen))) - (and t - (car t) - (> (car t) (or path-zo-time -inf.0)) - (begin (trace-printf "newer: ~a (~a > ~a)..." - d (car t) path-zo-time) - #t))) - (cddr deps)) - ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: - (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] - [else #f])) - (cond - [(and build sha1-only?) #f] - [else - (when build (build)) - (let ([stamp (cons (or (get-compiled-time path->mode roots path) +inf.0) - (delay (get-compiled-sha1 path->mode roots path)))]) - (hash-set! up-to-date main-path stamp) - (unless (eq? main-path alt-path) - (hash-set! up-to-date alt-path stamp)) - stamp)]))]))) - (or (hash-ref up-to-date orig-path #f) - (let ([v ((manager-skip-file-handler) orig-path)]) - (and v - (hash-set! up-to-date orig-path v) - v)) - (begin (trace-printf "checking: ~a" orig-path) - (do-check)))) - -(define (ormap-strict f l) - (cond - [(null? l) #f] - [else - (define a (f (car l))) - (define b (ormap-strict f (cdr l))) - (or a b)])) - -(define (managed-compile-zo zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) - ((make-caching-managed-compile-zo read-src-syntax #:security-guard security-guard) zo)) - -(define (make-caching-managed-compile-zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) - (let ([cache (make-hash)] - [collection-cache (make-hash)]) - (lambda (src) - (parameterize ([current-load/use-compiled - (make-compilation-manager-load/use-compiled-handler/table - cache - collection-cache - #f - #:security-guard security-guard)] - [error-display-handler - (make-compilation-context-error-display-handler - (error-display-handler))]) - (compile-root (or (current-path->mode) - (let ([mode (car (use-compiled-file-paths))]) - (λ (pth) mode))) - (current-compiled-file-roots) - (path->complete-path src) - cache - collection-cache - read-src-syntax - #f - #hash()) - (void))))) - -(define (make-compilation-manager-load/use-compiled-handler [delete-zos-when-rkt-file-does-not-exist? #f] - #:security-guard - [security-guard #f]) - (make-compilation-manager-load/use-compiled-handler/table (make-hash) (make-hash) - delete-zos-when-rkt-file-does-not-exist? - #:security-guard security-guard)) - -(define (make-compilation-manager-load/use-compiled-handler/table cache collection-cache - delete-zos-when-rkt-file-does-not-exist? - #:security-guard [security-guard #f]) - - - (define cp->m (current-path->mode)) - (define modes (use-compiled-file-paths)) - (when (and (not cp->m) (null? modes)) - (raise-mismatch-error 'make-compilation-manager-... - "use-compiled-file-paths is '() and current-path->mode is #f")) - (define path->mode (or cp->m (λ (p) (car modes)))) - (let ([orig-eval (current-eval)] - [orig-load (current-load)] - [orig-registry (namespace-module-registry (current-namespace))] - [default-handler (current-load/use-compiled)] - [roots (current-compiled-file-roots)]) - (define (compilation-manager-load-handler path mod-name) - (cond [(or (not mod-name) - ;; Don't trigger compilation if we're not supposed to work with source: - (and (pair? mod-name) - (not (car mod-name)))) - (trace-printf "skipping: ~a mod-name ~s" path mod-name)] - [(not (or (file-exists? path) - (let ([p2 (rkt->ss path)]) - (and (not (eq? path p2)) - (file-exists? p2))))) - (trace-printf "skipping: ~a file does not exist" path) - (when delete-zos-when-rkt-file-does-not-exist? - (define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo")) - (when (file-exists? to-delete) - (trace-printf "deleting: ~s" to-delete) - (with-compiler-security-guard (delete-file to-delete))))] - [(if cp->m - (not (equal? (current-path->mode) cp->m)) - (let ([current-cfp (use-compiled-file-paths)]) - (or (null? current-cfp) - (not (equal? (car current-cfp) (car modes)))))) - (if cp->m - (trace-printf "skipping: ~a current-path->mode changed; current value ~s, original value was ~s" - path (current-path->mode) cp->m) - (trace-printf "skipping: ~a use-compiled-file-paths's first element changed; current value ~s, first element was ~s" - path - (use-compiled-file-paths) - (car modes)))] - [(not (equal? roots (current-compiled-file-roots))) - (trace-printf "skipping: ~a current-compiled-file-roots changed; current value ~s, original was ~s" - path - (current-compiled-file-roots) - roots)] - [(not (eq? compilation-manager-load-handler - (current-load/use-compiled))) - (trace-printf "skipping: ~a current-load/use-compiled changed ~s" - path (current-load/use-compiled))] - [(not (eq? orig-eval (current-eval))) - (trace-printf "skipping: ~a orig-eval ~s current-eval ~s" - path orig-eval (current-eval))] - [(not (eq? orig-load (current-load))) - (trace-printf "skipping: ~a orig-load ~s current-load ~s" - path orig-load (current-load))] - [(not (eq? orig-registry - (namespace-module-registry (current-namespace)))) - (trace-printf "skipping: ~a orig-registry ~s current-registry ~s" - path orig-registry - (namespace-module-registry (current-namespace)))] - [else - (trace-printf "processing: ~a" path) - (parameterize ([compiler-security-guard security-guard]) - (compile-root path->mode roots path cache collection-cache read-syntax #f #hash())) - (trace-printf "done: ~a" path)]) - (default-handler path mod-name)) - (when (null? roots) - (raise-mismatch-error 'make-compilation-manager-... - "empty current-compiled-file-roots list: " - roots)) - compilation-manager-load-handler)) - - -;; Exported: -(define (get-compiled-file-sha1 path) - (try-file-sha1 path (path-replace-extension path #".dep"))) - -(define (get-file-sha1 path) - (get-source-sha1 path)) +;; ---------------------------------------- (define (make-compile-lock) (define-values (manager-side-chan build-side-chan) (place-channel)) diff --git a/racket/collects/compiler/depend.rkt b/racket/collects/compiler/depend.rkt new file mode 100644 index 0000000000..091186ba30 --- /dev/null +++ b/racket/collects/compiler/depend.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require compiler/compilation-path + compiler/private/dep + setup/collects) + +(provide module-recorded-dependencies) + +(define (module-recorded-dependencies path) + (define collection-cache (make-hash)) + (define (module-dependencies path all-deps) + (define dep-path (path-add-extension (get-compilation-path path) #".dep")) + (define deps (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)] + [exn:fail:read? (lambda (exn) #f)]) + (call-with-input-file* dep-path read))) + (for/fold ([all-deps all-deps]) ([dep (in-list (if (and (list? deps) + (pair? deps) + (pair? (cdr deps))) + (cddr deps) + '()))]) + (define p (collects-relative*->path (dep->encoded-path dep) collection-cache)) + (cond + [(hash-ref all-deps p #f) all-deps] + [else + (define new-deps (hash-set all-deps p #t)) + (cond + [(external-dep? dep) new-deps] + [else (module-dependencies p new-deps)])]))) + (hash-keys (module-dependencies (simplify-path path) #hash()))) + +(define (get-compilation-path path) + (define-values (dir name) (get-compilation-dir+name path)) + (build-path dir name)) + +(define (collects-relative*->path p cache) + (if (bytes? p) + (bytes->path p) + (hash-ref! cache p (lambda () (collects-relative->path p))))) diff --git a/racket/collects/compiler/distribute.rkt b/racket/collects/compiler/distribute.rkt index a800f6dc6b..eba3572873 100644 --- a/racket/collects/compiler/distribute.rkt +++ b/racket/collects/compiler/distribute.rkt @@ -32,7 +32,7 @@ (case (cross-system-type) [(windows) #f] [(unix) "bin"] - [(macosx) (if (memq type '(gracketcgc gracket3m)) + [(macosx) (if (memq type '(gracketcgc gracket3m gracketcs)) #f "bin")]))) orig-binaries @@ -48,7 +48,7 @@ (make-directory dest-dir)) (let-values ([(base name dir?) (split-path b)]) (let ([dest (build-path dest-dir name)]) - (if (and (memq type '(gracketcgc gracket3m)) + (if (and (memq type '(gracketcgc gracket3m gracketcs)) (eq? 'macosx (cross-system-type))) (begin (copy-app b dest) @@ -67,7 +67,7 @@ [single-mac-app? (and executables? (eq? 'macosx (cross-system-type)) (= 1 (length types)) - (memq (car types) '(gracketcgc gracket3m)))]) + (memq (car types) '(gracketcgc gracket3m gracketcs)))]) ;; Create directories for libs, collects, and extensions: (let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir) (if single-mac-app? @@ -131,7 +131,7 @@ [sub-dir (build-path 'up relative-dir)] [(and (eq? 'macosx (cross-system-type)) - (memq type '(gracketcgc gracket3m)) + (memq type '(gracketcgc gracket3m gracketcs)) (not single-mac-app?)) (build-path 'up 'up 'up relative-dir)] [else @@ -187,15 +187,23 @@ (memq 'gracket3m types)) (map copy-dll (list - (versionize "libracket3m~a.dll"))))))] + (versionize "libracket3m~a.dll")))) + (when (or (memq 'racketcs types) + (memq 'gracketcs types)) + (map copy-dll + (list + (versionize "libracketcs~a.dll"))))))] [(macosx) (unless extras-only? (when (or (memq 'racketcgc types) (memq 'gracketcgc types)) - (copy-framework "Racket" #f lib-dir)) + (copy-framework "Racket" 'cgc lib-dir)) (when (or (memq 'racket3m types) (memq 'gracket3m types)) - (copy-framework "Racket" #t lib-dir)))] + (copy-framework "Racket" '3m lib-dir)) + (when (or (memq 'racketcs types) + (memq 'gracketcs types)) + (copy-framework "Racket" 'cs lib-dir)))] [(unix) (unless extras-only? (let ([lib-plt-dir (build-path lib-dir "plt")]) @@ -213,10 +221,14 @@ (copy-bin "racket" 'cgc #f)) (when (memq 'racket3m types) (copy-bin "racket" '3m #f)) + (when (memq 'racketcs types) + (copy-bin "racket" 'cs #f)) (when (memq 'gracketcgc types) (copy-bin "gracket" 'cgc #t)) (when (memq 'gracket3m types) - (copy-bin "gracket" '3m #t))) + (copy-bin "gracket" '3m #t)) + (when (memq 'gracketcs types) + (copy-bin "gracket" 'cs #t))) (when (shared-libraries?) (when (or (memq 'racketcgc types) (memq 'gracketcgc types)) @@ -224,7 +236,10 @@ (copy-shared-lib "mzgc" lib-dir)) (when (or (memq 'racket3m types) (memq 'gracket3m types)) - (copy-shared-lib "racket3m" lib-dir)))))])) + (copy-shared-lib "racket3m" lib-dir)) + (when (or (memq 'racketcs types) + (memq 'gracketcs types)) + (copy-shared-lib "racketcs" lib-dir)))))])) (define (search-dll dll-dir dll) (if dll-dir @@ -248,12 +263,13 @@ ;; Can't find it, so just use executable's dir: (build-path exe-dir dll))))) - (define (copy-framework name 3m? lib-dir) + (define (copy-framework name variant lib-dir) (let* ([fw-name (format "~a.framework" name)] [sub-dir (build-path fw-name "Versions" - (if 3m? - (format "~a_3m" (version)) - (version)))]) + (case variant + [(3m) (format "~a_3m" (version))] + [(cs) (format "~a_CS" (version))] + [else (version)]))]) (make-directory* (build-path lib-dir sub-dir)) (let* ([fw-name (build-path sub-dir (format "~a" name))] [dll-dir (find-framework fw-name)]) @@ -308,18 +324,18 @@ binaries)] [(macosx) (if (and (= 1 (length types)) - (memq (car types) '(gracketcgc gracket3m))) + (memq (car types) '(gracketcgc gracket3m gracketcs))) ;; Special case for single GRacket app: (update-framework-path "@executable_path/../Frameworks/" (car binaries) #t) ;; General case: (for-each (lambda (b type) - (update-framework-path (if (memq type '(racketcgc racket3m)) + (update-framework-path (if (memq type '(racketcgc racket3m racketcs)) "@executable_path/../lib/" "@executable_path/../../../lib/" ) b - (memq type '(gracketcgc gracket3m)))) + (memq type '(gracketcgc gracket3m gracketcs)))) binaries types))] [(unix) (for-each (lambda (b type) @@ -645,14 +661,19 @@ (error 'assemble-distribution "file is an original PLT executable, not a stub binary: ~e" b))) - (let ([3m? (equal? (list-ref m 4) #"3")]) + (let ([variant (case (list-ref m 4) + [(#"3") '3m] + [(#"s") 'cs] + [else 'cgc])]) (if (equal? (caddr m) #"r") - (if 3m? - 'gracket3m - 'gracketcgc) - (if 3m? - 'racket3m - 'racketcgc)))) + (case variant + [(3m) 'gracket3m] + [(cs) 'gracketcs] + [else 'gracketcgc]) + (case variant + [(3m) 'racket3m] + [(cs) 'racketcs] + [else 'racketcgc])))) (error 'assemble-distribution "file is not a PLT executable: ~e" b)))))) diff --git a/racket/collects/compiler/embed.rkt b/racket/collects/compiler/embed.rkt index 07e43c88df..f24e0cda4c 100644 --- a/racket/collects/compiler/embed.rkt +++ b/racket/collects/compiler/embed.rkt @@ -60,7 +60,7 @@ #:cmdline (listof string?) #:gracket? any/c #:mred? any/c - #:variant (or/c '3m 'cgc) + #:variant (or/c '3m 'cgc 'cs) #:aux (listof (cons/c symbol? any/c)) #:collects-path (or/c #f path-string? @@ -1720,7 +1720,8 @@ (lambda () (find-cmdline "configuration" #"cOnFiG:")))] - [typepos (and (or mred? (eq? variant '3m)) + [typepos (and (or mred? (or (eq? variant '3m) + (eq? variant 'cs))) (with-input-from-file dest-exe (lambda () (find-cmdline "exeuctable type" @@ -1743,6 +1744,9 @@ (when (eq? variant '3m) (file-position out (+ typepos 15)) (write-bytes #"3" out)) + (when (eq? variant 'cs) + (file-position out (+ typepos 15)) + (write-bytes #"s" out)) (flush-output out)) (file-position out (+ numpos 7)) (write-bytes #"!" out) diff --git a/racket/collects/compiler/private/cm-minimal.rkt b/racket/collects/compiler/private/cm-minimal.rkt new file mode 100644 index 0000000000..8e218c56b6 --- /dev/null +++ b/racket/collects/compiler/private/cm-minimal.rkt @@ -0,0 +1,763 @@ +#lang racket/base +(require syntax/private/modcode-noctc + syntax/private/modresolve-noctc + syntax/modread + setup/private/dirs + racket/file + racket/list + racket/path + racket/promise + openssl/sha1 + setup/collects + compiler/compilation-path + compiler/private/dep) + +(provide make-compilation-manager-load/use-compiled-handler + managed-compile-zo + make-caching-managed-compile-zo + trust-existing-zos + manager-compile-notify-handler + manager-skip-file-handler + manager-trace-handler + get-file-sha1 + get-compiled-file-sha1 + with-compile-output + + managed-compiled-context-key + make-compilation-context-error-display-handler + + parallel-lock-client + + install-module-hashes! + + current-path->mode) + +(module+ cm-internal + (provide try-file-time + rkt->ss + get-source-sha1)) + +(define current-path->mode (make-parameter #f)) + +(define cm-logger (make-logger 'compiler/cm (current-logger))) +(define (default-manager-trace-handler str) + (when (log-level? cm-logger 'debug) + (log-message cm-logger 'debug str (current-inexact-milliseconds)))) + +(struct compile-event (timestamp path action) #:prefab) +(define (log-compile-event path action) + (when (log-level? cm-logger 'info 'compiler/cm) + (log-message cm-logger 'info (format "~a~a: ~a" (get-indent-string) action path) + (compile-event (current-inexact-milliseconds) path action)))) + +(define manager-compile-notify-handler (make-parameter void)) +(define manager-trace-handler (make-parameter default-manager-trace-handler)) +(define indent (make-parameter 0)) +(define trust-existing-zos (make-parameter #f)) +(define manager-skip-file-handler (make-parameter (λ (x) #f))) +(define depth (make-parameter 0)) +(define parallel-lock-client (make-parameter #f)) + +(define managed-compiled-context-key (gensym)) +(define (make-compilation-context-error-display-handler orig) + (lambda (str exn) + (define l (continuation-mark-set->list + (exn-continuation-marks exn) + managed-compiled-context-key)) + (orig (if (null? l) + str + (apply + string-append + str + "\n compilation context...:" + (for/list ([i (in-list l)]) + (format "\n ~a" i)))) + exn))) + +(define (try-file-time p) + (let ([s (file-or-directory-modify-seconds p #f (lambda () #f))]) + (and s + (if (eq? (use-compiled-file-check) 'modify-seconds) + s + 0)))) + +(define (path*->collects-relative p) + (if (bytes? p) + (let ([q (path->collects-relative (bytes->path p))]) + (if (path? q) + (path->bytes q) + q)) + (path->collects-relative p))) + +(define (collects-relative*->path p cache) + (if (bytes? p) + (bytes->path p) + (hash-ref! cache p (lambda () (collects-relative->path p))))) + +(define (trace-printf fmt . args) + (let ([t (manager-trace-handler)]) + (unless (or (eq? t void) + (and (equal? t default-manager-trace-handler) + (not (log-level? cm-logger 'debug)))) + (t (string-append (get-indent-string) + (apply format fmt args)))))) + +(define (get-indent-string) + (build-string (indent) + (λ (x) + (if (and (= 2 (modulo x 3)) + (not (= x (- (indent) 1)))) + #\| + #\space)))) + +(define (get-deps code path) + (define ht + (let loop ([code code] [ht (hash)]) + (define new-ht + (for*/fold ([ht ht]) ([imports (in-list (module-compiled-imports code))] + [x (in-list (cdr imports))]) + (let* ([r (resolve-module-path-index x path)] + [r (if (pair? r) (cadr r) r)]) + (if (and (path? r) + (not (equal? path r)) + (not (equal? path r)) + (not (equal? path (rkt->ss r)))) + (hash-set ht (path->bytes r) #t) + ht)))) + (for*/fold ([ht new-ht]) ([non-star? (in-list '(#f #t))] + [subcode (in-list (module-compiled-submodules code non-star?))]) + (loop subcode ht)))) + (for/list ([k (in-hash-keys ht)]) k)) + +(define (get-compilation-path path->mode roots path) + (let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)]) + (build-path dir name))) + +(define (touch path) + (when (eq? 'modify-seconds (use-compiled-file-check)) + (with-compiler-security-guard + (file-or-directory-modify-seconds + path + (current-seconds) + (lambda () + (close-output-port (open-output-file path #:exists 'append))))))) + +(define (try-delete-file path [noisy? #t]) + ;; Attempt to delete, but give up if it doesn't work: + (with-handlers ([exn:fail:filesystem? void]) + (when noisy? (trace-printf "deleting ~a" path)) + (with-compiler-security-guard (delete-file path)))) + +(define (compilation-failure path->mode roots path zo-name date-path reason) + (try-delete-file zo-name) + (trace-printf "failure")) + +;; with-compile-output : path (output-port path -> alpha) -> alpha +(define (with-compile-output path proc) + (call-with-atomic-output-file + path + #:security-guard (pick-security-guard) + proc)) + +(define-syntax-rule + (with-compiler-security-guard expr) + (parameterize ([current-security-guard (pick-security-guard)]) + expr)) + +(define compiler-security-guard (make-parameter #f)) + +(define (pick-security-guard) + (or (compiler-security-guard) + (current-security-guard))) + +(define (get-source-sha1 p) + (with-handlers ([exn:fail:filesystem? (lambda (exn) + (and (path-has-extension? p #".rkt") + (get-source-sha1 (path-replace-extension p #".ss"))))]) + (call-with-input-file* p sha1))) + +(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen) + (let ([l (for/fold ([l null]) ([dep (in-list deps)]) + (and l + (let* ([ext? (external-dep? dep)] + [p (collects-relative*->path (dep->encoded-path dep) collection-cache)]) + (cond + [ext? (let ([v (get-source-sha1 p)]) + (cond + [v (cons (cons (delay v) dep) l)] + [must-exist? (error 'cm "cannot find external-dependency file: ~v" p)] + [else #f]))] + [(or (hash-ref up-to-date (simple-form-path p) #f) + ;; Use `compile-root' with `sha1-only?' as #t: + (compile-root path->mode roots p up-to-date collection-cache read-src-syntax #t seen)) + => (lambda (sh) + (cons (cons (cdr sh) dep) l))] + [must-exist? + ;; apparently, we're forced to use the source of the module, + ;; so compute a sha1 from it instead of the bytecode + (cons (cons (get-source-sha1 p) dep) l)] + [else #f]))))]) + (and l + (let ([p (open-output-string)] + [l (map (lambda (v) + (let ([sha1 (force (car v))] + [dep (cdr v)]) + (unless sha1 + (error 'cm "no SHA-1 for dependency: ~s" dep)) + (cons sha1 dep))) + l)]) + ;; sort by sha1s so that order doesn't matter + (write (sort l stringmode roots path src-sha1 + external-deps external-module-deps reader-deps + up-to-date collection-cache read-src-syntax) + (let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")] + [deps (remove-duplicates (append (get-deps code path) + external-module-deps ; can create cycles if misused! + reader-deps))] + [external-deps (remove-duplicates external-deps)]) + (define (path*->collects-relative/maybe-indirect dep) + (if (and (pair? dep) (eq? 'indirect (car dep))) + (cons 'indirect (path*->collects-relative (cdr dep))) + (path*->collects-relative dep))) + (with-compile-output dep-path + (lambda (op tmp-path) + (let ([deps (append + (map path*->collects-relative/maybe-indirect deps) + (map (lambda (x) + (define d (path*->collects-relative/maybe-indirect x)) + (if (and (pair? d) (eq? 'indirect d)) + (cons 'indirect (cons 'ext (cdr d))) + (cons 'ext d))) + external-deps))]) + (write (list* (version) + (cons (or src-sha1 (get-source-sha1 path)) + (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash())) + (sort deps s-expdate sec)]) + (format "~a-~a-~a ~a:~a:~a" + (date-year d) (date-month d) (date-day d) + (date-hour d) (date-minute d) (date-second d)))) + +(define (verify-times ss-name zo-name) + (when (eq? 'modify-seconds (use-compiled-file-check)) + (define ss-sec (file-or-directory-modify-seconds ss-name)) + (define zo-sec (try-file-time zo-name)) + (cond [(not ss-sec) (error 'compile-zo "internal error")] + [(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a" + zo-name ss-name)] + [(< zo-sec ss-sec) (error 'compile-zo + "date for newly created .zo file (~a @ ~a) ~ + is before source-file date (~a @ ~a)~a" + zo-name (format-time zo-sec) + ss-name (format-time ss-sec) + (if (> ss-sec (current-seconds)) + ", which appears to be in the future" + ""))]))) + +(define-struct ext-reader-guard (proc top) + #:property prop:procedure (struct-field-index proc)) +(define-struct file-dependency (path module?) #:prefab) +(define-struct (file-dependency/options file-dependency) (table) #:prefab) + +(define (compile-zo* path->mode roots path src-sha1 read-src-syntax orig-zo-name up-to-date collection-cache) + ;; The `path' argument has been converted to .rkt or .ss form, + ;; as appropriate. + ;; External dependencies registered through reader guard and + ;; accomplice-logged events: + (define external-deps null) + (define external-module-deps null) + (define reader-deps null) + (define deps-sema (make-semaphore 1)) + (define done-key (gensym)) + (define (external-dep! p module? indirect?) + (define bstr (path->bytes p)) + (define dep (if indirect? + (cons 'indirect bstr) + bstr)) + (if module? + (set! external-module-deps (cons dep external-module-deps)) + (set! external-deps (cons dep external-deps)))) + (define (reader-dep! p) + (call-with-semaphore + deps-sema + (lambda () + (set! reader-deps (cons (path->bytes p) reader-deps))))) + + ;; Set up a logger to receive and filter accomplice events: + (define accomplice-logger (make-logger #f (current-logger) + ;; Don't propoagate 'cm-accomplice events, so that + ;; enclosing compilations don't see events intended + ;; for this one: + 'none 'cm-accomplice + ;; Propagate everything else: + 'debug)) + (define receiver (make-log-receiver accomplice-logger 'info 'cm-accomplice)) + + ;; Compile the code: + (define code + (parameterize ([current-reader-guard + (let* ([rg (current-reader-guard)] + [rg (if (ext-reader-guard? rg) + (ext-reader-guard-top rg) + rg)]) + (make-ext-reader-guard + (lambda (d) + ;; Start by calling the top installed guard to + ;; transform the module path, avoiding redundant + ;; dependencies by avoiding accumulation of these + ;; guards. + (let ([d (rg d)]) + (when (module-path? d) + (let* ([p (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join d #f)))] + [p (if (pair? p) + ;; Create a dependency only if + ;; the corresponding submodule is + ;; declared: + (if (module-declared? d #t) + (car p) + #f) + p)]) + (when (path? p) (reader-dep! p)))) + d)) + rg))] + [current-logger accomplice-logger]) + (with-continuation-mark + managed-compiled-context-key + path + (get-module-code path (path->mode path) compile + (lambda (a b) #f) ; extension handler + #:source-reader read-src-syntax)))) + (define dest-roots (list (car roots))) + (define-values (code-dir code-name) + (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots dest-roots)) + (define zo-name + ;; If we have multiple roots, make sure that compilation uses the first one + (if (pair? (cdr roots)) + (build-path code-dir (path-add-suffix code-name #".zo")) + orig-zo-name)) + + ;; Get all accomplice data: + (let loop () + (let ([l (sync/timeout 0 receiver)]) + (when l + (when (and (eq? (vector-ref l 0) 'info) + (file-dependency? (vector-ref l 2)) + (path? (file-dependency-path (vector-ref l 2)))) + (external-dep! (file-dependency-path (vector-ref l 2)) + (file-dependency-module? (vector-ref l 2)) + (and (file-dependency/options? (vector-ref l 2)) + (hash-ref (file-dependency/options-table (vector-ref l 2)) + 'indirect + #f)))) + (loop)))) + + ;; Write the code and dependencies: + (when code + (with-compiler-security-guard (make-directory* code-dir)) + (with-compile-output zo-name + (lambda (out tmp-name) + (with-handlers ([exn:fail? + (lambda (ex) + (close-output-port out) + (compilation-failure path->mode dest-roots path zo-name #f + (exn-message ex)) + (raise ex))]) + (parameterize ([current-write-relative-directory + (let* ([dir + (let-values ([(base name dir?) (split-path path)]) + (if (eq? base 'relative) + (current-directory) + (path->complete-path base (current-directory))))] + [collects-dir (find-collects-dir)] + [e-dir (explode-path dir)] + [e-collects-dir (explode-path collects-dir)]) + (if (and ((length e-dir) . > . (length e-collects-dir)) + (for/and ([a (in-list e-dir)] + [b (in-list e-collects-dir)]) + (equal? a b))) + ;; `dir' extends `collects-dir': + (cons dir collects-dir) + ;; `dir' doesn't extend `collects-dir': + dir))]) + (let ([b (open-output-bytes)]) + ;; Write bytecode into string + (write code b) + ;; Compute SHA1 over modules within bytecode + (let* ([s (get-output-bytes b)]) + (install-module-hashes! s) + ;; Write out the bytecode with module hash + (write-bytes s out))))) + ;; redundant, but close as early as possible: + (close-output-port out) + ;; Note that we check time and write .deps before returning from + ;; with-compile-output... + (verify-times path tmp-name) + (write-deps code path->mode dest-roots path src-sha1 + external-deps external-module-deps reader-deps + up-to-date collection-cache read-src-syntax))) + (trace-printf "wrote zo file: ~a" zo-name))) + +(define (install-module-hashes! s [start 0] [len (bytes-length s)]) + (define vlen (bytes-ref s (+ start 2))) + (define mode (integer->char (bytes-ref s (+ start 3 vlen)))) + (case mode + [(#\B) + ;; A linklet bundle: + (define h (sha1-bytes (open-input-bytes (if (and (zero? start) + (= len (bytes-length s))) + s + (subbytes s start (+ start len)))))) + ;; Write sha1 for bundle hash: + (bytes-copy! s (+ start 4 vlen) h)] + [(#\D) + ;; A linklet directory. The format starts with , + ;; and then it's records of the format: + ;; + (define (read-num rel-pos) + (define pos (+ start rel-pos)) + (integer-bytes->integer s #t #f pos (+ pos 4))) + (define count (read-num (+ 4 vlen))) + (for/fold ([pos (+ 8 vlen)]) ([i (in-range count)]) + (define pos-pos (+ pos 4 (read-num pos))) + (define bund-start (read-num pos-pos)) + (define bund-len (read-num (+ pos-pos 4))) + (install-module-hashes! s (+ start bund-start) bund-len) + (+ pos-pos 16)) + (void)] + [else + ;; ?? unknown mode + (void)])) + +(define (actual-source-path path) + (if (file-exists? path) + path + (let ([alt-path (rkt->ss path)]) + (if (file-exists? alt-path) + alt-path + path)))) + +(define (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen) + (let ([actual-path (actual-source-path orig-path)]) + (unless sha1-only? + ((manager-compile-notify-handler) actual-path) + (trace-printf "maybe-compile-zo starting ~a" actual-path)) + (begin0 + (parameterize ([indent (+ 2 (indent))]) + (let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")] + [zo-exists? (file-exists? zo-name)]) + (if (and zo-exists? (trust-existing-zos)) + (begin + (trace-printf "trusting: ~a" zo-name) + (touch zo-name) + #f) + (let ([src-sha1 (and zo-exists? + deps + (cadr deps) + (get-source-sha1 path))]) + (if (and zo-exists? + src-sha1 + (equal? src-sha1 (and (pair? (cadr deps)) + (caadr deps))) + (equal? (get-dep-sha1s (cddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen) + (cdadr deps))) + (begin + (trace-printf "hash-equivalent: ~a" zo-name) + (touch zo-name) + #f) + ((if sha1-only? values (lambda (build) (build) #f)) + (lambda () + (let* ([lc (parallel-lock-client)] + [_ (when lc (log-compile-event path 'locking))] + [locked? (and lc (lc 'lock zo-name))] + [ok-to-compile? (or (not lc) locked?)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (when ok-to-compile? + (log-compile-event path 'start-compile) + (when zo-exists? (try-delete-file zo-name #f)) + (trace-printf "compiling ~a" actual-path) + (parameterize ([depth (+ (depth) 1)]) + (with-handlers + ([exn:get-module-code? + (lambda (ex) + (compilation-failure path->mode roots path zo-name + (exn:get-module-code-path ex) + (exn-message ex)) + (raise ex))]) + (compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache))) + (trace-printf "compiled ~a" actual-path))) + (lambda () + (log-compile-event path (if (or (not lc) locked?) 'finish-compile 'already-done)) + (when locked? + (lc 'unlock zo-name)))))))))))) + (unless sha1-only? + (trace-printf "maybe-compile-zo finished ~a" actual-path))))) + +(define (get-compiled-time path->mode roots path) + (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) + (or (try-file-time (build-path dir "native" (system-library-subpath) + (path-add-extension name (system-type + 'so-suffix)))) + (try-file-time (build-path dir (path-add-extension name #".zo"))))) + +(define (try-file-sha1 path dep-path) + (with-module-reading-parameterization + (lambda () + (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) + (string-append + (call-with-input-file* path sha1) + (with-handlers ([exn:fail:filesystem? (lambda (exn) "")]) + (call-with-input-file* dep-path (lambda (p) (cdadr (read p)))))))))) + +(define (get-compiled-sha1 path->mode roots path) + (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) + (let ([dep-path (build-path dir (path-add-extension name #".dep"))]) + (or (try-file-sha1 (build-path dir "native" (system-library-subpath) + (path-add-extension name (system-type + 'so-suffix))) + dep-path) + (try-file-sha1 (build-path dir (path-add-extension name #".zo")) + dep-path) + ""))) + +(define (different-source-sha1-and-dep-recorded path deps) + (define src-hash (get-source-sha1 path)) + (define recorded-hash (and (pair? (cadr deps)) + (caadr deps))) + (if (equal? src-hash recorded-hash) + #f + (list src-hash recorded-hash))) + +(define (rkt->ss p) + (if (path-has-extension? p #".rkt") + (path-replace-extension p #".ss") + p)) + +(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen) + (define orig-path (simple-form-path path0)) + (define (read-deps path) + (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))]) + (with-module-reading-parameterization + (lambda () + (call-with-input-file* + (path-add-extension (get-compilation-path path->mode roots path) #".dep") + read))))) + (define (do-check) + (let* ([main-path orig-path] + [alt-path (rkt->ss orig-path)] + [main-path-time (try-file-time main-path)] + [alt-path-time (and (not main-path-time) + (not (eq? alt-path main-path)) + (try-file-time alt-path))] + [path (if alt-path-time alt-path main-path)] + [path-time (or main-path-time alt-path-time)] + [path-zo-time (get-compiled-time path->mode roots path)]) + (cond + [(hash-ref seen path #f) + (error 'compile-zo + "dependency cycle\n involves module: ~a" + path) + #f] + [(not path-time) + (trace-printf "~a does not exist" orig-path) + (or (hash-ref up-to-date orig-path #f) + (let ([stamp (cons (or path-zo-time +inf.0) + (delay (get-compiled-sha1 path->mode roots path)))]) + (hash-set! up-to-date main-path stamp) + (unless (eq? main-path alt-path) + (hash-set! up-to-date alt-path stamp)) + stamp))] + [else + (let ([deps (read-deps path)] + [new-seen (hash-set seen path #t)]) + (define build + (cond + [(not (and (pair? deps) (equal? (version) (car deps)))) + (lambda () + (trace-printf "newer version...") + (maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] + [(> path-time (or path-zo-time -inf.0)) + (trace-printf "newer src... ~a > ~a" path-time path-zo-time) + ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: + (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] + [(different-source-sha1-and-dep-recorded path deps) + => (lambda (difference) + (trace-printf "different src hash... ~a" difference) + ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: + (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))] + [(ormap-strict + (lambda (p) + (define ext? (external-dep? p)) + (define d (collects-relative*->path (dep->encoded-path p) collection-cache)) + (define t + (if ext? + (cons (or (try-file-time d) +inf.0) #f) + (compile-root path->mode roots d up-to-date collection-cache read-src-syntax #f new-seen))) + (and t + (car t) + (> (car t) (or path-zo-time -inf.0)) + (begin (trace-printf "newer: ~a (~a > ~a)..." + d (car t) path-zo-time) + #t))) + (cddr deps)) + ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk: + (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)] + [else #f])) + (cond + [(and build sha1-only?) #f] + [else + (when build (build)) + (let ([stamp (cons (or (get-compiled-time path->mode roots path) +inf.0) + (delay (get-compiled-sha1 path->mode roots path)))]) + (hash-set! up-to-date main-path stamp) + (unless (eq? main-path alt-path) + (hash-set! up-to-date alt-path stamp)) + stamp)]))]))) + (or (hash-ref up-to-date orig-path #f) + (let ([v ((manager-skip-file-handler) orig-path)]) + (and v + (hash-set! up-to-date orig-path v) + v)) + (begin (trace-printf "checking: ~a" orig-path) + (do-check)))) + +(define (ormap-strict f l) + (cond + [(null? l) #f] + [else + (define a (f (car l))) + (define b (ormap-strict f (cdr l))) + (or a b)])) + +(define (managed-compile-zo zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) + ((make-caching-managed-compile-zo read-src-syntax #:security-guard security-guard) zo)) + +(define (make-caching-managed-compile-zo [read-src-syntax read-syntax] #:security-guard [security-guard #f]) + (let ([cache (make-hash)] + [collection-cache (make-hash)]) + (lambda (src) + (parameterize ([current-load/use-compiled + (make-compilation-manager-load/use-compiled-handler/table + cache + collection-cache + #f + #:security-guard security-guard)] + [error-display-handler + (make-compilation-context-error-display-handler + (error-display-handler))]) + (compile-root (or (current-path->mode) + (let ([mode (car (use-compiled-file-paths))]) + (λ (pth) mode))) + (current-compiled-file-roots) + (path->complete-path src) + cache + collection-cache + read-src-syntax + #f + #hash()) + (void))))) + +(define (make-compilation-manager-load/use-compiled-handler [delete-zos-when-rkt-file-does-not-exist? #f] + #:security-guard + [security-guard #f]) + (make-compilation-manager-load/use-compiled-handler/table (make-hash) (make-hash) + delete-zos-when-rkt-file-does-not-exist? + #:security-guard security-guard)) + +(define (make-compilation-manager-load/use-compiled-handler/table cache collection-cache + delete-zos-when-rkt-file-does-not-exist? + #:security-guard [security-guard #f]) + + + (define cp->m (current-path->mode)) + (define modes (use-compiled-file-paths)) + (when (and (not cp->m) (null? modes)) + (raise-mismatch-error 'make-compilation-manager-... + "use-compiled-file-paths is '() and current-path->mode is #f")) + (define path->mode (or cp->m (λ (p) (car modes)))) + (let ([orig-eval (current-eval)] + [orig-load (current-load)] + [orig-registry (namespace-module-registry (current-namespace))] + [default-handler (current-load/use-compiled)] + [roots (current-compiled-file-roots)]) + (define (compilation-manager-load-handler path mod-name) + (cond [(or (not mod-name) + ;; Don't trigger compilation if we're not supposed to work with source: + (and (pair? mod-name) + (not (car mod-name)))) + (trace-printf "skipping: ~a mod-name ~s" path mod-name)] + [(not (or (file-exists? path) + (let ([p2 (rkt->ss path)]) + (and (not (eq? path p2)) + (file-exists? p2))))) + (trace-printf "skipping: ~a file does not exist" path) + (when delete-zos-when-rkt-file-does-not-exist? + (define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo")) + (when (file-exists? to-delete) + (trace-printf "deleting: ~s" to-delete) + (with-compiler-security-guard (delete-file to-delete))))] + [(if cp->m + (not (equal? (current-path->mode) cp->m)) + (let ([current-cfp (use-compiled-file-paths)]) + (or (null? current-cfp) + (not (equal? (car current-cfp) (car modes)))))) + (if cp->m + (trace-printf "skipping: ~a current-path->mode changed; current value ~s, original value was ~s" + path (current-path->mode) cp->m) + (trace-printf "skipping: ~a use-compiled-file-paths's first element changed; current value ~s, first element was ~s" + path + (use-compiled-file-paths) + (car modes)))] + [(not (equal? roots (current-compiled-file-roots))) + (trace-printf "skipping: ~a current-compiled-file-roots changed; current value ~s, original was ~s" + path + (current-compiled-file-roots) + roots)] + [(not (eq? compilation-manager-load-handler + (current-load/use-compiled))) + (trace-printf "skipping: ~a current-load/use-compiled changed ~s" + path (current-load/use-compiled))] + [(not (eq? orig-eval (current-eval))) + (trace-printf "skipping: ~a orig-eval ~s current-eval ~s" + path orig-eval (current-eval))] + [(not (eq? orig-load (current-load))) + (trace-printf "skipping: ~a orig-load ~s current-load ~s" + path orig-load (current-load))] + [(not (eq? orig-registry + (namespace-module-registry (current-namespace)))) + (trace-printf "skipping: ~a orig-registry ~s current-registry ~s" + path orig-registry + (namespace-module-registry (current-namespace)))] + [else + (trace-printf "processing: ~a" path) + (parameterize ([compiler-security-guard security-guard]) + (compile-root path->mode roots path cache collection-cache read-syntax #f #hash())) + (trace-printf "done: ~a" path)]) + (default-handler path mod-name)) + (when (null? roots) + (raise-mismatch-error 'make-compilation-manager-... + "empty current-compiled-file-roots list: " + roots)) + compilation-manager-load-handler)) + + +;; Exported: +(define (get-compiled-file-sha1 path) + (try-file-sha1 path (path-replace-extension path #".dep"))) + +(define (get-file-sha1 path) + (get-source-sha1 path)) diff --git a/racket/collects/compiler/private/elf.rkt b/racket/collects/compiler/private/elf.rkt index c0c9fb415a..690d64cf97 100644 --- a/racket/collects/compiler/private/elf.rkt +++ b/racket/collects/compiler/private/elf.rkt @@ -258,6 +258,14 @@ (section-size s))) s))) +;; The `get-data` function takes an offset and must return +;; (values bytes any1 any2) +;; The result of `add-racket-section` is either +;; (values #f #f #f #f) ; => not an ELF file +;; or +;; (values start-pos end-pos any1 any2) +;; where `any1` and `any2` are return through +;; from `get-data`. (define (add-racket-section src-file dest-file section-name get-data) (call-with-input-file* src-file @@ -275,7 +283,7 @@ void))))))) (define (expand-elf in dest-file - ;; Current state parted from `in`: + ;; Current state parsed from `in`: elf sections programs str-section strs total-size ;; New state: section-name ; #f or name of new section diff --git a/racket/collects/compiler/private/macfw.rkt b/racket/collects/compiler/private/macfw.rkt index 65536366d1..7404e1d250 100644 --- a/racket/collects/compiler/private/macfw.rkt +++ b/racket/collects/compiler/private/macfw.rkt @@ -23,16 +23,17 @@ dest)]) (for-each (lambda (p) (let* ([orig (get-current-framework-path dest p)] - [3m (if (and orig (regexp-match #rx"_3m" orig)) - "_3m" - "")] + [variant (cond + [(and orig (regexp-match #rx"_3m" orig)) "_3m"] + [(and orig (regexp-match #rx"_CS" orig)) "_CS"] + [else ""])] [old-path (or orig - (format "~a.framework/Versions/~a~a/~a" p (version) 3m p))] + (format "~a.framework/Versions/~a~a/~a" p (version) variant p))] [new-path (if as-given? (format "~a" fw-path) (format "~a~a.framework/Versions/~a~a/~a" fw-path - p (version) 3m p))]) + p (version) variant p))]) (get/set-dylib-path dest (byte-regexp (bytes-append diff --git a/racket/collects/compiler/private/mach-o.rkt b/racket/collects/compiler/private/mach-o.rkt index b12fde7107..ee660ae5f7 100644 --- a/racket/collects/compiler/private/mach-o.rkt +++ b/racket/collects/compiler/private/mach-o.rkt @@ -56,7 +56,8 @@ ;; generally retain the location in a file of an offset that needs to ;; be updated. ;; -(define (add-plt-segment file segdata) +(define (add-plt-segment file segdata + #:name [segment-name #"__PLTSCHEME"]) (let-values ([(p out) (open-input-output-file file #:exists 'update)]) (dynamic-wind void @@ -136,7 +137,8 @@ [nreloc (read-ulong p)] [flags (read-ulong p)]) (when ((+ offset vmsz) . > . (+ cmdssz (if (equal? exe-id #xFeedFacf) 32 28))) - (when (offset . < . min-used) + (when (and (positive? offset) + (offset . < . min-used)) ;; (printf " new min!\n") (set! min-used offset))) ;; (printf " ~s,~s 0x~x 0x~x\n" seg sect offset vmsz) @@ -276,7 +278,7 @@ (file-position out link-edit-pos) (write-ulong (if link-edit-64? #x19 1) out) ; LC_SEGMENT[_64] (write-ulong new-cmd-sz out) - (display #"__PLTSCHEME\0\0\0\0\0" out) + (display (pad-segment-name segment-name) out) ((if link-edit-64? write-xulong write-ulong) out-addr out) ((if link-edit-64? write-xulong write-ulong) outlen out) ((if link-edit-64? write-xulong write-ulong) out-offset out) @@ -378,6 +380,9 @@ (close-input-port p) (close-output-port out))))) +(define (pad-segment-name bs) + (bytes-append bs (make-bytes (- 16 (bytes-length bs))))) + (define (fix-offset p pos out d base delta) (when (and out (not (zero? delta))) (file-position p (+ pos d)) diff --git a/racket/collects/compiler/private/windlldir.rkt b/racket/collects/compiler/private/windlldir.rkt index eeb1d7547b..5493d381d1 100644 --- a/racket/collects/compiler/private/windlldir.rkt +++ b/racket/collects/compiler/private/windlldir.rkt @@ -1,11 +1,12 @@ (module windlldir racket/base (require racket/port + racket/promise "winutf16.rkt") (provide update-dll-dir get-current-dll-dir) - (define label (byte-regexp (bytes->utf-16-bytes #"dLl dIRECTORy:"))) + (define label (delay/sync (byte-regexp (bytes->utf-16-bytes #"dLl dIRECTORy:")))) (define max-dir-len (* 512 2)) ; sizeof(wchar_t) is 2 (define (update-dll-dir dest path) @@ -17,7 +18,7 @@ (error 'update-dll-dir "path too long: ~e" path)) (let ([m (with-input-from-file dest (lambda () - (regexp-match-positions label (current-input-port))))]) + (regexp-match-positions (force label) (current-input-port))))]) (unless m (error 'update-ddl-dir "cannot find DLL path in file: ~e" dest)) (with-output-to-file dest @@ -30,7 +31,7 @@ (define (get-current-dll-dir dest) (with-input-from-file dest (lambda () - (unless (regexp-match label (current-input-port)) + (unless (regexp-match (force label) (current-input-port)) (error 'get-current-dll-dir "cannot find DLL path in file: ~e" dest)) (let ([p (make-limited-input-port (current-input-port) max-dir-len)]) (let ([m (regexp-match #rx#"(?:[^\0].|.[^\0])*" p)]) diff --git a/racket/collects/data/bit-vector.rkt b/racket/collects/data/bit-vector.rkt index 86a2205049..c2d67e7dc0 100644 --- a/racket/collects/data/bit-vector.rkt +++ b/racket/collects/data/bit-vector.rkt @@ -155,7 +155,8 @@ for/bit-vector for*/bit-vector bit-vector-copy - #f) + #f + check-bitvector) ;; A bit vector is represented as bytes. (serializable-struct bit-vector (words size) diff --git a/racket/collects/db/private/sqlite3/ffi.rkt b/racket/collects/db/private/sqlite3/ffi.rkt index e7af8f040f..2da349fe35 100644 --- a/racket/collects/db/private/sqlite3/ffi.rkt +++ b/racket/collects/db/private/sqlite3/ffi.rkt @@ -39,14 +39,14 @@ (define-sqlite sqlite3_open (_fun (filename ignored-flags) :: - (filename : _bytes) + ((bytes-append filename #"\0") : _bytes) (db : (_ptr o _sqlite3_database)) -> (result : _int) -> (values db result))) (define-sqlite sqlite3_open_v2 (_fun (filename flags) :: - (filename : _bytes) + ((bytes-append filename #"\0") : _bytes) (db : (_ptr o _sqlite3_database)) (flags : _int) (vfs : _pointer = #f) @@ -63,23 +63,28 @@ (define (trim-and-copy-buffer buffer) (let* ([buffer (string->bytes/utf-8 (string-trim #:left? #f buffer))] [n (bytes-length buffer)] - [rawcopy (malloc (add1 n) 'atomic-interior)] - [copy (make-sized-byte-string rawcopy n)]) - (memcpy copy buffer n) + [rawcopy (malloc (add1 n) 'atomic-interior)]) + (memcpy rawcopy buffer n) (ptr-set! rawcopy _byte n 0) - copy)) + rawcopy)) + +(define (c-string-length p) + (let loop ([i 0]) + (if (zero? (ptr-ref p _byte i)) + i + (loop (add1 i))))) (define (points-to-end? tail sql-buffer) (ptr-equal? tail - (ptr-add sql-buffer (bytes-length sql-buffer)))) + (ptr-add sql-buffer (c-string-length sql-buffer)))) (define-sqlite sqlite3_prepare (_fun (db sql) :: (db : _sqlite3_database) - (sql-buffer : _bytes = (trim-and-copy-buffer sql)) - ((bytes-length sql-buffer) : _int) + (sql-buffer : _gcpointer = (trim-and-copy-buffer sql)) + ((c-string-length sql-buffer) : _int) (statement : (_ptr o _sqlite3_statement/null)) - (tail : (_ptr o _gcpointer)) ;; points into sql-buffer (atomic-interior) + (tail : (_ptr o _pointer)) ;; points into sql-buffer (atomic-interior) -> (result : _int) -> (values result statement (and tail (not (points-to-end? tail sql-buffer)))))) @@ -87,11 +92,11 @@ (define-sqlite sqlite3_prepare_v2 (_fun (db sql) :: (db : _sqlite3_database) - (sql-buffer : _bytes = (trim-and-copy-buffer sql)) - ((bytes-length sql-buffer) : _int) + (sql-buffer : _gcpointer = (trim-and-copy-buffer sql)) + ((c-string-length sql-buffer) : _int) ;; bad prepare statements set statement to NULL, with no error reported (statement : (_ptr o _sqlite3_statement/null)) - (tail : (_ptr o _gcpointer)) ;; points into sql-buffer (atomic-interior) + (tail : (_ptr o _pointer)) ;; points into sql-buffer (atomic-interior) -> (result : _int) -> (values result statement (and tail (not (points-to-end? tail sql-buffer))))) @@ -190,9 +195,11 @@ (define-sqlite sqlite3_column_blob (_fun (stmt : _sqlite3_statement) (col : _int) - -> (blob : _bytes) - -> (let ([len (sqlite3_column_bytes stmt col)]) - (bytes-copy (make-sized-byte-string blob len))))) + -> (blob : _pointer) + -> (let* ([len (sqlite3_column_bytes stmt col)] + [bstr (make-bytes len)]) + (memcpy bstr blob len) + bstr))) ;; ---------------------------------------- diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 0dc49982b3..6829304bc8 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -251,13 +251,12 @@ (syntax-case stx () [(_ var-name lib-name type-expr) (with-syntax ([(p) (generate-temporaries (list #'var-name))]) - (namespace-syntax-introduce - #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) - (define-syntax var-name - (syntax-id-rules (set!) - [(set! var val) (p val)] - [(var . xs) ((p) . xs)] - [var (p)])))))])) + #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) + (define-syntax var-name + (syntax-id-rules (set!) + [(set! var val) (p val)] + [(var . xs) ((p) . xs)] + [var (p)]))))])) ;; Used to convert strings and symbols to a byte-string that names an object (define (get-ffi-obj-name who objname) @@ -472,16 +471,31 @@ #:lock-name [lock-name #f] #:async-apply [async-apply #f] #:save-errno [errno #f]) - (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno lock-name)) + (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? blocking? async-apply errno lock-name)) + +;; A lightwegith delay meachnism for a single-argument function when +;; it's ok (but unlikely) to evaluate `expr` more than once and keep +;; the first result: +(define-syntax-rule (delay/cas expr) + (let ([b (box #f)]) + (lambda (arg) + (define f (unbox b)) + (cond + [f (f arg)] + [else + (box-cas! b #f expr) + ((unbox b) arg)])))) ;; for internal use (define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? async-apply errno lock-name) +(define (_cprocedure* itypes otype abi wrapper keep atomic? orig-place? blocking? async-apply errno lock-name) + (define make-ffi-callback (delay/cas (ffi-callback-maker itypes otype abi atomic? async-apply))) + (define make-ffi-call (delay/cas (ffi-call-maker itypes otype abi errno orig-place? lock-name blocking?))) (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) (and x - (let ([cb (ffi-callback (wrap x) itypes otype abi atomic? async-apply)]) + (let ([cb (make-ffi-callback (wrap x))]) (cond [(eq? keep #t) (hash-set! held-callbacks x (make-ephemeron x cb))] [(box? keep) (let ([x (unbox keep)]) @@ -489,7 +503,7 @@ (if (or (null? x) (pair? x)) (cons cb x) cb)))] [(procedure? keep) (keep cb)]) cb))) - (lambda (x) (and x (wrap (ffi-call x itypes otype abi errno orig-place? lock-name)))))) + (lambda (x) (and x (wrap (make-ffi-call x)))))) (if wrapper (make-it wrapper) (make-it begin))) ;; Syntax for the special _fun type: @@ -676,6 +690,7 @@ #,(kwd-ref '#:keep) #,(kwd-ref '#:atomic?) #,(kwd-ref '#:in-original-place?) + #,(kwd-ref '#:blocking?) #,(kwd-ref '#:async-apply) #,(kwd-ref '#:save-errno) #,(kwd-ref '#:lock-name)))]) @@ -764,16 +779,25 @@ ;; utf-16 type (provide _string/ucs-4 _string/utf-16) +(define _bytes+nul + (make-ctype _bytes + (lambda (x) + (and x (let* ([len (bytes-length x)] + [s (make-bytes (add1 len))]) + (bytes-copy! s 0 x 0 len) + s))) + (lambda (x) x))) + ;; 8-bit string encodings, #f is NULL (define ((false-or-op op) x) (and x (op x))) (define* _string/utf-8 - (make-ctype _bytes + (make-ctype _bytes+nul (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) (define* _string/locale - (make-ctype _bytes + (make-ctype _bytes+nul (false-or-op string->bytes/locale) (false-or-op bytes->string/locale))) (define* _string/latin-1 - (make-ctype _bytes + (make-ctype _bytes+nul (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) ;; 8-bit string encodings, #f is NULL, can also use bytes and paths @@ -783,13 +807,13 @@ [(path? x) (path->bytes x)] [else (op x)])) (define* _string*/utf-8 - (make-ctype _bytes + (make-ctype _bytes+nul (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) (define* _string*/locale - (make-ctype _bytes + (make-ctype _bytes+nul (any-string-op string->bytes/locale) (false-or-op bytes->string/locale))) (define* _string*/latin-1 - (make-ctype _bytes + (make-ctype _bytes+nul (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) ;; A generic _string type that usually does the right thing via a parameter @@ -1060,16 +1084,31 @@ (define-fun-syntax _bytes* (syntax-id-rules (o) [(_ o n) (type: _gcpointer - pre: (let ([bstr (make-sized-byte-string (malloc (add1 n)) n)]) - ;; Ensure a null terminator, so that the result is - ;; compatible with `_bytes`: - (ptr-set! bstr _byte n 0) - bstr) + pre: (make-bytes-argument n) ;; post is needed when this is used as a function output type - post: (x => (make-sized-byte-string x n)))] + post: (x => (receive-bytes-result x n)))] [(_ . xs) (_bytes . xs)] [_ _bytes])) +(define (make-bytes-argument n) + (cond + [(eq? 'racket (system-type 'vm)) + (define bstr (make-sized-byte-string (malloc (add1 n)) n)) + ;; Ensure a null terminator, so that the result is + ;; compatible with `_bytes`: + (ptr-set! bstr _byte n 0) + bstr] + [else (make-bytes n)])) + +(define (receive-bytes-result x n) + (cond + [(eq? 'racket (system-type 'vm)) + (make-sized-byte-string x n)] + [else + (define bstr (make-bytes n)) + (memcpy bstr x n) + bstr])) + ;; _bytes/nul-terminated copies and includes a nul terminator in a ;; way that will be more consistent across Racket implementations (define _bytes/nul-terminated @@ -1151,7 +1190,7 @@ ;; in-vector like sequence over array (define-:vector-like-gen :array-gen array-ref) -(define-in-vector-like in-array +(define-in-vector-like (in-array check-array) "array" array? array-length :array-gen) (define-sequence-syntax *in-array @@ -1161,6 +1200,7 @@ #'array? #'array-length #'in-array + #'check-array #'array-ref)) ;; (_array/list ...+) @@ -1355,14 +1395,15 @@ [(eq? t 'gcpointer) ctype] [(eq? t 'pointer) (let loop ([ctype ctype]) - (if (eq? ctype 'pointer) + (if (or (eq? ctype _pointer) + (eq? ctype 'pointer)) _gcpointer (make-ctype (loop (ctype-basetype ctype)) (ctype-scheme->c ctype) (ctype-c->scheme ctype))))] [else - (raise-argument-error '_or-null "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer))))" + (raise-argument-error '_gcable "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer))))" ctype)])) (define (ctype-coretype c) diff --git a/racket/collects/ffi/unsafe/objc.rkt b/racket/collects/ffi/unsafe/objc.rkt index 7fcf0eb2fd..62a03986ad 100644 --- a/racket/collects/ffi/unsafe/objc.rkt +++ b/racket/collects/ffi/unsafe/objc.rkt @@ -219,9 +219,7 @@ (cast (objc_lookUpClass name) _Class _Protocol)))) (define-objc sel_registerName (_fun _string -> _SEL) - #:fail (lambda () (lambda (name) - ;; Fake registration using interned symbols - (cast (string->symbol name) _racket _gcpointer)))) + #:fail (lambda () (lambda (name) #f))) (define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class) #:fail (lambda () #f)) diff --git a/racket/collects/ffi/unsafe/os-thread.rkt b/racket/collects/ffi/unsafe/os-thread.rkt new file mode 100644 index 0000000000..9c85a14eaf --- /dev/null +++ b/racket/collects/ffi/unsafe/os-thread.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(require '#%unsafe) + +(provide + (rename-out [unsafe-os-thread-enabled? os-thread-enabled?] + [unsafe-call-in-os-thread call-in-os-thread] + [unsafe-make-os-semaphore make-os-semaphore] + [unsafe-os-semaphore-post os-semaphore-post] + [unsafe-os-semaphore-wait os-semaphore-wait])) diff --git a/racket/collects/launcher/launcher.rkt b/racket/collects/launcher/launcher.rkt index d3acda779c..ca91fbd49f 100644 --- a/racket/collects/launcher/launcher.rkt +++ b/racket/collects/launcher/launcher.rkt @@ -72,7 +72,7 @@ (define current-launcher-variant (make-parameter (cross-system-type 'gc) (lambda (v) - (unless (memq v '(3m script-3m cgc script-cgc)) + (unless (memq v '(3m script-3m cgc script-cgc cs script-cs)) (raise-type-error 'current-launcher-variant "variant symbol" @@ -116,26 +116,38 @@ [alt-kind (if (eq? '3m normal-kind) 'cgc '3m)] + [alt2-kind (if (or (eq? '3m normal-kind) + (eq? 'cgc normal-kind)) + 'cs + 'cgc)] [normal (if (variant-available? kind cased-kind-name normal-kind) (list normal-kind) null)] [alt (if (variant-available? kind cased-kind-name alt-kind) (list alt-kind) null)] + [alt2 (if (variant-available? kind cased-kind-name alt2-kind) + (list alt2-kind) + null)] + [kind->script-kind (lambda (kind) + (cond + [(eq? kind '3m) '(script-3m)] + [(eq? kind 'cgc) '(script-cgc)] + [else '(script-cs)]))] [script (if (and (eq? 'macosx (cross-system-type)) (eq? kind 'mred) (pair? normal)) - (if (eq? normal-kind '3m) - '(script-3m) - '(script-cgc)) + (kind->script-kind normal-kind) null)] [script-alt (if (and (memq alt-kind alt) (pair? script)) - (if (eq? alt-kind '3m) - '(script-3m) - '(script-cgc)) - null)]) - (append normal alt script script-alt))) + (kind->script-kind alt-kind) + null)] + [script-alt2 (if (and (memq alt2-kind alt2) + (pair? script)) + (kind->script-kind alt2-kind) + null)]) + (append normal alt alt2 script script-alt script-alt2))) (define (available-gracket-variants) (available-variants 'mred)) @@ -163,7 +175,7 @@ (file-or-directory-permissions dest perms2)))) (define (script-variant? v) - (memq v '(script-3m script-cgc))) + (memq v '(script-3m script-cgc script-cs))) (define (add-file-suffix path variant mred?) (let ([s (variant-suffix diff --git a/racket/collects/net/osx-ssl.rkt b/racket/collects/net/osx-ssl.rkt index 2698554ff8..2909c24364 100644 --- a/racket/collects/net/osx-ssl.rkt +++ b/racket/collects/net/osx-ssl.rkt @@ -5,6 +5,8 @@ ffi/unsafe/alloc ffi/unsafe/atomic ffi/unsafe/custodian + ffi/unsafe/schedule + ffi/unsafe/os-thread racket/port racket/format openssl) @@ -39,6 +41,7 @@ (define _CFReadStreamRef (_cpointer/null 'CFReadStreamRef)) (define _CFWriteStreamRef (_cpointer/null 'CFWriteStreamRef)) +(define _CFErrorRef (_cpointer/null 'CFError)) (define _CFRunLoopRef (_cpointer/null 'CFRunLoopRef)) @@ -156,6 +159,14 @@ (define-cf CFWriteStreamGetStatus (_fun _CFWriteStreamRef -> _CFStreamStatus)) +(define-cf CFReadStreamCopyError + (_fun _CFReadStreamRef -> _CFErrorRef) + #:wrap (allocator CFRelease)) +(define-cf CFWriteStreamCopyError + (_fun _CFWriteStreamRef -> _CFErrorRef) + #:wrap (allocator CFRelease)) +(define-cf CFErrorCopyDescription + (_fun _CFErrorRef -> _NSString)) (define-cf CFDictionaryCreate (_fun (_pointer = #f) @@ -177,8 +188,6 @@ [proc4 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) -> _pointer)]) #:malloc-mode 'nonatomic) -(define-racket scheme_signal_received (_fun -> _void)) - (define _pthread (_cpointer/null 'pthread)) (define-racket pthread_create @@ -192,10 +201,12 @@ (define-racket scheme_call_sequence_of_procedures-ptr _fpointer #:c-id scheme_call_sequence_of_procedures) -(define-cf CFRunLoopRun-ptr _fpointer - #:c-id CFRunLoopRun) +(define-cf CFRunLoopGetCurrent (_fun -> _CFRunLoopRef)) +(define-cf CFRunLoopRun (_fun #:blocking? #t _CFRunLoopRef -> _void)) (define-cf CFRunLoopGetCurrent-ptr _fpointer #:c-id CFRunLoopGetCurrent) +(define-cf CFRunLoopRun-ptr _fpointer + #:c-id CFRunLoopRun) (define stop-and-release ((deallocator) @@ -211,36 +222,58 @@ (define (launch-run-loop-in-pthread init-reg more-retain) (define run-loop #f) - (define done (make-semaphore)) - (define (setup r) - ;; Called in atomic mode in arbitrary Racket thread: - (set! run-loop (CFRetainRunLoop (cast r _pointer _CFRunLoopRef))) - (init-reg run-loop) - (semaphore-post done) - (scheme_signal_received) - #f) - (define (finished) - (free-immobile-cell retainer) - #f) - ;; Retains callbacks until the thread is done: - (define retainer (malloc-immobile-cell - (vector setup finished more-retain))) - (define seq (make-Scheme_Proc_Sequence 4 - #f - CFRunLoopGetCurrent-ptr - ;; `#:aync-apply` moves the following - ;; back to the main thread (in atomic mode): - setup - CFRunLoopRun-ptr - ;; `#:async-apply` here, too: - finished)) - (define pth (pthread_create #f scheme_call_sequence_of_procedures-ptr seq)) - (unless pth (error "could not start run-loop thread")) - (pthread_detach pth) - - (semaphore-wait done) - (set! done seq) ; retains `seq` until here + (cond + [(os-thread-enabled?) + (define create-done (make-os-semaphore)) + (define retain-done (make-os-semaphore)) + (define setup-done create-done) + (call-in-os-thread + (lambda () + (define rl (CFRunLoopGetCurrent)) + (set! run-loop rl) + (os-semaphore-post create-done) + (os-semaphore-wait retain-done) + (init-reg rl) + (os-semaphore-post setup-done) + (CFRunLoopRun rl) + (void/reference-sink more-retain))) + (os-semaphore-wait create-done) + ;; To be on the safe side, register a finalizer in the Racket thread: + (set! run-loop (CFRetainRunLoop run-loop)) + (os-semaphore-post retain-done) + (os-semaphore-wait setup-done)] + [else + (define done (make-semaphore)) + (define (setup r) + ;; Called in atomic mode in arbitrary Racket thread: + (set! run-loop (CFRetainRunLoop (cast r _pointer _CFRunLoopRef))) + (init-reg run-loop) + (semaphore-post done) + (unsafe-signal-received) + #f) + (define (finished) + (free-immobile-cell retainer) + #f) + ;; Retains callbacks until the thread is done: + (define retainer (malloc-immobile-cell + (vector setup finished more-retain))) + (define seq (make-Scheme_Proc_Sequence 4 + #f + CFRunLoopGetCurrent-ptr + ;; `#:aync-apply` moves the following + ;; back to the main thread (in atomic mode): + setup + CFRunLoopRun-ptr + ;; `#:async-apply` here, too: + finished)) + (define pth (pthread_create #f scheme_call_sequence_of_procedures-ptr seq)) + (unless pth (error "could not start run-loop thread")) + (pthread_detach pth) + (semaphore-wait done) + (set! done seq) ; retains `seq` until here + + (void)]) run-loop) ;; ---------------------------------------- @@ -275,20 +308,20 @@ (check-ok (CFReadStreamSetProperty in kCFStreamPropertySSLSettings d)) (check-ok (CFWriteStreamSetProperty out kCFStreamPropertySSLSettings d)) (CFRelease d)) - + (define in-ready (make-semaphore)) (define out-ready (make-semaphore 1)) - + ;; These callback must be retained so that they're not GCed ;; until the run loop is terminated: (define in-callback (lambda (_in evt _null) (void (semaphore-try-wait? in-ready)) (semaphore-post in-ready) - (scheme_signal_received))) + (unsafe-signal-received))) (define out-callback (lambda (_out evt _null) (void (semaphore-try-wait? out-ready)) (semaphore-post out-ready) - (scheme_signal_received))) + (unsafe-signal-received))) (define context (make-CFStreamClientContext 0 #f #f #f #f)) (check-ok (CFReadStreamSetClient in all-evts in-callback context)) @@ -296,7 +329,8 @@ (define run-loop (launch-run-loop-in-pthread - ;; This function will be called as atomic within the scheduler: + ;; This function will be called as atomic within the scheduler + ;; or in a separate OS thread: (lambda (run-loop) (CFReadStreamScheduleWithRunLoop in run-loop kCFRunLoopDefaultMode) (CFWriteStreamScheduleWithRunLoop out run-loop kCFRunLoopDefaultMode)) @@ -304,7 +338,7 @@ (check-ok (CFWriteStreamOpen out)) (check-ok (CFReadStreamOpen in)) - + (let loop () (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusOpening) (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusOpening)) @@ -316,6 +350,13 @@ (raise (exn:fail:network (~a "osx-ssl-connect: connection failed\n" + " message: " (let ([err (if (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusError) + (CFReadStreamCopyError in) + (CFWriteStreamCopyError out))]) + (begin0 + (CFErrorCopyDescription err) + (CFRelease err))) + "\n" " address: " host "\n" " port number: " port) (current-continuation-marks)))) diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt index f56c8245c2..01f404e39b 100644 --- a/racket/collects/openssl/mzssl.rkt +++ b/racket/collects/openssl/mzssl.rkt @@ -205,8 +205,6 @@ TO DO: (or libssl-load-fail-reason libcrypto-load-fail-reason)) -(define 3m? (eq? '3m (system-type 'gc))) - (define libmz (ffi-lib #f)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -281,13 +279,13 @@ TO DO: (SSL_CTX_ctrl ctx SSL_CTRL_OPTIONS opts #f)) (define-ssl SSL_CTX_set_verify (_fun _SSL_CTX* _int _pointer -> _void)) -(define-ssl SSL_CTX_use_certificate_chain_file (_fun _SSL_CTX* _bytes -> _int)) -(define-ssl SSL_CTX_load_verify_locations (_fun _SSL_CTX* _bytes _bytes -> _int)) +(define-ssl SSL_CTX_use_certificate_chain_file (_fun _SSL_CTX* _path -> _int)) +(define-ssl SSL_CTX_load_verify_locations (_fun _SSL_CTX* _path _path -> _int)) (define-ssl SSL_CTX_set_client_CA_list (_fun _SSL_CTX* _X509_NAME* -> _int)) (define-ssl SSL_CTX_set_session_id_context (_fun _SSL_CTX* _bytes _int -> _int)) -(define-ssl SSL_CTX_use_RSAPrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int)) -(define-ssl SSL_CTX_use_PrivateKey_file (_fun _SSL_CTX* _bytes _int -> _int)) -(define-ssl SSL_load_client_CA_file (_fun _bytes -> _X509_NAME*/null)) +(define-ssl SSL_CTX_use_RSAPrivateKey_file (_fun _SSL_CTX* _path _int -> _int)) +(define-ssl SSL_CTX_use_PrivateKey_file (_fun _SSL_CTX* _path _int -> _int)) +(define-ssl SSL_load_client_CA_file (_fun _path -> _X509_NAME*/null)) (define-ssl SSL_CTX_set_cipher_list (_fun _SSL_CTX* _string -> _int)) (define-ssl SSL_free (_fun _SSL* -> _void) @@ -513,14 +511,6 @@ TO DO: server?) #:mutable) -(define (make-immobile-bytes n) - (if 3m? - ;; Allocate the byte string via malloc: - (let ([p (malloc 'atomic-interior n)]) - (make-sized-byte-string p n)) - ;; Normal byte string is immobile: - (make-bytes n))) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Errors @@ -715,13 +705,12 @@ TO DO: (path->complete-path (cleanse-path pathname) (current-directory))]) (security-guard-check-file who path '(read)) - (let ([path (path->bytes path)]) - (atomically ;; for to connect ERR_get_error to `load-it' - (let ([n (load-it ctx path)]) - (unless (or (= n 1) try?) - (error who "load failed from: ~e ~a" - pathname - (get-error-message (ERR_get_error)))))))))) + (atomically ;; for to connect ERR_get_error to `load-it' + (let ([n (load-it ctx path)]) + (unless (or (= n 1) try?) + (error who "load failed from: ~e ~a" + pathname + (get-error-message (ERR_get_error))))))))) (define (ssl-load-certificate-chain! ssl-context-or-listener pathname) (ssl-load-... 'ssl-load-certificate-chain! @@ -1020,7 +1009,7 @@ TO DO: ;; call to SSL_read must use the same arguments. ;; Use xfer-buffer so we have a consistent buffer to use with ;; SSL_read across calls to the port's write function. - (let-values ([(xfer-buffer) (make-immobile-bytes BUFFER-SIZE)] + (let-values ([(xfer-buffer) (make-bytes BUFFER-SIZE)] [(got-r got-w) (make-pipe)] [(must-read-len) #f]) (make-input-port/read-to-peek @@ -1156,7 +1145,7 @@ TO DO: ;; call to SSL_write must use the same arguments. ;; Use xfer-buffer so we have a consistent buffer to use with ;; SSL_write across calls to the port's write function. - (let ([xfer-buffer (make-immobile-bytes BUFFER-SIZE)] + (let ([xfer-buffer (make-bytes BUFFER-SIZE)] [buffer-mode (or (file-stream-buffer-mode (mzssl-o mzssl)) 'bloack)] [flush-ch (make-channel)] [must-write-len #f]) @@ -1694,7 +1683,7 @@ TO DO: ;; it. (begin (start-atomic) - (let* ([done (cast 1 _scheme _pointer)] + (let* ([done (ptr-add #f 1)] [v (register-process-global #"OpenSSL-support-initializing" done)]) (if v ;; Some other place is initializing: diff --git a/racket/collects/pkg/dirs-catalog.rkt b/racket/collects/pkg/dirs-catalog.rkt index c65d605592..08af41f790 100644 --- a/racket/collects/pkg/dirs-catalog.rkt +++ b/racket/collects/pkg/dirs-catalog.rkt @@ -14,6 +14,7 @@ (provide create-dirs-catalog) (module+ main + (define immediate? #f) (define link? #f) (define merge? #f) (define check-metadata? #f) @@ -21,6 +22,8 @@ (command-line #:once-each + ["--immediate" "Check given directories as immediate packages" + (set! immediate? #t)] ["--link" "Install packages as links" (set! link? #t)] ["--merge" "Preserve existing packages in catalog" @@ -34,6 +37,7 @@ (create-dirs-catalog catalog-path ;; a list: dir + #:immediate? immediate? #:status-printf (if quiet? void printf) #:link? link? #:merge? merge? @@ -41,6 +45,7 @@ (define (create-dirs-catalog catalog-path dirs + #:immediate? [immediate? #f] #:status-printf [status-printf void] #:link? [link? #f] #:merge? [merge? #f] @@ -55,21 +60,31 @@ ;; further into the package) (for ([src-dir (in-list dirs)]) (when (directory-exists? src-dir) - (let loop ([src-dir src-dir]) + (define (check-content src-dir) (for ([f (in-list (directory-list src-dir))]) (define src-f (build-path src-dir f)) - (cond - [(file-exists? (build-path src-f "info.rkt")) - (define f-name (path->string f)) - (when (hash-ref found f-name #f) - (error 'pack-local - "found package ~a multiple times: ~a and ~a" - f-name - (hash-ref found f-name) - src-f)) - (hash-set! found f-name src-f)] - [(directory-exists? src-f) - (loop src-f)]))))) + (check-path src-f f))) + (define (check-path src-f f) + (cond + [(file-exists? (build-path src-f "info.rkt")) + (define f-name (path->string f)) + (when (hash-ref found f-name #f) + (error 'pack-local + "found package ~a multiple times: ~a and ~a" + f-name + (hash-ref found f-name) + src-f)) + (hash-set! found f-name src-f)] + [(directory-exists? src-f) + (check-content src-f)])) + (cond + [(and immediate? + (let-values ([(base name dir?) (split-path src-dir)]) + (and (path? name) + name))) + => (lambda (f) (check-path src-dir f))] + [else + (check-content src-dir)]))) (unless merge? (when (directory-exists? (build-path catalog-path "pkg")) diff --git a/racket/collects/pkg/private/catalog-copy.rkt b/racket/collects/pkg/private/catalog-copy.rkt index 34550d316e..797471f153 100644 --- a/racket/collects/pkg/private/catalog-copy.rkt +++ b/racket/collects/pkg/private/catalog-copy.rkt @@ -121,32 +121,34 @@ (for/hash ([(k v) (in-hash details)]) (values k (select-info-version v)))) (parameterize ([db:current-pkg-catalog-file dest-path]) - (db:set-catalogs! '("local")) - (db:set-pkgs! "local" - (for/list ([(k v) (in-hash vers-details)]) - (db:pkg k "local" - (hash-ref v 'author "") - (hash-ref v 'source "") - (hash-ref v 'checksum "") - (hash-ref v 'description "")))) - (for ([(k v) (in-hash vers-details)]) - (define t (hash-ref v 'tags '())) - (unless (null? t) - (db:set-pkg-tags! k "local" t))) - (for ([(k v) (in-hash vers-details)]) - (define mods (hash-ref v 'modules '())) - (unless (null? mods) - (define cs (hash-ref v 'checksum "")) - (db:set-pkg-modules! k "local" cs mods))) - (for ([(k v) (in-hash vers-details)]) - (define deps (hash-ref v 'dependencies '())) - (unless (null? deps) - (define cs (hash-ref v 'checksum "")) - (db:set-pkg-dependencies! k "local" cs deps))) - (for ([(k v) (in-hash vers-details)]) - (define ring (hash-ref v 'ring #f)) - (when ring - (db:set-pkg-ring! k "local" ring))))] + (db:call-with-pkgs-transaction + (lambda () + (db:set-catalogs! '("local")) + (db:set-pkgs! "local" + (for/list ([(k v) (in-hash vers-details)]) + (db:pkg k "local" + (hash-ref v 'author "") + (hash-ref v 'source "") + (hash-ref v 'checksum "") + (hash-ref v 'description "")))) + (for ([(k v) (in-hash vers-details)]) + (define t (hash-ref v 'tags '())) + (unless (null? t) + (db:set-pkg-tags! k "local" t))) + (for ([(k v) (in-hash vers-details)]) + (define mods (hash-ref v 'modules '())) + (unless (null? mods) + (define cs (hash-ref v 'checksum "")) + (db:set-pkg-modules! k "local" cs mods))) + (for ([(k v) (in-hash vers-details)]) + (define deps (hash-ref v 'dependencies '())) + (unless (null? deps) + (define cs (hash-ref v 'checksum "")) + (db:set-pkg-dependencies! k "local" cs deps))) + (for ([(k v) (in-hash vers-details)]) + (define ring (hash-ref v 'ring #f)) + (when ring + (db:set-pkg-ring! k "local" ring))))))] [else (define pkg-path (build-path dest-path "pkg")) (make-directory* pkg-path) diff --git a/racket/collects/racket/extflonum.rkt b/racket/collects/racket/extflonum.rkt index 5abd20cb42..70cb7aaa67 100644 --- a/racket/collects/racket/extflonum.rkt +++ b/racket/collects/racket/extflonum.rkt @@ -21,4 +21,5 @@ for/extflvector for*/extflvector extflvector-copy - 0.0T0) + 0.0T0 + check-extflonum) diff --git a/racket/collects/racket/fixnum.rkt b/racket/collects/racket/fixnum.rkt index 20fe409155..c7d6bec355 100644 --- a/racket/collects/racket/fixnum.rkt +++ b/racket/collects/racket/fixnum.rkt @@ -28,4 +28,5 @@ for/fxvector for*/fxvector fxvector-copy - 0) + 0 + check-fxvector) diff --git a/racket/collects/racket/flonum.rkt b/racket/collects/racket/flonum.rkt index b9446e76bb..f367414699 100644 --- a/racket/collects/racket/flonum.rkt +++ b/racket/collects/racket/flonum.rkt @@ -28,7 +28,8 @@ for/flvector for*/flvector flvector-copy - 0.0) + 0.0 + check-flvector) (define (flrandom r) (if (pseudo-random-generator? r) diff --git a/racket/collects/racket/gui/dynamic.rkt b/racket/collects/racket/gui/dynamic.rkt index 14b7f05df2..8859bcec84 100644 --- a/racket/collects/racket/gui/dynamic.rkt +++ b/racket/collects/racket/gui/dynamic.rkt @@ -1,18 +1,16 @@ #lang racket/base -(require ffi/unsafe) +(require ffi/unsafe + ffi/unsafe/global) (provide gui-available? gui-dynamic-require) -(define scheme_register_process_global - (get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer))) - (define (gui-available?) (and ;; Never available in non-0 phases: (zero? (variable-reference->phase (#%variable-reference))) ;; Must be instantiated: - (scheme_register_process_global "GRacket-support-initialized" #f) + (register-process-global #"GRacket-support-initialized" #f) (with-handlers ([exn:fail? (lambda (exn) #f)]) ;; Fails if `mred/private/dynamic' is not declared ;; (without loading it if not): diff --git a/racket/collects/racket/linklet.rkt b/racket/collects/racket/linklet.rkt new file mode 100644 index 0000000000..8abd75a517 --- /dev/null +++ b/racket/collects/racket/linklet.rkt @@ -0,0 +1,88 @@ +#lang racket/base +(require '#%linklet) + +(provide linklet? + + compile-linklet + recompile-linklet + eval-linklet + instantiate-linklet + + linklet-import-variables + linklet-export-variables + + linklet-directory? + hash->linklet-directory + linklet-directory->hash + + linklet-bundle? + hash->linklet-bundle + linklet-bundle->hash + + instance? + make-instance + instance-name + instance-data + instance-variable-names + instance-variable-value + instance-set-variable-value! + instance-unset-variable! + + variable-reference->instance + + correlated? + datum->correlated + correlated->datum + correlated-e + correlated-property + correlated-property-symbol-keys + + correlated-source + correlated-line + correlated-column + correlated-position + correlated-span) + +;; The `#%kernel` primitive table is more primitive than the +;; `#%kernel` module: +(define kernel (primitive-table '#%kernel)) +(define-syntax-rule (bounce id ...) + (begin (define id (hash-ref kernel 'id)) ...)) +(bounce syntax? + syntax-e + datum->syntax + syntax->datum + syntax-property + syntax-property-symbol-keys + + syntax-source + syntax-line + syntax-column + syntax-position + syntax-span) + +(define (correlated? e) + (syntax? e)) + +(define (datum->correlated d [srcloc #f]) + (datum->syntax #f d srcloc)) + +(define (correlated-e e) + (syntax-e e)) + +(define (correlated->datum e) + (syntax->datum e)) + +(define correlated-property + (case-lambda + [(e k) (syntax-property e k)] + [(e k v) (syntax-property e k v)])) + +(define (correlated-property-symbol-keys e) + (syntax-property-symbol-keys e)) + +(define (correlated-source s) (syntax-source s)) +(define (correlated-line s) (syntax-line s)) +(define (correlated-column s) (syntax-column s)) +(define (correlated-position s) (syntax-position s)) +(define (correlated-span s) (syntax-span s)) diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt index 880c54ca8b..1e63d2e5d0 100644 --- a/racket/collects/racket/private/class-internal.rkt +++ b/racket/collects/racket/private/class-internal.rkt @@ -529,7 +529,7 @@ ;; optional argument; need to wrap arg expression (cons (with-syntax ([expr (syntax/loc #'expr - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) (#%expression expr)))]) (syntax/loc (car vars) (id expr))) @@ -539,7 +539,7 @@ #'vars)]) (let ([l (syntax/loc stx (lambda (the-obj . vars) - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) body1 body ...)))]) (syntax-track-origin (with-syntax ([l (rearm (add-method-property l) stx)]) @@ -563,7 +563,7 @@ [name (mk-name name)]) (let ([cl (syntax/loc stx (case-lambda [(the-obj . vars) - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) body1 body ...)] ...))]) (syntax-track-origin (with-syntax ([cl (rearm (add-method-property cl) stx)]) @@ -1571,6 +1571,7 @@ rename-super-temp ... rename-super-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ... method-accessor ...) ; for a local call that needs a dynamic lookup + (define-syntax-parameter the-finder #f) (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)] ... @@ -1659,7 +1660,7 @@ #, ;; Attach srcloc (useful for profiling) (quasisyntax/loc stx (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize ([the-finder (quote-syntax the-obj)]) (syntax-parameterize ([super-instantiate-param (lambda (stx) diff --git a/racket/collects/racket/private/classidmap.rkt b/racket/collects/racket/private/classidmap.rkt index 0772052e31..5ca2ad921e 100644 --- a/racket/collects/racket/private/classidmap.rkt +++ b/racket/collects/racket/private/classidmap.rkt @@ -2,7 +2,8 @@ (require syntax/stx (for-syntax racket/base) - (for-template racket/base + (for-template racket/stxparam + racket/base racket/unsafe/undefined "class-wrapped.rkt" "class-undef.rkt")) @@ -29,7 +30,7 @@ (list* 'apply id this (reverse (cons args accum)))]))) (define (find the-finder name src) - (let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))]) + (let ([this-id (syntax-parameter-value the-finder)]) (datum->syntax this-id name src))) ;; Check Syntax binding info: diff --git a/racket/collects/racket/private/collect.rkt b/racket/collects/racket/private/collect.rkt index dddbedd6a9..4c06792fc0 100644 --- a/racket/collects/racket/private/collect.rkt +++ b/racket/collects/racket/private/collect.rkt @@ -1,7 +1,33 @@ -(module collect '#%kernel - (#%require '#%utils) - (#%provide find-col-file - collection-path - collection-file-path - find-library-collection-paths - find-library-collection-links)) +(module pre-base '#%kernel + (#%require "qq-and-or.rkt" + "path.rkt" + "kw.rkt") + + (#%provide new:collection-path + new:collection-file-path) + + (define-values (new:collection-path) + (let ([collection-path (new-lambda (collection + #:fail [fail (lambda (s) + (raise + (exn:fail:filesystem + (string-append "collection-path: " s) + (current-continuation-marks))))] + . collections) + (collection-path fail collection collections))]) + collection-path)) + + (define-values (new:collection-file-path) + (let ([collection-file-path (new-lambda (file-name + collection + #:check-compiled? [check-compiled? + (and (path-string? file-name) + (regexp-match? #rx".[.]rkt$" file-name))] + #:fail [fail (lambda (s) + (raise + (exn:fail:filesystem + (string-append "collection-file-path: " s) + (current-continuation-marks))))] + . collections) + (collection-file-path fail check-compiled? file-name collection collections))]) + collection-file-path))) diff --git a/racket/collects/racket/private/define-et-al.rkt b/racket/collects/racket/private/define-et-al.rkt index 4f617c9d79..d816a04c09 100644 --- a/racket/collects/racket/private/define-et-al.rkt +++ b/racket/collects/racket/private/define-et-al.rkt @@ -184,14 +184,7 @@ `(begin (define-values ,defined-names - ,(let ([core (make-core name (and inspector 'inspector) super-id/struct: field-names)]) - (if inspector - `(let-values ([(inspector) ,inspector]) - (if (if inspector (not (inspector? inspector)) #f) - (raise-argument-error 'define-struct "(or/c inspector? #f)" inspector) - (void)) - ,core) - core))) + ,(make-core name inspector super-id/struct: field-names)) (define-syntaxes (,name) ,stx-info)) stx)]) (if super-id diff --git a/racket/collects/racket/private/define-struct.rkt b/racket/collects/racket/private/define-struct.rkt index 40b5f8531a..973421d8c7 100644 --- a/racket/collects/racket/private/define-struct.rkt +++ b/racket/collects/racket/private/define-struct.rkt @@ -518,7 +518,13 @@ [prune (lambda (stx) (identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))] [reflect-name-expr (if reflect-name-expr - (quasisyntax (check-reflection-name 'fm #,reflect-name-expr)) + (syntax-case reflect-name-expr (quote) + [(quote id) + (identifier? #'id) + ;; No need to generate run-time test for a symbol: + reflect-name-expr] + [else + (quasisyntax (check-reflection-name 'fm #,reflect-name-expr))]) (quasisyntax '#,id))]) (define struct-name-size (string-length (symbol->string (syntax-e id)))) diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index 95f280d0e3..b9c376ca27 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -7,6 +7,7 @@ "member.rkt" "reverse.rkt" "sort.rkt" + "performance-hint.rkt" '#%unsafe '#%flfxnum (for-syntax '#%kernel @@ -387,6 +388,9 @@ (raise-syntax-error #f "illegal outside of a loop or comprehension binding" stx)) + (define-syntax-rule (unless-unsafe e) + (unless (variable-reference-from-unsafe? (#%variable-reference)) e)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; streams & sequences @@ -582,14 +586,17 @@ #f #f)))))) + (define (check-range a b step) + (unless (real? a) (raise-argument-error 'in-range "real?" a)) + (unless (real? b) (raise-argument-error 'in-range "real?" b)) + (unless (real? step) (raise-argument-error 'in-range "real?" step))) + (define in-range (case-lambda [(b) (in-range 0 b 1)] [(a b) (in-range a b 1)] [(a b step) - (unless (real? a) (raise-argument-error 'in-range "real?" a)) - (unless (real? b) (raise-argument-error 'in-range "real?" b)) - (unless (real? step) (raise-argument-error 'in-range "real?" step)) + (check-range a b step) (let* ([cont? (if (step . >= . 0) (lambda (x) (< x b)) (lambda (x) (> x b)))] @@ -599,16 +606,20 @@ (define (:integer-gen v) (values values #f add1 0 (lambda (i) (i . < . v)) #f #f)) + (begin-encourage-inline + (define (check-naturals n) + (unless (and (integer? n) + (exact? n) + (n . >= . 0)) + (raise-argument-error 'in-naturals + "exact-nonnegative-integer?" + n)))) + (define in-naturals (case-lambda [() (in-naturals 0)] [(n) - (unless (and (integer? n) - (exact? n) - (n . >= . 0)) - (raise-argument-error 'in-naturals - "exact-nonnegative-integer?" - n)) + (check-naturals n) (make-range n add1 #f)])) (define-values (struct:list-stream @@ -633,8 +644,10 @@ #f #f)))))) + (define (check-list l) + (unless (list? l) (raise-argument-error 'in-list "list?" l))) (define (in-list l) - (unless (list? l) (raise-argument-error 'in-list "list?" l)) + (check-list l) (make-list-stream l)) (define (:list-gen l) @@ -776,11 +789,15 @@ ([-first (format-id #'PREFIX "~a-first" #'PREFIX)] [-next (format-id #'PREFIX "~a-next" #'PREFIX)] [-VAL (format-id #'PREFIX "~a-~a" #'PREFIX #'VAL)] + [CHECK-SEQ (format-id #'def "check-~a" #'IN-HASH-SEQ)] [AS-EXPR-SEQ (format-id #'def "default-~a" #'IN-HASH-SEQ)]) #'(begin + (begin-encourage-inline + (define (CHECK-SEQ ht) + (unless (HASHTYPE? ht) + (raise-argument-error 'IN-HASH-SEQ ERR-STR ht)))) (define (AS-EXPR-SEQ ht) - (unless (HASHTYPE? ht) - (raise-argument-error 'IN-HASH-SEQ ERR-STR ht)) + (CHECK-SEQ ht) (make-do-sequence (lambda () (:hash-gen ht -VAL -first -next)))) (define-sequence-syntax IN-HASH-SEQ (lambda () #'AS-EXPR-SEQ) @@ -793,7 +810,7 @@ ;;outer bindings ([(ht) ht-expr]) ;; outer check - (unless (HASHTYPE? ht) (AS-EXPR-SEQ ht)) + (unless-unsafe (CHECK-SEQ ht)) ;; loop bindings ([i (-first ht)]) ;; pos check @@ -861,18 +878,22 @@ (define-syntax define-in-vector-like (syntax-rules () - [(define-in-vector-like in-vector-name + [(define-in-vector-like (in-vector-name check-vector-name) type-name-str vector?-id vector-length-id :vector-gen-id) - (define in-vector-name - (case-lambda - [(v) (in-vector-name v 0 #f 1)] - [(v start) (in-vector-name v start #f 1)] - [(v start stop) (in-vector-name v start stop 1)] - [(v start stop step) - (let-values (([v start stop step] - (normalise-inputs 'in-vector-name type-name-str vector?-id vector-length-id - v start stop step))) - (make-do-sequence (lambda () (:vector-gen-id v start stop step))))]))])) + (begin + (define in-vector-name + (case-lambda + [(v) (in-vector-name v 0 #f 1)] + [(v start) (in-vector-name v start #f 1)] + [(v start stop) (in-vector-name v start stop 1)] + [(v start stop step) + (let-values (([v start stop step] + (normalise-inputs 'in-vector-name type-name-str vector?-id vector-length-id + v start stop step))) + (make-do-sequence (lambda () (:vector-gen-id v start stop step))))])) + (define (check-vector-name v) + (unless (vector?-id v) + (raise-argument-error 'in-vector-name type-name-str v))))])) (define-syntax define-:vector-like-gen (syntax-rules () @@ -900,12 +921,14 @@ vector?-id unsafe-vector-length-id in-vector-id + check-vector-id unsafe-vector-ref-id) (define (in-vector-like stx) (with-syntax ([in-vector-name in-vector-name] [type-name type-name-str] [vector? vector?-id] [in-vector in-vector-id] + [check-vector check-vector-id] [unsafe-vector-length unsafe-vector-length-id] [unsafe-vector-ref unsafe-vector-ref-id]) (syntax-case stx () @@ -916,8 +939,7 @@ (:do-in ;;outer bindings ([(vec len) (let ([vec vec-expr]) - (unless (vector? vec) - (in-vector vec)) + (check-vector vec) (values vec (unsafe-vector-length vec)))]) ;; outer check #f @@ -981,7 +1003,7 @@ (define-:vector-like-gen :vector-gen unsafe-vector-ref) - (define-in-vector-like in-vector + (define-in-vector-like (in-vector check-vector) "vector" vector? vector-length :vector-gen) (define-sequence-syntax *in-vector @@ -991,11 +1013,12 @@ #'vector? #'unsafe-vector-length #'in-vector + #'check-vector #'unsafe-vector-ref)) (define-:vector-like-gen :string-gen string-ref) - (define-in-vector-like in-string + (define-in-vector-like (in-string check-string) "string" string? string-length :string-gen) (define-sequence-syntax *in-string @@ -1005,11 +1028,12 @@ #'string? #'unsafe-string-length #'in-string + #'check-string #'string-ref)) (define-:vector-like-gen :bytes-gen unsafe-bytes-ref) - (define-in-vector-like in-bytes + (define-in-vector-like (in-bytes check-bytes) "bytes" bytes? bytes-length :bytes-gen) (define-sequence-syntax *in-bytes @@ -1019,6 +1043,7 @@ #'bytes? #'unsafe-bytes-length #'in-bytes + #'check-bytes #'unsafe-bytes-ref)) (define-:vector-like-gen :flvector-gen unsafe-flvector-ref) @@ -1878,9 +1903,8 @@ ;; outer bindings: ([(start) a] [(end) b] [(inc) step]) ;; outer check: - (unless (and (real? start) (real? end) (real? inc)) - ;; let `in-range' report the error: - (in-range start end inc)) + ;; let `check-range' report the error: + (unless-unsafe (check-range start end inc)) ;; loop bindings: ([pos start]) ;; pos check @@ -1920,9 +1944,8 @@ ;; outer bindings: ([(start) start-expr]) ;; outer check: - (unless (exact-nonnegative-integer? start) - ;; let `in-naturals' report the error: - (in-naturals start)) + ;; let `check-naturals' report the error: + (unless-unsafe (check-naturals start)) ;; loop bindings: ([pos start]) ;; pos check @@ -1951,7 +1974,7 @@ ;;outer bindings ([(lst) lst-expr]) ;; outer check - (unless (list? lst) (in-list lst)) + (unless-unsafe (check-list lst)) ;; loop bindings ([lst lst]) ;; pos check @@ -2005,7 +2028,7 @@ ;;outer bindings ([(lst) lst-expr]) ;; outer check - (unless (stream? lst) (in-stream lst)) + (unless (unless-unsafe (stream? lst)) (in-stream lst)) ;; loop bindings ([lst lst]) ;; pos check diff --git a/racket/collects/racket/private/kw.rkt b/racket/collects/racket/private/kw.rkt index 17896a4852..cadd361fd3 100644 --- a/racket/collects/racket/private/kw.rkt +++ b/racket/collects/racket/private/kw.rkt @@ -266,7 +266,8 @@ (apply proc null null args)))] [(proc plain-proc) (make-optional-keyword-procedure - (make-keyword-checker null #f (procedure-arity proc)) + (make-keyword-checker null #f (and (procedure? proc) ; reundant check helps purity inference + (procedure-arity proc))) proc null #f @@ -1053,6 +1054,19 @@ arg-accum (cons (cons (car l) (car ids)) kw-pairs))] + [(and (identifier? (car l)) + (null? bind-accum)) + ;; Don't generate an alias for an identifier if we haven't + ;; needed to bind anything earlier, since we'll keep the + ;; arguments in order in that case. This optimization is especially + ;; useful for the rator position of a direct keyword call, + ;; since we avoid generating an alias (that might take a while + ;; to optimize away] to the generic implementation. + (loop (cdr l) + (cdr ids) + null + (cons (car l) arg-accum) + kw-pairs)] [else (loop (cdr l) (cdr ids) (cons (list (car ids) (car l)) bind-accum) @@ -1277,7 +1291,9 @@ (arity-check-lambda (kws) (subset? kws allowed-kws))] [else ;; Some required, some allowed - (if (equal? req-kws allowed-kws) + (if (and (list? req-kws) ; reundant, but helps inferences of no side effects + (list? allowed-kws) ; also for inference + (eq? (length req-kws) (length allowed-kws))) (arity-check-lambda (kws) ;; All allowed are required, so check equality diff --git a/racket/collects/racket/private/load.rkt b/racket/collects/racket/private/load.rkt deleted file mode 100644 index a93f1d4908..0000000000 --- a/racket/collects/racket/private/load.rkt +++ /dev/null @@ -1,35 +0,0 @@ -(module load '#%kernel - (#%require "qq-and-or.rkt" - "more-scheme.rkt" - "define-et-al.rkt" - "executable-path.rkt") - - (#%provide load/use-compiled - embedded-load) - - (define-values (load/use-compiled) - (lambda (f) ((current-load/use-compiled) f #f))) - - ;; used for the -k command-line argument: - (define-values (embedded-load) - (lambda (start end str) - (let* ([s (if str - str - (let* ([sp (find-system-path 'exec-file)] - [exe (find-executable-path sp #f)] - [start (or (string->number start) 0)] - [end (or (string->number end) 0)]) - (with-input-from-file exe - (lambda () - (file-position (current-input-port) start) - (read-bytes (max 0 (- end start)))))))] - [p (open-input-bytes s)]) - (let loop () - (let ([e (parameterize ([read-accept-compiled #t] - [read-accept-reader #t] - [read-accept-lang #t] - [read-on-demand-source #t]) - (read p))]) - (unless (eof-object? e) - ((current-eval) e) - (loop)))))))) diff --git a/racket/collects/racket/private/map.rkt b/racket/collects/racket/private/map.rkt index 459711167d..0f40f37f76 100644 --- a/racket/collects/racket/private/map.rkt +++ b/racket/collects/racket/private/map.rkt @@ -4,7 +4,8 @@ (module map '#%kernel (#%require "small-scheme.rkt" "define.rkt" - "performance-hint.rkt") + "performance-hint.rkt" + '#%paramz) (#%provide (rename map2 map) (rename for-each2 for-each) @@ -28,7 +29,7 @@ [else (let ([r (cdr l)]) ; so `l` is not necessarily retained during `f` (cons (f (car l)) (loop r)))])) - (map f l))] + (gen-map f (list l)))] [(f l1 l2) (if (and (procedure? f) (procedure-arity-includes? f 2) @@ -43,8 +44,8 @@ [r2 (cdr l2)]) (cons (f (car l1) (car l2)) (loop r1 r2)))])) - (map f l1 l2))] - [(f l . args) (apply map f l args)])]) + (gen-map f (list l1 l2)))] + [(f l . args) (gen-map f (cons l args))])]) map)) (define for-each2 @@ -60,7 +61,7 @@ [else (let ([r (cdr l)]) (begin (f (car l)) (loop r)))])) - (for-each f l))] + (gen-for-each f (list l)))] [(f l1 l2) (if (and (procedure? f) (procedure-arity-includes? f 2) @@ -75,8 +76,8 @@ [r2 (cdr l2)]) (begin (f (car l1) (car l2)) (loop r1 r2)))])) - (for-each f l1 l2))] - [(f l . args) (apply for-each f l args)])]) + (gen-for-each f (list l1 l2)))] + [(f l . args) (gen-for-each f (cons l args))])]) for-each)) (define andmap2 @@ -95,7 +96,7 @@ (let ([r (cdr l)]) (and (f (car l)) (loop r)))]))) - (andmap f l))] + (gen-andmap f (list l)))] [(f l1 l2) (if (and (procedure? f) (procedure-arity-includes? f 2) @@ -112,8 +113,8 @@ [r2 (cdr l2)]) (and (f (car l1) (car l2)) (loop r1 r2)))]))) - (andmap f l1 l2))] - [(f l . args) (apply andmap f l args)])]) + (gen-andmap f (list l1 l2)))] + [(f l . args) (gen-andmap f (cons l args))])]) andmap)) (define ormap2 @@ -131,7 +132,7 @@ [else (let ([r (cdr l)]) (or (f (car l)) (loop r)))]))) - (ormap f l))] + (gen-ormap f (list l)))] [(f l1 l2) (if (and (procedure? f) (procedure-arity-includes? f 2) @@ -148,6 +149,101 @@ [r2 (cdr l2)]) (or (f (car l1) (car l2)) (loop r1 r2)))]))) - (ormap f l1 l2))] - [(f l . args) (apply ormap f l args)])]) - ormap)))) + (gen-ormap f (list l1 l2)))] + [(f l . args) (gen-ormap f (cons l args))])]) + ormap))) + + + ;; ------------------------------------------------------------------------- + + (define (check-args who f ls) + (unless (procedure? f) + (raise-argument-error who "procedure?" f)) + (let loop ([prev-len #f] [ls ls] [i 1]) + (unless (null? ls) + (let ([l (car ls)]) + (unless (list? l) + (raise-argument-error who "list?" l)) + (let ([len (length l)]) + (when (and prev-len + (not (= len prev-len))) + (raise-arguments-error who "all lists must have same size" + "first list length" prev-len + "other list length" len + "procedure" f)) + (loop len (cdr ls) (add1 i)))))) + (unless (procedure-arity-includes? f (length ls)) + (apply raise-arguments-error who + (string-append "argument mismatch;\n" + " the given procedure's expected number of arguments does not match" + " the given number of lists") + "given procedure" (unquoted-printing-string + (or (let ([n (object-name f)]) + (and (symbol? n) + (symbol->string n))) + "#")) + (append + (let ([a (procedure-arity f)]) + (cond + [(integer? a) + (list "expected" a)] + [(arity-at-least? a) + (list "expected" (unquoted-printing-string + (string-append "at least " (number->string (arity-at-least-value a)))))] + [else + null])) + (list "given" (length ls)) + (let ([w (quotient (error-print-width) (length ls))]) + (if (w . > . 10) + (list "argument lists..." + (unquoted-printing-string + (apply string-append + (let loop ([ls ls]) + (cond + [(null? ls) null] + [else (cons (string-append "\n " + ((error-value->string-handler) + (car ls) + w)) + (loop (cdr ls)))]))))) + null)))))) + + (define (gen-map f ls) + (check-args 'map f ls) + (let loop ([ls ls]) + (cond + [(null? (car ls)) null] + [else + (let ([next-ls (map2 cdr ls)]) + (cons (apply f (map2 car ls)) + (loop next-ls)))]))) + + (define (gen-for-each f ls) + (check-args 'for-each f ls) + (let loop ([ls ls]) + (unless (null? (car ls)) + (let ([next-ls (map2 cdr ls)]) + (apply f (map2 car ls)) + (loop next-ls))))) + + (define (gen-andmap f ls) + (check-args 'andmap f ls) + (let loop ([ls ls]) + (cond + [(null? (car ls)) #t] + [(null? (cdar ls)) (apply f (map2 car ls))] + [else (let ([next-ls (map2 cdr ls)]) + (and (apply f (map2 car ls)) + (loop next-ls)))]))) + + (define (gen-ormap f ls) + (check-args 'ormap f ls) + (let loop ([ls ls]) + (cond + [(null? (car ls)) #f] + [(null? (cdar ls)) (apply f (map2 car ls))] + [else (let ([next-ls (map2 cdr ls)]) + (or (apply f (map2 car ls)) + (loop next-ls)))]))) + + (void)) diff --git a/racket/collects/racket/private/misc.rkt b/racket/collects/racket/private/misc.rkt index 5ba2a87568..dccaa4faa3 100644 --- a/racket/collects/racket/private/misc.rkt +++ b/racket/collects/racket/private/misc.rkt @@ -4,8 +4,8 @@ (module misc '#%kernel (#%require "small-scheme.rkt" "define.rkt" "path.rkt" "old-path.rkt" - "path-list.rkt" "executable-path.rkt" "collect.rkt" - "reading-param.rkt" "load.rkt" + "path-list.rkt" "executable-path.rkt" + "reading-param.rkt" (for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt")) ;; ------------------------------------------------------------------------- @@ -254,12 +254,12 @@ load/cd load-relative load-relative-extension path-list-string->path-list find-executable-path - collection-path collection-file-path load/use-compiled guard-evt channel-get channel-try-get channel-put port? writeln displayln println - find-library-collection-paths - find-library-collection-links bytes-environment-variable-name? string-environment-variable-name? getenv putenv - call-with-default-reading-parameterization)) + call-with-default-reading-parameterization + + ;; From '#%kernel, but re-exported for compatibility: + collection-path collection-file-path)) diff --git a/racket/collects/racket/private/more-scheme.rkt b/racket/collects/racket/private/more-scheme.rkt index 8284abdd7e..7c9dd99041 100644 --- a/racket/collects/racket/private/more-scheme.rkt +++ b/racket/collects/racket/private/more-scheme.rkt @@ -201,7 +201,7 @@ (error 'with-handlers "exception handler used out of context"))) - (define handler-prompt-key (make-continuation-prompt-tag)) + (define handler-prompt-key (make-continuation-prompt-tag 'handler-prompt-tag)) (define (call-handled-body bpz handle-proc body-thunk) ;; Disable breaks here, so that when the exception handler jumps diff --git a/racket/collects/racket/private/path-list.rkt b/racket/collects/racket/private/path-list.rkt index c1d794356f..4f930c0f87 100644 --- a/racket/collects/racket/private/path-list.rkt +++ b/racket/collects/racket/private/path-list.rkt @@ -4,11 +4,7 @@ (#%provide path-list-string->path-list) (define-values (path-list-string->path-list) - (let ((r (byte-regexp (string->bytes/utf-8 - (let ((sep (if (eq? (system-type) 'windows) - ";" - ":"))) - (format "([^~a]*)~a(.*)" sep sep))))) + (let ((r #f) (cons-path (lambda (default s l) (let ([s (if (eq? (system-type) 'windows) (regexp-replace* #rx#"\"" s #"") @@ -18,6 +14,12 @@ (cons (bytes->path s) l)))))) (lambda (s default) + (unless r + (set! r (byte-regexp (string->bytes/utf-8 + (let ((sep (if (eq? (system-type) 'windows) + ";" + ":"))) + (format "([^~a]*)~a(.*)" sep sep)))))) (unless (or (bytes? s) (string? s)) (raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s)) diff --git a/racket/collects/racket/private/pre-base.rkt b/racket/collects/racket/private/pre-base.rkt index 2459ef4d9d..155c136f1a 100644 --- a/racket/collects/racket/private/pre-base.rkt +++ b/racket/collects/racket/private/pre-base.rkt @@ -19,6 +19,7 @@ "norm-arity.rkt" "performance-hint.rkt" "top-int.rkt" + "collect.rkt" '#%builtin ; so it's attached (for-syntax "kw.rkt" "norm-define.rkt")) @@ -159,32 +160,6 @@ (+ min (random d prng)))])]) random))) - (define-values (new:collection-path) - (let ([collection-path (new-lambda (collection - #:fail [fail (lambda (s) - (raise - (exn:fail:filesystem - (string-append "collection-path: " s) - (current-continuation-marks))))] - . collections) - (collection-path fail collection collections))]) - collection-path)) - - (define-values (new:collection-file-path) - (let ([collection-file-path (new-lambda (file-name - collection - #:check-compiled? [check-compiled? - (and (path-string? file-name) - (regexp-match? #rx".[.]rkt$" file-name))] - #:fail [fail (lambda (s) - (raise - (exn:fail:filesystem - (string-append "collection-file-path: " s) - (current-continuation-marks))))] - . collections) - (collection-file-path fail check-compiled? file-name collection collections))]) - collection-file-path)) - (define-syntaxes (module-begin) (lambda (stx) (let-values ([(l) (syntax->list stx)]) @@ -248,7 +223,8 @@ assq assv assoc prop:incomplete-arity prop:method-arity-error list-pair? interned-char? true-object? - random) + random + collection-path collection-file-path) (all-from "reqprov.rkt") (all-from-except "for.rkt" define-in-vector-like diff --git a/racket/collects/racket/private/reverse.rkt b/racket/collects/racket/private/reverse.rkt index b0764e2012..40ef640924 100644 --- a/racket/collects/racket/private/reverse.rkt +++ b/racket/collects/racket/private/reverse.rkt @@ -1,20 +1,14 @@ (module reverse '#%kernel - (#%provide alt-reverse) - - (define-values (alt-reverse) - (if (eval-jit-enabled) - (let-values ([(reverse) - (lambda (l) - (if (list? l) - (void) - (raise-argument-error 'reverse "list?" l)) - (letrec-values ([(loop) - (lambda (a l) - (if (null? l) - a - (loop (cons (car l) a) (cdr l))))]) - (loop null l)))]) - reverse) - reverse))) - + (#%provide (rename reverse alt-reverse)) + (define-values (reverse) + (lambda (l) + (if (list? l) + (void) + (raise-argument-error 'reverse "list?" l)) + (letrec-values ([(loop) + (lambda (a l) + (if (null? l) + a + (loop (cons (car l) a) (cdr l))))]) + (loop null l))))) diff --git a/racket/collects/racket/private/sort.rkt b/racket/collects/racket/private/sort.rkt index ae824ba9db..513182a321 100644 --- a/racket/collects/racket/private/sort.rkt +++ b/racket/collects/racket/private/sort.rkt @@ -17,8 +17,7 @@ redundant pointer arithmetic in that paper is dealing with cases of uneven number of elements.) The source uses macros to optimize some common cases (eg, no `getkey' -function, or precompiled versions with inlinable common comparison -predicates) -- they are local macros so they're not left in the compiled +function) -- they are local macros so they're not left in the compiled code. |# @@ -151,34 +150,6 @@ code. (unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-)) (merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo))))) - ;; - - - - - - - - - - - - - - - - - - - - - - - - - ;; Precompiling of standard comparison functions - ;; for standard data types - ;; - - - - - - - - - - - - - - - - - - - - - - - - - (define precompiled-sorts - (let ([sorts (make-hasheq)]) - (define-syntax-rule (precomp less-than? more ...) - (let ([sort-proc - (λ (A n) (sort-internal-body A less-than? n #f))]) - (hash-set! sorts less-than? sort-proc) - (hash-set! sorts more sort-proc) ...)) - ;; for comparison ops provided by racket/base we build - ;; fast precompiled versions - (precomp unsafe-fl< unsafe-fl<=) - (precomp unsafe-fl> unsafe-fl>=) - (precomp i< i<=) - (precomp i> i>=) - (precomp < <=) - (precomp > >=) - (precomp string? string>=?) - (precomp string-ci? string-ci>=?) - (precomp char? char>=?) - (precomp keywordstr x) (if (bytes? x) (bytes->string/utf-8 x) x)) - (define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x))) - (define-syntax-rule (tweak unwrap wrap convert) - (let ([tweaked (tweaker (unwrap rx) n)]) - ;; the tweaker is allowed to return a regexp - (if (or (regexp? tweaked) (byte-regexp? tweaked)) - tweaked - (wrap (convert tweaked))))) - (define (run-tweak) - (cond [(pregexp? rx) (tweak object-name pregexp ->str)] - [(regexp? rx) (tweak object-name regexp ->str)] - [(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)] - [(byte-regexp? rx) (tweak object-name byte-regexp ->bts)] - ;; allow getting a string, so if someone needs to go - ;; from a string to a regexp, there's no penalty - ;; because of the intermediate regexp being recreated - [(string? rx) (tweak (lambda (x) x) regexp ->str)] - [(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)] - [else (raise-argument-error - 'regexp-tweaker - "(or/c regexp? byte-regexp? string? bytes?)" - rx)])) - (let ([key (cons n rx)]) - (or (hash-ref t key #f) - (let ([rx* (run-tweak)]) (hash-set! t key rx*) rx*)))))) + (define no-empty-edge-table (make-hash)) + (define (no-empty-edge-matches rx n) + (define (tweaker rx n) + (if (bytes? rx) + (bytes-append #"(?:" rx #")(?<=" + (make-bytes n (char->integer #\.)) #")") + (format "(?:~a)(?<=~a)" rx (make-bytes n (char->integer #\.))))) + (define-syntax-rule (->str x) (if (bytes? x) (bytes->string/utf-8 x) x)) + (define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x))) + (define-syntax-rule (tweak unwrap wrap convert) + (let ([tweaked (tweaker (unwrap rx) n)]) + ;; the tweaker is allowed to return a regexp + (if (or (regexp? tweaked) (byte-regexp? tweaked)) + tweaked + (wrap (convert tweaked))))) + (define (run-tweak) + (cond [(pregexp? rx) (tweak object-name pregexp ->str)] + [(regexp? rx) (tweak object-name regexp ->str)] + [(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)] + [(byte-regexp? rx) (tweak object-name byte-regexp ->bts)] + ;; allow getting a string, so if someone needs to go + ;; from a string to a regexp, there's no penalty + ;; because of the intermediate regexp being recreated + [(string? rx) (tweak (lambda (x) x) regexp ->str)] + [(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)] + [else (raise-argument-error + 'regexp-tweaker + "(or/c regexp? byte-regexp? string? bytes?)" + rx)])) + (let ([key (cons n rx)]) + (or (hash-ref no-empty-edge-table key #f) + (let ([rx* (run-tweak)]) (hash-set! no-empty-edge-table key rx*) rx*)))) (define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f] [prefix #""]) @@ -112,13 +114,7 @@ ;; Helper macro for the regexp functions below, with some utilities. (define (bstring-length s) (if (bytes? s) (bytes-length s) (string-length s))) - (define no-empty-edge-matches - (make-regexp-tweaker - (lambda (rx n) - (if (bytes? rx) - (bytes-append #"(?:" rx #")(?<=" - (make-bytes n (char->integer #\.)) #")") - (format "(?:~a)(?<=~a)" rx (make-bytes n (char->integer #\.))))))) + (define-syntax-rule (regexp-loop name loop start end pattern string ipre success-choose failure-k diff --git a/racket/collects/racket/private/stx.rkt b/racket/collects/racket/private/stx.rkt index e0d4d694ee..9d8359dd1e 100644 --- a/racket/collects/racket/private/stx.rkt +++ b/racket/collects/racket/private/stx.rkt @@ -198,6 +198,7 @@ (values pre post (= m n))))) (define-values (intro) #f) + (define-values (counter) 0) (define-values (gen-temp-id) ;; Even though we gensym, using an introducer helps the ;; syntax system simplify renamings that can't apply @@ -207,7 +208,8 @@ (if intro (void) (set! intro (make-syntax-introducer))) - (intro (datum->syntax #f (gensym pfx))))) + (set! counter (add1 counter)) + (intro (datum->syntax #f (string->uninterned-symbol (format "~a~a" pfx counter)))))) (#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list? stx-car stx-cdr stx->list diff --git a/racket/collects/racket/private/stxparam.rkt b/racket/collects/racket/private/stxparam.rkt index 77bd397268..5553a4f100 100644 --- a/racket/collects/racket/private/stxparam.rkt +++ b/racket/collects/racket/private/stxparam.rkt @@ -4,15 +4,17 @@ (for-syntax '#%kernel "stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt" + "more-scheme.rkt" "stxloc.rkt" "stxparamkey.rkt")) - (#%provide (for-syntax do-syntax-parameterize)) + (#%provide (for-syntax do-syntax-parameterize) + let-local-keys) - (define-for-syntax (do-syntax-parameterize stx let-syntaxes-id empty-body-ok? keep-orig?) + (define-for-syntax (do-syntax-parameterize stx letrec-syntaxes-id empty-body-ok? keep-ids?) (syntax-case stx () - [(_ ([id val] ...) body ...) + [(-syntax-parameterize ([id val] ...) body ...) (let ([ids (syntax->list #'(id ...))]) - (with-syntax ([((gen-id must-be-renamer?) ...) + (with-syntax ([((gen-id local-key who/must-be-renamer) ...) (map (lambda (id) (unless (identifier? id) (raise-syntax-error @@ -28,10 +30,10 @@ stx id)) (list - (syntax-local-get-shadower - (syntax-local-introduce (syntax-parameter-target sp)) - #t) - (rename-transformer-parameter? sp)))) + (car (generate-temporaries '(stx-param))) + (syntax-parameter-key sp) + (and (rename-transformer-parameter? sp) + #'-syntax-parameterize)))) ids)]) (let ([dup (check-duplicate-identifier ids)]) (when dup @@ -46,15 +48,29 @@ #f "missing body expression(s)" stx))) - (with-syntax ([let-syntaxes let-syntaxes-id] - [(orig ...) (if keep-orig? - (list ids) - #'())]) + (with-syntax ([letrec-syntaxes letrec-syntaxes-id] + [(kept-id ...) (if keep-ids? + #'(id ...) + '())]) (syntax/loc stx - (let-syntaxes ([(gen-id) - (convert-renamer - (if must-be-renamer? (quote-syntax val) #f) - val)] - ...) - orig ... - body ...)))))]))) + (letrec-syntaxes ([(gen-id) (wrap-parameter-value 'who/must-be-renamer val)] + ...) + kept-id ... + (let-local-keys ([local-key gen-id] ...) + body ...))))))])) + + (define-syntax (let-local-keys stx) + (if (eq? 'expression (syntax-local-context)) + (let-values ([(expr opaque-expr) + (syntax-case stx () + [(_ ([local-key id] ...) body ...) + (parameterize ([current-parameter-environment + (extend-parameter-environment + (current-parameter-environment) + #'([local-key id] ...))]) + (syntax-local-expand-expression + #'(let-values () body ...) + #t))])]) + opaque-expr) + (with-syntax ([stx stx]) + #'(#%expression stx))))) diff --git a/racket/collects/racket/private/stxparamkey.rkt b/racket/collects/racket/private/stxparamkey.rkt index 16bf8479c6..c3d164b347 100644 --- a/racket/collects/racket/private/stxparamkey.rkt +++ b/racket/collects/racket/private/stxparamkey.rkt @@ -2,116 +2,107 @@ (module stxparamkey '#%kernel (#%require "small-scheme.rkt" "define.rkt" "stxcase.rkt" "stxloc.rkt" "with-stx.rkt") - - (-define-struct wrapped-renamer (renamer)) - - (define-values (struct:parameter-binding make-parameter-binding parameter-binding? parameter-binding-ref parameter-binding-set!) - (make-struct-type 'parameter-binding #f 2 0 #f null (current-inspector) #f '(0 1))) - (define parameter-binding-val (make-struct-field-accessor parameter-binding-ref 0)) - (define parameter-binding-param (make-struct-field-accessor parameter-binding-ref 1)) - - (define (parameter-binding-rt-target pbr) - (rename-transformer-target (wrapped-renamer-renamer (parameter-binding-val pbr)))) - (define-values (struct:parameter-binding-rt make-parameter-binding-rt parameter-binding-rt? parameter-binding-rt-ref parameter-binding-rt-set!) - (make-struct-type 'parameter-binding-rt struct:parameter-binding 0 0 #f (list (cons prop:rename-transformer parameter-binding-rt-target)) (current-inspector) #f)) - + ;; Consulted before the expander's table, for use by compile-time + ;; code wrapped by a run-time-phased `syntax-parameterize`: + (define current-parameter-environment (make-parameter #hasheq())) + + ;; Wrap the value for a syntax parameter in a `parameter-value` struct, + ;; so that we can distinguish it from rename transformers that arrive + ;; at the value + (define-values (struct:parameter-value make-parameter-value parameter-value? parameter-value-ref parameter-value-set!) + (make-struct-type 'parameter-value #f 1 0 #f null (current-inspector) #f '(0))) + (define parameter-value-content (make-struct-field-accessor parameter-value-ref 0)) + + (define (wrap-parameter-value who/must-be-transformer v) + (unless (or (not who/must-be-transformer) (rename-transformer? v)) + (raise-argument-error who/must-be-transformer + "rename-transformer?" + v)) + (make-parameter-value v)) + + (define (extend-parameter-environment env binds) + (with-syntax ([((key sp-id) ...) binds]) + (let loop ([ht (current-parameter-environment)] + [keys (syntax->datum #'(key ...))] + [ids (syntax->list #'(sp-id ...))]) + (cond + [(null? keys) ht] + [else (loop (hash-set ht (car keys) (car ids)) + (cdr keys) + (cdr ids))])))) + + ;; Used to propagate to a submodule, where the parameter + ;; will get a frash key as the submodule compilation starts + (define (update-parameter-keys ids binds) + (let loop ([ids (syntax->list ids)] + [binds (syntax->list binds)]) + (cond + [(null? ids) null] + [else + (with-syntax ([(key rhs) (car binds)] + [new-key (syntax-parameter-key (syntax-local-value (car ids)))]) + (cons #'[new-key rhs] + (loop (cdr ids) (cdr binds))))]))) + + (define (apply-syntax-parameter sp stx) + (let ([v (syntax-parameter-key-value (syntax-parameter-key sp) + (syntax-parameter-default-id sp))]) + (apply-transformer v stx #'set!))) + (define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!) - (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0 '(0 1))) + (make-struct-type 'syntax-parameter #f 2 0 #f (list (cons prop:set!-transformer apply-syntax-parameter)) (current-inspector) 0 '(0 1))) + + (define (syntax-parameter-default-id sp) + (syntax-parameter-ref sp 0)) + + (define (syntax-parameter-key sp) + (syntax-parameter-ref sp 1)) (define (rename-transformer-parameter-target rtp) - (define t (syntax-parameter-target rtp)) - ;; XXX (syntax-transforming?) is not always true when the - ;; prop:rename-transformer procedure is evaluated. I think this is - ;; because it used to test rename-transformer? + (define key (syntax-parameter-key rtp)) + (define default-id (syntax-parameter-default-id rtp)) + ;; (syntax-transforming?) is not always true when the + ;; prop:rename-transformer procedure is evaluated, because it is + ;; used to test the rename-transformer (define lt (if (syntax-transforming?) - (syntax-local-get-shadower t #t) - t)) + (rename-transformer-target (syntax-parameter-key-value key default-id)) + default-id)) (syntax-property lt 'not-free-identifier=? #t)) (define-values (struct:rename-transformer-parameter make-rename-transformer-parameter rename-transformer-parameter? rename-transformer-parameter-ref rename-transformer-parameter-set!) (make-struct-type 'rename-transformer-parameter struct:syntax-parameter 0 0 #f (list (cons prop:rename-transformer rename-transformer-parameter-target)) (current-inspector) #f)) - (define (syntax-parameter-target sp) - (syntax-parameter-ref sp 1)) - - ;; If it is a rename-transformer-parameter, then we need to get the - ;; parameter and not what it points to, otherwise, we can keep - ;; going. + (define (syntax-parameter-key-value key default-id) + (define id (hash-ref + (current-parameter-environment) + key + (lambda () #f))) + (let loop ([id (or id default-id)]) + (define-values (val next-id) (syntax-local-value/immediate id (lambda () (values #f #f)))) + (cond + [(parameter-value? val) (parameter-value-content val)] + [next-id + ;; Some part of expansion introduced a rename transformer + ;; between our identifier and its binding + (loop next-id)] + [else val]))) + (define (syntax-parameter-local-value id) - (let*-values - ([(rt* rt-target) - (syntax-local-value/immediate id (lambda () (values #f #f)))] - [(rt) (if (syntax-parameter? rt*) - rt* - (or (and rt-target - (syntax-local-value rt-target - (λ () rt-target))) - rt*))] - [(sp) (if (set!-transformer? rt) - (set!-transformer-procedure rt) - rt)]) - sp)) - - (define (syntax-parameter-local-value-pre id) - (define-values (rt* rt-target) - (syntax-local-value/immediate id (λ () (values #f #f)))) - (cond - [(not rt-target) - rt*] - [(syntax-parameter? rt*) - rt-target] - [(parameter-binding? rt*) - rt*] - [else - (syntax-parameter-local-value-pre rt-target)])) - - (define (syntax-parameter-local-value-for-parameter target) - (or (syntax-parameter-local-value-pre (syntax-local-get-shadower target #t)) - (syntax-parameter-local-value-pre target))) - - (define (target-value target) - (syntax-local-value (syntax-local-get-shadower target #t) - (lambda () - (syntax-local-value - target - (lambda () #f))))) - - (define (syntax-parameter-target-value target) - (let* ([v (target-value target)] - [v (if (parameter-binding? v) - (or (let ([id ((parameter-binding-param v))]) - (and id - (let ([v (syntax-local-value id)]) - (parameter-binding-val v)))) - (parameter-binding-val v)) - v)]) - (if (wrapped-renamer? v) - (wrapped-renamer-renamer v) - v))) - - (define (syntax-parameter-target-parameter target) - (let ([v (syntax-parameter-local-value-for-parameter target)]) - (parameter-binding-param v))) - - (define (convert-renamer must-be-renamer?-stx v) - (when must-be-renamer?-stx - (unless (rename-transformer? v) - (raise-syntax-error #f "rename-transformer-parameter must be bound to rename-transformer" must-be-renamer?-stx))) - ((if must-be-renamer?-stx - make-parameter-binding-rt - make-parameter-binding) - (if (rename-transformer? v) - (make-wrapped-renamer v) - v) - ;; compile-time parameter needed for `splicing-syntax-parameterize': - (make-parameter #f))) + (let loop ([id id]) + (define-values (sp next-id) (syntax-local-value/immediate id (lambda () (values #f #f)))) + (cond + [(syntax-parameter? sp) sp] + [next-id + ;; Might be a rename of a syntax-parameter binding + (loop next-id)] + [else #f]))) (define (apply-transformer v stx set!-stx) (cond [(rename-transformer? v) - (with-syntax ([target (rename-transformer-target v)]) + (with-syntax ([target (rename-transformer-target v)]) (syntax-case stx () [(set! id _expr) (free-identifier=? #'set! set!-stx) @@ -143,14 +134,16 @@ stx #f)])) - - (#%provide convert-renamer + (#%provide wrap-parameter-value + current-parameter-environment + extend-parameter-environment + update-parameter-keys apply-transformer syntax-parameter? make-syntax-parameter rename-transformer-parameter? make-rename-transformer-parameter syntax-parameter-local-value - syntax-parameter-target - syntax-parameter-target-value - syntax-parameter-target-parameter)) + syntax-parameter-key + syntax-parameter-default-id + syntax-parameter-key-value)) diff --git a/racket/collects/racket/private/vector-wraps.rkt b/racket/collects/racket/private/vector-wraps.rkt index 2513b68010..473cd76369 100644 --- a/racket/collects/racket/private/vector-wraps.rkt +++ b/racket/collects/racket/private/vector-wraps.rkt @@ -17,12 +17,13 @@ for/fXvector for*/fXvector fXvector-copy - fXzero) + fXzero + check-fXvector) (... (begin (define-:vector-like-gen :fXvector-gen unsafe-fXvector-ref) - (define-in-vector-like in-fXvector* + (define-in-vector-like (in-fXvector* check-fXvector) fXvector-str fXvector? fXvector-length :fXvector-gen) (define-sequence-syntax in-fXvector @@ -32,6 +33,7 @@ #'fXvector? #'unsafe-fXvector-length #'in-fXvector* + #'check-fXvector #'unsafe-fXvector-ref)) (define (unsafe-fXvector-copy! vec dest-start flv start end) diff --git a/racket/collects/racket/splicing.rkt b/racket/collects/racket/splicing.rkt index c26d1ca808..5419427767 100644 --- a/racket/collects/racket/splicing.rkt +++ b/racket/collects/racket/splicing.rkt @@ -294,28 +294,24 @@ (define-syntax (ssp-let-syntaxes stx) (syntax-case stx () - [(_ ([(id) rhs] ...) (orig-id ...) body ...) - (with-syntax ([(splicing-temp ...) (generate-temporaries #'(id ...))]) - #'(begin - ;; Evaluate each RHS only once: - (define-syntax splicing-temp rhs) ... - ;; Partially expand `body' to push down `let-syntax': - (expand-ssp-body (id ...) (splicing-temp ...) (orig-id ...) body) - ...))])) + [(_ ([(id) rhs] ...) orig-id ... (llk binds body ...)) + #'(begin + ;; Evaluate each RHS only once: + (define-syntax id rhs) ... + ;; Partially expand `body' to push down `let-syntax': + (expand-ssp-body binds [orig-id ...] body) + ...)])) (define-syntax (expand-ssp-body stx) (syntax-case stx () - [(_ (sp-id ...) (temp-id ...) (orig-id ...) body) + [(_ binds orig-ids body) (let ([ctx (syntax-local-make-definition-context #f #f)]) - (for ([sp-id (in-list (syntax->list #'(sp-id ...)))] - [temp-id (in-list (syntax->list #'(temp-id ...)))]) - (syntax-local-bind-syntaxes (list sp-id) - #`(syntax-local-value (quote-syntax #,temp-id)) - ctx)) - (let ([body (local-expand #'(force-expand body) - (syntax-local-context) - null ;; `force-expand' actually determines stopping places - ctx)]) + (let ([body (parameterize ([current-parameter-environment + (extend-parameter-environment (current-parameter-environment) #'binds)]) + (local-expand #'(force-expand body) + (syntax-local-context) + null ;; `force-expand' actually determines stopping places + ctx))]) (let ([body ;; Extract expanded body out of `body': (syntax-case body (quote) @@ -331,24 +327,23 @@ #%declare ) [(begin expr ...) (syntax/loc/props body - (begin (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) expr) ...))] + (begin (expand-ssp-body binds orig-ids expr) ...))] [(define-values (id ...) rhs) (syntax/loc/props body (define-values (id ...) - (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...) - rhs)))] + (let-local-keys binds rhs)))] [(define-syntaxes ids rhs) (syntax/loc/props body - (define-syntaxes ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))] + (define-syntaxes ids (wrap-param-et rhs binds)))] [(begin-for-syntax e ...) (syntax/loc/props body - (begin-for-syntax (wrap-param-et e (orig-id ...) (temp-id ...)) ...))] + (begin-for-syntax (wrap-param-et e binds) ...))] [(module . _) body] [(module* name #f form ...) (datum->syntax body (list #'module* #'name #f #`(expand-ssp-module-begin - (sp-id ...) (temp-id ...) (orig-id ...) + binds orig-ids #,body name form ...)) body)] [(module* . _) body] @@ -356,37 +351,34 @@ [(#%provide . _) body] [(#%declare . _) body] [expr (syntax/loc body - (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...) - expr))]))))])) + (let-local-keys binds expr))]))))])) (define-syntax (expand-ssp-module-begin stx) (syntax-case stx () - [(_ (sp-id ...) (temp-id ...) (orig-id ...) mod-form mod-name-id body-form ...) + [(_ binds orig-ids mod-form mod-name-id body-form ...) (unless (eq? (syntax-local-context) 'module-begin) (raise-syntax-error #f "only allowed in module-begin context" stx)) - (let ([ctx (syntax-local-make-definition-context #f #f)]) - (for ([sp-id (in-list (syntax->list #'(sp-id ...)))] - [temp-id (in-list (syntax->list #'(temp-id ...)))]) - (syntax-local-bind-syntaxes (list sp-id) - #`(syntax-local-value (quote-syntax #,temp-id)) - ctx)) - (let* ([forms (syntax->list #'(body-form ...))] - ; emulate how the macroexpander expands module bodies and introduces #%module-begin - [body (if (= (length forms) 1) - (let ([body (local-expand (car forms) 'module-begin #f ctx)]) - (syntax-case body (#%plain-module-begin) - [(#%plain-module-begin . _) body] - [_ (datum->syntax #'mod-form (list '#%module-begin body) #'mod-form)])) - (datum->syntax #'mod-form (list* '#%module-begin forms) #'mod-form))] - [body (syntax-property body 'enclosing-module-name (syntax-e #'mod-name-id))] - [body (local-expand body 'module-begin #f ctx)]) - (syntax-case body (#%plain-module-begin) - [(#%plain-module-begin form ...) - (syntax/loc/props body - (#%plain-module-begin - (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) form) ...))] - [_ (raise-syntax-error - #f "expansion of #%module-begin is not a #%plain-module-begin form" body)])))])) + (with-syntax ([new-binds (update-parameter-keys #'orig-ids #'binds)]) + (parameterize ([current-parameter-environment + (extend-parameter-environment (current-parameter-environment) + #'new-binds)]) + (let* ([forms (syntax->list #'(body-form ...))] + ;; emulate how the macroexpander expands module bodies and introduces #%module-begin + [body (if (= (length forms) 1) + (let ([body (local-expand (car forms) 'module-begin #f)]) + (syntax-case body (#%plain-module-begin) + [(#%plain-module-begin . _) body] + [_ (datum->syntax #'mod-form (list '#%module-begin body) #'mod-form)])) + (datum->syntax #'mod-form (list* '#%module-begin forms) #'mod-form))] + [body (syntax-property body 'enclosing-module-name (syntax-e #'mod-name-id))] + [body (local-expand body 'module-begin #f)]) + (syntax-case body (#%plain-module-begin) + [(#%plain-module-begin form ...) + (syntax/loc/props body + (#%plain-module-begin + (expand-ssp-body new-binds orig-ids form) ...))] + [_ (raise-syntax-error + #f "expansion of #%module-begin is not a #%plain-module-begin form" body)]))))])) (define-syntax (letrec-syntaxes/trans stx) (syntax-case stx () @@ -409,20 +401,14 @@ 'certify-mode 'transparent)])) -(define-for-syntax (parameter-of id) - (let ([sp (syntax-parameter-local-value id)]) - (syntax-parameter-target-parameter - (syntax-parameter-target sp)))) - (begin-for-syntax (define-syntax (wrap-param-et stx) (syntax-case stx () - [(_ e (orig-id ...) (temp-id ...)) + [(_ e binds) (let ([as-expression (lambda () - #'(parameterize ([(parameter-of (quote-syntax orig-id)) - (quote-syntax temp-id)] - ...) + #'(parameterize ([current-parameter-environment + (extend-parameter-environment (current-parameter-environment) (quote-syntax binds))]) e))]) (if (eq? (syntax-local-context) 'expression) (as-expression) @@ -438,17 +424,17 @@ quote-syntax) [(begin form ...) (syntax/loc/props e - (begin (wrap-param-et form (orig-id ...) (temp-id ...)) ...))] + (begin (wrap-param-et form binds) ...))] [(define-syntaxes . _) e] [(begin-for-syntax . _) e] [(define-values ids rhs) (syntax/loc/props e - (define-values ids (wrap-param-et rhs (orig-id ...) (temp-id ...))))] + (define-values ids (wrap-param-et rhs binds)))] [(module . _) e] [(module* n #f form ...) (datum->syntax e - (syntax-e #'(module* n #f (wrap-param-et form (orig-id ...) (temp-id ...)) ...)) + (syntax-e #'(module* n #f (wrap-param-et form binds) ...)) e e)] [(module* . _) e] diff --git a/racket/collects/racket/stxparam-exptime.rkt b/racket/collects/racket/stxparam-exptime.rkt index 86e1b34c20..b301f0c67c 100644 --- a/racket/collects/racket/stxparam-exptime.rkt +++ b/racket/collects/racket/stxparam-exptime.rkt @@ -9,14 +9,11 @@ (define-values (syntax-parameter-value) (lambda (id) - (let* ([v (syntax-local-value id (lambda () #f))] - [v (if (set!-transformer? v) - (set!-transformer-procedure v) - v)]) + (let* ([v (syntax-local-value id (lambda () #f))]) (unless (syntax-parameter? v) (raise-argument-error 'syntax-parameter-value "syntax-parameter?" v)) - (let ([target (syntax-parameter-target v)]) - (syntax-parameter-target-value target))))) + (syntax-parameter-key-value (syntax-parameter-key v) + (syntax-parameter-default-id v))))) (define-values (make-parameter-rename-transformer) (lambda (id) diff --git a/racket/collects/racket/stxparam.rkt b/racket/collects/racket/stxparam.rkt index cf3c561a07..182df39e96 100644 --- a/racket/collects/racket/stxparam.rkt +++ b/racket/collects/racket/stxparam.rkt @@ -7,7 +7,8 @@ "stxparam-exptime.rkt" "private/stxcase-scheme.rkt" "private/small-scheme.rkt" - "private/stxloc.rkt" "private/stxparamkey.rkt")) + "private/stxloc.rkt" + "private/stxparamkey.rkt")) (#%provide define-syntax-parameter define-rename-transformer-parameter @@ -20,27 +21,24 @@ [(_ id init-val) (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) #'(begin - (define-syntax gen-id (convert-renamer #f init-val)) - (define-syntax id - (let ([gen-id #'gen-id]) - (make-set!-transformer - (make-syntax-parameter - (lambda (stx) - (let ([v (syntax-parameter-target-value gen-id)]) - (apply-transformer v stx #'set!))) - gen-id))))))])) + (define-syntax gen-id (wrap-parameter-value #f init-val)) + (define-syntax id + (let ([key (gensym)]) + (make-syntax-parameter + (quote-syntax gen-id) + key)))))])) (define-syntax (define-rename-transformer-parameter stx) (syntax-case stx () [(_ id init-val) (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) #'(begin - (define-syntax gen-id (convert-renamer #'init-val init-val)) + (define-syntax gen-id (wrap-parameter-value 'define-rename-transformer-parameter init-val)) (define-syntax id - (let ([gen-id #'gen-id]) + (let ([key (gensym)]) (make-rename-transformer-parameter - #f - gen-id)))))])) + #'gen-id ; needed if `key` is not set + key)))))])) (define-syntax (syntax-parameterize stx) - (do-syntax-parameterize stx #'let-syntaxes #f #f))) + (do-syntax-parameterize stx #'letrec-syntaxes #f #f))) diff --git a/racket/collects/raco/main.rkt b/racket/collects/raco/main.rkt index ae96ee0765..c337bcc1d3 100644 --- a/racket/collects/raco/main.rkt +++ b/racket/collects/raco/main.rkt @@ -6,18 +6,21 @@ ;; `for-label', otherwise it could get a .zo anyway. (module main '#%kernel - (#%require '#%min-stx + (#%require '#%paramz ;; Need to make sure they're here: '#%builtin) - (module test '#%kernel) - (let-values ([(cmdline) (current-command-line-arguments)]) - (if (and (positive? (vector-length cmdline)) - (equal? "setup" (vector-ref cmdline 0))) - (parameterize ([current-command-line-arguments - (list->vector - (cdr - (vector->list cmdline)))]) + (if (if (positive? (vector-length cmdline)) + (equal? "setup" (vector-ref cmdline 0)) + #f) + (with-continuation-mark + parameterization-key + (extend-parameterization + (continuation-mark-set-first #f parameterization-key) + current-command-line-arguments + (list->vector + (cdr + (vector->list cmdline)))) (dynamic-require 'setup/main #f)) (dynamic-require 'raco/raco #f)))) diff --git a/racket/collects/setup/cross-system.rkt b/racket/collects/setup/cross-system.rkt index b4c48ab517..00a435caff 100644 --- a/racket/collects/setup/cross-system.rkt +++ b/racket/collects/setup/cross-system.rkt @@ -7,7 +7,7 @@ (define cross-system-table #f) -(define system-type-symbols '(os word gc link machine so-suffix so-mode fs-change)) +(define system-type-symbols '(os word gc vm link machine so-suffix so-mode fs-change)) (define (compute-cross!) (unless cross-system-table @@ -49,7 +49,7 @@ (unless (memq mode system-type-symbols) (raise-argument-error 'cross-system-type - "(or/c 'os 'word 'gc 'link 'machine 'so-suffix 'so-mode 'fs-change)" + "(or/c 'os 'word 'gc 'vm 'link 'machine 'so-suffix 'so-mode 'fs-change)" mode)) (compute-cross!) (or (hash-ref cross-system-table mode #f) @@ -58,10 +58,10 @@ (define (cross-system-library-subpath [mode (begin (compute-cross!) (cross-system-type 'gc))]) - (unless (memq mode '(#f 3m cgc)) + (unless (memq mode '(#f 3m cgc cs)) (raise-argument-error 'cross-system-library-subtype - "(or/c #f '3m 'cgc)" + "(or/c #f '3m 'cgc 'cs)" mode)) (compute-cross!) (define bstr (hash-ref cross-system-table 'library-subpath #f)) @@ -71,7 +71,8 @@ (define path (bytes->path bstr conv)) (case mode [(#f cgc) path] - [(3m) (build-path path (bytes->path #"3m" conv))])] + [(3m) (build-path path (bytes->path #"3m" conv))] + [(cs) (build-path path (bytes->path #"cs" conv))])] [else (system-library-subpath mode)])) (define (cross-installation?) diff --git a/racket/collects/setup/main.rkt b/racket/collects/setup/main.rkt index 0473c8ea3e..4143efddc4 100644 --- a/racket/collects/setup/main.rkt +++ b/racket/collects/setup/main.rkt @@ -9,18 +9,84 @@ ;; `for-label', otherwise it could get a .zo anyway. ;; Also, do not `require' any module that is compiled. That constraint -;; essentially restrcts this module to `require's of '#%... modules. +;; essentially restricts this module to `require's of '#%... modules. (module main '#%kernel - (#%require '#%min-stx - '#%utils ; for find-main-collects + (#%require '#%utils ; for find-main-collects + '#%paramz ;; Need to make sure they're here: - '#%builtin) + '#%builtin + (for-syntax '#%kernel)) (module test '#%kernel) + + ;; ---------------------------------------- + ;; Some minimal syntax extensions to '#%kernel + + (define-syntaxes (parameterize) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (let-values ([(bindings) (apply append + (map syntax->list (syntax->list (car s))))]) + (datum->syntax + (quote-syntax here) + (list 'with-continuation-mark + 'parameterization-key + (list* 'extend-parameterization + '(continuation-mark-set-first #f parameterization-key) + bindings) + (list* 'let-values () + (cdr s)))))))) - (when (file-stream-port? (current-output-port)) - (file-stream-buffer-mode (current-output-port) 'line)) + (define-syntaxes (and) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (if (null? s) + (quote-syntax #t) + (if (null? (cdr s)) + (car s) + (datum->syntax (quote-syntax here) + (list 'if (car s) (cons 'and (cdr s)) #f))))))) + + (define-syntaxes (or) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (if (null? s) + (quote-syntax #f) + (if (null? (cdr s)) + (car s) + (datum->syntax (quote-syntax here) + (list 'let-values (list (list (list 'x) + (car s))) + (list 'if 'x 'x (cons 'or (cdr s)))))))))) + + (define-syntaxes (let) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (datum->syntax + (quote-syntax here) + (if (symbol? (syntax-e (car s))) + (let-values ([(clauses) + (map (lambda (c) + (syntax->list c)) + (syntax->list (cadr s)))]) + (list 'letrec-values (list (list (list (car s)) + (list* 'lambda + (map car clauses) + (cddr s)))) + (cons (car s) (map cadr clauses)))) + (list* 'let-values (map (lambda (c) + (let-values ([(c) (syntax->list c)]) + (cons (list (car c)) + (cdr c)))) + (syntax->list (car s))) + (cdr s))))))) + + ;; ---------------------------------------- + + (if (file-stream-port? (current-output-port)) + (file-stream-buffer-mode (current-output-port) 'line) + (void)) (define-values (make-kernel-namespace) (lambda () @@ -36,30 +102,6 @@ [current-namespace (make-kernel-namespace)]) ((dynamic-require 'setup/private/command-name 'get-names)))) - ;; Poor-man's processing of the command-line flags to drop strings - ;; that will not be parsed as flags by "parse-cmdline.rkt". We don't - ;; want to load "parse-cmdline.rkt" because it takes a long time with - ;; bytecode files disabled, and we're not yet sure whether to trust - ;; bytecode files that do exist. - (define-values (filter-flags) - (lambda (flags) - (if (or (null? flags) - (not (regexp-match? #rx"^-" (car flags))) - (equal? "-l" (car flags))) - null - (if (equal? "-P" (car flags)) - (if ((length flags) . > . 5) - (filter-flags (list-tail flags 5)) - null) - (if (or (equal? "--mode" (car flags)) - (equal? "--doc-pdf" (car flags))) - (if (pair? (cdr flags)) - (filter-flags (cddr flags)) - null) - (cons (car flags) (filter-flags (cdr flags)))))))) - - (define-values (flags) (filter-flags (vector->list (current-command-line-arguments)))) - (define-values (member) (lambda (a l) (if (null? l) @@ -68,6 +110,69 @@ l (member a (cdr l)))))) + (define-values (go-module) 'setup/setup-go) + (define-values (print-loading-sources?) #f) + + ;; Poor-man's processing of the command-line flags to drop strings + ;; that will not be parsed as flags by "parse-cmdline.rkt". We don't + ;; want to load "parse-cmdline.rkt" because it takes a long time with + ;; bytecode files disabled, and we're not yet sure whether to trust + ;; bytecode files that do exist. + (define-values (filter-flags) + (lambda (queued-flags flags) + (let ([flags (if (pair? queued-flags) + (cons (car queued-flags) flags) + flags)] + [queued-flags (if (pair? queued-flags) + (cdr queued-flags) + '())]) + (if (or (null? flags) + (not (regexp-match? #rx"^-" (car flags))) + (member (car flags) + ;; Flags that end flag processing: + '("-l" "--pkgs" "--"))) + queued-flags + (if (equal? "-P" (car flags)) + (if ((length flags) . > . 5) + (filter-flags queued-flags (list-tail flags 5)) + queued-flags) + (if (member (car flags) + ;; Flags that take 1 argument: + '("--mode" "--doc-pdf" + "-j" "--jobs" "--workers")) + (if (pair? (cdr flags)) + (filter-flags queued-flags (cddr flags)) + queued-flags) + (if (or (equal? "--boot" (car flags)) + (equal? "--chain" (car flags))) + ;; Record an alternate boot module and [additional] compiled-file root + (if (and (pair? (cdr flags)) + (pair? (cddr flags))) + (begin + (set! go-module (list 'file (cadr flags))) + (set! print-loading-sources? #t) + (let ([root (path->complete-path (caddr flags))]) + (current-compiled-file-roots + (if (equal? "--boot" (car flags)) + (list root) + (cons root (current-compiled-file-roots))))) + (cons (car flags) + (filter-flags queued-flags (cddr flags)))) + queued-flags) + ;; Check for combined flags and split them apart: + (if (regexp-match? #rx"^-([^-].+)" (car flags)) + (filter-flags (append + (map (lambda (c) + (string #\- c)) + (cdr (string->list (car flags)))) + queued-flags) + (cdr flags)) + ;; A flag with no argument: + (cons (car flags) + (filter-flags queued-flags (cdr flags))))))))))) + + (define-values (flags) (filter-flags '() (vector->list (current-command-line-arguments)))) + ;; Checks whether a flag is present: (define-values (on?) (lambda (flag-name) @@ -83,8 +188,9 @@ (define-values (main-collects-relative->path) (let ([main-collects #f]) (lambda (p) - (unless main-collects - (set! main-collects (find-main-collects))) + (if main-collects + (void) + (set! main-collects (find-main-collects))) (if (and (pair? p) (eq? 'collects (car p))) (apply build-path main-collects @@ -99,11 +205,13 @@ (on? "-n")) ;; Don't use .zos, in case they're out of date, and don't load ;; cm: - (when (or (on? "--clean") - (on? "-c")) - (use-compiled-file-paths null) - (print-bootstrapping "triggered by command-line `--clean` or `-c`")) - + (if (or (on? "--clean") + (on? "-c")) + (begin + (use-compiled-file-paths null) + (print-bootstrapping "triggered by command-line `--clean` or `-c`")) + (void)) + ;; Load the cm instance to be installed while loading Setup PLT. ;; This has to be dynamic, so we get a chance to turn off compiled ;; file loading, and so it can be in a separate namespace. @@ -124,8 +232,9 @@ ;; compiled files. (let loop ([skip-zo/reason (and (null? (use-compiled-file-paths)) "empty use-compiled-file-paths")]) - (when skip-zo/reason - (print-bootstrapping skip-zo/reason)) + (if skip-zo/reason + (print-bootstrapping skip-zo/reason) + (void)) ((call-with-escape-continuation (lambda (escape) ;; Create a new namespace, and also install load handlers @@ -138,7 +247,11 @@ [current-load (let ([orig-load (current-load)]) (if skip-zo/reason - orig-load + (if print-loading-sources? + (lambda (path modname) + (log-message (current-logger) 'info 'compiler/cm (format "loading ~a" path)) + (orig-load path modname)) + orig-load) (lambda (path modname) (if (regexp-match? #rx#"[.]zo$" (path->bytes path)) ;; It's a .zo: @@ -158,9 +271,10 @@ (eq? (car dep) 'indirect)) (cdr dep) dep)]) - (unless (and (pair? dep) - (eq? (car dep) 'ext)) - (dynamic-require (main-collects-relative->path dep) #f)))) + (if (and (pair? dep) + (eq? (car dep) 'ext)) + (void) + (dynamic-require (main-collects-relative->path dep) #f)))) (cddr deps)))) ;; Not a .zo! Don't use .zo files at all... (escape (lambda () @@ -177,7 +291,7 @@ ;; If something goes wrong, of course, give up on .zo files. (parameterize ([uncaught-exception-handler (lambda (exn) - (when (exn:break? exn) (exit 1)) + (if (exn:break? exn) (exit 1) (void)) (if skip-zo/reason (escape (lambda () (raise exn))) @@ -187,16 +301,17 @@ (format "uncaught exn: ~s" exn)))))))]) ;; Here's the main dynamic load of "cm.rkt": (let ([mk - (dynamic-require 'compiler/cm + (dynamic-require 'compiler/private/cm-minimal 'make-compilation-manager-load/use-compiled-handler)] [trust-zos - (dynamic-require 'compiler/cm 'trust-existing-zos)]) + (dynamic-require 'compiler/private/cm-minimal 'trust-existing-zos)]) ;; Return the two extracted functions: (lambda () (values mk trust-zos)))))))))]) - (when (on? "--trust-zos") - (trust-zos #t)) + (if (on? "--trust-zos") + (trust-zos #t) + (void)) (current-load/use-compiled (mk)))) ;; This has to be dynamic, so we get a chance to turn off ;; .zo use and turn on the compilation manager. - ((dynamic-require 'setup/setup-go 'go) original-compiled-file-paths)) + ((dynamic-require go-module 'go) original-compiled-file-paths)) diff --git a/racket/collects/setup/private/command-name.rkt b/racket/collects/setup/private/command-name.rkt index 9a3dfd0444..3af92595d7 100644 --- a/racket/collects/setup/private/command-name.rkt +++ b/racket/collects/setup/private/command-name.rkt @@ -20,9 +20,9 @@ ;; then claim to be the "setup" command: ;; if the program name is "racket", assume that there's a "racket -l setup" ;; going on in there and also claim to be the "raco setup" command - (if (if (equal? (path->string name) "raco") + (if (if (regexp-match? #rx"^raco(?:|3m|cgc|cs)$" (path->string name)) #t - (equal? (path->string name) "racket")) + (regexp-match? #rx"^racket(?:|3m|cgc|cs)$" (path->string name))) (values "raco setup" (string-append (regexp-replace* #rx"racket$" diff --git a/racket/collects/setup/private/dirs.rkt b/racket/collects/setup/private/dirs.rkt index 74f15bcd6e..25b8b4ae61 100644 --- a/racket/collects/setup/private/dirs.rkt +++ b/racket/collects/setup/private/dirs.rkt @@ -75,6 +75,7 @@ (define-config config:pkgs-search-dirs 'pkgs-search-dirs to-path) (define-config config:cgc-suffix 'cgc-suffix values) (define-config config:3m-suffix '3m-suffix values) +(define-config config:cs-suffix 'cs-suffix values) (define-config config:absolute-installation? 'absolute-installation? (lambda (x) (and x #t))) (define-config config:doc-search-url 'doc-search-url values) (define-config config:doc-open-url 'doc-open-url values) @@ -84,6 +85,7 @@ (provide get-absolute-installation? get-cgc-suffix get-3m-suffix + get-cs-suffix get-doc-search-url get-doc-open-url get-installation-name @@ -92,6 +94,7 @@ (define (get-absolute-installation?) (force config:absolute-installation?)) (define (get-cgc-suffix) (force config:cgc-suffix)) (define (get-3m-suffix) (force config:3m-suffix)) +(define (get-cs-suffix) (force config:cs-suffix)) (define (get-doc-search-url) (or (force config:doc-search-url) "http://docs.racket-lang.org/local-redirect/index.html")) (define (get-doc-open-url) (force config:doc-open-url)) diff --git a/racket/collects/setup/setup-cmdline.rkt b/racket/collects/setup/setup-cmdline.rkt index 135124732a..4c3931d890 100644 --- a/racket/collects/setup/setup-cmdline.rkt +++ b/racket/collects/setup/setup-cmdline.rkt @@ -108,6 +108,12 @@ [("--unused-pkg-deps") "Check for unused package-dependency declarations" (add-flags '((check-dependencies #t) (check-unused-dependencies #t)))] + [("--chain") path dir "Select a continuation other than `setup/setup-go`" + ;; This flag is handled by `setup/main` + (void)] + [("--boot") path dir "Like `--chain`, but use compiled only from " + ;; This flag is handled by `setup/main` + (void)] #:help-labels " ------------------------------ users ------------------------------ " #:once-each diff --git a/racket/collects/setup/variant.rkt b/racket/collects/setup/variant.rkt index 01969f5044..dbfeebfcfa 100644 --- a/racket/collects/setup/variant.rkt +++ b/racket/collects/setup/variant.rkt @@ -6,30 +6,39 @@ (provide variant-suffix) -(define plain-mz-is-cgc? +(define plain-variant (delay/sync (cond - [(cross-installation?) - (eq? 'cgc (cross-system-type 'gc))] - [else - (let* ([dir (find-console-bin-dir)] - [exe (cond [(eq? 'windows (system-type)) "Racket.exe"] - [(equal? #".dll" (system-type 'so-suffix)) - ;; in cygwin so-suffix is ".dll" - "racket.exe"] - [else "racket"])] - [f (build-path dir exe)]) - (and (file-exists? f) - (with-input-from-file f - (lambda () - (regexp-match? #rx#"bINARy tYPe:..c" - (current-input-port))))))]))) + [(cross-installation?) + (if (eq? 'chez-scheme (cross-system-type 'vm)) + 'cs + (cross-system-type 'gc))] + [else + (let* ([dir (find-console-bin-dir)] + [exe (cond [(eq? 'windows (system-type)) "Racket.exe"] + [(equal? #".dll" (system-type 'so-suffix)) + ;; in cygwin so-suffix is ".dll" + "racket.exe"] + [else "racket"])] + [f (build-path dir exe)]) + (and (file-exists? f) + (with-input-from-file f + (lambda () + (define m (regexp-match #rx#"bINARy tYPe:..(.)" + (current-input-port))) + (cond + [(not m) '3m] + [(equal? (cadr m) #"c") 'cgc] + [(equal? (cadr m) #"s") 'cs] + [else '3m])))))]))) (define (variant-suffix variant cased?) (let ([r (case variant [(3m script-3m) (or (get-3m-suffix) - (if (force plain-mz-is-cgc?) "3m" ""))] + (if (eq? '3m (force plain-variant)) "" "3m"))] [(cgc script-cgc) (or (get-cgc-suffix) - (if (force plain-mz-is-cgc?) "" "CGC"))] + (if (eq? 'cgc (force plain-variant)) "" "CGC"))] + [(cs script-cs) (or (get-cs-suffix) + (if (eq? 'cs (force plain-variant)) "" "CS"))] [else (error 'variant-suffix "unknown variant: ~e" variant)])]) (if cased? r (string-downcase r)))) diff --git a/racket/collects/syntax/modcode.rkt b/racket/collects/syntax/modcode.rkt index 5c355d138c..f97963f9a3 100644 --- a/racket/collects/syntax/modcode.rkt +++ b/racket/collects/syntax/modcode.rkt @@ -1,14 +1,11 @@ #lang racket/base (require racket/contract/base - racket/list - racket/path - "modread.rkt") + "private/modcode-noctc.rkt") -(provide moddep-current-open-input-file - exn:get-module-code - exn:get-module-code? - exn:get-module-code-path - make-exn:get-module-code) +(provide (except-out (all-from-out "private/modcode-noctc.rkt") + get-module-code + get-module-path + get-metadata-path)) (provide/contract [get-module-code @@ -40,249 +37,3 @@ (#:roots (listof (or/c path-string? 'same))) #:rest (listof (or/c path-string? 'same)) path?)]) - -(define moddep-current-open-input-file - (make-parameter open-input-file)) - -(define (resolve s) - (if (complete-path? s) - s - (let ([d (current-load-relative-directory)]) - (if d (path->complete-path s d) s)))) - -(define (date>=? a bm) - (and a - (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (file-or-directory-modify-seconds a))]) - (and am (if bm (>= am bm) #t))))) - -(define (read-one orig-path path src? read-src-syntax) - (define p ((moddep-current-open-input-file) path)) - (when src? (port-count-lines! p)) - (define (reader) - (define-values (base name dir?) (split-path orig-path)) - (define unchecked-v - (with-module-reading-parameterization - (lambda () - ;; In case we're reading a .zo, we need to set - ;; the load-relative directory for unmarshaling - ;; path literals. - (parameterize ([current-load-relative-directory - (if (path? base) base (current-directory))]) - (read-src-syntax path p))))) - (when (eof-object? unchecked-v) - (error 'read-one "empty file; expected a module declaration in: ~a" path)) - (define sym - (string->symbol - (bytes->string/utf-8 (path->bytes (path-replace-extension name #"")) #\?))) - (define checked-v (check-module-form unchecked-v sym path)) - (unless (eof-object? (read p)) - (error 'read-one - "file has more than one expression; expected a module declaration only in: ~a" - path)) - (if (and (syntax? checked-v) (compiled-expression? (syntax-e checked-v))) - (syntax-e checked-v) - checked-v)) - (define (closer) (close-input-port p)) - (dynamic-wind void reader closer)) - -(define-struct (exn:get-module-code exn:fail) (path)) - -(define (reroot-path* base root) - (cond - [(eq? root 'same) base] - [(relative-path? root) (build-path base root)] - [else (reroot-path base root)])) - -;; : (or/c path-string? 'same) -> (or/c path? 'same) -(define (path-string->path ps) - (if (string? ps) (string->path ps) ps)) - -;; : (listof (or/c path-string? 'same)) -> (listof (or/c path? 'same)) -(define (root-strs->roots root-strs) - (map path-string->path root-strs)) - -(define (get-metadata-path - #:roots [root-strs (current-compiled-file-roots)] - base-str . arg-strs) - (define base (path-string->path base-str)) - (define roots (root-strs->roots root-strs)) - (define args (root-strs->roots arg-strs)) - (cond - [(or (equal? roots '(same)) (null? roots)) - (apply build-path base args)] - [else - (or (for/or ([root (in-list (if (null? (cdr roots)) null roots))]) - (define p (apply build-path (reroot-path* base root) args)) - (and (file-exists? p) p)) - (apply build-path (reroot-path* base (car roots)) args))])) - -(define (get-module-path - path0-str - #:roots [root-strs (current-compiled-file-roots)] - #:submodule? [submodule? #f] - #:sub-path [sub-path/kw "compiled"] - [sub-path sub-path/kw] - #:choose [choose (lambda (src zo so) #f)] - #:rkt-try-ss? [rkt-try-ss? #t]) - (define path0 (path-string->path path0-str)) - (define roots (root-strs->roots root-strs)) - (define resolved-path (resolve path0)) - (define-values (path0-rel path0-file path0-dir?) (split-path path0)) - (define-values (main-src-file alt-src-file) - (if rkt-try-ss? - (let* ([b (path->bytes path0-file)] - [len (bytes-length b)]) - (cond - [(and (len . >= . 4) (bytes=? #".rkt" (subbytes b (- len 4)))) - ;; .rkt => try .rkt then .ss - (values path0-file - (bytes->path (bytes-append (subbytes b 0 (- len 4)) - #".ss")))] - [else - ;; No search path - (values path0-file #f)])) - (values path0-file #f))) - (define main-src-path - (if (eq? main-src-file path0-file) - resolved-path - (build-path path0-rel main-src-file))) - (define alt-src-path - (and alt-src-file - (if (eq? alt-src-file path0-file) - resolved-path - (build-path path0-rel alt-src-file)))) - (define path0-base (if (eq? path0-rel 'relative) 'same path0-rel)) - (define main-src-date - (file-or-directory-modify-seconds main-src-path #f (lambda () #f))) - (define alt-src-date - (and alt-src-path - (not main-src-date) - (file-or-directory-modify-seconds alt-src-path #f (lambda () #f)))) - (define src-date (or main-src-date alt-src-date)) - (define src-file (if alt-src-date alt-src-file main-src-file)) - (define src-path (if alt-src-date alt-src-path main-src-path)) - (define try-alt? (and alt-src-file (not alt-src-date) (not main-src-date))) - (define (get-so file) - (get-metadata-path #:roots roots - path0-base - sub-path - "native" - (system-library-subpath) - (path-add-extension file (system-type 'so-suffix)))) - (define zo - (get-metadata-path #:roots roots - path0-base - sub-path - (path-add-extension src-file #".zo"))) - (define alt-zo - (and try-alt? - (get-metadata-path #:roots roots - path0-base - sub-path - (path-add-extension alt-src-file #".zo")))) - (define so (get-so src-file)) - (define alt-so (and try-alt? (get-so alt-src-file))) - (define prefer (choose src-path zo so)) - (cond - ;; Use .zo, if it's new enough - [(or (eq? prefer 'zo) - (and (not prefer) - (pair? roots) - (or (date>=? zo src-date) - (and try-alt? - (date>=? alt-zo src-date))))) - (let ([zo (if (date>=? zo src-date) - zo - (if (and try-alt? (date>=? alt-zo src-date)) - alt-zo - zo))]) - (values (simple-form-path zo) 'zo))] - ;; Maybe there's an .so? Use it only if we don't prefer source - ;; and only if there's no submodule path. - [(and (not submodule?) - (or (eq? prefer 'so) - (and (not prefer) - (pair? roots) - (or (date>=? so src-date) - (and try-alt? - (date>=? alt-so src-date)))))) - (let ([so (if (date>=? so src-date) - so - (if (and try-alt? (date>=? alt-so src-date)) - alt-so - so))]) - (values (simple-form-path so) 'so))] - ;; Use source if it exists - [(or (eq? prefer 'src) src-date) - (values (simple-form-path src-path) 'src)] - ;; Report a not-there error - [else (raise (make-exn:get-module-code - (format "get-module-code: no such file: ~e" resolved-path) - (current-continuation-marks) - #f))])) - -(define (get-module-code - path0-str - #:roots [root-strs (current-compiled-file-roots)] - #:submodule-path [submodule-path '()] - #:sub-path [sub-path/kw "compiled"] - [sub-path sub-path/kw] - #:compile [compile/kw compile] - [compiler compile/kw] - #:extension-handler [ext-handler/kw #f] - [ext-handler ext-handler/kw] - #:choose [choose (lambda (src zo so) #f)] - #:notify [notify void] - #:source-reader [read-src-syntax read-syntax] - #:rkt-try-ss? [rkt-try-ss? #t]) - (define path0 (path-string->path path0-str)) - (define roots (root-strs->roots root-strs)) - (define-values (path type) - (get-module-path - path0 - #:roots roots - #:submodule? (pair? submodule-path) - #:sub-path sub-path - #:choose choose - #:rkt-try-ss? rkt-try-ss?)) - (define (extract-submodule m [sm-path submodule-path]) - (cond - [(null? sm-path) m] - [else - (extract-submodule - (or (for/or ([c (in-list (append (module-compiled-submodules m #t) - (module-compiled-submodules m #f)))]) - (and (eq? (last (module-compiled-name c)) (car sm-path)) - c)) - (raise - (make-exn:get-module-code - (format "get-module-code: cannot find submodule: ~e" sm-path) - (current-continuation-marks) - #f))) - (cdr sm-path))])) - (case type - [(zo) - (notify path) - (extract-submodule (read-one path0 path #f read-syntax))] - [(so) - (if ext-handler - (begin - (notify path) - (ext-handler path #f)) - (raise (make-exn:get-module-code - (format "get-module-code: cannot use extension file; ~e" path) - (current-continuation-marks) - path)))] - [(src) - (notify path) - (define (compile-one) - (define-values (path0-base path0-name path0-dir?) (split-path path0)) - (parameterize ([current-load-relative-directory - (if (path? path0-base) path0-base (current-directory))]) - (compiler (read-one path0 path #t read-src-syntax)))) - (if (null? submodule-path) - ;; allow any result: - (compile-one) - ;; expect a compiled-module result: - (extract-submodule (compile-one)))])) diff --git a/racket/collects/syntax/modread.rkt b/racket/collects/syntax/modread.rkt index b12e27bbca..38e2d27459 100644 --- a/racket/collects/syntax/modread.rkt +++ b/racket/collects/syntax/modread.rkt @@ -1,9 +1,6 @@ (module modread racket/base - (require racket/contract/base) - - (provide with-module-reading-parameterization) - (provide/contract - [check-module-form ((or/c syntax? eof-object?) (or/c symbol? list?) (or/c string? path? false/c) . -> . any)]) + (provide with-module-reading-parameterization + check-module-form) (define (with-module-reading-parameterization thunk) (call-with-default-reading-parameterization @@ -19,6 +16,13 @@ expected-name filename name)) (define (check-module-form exp expected-module filename) + (unless (or (syntax? exp) (eof-object? exp)) + (raise-argument-error 'check-module-form "(or/c syntax? eof-object?)" exp)) + (unless (or (symbol? expected-module) (list? expected-module)) + (raise-argument-error 'check-module-form "(or/c symbol? list?)" list)) + (unless (or (not filename) (path-string? filename)) + (raise-argument-error 'check-module-form "(or/c path-string? false/c)" list)) + (cond [(or (eof-object? exp) (eof-object? (syntax-e exp))) (and filename (error 'load-handler diff --git a/racket/collects/syntax/modresolve.rkt b/racket/collects/syntax/modresolve.rkt index bc98f65ef3..4783deb8fd 100644 --- a/racket/collects/syntax/modresolve.rkt +++ b/racket/collects/syntax/modresolve.rkt @@ -1,132 +1,6 @@ #lang racket/base (require racket/contract/base - racket/path - "private/modhelp.rkt") - -(define (force-relto relto dir? #:path? [path? #t]) - (let ([relto (if (and (pair? relto) - (eq? (car relto) 'submod)) - (cadr relto) - relto)] - [submod (if (and (pair? relto) - (eq? (car relto) 'submod)) - (cddr relto) - null)]) - (cond [(path-string? relto) - (values (and path? - (if dir? - (let-values ([(base n d?) (split-path relto)]) - (when d? - (error 'resolve-module-path-index - "given a directory path instead of a file path: ~e" relto)) - (if (eq? base 'relative) - (or (current-load-relative-directory) (current-directory)) - base)) - relto)) - submod)] - [(pair? relto) (values relto submod)] - [(not dir?) - (values - (and path? - (error 'resolve-module-path-index - "can't resolve \"self\" with non-path relative-to: ~e" relto)) - submod)] - [(procedure? relto) (force-relto (relto) dir? #:path? path?)] - [else (values (and path? (current-directory)) submod)]))) - -(define (path-ss->rkt p) - (if (path-has-extension? p #".ss") - (path-replace-extension p #".rkt") - p)) - -(define (combine-submod v p) - (if (null? p) - v - (list* 'submod v p))) - -(define (flatten base orig-p) - (let loop ([accum '()] [p orig-p]) - (cond - [(null? p) (combine-submod base (reverse accum))] - [(equal? (car p) "..") - (if (null? accum) - (error 'resolve-module-path "too many \"..\"s: ~s" - (combine-submod base orig-p)) - (loop (cdr accum) (cdr p)))] - [else (loop (cons (car p) accum) (cdr p))]))) - -(define (resolve-module-path s [relto #f]) - ;; relto should be a complete path, #f, or procedure that returns a - ;; complete path - (define (get-dir) (force-relto relto #t)) - (cond [(symbol? s) - ;; use resolver handler: - (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join s #f)))] - [(string? s) - ;; Parse Unix-style relative path string - (define-values (dir submod) (get-dir)) - (path-ss->rkt - (apply build-path dir (explode-relpath-string s)))] - [(and (or (not (pair? s)) (not (list? s))) (not (path? s))) - #f] - [(or (path? s) (eq? (car s) 'file)) - (let ([p (if (path? s) s (expand-user-path (cadr s)))]) - (define-values (d submod) (get-dir)) - (path-ss->rkt - (path->complete-path - p - (if (path-string? d) - d - (or (current-load-relative-directory) - (current-directory))))))] - [(or (eq? (car s) 'lib) - (eq? (car s) 'quote) - (eq? (car s) 'planet)) - ;; use resolver handler in this case, too: - (define-values (d submod) (force-relto relto #f #:path? #f)) - (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join s #f)))] - [(eq? (car s) 'submod) - (define r (cond - [(or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - (define-values (d submod) (force-relto relto #f)) - (combine-submod d submod)] - [else (resolve-module-path (cadr s) relto)])) - (define base-submods (if (and (or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - (pair? r)) - (cddr r) - null)) - (define base (if (pair? r) (cadr r) r)) - (flatten base (append base-submods - (if (equal? (cadr s) "..") (cdr s) (cddr s))))] - [else #f])) - -(define (resolve-module-path-index mpi [relto #f]) - ;; relto must be a complete path - (let-values ([(path base) (module-path-index-split mpi)]) - (if path - (resolve-module-path path (resolve-possible-module-path-index base relto)) - (let () - (define sm (module-path-index-submodule mpi)) - (define-values (dir submod) (force-relto relto #f)) - (combine-submod (path-ss->rkt dir) (if (and sm submod) - (append submod sm) - (or sm submod))))))) - -(define (resolve-possible-module-path-index base [relto #f]) - (cond [(module-path-index? base) - (resolve-module-path-index base relto)] - [(and (resolved-module-path? base) - (path? (resolved-module-path-name base))) - (resolved-module-path-name base)] - [relto relto] - [else #f])) - + "private/modresolve-noctc.rkt") (define rel-to-path-string/c (or/c path-string? (cons/c 'submod (cons/c path-string? (listof symbol?))))) diff --git a/racket/collects/syntax/private/modcode-noctc.rkt b/racket/collects/syntax/private/modcode-noctc.rkt new file mode 100644 index 0000000000..ce14c96d56 --- /dev/null +++ b/racket/collects/syntax/private/modcode-noctc.rkt @@ -0,0 +1,266 @@ +#lang racket/base +(require racket/list + racket/path + "../modread.rkt") + +(provide moddep-current-open-input-file + exn:get-module-code + exn:get-module-code? + exn:get-module-code-path + make-exn:get-module-code + + get-module-code + get-module-path + get-metadata-path) + +(define moddep-current-open-input-file + (make-parameter open-input-file)) + +(define (resolve s) + (if (complete-path? s) + s + (let ([d (current-load-relative-directory)]) + (if d (path->complete-path s d) s)))) + +(define (date>=? a bm) + (and a + (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) + (file-or-directory-modify-seconds a))]) + (and am (if bm (>= am bm) #t))))) + +(define (read-one orig-path path src? read-src-syntax) + (define p ((moddep-current-open-input-file) path)) + (when src? (port-count-lines! p)) + (define (reader) + (define-values (base name dir?) (split-path orig-path)) + (define unchecked-v + (with-module-reading-parameterization + (lambda () + ;; In case we're reading a .zo, we need to set + ;; the load-relative directory for unmarshaling + ;; path literals. + (parameterize ([current-load-relative-directory + (if (path? base) base (current-directory))]) + (read-src-syntax path p))))) + (when (eof-object? unchecked-v) + (error 'read-one "empty file; expected a module declaration in: ~a" path)) + (define sym + (string->symbol + (bytes->string/utf-8 (path->bytes (path-replace-extension name #"")) #\?))) + (define checked-v (check-module-form unchecked-v sym path)) + (unless (eof-object? (read p)) + (error 'read-one + "file has more than one expression; expected a module declaration only in: ~a" + path)) + (if (and (syntax? checked-v) (compiled-expression? (syntax-e checked-v))) + (syntax-e checked-v) + checked-v)) + (define (closer) (close-input-port p)) + (dynamic-wind void reader closer)) + +(define-struct (exn:get-module-code exn:fail) (path)) + +(define (reroot-path* base root) + (cond + [(eq? root 'same) base] + [(relative-path? root) (build-path base root)] + [else (reroot-path base root)])) + +;; : (or/c path-string? 'same) -> (or/c path? 'same) +(define (path-string->path ps) + (if (string? ps) (string->path ps) ps)) + +;; : (listof (or/c path-string? 'same)) -> (listof (or/c path? 'same)) +(define (root-strs->roots root-strs) + (map path-string->path root-strs)) + +(define (get-metadata-path + #:roots [root-strs (current-compiled-file-roots)] + base-str . arg-strs) + (define base (path-string->path base-str)) + (define roots (root-strs->roots root-strs)) + (define args (root-strs->roots arg-strs)) + (cond + [(or (equal? roots '(same)) (null? roots)) + (apply build-path base args)] + [else + (or (for/or ([root (in-list (if (null? (cdr roots)) null roots))]) + (define p (apply build-path (reroot-path* base root) args)) + (and (file-exists? p) p)) + (apply build-path (reroot-path* base (car roots)) args))])) + +(define (default-compiled-sub-path) + (let ([l (use-compiled-file-paths)]) + (if (pair? l) + (car l) + "compiled"))) + +(define (get-module-path + path0-str + #:roots [root-strs (current-compiled-file-roots)] + #:submodule? [submodule? #f] + #:sub-path [sub-path/kw (default-compiled-sub-path)] + [sub-path sub-path/kw] + #:choose [choose (lambda (src zo so) #f)] + #:rkt-try-ss? [rkt-try-ss? #t]) + (define path0 (path-string->path path0-str)) + (define roots (root-strs->roots root-strs)) + (define resolved-path (resolve path0)) + (define-values (path0-rel path0-file path0-dir?) (split-path path0)) + (define-values (main-src-file alt-src-file) + (if rkt-try-ss? + (let* ([b (path->bytes path0-file)] + [len (bytes-length b)]) + (cond + [(and (len . >= . 4) (bytes=? #".rkt" (subbytes b (- len 4)))) + ;; .rkt => try .rkt then .ss + (values path0-file + (bytes->path (bytes-append (subbytes b 0 (- len 4)) + #".ss")))] + [else + ;; No search path + (values path0-file #f)])) + (values path0-file #f))) + (define main-src-path + (if (eq? main-src-file path0-file) + resolved-path + (build-path path0-rel main-src-file))) + (define alt-src-path + (and alt-src-file + (if (eq? alt-src-file path0-file) + resolved-path + (build-path path0-rel alt-src-file)))) + (define path0-base (if (eq? path0-rel 'relative) 'same path0-rel)) + (define main-src-date + (file-or-directory-modify-seconds main-src-path #f (lambda () #f))) + (define alt-src-date + (and alt-src-path + (not main-src-date) + (file-or-directory-modify-seconds alt-src-path #f (lambda () #f)))) + (define src-date (or main-src-date alt-src-date)) + (define src-file (if alt-src-date alt-src-file main-src-file)) + (define src-path (if alt-src-date alt-src-path main-src-path)) + (define try-alt? (and alt-src-file (not alt-src-date) (not main-src-date))) + (define (get-so file) + (get-metadata-path #:roots roots + path0-base + sub-path + "native" + (system-library-subpath) + (path-add-extension file (system-type 'so-suffix)))) + (define zo + (get-metadata-path #:roots roots + path0-base + sub-path + (path-add-extension src-file #".zo"))) + (define alt-zo + (and try-alt? + (get-metadata-path #:roots roots + path0-base + sub-path + (path-add-extension alt-src-file #".zo")))) + (define so (get-so src-file)) + (define alt-so (and try-alt? (get-so alt-src-file))) + (define prefer (choose src-path zo so)) + (cond + ;; Use .zo, if it's new enough + [(or (eq? prefer 'zo) + (and (not prefer) + (pair? roots) + (or (date>=? zo src-date) + (and try-alt? + (date>=? alt-zo src-date))))) + (let ([zo (if (date>=? zo src-date) + zo + (if (and try-alt? (date>=? alt-zo src-date)) + alt-zo + zo))]) + (values (simple-form-path zo) 'zo))] + ;; Maybe there's an .so? Use it only if we don't prefer source + ;; and only if there's no submodule path. + [(and (not submodule?) + (or (eq? prefer 'so) + (and (not prefer) + (pair? roots) + (or (date>=? so src-date) + (and try-alt? + (date>=? alt-so src-date)))))) + (let ([so (if (date>=? so src-date) + so + (if (and try-alt? (date>=? alt-so src-date)) + alt-so + so))]) + (values (simple-form-path so) 'so))] + ;; Use source if it exists + [(or (eq? prefer 'src) src-date) + (values (simple-form-path src-path) 'src)] + ;; Report a not-there error + [else (raise (make-exn:get-module-code + (format "get-module-code: no such file: ~e" resolved-path) + (current-continuation-marks) + #f))])) + +(define (get-module-code + path0-str + #:roots [root-strs (current-compiled-file-roots)] + #:submodule-path [submodule-path '()] + #:sub-path [sub-path/kw (default-compiled-sub-path)] + [sub-path sub-path/kw] + #:compile [compile/kw compile] + [compiler compile/kw] + #:extension-handler [ext-handler/kw #f] + [ext-handler ext-handler/kw] + #:choose [choose (lambda (src zo so) #f)] + #:notify [notify void] + #:source-reader [read-src-syntax read-syntax] + #:rkt-try-ss? [rkt-try-ss? #t]) + (define path0 (path-string->path path0-str)) + (define roots (root-strs->roots root-strs)) + (define-values (path type) + (get-module-path + path0 + #:roots roots + #:submodule? (pair? submodule-path) + #:sub-path sub-path + #:choose choose + #:rkt-try-ss? rkt-try-ss?)) + (define (extract-submodule m [sm-path submodule-path]) + (cond + [(null? sm-path) m] + [else + (extract-submodule + (or (for/or ([c (in-list (append (module-compiled-submodules m #t) + (module-compiled-submodules m #f)))]) + (and (eq? (last (module-compiled-name c)) (car sm-path)) + c)) + (raise + (make-exn:get-module-code + (format "get-module-code: cannot find submodule: ~e" sm-path) + (current-continuation-marks) + #f))) + (cdr sm-path))])) + (case type + [(zo) + (notify path) + (extract-submodule (read-one path0 path #f read-syntax))] + [(so) + (if ext-handler + (begin + (notify path) + (ext-handler path #f)) + (raise (make-exn:get-module-code + (format "get-module-code: cannot use extension file; ~e" path) + (current-continuation-marks) + path)))] + [(src) + (notify path) + (define (compile-one) + (define-values (path0-base path0-name path0-dir?) (split-path path0)) + (parameterize ([current-load-relative-directory + (if (path? path0-base) path0-base (current-directory))]) + (compiler (read-one path0 path #t read-src-syntax)))) + (if (null? submodule-path) + ;; allow any result: + (compile-one) + ;; expect a compiled-module result: + (extract-submodule (compile-one)))])) diff --git a/racket/collects/syntax/private/modresolve-noctc.rkt b/racket/collects/syntax/private/modresolve-noctc.rkt new file mode 100644 index 0000000000..087449b001 --- /dev/null +++ b/racket/collects/syntax/private/modresolve-noctc.rkt @@ -0,0 +1,130 @@ +#lang racket/base +(require racket/path + "modhelp.rkt") + +(provide resolve-module-path + resolve-module-path-index) + +(define (force-relto relto dir? #:path? [path? #t]) + (let ([relto (if (and (pair? relto) + (eq? (car relto) 'submod)) + (cadr relto) + relto)] + [submod (if (and (pair? relto) + (eq? (car relto) 'submod)) + (cddr relto) + null)]) + (cond [(path-string? relto) + (values (and path? + (if dir? + (let-values ([(base n d?) (split-path relto)]) + (when d? + (error 'resolve-module-path-index + "given a directory path instead of a file path: ~e" relto)) + (if (eq? base 'relative) + (or (current-load-relative-directory) (current-directory)) + base)) + relto)) + submod)] + [(pair? relto) (values relto submod)] + [(not dir?) + (values + (and path? + (error 'resolve-module-path-index + "can't resolve \"self\" with non-path relative-to: ~e" relto)) + submod)] + [(procedure? relto) (force-relto (relto) dir? #:path? path?)] + [else (values (and path? (current-directory)) submod)]))) + +(define (path-ss->rkt p) + (if (path-has-extension? p #".ss") + (path-replace-extension p #".rkt") + p)) + +(define (combine-submod v p) + (if (null? p) + v + (list* 'submod v p))) + +(define (flatten base orig-p) + (let loop ([accum '()] [p orig-p]) + (cond + [(null? p) (combine-submod base (reverse accum))] + [(equal? (car p) "..") + (if (null? accum) + (error 'resolve-module-path "too many \"..\"s: ~s" + (combine-submod base orig-p)) + (loop (cdr accum) (cdr p)))] + [else (loop (cons (car p) accum) (cdr p))]))) + +(define (resolve-module-path s [relto #f]) + ;; relto should be a complete path, #f, or procedure that returns a + ;; complete path + (define (get-dir) (force-relto relto #t)) + (cond [(symbol? s) + ;; use resolver handler: + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join s #f)))] + [(string? s) + ;; Parse Unix-style relative path string + (define-values (dir submod) (get-dir)) + (path-ss->rkt + (apply build-path dir (explode-relpath-string s)))] + [(and (or (not (pair? s)) (not (list? s))) (not (path? s))) + #f] + [(or (path? s) (eq? (car s) 'file)) + (let ([p (if (path? s) s (expand-user-path (cadr s)))]) + (define-values (d submod) (get-dir)) + (path-ss->rkt + (path->complete-path + p + (if (path-string? d) + d + (or (current-load-relative-directory) + (current-directory))))))] + [(or (eq? (car s) 'lib) + (eq? (car s) 'quote) + (eq? (car s) 'planet)) + ;; use resolver handler in this case, too: + (define-values (d submod) (force-relto relto #f #:path? #f)) + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join s #f)))] + [(eq? (car s) 'submod) + (define r (cond + [(or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + (define-values (d submod) (force-relto relto #f)) + (combine-submod d submod)] + [else (resolve-module-path (cadr s) relto)])) + (define base-submods (if (and (or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + (pair? r)) + (cddr r) + null)) + (define base (if (pair? r) (cadr r) r)) + (flatten base (append base-submods + (if (equal? (cadr s) "..") (cdr s) (cddr s))))] + [else #f])) + +(define (resolve-module-path-index mpi [relto #f]) + ;; relto must be a complete path + (let-values ([(path base) (module-path-index-split mpi)]) + (if path + (resolve-module-path path (resolve-possible-module-path-index base relto)) + (let () + (define sm (module-path-index-submodule mpi)) + (define-values (dir submod) (force-relto relto #f)) + (combine-submod (path-ss->rkt dir) (if (and sm submod) + (append submod sm) + (or sm submod))))))) + +(define (resolve-possible-module-path-index base [relto #f]) + (cond [(module-path-index? base) + (resolve-module-path-index base relto)] + [(and (resolved-module-path? base) + (path? (resolved-module-path-name base))) + (resolved-module-path-name base)] + [relto relto] + [else #f])) diff --git a/racket/src/Makefile.in b/racket/src/Makefile.in index 7870fa0e60..76483c1793 100644 --- a/racket/src/Makefile.in +++ b/racket/src/Makefile.in @@ -248,6 +248,7 @@ install-pdf: clean: cd racket; $(MAKE) clean if [ -d gracket ]; then cd gracket; $(MAKE) clean; fi + rm -rf compiled rm -f TAGS # Reconfigure ---------------------------------------- diff --git a/racket/src/README b/racket/src/README index 65ee3e922b..2738b1e14c 100644 --- a/racket/src/README +++ b/racket/src/README @@ -11,13 +11,25 @@ Windows, Mac OS, or any Unix/X platform (including Linux). Per-platform instructions are below. Please report bugs via one of the following: - - DrRacket's "submit bug report" menu (preferred) + - https://github.com/racket/racket/issues (preferred) + - DrRacket's "submit bug report" menu - http://bugs.racket-lang.org/ - the mailing list (users@racket-lang.org) (last resort) -PLT racket@racket-lang.org +======================================================================== + Traditional Racket versus Racket-on-Chez +======================================================================== + +To build the experimental variant of Racket that runs on Chez Scheme +see "cs/c/README.txt". + +The rest of the instructions below are about building the traditional +Racket implementation, but a general "Implementation Organization" +note at the end applies to both variants. + ======================================================================== Compiling for Windows ======================================================================== @@ -26,15 +38,15 @@ To compile with Microsoft Visual C, read the instructions in "racket\src\worksp\README". To compile with MinGW tools, follow the Unix instructions below; do not -use `--enable-shared', because DLLs will be generated automatically. +use `--enable-shared`, because DLLs will be generated automatically. The result is a Windows-style build. If you are using a variant of MinGW without "libdelayimp.a", get the implementation of "delayimp.c" from MinGW-w64 and compile it to "libdelayimp.a". To compile with Cygwin tools, follow the Unix instructions below. The result is a Unix-style build, not a Windows-style build (e.g., -Racket's `system-type' procedure returns 'unix, not 'windows, and -`racket/gui' uses Gtk instead of Win32). +Racket's `system-type` procedure returns 'unix, not 'windows, and +`racket/gui` uses Gtk instead of Win32). ======================================================================== Compiling for Mac OS @@ -49,37 +61,37 @@ After installing developer tools, follow the Unix instructions below, but note the following: * The Racket build creates a framework, "Racket.framework", which is - installed into "racket/lib". This framework is used by the `racket' + installed into "racket/lib". This framework is used by the `racket` executable that goes into "racket/bin". * The GRacket build creates a GUI-executable variant of the Racket executable. The GRacket build process also downloads (from github) pre-built libraries for Cairo, Pango, etc. - * The `--enable-shared' flag for `configure' must not be used, because + * The `--enable-shared` flag for `configure` must not be used, because builds create and use frameworks by default. Furthermore, - `--disable-shared' is not supported. (Unless you use - `--enable-xonx'...) + `--disable-shared` is not supported. (Unless you use + `--enable-xonx`...) - * To build an X11- and Gtk-based GRacket, run `configure' with the - `--enable-xonx' flag. Frameworks are not used for such builds, so - `--enable-shared' is allowed. The `--enable-xonx' flag also affects - the Racket build, so that `system-type' reports 'unix. Pre-built + * To build an X11- and Gtk-based GRacket, run `configure` with the + `--enable-xonx` flag. Frameworks are not used for such builds, so + `--enable-shared` is allowed. The `--enable-xonx` flag also affects + the Racket build, so that `system-type` reports 'unix. Pre-built libraries are not downloaded in this mode; you must have Cairo, Pango, and GTk installed. - * To use `--prefix' without `--enable-xonx', you must also supply - `--enable-macprefix'. BEWARE! The directory structure for a + * To use `--prefix` without `--enable-xonx`, you must also supply + `--enable-macprefix`. BEWARE! The directory structure for a non-xonx build does not fit a typical Unix directory structure. For example, frameworks are written directly to a "lib" subdirectory, and executables like "GRacket.app" are written directly to the prefix - directory. (Requiring `--enable-macprefix' with `--prefix' for a + directory. (Requiring `--enable-macprefix` with `--prefix` for a non-xonx build helps prevent accidental installation of a Mac-style directory structure on top of an existing Unix-style directory structure.) * Under Mac OS 10.6 and later, to build Racket in 32-bit mode, - use `--disable-mac64'. + use `--disable-mac64`. ======================================================================== Compiling for supported Unix variants (including Linux) or Cygwin/MinGW @@ -87,7 +99,7 @@ but note the following: Quick instructions: - From this directory (where the `configure' file is), run the following + From this directory (where the `configure` file is), run the following commands: mkdir build @@ -96,12 +108,12 @@ Quick instructions: make make install - This will create an in-place installation of Racket and store the - results of C compilation in a separate "build" subdirectory, which - is useful if you need to update your sources, delete the build, and - start from scratch. + Those commands will create an in-place installation of Racket and + store the results of C compilation in a separate "build" + subdirectory, which is useful if you need to update your sources, + delete the build, and start from scratch. - You can also run the typical `./configure && make && make install' if + You can also run the typical `./configure && make && make install` if you don't anticipate updating/rebuilding, but it will be harder to restart from scratch should you need to. @@ -111,31 +123,31 @@ Detailed instructions: remove it (unless you are using an "in-place" build from a repository as described below). - To run `racket/draw' and `racket/gui' programs, you will need - Cairo, Pango, and GTk install. These libraries are not + To run `racket/draw` and `racket/gui` programs, you will need + Cairo, Pango, and GTk installed. These libraries are not distributed with Racket, and they are not needed for compilation, - except for building documentation that uses `racket/draw'. More + except for building documentation that uses `racket/draw`. More info about required libs is available at http://docs.racket-lang.org/draw/libs.html and http://docs.racket-lang.org/gui/libs.html. - The content of the "foreign" subdirectory may require GNU `make' + The content of the "foreign" subdirectory may require GNU `make` if no installed "libffi" is detected. If the build fails with - another variant of `make', please try using GNU `make'. + another variant of `make`, please try using GNU `make`. 1. Select (or create) a build directory. It's better to run the build in a directory other than the one - containing `configure', especially if you're getting sources via + containing `configure`, especially if you're getting sources via git. A common way to start a git-based build is: cd [here] mkdir build cd build - where "[here]" is the directory containing this `README' file and - the `configure' script. The git repository is configured to support - this convention by ignoring `build' in this directory. + where "[here]" is the directory containing this `README` file and + the `configure` script. The git repository is configured to support + this convention by ignoring `build` in this directory. A separate build directory is better in case the Makefile organization changes, or in case the Makefiles lack some @@ -143,40 +155,40 @@ Detailed instructions: you can just delete and re-create "build" without mangling your source tree. - 2. From your build directory, run the script `configure' (which is in + 2. From your build directory, run the script `configure` (which is in the same directory as this README), with optional command-line - arguments `--prefix=TARGETDIR' or `--enable-shared' (or both). + arguments `--prefix=TARGETDIR` or `--enable-shared` (or both). For example, if you want to install into "/usr/local/racket" using dynamic libraries, then run: [here]configure --prefix=/usr/local/racket --enable-shared - Again, "[here]" is the directory path containing the `configure' + Again, "[here]" is the directory path containing the `configure` script. If you follow the convention of running from a "build" subdirectory, "[here]" is just "../". If you build from the current directory, "[here]" is possibly unnecessary, or possibly just "./", depending on your shell and PATH setting. - If the `--prefix' flag is omitted, the binaries are built for an + If the `--prefix` flag is omitted, the binaries are built for an in-place installation (i.e., the parent of the directory containing - this README will be used directly). Unless `--enable-shared' is + this README will be used directly). Unless `--enable-shared` is used, the "racket" directory can be moved later; most system - administrators would recommend that you use `--enable-shared', but + administrators would recommend that you use `--enable-shared`, but the Racket developers distribute binaries built without - `--enable-shared'. + `--enable-shared`. - The `configure' script generates the makefiles for building Racket - and/or GRacket. The current directory at the time `configure' is + The `configure` script generates the makefiles for building Racket + and/or GRacket. The current directory at the time `configure` is run will be used as working space for building the executables - (independent of `--prefix'). This build directory does not have to + (independent of `--prefix`). This build directory does not have to be in the source tree, even for an in-place build. It's ok to run - `configure' from its own directory (as in the first example above), + `configure` from its own directory (as in the first example above), but it's better to pick a separate build directory that is otherwise empty (as in the second example). - The `configure' script accepts many other flags that adjust the - build process. Run `configure --help' for more information. In + The `configure` script accepts many other flags that adjust the + build process. Run `configure --help` for more information. In addition, a specific compiler can be selected through environment variables. For example, to select the SGI compilers for Irix instead of gcc, run configure as @@ -188,89 +200,91 @@ Detailed instructions: which includes C compilation, and the Racket build normally uses the C pre-processor directly for some parts of the build. - If you re-run `configure' after running `make', then products of the - `make' may be incorrect due to changes in the compiler command line. - To be safe, run `make clean' each time after running `configure'. - To be even safer, run `configure' in a fresh build directory every + If you re-run `configure` after running `make`, then products of the + `make` may be incorrect due to changes in the compiler command line. + To be safe, run `make clean' each time after running `configure`. + To be even safer, run `configure` in a fresh build directory every time. When building for multiple platforms or configurations out of the - same source directory, beware of cached `configure' information in + same source directory, beware of cached `configure` information in "config.cache". Avoid this problem entirely by using a separate build directory (but the same source) for each platform or configuration. - 3. Run `make'. [As noted in step 0, this must be GNU `make'.] + 3. Run `make`. [As noted in step 0, this might need to be GNU `make`.] - With Cygwin, you may need to use `make --unix'. + With Cygwin, you may need to use `make --unix`. Binaries and libraries are placed in subdirectories of the build - directory. For example, the `racket3m' binary appears in the + directory. For example, the `racket3m` binary appears in the "racket" directory. - 4. Run `make install'. + 4. Run `make install`. This step copies binaries and libraries into place within the target installation. For example, the "racket" binary is copied into the "bin" directory for an in-place build, or into the executable - directory for a --prefix build. + directory for a `--prefix` build. - For a `--prefix' build, this step also creates a "config.rkt" module - in a "config" collection, so that various Racket tools and libraries + For a `--prefix` build, this step also creates a "config.rktd" module + in an "etc" directory, so that various Racket tools and libraries can find the installation directories. At this stage, in case you are packaging an installation instead of installing directly, you can redirect the installation by setting the "DESTDIR" environment variable to an absolute path for the packaging area. For example, - `make DESTDIR=/tmp/racket-build install' places the installation + `make DESTDIR=/tmp/racket-build install` places the installation into "/tmp/racket-build" instead of the location originally - specified with `--prefix'. The resulting installation will not + specified with `--prefix`. The resulting installation will not work, however, until it is moved to the location originally - specified with `--prefix'. + specified with `--prefix`. - Finally, the `make install' step compiles ".zo" bytecode files for - installed Racket source, generates launcher programs like - DrRacket, and builds documentation. Use `make plain-install' to - install without compiling ".zo" files, creating launchers, or - building documentation. + Finally, the `make install` step compiles ".zo" bytecode files for + installed Racket source, generates launcher programs like DrRacket + (if it's already installed as a package), and builds documentation + (again, if installed). Use `make plain-install` to install without + compiling ".zo" files, creating launchers, or building + documentation. If the installation fails because the target directory cannot be created, or because the target directory is not the one you want, - then you can try repeating step 4 after running `configure' again - with a new `--prefix' value. That is, sometimes it is not necessary + then you can try repeating step 4 after running `configure` again + with a new `--prefix` value. That is, sometimes it is not necessary to repeat step 3 (so try it and find out). On other platforms and configurations, it is necessary to start with a clean build - directory when changing the `--prefix' value, because the path gets + directory when changing the `--prefix` value, because the path gets wired into shared objects. If you build frequently from the git-based sources, beware that you may accumulate user- and version-specific information in your "add-ons" directory, which you can most easily find by evaluating (find-system-path 'addon-dir) - in Racket. In addition, if you configure with `--enabled-shared', + in Racket. In addition, if you configure with `--enabled-shared`, you may accumulate many unused versions of the dynamic libraries in your installation target. -After an "in-place" install without git, the "racket/src" directory is -no longer needed, and it can be safely deleted. Build information is -recorded in a "buildinfo" file in the installation. +After an "in-place" install from a source distribution, the +"racket/src" directory is no longer needed, and it can be safely +deleted. Build information is recorded in a "buildinfo" file in the +installation. -For a build without `--prefix' (or with `--enable-origtree') and without -`--enable-shared', you can safely move the install tree, because all +For a build without `--prefix` (or with `--enable-origtree`) and without +`--enable-shared`, you can safely move the install tree, because all file references within the installation are relative. ======================================================================== Cross-compiling ======================================================================== -Cross-compilation requires at least two flags to `configure': +Cross-compilation requires at least two flags to `configure`: - * `--host=OS', where OS is something like `i386-gnu-linux' to + * `--host=OS`, where OS is something like `i386-gnu-linux` to indicate the target platform. - The `configure' script uses OS to find suitable compilation tools, - such as `OS-gcc' and `OS-strip'. + The `configure` script uses OS to find suitable compilation tools, + such as `OS-gcc` and `OS-strip`. - * `--enable-racket=RACKET', where RACKET is a path to a Racket + * `--enable-racket=RACKET`, where RACKET is a path to a Racket executable that runs on the build platform; the executable must be the same version of Racket as being built for the target platform. @@ -282,11 +296,16 @@ Cross-compilation requires at least two flags to `configure': will run `configure` again (with no arguments) in a "local" subdirectory to create a build for the current platform. -Some less commonly needed `configure' flags: +Some less commonly needed `configure` flags: - * `--enable-stackup', if the target platform's stack grows up. + * `--enable-stackup`, if the target platform`s stack grows up. - * `--enable-bigendian', if target platform is big-endian. + * `--enable-bigendian`, if target platform is big-endian. + + * `--enable-cify` or `--disable-cify` if the JIT availablity on the + target platform is different than the build platform; use + `--enable-cify` if the JIT is not abailable on the target + platform. ======================================================================== Cross-compiling for Android @@ -304,7 +323,7 @@ of Android (such as 14), and [ndk]/toolchains/arm-linux-androideabi-[comp]/prebuilt/[platform]/bin -is in your PATH (so that a suitable `gcc', `ar', etc., are found) for +is in your PATH (so that a suitable `gcc`, `ar`, etc., are found) for the [comp] of your choice and the [platform] used to compile. ======================================================================== @@ -335,22 +354,22 @@ becomes the path (all on one line) CGC versus 3m ======================================================================== -Racket and GRacket have two variants: CGC and 3m. The CGC variant is -older, and it cooperates more easily with extensions written in C. The -3m variant is the default: it is more robust and usually provides better -overall performance. +Traditional Racket and GRacket have two variants: CGC and 3m. The CGC +variant is older, and it cooperates more easily with extensions +written in C. The 3m variant is the default: it is more robust and +usually provides better overall performance. The default build mode creates 3m binaries only (except for a CGC binary that is used to build the 3m binary). To create CGC binaries -in addition, run `make cgc' in addition to `make', or run `make both'. -To install both variants, use `make install-both' instead of just -`make install'. Alternately, use just `make cgc' and `make -install-cgc' to build and install just the CGC variants. +in addition, run `make cgc` in addition to `make`, or run `make both`. +To install both variants, use `make install-both` instead of just +`make install`. Alternately, use just `make cgc` and `make +install-cgc` to build and install just the CGC variants. CGC variants are installed with a "cgc" suffix. To swap the default -build and install mode, supply `--enable-cgcdefault' to `configure'. In -that case, CGC variants are built by default, `make 3m' creates 3m -binaries, and `make install-both' installs CGC variants without a suffix +build and install mode, supply `--enable-cgcdefault` to `configure`. In +that case, CGC variants are built by default, `make 3m` creates 3m +binaries, and `make install-both` installs CGC variants without a suffix and 3m variants with a "3m" suffix. ======================================================================== @@ -370,7 +389,7 @@ list of paths must end with an additional NUL terminator, and the overall list must be less than 1024 bytes long. As an alternative to editing an executable directly, the -`create-embedding-executable' procedure from `compiler/embed' can be +`create-embedding-executable` procedure from `compiler/embed` can be used to change the embedded path. For example, the following program clones the Racket executable to "/tmp/mz" and changes the embedded path in the clone to "/tmp/collects": @@ -378,7 +397,7 @@ in the clone to "/tmp/collects": (require compiler/embed) (create-embedding-executable "/tmp/mz" #:collects-path "/tmp/collects") -Similarly, `raco exe' mode accepts a `--collects' flag to set the +Similarly, `raco exe` mode accepts a `--collects` flag to set the collection path in the generated executable. Under Windows, executables also embed a path to DLLs. For more @@ -425,7 +444,7 @@ Pre-processor tests in "sconfig.h" and "scheme.h" attempt to determine when the x87 floating-point processor needs to be configured for double-precision mode, when JIT can use SSE2 instructions, and when extflonums can be supported because both the JIT and C code use SSE2 -for double-precision floating-point while `long double' is available +for double-precision floating-point while `long double` is available for extflonums. In particular, "scheme.h" looks for __SSE2_MATH__ to indicate that gcc @@ -435,12 +454,12 @@ CFLAGS. See related configuration options below. The Windows build using MSVC enables extflonum support through a MinGW-compiled "longdouble.dll", since MSVC does not support `long -double' as extended-precision floating point. +double` as extended-precision floating point. Configuration Options --------------------- -Although `configure' flags control most options, some configurations +Although `configure` flags control most options, some configurations options can be modified by setting flags in "racket/sconfig.h". Some CPP flags control default settings in "racket/sconfig.h": @@ -451,12 +470,101 @@ Some CPP flags control default settings in "racket/sconfig.h": Racket thread scheduling. * C_COMPILER_USES_SSE - declares that the C compiler is using SSE2 - instructions to implement `double' floating-point operations. + instructions to implement `double` floating-point operations. Modifying Racket ---------------- If you modify Racket and change any primitive syntax or the collection -of built-in identifiers, be sure to turn off USE_COMPILED_STARTUP in -"schminc.h"; otherwise, Racket won't start. See "schminc.h" for -details. +of built-in identifiers, be sure to update the version number in +"racket/src/schvers.h", so that various tools know to rebuild +bytecode. If you add or remove primitives, you'll also need to adjust +the counter in "racket/src/schminc.h" . + +======================================================================== + Implementation Organization +======================================================================== + +Everything in this "src" directory contributes to the implementation +of the `racket` executable (and variants), while "../collects" +contains the additional Racket libraries that are included in a +minimal Racket distribution. + +Directories in "src": + + "racket" --- starting point for the traditional Racket implementation + + This implementation can build from "scratch" with a C + compiler, but first by building a CGC variant of Racket to + transform the C sourses to build a (normal) 3m variant. + + "cs" --- starting point for the Racket-on-Chez implementation + + Building the implementation requires both an existing Racket + (possibly created from the "racket" sources) and an existing + Chez Scheme build. + + "rktio" --- portability layer for low-level I/O, used by "racket" and + "cs" + + If you change "rktio.h", then be sure to regenerate + "rktio.rktl" and "rktio.inc" using an existing Racket + implementation that has the "parser-tools" package installed. + + "start" --- main-executable wrapper, used by "racket" and "cs" + + "foreign" --- the FFI implementation for "racket", including "libffi" + (as needed for some platforms) + + "expander" --- the macro expander implementation, used by "racket" + and "cs"; doubles as the "expander" package + + This expander is both included in Racket builds and used to + expand itself for including in "racket" or "cs". It's also + used to expand other libraries included in "cs". + + If you change the expander, run `make` in its directory to + generate the "startup.inc" file that holds the expander's + implementation for inclusion in the traditional Racket + variant. The "cs" build (which needs an existing Racket to + build, anyway) picks up changes automatically. + + "thread" --- the thread scheduler implementation, used by "cs" + + "io" --- the I/O implementation, used by "cs" + + "regexp" --- the regexp matcher implementation, used by "cs" + + "schemify" --- a Racket-to-Scheme compiler, used by "cs" and "cify" + + Similar to "expander", this layer is applied to itself and + other libraries for inclusion in "cs". + + "cify" --- a Racket-to-C compiler, used by "racket" + + This compiler is used only when embedding the expander as C + code, instead of Racket bytecode, which is the default for + platforms where the Racket JIT is not supported. + + "common" --- Racket libraries used by "thread", "io", etc. + + "gracket" --- implementation of the GRacket layer for the traditional + Racket implementation + + "mzcom" --- implementation of the MzCOM layer (for Windows)for the + traditional Racket implementation + + "mysink" --- `ffi/unsafe/com` helper DLL implementation (for Windows) + + "mac" --- scripts for Mac OS ".app"s, used by "gracket" and "cs" + + "worksp" --- Windows projects and build scripts for "racket" and "cs" + + "native-libs" --- build scripts for some native-library packages + + "lt" --- libtool/configure support + + "utils" --- miscellaneous + + "setup-go.rkt" --- helper script used by parts of the build that need + to run substantial Racket programs diff --git a/racket/src/cify/README.txt b/racket/src/cify/README.txt new file mode 100644 index 0000000000..137c7acfda --- /dev/null +++ b/racket/src/cify/README.txt @@ -0,0 +1,47 @@ +The "cify" compiler takes a linklet with no imports as produced by +"schemify" and compiles it to C code suitable for including as part of +the Racket virtual machine's implementation. + +The schmeify compiler is lightly customized by a `for-cify?` flag to +make it produce output friendlier for cify. In cify mode, schemify +avoids obscuring structure-type creation, and it lifts all constants +to the top. + +Compilation by cify is UNSAFE. For example: + + * cify assumes that `car` is applied to a pair, `vector-ref` is + applied to a vector with an in-bounds argument, a struct selector + is applied to an instance of the struct, and so on. + + * cify assumes that a variable is not referenced before its + defintion. + + * cify assumes that a function defined within the linklet is called + within the linklet with the right number of arguments. + +The cify pass relies on the schemify pass lift functions to avoid +closure allocation whenevr possible. The schemify pass also performs +some basic inlining, constant propoagation, and compy propagation --- +but it's designed to defer significantly to the back end to perform +more of that. So, cify includes some copy propagation support, +especially for bindings that are outside of any `lambda` form. +(There's not much extra inling, so that's a direction for +improvement.) + +When a function A tail-calls a known function B, cify generates a +single "vehicle" C function to hold A and B, so the tail cal can be +implemented as a `goto`. The same vehicle holds anything else that +tail-calls A and B or any other function that A or B tail-calls. That +strategy can generate a big function. For tail cals to unknown +functions or non-immediate primitives, cify uses the Racket virtual +machine's protocol for trampolined tail calls. + +The output of cify uses the same Racket-value stack (internally called +"runstack") as the virtual machine's bytecode interpreter and JIT. +Along the same lines as the bytecode compiler, cify must determine the +liveness of a binding and clear the stack slot of any dead variable +before a potential GC. If a value's lifetime doesn't span a GC +boundary, then cify tries to keep it in a C variable (so the C +compiler can allocate it to a register, etc.). Most of cify's +complexity is to put variables in the right place and take advantage +of global runstack invariants to minimize value shuffling. diff --git a/racket/src/cify/arg.rkt b/racket/src/cify/arg.rkt new file mode 100644 index 0000000000..88e60ff6de --- /dev/null +++ b/racket/src/cify/arg.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require "match.rkt") + +(provide add-args + extract-rest-arg + lambda-arity + lambda-no-rest-args? + args-length + compatible-args?) + +(define (add-args env ids) + (cond + [(null? ids) env] + [(symbol? ids) (hash-set env ids #t)] + [else (add-args (hash-set env (car ids) #t) + (cdr ids))])) + +(define (extract-rest-arg ids) + (if (pair? ids) + (extract-rest-arg (cdr ids)) + ids)) + +(define (lambda-arity e #:precise-cases? [precise-cases? #f]) + (match e + [`(lambda ,ids . ,_) + (define min-a (args-length ids)) + (if (list? ids) + (values min-a min-a) + (values min-a -1))] + [`(case-lambda [,unsorted-idss . ,_] ...) + (cond + [precise-cases? + ;; Get full arity to record for arity reporting + (define idss unsorted-idss) + (values (- (+ (length idss) 1)) + (substring + (format "~s" + (apply bytes-append + ;; Encode individual arities as pairs of little-endian `int`s: + (for/list ([ids (in-list idss)]) + (define-values (min-a max-a) (lambda-arity `(lambda ,ids))) + (bytes-append (integer->integer-bytes min-a 4 #t #f) + (integer->integer-bytes max-a 4 #t #f))))) + 1))] + [else + ;; Get approximate arity for predictions about calls + (define idss (sort unsorted-idss < #:key args-length)) + (define-values (min-a max-a) (lambda-arity `(lambda ,(car idss)))) + (let loop ([min-a min-a] [max-a max-a] [idss (cdr idss)]) + (cond + [(null? idss) (values min-a max-a)] + [else + (define-values (new-min-a new-max-a) (lambda-arity `(lambda ,(car idss)))) + (loop (min min-a new-min-a) + (if (or (= max-a -1) (= new-max-a -1)) + -1 + (max max-a new-max-a)) + (cdr idss))]))])])) + +(define (lambda-no-rest-args? e) + (match e + [`(lambda ,ids . ,_) (list? ids)] + [`(case-lambda [,idss . ,_] ...) + (for/and ([ids (in-list idss)]) + (list? ids))])) + +(define (args-length ids) + (if (pair? ids) (add1 (args-length (cdr ids))) 0)) + +(define (compatible-args? n e) + (match e + [`(lambda ,ids . ,_) (= n (args-length ids))] + [`(case-lambda [,idss . ,_] ...) + (for/or ([ids (in-list idss)]) + (= n (args-length ids)))])) diff --git a/racket/src/cify/debug.rkt b/racket/src/cify/debug.rkt new file mode 100644 index 0000000000..38cff0ba7c --- /dev/null +++ b/racket/src/cify/debug.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide current-debug) + +;; Insert debugging checks? +(define current-debug (make-parameter #f)) + diff --git a/racket/src/cify/free-var.rkt b/racket/src/cify/free-var.rkt new file mode 100644 index 0000000000..76459b34cb --- /dev/null +++ b/racket/src/cify/free-var.rkt @@ -0,0 +1,90 @@ +#lang racket/base +(require "match.rkt" + "vehicle.rkt" + "function.rkt" + "ref.rkt" + "sort.rkt" + "arg.rkt") + +(provide get-free-vars) + +(define (get-free-vars e env lambdas knowns top-names state) + (define lam (hash-ref lambdas e)) + (or (lam-free-var-refs lam) + (let ([vars (extract-lambda-free-vars #hasheq() e env lambdas knowns top-names state)]) + (define free-vars (for/list ([var (in-sorted-hash-keys vars symbol~a" (cify (vehicle-id vehicle)))) + (vehicle-max-runstack-depth vehicle)) + (out-close!) + (out-open "if (c_argv == c_orig_runstack)") + (out "c_runbase = c_argv + c_argc;") + (out-close+open "else") + (out "c_runbase = c_orig_runstack;") + (out-close!)) + (cond + [multi? + (out-open "switch(SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(c_self)[0])) {") + (out "default:") + (for ([lam (in-list lams)] + [i (in-naturals)]) + (out-open "case ~a:" i) + (when (lam-no-rest-args? lam) + (ensure-lambda-args-in-place leaf? lam)) + (out "goto c_entry_~a;" (cify (lam-id lam))) + (out-close!)) + (out-close "}")] + [else + (when (lam-no-rest-args? (car lams)) + (ensure-lambda-args-in-place leaf? (car lams)))]) + (for ([lam (in-list lams)]) + (when (or multi? (lam-need-entry? lam)) + (out-margin "c_entry_~a:" (cify (lam-id lam)))) + (generate-lambda lam multi? leaf? (or multi? overflow-check?))) + (out-close "}")) + + (define (generate-lambda lam multi? leaf? bracket?) + (define e (lam-e lam)) + (define id (lam-id lam)) + (define free-var-refs (lam-free-var-refs lam)) + (define closure-offset (if multi? 1 0)) + (when bracket? (out-open "{")) + (match e + [`(lambda . ,_) (generate-lambda-case lam leaf? e free-var-refs closure-offset)] + [`(case-lambda [,idss . ,bodys] ...) + (for ([ids (in-list idss)] + [body (in-list bodys)] + [i (in-naturals)]) + (out-open "~aif (c_argc ~a ~a) {" (if (zero? i) "" "else ") (if (list? ids) "==" ">=") (args-length ids)) + (generate-lambda-case lam leaf? `(lambda ,ids . ,body) free-var-refs closure-offset) + (out-close "}")) + (out "else return c_wrong_arity(~s, c_argc, c_argv);" (format "~a" id))]) + (when bracket? (out-close "}"))) + + ;; Returns a boolean indicating whether the functon can be a leaf + (define (generate-lambda-case lam leaf? e free-var-refs closure-offset) + (define name (lam-id lam)) + (match e + [`(lambda ,ids . ,body) + (define n (args-length ids)) + (when (not (lam-no-rest-args? lam)) + (define rest-arg? (not (list? ids))) + (ensure-args-in-place leaf? n free-var-refs + #:rest-arg? rest-arg? + #:rest-arg-used? (and rest-arg? (referenced? (hash-ref state (extract-rest-arg ids) #f))))) + (unless (null? ids) (out-open "{")) + (when (and leaf? (for/or ([id (in-list ids)]) + (referenced? (hash-ref state id #f)))) + (out "Scheme_Object **c_runbase = c_argv + ~a;" n)) + ;; At this point, for a non-leaf, runstack == runbase - argument-count (including rest) + (define runstack (make-runstack state)) + (define pushed-arg-count + (let loop ([ids ids]) + (cond + [(null? ids) 0] + [(symbol? ids) (loop (list ids))] + [else + ;; Push last first: + (define count (add1 (loop (cdr ids)))) + (runstack-push! runstack (car ids) #:referenced? (referenced? (hash-ref state (car ids) #f))) + count]))) + (runstack-synced! runstack) ; since runstack = start of arguments + ;; Unpack closure + (for ([ref (in-list free-var-refs)]) + (runstack-push! runstack (ref-id ref) #:local? leaf?)) + (for ([ref (in-list free-var-refs)] + [i (in-naturals)]) + (define id (ref-id ref)) + (out "~a = SCHEME_PRIM_CLOSURE_ELS(c_self)[~a];" (runstack-assign runstack id) (+ closure-offset i))) + (when (hash-ref (lam-loop-targets lam) n #f) + (out-margin "c_recur_~a_~a:" (cify name) n)) + (clear-unused-ids ids runstack state) + (box-mutable-ids ids runstack lam state top-names) + (generate (tail-return name lam ids leaf?) `(begin . ,body) lam (add-args (lam-env lam) ids) runstack + knowns top-names state lambdas prim-names prim-knowns) + (runstack-pop! runstack pushed-arg-count) + (unless (null? ids) (out-close "}")) + (let ([vehicle (lam-vehicle lam)]) + (set-vehicle-max-runstack-depth! vehicle (max (runstack-max-depth runstack) + (vehicle-max-runstack-depth vehicle)))) + (set-lam-can-leaf?! lam (not (runstack-ever-synced? runstack)))])) + + (for ([vehicle (in-list vehicles)]) + (generate-vehicle vehicle))) + +(define (lam-constant-args-count? lam) + (match (lam-e lam) + [`(lambda (,_ ...) . ,_) #t] + [`,_ #f])) + +(define (lam-no-rest-args? lam) + (match (lam-e lam) + [`(lambda (,_ ...) . ,_) #t] + [`(case-lambda [(,_ ...) . ,_] ...) #t] + [`,_ #f])) + +;; Only used when no rest args: +(define (ensure-lambda-args-in-place leaf? lam) + (match (lam-e lam) + [`(lambda ,ids . ,_) + (ensure-args-in-place leaf? (length ids) #:rest-arg? #f (lam-free-var-refs lam))] + [`,_ + (ensure-args-in-place leaf? "c_argc" #:rest-arg? #f (lam-free-var-refs lam))])) + +(define (ensure-args-in-place leaf? expected-n free-var-refs + #:rest-arg? rest-arg? + #:rest-arg-used? [rest-arg-used? #t]) + ;; Generate code to make sure that `c_runbase` minus the number of + ;; argument variables (including a "rest" args) holds arguments, + ;; converting "rest" args to a list as needed. We don't need to + ;; perform this check (or set `c_argv` and `c_argc`) for a call + ;; within a vehicle for a non-`case-lambda`, because it will + ;; definitely hold then. + (unless leaf? + (cond + [rest-arg? + (out "~ac_ensure_args_in_place_rest(c_argc, c_argv, c_runbase, ~a, 1, ~a, ~a);" + (if (null? free-var-refs) "(void)" "c_self = ") + expected-n + (if rest-arg-used? "c_rest_arg_used" "c_rest_arg_unused") + (if (null? free-var-refs) "NULL" "c_self"))] + [(eqv? 0 expected-n) + ;; No args; we can always assume that 0 arguments are at `_runbase` + (void)] + [else + ;; No rest arg + (out "c_ensure_args_in_place(~a, c_argv, c_runbase);" expected-n)]))) + +(define (box-mutable-ids ids runstack in-lam state top-names) + (let loop ([ids ids]) + (unless (null? ids) + (cond + [(symbol? ids) (loop (list ids))] + [else + (when (and (mutated? (hash-ref state (car ids) #f)) + (not (hash-ref top-names (car ids) #f))) + (define s (let ([id (car ids)]) + (if (hash-ref top-names id #f) + (format "~a =" (top-ref in-lam id)) + (runstack-assign runstack id)))) + (runstack-sync! runstack) + (out "~a = scheme_box_variable(~a);" s s)) + (loop (cdr ids))])))) + +(define (clear-unused-ids ids runstack state) + (let loop ([ids ids]) + (unless (null? ids) + (cond + [(symbol? ids) (loop (list ids))] + [else + (define id (car ids)) + (when (and (not (referenced? (hash-ref state id #f))) + (not (state-implicitly-referenced? state id))) + (runstack-stage-clear! runstack id state)) + (loop (cdr ids))])))) + +;; ---------------------------------------- + +(define (generate ret e in-lam env runstack knowns top-names state lambdas prim-names prim-knowns) + (define (generate ret e env) + (match e + [`(quote ,v) + (generate-quote ret v)] + [`(lambda . ,_) + (generate-closure ret e env)] + [`(case-lambda . ,_) + (generate-closure ret e env)] + [`(begin ,e) + (generate ret e env)] + [`(begin ,e . ,r) + (generate (multiple-return "") e env) + (generate ret `(begin . ,r) env)] + [`(begin0 ,e . ,r) + (define vals-id (genid 'c_vals)) + (out-open "{") + (runstack-push! runstack vals-id) + (out "int ~a_count;" vals-id) + (generate (multiple-return (lambda (s) + (out "~a = ~a;" (runstack-assign runstack vals-id) s) + (out-open "if (~a == SCHEME_MULTIPLE_VALUES) {" (runstack-ref runstack vals-id #:values-ok? #t)) + (out "Scheme_Object **~a_vals;" vals-id) + (out "~a_vals = c_current_thread->ku.multiple.array;" vals-id) + (out "~a_count = c_current_thread->ku.multiple.count;" vals-id) + (out "if (SAME_OBJ(~a_vals, c_current_thread->values_buffer))" vals-id) + (out " c_current_thread->values_buffer = NULL;") + (out "~a = (Scheme_Object *)~a_vals;" (runstack-assign runstack vals-id) vals-id) + (out-close+open "} else") + (out "~a_count = 1;" vals-id) + (out-close!))) + e env) + (generate (multiple-return "") `(begin . ,r) env) + (out-open "if (~a_count != 1)" vals-id) + (return ret runstack #:can-omit? #t + (format "scheme_values(~a_count, (Scheme_Object **)~a)" vals-id (runstack-ref runstack vals-id))) + (out-close+open "else") + (return ret runstack #:can-omit? #t #:can-pre-pop? #t + (runstack-ref runstack vals-id)) + (out-close!) + (runstack-pop! runstack) + (out-close "}")] + [`(if ,orig-tst ,thn ,els) + (define-values (tsts sync-for-gc? wrapper) (extract-inline-predicate orig-tst in-lam knowns #:compose? #t)) + (define tst-ids (for/list ([tst (in-list tsts)]) + (if (simple? tst in-lam state knowns) + #f + (genid 'c_if)))) + (define all-simple? (for/and ([tst-id (in-list tst-ids)]) + (not tst-id))) + ;; The last `tst-id` doesn't need to be on the runstack + (define immediate-tst-id (for/fold ([id #f]) ([tst-id (in-list tst-ids)]) + (or tst-id id))) + (unless all-simple? (out-open "{")) + (define tst-id-count + (for/sum ([tst-id (in-list tst-ids)] + #:when (and tst-id (not (eq? tst-id immediate-tst-id)))) + (runstack-push! runstack tst-id) + 1)) + (when immediate-tst-id + (out "Scheme_Object *~a;" (cify immediate-tst-id))) + (for ([tst-id (in-list tst-ids)] + [tst (in-list tsts)] + #:when tst-id) + (generate (if (eq? tst-id immediate-tst-id) + (format "~a =" (cify tst-id)) + (make-runstack-assign runstack tst-id)) + tst env)) + (when sync-for-gc? + (runstack-sync! runstack)) + (call-with-simple-shared + (cons 'begin (for/list ([tst-id (in-list tst-ids)] + [tst (in-list tsts)] + #:when (not tst-id)) + tst)) + runstack state + (lambda (shared) + (out-open "if (~a) {" + (wrapper (apply string-append + (add-between + (for/list ([tst-id (in-list tst-ids)] + [tst (in-list tsts)]) + (format "~a" + (cond + [(not tst-id) (generate-simple tst shared env runstack in-lam state top-names knowns prim-names)] + [(eq? tst-id immediate-tst-id) (cify tst-id)] + [tst-id (runstack-ref runstack tst-id)]))) + ", ")))) + (define-values (thn-refs els-refs) (let ([p (hash-ref state e '(#hasheq() . #hasheq()))]) + (values (car p) (cdr p)))) + (define pre-branch (runstack-branch-before! runstack)) + (define pre-ref-use (ref-use-branch-before! state)) + (runstack-stage-clear-unused! runstack thn-refs els-refs state) + (generate ret thn env) + (out-close+open "} else {") + (runstack-stage-clear-unused! runstack els-refs thn-refs state) + (define post-branch (runstack-branch-other! runstack pre-branch)) + (define post-ref-use (ref-use-branch-other! state pre-ref-use)) + (generate ret els env) + (when (state-first-pass? state) + (define-values (thn-refs els-refs) (runstack-branch-refs runstack pre-branch post-branch)) + (hash-set! state e (cons thn-refs els-refs))) + (runstack-branch-merge! runstack pre-branch post-branch) + (ref-use-branch-merge! state pre-ref-use post-ref-use) + (out-close "}") + (runstack-pop! runstack tst-id-count))) + (unless all-simple? (out-close "}"))] + [`(with-continuation-mark ,key ,val ,body) + (define wcm-id (genid 'c_wcm)) + (define wcm-key-id (genid 'c_wcm_key)) + (define wcm-val-id (genid 'c_wcm_val)) + (out-open "{") + (define simple-key? (simple? key in-lam state knowns)) + (define simple-val? (simple? val in-lam state knowns)) + (define simple-either? (or simple-key? simple-val?)) + (runstack-push! runstack wcm-key-id #:local? simple-either?) + (runstack-push! runstack wcm-val-id #:local? simple-either?) + (unless (tail-return? ret) + (out "c_saved_mark_stack_t ~a_frame = c_push_mark_stack();" wcm-id)) + (cond + [(and simple-key? (not simple-val?)) + ;; Value first + (generate (make-runstack-assign runstack wcm-val-id) val env) + (generate (make-runstack-assign runstack wcm-key-id) key env)] + [else + ;; Key first + (generate (make-runstack-assign runstack wcm-key-id) key env) + (generate (make-runstack-assign runstack wcm-val-id) val env)]) + (define set-cont-mark (format "scheme_set_cont_mark(~a, ~a);" + (runstack-ref runstack wcm-key-id) + (runstack-ref runstack wcm-val-id))) + (runstack-pop! runstack 2) + (runstack-sync! runstack) + (out set-cont-mark) + (generate ret body env) + (unless (tail-return? ret) + (out "c_pop_mark_stack(~a_frame);" wcm-id)) + (out-close "}")] + [`(let () . ,body) (generate ret `(begin . ,body) env)] + [`(let (,_) . ,_) (generate-let ret e env)] + [`(let ([,id ,rhs] . ,rest) . ,body) + ;; One at a time, so runstack slot can be allocated after RHS: + (generate ret `(let ([,id ,rhs]) (let ,rest . ,body)) env)] + [`(letrec . ,_) (generate-let ret e env)] + [`(letrec* . ,_) (generate-let ret e env)] + [`(call-with-values (lambda () . ,body1) (lambda (,ids ...) . ,body2)) + (define values-ret (if (for/or ([id (in-list ids)]) + (or (referenced? (hash-ref state id #f)) + (hash-ref top-names id #f))) + "/*needed*/" + "")) + (generate (multiple-return values-ret) `(begin . ,body1) env) + (out-open "{") + (define bind-count + (for/sum ([id (in-list ids)] + #:unless (or (hash-ref top-names id #f) + (not (referenced? (hash-ref state id #f))))) + (runstack-push! runstack id) + 1)) + (generate-multiple-value-binds ids runstack in-lam state top-names) + (box-mutable-ids ids runstack in-lam state top-names) + (generate ret `(begin . ,body2) (add-args env ids)) + (runstack-pop! runstack bind-count) + (out-close "}")] + [`(set! ,ref ,rhs) + (define top? (hash-ref top-names ref #f)) + (define target + (cond + [top? (top-ref in-lam ref)] + [else (genid 'c_set)])) + (unless top? + (out-open "{") + (out "Scheme_Object *~a;" target)) + (generate (format "~a =" target) rhs env) + (unless top? + (when (ref? ref) (ref-use! ref state)) + (out "SCHEME_UNBOX_VARIABLE_LHS(~a) = ~a;" + (runstack-ref runstack (unref ref) #:ref (and (ref? ref) ref)) + target) + (out-close "}")) + (generate ret '(void) env)] + [`(void) (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_void")] + [`(void . ,r) + (generate ret `(begin ,@r (void)) env)] + [`(values ,r) + (generate ret r env)] + [`null (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_null")] + [`eof-object (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_eof")] + [`unsafe-undefined (return ret runstack #:can-omit? #t #:can-pre-pop? #t "scheme_undefined")] + [`(,rator ,rands ...) + (generate-app ret rator rands env)] + [`,_ + (cond + [(symbol-ref? e) + (when (ref? e) (ref-use! e state)) + (define can-omit? (not (and (ref? e) (ref-last-use? e)))) + (define id (unref e)) + (return ret runstack #:can-omit? can-omit? #:can-pre-pop? #t + (cond + [(hash-ref env id #f) + (cond + [(mutated? (hash-ref state id #f)) + (format "SCHEME_UNBOX_VARIABLE(~a)" + (runstack-ref runstack id #:ref e))] + [else + (when (and (return-can-omit? ret) + can-omit? + (state-first-pass? state)) + (adjust-state! state id -1)) + (runstack-ref runstack id #:ref e)])] + [(hash-ref top-names id #f) (top-ref in-lam id)] + [else (format "c_prims.~a" (cify id))]))] + [else (generate-quote ret e)])])) + + (define (generate-let ret e env) + (match e + [`(,let-id ([,ids ,rhss] ...) . ,body) + (define body-env (for/fold ([env env]) ([id (in-list ids)] + ;; Leave out of the environment if flattened + ;; into the top sequence: + #:unless (hash-ref top-names id #f)) + (when (eq? let-id 'letrec) + (unless (function? (hash-ref knowns id #f)) + (log-error "`letrec` binding should have been treated as closed: ~e" id))) + (hash-set env id #t))) + (define rhs-env (if (eq? let-id 'let) env body-env)) + (out-open "{") + (define (push-binds) + (for/sum ([id (in-list ids)] + #:unless (or (not (referenced? (hash-ref state id #f))) + ;; flattened into top? + (hash-ref top-names id #f))) + (runstack-push! runstack id #:track-local? (eq? let-id 'let)) + 1)) + (define let-one? (and (eq? let-id 'let) + (= 1 (length ids)) + (referenced? (hash-ref state (car ids) #f)) + (not (hash-ref top-names (car ids) #f)))) + (define pre-bind-count (if let-one? 0 (push-binds))) + (define let-one-id (and let-one? (genid 'c_let))) + (when let-one? + (out "Scheme_Object *~a;" (cify let-one-id))) + (when (eq? let-id 'letrec*) + (box-mutable-ids ids runstack in-lam state top-names)) + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (cond + [(eq? let-id 'letrec*) + (generate "" `(set! ,id ,rhs) rhs-env)] + [(not (referenced? (hash-ref state id #f))) + (generate "" rhs rhs-env)] + [else + (define ret (cond + [let-one? (format "~a =" (cify let-one-id))] + [(hash-ref top-names id #f) (format "~a =" (top-ref in-lam id))] + [else + (make-runstack-assign runstack id)])) + (generate ret rhs rhs-env)])) + (when let-one? + (runstack-push! runstack (car ids) #:track-local? #t) + (out "~a = ~a;" (runstack-assign runstack (car ids)) (cify let-one-id))) + (when (eq? let-id 'let) + (box-mutable-ids ids runstack in-lam state top-names)) + (generate ret `(begin . ,body) body-env) + (runstack-pop! runstack (if let-one? 1 pre-bind-count) + #:track-local? (eq? let-id 'let)) + (out-close "}") + (when (state-first-pass? state) + ;; For any variable that has become unused, mark a + ;; right-hand side function as unused + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (unless (referenced? (hash-ref state id #f)) + (define lam-e (match rhs + [`(lambda . ,_) rhs] + [`(case-lambda . ,_) rhs] + [`,_ #f])) + (when lam-e + (define lam (hash-ref lambdas lam-e #f)) + (set-lam-unused?! lam #t)))))])) + + (define (generate-app ret rator rands env) + (define n (length rands)) + (cond + [(and (symbol? rator) + (inline-function rator n rands in-lam knowns)) + (generate-inline-app ret rator rands n env)] + [(and (symbol? rator) + (let ([k (hash-ref knowns rator #f)]) + (and (struct-constructor? k) + (struct-info-pure-constructor? (struct-constructor-si k)) + k))) + => (lambda (k) + (generate-inline-construct ret k rands n env))] + [else + (generate-general-app ret rator rands n env)])) + + (define (generate-inline-app ret rator rands n env) + (define need-sync? (not (inline-function rator n rands in-lam knowns #:can-gc? #f))) + (define tmp-ids (for/list ([rand (in-list rands)] + [i (in-naturals)]) + (and (not (simple? rand in-lam state knowns)) + (genid (format "c_arg_~a_" i))))) + (define all-simple? (for/and ([tmp-id (in-list tmp-ids)]) + (not tmp-id))) + (unless all-simple? (out-open "{")) + (define tmp-count + (for/sum ([tmp-id (in-list tmp-ids)] + #:when tmp-id) + (runstack-push! runstack tmp-id) + 1)) + (for ([tmp-id (in-list tmp-ids)] + [rand (in-list rands)]) + (when tmp-id + (generate (make-runstack-assign runstack tmp-id) + rand env))) + (when need-sync? + (runstack-sync! runstack)) + (define inline-app (cons rator (for/list ([tmp-id (in-list tmp-ids)] + [rand (in-list rands)]) + (or tmp-id rand)))) + (call-with-simple-shared + inline-app + runstack state + (lambda (shared) + (define s (generate-simple inline-app shared env runstack in-lam state top-names knowns prim-names)) + (return ret runstack #:can-pre-pop? #t s) + (runstack-pop! runstack tmp-count))) + (unless all-simple? (out-close "}"))) + + (define (generate-inline-construct ret k rands n env) + (define si (struct-constructor-si k)) + (out-open "{") + (define struct-tmp-id (genid 'c_structtmp)) + (out "Scheme_Object *~a;" (cify struct-tmp-id)) + (runstack-sync! runstack) + (out "~a = c_malloc_struct(~a);" (cify struct-tmp-id) (struct-info-field-count si)) + (out "c_struct_set_type(~a, ~a);" (cify struct-tmp-id) (top-ref in-lam (struct-info-struct-id si))) + (define all-simple? (for/and ([rand (in-list rands)]) + (simple? rand in-lam state knowns))) + (define struct-id (and (not all-simple?) (genid 'c_struct))) + (unless all-simple? + (out-open "{") + (runstack-push! runstack struct-id #:track-local? #t) + (out "~a = ~a;" (runstack-assign runstack struct-id) (cify struct-tmp-id))) + (for ([rand (in-list rands)] + [i (in-naturals)]) + (define to-struct-s (format "c_STRUCT_ELS(~a)[~a] =" + (if all-simple? + (cify struct-tmp-id) + (runstack-ref runstack struct-id)) + i)) + (generate (if all-simple? + to-struct-s + (format "~a =" (cify struct-tmp-id))) + rand env) + (unless all-simple? + (out "~a ~a;" to-struct-s (cify struct-tmp-id)))) + (return ret runstack (if all-simple? + (cify struct-tmp-id) + (runstack-ref runstack struct-id))) + (unless all-simple? + (runstack-pop! runstack 1 #:track-local? #t) + (out-close "}")) + (out-close "}")) + + (define (generate-general-app ret rator rands n env) + (define known-target-lam (let ([f (hash-ref knowns rator #f)]) + (and (function? f) (hash-ref lambdas (function-e f))))) + ;; If the target is known for a tail call, put this lambda and + ;; that one in the same vehicle, so the tail call can be a jump: + (when (and (tail-return? ret) + known-target-lam + (state-first-pass? state)) + (union! state (tail-return-lam ret) known-target-lam)) + ;; If it's known, we can jump as long as the target is in the same + ;; vehicle (which we just ensured, at least for a second pass) + (define direct? (and known-target-lam + (or (not (tail-return? ret)) + (eq? (find! state known-target-lam) + (find! state (tail-return-lam ret)))) + (compatible-args? n (lam-e known-target-lam)))) + (define direct-tail? (and direct? (tail-return? ret))) + ;; Do we need to evaluate the rator expression? If so, `rator-id` + ;; will be non-#f: + (define rator-id (cond + [direct? #f] + [(simple? rator in-lam state knowns) #f] + [else (genid 'c_rator)])) + ;; For a non-tail call, make a runstack id for every argument; + ;; that part of the runstack will be argv. + ;; For a tail call, we only need an arg-id for a non-simple + ;; expression, and we don't need one for the last non-simple. + (define arg-ids (for/list ([rand (in-list rands)] + [i (in-naturals)]) + (if (and direct-tail? + (simple? rand in-lam state knowns)) + #f + (genid (format "c_arg_~a_" i))))) + (define last-non-simple-arg-id + (and direct-tail? (for/last ([arg-id (in-list arg-ids)]) + arg-id))) + (define open? (not (and (zero? n) (not rator-id)))) + (when open? (out-open "{")) + ;; We can perform less runstack work by evaluating the first + ;; argument before making room on the runstack: + (define-values (first-non-simple-id first-non-simple-e) + (if rator-id + (values rator-id rator) + (let loop ([arg-ids arg-ids] [rands rands]) + (cond + [(null? arg-ids) (values #f #f)] + [(simple? (car rands) in-lam state knowns) (loop (cdr arg-ids) (cdr rands))] + [else (values (car arg-ids) (car rands))])))) + (define first-tmp-id (and first-non-simple-id + (genid 'c_argtmp))) + (when first-non-simple-id + (out "Scheme_Object *~a;" (cify first-tmp-id)) + (generate (format "~a =" (cify first-tmp-id)) + first-non-simple-e env)) + (when last-non-simple-arg-id ; could be the same as `first-non-simple-id` + (out "Scheme_Object *~a;" (cify last-non-simple-arg-id))) + (define declared-tmp? (or first-non-simple-id last-non-simple-arg-id)) + (when declared-tmp? (out-open "{")) + ;; Allocate the runstack room; put space for the rator, + ;; if needed, at the end, so it's after the runstack as argv + (when rator-id + (runstack-push! runstack rator-id)) + (define arg-push-count + (for/sum ([arg-id (reverse arg-ids)] + #:when (and arg-id + (not (eq? arg-id last-non-simple-arg-id)))) + (runstack-push! runstack arg-id) + 1)) + (define (generate-assign id e) + ;; Generate or use an already-generated non-simple in tmp + (cond + [(eq? id first-non-simple-id) + (out "~a = ~a;" + (if (eq? id last-non-simple-arg-id) + (cify id) + (runstack-assign runstack id)) + (cify first-tmp-id))] + [(eq? id last-non-simple-arg-id) + (generate (format "~a =" (cify id)) + e env)] + [else + (generate (make-runstack-assign runstack id) + e env)])) + (define (generate-args #:simple? gen-simple?) + (for ([arg-id (in-list arg-ids)] + [rand (in-list rands)] + #:when (and arg-id + (eq? (and gen-simple? #t) + (simple? rand in-lam state knowns)))) + (generate-assign arg-id rand))) + ;; For a non-tail call, generate simple arguments first, so + ;; that the allocated runstacks are filled: + (unless direct-tail? + (generate-args #:simple? #t)) + (when rator-id + (generate-assign rator-id rator)) + (generate-args #:simple? #f) + ;; Now that the arguments are ready (except simple arguments + ;; for a direct tail call), we finish in various ways: + (cond + ;; Special case for `values`: + [(eq? rator 'values) + (runstack-sync! runstack) ; now argv == runstack + (return ret runstack #:can-omit? #t + (if (zero? n) + "c_zero_values()" + (format "scheme_values(~a, c_current_runstack)" n)))] + ;; Call to a non-inlined primitive or to an unknown target + [(not direct?) + (call-with-simple-shared + (if rator-id #f rator) + runstack state + (lambda (shared) + (define rator-s (if rator-id + (runstack-ref runstack rator-id) + (generate-simple rator shared env runstack in-lam state top-names knowns prim-names))) + (define direct-prim? (and (symbol? rator) + (direct-call-primitive? rator prim-knowns))) + (define use-tail-apply? (and (tail-return? ret) + (or (not (symbol? rator)) + (hash-ref env rator #f) + (hash-ref top-names rator #f) + (not direct-prim?)))) + (define template (cond + [use-tail-apply? "_scheme_tail_apply(~a, ~a, ~a)"] + [direct-prim? "c_extract_prim(~a)(~a, ~a)"] + [(or (multiple-return? ret) (tail-return? ret)) "_scheme_apply_multi(~a, ~a, ~a)"] + [else "_scheme_apply(~a, ~a, ~a)"])) + (unless (or use-tail-apply? + (and direct-prim? (immediate-primitive? rator prim-knowns))) + (lam-calls-non-immediate! in-lam)) + (when use-tail-apply? + (set-lam-can-tail-apply?! in-lam #t)) + (runstack-sync! runstack) ; now argv == runstack + (return ret runstack (format template rator-s n (if (zero? n) "NULL" (runstack-stack-ref runstack))))))] + ;; Tail call to a known target: + [(tail-return? ret) + ;; Put simple arguments in temporaries: + (define any-simple? (for/or ([arg-id (in-list arg-ids)]) (not arg-id))) + (define arg-tmp-ids (for/list ([arg-id (in-list arg-ids)] + [rand (in-list rands)] + [i (in-naturals)]) + (cond + [arg-id #f] + [(and (symbol-ref? rand) + (eqv? (runstack-ref-pos runstack (unref rand)) (- n i)) + ((- n i) . <= . (args-length (tail-return-self-args ret))) + (not (mutated? (hash-ref state (unref rand) #f)))) + ;; No need to copy an argument to itself, which is + ;; common for lifted loops: + (when (state-first-pass? state) + (adjust-state! state (unref rand) -1)) + #f] + [else + (genid 'c_argtmp)]))) + (when any-simple? + (out-open "{") + (for ([arg-tmp-id (in-list arg-tmp-ids)] + #:when arg-tmp-id) + (out "Scheme_Object *~a;" (cify arg-tmp-id))) + (for ([arg-tmp-id (in-list arg-tmp-ids)] + [rand (in-list rands)] + #:when arg-tmp-id) + (generate (format "~a =" (cify arg-tmp-id)) + rand env))) + ;; Non-simple args are on the runstack. We need to move from + ;; last to first, since the runstack staging area and the + ;; and target argument area may overlap. + (for ([i (in-range n 0 -1)] + [arg-id (in-list (reverse arg-ids))]) + (when arg-id + (out "c_runbase[~a] = ~a;" + (- i (add1 n)) + (if (eq? arg-id last-non-simple-arg-id) + (cify arg-id) + (runstack-ref runstack arg-id))))) + ;; Move the simple arguments into place: + (for ([i (in-range n)] + [arg-tmp-id (in-list arg-tmp-ids)]) + (when arg-tmp-id + (out "c_runbase[~a] = ~a;" (- i n) (cify arg-tmp-id)))) + ;; For any argument that was skipped because it's already in + ;; place, record that we need it live to here: + (for ([arg-id (in-list arg-ids)] + [arg-tmp-id (in-list arg-tmp-ids)] + [rand (in-list rands)]) + (unless (or arg-id arg-tmp-id) + (out "/* in place: ~a */" (cify (ref-id rand))) + (runstack-ref-use! runstack rand) + (ref-use! rand state) + (state-implicit-reference! state (ref-id rand)))) + (when any-simple? + (out-close "}")) + ;; Set the runstack pointer to the argument start, then jump + (out "c_current_runstack = c_runbase - ~a;" n) + (when (if (eq? in-lam known-target-lam) + (n . <= . (args-length (tail-return-self-args ret))) + (symbolstring e))] + [(string? e) + (define s (string->bytes/utf-8 e)) + (format "scheme_make_sized_utf8_string(~s, ~a)" + (bytes->string/latin-1 s) + (bytes-length s))] + [(bytes? e) + (format "scheme_make_sized_byte_string(~s, ~a, 0)" + (bytes->string/latin-1 e) + (bytes-length e))] + [(number? e) + (cond + [(always-fixnum? e) + (format "scheme_make_integer(~a)" e)] + [(eqv? e +inf.0) "scheme_inf_object"] + [(eqv? e -inf.0) "scheme_minus_inf_object"] + [(eqv? e +nan.0) "scheme_nan_object"] + [(eqv? e +inf.f) "scheme_single_inf_object"] + [(eqv? e -inf.f) "scheme_single_minus_inf_object"] + [(eqv? e +nan.f) "scheme_single_nan_object"] + [else + (format "scheme_make_double(~a)" e)])] + [(boolean? e) (if e "scheme_true" "scheme_false")] + [(null? e) "scheme_null"] + [(void? e) "scheme_void"] + [(eq? unsafe-undefined e) "scheme_undefined"] + [(char? e) (format "scheme_make_character(~a)" (char->integer e))] + [else + (error 'generate-quote "not handled: ~e" e)])) + + (generate ret e env)) + +;; ---------------------------------------- + +(define (generate-tops e max-runstack-depth exports knowns top-names state lambdas prim-names prim-knowns) + (define runstack (make-runstack state)) + + (define (generate-tops e) + (generate-init-prims) + (out-next) + (out-open "void scheme_init_startup_instance(Scheme_Instance *c_instance) {") + (out "c_LINK_THREAD_LOCAL") + (out "Scheme_Object **c_runbase = c_current_runstack;") + (out "MZ_GC_DECL_REG(1);") + (out "MZ_GC_VAR_IN_REG(0, c_instance);") + (out "MZ_GC_REG();") + + (out "REGISTER_SO(c_top);") + (out "c_top = scheme_malloc(sizeof(struct startup_instance_top_t));") + + (out "c_check_top_runstack_depth(~a);" max-runstack-depth) + (generate-moved-to-top lambdas) + (generate-top e) + ;; Expects `([ ] ...)` for `exports` + (for ([ex (in-list exports)]) + (out "scheme_instance_add(c_instance, ~s, ~a);" + (format "~a" (cadr ex)) + (top-ref #f (no-c-prefix (car ex))))) + + (out "MZ_GC_UNREG();") + (out-close "}") + (runstack-max-depth runstack)) + + (define (generate-moved-to-top lambdas) + (for ([lam (in-sorted-hash-values lambdas (compare symbolku.multiple.array[~a];" s i))) + +;; ---------------------------------------- + +;; Recognize the patterns that the linklet flattener uses to record a +;; function's name within an S-expression, taking into account that lifting +;; may have pushed the pattern under a `let`: +(define (extract-lambda-name e) + (define (extract body) + (match body + [`(,e ,e2 . ,_) + (extract-one e)] + [`((begin . ,body)) + (extract body)] + [`((let ,binds . ,body)) (extract body)] + [`((letrec ,binds . ,body)) (extract body)] + [`((letrec* ,binds . ,body)) (extract body)] + [`,_ #f])) + (define (extract-one e) + (match e + [`(quote ,id) (and (symbol? id) id)] + [`(begin ,e . ,_) (extract-one e)] + [`,_ #f])) + (match e + [`(lambda ,_ . ,body) + (extract body)] + [`(case-lambda [,_ . ,body] . ,_) + (extract body)] + [`,_ #f])) + diff --git a/racket/src/cify/id.rkt b/racket/src/cify/id.rkt new file mode 100644 index 0000000000..3fdb05a05b --- /dev/null +++ b/racket/src/cify/id.rkt @@ -0,0 +1,78 @@ +#lang racket/base + +(provide no-c-prefix + cify + genid + reset-genid-counters!) + +;; The "c_" prefix is reserved for names that are provided +;; by the Racket glue or that we make up, where we choose +;; a prefix for any made-up name that won't conflict with +;; the Racket-glue names. +(define (no-c-prefix s) + (if (regexp-match? #rx"c_" (symbol->string s)) + (string->symbol (format "o_~a" s)) + s)) + +(define c-names (make-hasheq)) +(define used-names (make-hasheq)) + +;; Count reserved names as used, as well as anything +;; that doesn't fit the "c_..." or "scheme_..." pattern. +(for ([n (in-list '(void int long double short + if else return const goto switch case + SAME_OBJ))]) + (hash-set! used-names n #t)) + +(define replacements + '((#rx"!" "_B_") + (#rx"-" "_") + (#rx"[.]" "_T_") + (#rx"[?]" "_Q_") + (#rx"[+]" "_P_") + (#rx":" "_C_") + (#rx"/" "_S_") + (#rx"<" "_L_") + (#rx">" "_G_") + (#rx"#%" "_HP_") + (#rx"[*]" "_R_") + (#rx"[=]" "_E_") + (#rx"[$]" "_M_") + (#rx"#" "_H_") + (#rx"~" "_I") + (#rx"@" "_A_"))) + +(define (cify name) + (or (hash-ref c-names name #f) + (let* ([c-name + (string->symbol + (regexp-replace* + #rx"^(?=[0-9]|_[_A-Z]|scheme|SCHEME|Scheme|MZ_)" ; c_ prefix is avoided via `no-c-prefix` + (for/fold ([s (symbol->string name)]) ([r (in-list replacements)]) + (regexp-replace* (car r) s (cadr r))) + "o_"))] + [c-name (if (not (hash-ref used-names c-name #f)) + c-name + ;; collisions should be very rare + (let loop ([i 2]) + (define new-c-name (string->symbol (format "~a_~a" c-name i))) + (if (hash-ref used-names new-c-name #f) + (loop (add1 i)) + new-c-name)))]) + (hash-set! c-names name c-name) + (hash-set! used-names c-name #t) + c-name))) + +;; ---------------------------------------- + +(define compiler-ids (make-hasheq)) + +(define (genid in-s) + (define s (if (string? in-s) (string->symbol in-s) in-s)) + (define c (hash-ref compiler-ids s 0)) + (hash-set! compiler-ids s (add1 c)) + (string->symbol (format "~a~a" s c))) + +(define (reset-genid-counters! l) + (for ([c (in-list l)]) + (hash-set! compiler-ids c 0))) diff --git a/racket/src/cify/inline.rkt b/racket/src/cify/inline.rkt new file mode 100644 index 0000000000..520808173b --- /dev/null +++ b/racket/src/cify/inline.rkt @@ -0,0 +1,143 @@ +#lang racket/base +(require "match.rkt" + "id.rkt" + "vehicle.rkt" + "struct.rkt") + +(provide inline-function + extract-inline-predicate) + +(define (inline-function rator n rands in-lam knowns #:can-gc? [can-gc? #t]) + (case rator + [(car unsafe-car) (and (= n 1) 'c_pair_car)] + [(cdr unsafe-cdr) (and (= n 1) 'c_pair_cdr)] + [(cadr) (and (= n 1) 'c_pair_cadr)] + [(cdar) (and (= n 1) 'c_pair_cdar)] + [(cddr) (and (= n 1) 'c_pair_cddr)] + [(caar) (and (= n 1) 'c_pair_caar)] + [(cons) (and (= n 2) can-gc? 'scheme_make_pair)] + [(list*) (and (= n 2) can-gc? 'scheme_make_pair)] + [(list) (and (or (= n 1) (= n 2)) can-gc? (if (= n 1) 'c_make_list1 'c_make_list2))] + [(unbox unsafe-unbox unbox* unsafe-unbox*) (and (= n 1) 'c_box_ref)] + [(weak-box-value) (and (or (= n 1) (= n 2)) 'c_weak_box_value)] + [(set-box! set-box*! unsafe-set-box! unsafe-set-box*!) (and (= n 2) 'c_box_set)] + [(vector-ref unsafe-vector-ref) (and (= n 2) 'c_vector_ref)] + [(vector*-ref unsafe-vector*-ref) (and (= n 2) 'c_authentic_vector_ref)] + [(vector-set! unsafe-vector-set! vector*-set! unsafe-vector*-set!) (and (= n 3) 'c_vector_set)] + [(vector-length unsafe-vector-length vector*-length unsafe-vector*-length) (and (= n 1) 'c_vector_length)] + [(string-ref unsafe-string-ref) (and (= n 2) can-gc? 'c_string_ref)] + [(bytes-ref unsafe-bytes-ref) (and (= n 2) 'c_bytes_ref)] + [(fx+ unsafe-fx+) (and (= n 2) 'c_int_add)] + [(add1) (and (= n 1) can-gc? 'c_number_add1)] + [(sub1) (and (= n 1) can-gc? 'c_number_sub1)] + [(hash-ref) (cond + [(= n 3) (and can-gc? (known-non-procedure? (caddr rands) knowns) 'c_hash_ref)] + [(= n 2) (and can-gc? 'c_hash_ref2)] + [else #f])] + [(hash-set) (and (= n 3) can-gc? 'c_hash_set)] + [(hash-count) (and (= n 1) can-gc? 'c_hash_count)] + [(hash-iterate-first) (and (= n 1) can-gc? 'c_hash_iterate_first)] + [(unsafe-immutable-hash-iterate-first) (and (= n 1) can-gc? 'c_unsafe_immutable_hash_iterate_first)] + [(unsafe-immutable-hash-iterate-next) (and (= n 2) can-gc? 'c_unsafe_immutable_hash_iterate_next)] + [(unsafe-immutable-hash-iterate-key) (and (= n 2) can-gc? 'c_unsafe_immutable_hash_iterate_key)] + [(unsafe-immutable-hash-iterate-key+value) (and (= n 2) can-gc? 'c_unsafe_immutable_hash_iterate_key_value)] + [(prefab-struct-key) (and (= n 1) 'c_prefab_struct_key)] + [else + (define-values (pred-exprs pred-gc? pred-inliner) + (extract-inline-predicate (cons rator (for/list ([i (in-range n)]) 'c_unknown)) in-lam knowns)) + (cond + [(and pred-inliner + (or (not pred-gc?) can-gc?)) + (lambda (s) (format "(~a ? scheme_true : scheme_false)" (pred-inliner s)))] + [else + (define k (hash-ref knowns rator #f)) + (cond + [(and (struct-accessor? k) (= n 1)) + (lambda (s) + (if (struct-info-authentic? (struct-accessor-si k)) + (format "c_authentic_struct_ref(~a, ~a)" s (struct-accessor-pos k)) + (and can-gc? (format "c_struct_ref(~a, ~a)" s (struct-accessor-pos k)))))] + [(and (struct-mutator? k) (= n 2)) + (lambda (s) + (if (struct-info-authentic? (struct-mutator-si k)) + (format "c_authentic_struct_set(~a, ~a)" s (struct-mutator-pos k)) + (and can-gc? (format "c_struct_set(~a, ~a)" s (struct-mutator-pos k)))))] + [(and (struct-property-accessor? k) (= n 1)) + (and can-gc? + (lambda (s top-ref) + (format "c_struct_property_ref(~a, ~a)" s (top-ref (struct-property-accessor-property-id k)))))] + [else #f])])])) + +(define (extract-inline-predicate e in-lam knowns #:compose? [compose? #f]) + (define (compose e gc? wrapper) + (define-values (new-es new-gc? new-wrapper) (extract-inline-predicate e in-lam knowns #:compose? compose?)) + (values new-es (or gc? new-gc?) (lambda (s) (wrapper (new-wrapper s))))) + (define (generic e) + (if compose? + (values (list e) #f (lambda (s) (format "c_scheme_truep(~a)" s))) + (values #f #f #f))) + ;; simple => no GC + (define (simple template #:can-gc? [can-gc? #f] . args) + (values args can-gc? (lambda (s) (format template s)))) + (match e + [`(not ,e) + (if compose? + (compose e #f (lambda (s) (format "!~a" s))) + (values (list e) #f (lambda (s) (format "c_scheme_falsep(~a)" s))))] + [`(null? ,e) (simple "c_scheme_nullp(~a)" e)] + [`(eof-object? ,e) (simple "c_scheme_eof_objectp(~a)" e)] + [`(void? ,e) (simple "c_scheme_voidp(~a)" e)] + [`(boolean? ,e) (simple "c_scheme_boolp(~a)" e)] + [`(number? ,e) (simple "c_scheme_numberp(~a)" e)] + [`(pair? ,e) (simple "c_scheme_pairp(~a)" e)] + [`(list? ,e) (simple "c_scheme_listp(~a)" e)] + [`(vector? ,e) (simple "c_scheme_chaperone_vectorp(~a)" e)] + [`(box? ,e) (simple "c_scheme_chaperone_boxp(~a)" e)] + [`(symbol? ,e) (simple "c_scheme_symbolp(~a)" e)] + [`(keyword? ,e) (simple "c_scheme_keywordp(~a)" e)] + [`(string? ,e) (simple "c_scheme_char_stringp(~a)" e)] + [`(bytes? ,e) (simple "c_scheme_byte_stringp(~a)" e)] + [`(path? ,e) (simple "c_scheme_pathp(~a)" e)] + [`(char? ,e) (simple "c_scheme_charp(~a)" e)] + [`(hash? ,e) (simple "c_scheme_hashp(~a)" e)] + [`(eq? ,e1 ,e2) (simple "c_same_obj(~a)" e1 e2)] + [`(eqv? ,e1 ,e2) (simple "scheme_eqv(~a)" e1 e2)] + [`(equal? ,e1 ,e2) (simple #:can-gc? #t "scheme_equal(~a)"e1 e2)] + [`(char=? ,e1 ,e2) (simple "c_scheme_char_eq(~a)" e1 e2)] + [`(char-whitespace? ,e) (simple "c_scheme_char_whitespacep(~a)" e)] + [`(unsafe-fx< ,e1 ,e2) (simple "c_int_lt(~a)" e1 e2)] + [`(unsafe-fx> ,e1 ,e2) (simple "c_int_gt(~a)" e1 e2)] + [`(unsafe-fx>= ,e1 ,e2) (simple "!c_int_lt(~a)" e1 e2)] + [`(unsafe-fx<= ,e1 ,e2) (simple "!c_int_gt(~a)" e1 e2)] + [`(unsafe-fx= ,e1 ,e2) (simple "c_same_obj(~a)" e1 e2)] + [`(= ,e1 ,e2) (simple #:can-gc? #t "c_number_eq(~a)" e1 e2)] + [`(< ,e1 ,e2) (simple #:can-gc? #t "c_number_lt(~a)" e1 e2)] + [`(> ,e1 ,e2) (simple #:can-gc? #t "c_number_gt(~a)" e1 e2)] + [`(<= ,e1 ,e2) (simple #:can-gc? #t "c_number_lt_eq(~a)" e1 e2)] + [`(>= ,e1 ,e2) (simple #:can-gc? #t "c_number_gt_eq(~a)" e1 e2)] + [`(zero? ,e) (simple "c_number_zerop(~a)" e)] + [`(,rator ,rand) + (define k (and (symbol? rator) + (hash-ref knowns rator #f))) + (cond + [(struct-predicate? k) + (define si (struct-predicate-si k)) + (define s-id (struct-info-struct-id si)) + (values (list rand) + #f + (cond + [(struct-info-authentic? si) + (lambda (s) (format "c_is_authentic_struct_instance(~a, ~a)" s (top-ref in-lam s-id)))] + [else + (lambda (s) (format "c_is_struct_instance(~a, ~a)" s (top-ref in-lam s-id)))]))] + [else (generic e)])] + [`,_ (generic e)])) + +(define (known-non-procedure? e knowns) + (or (boolean? e) + (number? e) + (eq? e 'null) + (and (symbol? e) + (let ([k (hash-ref knowns e #f)]) + (or (symbol? k) + (eq? k '#:non-procedure)))))) diff --git a/racket/src/cify/lambda.rkt b/racket/src/cify/lambda.rkt new file mode 100644 index 0000000000..1ddd2f3ca5 --- /dev/null +++ b/racket/src/cify/lambda.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require "match.rkt" + "vehicle.rkt" + "id.rkt") + +;; See also "vehicle.rkt" for the `lam` structure type. + +(provide extract-lambdas!) + +(define (extract-lambdas! lambdas e) + (match e + [`(define ,id ,rhs) + (extract-lambdas! lambdas rhs)] + [`(define-values ,_ ,rhs) + (extract-lambdas! lambdas rhs)] + [`(begin ,es ...) + (for ([e (in-list es)]) + (extract-lambdas! lambdas e))] + [`(begin0 ,es ...) + (extract-lambdas! lambdas `(begin . ,es))] + [`(lambda ,ids . ,body) + (hash-set! lambdas e (make-lam (genid 'c_lambda) e)) + (extract-lambdas! lambdas `(begin . ,body))] + [`(case-lambda [,idss . ,bodys] ...) + (hash-set! lambdas e (make-lam (genid 'c_case_lambda) e)) + (for ([ids (in-list idss)] + [body (in-list bodys)]) + (extract-lambdas! lambdas `(begin . ,body)))] + [`(quote ,_) lambdas] + [`(if ,tst ,thn ,els) + (extract-lambdas! lambdas tst) + (extract-lambdas! lambdas thn) + (extract-lambdas! lambdas els)] + [`(with-continuation-mark ,key ,val ,body) + (extract-lambdas! lambdas key) + (extract-lambdas! lambdas val) + (extract-lambdas! lambdas body)] + [`(let . ,_) + (extract-let-lambdas! lambdas e)] + [`(letrec . ,_) + (extract-let-lambdas! lambdas e)] + [`(letrec* . ,_) + (extract-let-lambdas! lambdas e)] + [`(set! ,id ,rhs) + (extract-lambdas! lambdas rhs)] + [`(call-with-values (lambda () . ,body1) (lambda (,ids ...) . ,body2)) + (extract-lambdas! lambdas `(begin . ,body1)) + (extract-lambdas! lambdas `(begin . ,body2))] + [`(,rator ,rands ...) + (extract-lambdas! lambdas `(begin ,rator . ,rands))] + [`,_ (void)])) + +(define (extract-let-lambdas! lambdas e) + (match e + [`(,let-id ([,ids ,rhss] ...) . ,body) + (for ([rhs (in-list rhss)]) + (extract-lambdas! lambdas rhs)) + (extract-lambdas! lambdas `(begin . ,body))])) diff --git a/racket/src/cify/main.rkt b/racket/src/cify/main.rkt new file mode 100644 index 0000000000..53e01fdd54 --- /dev/null +++ b/racket/src/cify/main.rkt @@ -0,0 +1,129 @@ +#lang racket/base +(require racket/list + racket/port + "match.rkt" + "out.rkt" + "prune.rkt" + "unique.rkt" + "sort.rkt" + "id.rkt" + "vehicle.rkt" + "top-name.rkt" + "prim-name.rkt" + "ref.rkt" + "function.rkt" + "state.rkt" + "generate.rkt" + "lambda.rkt" + "struct.rkt" + "union.rkt" + "debug.rkt") + +(provide (rename-out [main-cify cify])) + +(define (main-cify out-file exports in-e prim-knowns + #:debug? [debug? #f] + #:preamble [preamble '()] + #:postamble [postamble '()]) + (current-debug debug?) + (call-with-output-file* + out-file + #:exists 'truncate/replace + (lambda (out) + (parameterize ([current-c-output-port out]) + (for-each out-exact preamble) + (to-c exports in-e prim-knowns) + (for-each out-exact postamble))))) + +;; ---------------------------------------- + +(define (to-c exports in-e prim-knowns) + (generate-header) + + ;; Inlining may have made some definitions useless: + (define pruned-e (prune-unused in-e exports)) + + ;; Make sure all names are unique: + (define unique-e (re-unique pruned-e)) + + ;; Find all `define`d names and `let[rec[*]]` names that are + ;; flattend into the top sequence: + (define top-names (extract-top-names #hasheq() unique-e)) + + ;; Find all the primitives that we'll need to call: + (define prim-names (extract-prim-names unique-e top-names)) + + ;; Find mutable variables, which will need to be boxed: + (define state (make-state)) + (extract-state! state unique-e) + + ;; Wrap `ref` around every local-variable reference. Also, + ;; perform copy propagation: + (define e (wrap-ref unique-e top-names prim-names state)) + + ;; Find all `lambda`s and `case-lambda`s, mapping each to + ;; a newly synthesized name: + (define lambdas (make-hasheq)) + (extract-lambdas! lambdas e) + + (define struct-knowns (extract-structs e)) + + ;; Find all functions that do not need to be kept in a closure. + ;; Top-level functions and functions bound with `letrec` are in this + ;; category: + (define functions (extract-functions #hasheq() e lambdas)) + (for ([(id f) (in-sorted-hash functions symbol 'local or distance from stack start + need-inits ; set of pushed vars that are not yet initialized + unsynced ; pushed vars that haven't yet lived through a GC boundary + unsynced-refs ; per-var refs that haven't yet lived through a GC boundary + all-refs ; per-var, all references encountered + staged-clears ; clears staged by branching + ever-synced?) ; whether the runstack is ever synced + #:mutable) + +(define (make-runstack state) + (define rs-state (or (hash-ref state '#:runstack #f) + (let ([ht (make-hasheq)]) + (hash-set! state '#:runstack ht) + ht))) + (runstack rs-state + 0 ; depth + 0 ; max-depth + #f ; sync-depth + '() ; vars + (make-hasheq) ; var-depths + (make-hasheq) ; need-inits + (make-hasheq) ; unsyned + (make-hasheq) ; unsynced-refs + #hasheq() ; all-refs + #hasheq() ; staged-clears + #f)) ; ever-synced? + +(define (runstack-push! rs id + #:referenced? [referenced? #t] + #:local? [local? #f] + #:track-local? [track-local? #f]) + (set-runstack-vars! rs (cons id (runstack-vars rs))) + (cond + [(or local? + (and track-local? + referenced? + (eq? 'local (hash-ref (runstack-rs-state rs) id #f)))) + ;; A previous pass determined that this variable will not + ;; live across a GC boundary, so it can be stored in a C local. + ;; Note that we're sharing a global table, even though an id + ;; can have different extents due to closures; but only `let` + ;; bindings are "tracked", and each of those is unique. + (hash-set! (runstack-var-depths rs) id 'local) + (out "Scheme_Object *~a;" (cify id))] + [else + (define depth (add1 (runstack-depth rs))) + (set-runstack-depth! rs depth) + (set-runstack-max-depth! rs (max depth (runstack-max-depth rs))) + (hash-set! (runstack-var-depths rs) id depth) + (hash-set! (runstack-need-inits rs) id #t) + (hash-set! (runstack-unsynced rs) id #t) + (out "~aconst int ~a = -~a;~a" + (if referenced? "" "/* ") + (cify id) depth + (if referenced? "" " */"))])) + +(define (runstack-pop! rs [n 1] + #:track-local? [track-local? #f]) + (define var-depths (runstack-var-depths rs)) + (let loop ([n n]) + (unless (zero? n) + (define var (car (runstack-vars rs))) + (unless (eq? 'local (hash-ref var-depths var #f)) + (set-runstack-depth! rs (- (runstack-depth rs) 1)) + (hash-remove! (runstack-need-inits rs) var) + (when (hash-ref (runstack-unsynced rs) var #f) + (when track-local? + (hash-set! (runstack-rs-state rs) var 'local)) + (hash-remove! (runstack-unsynced rs) var)) + (let ([refs (hash-ref (runstack-unsynced-refs rs) var '())]) + (hash-remove! (runstack-unsynced-refs rs) var) + (for ([ref (in-list refs)]) + (set-ref-last-use?! ref #f)))) + (set-runstack-vars! rs (cdr (runstack-vars rs))) + (set-runstack-all-refs! rs (hash-remove (runstack-all-refs rs) var)) + (hash-remove! var-depths var) + (set-runstack-staged-clears! rs (hash-remove (runstack-staged-clears rs) var)) + (loop (sub1 n))))) + +(define (runstack-ref rs id #:assign? [assign? #f] #:ref [ref #f] #:values-ok? [values-ok? #f]) + (when ref + (runstack-ref-use! rs ref) + ;; Remember the ref, so we can clear its `last-use?` if no sync + ;; happens before the variable is popped + (hash-set! (runstack-unsynced-refs rs) id + (cons ref (hash-ref (runstack-unsynced-refs rs) id '())))) + (define s + (cond + [(eq? 'local (hash-ref (runstack-var-depths rs) id #f)) + (format "~a" (cify id))] + [(and ref (ref-last-use? ref)) + (format "c_last_use(c_runbase, ~a)" (cify id))] + [else + (format "c_runbase[~a]" (cify id))])) + (if (and (current-debug) (not values-ok?) (not assign?)) + (format "c_validate(~a)" s) + s)) + +(define (runstack-ref-use! rs ref) + (set-runstack-all-refs! rs (hash-set2 (runstack-all-refs rs) (ref-id ref) ref #t))) + +(define (runstack-assign rs id) + (hash-remove! (runstack-need-inits rs) id) + (runstack-ref rs id #:assign? #t)) + +(define (make-runstack-assign rs id) + (lambda (s) (out "~a = ~a;" (runstack-assign rs id) s))) + +(define (runstack-stack-ref rs) + (format "(c_runbase-~a)" (runstack-depth rs))) + +(define (runstack-ref-pos rs id) + (hash-ref (runstack-var-depths rs) id #f)) + +(define (runstack-sync! rs) + (set-runstack-ever-synced?! rs #t) + (hash-clear! (runstack-unsynced rs)) + (hash-clear! (runstack-unsynced-refs rs)) + (runstack-generate-staged-clears! rs) + (define vars (sort (hash-keys (runstack-need-inits rs)) symbol . (hash-count a)) + (union-unsynced-refs! b a c)] + [((hash-count c) . > . (hash-count b)) + (union-unsynced-refs! a c b)] + [else + (union-unsynced-refs! a b) + (union-unsynced-refs! a c)])] + [(a b) + (for ([(id l) (in-hash b)]) + (hash-set! a id (append l (hash-ref a id '())))) + a])) + +(define union-all-refs + (case-lambda + [(a b c) + (cond + [((hash-count b) . > . (hash-count a)) + (union-all-refs b a c)] + [((hash-count c) . > . (hash-count b)) + (union-all-refs a c b)] + [else + (union-all-refs (union-all-refs a b) c)])] + [(a b) + (for/fold ([a a]) ([(id b-refs) (in-hash b)]) + (define a-refs (hash-ref a id #hasheq())) + (hash-set a id (hash-union a-refs b-refs)))])) + +(define (hash-set2 ht key key2 val) + (hash-set ht key + (hash-set (hash-ref ht key #hasheq()) + key2 + val))) + +;; ---------------------------------------- + +;; If `other-refs` includes a last use of a variable that +;; is not referenced in `my-refs`, then stage a clear +;; operation for space safety. The clear operation is emitted +;; only if the variable is still live by the time the runstack +;; is synced. +(define (runstack-stage-clear-unused! rs my-refs other-refs state) + (for* ([refs (in-hash-values other-refs)] + [ref (in-hash-keys refs)]) + (define id (ref-id ref)) + (when (and (ref-last-use? ref) + (not (hash-ref my-refs id #f))) + (runstack-stage-clear! rs id state)))) + +;; A danger of lazy clearing is that we might push the same +;; clearing operation to two different branches. It would be +;; better to clear eagerly at the start of a branch if there +;; will definitely by a sync point later, but we don't currently +;; have the "sync point later?" information. +(define (runstack-stage-clear! rs id state) + (set-runstack-staged-clears! + rs + (hash-set (runstack-staged-clears rs) + id + ;; the `get-pos` thunk: + (lambda () + (cond + [(not (referenced? (hash-ref state id #f))) + ;; This can happen in we need to clear a variable that is + ;; otherwise only implicitly passed in a tail call: + (format "-~a /* ~a */" (runstack-ref-pos rs id) (cify id))] + [else + (cify id)]))))) + +(define (runstack-generate-staged-clears! rs) + (for ([(id get-pos) (in-sorted-hash (runstack-staged-clears rs) symbol (lambda (new-id) (format "~a" (cify new-id)))] + [else + (ref-use! e state) + (runstack-ref runstack id #:ref e)])] + [(or (hash-ref top-names e #f) + (hash-ref knowns e #f)) + (format "~a" (top-ref in-lam e))] + [(hash-ref prim-names e #f) + (cond + [(eq? e 'null) "scheme_null"] + [(eq? e 'eof-object) "scheme_eof"] + [(eq? e 'unsafe-undefined) "scheme_undefined"] + [else (format "c_prims.~a" (cify e))])] + [else (runstack-ref runstack e)])] + [else + (define inliner (inline-function (car e) (length (cdr e)) (cdr e) in-lam knowns)) + (define args (apply string-append + (append + (add-between + (for/list ([e (in-list (cdr e))]) + (format "~a" (generate-simple e))) + ", ")))) + (cond + [(procedure? inliner) (if (procedure-arity-includes? inliner 2) + (inliner args (lambda (id) (top-ref in-lam id))) + (inliner args))] + [else + (format "~a(~a)" inliner args)])])) + (generate-simple e)) + +;; ---------------------------------------- + +(define (simple-quote? e) + (or (always-fixnum? e) + (boolean? e) + (null? e) + (void? e) + (and (char? e) + (<= 0 (char->integer e) 255)))) + +(define (always-fixnum? e) + (and (integer? e) + (exact? e) + (<= (- (expt 2 30)) e (sub1 (expt 2 30))))) diff --git a/racket/src/cify/sort.rkt b/racket/src/cify/sort.rkt new file mode 100644 index 0000000000..c49c75dd8d --- /dev/null +++ b/racket/src/cify/sort.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(provide in-sorted-hash + in-sorted-hash-keys + in-sorted-hash-values + + compare) + +(define (in-sorted-hash ht GC-independent leaf + +(struct vehicle ([id #:mutable] + [lams #:mutable] + [closure? #:mutable] + [uses-top? #:mutable] + [min-argc #:mutable] + [max-jump-argc #:mutable] + [max-runstack-depth #:mutable] + [called-direct? #:mutable] ; if the vehicle can be called directly + [calls-non-immediate? #:mutable])) + +(define (make-lam id e) + (define-values (min-argc max-argc) (lambda-arity e)) + (define a-vehicle (vehicle id '() #f #f min-argc 0 0 #f #f)) + (define a-lam (lam id e #f #f (make-hasheqv) 0 #f a-vehicle 0 #f #f #f #f #hasheq() #f)) + (set-vehicle-lams! a-vehicle (list a-lam)) + a-lam) + +(define (top-ref in-lam id) + (when in-lam + (set-vehicle-uses-top?! (lam-vehicle in-lam) #t)) + (format "c_top->~a" (cify id))) + +(define (lam-calls-non-immediate! in-lam) + (when in-lam + (set-vehicle-calls-non-immediate?! (lam-vehicle in-lam) #t))) + +(define (lam-called-direct! in-lam) + (when in-lam + (set-vehicle-called-direct?! (lam-vehicle in-lam) #t))) + +(define (lam-add-transitive-tail-apply! lam target-lam) + (set-lam-transitive-tail-applies! + lam + (hash-set (lam-transitive-tail-applies lam) target-lam #t))) + +(define (merge-vehicles! lambdas state) + (define vehicles + (for/fold ([vehicles #hash()]) ([lam (in-sorted-hash-values lambdas (compare symbolpath p)) + (or (find-executable-path p) + p) + p)) + orig-p)) + + (display (simplify-path (path->complete-path p)))]) + +;; In case there are extra arguments to an executable, preserve them +(for ([e (in-list extras)]) + (display " ") + (display e)) + +(newline) diff --git a/racket/src/cs/c/Makefile.in b/racket/src/cs/c/Makefile.in new file mode 100644 index 0000000000..571a5e6a5c --- /dev/null +++ b/racket/src/cs/c/Makefile.in @@ -0,0 +1,226 @@ +srcdir = @srcdir@ +builddir = @builddir@ + +SCHEME_SRC = @SCHEME_SRC@ +MACH = @MACH@ +SCHEME_BIN = $(SCHEME_SRC)/$(MACH)/bin/$(MACH)/scheme +SCHEME_INC = $(SCHEME_SRC)/$(MACH)/boot/$(MACH) +SCHEME = $(SCHEME_BIN) -b $(SCHEME_INC)/petite.boot -b $(SCHEME_INC)/scheme.boot + +CC = @CC@ +CFLAGS = @CFLAGS@ @CPPFLAGS@ -I$(SCHEME_INC) -I$(srcdir)/../../rktio -Irktio -I. +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +DEFAULT_RACKET = $(srcdir)/../../../bin/racket +RACKET = @RACKET@ +RACO = $(RACKET) -N raco -l- raco + +CS_INSTALLED = cs +CS_GR_INSTALLED = CS +bindir = $(srcdir)/../../../bin +libpltdir = $(srcdir)/../../../lib +docdir = $(srcdir)/../../../doc +sharepltdir = $(srcdir)/../../../share +configdir = $(srcdir)/../../../etc + +ALLDIRINFO = "$(DESTDIR)$(bindir)" \ + "$(DESTDIR)$(docdir)" \ + "$(DESTDIR)$(libpltdir)" \ + "$(DESTDIR)$(sharepltdir)" \ + "$(DESTDIR)$(configdir)" + +# Defines FWVERSION: +mainsrcdir = @srcdir@/../.. +@INCLUDEDEP@ @srcdir@/../../racket/version.mak + +cs: + $(MAKE) scheme + $(MAKE) racket-so + cd rktio; $(MAKE) + $(MAKE) racketcs + $(MAKE) gracketcs + $(MAKE) starter + +ABS_RACKET = "`$(RACKET) $(srcdir)/../absify.rkt --exec $(RACKET)`" +ABS_SCHEME_SRC = "`$(RACKET) $(srcdir)/../absify.rkt $(SCHEME_SRC)`" +ABS_SRCDIR = "`$(RACKET) $(srcdir)/../absify.rkt $(srcdir)`" +ABS_BUILDDIR = "`$(RACKET) $(srcdir)/../absify.rkt $(builddir)`" + +SETUP_BOOT = -W 'info@compiler/cm error' -l- setup --chain $(srcdir)/../../setup-go.rkt $(builddir)/compiled + +# We don't try to track dependencies through makefiles for things +# build with the expander extrator, hence "ignored" +BOOTSTRAP_RACKET = $(RACKET) $(SETUP_BOOT) ignored $(builddir)/ignored.d + +RKTIO_RACKET = $(RACKET) $(SETUP_BOOT) '(GENERATED_RKTIO_RKTL)' $(builddir)/rktio.d +CONVERT_RACKET = $(RACKET) $(SETUP_BOOT) + +racket-so: + $(MAKE) bounce TARGET=build-racket-so + +RACKET_SO_ENV = @CONFIGURE_RACKET_SO_COMPILE@ env COMPILED_SCM_DIR="$(builddir)/compiled/" + +build-racket-so: + $(MAKE) expander + $(MAKE) thread + $(MAKE) io + $(MAKE) regexp + $(MAKE) schemify + $(MAKE) known + cd $(srcdir)/.. && $(RACKET_SO_ENV) $(MAKE) "$(builddir)/racket.so" RACKET="$(RACKET)" SCHEME="$(SCHEME)" BUILDDIR="$(builddir)/" CONVERT_RACKET="$(CONVERT_RACKET)" + +bounce: + $(MAKE) RACKET="$(ABS_RACKET)" SCHEME_SRC="$(ABS_SCHEME_SRC)" srcdir="$(ABS_SRCDIR)" builddir="$(ABS_BUILDDIR)" $(TARGET) + +# You can't make `expander`, `thread`, etc., directly, because +# `builddir` and `srcdir` are not necessarily absolute. But you can +# `make bounce TARGET=expander`, etc. + +# This sequence essentially duplicates the handling of layers that is +# in "../Makefile", but it does so to swap in `BOOTSTRAP_RACKET` in +# place of `raco make` (to avoid a dependency on a package for `raco +# make`). + +expander: + cd $(srcdir)/../../expander && $(MAKE) expander-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +thread: + cd $(srcdir)/../../thread && $(MAKE) thread-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +io: + cd $(srcdir)/../../io && $(MAKE) io-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +regexp: + cd $(srcdir)/../../regexp && $(MAKE) regexp-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +schemify: + cd $(srcdir)/../../schemify && $(MAKE) schemify-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +known: + cd $(srcdir)/../../schemify && $(MAKE) known-src-generate RACKET="$(BOOTSTRAP_RACKET)" BUILDDIR="$(builddir)/" + +scheme: + $(MAKE) $(SCHEME_BIN) + +$(SCHEME_BIN): + cd @SCHEME_SRC@ && ./configure @SCHEME_CONFIG_ARGS@ + cd @SCHEME_SRC@ && make + +# ---------------------------------------- +# Unix + +EMBED_DEPS = $(srcdir)/embed-boot.rkt + +racketcs@NOT_OSX@: raw_racketcs racket.so $(EMBED_DEPS) + $(RACKET) $(srcdir)/embed-boot.rkt raw_racketcs racketcs $(SCHEME_INC) racket.so + +gracketcs@NOT_OSX@: raw_gracketcs racket.so $(EMBED_DEPS) + $(RACKET) $(srcdir)/embed-boot.rkt raw_gracketcs gracketcs $(SCHEME_INC) racket.so + +BOOT_OBJS = boot.o $(SCHEME_INC)/kernel.o rktio/librktio.a + +raw_racketcs: main.o boot.o $(BOOT_OBJS) + $(CC) $(CFLAGS) -o raw_racketcs main.o $(BOOT_OBJS) $(LDFLAGS) $(LIBS) + +raw_gracketcs: grmain.o boot.o $(BOOT_OBJS) + $(CC) $(CFLAGS) -o raw_gracketcs grmain.o $(BOOT_OBJS) $(LDFLAGS) $(LIBS) + +# ---------------------------------------- +# Mac OS + +RKTFWDIR = Racket.framework/Versions/$(FWVERSION)_CS +RKTFW = $(RKTFWDIR)/Racket +GRAPPSKEL = GRacketCS.app/Contents/Info.plist + +racketcs@OSX@: main.o $(RKTFW) + $(CC) $(CFLAGS) -o racketcs main.o -F. -framework Racket + /usr/bin/install_name_tool -change "Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@executable_path/Racket.framework/Versions/$(FWVERSION)_CS/Racket" racketcs + +GRACKET_BIN = GRacketCS.app/Contents/MacOS/GracketCS + +gracketcs@OSX@: + $(MAKE) $(GRACKET_BIN) + +$(GRACKET_BIN): grmain.o $(RKTFW) $(GRAPPSKEL) + $(CC) $(CFLAGS) -o $(GRACKET_BIN) grmain.o -F. -framework Racket + /usr/bin/install_name_tool -change "Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@executable_path/../../../Racket.framework/Versions/$(FWVERSION)_CS/Racket" $(GRACKET_BIN) + +$(GRAPPSKEL): $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../../racket/src/schvers.h $(srcdir)/../../mac/icon/GRacket.icns + env $(RACKET) $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "CS" + +BOOT_FILES = $(SCHEME_INC)/petite.boot $(SCHEME_INC)/scheme.boot racket.so + +$(RKTFW): $(BOOT_OBJS) $(BOOT_FILES) + mkdir -p Racket.framework/Versions/$(FWVERSION)_CS + @RKTLINKER@ -o $(RKTFW) @LDFLAGS@ -dynamiclib -all_load $(BOOT_OBJS) $(LDFLAGS) $(LIBS) + rm -f Racket.framework/Racket + ln -s Versions/$(FWVERSION)_CS/Racket Racket.framework/Racket + mkdir -p Racket.framework/Versions/$(FWVERSION)_CS/boot + cp $(SCHEME_INC)/petite.boot $(SCHEME_INC)/scheme.boot Racket.framework/Versions/$(FWVERSION)_CS/boot + cp racket.so Racket.framework/Versions/$(FWVERSION)_CS/boot + +# ---------------------------------------- +# Common + +DEF_COLLECTS_DIR = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"' +DEF_CONFIG_DIR = -DINITIAL_CONFIG_DIRECTORY='"'"`cd $(srcdir)/../../..; pwd`/etc"'"' +DEF_C_DIRS = $(DEF_COLLECTS_DIR) $(DEF_CONFIG_DIR) + +MAIN_DEPS = $(srcdir)/main.c $(srcdir)/boot.h $(srcdir)/../../start/config.inc + +main.o: $(MAIN_DEPS) + $(CC) $(CFLAGS) $(DEF_C_DIRS) -c -o main.o $(srcdir)/main.c + +grmain.o: $(srcdir)/grmain.c $(MAIN_DEPS) $(srcdir)/../../start/gui_filter.inc + $(CC) $(CFLAGS) $(DEF_C_DIRS) -c -o grmain.o $(srcdir)/grmain.c + +boot.o: $(srcdir)/boot.c $(srcdir)/../../rktio/rktio.inc $(srcdir)/boot.h + $(CC) $(CFLAGS) -c -o boot.o $(srcdir)/boot.c + +starter: $(srcdir)/../../start/ustart.c + $(CC) $(CFLAGS) -o starter $(srcdir)/../../start/ustart.c + +# ---------------------------------------- +# Install + +ICP=@ICP@ + +install: + $(MAKE) plain-install + $(srcdir)/../../../bin/racketcs $(SELF_RACKET_FLAGS) -N raco -l- raco setup $(PLT_SETUP_OPTIONS) + +plain-install@NOT_OSX@: + $(MAKE) unix-install + +plain-install@OSX@: + $(MAKE) macos-install + +common-install: + mkdir -p $(ALLDIRINFO) + $(ICP) racketcs "$(DESTDIR)$(bindir)/racket$(CS_INSTALLED)" + $(ICP) starter "$(DESTDIR)$(libpltdir)/starter" + $(ICP) $(srcdir)/../../start/starter-sh "$(DESTDIR)$(libpltdir)/starter-sh" + +unix-install: + $(MAKE) common-install + $(ICP) gracketcs "$(DESTDIR)$(libpltdir)/gracket$(CS_INSTALLED)" + +RKTFWDEST = @FRAMEWORK_INSTALL_DIR@/Racket.framework + +macos-install: + $(MAKE) common-install + rm -f $(DESTDIR)$(RKTFWDEST)/Racket + rm -rf $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS + mkdir -p $(DESTDIR)"$(RKTFWDEST)/Versions/$(FWVERSION)_CS" + cp $(RKTFW) $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/ + mkdir -p $(DESTDIR)"$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot" + cp $(RKTFWDIR)/boot/petite.boot $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot/ + cp $(RKTFWDIR)/boot/scheme.boot $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot/ + cp $(RKTFWDIR)/boot/racket.so $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot/ + /usr/bin/install_name_tool -change "@executable_path/Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@FRAMEWORK_PREFIX@Racket.framework/Versions/$(FWVERSION)_CS/Racket" $(DESTDIR)"$(bindir)/racket$(CS_GR_INSTALLED)" + rm -rf $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app" + $(ICP) -r "GRacketCS.app" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app" + $(RACKET) "$(srcdir)/../../mac/rename-app.rkt" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app" "GRacketCS" "GRacket$(CS_GR_INSTALLED)" no-up + /usr/bin/install_name_tool -change "@executable_path/../../../../racket/Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@FRAMEWORK_PREFIX@Racket.framework/Versions/$(FWVERSION)_CS/Racket" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app/Contents/MacOS/GRacket$(CS_GR_INSTALLED)" + $(RACKET) "$(srcdir)/../../racket/collects-path.rkt" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app/Contents/MacOS/GRacket$(CS_GR_INSTALLED)" ../../../../collects ../../../../etc diff --git a/racket/src/cs/c/README.txt b/racket/src/cs/c/README.txt new file mode 100644 index 0000000000..2e12ab9a30 --- /dev/null +++ b/racket/src/cs/c/README.txt @@ -0,0 +1,73 @@ +This directory contains a `configure` script and a makefile (template) +for building the variant of Racket that runs on Chez Scheme. The +result of the build is a `racketcs` executable that embeds both Chez +Scheme and the Racket startup code to behave the same as the +traditional `racket` executable. + +If you have a checkout of the main Racket repo, you can just use `make +cs` in the top-level directory of the repo to build Racket-on-Chez. +See "INSTALL.txt" in the top-level directory for more information. + +If you want to know more about how Racket-on-Chez is put together, see +"../README.txt". + +======================================================================== + Requirements +======================================================================== + +Building Racket-on-Chez requires both an existing Racket build and +Chez Scheme build: + + * By default, the build uses Racket as built and installed in-place + in the same way as described in "../../README", so that the Racket + executable is "../../../bin/racket". + + You can select a different Racket excutable by supplying + `--enable-racket=...` to `configure`. + + * By default, the build uses Chez Scheme as built in a "ChezScheme" + sibling directory of the build directory. The Racket-on-Chez build + needs a Chez Scheme build directory, and not an end-user Chez + Scheme installation, because it needs "kernel.o" as created in a + Chez Scheme build; it may also need makefiles or other scripts in + the Chez Scheme build directory. + + See "../README.txt" for information on the required Chez Scheme + version. + + You can select a different Chez Scheme build path by supplying + `--enable-scheme=...` to `configure`. + +======================================================================== + Compiling for supported Unix variants (including Linux and Mac OS) +======================================================================== + +From two directories up, run the following commands: + + mkdir build + cd build + ../cs/c/configure + make + make install + +Those commands will create an in-place installation of Racket and +store the results of various compilation steps in a separate "build" +subdirectory, which is useful if you need to update your sources, +delete the build, and start from scratch. + +You can also run the typical `./configure && make && make install` if +you don't anticipate updating/rebuilding, but it will be harder to +restart from scratch should you need to. + +======================================================================== + Compiling for Windows +======================================================================== + +Compilation for Windows on Windows requires building the traditional +Racket implementation. Then, from the directory "..\..\worksp", run + + ..\..\racket csbuild.rkt + +Many intermediate files will be put in "../../build", including a Chez +Scheme checkout if it's not already present (in whcih case `git` must +be available). diff --git a/racket/src/cs/c/boot.c b/racket/src/cs/c/boot.c new file mode 100644 index 0000000000..6287a95ca1 --- /dev/null +++ b/racket/src/cs/c/boot.c @@ -0,0 +1,138 @@ +#ifndef _MSC_VER +# include +#endif +#include +#include +#include +#include +#include "scheme.h" +#include "rktio.h" +#include "boot.h" + +#if defined(OS_X) && !defined(RACKET_XONX) + +# include +# define RACKET_USE_FRAMEWORK + +const char *get_framework_path() { + int i, c, len; + const char *s; + + c = _dyld_image_count(); + for (i = 0; i < c; i++) { + s = _dyld_get_image_name(i); + len = strlen(s); + if ((len > 9) && !strcmp("CS/Racket", s + len - 9)) { + char *s2; + s2 = strdup(s); + strcpy(s2 + len - 6, "boot"); + return s2; + } + } + + return "???"; +} + +char *path_append(const char *p1, char *p2) { + int l1, l2; + char *s; + l1 = strlen(p1); + l2 = strlen(p2); + s = malloc(l1 + l2 + 2); + memcpy(s, p1, l1); + s[l1] = '/'; + memcpy(s + l1 + 1, p2, l2); + s[l1+l2+1] = 0; + return s; +} + +#endif + +static ptr Sbytevector(char *s) +{ + iptr len = strlen(s); + ptr bv; + bv = Smake_bytevector(len, 0); + memcpy(Sbytevector_data(bv), s, len); + return bv; +} + +static void racket_exit(int v) +{ + exit(v); +} + +void racket_boot(int argc, char **argv, char *self, long segment_offset, + char *coldir, char *configdir, + int pos1, int pos2, int pos3, + int is_gui) +/* exe argument already stripped from argv */ +{ + int fd; +#ifdef RACKET_USE_FRAMEWORK + const char *fw_path; +#endif + + Sscheme_init(NULL); + +#ifdef RACKET_USE_FRAMEWORK + fw_path = get_framework_path(); + Sregister_boot_file(path_append(fw_path, "petite.boot")); + Sregister_boot_file(path_append(fw_path, "scheme.boot")); +#else + fd = open(self, O_RDONLY | O_BINARY); + + { + int fd1, fd2; + + fd1 = dup(fd); + lseek(fd1, pos1, SEEK_SET); + Sregister_boot_file_fd("petite", fd1); + + fd2 = open(self, O_RDONLY | O_BINARY); + lseek(fd2, pos2, SEEK_SET); + Sregister_boot_file_fd("scheme", fd2); + } +#endif + + Sbuild_heap(NULL, NULL); + +# include "rktio.inc" + Sforeign_symbol("racket_exit", (void *)racket_exit); + + { + ptr l = Snil; + int i; + char segment_offset_s[32]; + + for (i = argc; i--; ) { + l = Scons(Sbytevector(argv[i]), l); + } + l = Scons(Sbytevector(is_gui ? "true" : "false"), l); + sprintf(segment_offset_s, "%ld", segment_offset); + l = Scons(Sbytevector(segment_offset_s), l); + l = Scons(Sbytevector(configdir), l); + l = Scons(Sbytevector(coldir), l); + l = Scons(Sbytevector(self), l); + Sset_top_level_value(Sstring_to_symbol("bytes-command-line-arguments"), l); + } + +#ifdef RACKET_USE_FRAMEWORK + fd = open(path_append(fw_path, "racket.so"), O_RDONLY); + pos3 = 0; +#endif + + { + ptr c, p; + + if (pos3) lseek(fd, pos3, SEEK_SET); + c = Stop_level_value(Sstring_to_symbol("open-fd-input-port")); + p = Scall1(c, Sfixnum(fd)); + Slock_object(p); + c = Stop_level_value(Sstring_to_symbol("port-file-compressed!")); + Scall1(c, p); + Sunlock_object(p); + c = Stop_level_value(Sstring_to_symbol("load-compiled-from-port")); + Scall1(c, p); + } +} diff --git a/racket/src/cs/c/boot.h b/racket/src/cs/c/boot.h new file mode 100644 index 0000000000..ea2278663f --- /dev/null +++ b/racket/src/cs/c/boot.h @@ -0,0 +1,4 @@ +void racket_boot(int argc, char **argv, char *self, long segment_offset, + char *coldir, char *configdir, + int pos1, int pos2, int pos3, + int is_gui); diff --git a/racket/src/cs/c/configure b/racket/src/cs/c/configure new file mode 100755 index 0000000000..30a11c8f55 --- /dev/null +++ b/racket/src/cs/c/configure @@ -0,0 +1,5202 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69. +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 +test \$(( 1 + 1 )) = 2 || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= +PACKAGE_URL= + +ac_unique_file="embed-boot.rkt" +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_STAT_H +# include +#endif +#ifdef STDC_HEADERS +# include +# include +#else +# ifdef HAVE_STDLIB_H +# include +# endif +#endif +#ifdef HAVE_STRING_H +# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +# include +# endif +# include +#endif +#ifdef HAVE_STRINGS_H +# include +#endif +#ifdef HAVE_INTTYPES_H +# include +#endif +#ifdef HAVE_STDINT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif" + +ac_subst_vars='LTLIBOBJS +LIBOBJS +FRAMEWORK_PREFIX +FRAMEWORK_INSTALL_DIR +SCHEME_CONFIG_ARGS +SCHEME_SRC +CONFIGURE_RACKET_SO_COMPILE +NOT_OSX +OSX +MACH +SCHEME_DIR +RACKET +INCLUDEDEP +RKTLINKER +ICP +STATIC_AR +RANLIB +ARFLAGS +AR +EGREP +GREP +CPP +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +target_os +target_vendor +target_cpu +target +host_os +host_vendor +host_cpu +host +build_os +build_vendor +build_cpu +build +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +enable_shared +enable_standalone +enable_pthread +enable_iconv +enable_xonx +enable_racket +enable_scheme +enable_mach +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +CPP' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF + +System types: + --build=BUILD configure for building on BUILD [guessed] + --host=HOST cross-compile to build programs to run on HOST [BUILD] + --target=TARGET configure for building compilers for TARGET [HOST] +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-shared create shared libraries (ok, but not recommended) + --enable-standalone create a standalone shared library + --enable-pthread link with pthreads (usually auto-enabled if needed) + --enable-iconv use iconv (usually auto-enabled) + --enable-xonx use Unix style (e.g., use Gtk) for Mac OS + --enable-racket= use as Racket to build; or "auto" to create + --enable-scheme= Chez Scheme build directory at + --enable-mach= Use Chez Scheme machine type + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + CPP C preprocessor + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to the package provider. +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +configure +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link + +# ac_fn_c_try_cpp LINENO +# ---------------------- +# Try to preprocess conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_cpp () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_cpp + +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel + +# ac_fn_c_try_run LINENO +# ---------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes +# that executables *can* be run. +ac_fn_c_try_run () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then : + ac_retval=0 +else + $as_echo "$as_me: program exited with status $ac_status" >&5 + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=$ac_status +fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_run + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +ac_config_headers="$ac_config_headers cs_config.h" + + +ac_aux_dir= +for ac_dir in ../../lt "$srcdir"/../../lt; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + as_fn_error $? "cannot find install-sh, install.sh, or shtool in ../../lt \"$srcdir\"/../../lt" "$LINENO" 5 +fi + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. + + +# Make sure we can run config.sub. +$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || + as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 +$as_echo_n "checking build system type... " >&6; } +if ${ac_cv_build+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_build_alias=$build_alias +test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` +test "x$ac_build_alias" = x && + as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 +ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 +$as_echo "$ac_cv_build" >&6; } +case $ac_cv_build in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; +esac +build=$ac_cv_build +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_build +shift +build_cpu=$1 +build_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +build_os=$* +IFS=$ac_save_IFS +case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 +$as_echo_n "checking host system type... " >&6; } +if ${ac_cv_host+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build +else + ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 +$as_echo "$ac_cv_host" >&6; } +case $ac_cv_host in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; +esac +host=$ac_cv_host +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_host +shift +host_cpu=$1 +host_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +host_os=$* +IFS=$ac_save_IFS +case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking target system type" >&5 +$as_echo_n "checking target system type... " >&6; } +if ${ac_cv_target+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "x$target_alias" = x; then + ac_cv_target=$ac_cv_host +else + ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_target" >&5 +$as_echo "$ac_cv_target" >&6; } +case $ac_cv_target in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical target" "$LINENO" 5;; +esac +target=$ac_cv_target +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_target +shift +target_cpu=$1 +target_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +target_os=$* +IFS=$ac_save_IFS +case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac + + +# The aliases save the names the user supplied, while $host etc. +# will get canonicalized. +test -n "$target_alias" && + test "$program_prefix$program_suffix$program_transform_name" = \ + NONENONEs,x,x, && + program_prefix=${target_alias}- + + +# Check whether --enable-shared was given. +if test "${enable_shared+set}" = set; then : + enableval=$enable_shared; +fi + +# Check whether --enable-standalone was given. +if test "${enable_standalone+set}" = set; then : + enableval=$enable_standalone; +fi + +# Check whether --enable-pthread was given. +if test "${enable_pthread+set}" = set; then : + enableval=$enable_pthread; +fi + +# Check whether --enable-iconv was given. +if test "${enable_iconv+set}" = set; then : + enableval=$enable_iconv; +fi + +# Check whether --enable-xonx was given. +if test "${enable_xonx+set}" = set; then : + enableval=$enable_xonx; +fi + +# Check whether --enable-racket was given. +if test "${enable_racket+set}" = set; then : + enableval=$enable_racket; +fi + +# Check whether --enable-scheme was given. +if test "${enable_scheme+set}" = set; then : + enableval=$enable_scheme; +fi + +# Check whether --enable-mach was given. +if test "${enable_mach+set}" = set; then : + enableval=$enable_mach; +fi + + +show_explicitly_disabled() +{ + if test "$1" = "no" ; then + echo "=== $2 disabled" + fi +} + +show_explicitly_enabled() +{ + if test "$1" = "yes" ; then + echo "=== $2 enabled" + if test "$3" != "" ; then + echo " $3" + fi + fi +} + +show_explicitly_set() +{ + if test "$1" != "" ; then + echo "=== $2 set to $1" + fi +} + +show_explicitly_enabled "${enable_pthread}" "pthreads" +show_explicitly_disabled "${enable_pthread}" "pthreads" +show_explicitly_enabled "${enable_xonx}" "Unix style" +show_explicitly_set "${enable_racket}" "Racket" +show_explicitly_set "${enable_scheme}" "Chez Scheme build directory" +show_explicitly_set "${enable_mach}" "machine type" + +if test "${enable_iconv}" = "" ; then + enable_iconv=yes +fi + +if test "${enable_xonx}" == "" ; then + enable_xonx=no +fi + +skip_iconv_check=no +use_flag_pthread=yes +use_flag_posix_pthread=no + +INCLUDEDEP="#" +OSX="not_osx" +NOT_OSX="" +CONFIGURE_RACKET_SO_COMPILE="" + +FRAMEWORK_INSTALL_DIR='$(srcdir)/../../../lib/' +FRAMEWORK_PREFIX='@executable_path/../lib/' + +RACKET='$(DEFAULT_RACKET)' + +enable_pthread_by_default=yes + +###### Autoconfigure ####### + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi + + +test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } + +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +$as_echo_n "checking whether the C compiler works... " >&6; } +ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "C compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 +$as_echo_n "checking for C compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +$as_echo_n "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +$as_echo_n "checking for suffix of object files... " >&6; } +if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +$as_echo "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 +$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } +if ${ac_cv_c_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 +$as_echo "$ac_cv_c_compiler_gnu" >&6; } +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +$as_echo_n "checking whether $CC accepts -g... " >&6; } +if ${ac_cv_prog_cc_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +else + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 +$as_echo "$ac_cv_prog_cc_g" >&6; } +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 +$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +struct stat; +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c89" != xno; then : + +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +# If using gcc, we want all warnings: +if test "$CC" = "gcc" ; then + CFLAGS="$CFLAGS -Wall" +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for fmod in -lm" >&5 +$as_echo_n "checking for fmod in -lm... " >&6; } +if ${ac_cv_lib_m_fmod+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char fmod (); +int +main () +{ +return fmod (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_m_fmod=yes +else + ac_cv_lib_m_fmod=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_fmod" >&5 +$as_echo "$ac_cv_lib_m_fmod" >&6; } +if test "x$ac_cv_lib_m_fmod" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBM 1 +_ACEOF + + LIBS="-lm $LIBS" + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +$as_echo_n "checking for dlopen in -ldl... " >&6; } +if ${ac_cv_lib_dl_dlopen+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int +main () +{ +return dlopen (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dl_dlopen=yes +else + ac_cv_lib_dl_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 +$as_echo "$ac_cv_lib_dl_dlopen" >&6; } +if test "x$ac_cv_lib_dl_dlopen" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBDL 1 +_ACEOF + + LIBS="-ldl $LIBS" + +fi + + +############## platform tests ################ + +case "$host_os" in + solaris2*) + MACH_OS=s2 + ;; + aix*) + ;; + *freebsd*) + MACH_OS=fb + ;; + openbsd*) + MACH_OS=ob + ;; + bitrig*) + ;; + dragonfly*) + ;; + netbsd*) + MACH_OS=nb + ;; + irix*) + ;; + linux*) + MACH_OS=le + LIBS="${LIBS} -lncurses" + ;; + osf1*) + ;; + hpux*) + ;; + *mingw*) + skip_iconv_check=yes + ;; + cygwin*) + ;; + darwin*) + PREFLAGS="$PREFLAGS -DOS_X" + MACH_OS=osx + LIBS="${LIBS} -lncurses -framework CoreFoundation" + if test "${enable_xonx}" == "no" ; then + INCLUDEDEP="-include" + OSX="" + NOT_OSX="osx" + else + CONFIGURE_RACKET_SO_COMPILE="env PLT_CS_MAKE_UNIX_STYLE_MACOS=y" + CPPFLAGS="${CPPFLAGS} -DRACKET_XONX" + fi + + # -pthread is not needed and triggers a warning + use_flag_pthread=no + ;; + nto-qnx*) + MACH_OS=qnx + use_flag_pthread=no + ;; + *) + ;; +esac + +case "$host_cpu" in + arm*) + enable_pthread_by_default=no + ;; +esac + +if test "${enable_pthread}" = "" ; then + if test "${enable_pthread_by_default}" = "yes" ; then + enable_pthread=yes + fi +fi + +thread_prefix="" +thread_config_arg="" +if test "${enable_pthread}" = "yes" ; then + thread_prefix="t" + thread_config_arg="--threads" +fi + +case "$host_cpu" in + x86_64) + MACH="${thread_prefix}a6${MACH_OS}" + ;; + x86|i*86) + MACH="${thread_prefix}i3${MACH_OS}" + ;; + arm*) + MACH="${thread_prefix}arm32${MACH_OS}" + ;; + power*) + MACH="${thread_prefix}ppc32${MACH_OS}" + ;; +esac + +SCHEME_SRC=../ChezScheme + +if test "${enable_scheme}" != "" ; then + SCHEME_SRC="${enable_scheme}" +fi + +if test "${enable_racket}" != "" ; then + RACKET="${enable_racket}" +fi + +if test "${enable_mach}" != "" ; then + MACH="${enable_mach}" +fi + +SCHEME_CONFIG_ARGS="--machine=${MACH} ${thread_config_arg}" + +############## C flags ################ + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +iconv_lib_flag="" +if test "${skip_iconv_check}" = "no" ; then + if test "${enable_iconv}" = "yes" ; then + ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 +$as_echo_n "checking how to run the C preprocessor... " >&6; } +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if ${ac_cv_prog_CPP+:} false; then : + $as_echo_n "(cached) " >&6 +else + # Double quotes because CPP needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 +$as_echo "$CPP" >&6; } +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details" "$LINENO" 5; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 +$as_echo_n "checking for grep that handles long lines and -e... " >&6; } +if ${ac_cv_path_GREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -z "$GREP"; then + ac_path_GREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in grep ggrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_GREP" || continue +# Check for GNU ac_path_GREP and select it if it is found. + # Check for GNU $ac_path_GREP +case `"$ac_path_GREP" --version 2>&1` in +*GNU*) + ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'GREP' >> "conftest.nl" + "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_GREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_GREP="$ac_path_GREP" + ac_path_GREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_GREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_GREP"; then + as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_GREP=$GREP +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 +$as_echo "$ac_cv_path_GREP" >&6; } + GREP="$ac_cv_path_GREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 +$as_echo_n "checking for egrep... " >&6; } +if ${ac_cv_path_EGREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 + then ac_cv_path_EGREP="$GREP -E" + else + if test -z "$EGREP"; then + ac_path_EGREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in egrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_EGREP" || continue +# Check for GNU ac_path_EGREP and select it if it is found. + # Check for GNU $ac_path_EGREP +case `"$ac_path_EGREP" --version 2>&1` in +*GNU*) + ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'EGREP' >> "conftest.nl" + "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_EGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_EGREP="$ac_path_EGREP" + ac_path_EGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_EGREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_EGREP"; then + as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_EGREP=$EGREP +fi + + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 +$as_echo "$ac_cv_path_EGREP" >&6; } + EGREP="$ac_cv_path_EGREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 +$as_echo_n "checking for ANSI C header files... " >&6; } +if ${ac_cv_header_stdc+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#include +#include + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_header_stdc=yes +else + ac_cv_header_stdc=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then : + : +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + return 2; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +else + ac_cv_header_stdc=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 +$as_echo "$ac_cv_header_stdc" >&6; } +if test $ac_cv_header_stdc = yes; then + +$as_echo "#define STDC_HEADERS 1" >>confdefs.h + +fi + +# On IRIX 5.3, sys/types and inttypes.h are conflicting. +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default +" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +ac_fn_c_check_header_mongrel "$LINENO" "iconv.h" "ac_cv_header_iconv_h" "$ac_includes_default" +if test "x$ac_cv_header_iconv_h" = xyes; then : + enable_iconv=yes +else + enable_iconv=no +fi + + + if test "${enable_iconv}" = "yes" ; then + # Does it all work, now? + if test "$cross_compiling" = yes; then : + enable_iconv=yes +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + #include + #include + int main() { + iconv_open("UTF-8", "UTF-8"); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + enable_iconv=yes +else + enable_iconv=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + if test "${enable_iconv}" = "no" ; then + # Try adding -liconv ? + # We did not use AC_CHECK_LIB because iconv is sometimes macro-renamed + ORIG_LIBS="$LIBS" + LIBS="$LIBS -liconv" + if test "$cross_compiling" = yes; then : + enable_iconv=yes +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + #include + #include + int main() { + iconv_open("UTF-8", "UTF-8"); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + enable_iconv=yes +else + enable_iconv=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + if test "${enable_iconv}" = "no" ; then + LIBS="$ORIG_LIBS" + else + iconv_lib_flag=" -liconv" + fi + fi + fi + fi + msg="iconv is usable" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking $msg" >&5 +$as_echo_n "checking $msg... " >&6; } + iconv_usage_result="$enable_iconv$iconv_lib_flag" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $iconv_usage_result" >&5 +$as_echo "$iconv_usage_result" >&6; } +fi +if test "${enable_iconv}" = "no" ; then + +$as_echo "#define RKTIO_NO_ICONV 1" >>confdefs.h + +fi + +if test "${enable_iconv}" = "yes" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for nl_langinfo (CODESET)" >&5 +$as_echo_n "checking for nl_langinfo (CODESET)... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +char *codeset = nl_langinfo (CODESET); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + +$as_echo "#define RKTIO_HAVE_CODESET 1" >>confdefs.h + + have_codeset=yes +else + have_codeset=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_codeset" >&5 +$as_echo "$have_codeset" >&6; } +fi + +############### pthread ################### + +if test "${enable_pthread}" = "yes" ; then + if test "${use_flag_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" + fi + if test "${use_flag_posix_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -D_POSIX_PTHREAD_SEMANTICS -D_REENTRANT" + fi + +$as_echo "#define RKTIO_USE_PTHREADS 1" >>confdefs.h + +fi + +############## libtool ################ + +if test "${enable_shared}" = "yes" ; then + echo "Configuring libtool" + + # Assuming an absolute "${libdir}": + abslibdir="${libdir}" + + if test ! -d "../../lt" ; then + mkdir "../../lt" + fi + abssrcdir=`(cd ${srcdir}; pwd)` + + if test "${LIBTOOLPROG}" = "" ; then + (cd ../lt; sh ${abssrcdir}/../lt/configure --enable-shared --disable-static) + LIBTOOLPROG=`pwd`/../lt/libtool + fi + + if test "${need_gcc_static_libgcc}" = "yes" ; then + need_gcc_static_libgcc="" + if test "$CC" = "gcc" ; then + gcc_vers_three=`${CC} -v 2>&1 | grep "version 3."` + if test "$gcc_vers_three" = "" ; then + need_gcc_static_libgcc="" + else + need_gcc_static_libgcc=" -XCClinker -static-libgcc" + fi + fi + fi + + # Use only for standalone builds: + AR="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}${ar_libtool_no_undefined} -release ${rktio_version} -rpath ${abslibdir} \$(ARLIBFLAGS) -o" + # Used for a librktio convenience library: + STATIC_AR="${LIBTOOLPROG} --mode=link --tag=CC $CC -o" + ARFLAGS="" + RANLIB=":" + + RKTLINKER="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}" + CC="${LIBTOOLPROG} --mode=compile --tag=CC $CC" + LTO="lo" + LTA="la" + STRIP_LIB_DEBUG=":" + LIBSFX=la + ICP_LIB="${LIBTOOLPROG} --mode=install install -s" +else + ICP=cp + LTO="o" + LTA="a" + RKTLINKER='$(CC)' + STATIC_AR="$AR" + LIBSFX=so + ICP_LIB=cp + if test "${make_darwin_dylib}" = "yes" ; then + LIBSFX="dylib" + AR='$(RKTLINKER) --shared -o' + ARFLAGS="" + LIBS="${LIBS} -framework CoreFoundation" + ICP_LIB=cp + fi +fi + +############## final output ################ + +CPPFLAGS="$CPPFLAGS $PREFLAGS" + + + + + + + + + + + + + + + + + + + + + + + + +makefiles="Makefile" + +ac_config_files="$ac_config_files $makefiles" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + +case $ac_config_headers in *" +"*) set x $ac_config_headers; shift; ac_config_headers=$*;; +esac + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" +config_headers="$ac_config_headers" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to the package provider." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append CONFIG_HEADERS " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + as_fn_error $? "ambiguous option: \`$1' +Try \`$0 --help' for more information.";; + --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "cs_config.h") CONFIG_HEADERS="$CONFIG_HEADERS cs_config.h" ;; + "$makefiles") CONFIG_FILES="$CONFIG_FILES $makefiles" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + +# Set up the scripts for CONFIG_HEADERS section. +# No need to generate them if there are no CONFIG_HEADERS. +# This happens for instance with `./config.status Makefile'. +if test -n "$CONFIG_HEADERS"; then +cat >"$ac_tmp/defines.awk" <<\_ACAWK || +BEGIN { +_ACEOF + +# Transform confdefs.h into an awk script `defines.awk', embedded as +# here-document in config.status, that substitutes the proper values into +# config.h.in to produce config.h. + +# Create a delimiter string that does not exist in confdefs.h, to ease +# handling of long lines. +ac_delim='%!_!# ' +for ac_last_try in false false :; do + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +# For the awk script, D is an array of macro values keyed by name, +# likewise P contains macro parameters if any. Preserve backslash +# newline sequences. + +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +sed -n ' +s/.\{148\}/&'"$ac_delim"'/g +t rset +:rset +s/^[ ]*#[ ]*define[ ][ ]*/ / +t def +d +:def +s/\\$// +t bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3"/p +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p +d +:bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3\\\\\\n"\\/p +t cont +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p +t cont +d +:cont +n +s/.\{148\}/&'"$ac_delim"'/g +t clear +:clear +s/\\$// +t bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/"/p +d +:bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p +b cont +' >$CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + for (key in D) D_is_set[key] = 1 + FS = "" +} +/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { + line = \$ 0 + split(line, arg, " ") + if (arg[1] == "#") { + defundef = arg[2] + mac1 = arg[3] + } else { + defundef = substr(arg[1], 2) + mac1 = arg[2] + } + split(mac1, mac2, "(") #) + macro = mac2[1] + prefix = substr(line, 1, index(line, defundef) - 1) + if (D_is_set[macro]) { + # Preserve the white space surrounding the "#". + print prefix "define", macro P[macro] D[macro] + next + } else { + # Replace #undef with comments. This is necessary, for example, + # in the case of _POSIX_SOURCE, which is predefined and required + # on some systems where configure will not decide to define it. + if (defundef == "undef") { + print "/*", prefix defundef, macro, "*/" + next + } + } +} +{ print } +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 +fi # test -n "$CONFIG_HEADERS" + + +eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + :H) + # + # CONFIG_HEADER + # + if test x"$ac_file" != x-; then + { + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 +$as_echo "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" + mv "$ac_tmp/config.h" "$ac_file" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ + || as_fn_error $? "could not create -" "$LINENO" 5 + fi + ;; + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + +mkdir -p rktio +abssrcdir=`(cd ${srcdir}; pwd)` +echo "=== configuring in rktio (${abssrcdir}/../../rktio)" +cd rktio; ${abssrcdir}/../../rktio/configure diff --git a/racket/src/cs/c/configure.ac b/racket/src/cs/c/configure.ac new file mode 100644 index 0000000000..09350c1282 --- /dev/null +++ b/racket/src/cs/c/configure.ac @@ -0,0 +1,363 @@ + +################################################################# +# This is the source for the `configure` script, to be compiled # +# by autoconf (use `make-configure` in "../../racket"). # +################################################################# + +AC_INIT([embed-boot.rkt]) +AC_CONFIG_HEADERS([cs_config.h]) + +AC_CONFIG_AUX_DIR(../../lt) +AC_CANONICAL_SYSTEM + +AC_ARG_ENABLE(shared, [ --enable-shared create shared libraries (ok, but not recommended)]) +AC_ARG_ENABLE(standalone, [ --enable-standalone create a standalone shared library]) +AC_ARG_ENABLE(pthread, [ --enable-pthread link with pthreads (usually auto-enabled if needed)]) +AC_ARG_ENABLE(iconv, [ --enable-iconv use iconv (usually auto-enabled)]) +AC_ARG_ENABLE(xonx, [ --enable-xonx use Unix style (e.g., use Gtk) for Mac OS]) +AC_ARG_ENABLE(racket, [ --enable-racket= use as Racket to build; or "auto" to create]) +AC_ARG_ENABLE(scheme, [ --enable-scheme= Chez Scheme build directory at ]) +AC_ARG_ENABLE(mach, [ --enable-mach= Use Chez Scheme machine type ]) + +show_explicitly_disabled() +{ + if test "$1" = "no" ; then + echo "=== $2 disabled" + fi +} + +show_explicitly_enabled() +{ + if test "$1" = "yes" ; then + echo "=== $2 enabled" + if test "$3" != "" ; then + echo " $3" + fi + fi +} + +show_explicitly_set() +{ + if test "$1" != "" ; then + echo "=== $2 set to $1" + fi +} + +show_explicitly_enabled "${enable_pthread}" "pthreads" +show_explicitly_disabled "${enable_pthread}" "pthreads" +show_explicitly_enabled "${enable_xonx}" "Unix style" +show_explicitly_set "${enable_racket}" "Racket" +show_explicitly_set "${enable_scheme}" "Chez Scheme build directory" +show_explicitly_set "${enable_mach}" "machine type" + +if test "${enable_iconv}" = "" ; then + enable_iconv=yes +fi + +if test "${enable_xonx}" == "" ; then + enable_xonx=no +fi + +skip_iconv_check=no +use_flag_pthread=yes +use_flag_posix_pthread=no + +INCLUDEDEP="#" +OSX="not_osx" +NOT_OSX="" +CONFIGURE_RACKET_SO_COMPILE="" + +FRAMEWORK_INSTALL_DIR='$(srcdir)/../../../lib/' +FRAMEWORK_PREFIX='@executable_path/../lib/' + +RACKET='$(DEFAULT_RACKET)' + +enable_pthread_by_default=yes + +###### Autoconfigure ####### + +AC_PROG_CC + +# If using gcc, we want all warnings: +if test "$CC" = "gcc" ; then + CFLAGS="$CFLAGS -Wall" +fi + +AC_CHECK_LIB(m, fmod) +AC_CHECK_LIB(dl, dlopen) + +############## platform tests ################ + +case "$host_os" in + solaris2*) + MACH_OS=s2 + ;; + aix*) + ;; + *freebsd*) + MACH_OS=fb + ;; + openbsd*) + MACH_OS=ob + ;; + bitrig*) + ;; + dragonfly*) + ;; + netbsd*) + MACH_OS=nb + ;; + irix*) + ;; + linux*) + MACH_OS=le + LIBS="${LIBS} -lncurses" + ;; + osf1*) + ;; + hpux*) + ;; + *mingw*) + skip_iconv_check=yes + ;; + cygwin*) + ;; + darwin*) + PREFLAGS="$PREFLAGS -DOS_X" + MACH_OS=osx + LIBS="${LIBS} -lncurses -framework CoreFoundation" + if test "${enable_xonx}" == "no" ; then + INCLUDEDEP="-include" + OSX="" + NOT_OSX="osx" + else + CONFIGURE_RACKET_SO_COMPILE="env PLT_CS_MAKE_UNIX_STYLE_MACOS=y" + CPPFLAGS="${CPPFLAGS} -DRACKET_XONX" + fi + + # -pthread is not needed and triggers a warning + use_flag_pthread=no + ;; + nto-qnx*) + MACH_OS=qnx + use_flag_pthread=no + ;; + *) + ;; +esac + +case "$host_cpu" in + arm*) + enable_pthread_by_default=no + ;; +esac + +if test "${enable_pthread}" = "" ; then + if test "${enable_pthread_by_default}" = "yes" ; then + enable_pthread=yes + fi +fi + +thread_prefix="" +thread_config_arg="" +if test "${enable_pthread}" = "yes" ; then + thread_prefix="t" + thread_config_arg="--threads" +fi + +case "$host_cpu" in + x86_64) + MACH="${thread_prefix}a6${MACH_OS}" + ;; + x86|i*86) + MACH="${thread_prefix}i3${MACH_OS}" + ;; + arm*) + MACH="${thread_prefix}arm32${MACH_OS}" + ;; + power*) + MACH="${thread_prefix}ppc32${MACH_OS}" + ;; +esac + +SCHEME_SRC=../ChezScheme + +if test "${enable_scheme}" != "" ; then + SCHEME_SRC="${enable_scheme}" +fi + +if test "${enable_racket}" != "" ; then + RACKET="${enable_racket}" +fi + +if test "${enable_mach}" != "" ; then + MACH="${enable_mach}" +fi + +SCHEME_CONFIG_ARGS="--machine=${MACH} ${thread_config_arg}" + +############## C flags ################ + +AC_LANG_C + +iconv_lib_flag="" +if test "${skip_iconv_check}" = "no" ; then + if test "${enable_iconv}" = "yes" ; then + AC_CHECK_HEADER(iconv.h, enable_iconv=yes, enable_iconv=no) + if test "${enable_iconv}" = "yes" ; then + # Does it all work, now? + AC_TRY_RUN( +[ #include ] +[ #include ] + int main() { +[ iconv_open("UTF-8", "UTF-8");] + return 0; + }, enable_iconv=yes, enable_iconv=no, enable_iconv=yes) + if test "${enable_iconv}" = "no" ; then + # Try adding -liconv ? + # We did not use AC_CHECK_LIB because iconv is sometimes macro-renamed + ORIG_LIBS="$LIBS" + LIBS="$LIBS -liconv" + AC_TRY_RUN( +[ #include ] +[ #include ] + int main() { +[ iconv_open("UTF-8", "UTF-8");] + return 0; + }, enable_iconv=yes, enable_iconv=no, enable_iconv=yes) + if test "${enable_iconv}" = "no" ; then + LIBS="$ORIG_LIBS" + else + iconv_lib_flag=" -liconv" + fi + fi + fi + fi + [ msg="iconv is usable" ] + AC_MSG_CHECKING($msg) + iconv_usage_result="$enable_iconv$iconv_lib_flag" + AC_MSG_RESULT($iconv_usage_result) +fi +if test "${enable_iconv}" = "no" ; then + AC_DEFINE(RKTIO_NO_ICONV,1,[Do not use iconv]) +fi + +if test "${enable_iconv}" = "yes" ; then + AC_MSG_CHECKING([for nl_langinfo (CODESET)]) + AC_TRY_LINK([#include ], + [char *codeset = nl_langinfo (CODESET);], + AC_DEFINE(RKTIO_HAVE_CODESET,1,[Have nl_langinfo (CODESET)]) + have_codeset=yes, + have_codeset=no) + AC_MSG_RESULT($have_codeset) +fi + +############### pthread ################### + +if test "${enable_pthread}" = "yes" ; then + if test "${use_flag_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" + fi + if test "${use_flag_posix_pthread}" = "yes" ; then + PREFLAGS="$PREFLAGS -D_POSIX_PTHREAD_SEMANTICS -D_REENTRANT" + fi + AC_DEFINE(RKTIO_USE_PTHREADS, 1, [Pthread enabled]) +fi + +############## libtool ################ + +if test "${enable_shared}" = "yes" ; then + echo "Configuring libtool" + + # Assuming an absolute "${libdir}": + abslibdir="${libdir}" + + if test ! -d "../../lt" ; then + mkdir "../../lt" + fi + abssrcdir=`(cd ${srcdir}; pwd)` + + if test "${LIBTOOLPROG}" = "" ; then + (cd ../lt; sh ${abssrcdir}/../lt/configure --enable-shared --disable-static) + LIBTOOLPROG=`pwd`/../lt/libtool + fi + + if test "${need_gcc_static_libgcc}" = "yes" ; then + need_gcc_static_libgcc="" + if test "$CC" = "gcc" ; then + gcc_vers_three=`${CC} -v 2>&1 | grep "version 3[.]"` + if test "$gcc_vers_three" = "" ; then + need_gcc_static_libgcc="" + else + need_gcc_static_libgcc=" -XCClinker -static-libgcc" + fi + fi + fi + + # Use only for standalone builds: + AR="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}${ar_libtool_no_undefined} -release ${rktio_version} -rpath ${abslibdir} \$(ARLIBFLAGS) -o" + # Used for a librktio convenience library: + STATIC_AR="${LIBTOOLPROG} --mode=link --tag=CC $CC -o" + ARFLAGS="" + RANLIB=":" + + RKTLINKER="${LIBTOOLPROG} --mode=link --tag=CC $CC${need_gcc_static_libgcc}" + CC="${LIBTOOLPROG} --mode=compile --tag=CC $CC" + LTO="lo" + LTA="la" + STRIP_LIB_DEBUG=":" + LIBSFX=la + ICP_LIB="${LIBTOOLPROG} --mode=install install -s" +else + ICP=cp + LTO="o" + LTA="a" + RKTLINKER='$(CC)' + STATIC_AR="$AR" + LIBSFX=so + ICP_LIB=cp + if test "${make_darwin_dylib}" = "yes" ; then + LIBSFX="dylib" + AR='$(RKTLINKER) --shared -o' + ARFLAGS="" + LIBS="${LIBS} -framework CoreFoundation" + ICP_LIB=cp + fi +fi + +############## final output ################ + +CPPFLAGS="$CPPFLAGS $PREFLAGS" + +AC_SUBST(CC) +AC_SUBST(CFLAGS) +AC_SUBST(CPPFLAGS) +AC_SUBST(LDFLAGS) +AC_SUBST(LIBS) +AC_SUBST(AR) +AC_SUBST(ARFLAGS) +AC_SUBST(RANLIB) +AC_SUBST(STATIC_AR) +AC_SUBST(ICP) +AC_SUBST(RKTLINKER) +AC_SUBST(INCLUDEDEP) +AC_SUBST(RACKET) +AC_SUBST(SCHEME_DIR) +AC_SUBST(MACH) +AC_SUBST(OSX) +AC_SUBST(NOT_OSX) +AC_SUBST(CONFIGURE_RACKET_SO_COMPILE) +AC_SUBST(SCHEME_SRC) +AC_SUBST(SCHEME_CONFIG_ARGS) +AC_SUBST(FRAMEWORK_INSTALL_DIR) +AC_SUBST(FRAMEWORK_PREFIX) + +makefiles="Makefile" + +AC_OUTPUT($makefiles) + +mkdir -p rktio +abssrcdir=`(cd ${srcdir}; pwd)` +echo "=== configuring in rktio (${abssrcdir}/../../rktio)" +cd rktio; ${abssrcdir}/../../rktio/configure diff --git a/racket/src/cs/c/cs_config.h.in b/racket/src/cs/c/cs_config.h.in new file mode 100644 index 0000000000..8b13789179 --- /dev/null +++ b/racket/src/cs/c/cs_config.h.in @@ -0,0 +1 @@ + diff --git a/racket/src/cs/c/embed-boot.rkt b/racket/src/cs/c/embed-boot.rkt new file mode 100644 index 0000000000..3cb9cdbcc1 --- /dev/null +++ b/racket/src/cs/c/embed-boot.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require racket/cmdline + racket/file + compiler/private/mach-o + compiler/private/elf) + +(command-line + #:args (src-file dest-file boot-dir racket.so) + + (define bstr1 (file->bytes (build-path boot-dir "petite.boot"))) + (define bstr2 (file->bytes (build-path boot-dir "scheme.boot"))) + (define bstr3 (file->bytes racket.so)) + + (with-handlers ([exn? (lambda (x) + (when (file-exists? dest-file) + (delete-file dest-file)) + (raise x))]) + (define data + (bytes-append bstr1 #"\0" + bstr2 #"\0" + bstr3 #"\0")) + (define pos + (case (path->string (system-library-subpath #f)) + [("x86_64-darwin" "i386-darwin" "x86_64-macosx" "i386-macosx") + ;; Mach-O + (copy-file src-file dest-file #t) + (add-plt-segment dest-file data #:name #"__RKTBOOT")] + [else + ;; ELF? + (define-values (start-pos end-pos any1 any2) + (add-racket-section src-file dest-file #".rackboot" + (lambda (pos) + (values data 'any1 'any2)))) + (cond + [start-pos + ;; Success as ELF + start-pos] + [else + ;; Not ELF; just append to the end + (copy-file src-file dest-file #t) + (define pos (file-size dest-file)) + (call-with-output-file* + dest-file + #:exists 'update + (lambda (o) + (file-position o pos) + (write-bytes data o))) + pos])])) + + (define-values (i o) (open-input-output-file dest-file #:exists 'update)) + (define m (regexp-match-positions #rx"BooT FilE OffsetS:" i)) + (unless m + (error 'embed-boot "cannot file boot-file offset tag")) + + (file-position o (cdar m)) + (void (write-bytes (integer->integer-bytes pos 4 #t #f) o)) + (void (write-bytes (integer->integer-bytes (+ pos (bytes-length bstr1) 1) 4 #t #f) o)) + (void (write-bytes (integer->integer-bytes (+ pos (bytes-length bstr1) (bytes-length bstr2) 2) 4 #t #f) o)))) diff --git a/racket/src/cs/c/grmain.c b/racket/src/cs/c/grmain.c new file mode 100644 index 0000000000..57835b14d5 --- /dev/null +++ b/racket/src/cs/c/grmain.c @@ -0,0 +1,19 @@ +#define do_pre_filter_cmdline_arguments(argc, argv) pre_filter_cmdline_arguments(argc, argv) +static void pre_filter_cmdline_arguments(int *argc, char ***argv); + +#define INITIAL_BIN_TYPE "ri" +#define RACKET_IS_GUI 1 + +#include "main.c" + +#ifdef OS_X +# define wx_mac +#else +# define wx_xt +#endif + +static void scheme_register_process_global(const char *key, void *v) +{ +} + +#include "../../start/gui_filter.inc" diff --git a/racket/src/cs/c/main.c b/racket/src/cs/c/main.c new file mode 100644 index 0000000000..fb5bd23da1 --- /dev/null +++ b/racket/src/cs/c/main.c @@ -0,0 +1,132 @@ +#ifndef _MSC_VER +# include +#endif +#include +#include +#include +#ifdef _MSC_VER +# include +# define DOS_FILE_SYSTEM +static int scheme_utf8_encode(unsigned int *path, int zero_offset, int len, + char *dest, int dest_len, int get_utf16); +#endif +#include "boot.h" + +#define MZ_CHEZ_SCHEME +#ifndef INITIAL_BIN_TYPE +# define INITIAL_BIN_TYPE "zi" +#endif +#ifndef RACKET_IS_GUI +# define RACKET_IS_GUI 0 +#endif + +#include "../../start/config.inc" + +char *boot_file_data = "BooT FilE OffsetS:xxxxyyyyyzzzz"; +static int boot_file_offset = 18; + +#ifdef OS_X +# include +static char *get_self_path() +{ + char buf[1024], *s; + uint32_t size = sizeof(buf); + int r; + + r = _NSGetExecutablePath(buf, &size); + if (!r) + return strdup(buf); + else { + s = malloc(size); + r = _NSGetExecutablePath(s, &size); + if (!r) + return s; + fprintf(stderr, "failed to get self\n"); + exit(1); + } +} +#endif + +#if defined(__linux__) +# include +static char *get_self_path() +{ + char buf[256], *s = buf; + ssize_t len, blen = sizeof(buf); + + while (1) { + len = readlink("/proc/self/exe", s, blen-1); + if (len == (blen-1)) { + if (s != buf) free(s); + blen *= 2; + s = malloc(blen); + } else if (len < 0) { + fprintf(stderr, "failed to get self (%d)\n", errno); + exit(1); + } else + break; + } + buf[len] = 0; + return strdup(buf); +} +#endif + +#ifdef _MSC_VER +static char *get_self_path() +{ + wchar_t *p = get_self_executable_path(); + char *r; + int len; + + len = WideCharToMultiByte(CP_UTF8, 0, p, -1, NULL, 0, NULL, NULL); + r = malloc(len); + len = WideCharToMultiByte(CP_UTF8, 0, p, -1, r, len, NULL, NULL); + + return r; +} + +static int scheme_utf8_encode(unsigned int *path, int zero_offset, int len, + char *dest, int dest_len, int get_utf16) +{ + return WideCharToMultiByte(CP_UTF8, 0, (wchar_t *)path, len, dest, dest_len, NULL, NULL); +} +#endif + +#ifdef NO_GET_SEGMENT_OFFSET +static long get_segment_offset() +{ + return 0; +} +#endif + +#ifndef do_pre_filter_cmdline_arguments +# define do_pre_filter_cmdline_arguments(argc, argv) /* empty */ +#endif + +int main(int argc, char **argv) +{ + char *self, *prog = argv[0], *sprog = NULL; + int pos1, pos2, pos3; + long segment_offset; + + do_pre_filter_cmdline_arguments(&argc, &argv); + + argc--; + argv++; + + extract_built_in_arguments(&prog, &sprog, &argc, &argv); + segment_offset = get_segment_offset(); + + self = get_self_path(); + + memcpy(&pos1, boot_file_data + boot_file_offset, sizeof(pos1)); + memcpy(&pos2, boot_file_data + boot_file_offset + 4, sizeof(pos2)); + memcpy(&pos3, boot_file_data + boot_file_offset + 8, sizeof(pos2)); + + racket_boot(argc, argv, self, segment_offset, + extract_coldir(), extract_configdir(), + pos1, pos2, pos3, + RACKET_IS_GUI); + + return 0; +} diff --git a/racket/src/cs/chezpart.sls b/racket/src/cs/chezpart.sls new file mode 100644 index 0000000000..c0fe203913 --- /dev/null +++ b/racket/src/cs/chezpart.sls @@ -0,0 +1,82 @@ +;; Reexports from `chezscheme` bindings that won't be replaced +;; by Racket-specific implementations. + +(library (chezpart) + (export) + (import (chezscheme)) + (export (import + (rename (except (chezscheme) + remq remove + sort + force delay identifier? + output-port-buffer-mode + peek-char char-ready? + make-input-port make-output-port + close-input-port close-output-port + list? input-port? output-port? + open-input-file open-output-file abort + current-output-port current-input-port current-directory + open-input-string open-output-string get-output-string + open-input-output-file + with-input-from-file with-output-to-file + call-with-output-file + file-position + write display newline port-name port-closed? write-char + print-graph print-vector-length + date? make-date + dynamic-wind + call-with-current-continuation + make-engine engine-block engine-return + current-eval load + sleep thread? buffer-mode? + equal? + vector? mutable-vector? vector-length vector-ref vector-set! + vector-copy vector-fill! vector->immutable-vector vector->list + random random-seed + box? unbox set-box! + get-thread-id + threaded? + map for-each andmap ormap + char-general-category) + [make-parameter chez:make-parameter] + [void chez:void] + [date-second chez:date-second] + [date-minute chez:date-minute] + [date-hour chez:date-hour] + [date-day chez:date-day] + [date-month chez:date-month] + [date-year chez:date-year] + [date-week-day chez:date-week-day] + [date-year-day chez:date-year-day] + [date-dst? chez:date-dst?] + [string-copy! chez:string-copy!] + [apply chez:apply] + [procedure? chez:procedure?] + [procedure-arity-mask chez:procedure-arith-mask] + [substring chez:substring] + [gensym chez:gensym] + [symbol->string chez:symbol->string] + [fprintf chez:fprintf] + [printf chez:printf] + [format chez:format] + [current-error-port chez:current-error-port] + [string->number chez:string->number] + [number->string chez:number->string] + [file-exists? chez:file-exists?] + [directory-list chez:directory-list] + [delete-file chez:delete-file] + [delete-directory chez:delete-directory] + [filter chez:filter] + [member chez:member] + [memv chez:memv] + [memq chez:memq] + [error chez:error] + [raise chez:raise] + [exit-handler chez:exit-handler] + [exit chez:exit] + [vector-sort! chez:vector-sort!] + [vector-sort chez:vector-sort] + [call-with-input-file chez:call-with-input-file] + [read-char chez:read-char] + [gcd chez:gcd] + [lcm chez:lcm])))) diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss new file mode 100644 index 0000000000..70e6399613 --- /dev/null +++ b/racket/src/cs/compile-file.ss @@ -0,0 +1,102 @@ + +;; Check to make we're using a build of Chez Scheme +;; that has all the features we need. + +(define (check-defined expr) + (unless (guard (x [else #f]) (eval expr)) + (error 'compile-file + (format + "failed trying `~a`; probably you need a newer Chez Scheme" + expr)))) + +(check-defined 'box-cas!) +(check-defined 'make-arity-wrapper-procedure) +(check-defined 'generate-procedure-source-information) +(check-defined 'object-backreferences) +(check-defined 'current-generate-id) +(check-defined 'load-compiled-from-port) +(check-defined 'collect-rendezvous) +(check-defined '(define-ftype T (function __thread () void))) + +;; ---------------------------------------- + +(current-make-source-object + (lambda (sfd bfp efp) + (call-with-values (lambda () (locate-source sfd bfp #t)) + (case-lambda + [() (error 'compile-config "cannot get line and column")] + [(name line col) + (make-source-object sfd bfp efp line col)])))) + +(generate-wpo-files #t) + +(define (get-opt args flag arg-count) + (cond + [(null? args) #f] + [(equal? (car args) flag) + (unless (> (length args) arg-count) + (error 'compile-file "missing argument for ~a" flag)) + (cdr args)] + [else #f])) + +(define whole-program? #f) +(generate-inspector-information #f) +(generate-procedure-source-information #t) +(define build-dir "") + +(define-values (src deps) + (let loop ([args (command-line-arguments)]) + (cond + [(get-opt args "--debug" 0) + => (lambda (args) + (generate-inspector-information #t) + (loop args))] + [(get-opt args "--unsafe" 0) + => (lambda (args) + (optimize-level 3) + (loop args))] + [(get-opt args "--whole-program" 0) + => (lambda (args) + (set! whole-program? #t) + (loop args))] + [(get-opt args "--dest" 1) + => (lambda (args) + (set! build-dir (car args)) + (loop (cdr args)))] + [(null? args) + (error 'compile-file "missing source file")] + [else + (values (car args) (cdr args))]))) + +(define src-so + (letrec ([find-dot (lambda (pos) + (let ([pos (sub1 pos)]) + (cond + [(zero? pos) (error 'compile-file "can't find extension in ~s" src)] + [(char=? (string-ref src pos) #\.) pos] + [else (find-dot pos)])))]) + (string-append (substring src 0 (find-dot (string-length src))) ".so"))) + +(define dest + (if (equal? build-dir "") + src-so + (string-append build-dir src-so))) + +(cond + [whole-program? + (unless (= 1 (length deps)) + (error 'compile-file "expected a single dependency for whole-program compilation")) + (unless (equal? build-dir "") + (library-directories (list (cons "." build-dir)))) + (compile-whole-program (car deps) src #t)] + [else + (for-each load deps) + (parameterize ([current-generate-id + (let ([counter-ht (make-eq-hashtable)]) + (lambda (sym) + (let* ([n (eq-hashtable-ref counter-ht sym 0)] + [s ((if (gensym? sym) gensym->unique-string symbol->string) sym)] + [g (gensym (symbol->string sym) (format "rkt-~a-~a-~a" src s n))]) + (eq-hashtable-set! counter-ht sym (+ n 1)) + g)))]) + (compile-file src dest))]) diff --git a/racket/src/cs/convert.rkt b/racket/src/cs/convert.rkt new file mode 100644 index 0000000000..e543843957 --- /dev/null +++ b/racket/src/cs/convert.rkt @@ -0,0 +1,254 @@ +#lang racket/base +(require racket/cmdline + racket/pretty + racket/match + racket/file + racket/extflonum + racket/include + "../schemify/schemify.rkt" + "../schemify/serialize.rkt" + "../schemify/known.rkt" + "../schemify/lift.rkt") + +(define skip-export? #f) +(define for-cify? #f) +(define unsafe-mode? #f) + +(define-values (in-file out-file) + (command-line + #:once-each + [("--skip-export") "Don't generate an `export` form" + (set! skip-export? #t)] + [("--for-cify") "Keep `make-struct-type` as-is, etc." + (set! for-cify? #t)] + [("--unsafe") "Compile for unsafe mode" + (set! unsafe-mode? #t)] + #:args + (in-file out-file) + (values in-file out-file))) + +(define content (call-with-input-file* in-file read)) +(define l (cdddr content)) + +(let loop ([l l]) + (cond + [(eq? l 'make-optional-keyword-procedure) + (error "keyword residual `make-optional-keyword-procedure` appears in .rktl")] + [(pair? l) + (loop (car l)) + (loop (cdr l))])) + +(define lifts (make-hash)) +(define ordered-lifts null) + +(define (lift-set! k v) + (unless (hash-ref lifts k #f) + (hash-set! lifts k v) + (set! ordered-lifts (cons k ordered-lifts)))) + +;; Ad hoc patterns to deal with a special case in "expander.rktl": +(define (quote? v) + (and (pair? v) + (eq? (car v) 'quote) + (pair? (cdr v)) + (null? (cddr v)))) +(define (nested-hash? v) + (and (pair? v) + (eq? #f (car v)) + (hash? (cdr v)))) +(define (list-of-keywords? v) + (and (pair? v) + (list? v) + (andmap keyword? v))) + +;; Gather all literal regexps and hash tables +(define (lift v) + (cond + [(or (regexp? v) (byte-regexp? v)) + (define s (gensym 'rx)) + (lift-set! v s)] + [(or (pregexp? v) (byte-pregexp? v)) + (define s (gensym 'px)) + (lift-set! v s)] + [(hash? v) + (define s (gensym 'hash)) + (lift-set! v s)] + [(and (quote? v) + (nested-hash? (cadr v))) + (define s (gensym 'nhash)) + (lift-set! (cadr v) s)] + [(keyword? v) + (define s (gensym 'kw)) + (lift-set! v s)] + [(and (quote? v) + (list-of-keywords? (cadr v))) + (define s (gensym 'kws)) + (lift-set! (cadr v) s)] + [(and (quote? v) + (extflonum? (cadr v))) + (define s (gensym 'extfl)) + (lift-set! (cadr v) s)] + [(pair? v) + (lift (car v)) + (lift (cdr v))])) + +(unless for-cify? + (lift l)) + +(define prim-knowns + (let ([knowns (hasheq)]) + (define-syntax-rule (define-primitive-table id [prim known] ...) + (begin (set! knowns (hash-set knowns 'prim known)) ...)) + (include "primitive/kernel.ss") + (include "primitive/unsafe.ss") + (include "primitive/flfxnum.ss") + (include "primitive/paramz.ss") + (include "primitive/extfl.ss") + (include "primitive/network.ss") + (include "primitive/futures.ss") + (include "primitive/place.ss") + (include "primitive/foreign.ss") + (include "primitive/linklet.ss") + (include "primitive/internal.ss") + knowns)) + +;; Convert: +(define schemified-body + (let () + (define-values (bodys/constants-lifted lifted-constants) + (if for-cify? + (begin + (printf "Serializable...\n") + (time (convert-for-serialize l for-cify?))) + (values l null))) + (printf "Schemify...\n") + (define body + (time + (schemify-body bodys/constants-lifted (lambda (old-v new-v) new-v) prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode?))) + (printf "Lift...\n") + ;; Lift functions to aviod closure creation: + (define lifted-body + (time + (lift-in-schemified-body body (lambda (old new) new)))) + (append (for/list ([p (in-list lifted-constants)]) + (cons 'define p)) + lifted-body))) + +;; ---------------------------------------- + +(unless for-cify? + + ;; Set a hook to redirect literal regexps and + ;; hash tables to lifted bindings + (pretty-print-size-hook + (lambda (v display? out) + (cond + [(and (pair? v) + (pair? (cdr v)) + (eq? 'quote (car v)) + (or (regexp? (cadr v)) + (byte-regexp? (cadr v)) + (pregexp? (cadr v)) + (byte-pregexp? (cadr v)) + (hash? (cadr v)) + (nested-hash? (cadr v)) + (keyword? (cadr v)) + (list-of-keywords? (cadr v)) + (extflonum? (cadr v)))) + 10] + [(bytes? v) (* 3 (bytes-length v))] + [(and (symbol? v) (regexp-match? #rx"#" (symbol->string v))) + (+ 2 (string-length (symbol->string v)))] + [(char? v) 5] + [(single-flonum? v) 5] + [(or (keyword? v) + (regexp? v) + (pregexp? v) + (hash? v)) + (error 'lift "value that needs lifting is in an unrecognized context: ~v" v)] + [else #f]))) + + ;; This hook goes with `pretty-print-size-hook` + (pretty-print-print-hook + (lambda (v display? out) + (cond + [(and (pair? v) + (eq? 'quote (car v)) + (or (regexp? (cadr v)) + (byte-regexp? (cadr v)) + (pregexp? (cadr v)) + (byte-pregexp? (cadr v)) + (hash? (cadr v)) + (nested-hash? (cadr v)) + (keyword? (cadr v)) + (list-of-keywords? (cadr v)) + (extflonum? (cadr v)))) + (write (hash-ref lifts (cadr v)) out)] + [(bytes? v) + (display "#vu8") + (write (bytes->list v) out)] + [(symbol? v) + (write-string (format "|~a|" v) out)] + [(char? v) + (write-string (format "#\\x~x" (char->integer v)) out)] + [(single-flonum? v) + (write (real->double-flonum v) out)] + [else #f])))) + +;; ---------------------------------------- + +(make-parent-directory* out-file) + +(with-handlers ([void (lambda (exn) + (when (file-exists? out-file) + (with-handlers ([void (lambda (exn) + (log-error "delete failed: ~s" exn))]) + (delete-file out-file))) + (raise exn))]) + (with-output-to-file + out-file + #:exists 'truncate + (lambda () + (unless skip-export? + ;; Write out exports + (pretty-write + `(export (rename ,@(caddr content))))) + ;; Write out lifted regexp and hash-table literals + (for ([k (in-list (reverse ordered-lifts))]) + (define v (hash-ref lifts k)) + (pretty-write + `(define ,v + ,(let loop ([k k]) + (cond + [(or (regexp? k) + (byte-regexp? k)) + `(,(cond [(byte-regexp? k) 'byte-regexp] + [(byte-pregexp? k) 'byte-pregexp] + [(pregexp? k) 'pregexp] + [else 'regexp]) + ,(object-name k))] + [(hash? k) + `(,(cond + [(hash-equal? k) 'hash] + [(hash-eqv? k) 'hasheqv] + [else 'hasheq]) + ,@(for*/list ([(k v) (in-hash k)] + [e (in-list (list k v))]) + `(quote ,e)))] + [(pair? k) + `(cons ,(loop (car k)) ,(loop (cdr k)))] + [(keyword? k) + `(string->keyword ,(keyword->string k))] + [(null? k) ''()] + [(extflonum? k) `(string->number ,(format "~a" k) 10 'read)] + [else k]))))) + + ;; Write out converted forms + (for ([v (in-list schemified-body)]) + (unless (equal? v '(void)) + (let loop ([v v]) + (match v + [`(begin ,vs ...) + (for-each loop vs)] + [else + (pretty-write v)]))))))) diff --git a/racket/src/cs/demo/chaperone.ss b/racket/src/cs/demo/chaperone.ss new file mode 100644 index 0000000000..7f0bc3fb5a --- /dev/null +++ b/racket/src/cs/demo/chaperone.ss @@ -0,0 +1,458 @@ +(import (rumble)) + +(define-syntax check + (syntax-rules () + [(_ got expect) + (let ([v got] + [expect-v expect]) + (unless (equal? v expect-v) + (error 'check (format "failed: ~s => ~s" 'got v))))])) + +(define-syntax check-error + (syntax-rules () + [(_ expr) + (check (call-with-current-continuation + (lambda (esc) + (with-continuation-mark + exception-handler-key + (lambda (exn) (|#%app| esc 'expected-error)) + expr))) + 'expected-error)])) + +;; ---------------------------------------- + +(define v1 (vector 1 2 3)) +(define v2 (vector 1 2 3)) + +(check (impersonator-of? v1 v2) + #t) +(check (impersonator-of? v2 v1) + #t) + +(define v1i (impersonate-vector v1 + (lambda (v i e) (- e)) + (lambda (v i e) (* 2 e)))) + +(check (vector? v1) #t) +(check (vector? v2) #t) +(check (vector? v1i) #t) + +(check (vector-ref v1i 1) -2) +(check (vector-ref v1 1) 2) +(check (vector-set! v1 1 5) (void)) +(check (vector-ref v1i 1) -5) +(check (vector-ref v1 1) 5) +(check (vector-set! v1i 1 6) (void)) +(check (vector-ref v1i 1) -12) +(check (vector-ref v1 1) 12) + +(check (vector-set! v2 1 12) (void)) + +(check (impersonator-of? v1i v2) + #f) +(check (impersonator-of? v2 v1i) + #f) +(check (impersonator-of? v1i v1) + #t) +(check (impersonator-of? v1 v1i) + #f) + +(define v1j (impersonate-vector v1 + #f + #f)) + +(check (vector? v1j) #t) + +(check (impersonator-of? v1j v1) + #t) +(check (impersonator-of? v1 v1j) + #t) + +(define v1c (chaperone-vector v1 + (lambda (v i e) e) + (lambda (v i e) e))) + +(check (chaperone-of? v1c v1) + #t) +(check (chaperone-of? v1i v1) + #f) +(check (impersonator-of? v1c v1) + #t) + +(define vv (vector (vector 1 2 3) + (vector 4 5 6))) +(define vvc (chaperone-vector vv + (lambda (v i e) + (chaperone-vector + e + (lambda (v i e) e) + (lambda (v i e) e))) + (lambda (v i e) e))) +(check (chaperone-of? vvc vv) + #t) +(check (chaperone-of? (vector-ref vvc 0) (vector-ref vv 0)) + #t) + +;; ---------------------------------------- + +(define b1 (box 1)) +(define b1c (chaperone-box b1 (lambda (b v) v) (lambda (b v) v))) +(define b1i (impersonate-box b1 (lambda (b v) (add1 v)) (lambda (b v) (sub1 v)))) + +(check (unbox b1) 1) +(check (set-box! b1 0) (void)) +(check (unbox b1) 0) + +(check (unbox b1c) 0) +(check (unbox b1i) 1) + +;; ---------------------------------------- + +(define (f x y) + (list x y)) + +(define fi (impersonate-procedure f (lambda (x y) + (values (- x) (- y))))) +(define fc (chaperone-procedure f (lambda (x y) + (values x y)))) + +(check (f 1 2) '(1 2)) +(check (|#%app| fc 1 2) '(1 2)) +(check (|#%app| fi 1 2) '(-1 -2)) + +(check (impersonator-of? fc f) #t) +(check (impersonator-of? fi f) #t) +(check (impersonator-of? fi fc) #f) +(check (impersonator-of? fc fi) #f) + +(check (chaperone-of? fc f) #t) +(check (chaperone-of? fi f) #f) +(check (chaperone-of? fi fc) #f) +(check (chaperone-of? fc fi) #t) + +(define fc2 (chaperone-procedure f + (lambda (x y) + (values (chaperone-vector + x + (lambda (v i e) e) + (lambda (v i e) e)) + y)))) + +(check (|#%app| fc2 v1 0) (list v1 0)) +(check (chaperone-of? (|#%app| fc2 v1 0) (list v1 0)) + #t) + +(define fc* (chaperone-procedure* f (lambda (orig x y) + (check orig fc*) + (values x y)))) +(check (|#%app| fc* 'a 'b) '(a b)) + +(define fiu (unsafe-chaperone-procedure f (lambda (x y) 'unsafe))) +(check (chaperone-of? fiu f) #t) +(check (|#%app| fiu 'a 'b) 'unsafe) +(check (|#%app| (chaperone-procedure fiu (lambda (x y) (values x y))) 'a 'b) + 'unsafe) + +;; ---------------------------------------- + +(define-values (iprop:flavor flavor? flavor-ref) + (make-impersonator-property 'flavor)) + +(check (|#%app| flavor? 1) #f) +(check (|#%app| flavor? f) #f) + +(define fcp (chaperone-procedure f + (lambda (x y) + (values x y)) + iprop:flavor 'spicy)) + +(check (|#%app| flavor? fcp) #t) +(check (|#%app| flavor-ref fcp) 'spicy) + +(check (|#%app| fcp 3 4) '(3 4)) + +;; ---------------------------------------- + +(define (g x y) + (list x y (continuation-mark-set->list + (current-continuation-marks) + 'calling))) + +(check (g 1 2) '(1 2 ())) + +(define gcam (chaperone-procedure g + (lambda (x y) + (values x y)) + impersonator-prop:application-mark + (cons 'calling 'london))) + +(check (|#%app| gcam 1 2) '(1 2 (london))) + +(check (with-continuation-mark 'calling 'madrid + (|#%app| gcam 1 2)) + '(1 2 (london))) + + +(define giam (impersonate-procedure g + (lambda (x y) + ;; Has a result wrapper, so call of `g` + ;; will not be in tail positions + (values (lambda (r) r) + x + (continuation-mark-set->list + (current-continuation-marks) + 'calling))) + impersonator-prop:application-mark + (cons 'calling 'paris))) + +(check (|#%app| giam 1 2) '(1 () (paris))) + +(check (with-continuation-mark 'calling 'madrid + (|#%app| giam 1 2)) + '(1 (madrid madrid) (paris madrid))) + +(check (|#%app| + (chaperone-procedure (lambda (x) (list + (continuation-mark-set->list + (current-continuation-marks) + 'a) + x)) + (lambda (x) (values 'mark 'a 'b x))) + 1) + '((b) 1)) + +;; ---------------------------------------- + +(let () + (define-values (prop:x x? x-ref) (make-struct-type-property 'x)) + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f (list (cons prop:x 5)))) + (define-values (struct:s-b make-s-b s-b? s-b-ref s-b-set!) + (make-struct-type 's-b #f 2 0 #f '() #f 0)) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (define s-a-y (make-struct-field-accessor s-a-ref 1 'y)) + (define s-b-y (make-struct-field-accessor s-b-ref 1 'y)) + (define set-s-a-x! (make-struct-field-mutator s-a-set! 0 'x)) + (define counter 0) + (define last-flavor #f) + + (define s1 (make-s-a 1 2)) + (define s1c (chaperone-struct s1 + s-a-x (lambda (s v) (set! counter (add1 counter)) v) + x-ref (lambda (s v) (set! counter (add1 counter)) v))) + (define s1i (impersonate-struct s1 + s-a-x (lambda (s v) (list v)) + set-s-a-x! (lambda (s v) (box v)))) + + (define ps1 (make-s-b (lambda (c) (list c c)) 2)) + (define ps1i (impersonate-struct ps1 s-b-y (lambda (s v) (box v)))) + (define ps1ic (chaperone-procedure* ps1i (lambda (p v) + (set! last-flavor (and (|#%app| flavor? p) + (|#%app| flavor-ref p))) + (set! counter (add1 counter)) + v))) + (define ps1icp (impersonate-struct ps1ic struct:s-b iprop:flavor 'chocolate)) + + (check (chaperone-struct 7) 7) + (check (impersonate-struct 7) 7) + + (check (impersonator-of? s1c s1) #t) + + (check (s-a-x s1) 1) + (check (s-a-y s1) 2) + + (check counter 0) + (check (s-a-x s1c) 1) + (check counter 1) + (check (s-a-y s1c) 2) + (check counter 1) + + (check (s-a-x s1i) '(1)) + (check (s-a-y s1i) 2) + (check (set-s-a-x! s1i 0) (void)) + (check (s-a-x s1i) '(#&0)) + + (check counter 1) + (check (|#%app| s-a-ref s1c 1) 2) + (check counter 1) + (check (|#%app| s-a-ref s1c 0) '#&0) + (check counter 2) + + (check (|#%app| x-ref s1) 5) + (check counter 2) + (check (|#%app| x-ref s1c) 5) + (check counter 3) + + (check (|#%app| ps1 3) '(3 3)) + (check (|#%app| ps1i 3) '(3 3)) + (check (s-b-y ps1) 2) + (check (s-b-y ps1i) '#&2) + + (check counter 3) + (check (|#%app| ps1ic 3) '(3 3)) + (check counter 4) + (check last-flavor #f) + (check (|#%app| ps1icp 3) '(3 3)) + (check counter 5) + (check last-flavor 'chocolate) + + (void)) + +;; ---------------------------------------- + +(let () + (define ops null) + (define (push! v) (set! ops (cons v ops))) + (define (ops!) (begin0 (reverse ops) (set! ops '()))) + (define (ch ht) + (chaperone-hash ht + (lambda (ht k) + (push! 'get) + (values k (lambda (ht k v) + (push! 'got) + v))) + (lambda (ht k v) (push! 'set) (values k v)) + (lambda (ht k) (push! 'remove) k) + (lambda (ht k) (push! 'key) k) + (lambda (ht) (push! 'clear)) + (lambda (ht k) (push! 'equal-key) k))) + (define ht1 (hash 1 'a 2 'b)) + (define ht1c (ch ht1)) + (define ht2 (make-hash)) + (define ht2c (ch ht2)) + + (hash-set! ht2 1 'a) + (hash-set! ht2 2 'b) + + (check (ops!) '()) + + (check (hash-ref ht1c 1) 'a) + (check (ops!) '(get equal-key got)) + (check (hash-ref ht2c 1) 'a) + (check (ops!) '(get equal-key got)) + + (check (hash-ref ht1c 2) 'b) + (check (ops!) '(get equal-key got)) + (check (hash-ref ht2c 2) 'b) + (check (ops!) '(get equal-key got)) + + (check (hash-ref (hash-set ht1c 3 'c) 3) 'c) + (check (ops!) '(set equal-key get equal-key got)) + (check (begin (hash-set! ht2c 3 'c) + (hash-ref ht2c 3)) + 'c) + (check (ops!) '(set equal-key get equal-key got)) + (check (begin (hash-set! ht2c 4 'd) + (hash-ref ht2 4)) + 'd) + (check (ops!) '(set equal-key)) + + (check (hash-ref (hash-remove ht1c 1) 1 'none) 'none) + (check (ops!) '(remove equal-key get equal-key)) + (check (begin + (hash-remove! ht2c 1) + (hash-ref ht2c 1 'none)) + 'none) + (check (ops!) '(remove equal-key get equal-key)) + + (check (hash-clear! ht2c) (void)) + (check (ops!) '(clear)) + (check (hash-set! ht2c 1 'a) (void)) + (check (ops!) '(set equal-key)) + + (check (hash-map ht2c cons) '((1 . a))) + (check (ops!) '(key get equal-key got)) + + (let ([i (hash-iterate-first ht2c)]) + (check (ops!) '()) + (check (hash-iterate-key ht2c i) 1) + (check (ops!) '(key)) + (check (hash-iterate-value ht2c i) 'a) + (check (ops!) '(key get equal-key got))) + + (check (equal? (hash-remove ht1c 5) ht1c) #t) + + ;; Check that hash table updates maintain chaperone identity + (check (chaperone-of? (hash-remove ht1c 5) ht1c) #t) + (check (chaperone-of? (hash-set (hash-remove ht1c 1) 1 'a) ht1c) #t) + (check (chaperone-of? (hash-set (hash-remove ht1c 1) 1 'aa) ht1c) #f) + (check (chaperone-of? ht1 (hash-remove ht1c 5)) #f) + + (void)) + +;; ---------------------------------------- +;; `prop:impersonator-of` + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f (list (cons prop:equal+hash + ;; Equality compares only the first field + (list + (lambda (a b eql?) + (eql? (|#%app| s-a-ref a 0) + (|#%app| s-a-ref b 0))) + (lambda (a hc) + (hc (|#%app| s-a-ref a 0))) + (lambda (a hc) + (hc (|#%app| s-a-ref a 0))))) + (cons prop:impersonator-of + ;; Second field contains impersonated record + (lambda (a) + (|#%app| s-a-ref a 1)))))) + + (define a1 (make-s-a 1 #f)) + (define a1i (make-s-a #f a1)) + + (check (equal? a1 (make-s-a 1 #f)) #t) + (check (equal? a1 (make-s-a 3 #f)) #f) + + (check (equal? a1 a1i) #t) + (check (equal? a1i a1) #t) + (check (impersonator-of? a1i a1) #t) + (check (impersonator-of? a1 a1i) #f) + + (check (chaperone-of? a1i a1) #f) + (check (chaperone-of? a1 a1i) #f) + + (void)) + +;; ---------------------------------------- +;; `chaperone-struct-unsafe-undefined` + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f)) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (define set-s-a-x! (make-struct-field-mutator s-a-set! 0 'x)) + (define s-a-y (make-struct-field-accessor s-a-ref 1 'y)) + (define set-s-a-y! (make-struct-field-mutator s-a-set! 1 'y)) + + (define a1 (make-s-a 1 unsafe-undefined)) + (define a1c (chaperone-struct-unsafe-undefined a1)) + + (check unsafe-undefined (|#%app| s-a-ref a1 1)) + (check 1 (|#%app| s-a-ref a1c 0)) + (check 1 (s-a-x a1c)) + (check-error (|#%app| s-a-ref a1c 1)) + (check-error (s-a-y a1c)) + + (void)) + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 's-a #f 2 0 #f (list (cons + prop:chaperone-unsafe-undefined + '(y x))))) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (define set-s-a-x! (make-struct-field-mutator s-a-set! 0 'x)) + (define s-a-y (make-struct-field-accessor s-a-ref 1 'y)) + (define set-s-a-y! (make-struct-field-mutator s-a-set! 1 'y)) + + (define a1 (|#%app| make-s-a 1 unsafe-undefined)) + + (check 1 (|#%app| s-a-ref a1 0)) + (check 1 (s-a-x a1)) + (check-error (|#%app| s-a-ref a1 1)) + (check-error (s-a-y a1)) + + (void)) diff --git a/racket/src/cs/demo/control.ss b/racket/src/cs/demo/control.ss new file mode 100644 index 0000000000..7121620722 --- /dev/null +++ b/racket/src/cs/demo/control.ss @@ -0,0 +1,639 @@ +(import (rumble) + (rename (only (chezscheme) dynamic-wind) + (dynamic-wind chez:dynamic-wind))) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([v a]) + (unless (equal? v b) + (error 'check (format "failed ~s => ~s" 'a v))))])) + +(define check-abort-tag (make-continuation-prompt-tag 'check-abort)) + +(define-syntax check-error + (syntax-rules () + [(_ a s) + (let ([v (call-with-continuation-prompt + (lambda () + (with-continuation-mark + exception-handler-key + (lambda (exn) + (if (exn? exn) + (abort-current-continuation + check-abort-tag + (lambda () (exn-message exn))) + exn)) + a)) + check-abort-tag)] + [es s]) + (unless (and (string? v) + (>= (string-length v) (string-length es)) + (string=? es (substring v 0 (string-length es)))) + (error 'check (format "failed ~s != ~s" v es))))])) + +(define tag1 (make-continuation-prompt-tag 'tag1)) +(define tag2 (make-continuation-prompt-tag 'tag2)) + +(check (eq? (make-continuation-prompt-tag) + (make-continuation-prompt-tag)) + #f) + +(check (call-with-continuation-prompt + (lambda () 10)) + 10) + +(check (call-with-continuation-prompt + (lambda () 10) + tag1) + 10) + +(check (let ([saved #f]) + (let ([a (call-with-continuation-prompt + (lambda () + (+ 10 + (call-with-composable-continuation + (lambda (k) + (set! saved k) + 12) + tag1))) + tag1)]) + (list a + (|#%app| saved -12)))) + (list 22 -2)) + +(check (let ([saved #f]) + (let ([a (call-with-continuation-prompt + (lambda () + (+ 10 + (call-with-continuation-prompt + (lambda () + (call-with-composable-continuation + (lambda (k) + (set! saved k) + 12) + tag1)) + tag2))) + tag1)]) + (list a + (|#%app| saved -12)))) + (list 22 -2)) + +;; Shouldn't take long or use much memory: +(check (call-with-continuation-prompt + (lambda () + (let loop ([n 1000000]) + (call-with-composable-continuation + (lambda (k) + (if (zero? n) + 'ok + ;; In tail position: + (loop (sub1 n)))) + tag1))) + tag1) + 'ok) + +;; Also shouldn't take long or use much memory: +(check (let ([old-k (lambda (p) (p))] + [n 100000]) + (call-with-continuation-prompt + (lambda () + (let loop () + ((call-with-composable-continuation + (lambda (k) + (let ([prev-k old-k]) + (set! old-k k) + (|#%app| prev-k (lambda () + (call-with-composable-continuation + (lambda (k) + (cond + [(zero? n) + (lambda () 'also-ok)] + [else + (set! n (sub1 n)) + loop]))))))) + tag1)))) + tag1)) + 'also-ok) + +(check (let ([t (make-continuation-prompt-tag)]) + (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + (abort-current-continuation + t + 17)) + (make-continuation-prompt-tag))) + t + values)) + 17) + +(check (let ([syms null]) + (let ([v (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () 'ok) + (lambda () (set! syms (cons 'out syms))))]) + (cons v syms))) + '(ok out in)) + +(check (let ([syms null]) + (let ([v (call-with-current-continuation + (lambda (esc) + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () (|#%app| esc 'esc)) + (lambda () (set! syms (cons 'out syms))))))]) + (cons v syms))) + '(esc out in)) + +(check (let ([syms null]) + (let ([v (call-with-current-continuation + (lambda (esc) + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () + (call-with-continuation-prompt + (lambda () + 'in-prompt))) + (lambda () (set! syms (cons 'out syms))))))]) + (cons v syms))) + '(in-prompt out in)) + +(check (let ([saved #f] + [syms null]) + (let ([a (call-with-continuation-prompt + (lambda () + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () + (+ 10 + (call-with-composable-continuation + (lambda (k) + (set! saved k) + 12) + tag1))) + (lambda () (set! syms (cons 'out syms))))) + tag1)]) + (let ([b (|#%app| saved -10)]) + (list a + b + syms)))) + (list 22 0 '(out in out in))) + +(check (let ([saved #f]) + (with-continuation-mark + 'x 0 + (let ([a (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'x 1 + (begin + (call-with-composable-continuation + (lambda (k) + (set! saved k))) + (continuation-mark-set->list + (current-continuation-marks) + 'x)))))]) + (list a + (|#%app| saved #f))))) + '((1) (1 0))) + +(check (call-with-current-continuation + (lambda (k) + (|#%app| k 0))) + 0) + +(check (call-with-current-continuation + (lambda (k) + (call-with-continuation-prompt + (lambda () + (|#%app| k 100)) + tag1))) + 100) + +(check (let ([syms null]) + (let ([saved #f]) + (let ([v + (call-with-continuation-prompt + (lambda () + ;; This metacontinuation frame will be shared between the + ;; capture and invocation: + (dynamic-wind + (lambda () (set! syms (cons 'in0 syms))) + (lambda () + (let ([a (call-with-continuation-prompt + (lambda () + ;; This metacontinuation frame will not + ;; be shared: + (dynamic-wind + (lambda () (set! syms (cons 'in syms))) + (lambda () + (+ 10 + (call-with-current-continuation + (lambda (k) + (set! saved k) + 12) + tag1))) + (lambda () (set! syms (cons 'out syms))))) + tag1)]) + (let ([b (call-with-continuation-prompt + (lambda () + (|#%app| saved -8)) + tag1)]) + (list a b)))) + (lambda () (set! syms (cons 'out0 syms))))))]) + (list v syms)))) + (list (list 22 2) '(out0 out in out in in0))) + +;; ---------------------------------------- +;; Escape continuations + +(check (call-with-escape-continuation + (lambda (k) + (+ 1 (|#%app| k 'esc)))) + 'esc) + +(check (let-values ([(k ek) + (call-with-continuation-prompt + (lambda () + (call-with-escape-continuation + (lambda (ek) + (let-values ([(k0 ek0) + ((call-with-composable-continuation + (lambda (k) + (lambda () (values k ek)))))]) + (values k0 (box ek0)))))))]) + (let-values ([(k2 ek2) + (|#%app| k (lambda () (|#%app| (unbox ek) 'none 'skip)))]) + ek2)) + 'skip) + +(check-error (|#%app| (call-with-escape-continuation + (lambda (k) k))) + "continuation application: attempt to jump into an escape continuation") + +(check (with-continuation-mark + 'x 1 + (call-with-escape-continuation + (lambda (k) + (with-continuation-mark + 'x 2 + (continuation-mark-set->list (rumble:continuation-marks k) 'x))))) + '(1)) + +(check-error (rumble:continuation-marks (call-with-escape-continuation + (lambda (k) k))) + "continuation application: escape continuation not in the current continuation") + +;; ---------------------------------------- +;; Barriers + +(check (call-with-continuation-barrier + (lambda () + 'ok)) + 'ok) + +(check-error (call-with-continuation-prompt + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-composable-continuation + (lambda (k) + k) + (make-continuation-prompt-tag)))))) + "call-with-composable-continuation: continuation includes no prompt with the given tag") + +(check-error (call-with-continuation-prompt + (lambda () + (call-with-continuation-barrier + (lambda () + (call-with-composable-continuation + (lambda (k) + k)))))) + "call-with-composable-continuation: cannot capture past continuation barrier") + +(check-error (let ([k (call-with-continuation-barrier + (lambda () + (call-with-current-continuation + (lambda (k) + k))))]) + (|#%app| k void)) + "continuation application: attempt to cross a continuation barrier") + +;; ---------------------------------------- +;; Continuation marks + +(printf "Constant-time `continuation-mark-set-first` makes these tests fast enough...\n") + +;; Caching within a metacontinuation frame +(let ([N 100000]) + (check (let loop ([n N]) + (cond + [(zero? n) + (check (length (continuation-mark-set->list + (current-continuation-marks) + 'there)) + N) + n] + [else + (if (continuation-mark-set-first #f 'not-there #f) + 'oops + (with-continuation-mark + 'there n + (- (loop (sub1 n)) 1)))])) + (- N))) + +;; Caching across metacontinuation frames +(let ([N 10000]) + (check (let loop ([n N]) + (cond + [(zero? n) + (check (length (continuation-mark-set->list + (current-continuation-marks) + 'there)) + N) + n] + [else + (if (continuation-mark-set-first #f 'not-there #f) + 'oops + (call-with-continuation-prompt + (lambda () + (with-continuation-mark + 'there n + (- (loop (sub1 n)) 1))) + tag1))])) + (- N))) + +(printf "Done.\n") + +(check (call-with-immediate-continuation-mark + 'not-there + (lambda (v) v)) + #f) +(check (call-with-immediate-continuation-mark + 'not-there + (lambda (v) v) + 'no) + 'no) +(check (with-continuation-mark + 'there 1 + (call-with-immediate-continuation-mark + 'there + (lambda (v) v))) + 1) +(check (with-continuation-mark + 'there 1 + (list + (call-with-immediate-continuation-mark + 'there + (lambda (v) v)))) + '(#f)) + +(define (non-tail v) (values v)) + +(check (with-continuation-mark + 'x1 1 + (with-continuation-mark + 'x2 1 + (non-tail + (with-continuation-mark + 'x1 2 + (non-tail + (with-continuation-mark + 'x2 3 + (values + (continuation-mark-set->list* + (current-continuation-marks) + '(x1 x2) + (default-continuation-prompt-tag) + 'nope)))))))) + '(#(nope 3) #(2 nope) #(1 1))) + +;; Make sure caching doesn't ignore the prompt tag +;; for a continuation-mark lookup +(check (with-continuation-mark + 'x 1 + (non-tail + (with-continuation-mark + 'y 2 + (call-with-continuation-prompt + (lambda () + (call-with-continuation-prompt + (lambda () + (let ([a (continuation-mark-set-first #f 'x)]) + (list a + (continuation-mark-set-first #f 'x #f tag1)))) + tag2)) + tag1)))) + '(1 #f)) + +;; ---------------------------------------- +;; Engines + +(define e (make-engine (lambda () 'done) #f #f)) +(check (cdr (e 20 void list vector)) + '(done)) + +(define e-forever (make-engine (lambda () (let loop () (loop))) #f #f)) +(check (vector? (e-forever 10 void list vector)) + #t) + +(define e-10 (make-engine (lambda () + (let loop ([n 10]) + (cond + [(zero? n) + (engine-return 1 2 3) + (loop 0)] + [else + (engine-block) + (loop (sub1 n))]))) + #f #f)) +(check (let ([started 0]) + (let loop ([e e-10] [n 0]) + (e 100 + (lambda () (set! started (add1 started))) + (lambda (remain a b c) (list a b c n started)) + (lambda (e) + (loop e (add1 n)))))) + '(1 2 3 10 11)) + +;; Check that winders are not run on engine swaps: +(let ([pre 0] + [post 0]) + (let ([e-10/dw (make-engine (lambda () + (let loop ([n 10]) + (cond + [(zero? n) + (values 1 2 3 pre post)] + [else + (engine-block) + (dynamic-wind + (lambda () (set! pre (add1 pre))) + (lambda () (loop (sub1 n))) + (lambda () (set! post (add1 post))))]))) + #f #f)]) + (check (let loop ([e e-10/dw] [n 0]) + (e 200 + void + (lambda (remain a b c pre t-post) (list a b c pre t-post post n)) + (lambda (e) + (loop e (add1 n))))) + '(1 2 3 10 0 10 10)))) + +;; ---------------------------------------- +;; Thread cells (which are really engine cells): + +(let ([ut (make-thread-cell 1)] + [pt (make-thread-cell 100 #t)]) + (define (gen) + (define u-old (thread-cell-ref ut)) + (define p-old (thread-cell-ref pt)) + (thread-cell-set! ut (add1 u-old)) + (thread-cell-set! pt (add1 p-old)) + (list u-old + p-old + (make-engine gen #f #f) + (thread-cell-ref ut) + (thread-cell-ref pt))) + (define l1 ((make-engine gen #f #f) + 100 + void + (lambda (remain l) l) + (lambda (e) (error 'engine "oops")))) + (define l2 ((list-ref l1 2) + 100 + void + (lambda (remain l) l) + (lambda (e) (error 'engine "oops")))) + (check (list-ref l1 0) 1) + (check (list-ref l1 1) 100) + (check (list-ref l1 3) 2) + (check (list-ref l1 4) 101) + (check (list-ref l2 0) 1) + (check (list-ref l2 1) 101) + (check (list-ref l2 3) 2) + (check (list-ref l2 4) 102)) + +;; ---------------------------------------- +;; Parameters: + +(define my-param (make-parameter 'init)) +(check (procedure? my-param) #t) +(let ([e (with-continuation-mark parameterization-key + (extend-parameterization (continuation-mark-set-first #f parameterization-key) my-param 'set) + (make-engine (lambda () (|#%app| my-param)) #f #f))]) + (check (|#%app| my-param) 'init) + (check (e 1000 void (lambda (remain v) v) (lambda (e) (error 'engine "oops"))) 'set)) + +(let ([also-my-param (make-derived-parameter my-param + (lambda (v) (list v)) + (lambda (v) (box v)))]) + (check (procedure? also-my-param) #t) + (check (|#%app| my-param) 'init) + (with-continuation-mark parameterization-key + (extend-parameterization (continuation-mark-set-first #f parameterization-key) also-my-param 'set) + (begin + (check (|#%app| my-param) '(set)) + (check (|#%app| also-my-param) '#&(set))))) + +;; ---------------------------------------- +;; Prompt-tag impersonators + +(let ([tag1i (impersonate-prompt-tag tag1 + ;; handle + (lambda (args) (list 'handle args)) + ;; abort: + (lambda (args) (list 'abort args)) + ;; cc-guard: + (lambda (result) (list 'cc-guard result)) + ;; call-triggered guard impersonator: + (lambda (proc) (lambda (result) + (list 'cc-use (proc result)))))]) + (check (call-with-continuation-prompt + (lambda () + (abort-current-continuation tag1 'bye)) + tag1 + (lambda (arg) + (list 'aborted arg))) + (list 'aborted 'bye)) + (check (call-with-continuation-prompt + (lambda () + (abort-current-continuation tag1 'bye)) + tag1i + (lambda (arg) + (list 'aborted arg))) + (list 'aborted (list 'handle 'bye))) + (check (call-with-continuation-prompt + (lambda () + (abort-current-continuation tag1i 'bye)) + tag1 + (lambda (arg) + (list 'aborted arg))) + (list 'aborted (list 'abort 'bye))) + (check (call-with-continuation-prompt + (lambda () + (call-with-current-continuation + (lambda (k) + (|#%app| k 'jump)) + tag1)) + tag1i + (lambda (arg) 'oops)) + (list 'cc-guard 'jump)) + (check (call-with-continuation-prompt + (lambda () + (call-with-current-continuation + (lambda (k) + (|#%app| k 'jump)) + tag1i)) + tag1 + (lambda (arg) 'oops)) + (list 'cc-use 'jump)) + (check (call-with-continuation-prompt + (lambda () + (call-with-current-continuation + (lambda (k) + (|#%app| k 'jump)) + tag1i)) + tag1i + (lambda (arg) 'oops)) + (list 'cc-use (list 'cc-guard 'jump))) + (void)) + +;; ---------------------------------------- +;; call-with-system-wind + +(define e-sw (make-engine (let ([pre 0] + [post 0]) + (lambda () + (call-with-system-wind + (lambda () + (chez:dynamic-wind + (lambda () + (set! pre (add1 pre))) + (lambda () + (let loop ([n 1000]) + (if (zero? n) + (list pre post) + (loop (sub1 n))))) + (lambda () + (set! post (add1 post)))))))) + #f #f)) + +(check (let ([prefixes 0]) + (let loop ([e e-sw] [i 0]) + (e 100 + (lambda () (set! prefixes (add1 prefixes))) + (lambda (remain v) (list (> i 2) + (= prefixes (add1 i)) + (- (car v) i) + (- (cadr v) i))) + (lambda (e) (loop e (add1 i)))))) + '(#t #t 1 0)) + +;; ---------------------------------------- + +(call-with-continuation-prompt + (lambda () + (error 'demo "this is an intended error")) + tag1) diff --git a/racket/src/cs/demo/expander.ss b/racket/src/cs/demo/expander.ss new file mode 100644 index 0000000000..5750acb34e --- /dev/null +++ b/racket/src/cs/demo/expander.ss @@ -0,0 +1,72 @@ +(import (rumble) + (expander) + (io)) + +(define time-compiler-passes? (getenv "PLT_COMPILER_TIMES")) + +(define (show v) (write v) (newline)) + +(call-in-main-thread + (lambda () + (boot) + + (set-exec-file! (path->complete-path (string->path "../../bin/racket"))) + + (namespace-require ''|#%kernel|) + + (expand '1) + (eval '((lambda (x) x) 1)) + + (eval '(module m '|#%kernel| + (|#%require| (for-syntax '|#%kernel|)) + (define-syntaxes (m) + (lambda (stx) + (quote-syntax 'ex))) + (define-values (x) (m)) + (|#%provide| x))) + (eval '(|#%require| 'm)) + (eval 'x) + + (let () + (define (run s) + (show (eval (read (open-input-string s))))) + ;; (run "'x") + (void)) + + (|#%app| use-compiled-file-paths '()) ; => expand from source + (|#%app| current-library-collection-links + (find-library-collection-links)) + (|#%app| current-library-collection-paths + (find-library-collection-paths)) + + (when time-compiler-passes? + (#%$enable-pass-timing #t)) + + (time (eval '(|#%require| racket/base))) + + ;;(time (eval `(|#%require| "../regexp/demo.rkt"))) + ;;(time (eval `(|#%require| "../../../pkgs/expander/main.rkt"))) + + (when time-compiler-passes? + (let ([l (sort + (lambda (a b) (< (cdr a) (cdr b))) + (map (lambda (r) (cons (car r) + (let ([t (caddr r)]) + (+ (* 1000. (time-second t)) + (/ (time-nanosecond t) 1000000.))))) + (#%$pass-stats)))] + [pad (lambda (s len) + (let ([s (format "~a" s)]) + (string-append (make-string (max 0 (- len (string-length s))) #\space) + s)))] + [dec (lambda (s) (let ([s (format "~a" (/ (round (* s 100)) 100))]) + (if (char=? #\. (string-ref s (- (string-length s) 2))) + (string-append s "0") + s)))]) + (for-each (lambda (p) (printf "~a: ~a\n" + (pad (car p) 30) + (pad (dec (cdr p)) 8))) + (append l + (list (cons 'total (apply + (map cdr l)))))))) + + (void))) diff --git a/racket/src/cs/demo/foreign.ss b/racket/src/cs/demo/foreign.ss new file mode 100644 index 0000000000..a0ca17a84e --- /dev/null +++ b/racket/src/cs/demo/foreign.ss @@ -0,0 +1,73 @@ +(import (rumble)) + +(define-syntax check + (syntax-rules () + [(_ got expect) + (let ([v got] + [expect-v expect]) + (unless (equal? v expect-v) + (error 'check (format "failed: ~s => ~s" 'got v))))])) + +;; ---------------------------------------- + +(define m1 (malloc 24)) + +(check (ptr-set! m1 _int32 99) (void)) +(check (ptr-ref m1 _int32) 99) + +(define _idi (make-cstruct-type (list _int32 _double _int32))) + +(check (ctype-alignof _idi) 8) +(check (ctype-sizeof _idi) 24) ; due to alignment + +(define an-idi (malloc _idi)) +(ptr-set! an-idi _int32 99) +(ptr-set! an-idi _double 1 99.9) + +(check (ptr-ref an-idi _double 'abs 8) 99.9) + +(define double-of-an-idi (ptr-add an-idi 8)) +(check (ptr-ref double-of-an-idi _double) 99.9) + +(define icell (malloc-immobile-cell cons)) +(check (ptr-ref icell _scheme) cons) +(ptr-set! icell _scheme car) +(check (ptr-ref icell _scheme) car) +(free-immobile-cell icell) + +;; ---------------------------------------- + +(define sym1 (gensym)) +(define s/done? #f) +(define done 0) + +(define wb (make-weak-box sym1)) + +(define we/s (rumble:make-stubborn-will-executor void)) +(rumble:will-register we/s sym1 (lambda (s) + (unless (eq? s (weak-box-value wb)) + (error 'stubborn-executor-test "box context wrong")) + (set! s/done? (symbol? s)))) + +(define we (rumble:make-will-executor void)) +(rumble:will-register we sym1 (letrec ([will (lambda (s) + (when s/done? + (error 'stubborn-executor-test "done too early")) + (set! done (add1 done)) + (unless (= done 10) + (rumble:will-register we s will)))]) + will)) + +(set! sym1 #f) + +(define (run p) (when p ((car p) (cdr p)))) + +(let loop () + (unless s/done? + (collect (collect-maximum-generation)) + (run (rumble:will-try-execute we/s)) + (run (rumble:will-try-execute we)) + (loop))) +(collect (collect-maximum-generation)) +(unless (not (weak-box-value wb)) + (error 'stubborn-executor-test "weak box still has a value")) diff --git a/racket/src/cs/demo/hash.ss b/racket/src/cs/demo/hash.ss new file mode 100644 index 0000000000..9838c4b63f --- /dev/null +++ b/racket/src/cs/demo/hash.ss @@ -0,0 +1,425 @@ +(import (rumble)) + +(define-syntax time + (syntax-rules () + [(_ expr1 expr ...) + (let ([pre-mem (current-memory-use 'cumulative)]) + (let-values ([(v cpu user gc) (time-apply (lambda () expr1 expr ...) null)]) + (printf "cpu time: ~s real time: ~s gc time: ~s MB: ~s\n" cpu user gc + (quotient (- (current-memory-use 'cumulative) pre-mem) (* 1024 1024))) + (apply values v)))])) + +(define-values (struct:top top top? top-ref top-set!) + (make-struct-type 'top #f 2 0 #f + (list (cons prop:equal+hash + (list + (lambda (a b eql?) + (eql? (top-1 a) + (top-1 b))) + (lambda (a hc) + (hc (top-1 a))) + (lambda (a hc) + (hc (top-1 a)))))))) +(define top-1 (make-struct-field-accessor top-ref 0)) + +(define-values (struct:trans trans trans? trans-ref trans-set!) + (make-struct-type 'top #f 2 0 #f '() #f)) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([av a] + [bv b]) + (unless (equal? av bv) + (error 'check (format "failed ~s = ~s [expected ~s]" 'a av bv))))])) + +(check (equal? (top 1 2) (top 1 3)) #t) +(check (equal? (top 1 2) (top 2 2)) #f) +(check (hash-ref (hash-set (hash) (top 1 2) 'ok) (top 1 3) #f) 'ok) + +(check (equal? (trans 1 2) (trans 1 2)) #t) +(check (equal? (trans 1 2) (trans 1 3)) #f) +(check (hash-ref (hash-set (hash) (trans 1 2) 'ok) (trans 1 2) #f) 'ok) +(check (hash-ref (hash-set (hash) (trans 1 2) 'ok) (trans 1 3) #f) #f) + +(check (equal? (hash 1 'x 2 'y) (hash 2 'y 1 'x)) #t) +(check (hash-ref (hash (hash 1 'x 2 'y) 7) (hash 2 'y 1 'x) #f) 7) + +;; Check `equal?`-based weak hash tables +(let ([ht (make-weak-hash)] + [apple (string #\a #\p #\p #\l #\e)] + [banana (list "banana")]) + (check (hash-ref ht "apple" 'no) 'no) + (check (hash-set! ht apple 'yes) (void)) + (check (hash-ref ht "apple" 'no) 'yes) + (check (hash-ref ht apple 'no) 'yes) + (check (hash-set! ht apple banana) (void)) + (let ([bp (weak-cons banana #f)]) + (set! apple #f) + (set! banana #f) + (collect (collect-maximum-generation)) + (collect (collect-maximum-generation)) + (check (car bp) #!bwp) + ;; Ensure that `ht` stays live until here + (check (hash? ht) #t))) + +(define (shuffle l) + (define a (make-vector (length l))) + (let loop ([l l] [i 0]) + (unless (null? l) + (let ([x (car l)]) + (let ([j (random (add1 i))]) + (unless (= j i) (vector-set! a i (vector-ref a j))) + (vector-set! a j x))) + (loop (cdr l) (add1 i)))) + (vector->list a)) + +(define l (values #;shuffle (let loop ([i 1000]) + (if (zero? i) + '() + (cons i (loop (sub1 i))))))) + +(printf "large tables\n") +(time + (let loop ([j 1000]) + (define numbers + (let loop ([ht (hasheqv)] [l l]) + (if (null? l) + ht + (loop (hash-set ht (car l) #t) (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [i 1000]) + (if (zero? i) + v + (loop (hash-ref numbers i (lambda () (error 'oops "bad"))) (sub1 i)))) + (loop (sub1 j))))) +(time + (let loop ([j 1000]) + (define numbers + (let loop ([ht (hasheq)] [l l]) + (if (null? l) + ht + (loop (hash-set ht l #t) (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [l l]) + (if (null? l) + v + (loop (hash-ref numbers l (lambda () (error 'oops "bad"))) (cdr l)))) + (loop (sub1 j))))) + +(printf "small tables\n") +(time + (let loop ([j 100000]) + (define numbers + (let loop ([ht (hasheqv)] [i 10]) + (if (zero? i) + ht + (loop (hash-set ht i #t) (sub1 i))))) + (define numbers2 + (let loop ([ht (hasheqv)] [i 10]) + (if (zero? i) + ht + (loop (hash-set ht i #t) (sub1 i))))) + (unless (zero? j) + (let loop ([v #f] [i 10]) + (if (zero? i) + v + (and (hash-keys-subset? numbers numbers2) + (loop (hash-ref numbers i (lambda () (error 'oops "bad"))) (sub1 i))))) + (loop (sub1 j))))) + +(define numbers + (let loop ([ht (hasheqv)] [l l]) + (if (null? l) + ht + (loop (hash-set ht (car l) #t) (cdr l))))) + +(printf "safe iterate\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let loop ([v #f] [i (hash-iterate-first numbers)] [c (hash-count numbers)]) + (if i + (loop (hash-iterate-value numbers i) + (hash-iterate-next numbers i) + (fx1- c)) + (if (zero? c) + v + (error 'safe-iterate "not enough")))) + (loop (sub1 j))))) + +(printf "unsafe iterate\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let loop ([v #f] [i (unsafe-immutable-hash-iterate-first numbers)] [c (hash-count numbers)]) + (if i + (loop (unsafe-immutable-hash-iterate-value numbers i) + (unsafe-immutable-hash-iterate-next numbers i) + (fx1- c)) + (if (zero? c) + v + (error 'unsafe-iterate "not enough")))) + (loop (sub1 j))))) + +(printf "safe vs. unsafe on small table\n") +(let ([ht (let loop ([ht (hasheq)] [i 8]) + (if (zero? i) + ht + (loop (hash-set ht (gensym) #t) (sub1 i))))] + [N 1000000]) + (time + (let loop ([j N]) + (unless (zero? j) + (let loop ([v #f] [i (hash-iterate-first ht)]) + (if i + (loop (hash-iterate-value ht i) + (hash-iterate-next ht i)) + v)) + (loop (sub1 j))))) + (time + (let loop ([j N]) + (unless (zero? j) + (let loop ([v #f] [i (unsafe-immutable-hash-iterate-first ht)]) + (if i + (loop (unsafe-immutable-hash-iterate-value ht i) + (unsafe-immutable-hash-iterate-next ht i)) + v)) + (loop (sub1 j)))))) + +;; ---------------------------------------- + +(printf "mutable large tables\n") +(time + (let loop ([j 1000]) + (define numbers (make-hash)) + (let loop ([l l]) + (if (null? l) + (void) + (begin + (hash-set! numbers (car l) #t) + (loop (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [i 1000]) + (if (zero? i) + v + (loop (hash-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +(printf "mutable small tables\n") +(time + (let loop ([j 100000]) + (define numbers (make-hash)) + (let loop ([i 10]) + (if (zero? i) + (void) + (begin + (hash-set! numbers i #t) + (loop (sub1 i))))) + (unless (zero? j) + (let loop ([v #f] [i 10]) + (if (zero? i) + v + (loop (hash-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +(define mut-numbers (make-hasheqv)) +(let loop ([l l]) + (unless (null? l) + (hash-set! mut-numbers (car l) #t) + (loop (cdr l)))) + +(printf "mutable iterate\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let loop ([v #f] [i (hash-iterate-first mut-numbers)]) + (if i + (loop (hash-iterate-value mut-numbers i) + (hash-iterate-next mut-numbers i)) + v)) + (loop (sub1 j))))) + +(printf "mutable for-each\n") +(time + (let loop ([j 1000]) + (unless (zero? j) + (let ([a #f]) + (hash-for-each mut-numbers (lambda (k v) (set! a v)))) + (loop (sub1 j))))) + +(printf "mutable destructive for-each\n") +(time + (let loop ([j 1000]) + (define ht (hash-copy mut-numbers)) + (unless (zero? j) + (let ([count 0]) + (hash-for-each ht + (lambda (k v) + (set! count (add1 count)) + (hash-remove! ht k))) + (unless (= count (hash-count mut-numbers)) + (error 'mutable-for-each-remove! "bad count"))) + (loop (sub1 j))))) + +;; ---------------------------------------- + +(printf "primitive mutable large tables\n") +(time + (let loop ([j 1000]) + (define numbers (make-hashtable equal-hash-code equal?)) + (let loop ([l l]) + (if (null? l) + (void) + (begin + (hashtable-set! numbers (car l) #t) + (loop (cdr l))))) + (unless (zero? j) + (let loop ([v #f] [i 1000]) + (if (zero? i) + v + (loop (hashtable-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +(printf "primitive mutable small tables\n") +(time + (let loop ([j 100000]) + (define numbers (make-hashtable equal-hash-code equal?)) + (let loop ([i 10]) + (if (zero? i) + (void) + (begin + (hashtable-set! numbers i #t) + (loop (sub1 i))))) + (unless (zero? j) + (let loop ([v #f] [i 10]) + (if (zero? i) + v + (loop (hashtable-ref numbers i #f) (sub1 i)))) + (loop (sub1 j))))) + +;; ---------------------------------------- + +(printf "weak equal table\n") +(let ([ht (make-weak-hash)]) + (define evens + (let loop ([i 1000]) + (define s (format "~a" i)) + (hash-set! ht s i) + (cond + [(zero? i) '()] + [(even? i) + (cons s (loop (sub1 i)))] + [else (loop (sub1 i))]))) + (collect) + (printf "~s\n" (hash-count ht)) + (hash-set! ht "300" 'three-hundred) + (hash-remove! ht "302") + (for-each (lambda (e) + (define v (hash-ref ht (number->string (string->number e)) #f)) + (cond + [(equal? e "302") + (when v (error 'weak "present"))] + [else + (unless v + (error 'weak "missing ~s" e)) + (unless (equal? v (if (equal? e "300") + 'three-hundred + (string->number e))) + (error 'weak "wrong value"))])) + evens) + (let loop ([i (hash-iterate-first ht)] [c 0]) + (if i + (begin + (check (string? (hash-iterate-key ht i)) #t) + (loop (hash-iterate-next ht i) (add1 c))) + (check (hash-count ht) c))) + (check (positive? (length evens)) #t)) + +(check (hash-iterate-first (make-weak-hash)) #f) + +;; ---------------------------------------- + +(let loop ([i 1000]) + (unless (zero? i) + (let ([l2 (list-tail (shuffle l) (quotient (length l) 2))]) + (define half-numbers + (let loop ([ht (hasheqv)] [l l2]) + (if (null? l) + ht + (loop (hash-set ht (car l) #t) (cdr l))))) + (unless (hash-keys-subset? half-numbers numbers) + (error 'subset? "failed")) + (loop (sub1 i))))) + +;; ---------------------------------------- + +(printf "many tables\n") +(collect-garbage) +(define m1 (current-memory-use)) +(define hts + (time + (let loop ([i 0]) + (if (< i 100) + (cons + (let loop2 ([i 0]) + (if (< i 10000) + (hash-set + (loop2 (+ i 1)) + (gensym) + (cons (random 100) (random 100))) + (hasheq))) + (loop (+ 1 i))) + null)))) +(collect-garbage) +(printf "~a\n" (- (current-memory-use) m1)) + +;; ---------------------------------------- + +(printf "test hashing function, counting collisions\n") +(let* ([convert (lambda (l) + (case (random 4) + [(0) l] + [(1) (list->vector l)] + [(2) (box l)] + [(3) (map exact->inexact l)]))] + [l (let loop ([i 1000]) + (if (zero? i) + '() + (cons (convert + (let loop ([j (add1 (random 3))]) + (if (zero? j) + '() + (cons (random 10000) (loop (sub1 j)))))) + (loop (sub1 i)))))]) + (define len (length l)) + (define c-vec (make-vector len)) + (define r-vec (make-vector len)) + (define c-coll (make-hash)) + (define r-coll (make-hash)) + (for-each (lambda (i) + (define c-k (modulo (equal-hash i) len)) + (define r-k (modulo (equal-hash-code i) len)) + (vector-set! c-vec c-k (add1 (vector-ref c-vec c-k))) + (vector-set! r-vec r-k (add1 (vector-ref r-vec r-k)))) + l) + (let loop ([i 0]) + (unless (= i len) + (let () + (define (count coll vec) + (define n (vector-ref vec i)) + (hash-set! coll n (+ 1 (hash-ref coll n 0)))) + (count c-coll c-vec) + (count r-coll r-vec) + (loop (add1 i))))) + (let () + (define (report which coll) + (printf " ~a:\n" which) + (let ([keys (sort < (hash-map coll (lambda (k v) k)))]) + (for-each (lambda (k) + (printf " ~a: ~a\n" k (hash-ref coll k))) + keys))) + (report "equal-hash" c-coll) + (report "equal-hash-code" r-coll)) + (time (for-each (lambda (i) (for-each equal-hash l)) l)) + (time (for-each (lambda (i) (for-each equal-hash-code l)) l))) diff --git a/racket/src/cs/demo/io-impl.rkt b/racket/src/cs/demo/io-impl.rkt new file mode 100644 index 0000000000..7a5e4cf040 --- /dev/null +++ b/racket/src/cs/demo/io-impl.rkt @@ -0,0 +1,101 @@ +#lang racket/base +(require racket/include + racket/unsafe/ops + racket/flonum + racket/fixnum + '#%foreign + (only-in '#%kernel open-input-file) + (only-in '#%paramz + parameterization-key + extend-parameterization + break-enabled-key + check-for-break) + (only-in '#%linklet + primitive-table)) + +(provide (rename-out + (1/build-path/convention-type build-path/convention-type) + (1/peek-bytes! peek-bytes!) + (1/explode-path explode-path) + (1/peek-byte peek-byte) + (1/write write) + (1/fprintf fprintf) + (1/write-bytes-avail write-bytes-avail) + (1/open-output-bytes open-output-bytes) + (1/open-input-file open-input-file) + (1/write-bytes-avail* write-bytes-avail*) + (1/path-element->string path-element->string) + (1/simplify-path simplify-path) + (1/bytes->string/locale bytes->string/locale) + (1/error error) + (1/current-input-port current-input-port) + (1/path->directory-path path->directory-path) + (1/read-bytes-avail!* read-bytes-avail!*) + (1/make-pipe make-pipe) + (1/write-string write-string) + (1/bytes->path bytes->path) + (1/pathbytes/latin-1 string->bytes/latin-1) + (is-path? path?) + (1/bytes->string/utf-8 bytes->string/utf-8) + (1/path->bytes path->bytes) + (1/format format) + (1/newline newline) + (1/string->bytes/utf-8 string->bytes/utf-8) + (1/string->bytes/locale string->bytes/locale) + (1/read-bytes read-bytes) + (pipe-input-port? pipe-input-port?) + (1/string->path-element string->path-element) + (1/peek-char peek-char) + (1/absolute-path? absolute-path?) + (1/path-convention-type path-convention-type) + (1/path->complete-path path->complete-path) + (1/bytes-utf-8-length bytes-utf-8-length) + (1/cleanse-path cleanse-path) + (1/peek-string peek-string) + (1/write-bytes-avail/enable-break write-bytes-avail/enable-break) + (1/display display) + (1/read-char read-char) + (1/make-output-port make-output-port) + (1/bytes->path-element bytes->path-element) + (1/complete-path? complete-path?) + (1/build-path build-path) + (1/relative-path? relative-path?) + (1/path-for-some-system? path-for-some-system?) + (1/open-input-string open-input-string) + (1/string->path string->path) + (1/close-input-port close-input-port) + (1/current-error-port current-error-port) + (1/write-bytes write-bytes) + (1/prop:custom-write prop:custom-write) + (1/read-bytes-avail! read-bytes-avail!) + (1/peek-string! peek-string!) + (1/string-utf-8-length string-utf-8-length) + (pipe-output-port? pipe-output-port?) + (1/print print) + (1/read-byte read-byte) + (1/make-input-port make-input-port) + (1/port-next-location port-next-location) + (1/path-element->bytes path-element->bytes) + (1/split-path split-path) + (1/printf printf) + (1/read-string read-string) + (1/bytes->string/latin-1 bytes->string/latin-1) + (1/port-count-lines! port-count-lines!) + (1/path->string path->string) + (1/current-output-port current-output-port) + (1/peek-bytes-avail! peek-bytes-avail!) + (1/pipe-content-length pipe-content-length) + (1/peek-bytes-avail!* peek-bytes-avail!*) + (1/read-bytes! read-bytes!) + (1/peek-bytes peek-bytes) + (1/close-output-port close-output-port) + (1/open-output-string open-output-string))) + +(define-syntax-rule (linklet () (ex ...) body ...) + (begin body ...)) + +(include "../../io/compiled/io.rktl") diff --git a/racket/src/cs/demo/io.rkt b/racket/src/cs/demo/io.rkt new file mode 100644 index 0000000000..d3621c93e0 --- /dev/null +++ b/racket/src/cs/demo/io.rkt @@ -0,0 +1,64 @@ +#lang racket/base +(require "io-impl.rkt" + (only-in racket/base + [open-input-file c:open-input-file] + [port-count-lines! c:port-count-lines!] + [read-string c:read-string] + [close-input-port c:close-input-port] + [bytes->string/utf-8 c:bytes->string/utf-8] + [string->bytes/utf-8 c:string->bytes/utf-8])) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop () + (define s (read-string 100 p)) + (unless (eof-object? s) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +'|Same, but in C....| +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (c:open-input-file "compiled/io.scm")) + (c:port-count-lines! p) + (let loop () + (define s (c:read-string 100 p)) + (unless (eof-object? s) + (loop))) + (c:close-input-port p) + (loop (sub1 j)))))) + + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop () + (unless (eof-object? (read-byte p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([i 1000000] [v #f]) + (if (zero? i) + v + (loop (sub1 i) + (bytes->string/utf-8 (string->bytes/utf-8 "ap\x3BB;ple")))))) + +'|Same, but in C...| +(time + (let loop ([i 1000000] [v #f]) + (if (zero? i) + v + (loop (sub1 i) + (c:bytes->string/utf-8 (c:string->bytes/utf-8 "ap\x3BB;ple")))))) diff --git a/racket/src/cs/demo/io.ss b/racket/src/cs/demo/io.ss new file mode 100644 index 0000000000..ef59ab1697 --- /dev/null +++ b/racket/src/cs/demo/io.ss @@ -0,0 +1,120 @@ +(import (rumble) + (io) + (thread)) + +(define-syntax test + (syntax-rules () + [(_ expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))])) + +;; ---------------------------------------- + +(test #t (directory-exists? "demo")) +(test #f (directory-exists? "no-such-demo")) + +;; ---------------------------------------- + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop ([total 0]) + (define s (read-string 100 p)) + (unless (eof-object? s) + (loop (+ total (string-length s))))) + (loop (sub1 j)))))) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.scm")) + (port-count-lines! p) + (let loop () + (unless (eof-object? (read-byte p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([i 1000000] [v #f]) + (if (zero? i) + v + (loop (sub1 i) + (bytes->string/utf-8 (string->bytes/utf-8 "ap\x3BB;ple")))))) + + +;; ---------------------------------------- + +(let ([c (make-custodian)]) + (with-continuation-mark + parameterization-key + (extend-parameterization (continuation-mark-set-first #f parameterization-key) current-custodian c) + (let () + (define p (open-input-file "compiled/io.scm")) + (define wb (make-weak-box p)) + (define we (make-will-executor)) + (will-register we p values) + (set! p #f) + (collect (collect-maximum-generation)) + (test #t (input-port? (will-try-execute we))) + (collect (collect-maximum-generation)) + (test #f (weak-box-value wb)) + (custodian-shutdown-all c)))) + +;; ---------------------------------------- + +(call-in-main-thread + (lambda () + (define root-logger (make-logger)) + + (test 'none (log-max-level root-logger)) + (add-stderr-log-receiver! root-logger 'warning) + + (test 'warning (log-max-level root-logger)) + + (log-message root-logger 'error "this should print to stderr" 5) + + (let () + (define demo1-logger (make-logger 'demo1 root-logger)) + (define demo2-logger (make-logger 'demo2 root-logger 'fatal)) + + (log-message demo1-logger 'error "this should print to stderr, too" 5) + (log-message demo2-logger 'error "this should not print to stderr" 5) + + (test 'warning (log-max-level demo1-logger)) + (test 'fatal (log-max-level demo2-logger)) + + (let () + (define lr1 (make-log-receiver root-logger 'info 'cats)) + + (test 'info (log-max-level demo1-logger)) + (test 'fatal (log-max-level demo2-logger)) + + (test 'info (log-max-level demo1-logger 'cats)) + (test 'fatal (log-max-level demo2-logger 'cats)) + + (test 'warning (log-max-level demo1-logger 'dogs)) + (test 'fatal (log-max-level demo2-logger 'dogs)) + + (test #t (log-level? demo1-logger 'info 'cats)) + (test #f (log-level? demo1-logger 'debug 'cats)) + (test #f (log-level? demo1-logger 'info 'dogs)) + + (let () + (define msg1 #f) + (define th1 (thread (lambda () (set! msg1 (sync lr1))))) + (sync (system-idle-evt)) + (test #f msg1) + + (log-message demo1-logger 'info 'cats "hello" 7) + (sync (system-idle-evt)) + (test '#(info "cats: hello" 7 cats) msg1) + + (log-message demo1-logger 'info 'cats "goodbye" 9) + (test '#(info "cats: goodbye" 9 cats) (sync lr1))))))) diff --git a/racket/src/cs/demo/linklet.rkt b/racket/src/cs/demo/linklet.rkt new file mode 100644 index 0000000000..2f8b66ac63 --- /dev/null +++ b/racket/src/cs/demo/linklet.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require racket/pretty + "chezify.rkt") + +(pretty-print + (chezify-linklet '(linklet + (import (a b c)) + (export f g x) + (define-values (f) (lambda () (g))) + (define-values (g) (lambda () (a (f)))) + (define-values (x) 5)) + #hasheq())) + diff --git a/racket/src/cs/demo/linklet.ss b/racket/src/cs/demo/linklet.ss new file mode 100644 index 0000000000..d781e15f17 --- /dev/null +++ b/racket/src/cs/demo/linklet.ss @@ -0,0 +1,20 @@ +(import (rumble) + (linklet)) + +(define l1 (compile-linklet + '(linklet + () ; imports + (f x) ; exports + (define-values (f) (lambda (y) (add1 y))) + (define-values (x) 5) + 'done) + 'l1)) + +(define l2 (compile-linklet + '(linklet + ((f x)) ; imports + () ; exports + (display (f x)) + (newline)))) + +(instantiate-linklet l2 (list (instantiate-linklet l1 '()))) diff --git a/racket/src/cs/demo/regexp.rkt b/racket/src/cs/demo/regexp.rkt new file mode 100644 index 0000000000..df55a2ab06 --- /dev/null +++ b/racket/src/cs/demo/regexp.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(require racket/include + racket/unsafe/ops) + +;; Run using the built-in C implementation: +'|C -----------------| +(include "regexp.rktl") + +;; Run the Racket implementation: +'|Racket -----------------| +(let () + (define-syntax-rule (linklet () ([int-id ext-id] ...) body ...) + (begin + (define ext-id #f) ... + (let () + body ... + (set! ext-id int-id) ...))) + (include "../../regexp/compiled/regexp.rktl") + + ;; Run using the Racket implementation: + (include "regexp.rktl")) diff --git a/racket/src/cs/demo/regexp.rktl b/racket/src/cs/demo/regexp.rktl new file mode 100644 index 0000000000..7669460f75 --- /dev/null +++ b/racket/src/cs/demo/regexp.rktl @@ -0,0 +1,51 @@ +(define (check pat str) + (write + (time + (let ([rx (byte-regexp (string->bytes/utf-8 pat))] + [in (string->bytes/utf-8 str)]) + (let loop ([v #f] [n 100000]) + (if (zero? n) + v + (loop (regexp-match rx in) + (sub1 n))))))) + (newline)) + +;; A smallish backtracking test, more or less: +(check "ab(?:a*c)*d" "abaacacaaacacaaacd") + +;; Relatively realitic workload: +(define ipv6-hex "[0-9a-fA-F:]*:[0-9a-fA-F:]*") +(define url-s + (string-append + "^" + "(?:" ; / scheme-colon-opt + "([^:/?#]*)" ; | #1 = scheme-opt + ":)?" ; \ + "(?://" ; / slash-slash-authority-opt + "(?:" ; | / user-at-opt + "([^/?#@]*)" ; | | #2 = user-opt + "@)?" ; | \ + "(?:" ; + "(?:\\[" ; | / #3 = ipv6-host-opt + "(" ipv6-hex ")" ; | | hex-addresses + "\\])|" ; | \ + "([^/?#:]*)" ; | #4 = host-opt + ")?" ; + "(?::" ; | / colon-port-opt + "([0-9]*)" ; | | #5 = port-opt + ")?" ; | \ + ")?" ; \ + "([^?#]*)" ; #6 = path + "(?:\\?" ; / question-query-opt + "([^#]*)" ; | #7 = query-opt + ")?" ; \ + "(?:#" ; / hash-fragment-opt + "(.*)" ; | #8 = fragment-opt + ")?" ; \ + "$")) +(define rlo "https://racket-lang.org:80x/people.html?check=ok#end") +(check url-s rlo) + +;; A test of scanning a byte string to look for the letter "b" +;; (where a tight loop in C is likely to win): +(check "a*b" (make-string 1024 #\a)) diff --git a/racket/src/cs/demo/regexp.ss b/racket/src/cs/demo/regexp.ss new file mode 100644 index 0000000000..c25f711ecd --- /dev/null +++ b/racket/src/cs/demo/regexp.ss @@ -0,0 +1,5 @@ +(import (rumble) + (regexp) + (io)) + +(include "demo/regexp.rktl") diff --git a/racket/src/cs/demo/struct.ss b/racket/src/cs/demo/struct.ss new file mode 100644 index 0000000000..bd96b1f3de --- /dev/null +++ b/racket/src/cs/demo/struct.ss @@ -0,0 +1,275 @@ +(import (rumble)) + +(define (show v) (printf "~s\n" v) v) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([v a]) + (unless (equal? v b) + (error 'check (format "failed ~s => ~s" 'a v))))])) + +;; ---------------------------------------- + +(define-values (prop:x x? x-ref) (make-struct-type-property 'x)) + +(define-values (struct:a make-a a? a-ref a-set!) + (make-struct-type 'a #f 2 0 #f (list (cons prop:x 5)))) +(define a-x (make-struct-field-accessor a-ref 0 'x)) +(define a-y (make-struct-field-accessor a-ref 1 'y)) +(define-values (struct:b make-b b? b-ref b-set!) + (make-struct-type 'b #f 2 0 #f (list + (cons prop:equal+hash + (list (lambda (o t eql?) + (eql? (b-x o) (b-x t))) + (lambda (o hc) 0) + (lambda (o hc) 0)))))) +(define b-x (make-struct-field-accessor b-ref 0 'x)) +(define b-y (make-struct-field-accessor b-ref 1 'y)) + +(define an-a (make-a 1 2)) +(define b1 (make-b 3 4)) +(define b2 (make-b 3 4)) + +(check (a-x an-a) 1) +(check (|#%app| a-ref an-a 0) 1) +(check (|#%app| a-ref an-a 1) 2) + +(time (let loop ([i 10000000] [v1 (make-b 3 4)] [v2 (make-b 3 4)]) + (cond + [(= i 0) (list b1 b2)] + [else (loop (sub1 i) (if (equal? v1 v2) v2 v1) v1)]))) + + +(define-values (struct:p make-p p? p-ref p-set!) + (make-struct-type 'p #f 2 0 #f (list (cons prop:procedure 0)) (|#%app| current-inspector) #f '(0 1))) + +(check (|#%app| (make-p (lambda (x) (cons x x)) 'whatever) 10) '(10 . 10)) + +(check (procedure-arity (make-p add1 'x)) 1) +(check (procedure-arity (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x)) + (list 1 (|#%app| arity-at-least 3))) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 0) + #f) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 1) + #t) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 2) + #f) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 3) + #t) +(check (procedure-arity-includes? (make-p (case-lambda [(x) 1] [(x y z . w) 2]) 'x) 3000) + #t) + +(define-values (struct:p0 make-p0 p0? p0-ref p0-set!) + (make-struct-type 'p0 #f 2 0 #f)) +(define-values (struct:p1 make-p1 p1? p1-ref p1-set!) + (make-struct-type 'p1 struct:p0 2 0 #f '() (|#%app| current-inspector) 0)) + +(check (|#%app| (make-p (lambda (x) (cons x x)) 'whatever) 10) '(10 . 10)) +(check (|#%app| (make-p1 'no 'nope (lambda (x) (list x x)) 'whatever) 11) '(11 11)) + +(define-values (struct:p2 make-p2 p2? p2-ref p2-set!) + (make-struct-type 'p2 struct:p0 2 0 #f + (list (cons prop:procedure + (lambda (p2 x) + (list (|#%app| p2-ref p2 0) x)))))) + +(check (|#%app| (make-p2 0 1 'a 'b) 'c) '(a c)) +(check (procedure-arity (make-p2 0 1 'a 'b)) 1) +(check (procedure-arity-includes? (make-p2 0 1 'a 'b) 1) #t) +(check (procedure-arity-includes? (make-p2 0 1 'a 'b) 2) #f) + +;; ---------------------------------------- +;; Inspectors and `struct->vector` + +(check (struct->vector an-a) '#(struct:a ...)) + +(check (call-with-values (lambda () (struct-info an-a)) list) '(#f #t)) +(check (call-with-values (lambda () (struct-info 7)) list) '(#f #t)) + +(define sub-i (make-inspector (|#%app| current-inspector))) +(define-values (struct:q make-q q? q-ref q-set!) + (make-struct-type 'q #f 2 0 #f '() sub-i)) + +(define a-q (make-q 9 10)) +(check (struct->vector a-q) '#(struct:q 9 10)) +(check (call-with-values (lambda () (struct-info a-q)) list) (list struct:q #f)) +(check ((struct-type-make-constructor struct:q) 9 10) a-q) +(check ((struct-type-make-predicate struct:q) a-q) #t) + +(check (andmap (lambda (a b) + (or (equal? a b) + (and (struct-accessor-procedure? a) + (struct-accessor-procedure? b)) + (and (struct-mutator-procedure? a) + (struct-mutator-procedure? b)))) + (call-with-values (lambda () (struct-type-info struct:q)) list) + (list 'q 2 0 q-ref q-set! '() #f #f)) + #t) + +(define-values (struct:q+3 make-q+3 q+3? q+3-ref q+3-set!) + (make-struct-type 'q+3 struct:q 3 0)) + +(define a-q+3 (make-q+3 9 10 'a 'b 'c)) +(check (|#%app| q+3-ref a-q+3 0) 'a) +(check (|#%app| q+3-ref a-q+3 1) 'b) +(check ((make-struct-field-accessor q+3-ref 1 'second) a-q+3) 'b) +(check (struct->vector a-q+3) '#(struct:q+3 9 10 ...)) + +(define-values (struct:q+3+2 make-q+3+2 q+3+2? q+3+2-ref q+3+2-set!) + (make-struct-type 'q+3+2 struct:q+3 2 0 #f '() sub-i)) + +(check (struct->vector (make-q+3+2 9 10 'a 'b 'c "x" "y")) '#(struct:q+3+2 9 10 ... "x" "y")) + +;; ---------------------------------------- +;; Prefabs + +(check (prefab-key? 'a) #t) +(check (prefab-key? '(a)) #t) +(check (prefab-key? '(a 5)) #t) +(check (prefab-key? '(a 5 (0 #f))) #t) +(check (prefab-key? '(a 5 (3 #f))) #t) +(check (prefab-key? '(a (0 #f))) #t) +(check (prefab-key? '(a 3 (0 #f) #())) #t) +(check (prefab-key? '(a 3 #())) #t) +(check (prefab-key? '(a #())) #t) +(check (prefab-key? '(a 3 (0 #f) #(1 2))) #t) +(check (prefab-key? '(a 3 (10 #f) #(11 12))) #t) +(check (prefab-key? '(a #(100 101 99))) #t) +(check (prefab-key? '(a 3 (0 #f) #(2) b 1)) #t) +(check (prefab-key? '(a 3 b 1)) #t) +(check (prefab-key? '(a b 1)) #t) + +(check (prefab-key? "a") #f) +(check (prefab-key? '(a a)) #f) +(check (prefab-key? '(a . 5)) #f) +(check (prefab-key? '(a 5 (x #f))) #f) +(check (prefab-key? '(a 5 (2))) #f) +(check (prefab-key? '(a 5 (3 #f 5))) #f) +(check (prefab-key? '(a (x #f))) #f) +(check (prefab-key? '(a 3 (0 #f) #(x))) #f) +(check (prefab-key? '(a 3 (0 #f) #(-2))) #f) +(check (prefab-key? '(a 3 (0 #f) #(3))) #f) +(check (prefab-key? '(a 3 #(11 12))) #f) +(check (prefab-key? '(a #(100 101 100))) #f) +(check (prefab-key? '(a 3 (0 #f) #(2) b)) #f) +(check (prefab-key? '(a 3 (0 #f) #(2) "b" 1)) #f) +(check (prefab-key? '(a 3 (0 #f) #(2) b -1)) #f) + +(check (prefab-struct-key (make-prefab-struct 'a 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a 1) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct 'a 1 2)) 'a) +(check (equal? (make-prefab-struct 'a 1 2) + (make-prefab-struct 'a 1 2)) + #t) +(check (equal? (make-prefab-struct 'a 1) + (make-prefab-struct 'a 1 2)) + #f) + +(check (prefab-struct-key (make-prefab-struct '(a 1 (0 #f) #()) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a 1 (0 #f)) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a 1 #()) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a (0 #f) #()) 1)) 'a) +(check (prefab-struct-key (make-prefab-struct '(a (0 #f) #(0)) 1)) '(a #(0))) + +(let () + (define-values (struct:f make-f f? f-ref f-set!) + (make-struct-type 'f #f 1 0 #f '() 'prefab #f '(0))) + (define-values (struct:g make-g g? g-ref g-set!) + (make-struct-type 'g struct:f 2 0 #f '() 'prefab #f '(0 1))) + (define-values (struct:h make-h h? h-ref h-set!) + (make-struct-type 'h struct:g 3 0 #f '() 'prefab #f '(0 1 2))) + + (check (prefab-struct-key (make-f 1)) 'f) + (check (prefab-struct-key (make-g 1 2 3)) '(g f 1)) + (check (prefab-struct-key (make-h 1 2 3 4 5 6)) '(h g 2 f 1)) + + (void)) + +;; ---------------------------------------- +;; Guards + +(define checked-names '()) + +(define-values (struct:ga make-ga ga? ga-ref ga-set!) + (make-struct-type 'ga #f 2 0 #f null (|#%app| current-inspector) #f '(0 1) + (lambda (a b name) + (set! checked-names (cons name checked-names)) + (values a (box b))))) + +(check (|#%app| ga-ref (|#%app| make-ga 1 2) 1) (box 2)) +(check checked-names '(ga)) + +(define-values (struct:gb make-gb gb? gb-ref gb-set!) + (make-struct-type 'gb struct:ga 1 0 #f null (|#%app| current-inspector) #f '(0) + (lambda (a b c name) + (values a (list b) c)))) + +(check (|#%app| ga-ref (|#%app| make-gb 1 2 3) 1) (box (list 2))) +(check checked-names '(gb ga)) + +;; ---------------------------------------- +;; Graphs + +(let* ([p (make-placeholder #f)] + [c (cons 1 p)]) + (placeholder-set! p c) + (check (make-reader-graph p) + '#0=(1 . #0#))) + +(let* ([p (make-placeholder #f)] + [v (vector-immutable p 2 3)] + [b (box-immutable v)]) + (placeholder-set! p b) + (check (make-reader-graph v) + '#0=#(#�# 2 3))) + +(let* ([p (make-placeholder #f)] + [hp (make-hash-placeholder (list (cons 1 'a) (cons 2 p)))]) + (placeholder-set! p hp) + (let ([ht (make-reader-graph p)]) + (check (hash-ref ht 1) 'a) + (check (hash-ref (hash-ref ht 2) 1) 'a))) + +(let* ([p (make-placeholder #f)] + [a (make-prefab-struct 'a 1 2 p)]) + (define-values (struct:a make-a a? a-ref a-set!) + (make-struct-type 'a #f 3 0 #f '() 'prefab #f '(0 1 2))) + (placeholder-set! p a) + (check (|#%app| a-ref (|#%app| a-ref (|#%app| a-ref (make-reader-graph a) 2) 2) 0) + 1)) + +;; ---------------------------------------- + +(let () + (define-values (struct:s-a make-s-a s-a? s-a-ref s-a-set!) + (make-struct-type 'x #f 2 0 #f (list (cons prop:x 5)))) + (define s-a-x (make-struct-field-accessor s-a-ref 0 'x)) + (let ([an-a (make-s-a 1 2)]) + (time + (let loop ([i 10000000] [v 0]) + (if (zero? i) + v + (loop (sub1 i) (+ v (s-a-x an-a)))))))) + +(let () + (define struct:s-a (make-record-type-descriptor 's #f #f #f #f '#((mutable x) (mutable y)))) + (define make-s-a (record-constructor + (make-record-constructor-descriptor struct:s-a #f #f))) + (define s-a-x (record-accessor struct:s-a 0)) + (let ([an-a (make-s-a 1 2)]) + (time + (let loop ([i 10000000] [v 0]) + (if (zero? i) + v + (loop (sub1 i) (+ v (s-a-x an-a)))))))) + +(let () + (define-record r-a (x y)) + + (let ([an-a (make-r-a 1 2)]) + (time + (let loop ([i 10000000] [v 0]) + (if (zero? i) + v + (loop (sub1 i) (+ v (r-a-x an-a)))))))) diff --git a/racket/src/cs/demo/thread.ss b/racket/src/cs/demo/thread.ss new file mode 100644 index 0000000000..9098dc3f0f --- /dev/null +++ b/racket/src/cs/demo/thread.ss @@ -0,0 +1,221 @@ +(import (rumble) + (thread)) + +(define-syntax declare + (syntax-rules () + [(_ id ...) + (begin (define id #f) ...)])) + +(define done? #f) + +(call-in-main-thread + (lambda () + (define-syntax check + (syntax-rules () + [(_ a b) + (unless (equal? a b) + (printf "~s: ~s vs. ~s\n" 'b a b) + (error 'check "failed"))])) + + (declare s t0 t1 t2 + ch ct1 ct2 + cpt1 cpt2 + s2 + pc + ok-evt + sp + nack + now1 now2 now3 + t tinf tdelay + tdw dw-s dw-pre? dw-body? dw-post?) + + (define-syntax define + (syntax-rules () + [(_ id rhs) (set! id rhs)])) + + (check #t (thread? (current-thread))) + (check #t (evt? (current-thread))) + (define s (make-semaphore)) + (define t0 (thread (lambda () (semaphore-wait s) (printf "__\n") (semaphore-post s)))) + (define t1 (thread (lambda () (semaphore-wait s) (printf "hi\n") (semaphore-post s)))) + (define t2 (thread (lambda () (printf "HI\n") (semaphore-post s)))) + (thread-wait t0) + (thread-wait t1) + (thread-wait t2) + + (define ch (make-channel)) + (define ct1 (thread (lambda () (printf "1 ~a\n" (channel-get ch))))) + (define ct2 (thread (lambda () (printf "2 ~a\n" (channel-get ch))))) + (channel-put ch 'a) + (channel-put ch 'b) + + (define cpt1 (thread (lambda () (channel-put ch 'c)))) + (define cpt2 (thread (lambda () (channel-put ch 'd)))) + (printf "3 ~a\n" (channel-get ch)) + (printf "4 ~a\n" (channel-get ch)) + + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 s)) + + (define s2 (make-semaphore 3)) + (check s2 (sync/timeout 0 s s2)) + (check s2 (sync/timeout 0 s2 s)) + (check 'got-s2 (sync s (wrap-evt s2 (lambda (v) (check v s2) 'got-s2)))) + (check #f (sync/timeout 0 s2 s)) + + (void (thread (lambda () (channel-put ch 'c2)))) + (check 'c2 (sync ch)) + + (void (thread (lambda () (check 'c3 (channel-get ch))))) + (define pc (channel-put-evt ch 'c3)) + (check pc (sync pc)) + + (define ok-evt (guard-evt + (lambda () + (define ch (make-channel)) + (thread (lambda () (channel-put ch 'ok))) + ch))) + (check 'ok (sync ok-evt)) + + (semaphore-post s) + (define sp (semaphore-peek-evt s)) + (check sp (sync/timeout 0 sp)) + (check sp (sync/timeout 0 sp)) + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 sp)) + + (define nack #f) + (check #t (semaphore? (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore 1)))))) + (check #f (sync/timeout 0 nack)) + (set! nack #f) + (let loop () + (check 'ok (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore))) ok-evt)) + (unless nack (loop))) + (check (void) (sync/timeout 0 nack)) + + (semaphore-post s) + (check #f (sync/timeout 0 ch (channel-put-evt ch 'oops))) + (check sp (sync/timeout #f ch (channel-put-evt ch 'oops) sp)) + + (define now1 (current-inexact-milliseconds)) + (sleep 0.1) + (check #t (>= (current-inexact-milliseconds) (+ now1 0.1))) + + (define now2 (current-inexact-milliseconds)) + (define ts (thread (lambda () (sleep 0.1)))) + (check ts (sync ts)) + (check #t (>= (current-inexact-milliseconds) (+ now2 0.1))) + + (define v 0) + (thread (lambda () (set! v (add1 v)))) + (sync (system-idle-evt)) + (check 1 v) + + (define tinf (thread (lambda () (let loop () (loop))))) + (break-thread tinf) + (check tinf (sync tinf)) + (printf "[That break was from a thread, and it's expected]\n") + + (define now3 (current-inexact-milliseconds)) + (define tdelay (with-continuation-mark + break-enabled-key + (make-thread-cell #f #t) + (thread (lambda () + (sleep 0.1) + (with-continuation-mark + break-enabled-key + (make-thread-cell #t #t) + (begin + ;(check-for-break) + (let loop () (loop)))))))) + (break-thread tdelay) + (check tdelay (sync tdelay)) + (printf "[That break was from a thread, and it's expected]\n") + (check #t (>= (current-inexact-milliseconds) (+ now3 0.1))) + + ;; Make sure breaks are disabled in a `dynamic-wind` post thunk + (define dw-s (make-semaphore)) + (define dw-pre? #f) + (define dw-body? #f) + (define dw-post? #f) + (define tdw (thread + (lambda () + (dynamic-wind + (lambda () (semaphore-wait dw-s) (set! dw-pre? #t)) + (lambda () (set! dw-body? #f)) + (lambda () (set! dw-post? #t)))))) + (sync (system-idle-evt)) + (check #f dw-pre?) + (break-thread tdw) + (check #f dw-pre?) + (semaphore-post dw-s) + (sync tdw) + (check #t dw-pre?) + (check #f dw-body?) + (check #t dw-post?) + + ;; Make sure `equal?`-based hash tables are thread-safe + (let* ([ht (make-hash)] + [s (make-semaphore)] + [compare-ok (semaphore-peek-evt s)] + [trying 0] + [result #f]) + (define-values (struct:posn make-posn posn? posn-ref posn-set!) + (make-struct-type 'posn #f 2 0 #f (list (cons prop:equal+hash + (list + (lambda (a b eql?) + (set! trying (add1 trying)) + (sync compare-ok) + #t) + (lambda (a hc) 0) + (lambda (a hc) 0)))))) + (hash-set! ht (make-posn 1 2) 11) + (thread (lambda () + (set! result (hash-ref ht (make-posn 1 2) #f)))) + (sync (system-idle-evt)) + (check #f result) + (check 1 trying) + (thread (lambda () + ;; Should get stuck before calling the `posn` equality function: + (set! result (hash-ref ht (make-posn 1 2) #f)))) + (check #f result) + (check 1 trying) ; since the second thread is waiting for the table + (semaphore-post s) + (sync (system-idle-evt)) + (check 11 result) + (sync (system-idle-evt)) + (check 2 trying)) ; second thread should have completed + + ;; Measure thread quantum: + #; + (let ([t1 (thread (lambda () (let loop () (loop))))] + [t2 (thread (lambda () (let loop () + (define n (current-inexact-milliseconds)) + (sleep) + (fprintf (current-error-port) "~a\n" (- (current-inexact-milliseconds) n)) + (loop))))]) + (sleep 0.5) + (break-thread t1) + (break-thread t2)) + + (time + (let ([s1 (make-semaphore)] + [s2 (make-semaphore)]) + (let ([ping + (lambda (s1 s2) + (let loop ([n 1000000]) + (if (zero? n) + 'done + (begin + (semaphore-post s1) + (semaphore-wait s2) + (loop (sub1 n))))))]) + (let ([t1 (thread (lambda () (ping s1 s2)))] + [t2 (thread (lambda () (ping s2 s1)))]) + (thread-wait t1) + (thread-wait t2))))) + + (set! done? #t))) + +(unless done? + (error 'thread-demo "something went wrong; deadlock?")) diff --git a/racket/src/cs/demo/will.ss b/racket/src/cs/demo/will.ss new file mode 100644 index 0000000000..ec31042ffb --- /dev/null +++ b/racket/src/cs/demo/will.ss @@ -0,0 +1,46 @@ +(import (rumble)) + +(define-syntax check + (syntax-rules () + [(_ a b) + (let ([v b]) + (unless (equal? a v) + (error 'check (format "failed ~s = ~s" 'b v))))])) + +(define we (make-will-executor void)) +(define we2 (make-will-executor void)) +(define we3 (make-will-executor void)) +(check #t (will-executor? we)) + +(define s1 (gensym)) +(define s2 (gensym)) +(will-register we s1 (let ([s2 s2]) (lambda (s) s2))) +(will-register we2 s1 (lambda (s) 'second)) +(will-register we s1 (lambda (s) 'first)) +(will-register we3 s2 (lambda (s) 'other)) + +(set! s1 #f) +(set! s2 #f) + +(define (gc) + (collect (collect-maximum-generation))) + +(define (will-try-execute* we) + (let ([p (will-try-execute we)]) + (and p + ((car p) (cdr p))))) + +(gc) +(check 'first (will-try-execute* we)) +(gc) +(check 'second (will-try-execute* we2)) +(gc) +(check #f (will-try-execute* we3)) +(gc) +(check #t (gensym? (will-try-execute* we))) +(gc) +(check 'other (will-try-execute* we3)) +(gc) +(check #f (will-try-execute* we)) +(gc) +(check #f (will-try-execute* we2)) diff --git a/racket/src/cs/expander.rkt b/racket/src/cs/expander.rkt new file mode 100644 index 0000000000..237154ada3 --- /dev/null +++ b/racket/src/cs/expander.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require '#%paramz + (only-in '#%kernel prop:method-arity-error) + '#%linklet + racket/unsafe/ops + racket/fixnum + racket/flonum + racket/include) + +(define-syntax-rule (linklet () ([int-id ext-id] ...) body ...) + (begin + (provide (rename-out [int-id ext-id] ...)) + body ...)) + +(include "expander.rktl") diff --git a/racket/src/cs/expander.sls b/racket/src/cs/expander.sls new file mode 100644 index 0000000000..ffa07ca153 --- /dev/null +++ b/racket/src/cs/expander.sls @@ -0,0 +1,184 @@ +(library (expander) + (export current-command-line-arguments + executable-yield-handler + load-on-demand-enabled + call-in-main-thread + version + exit) + (import (except (chezpart) + syntax->datum + datum->syntax) + (rename (rumble) + [correlated? syntax?] + [correlated-source syntax-source] + [correlated-line syntax-line] + [correlated-column syntax-column] + [correlated-position syntax-position] + [correlated-span syntax-span] + [correlated-e syntax-e] + [correlated->datum syntax->datum] + [datum->correlated datum->syntax] + [correlated-property syntax-property] + [correlated-property-symbol-keys syntax-property-symbol-keys]) + (thread) + (regexp) + (io) + (linklet)) + + ;; Set to `#t` to make compiled code reliably compatible with + ;; changes to primitive libraries. Changing ths setting makes + ;; the build incompatible with previously generated ".zo" files. + (define compile-as-independent? #f) + + ;; The expander needs various tables to set up primitive modules, and + ;; the `primitive-table` function is the bridge between worlds + + (define (primitive-table key) + (case key + [(|#%linklet|) linklet-table] + [(|#%kernel|) kernel-table] + [(|#%read|) (make-hasheq)] + [(|#%paramz|) paramz-table] + [(|#%unsafe|) unsafe-table] + [(|#%foreign|) foreign-table] + [(|#%futures|) futures-table] + [(|#%place|) place-table] + [(|#%flfxnum|) flfxnum-table] + [(|#%extfl|) extfl-table] + [(|#%network|) network-table] + [else #f])) + + (define-syntax define-primitive-table + (syntax-rules () + [(_ id [prim known] ...) + (define id + (let ([ht (make-hasheq)]) + (hash-set! ht 'prim prim) + ... + ht))])) + + (include "primitive/kernel.ss") + (include "primitive/unsafe.ss") + (include "primitive/flfxnum.ss") + (include "primitive/paramz.ss") + (include "primitive/extfl.ss") + (include "primitive/network.ss") + (include "primitive/futures.ss") + (include "primitive/place.ss") + (include "primitive/foreign.ss") + (include "primitive/linklet.ss") + (include "primitive/internal.ss") + + ;; ---------------------------------------- + + (include "include.ss") + (include-generated "expander.scm") + + ;; ---------------------------------------- + + ;; The environment is used to evaluate linklets, so all primitives + ;; need to be there imported (prefered) or defined (less efficient, + ;; but less tied to library implementations) + (unless compile-as-independent? + (parameterize ([expand-omit-library-invocations #f]) + (eval `(import (rename (rumble) + [correlated? syntax?] + [correlated-source syntax-source] + [correlated-line syntax-line] + [correlated-column syntax-column] + [correlated-position syntax-position] + [correlated-span syntax-span] + [correlated-e syntax-e] + [correlated->datum syntax->datum] + [datum->correlated datum->syntax] + [correlated-property syntax-property] + [correlated-property-symbol-keys syntax-property-symbol-keys]) + (thread) + (io) + (regexp) + (linklet))) + ;; Ensure that the library is visited, especially for a wpo build: + (eval 'variable-set!))) + + (eval `(define primitive-table ',primitive-table)) + + (let ([install-table + (lambda (table) + (hash-for-each table + (lambda (k v) + ;; Avoid redefining some primitives that we + ;; don't have to replace: + (unless (memq k '(vector + list cons car cdr + eq? + values call-with-values)) + (eval `(define ,k ',v))))))]) + (when compile-as-independent? + (install-table kernel-table) + (install-table unsafe-table) + (install-table flfxnum-table) + (install-table paramz-table) + (install-table extfl-table) + (install-table network-table) + (install-table futures-table) + (install-table place-table) + (install-table foreign-table) + (install-table linklet-table) + (install-table internal-table) + (install-table schemify-table))) + + (when compile-as-independent? + ;; Copies of macros provided by `rumble`, plus + ;; other bindings assumed by schemify: + (eval '(define-syntax with-continuation-mark + (syntax-rules () + [(_ key val body) + (call/cm key val (lambda () body))]))) + (eval '(define-syntax begin0 + (syntax-rules () + [(_ expr0 expr ...) + (call-with-values (lambda () + (call-with-values (lambda () expr0) + (case-lambda + [(x) (values x #f)] + [args (values args #t)]))) + (lambda (l apply?) + expr ... + (if apply? + (#%apply values l) + l)))]))) + (eval '(define-syntax (|#%app| stx) + (syntax-case stx () + [(_ rator rand ...) + (with-syntax ([n-args (length #'(rand ...))]) + #'((extract-procedure rator n-args) rand ...))]))) + (eval `(define raise-binding-result-arity-error ',raise-binding-result-arity-error))) + + ;; For interpretation of the outer shell of a linklet: + (install-linklet-primitive-tables! kernel-table + unsafe-table + flfxnum-table + paramz-table + extfl-table + network-table + futures-table + place-table + foreign-table + linklet-table + internal-table + schemify-table) + + ;; ---------------------------------------- + + ;; `install-reader!` is from the `io` library, where the + ;; given functions are used by the default port read handler + (install-reader! 1/read 1/read-syntax 1/read-accept-reader 1/read-accept-lang) + + ;; `set-string->number?!` is also from the `io` library, where + ;; the printer needs to check whether a string parses as a number + ;; for deciding wheter to quote the string + (set-string->number?! (lambda (str) + (not (not (1/string->number str 10 'read))))) + + ;; `set-maybe-raise-missing-module!` is also from the `io` library + (set-maybe-raise-missing-module! maybe-raise-missing-module)) diff --git a/racket/src/cs/include.ss b/racket/src/cs/include.ss new file mode 100644 index 0000000000..270d2e1002 --- /dev/null +++ b/racket/src/cs/include.ss @@ -0,0 +1,8 @@ + +(define-syntax (include-generated stx) + (syntax-case stx () + [(inc file) + (let* ([dir (or (getenv "COMPILED_SCM_DIR") + "compiled/")] + [file (#%datum->syntax #'inc (string-append dir (#%syntax->datum #'file)))]) + (#%datum->syntax #'inc `(include ,file)))])) diff --git a/racket/src/cs/io.sls b/racket/src/cs/io.sls new file mode 100644 index 0000000000..7ce2b7ef33 --- /dev/null +++ b/racket/src/cs/io.sls @@ -0,0 +1,395 @@ +(library (io) + (export) + (import (except (chezpart) + close-port) + (rename (only (chezscheme) + read-char peek-char + current-directory + error + input-port? output-port? + file-position flush-output-port + file-symbolic-link?) + [input-port? chez:input-port?] + [output-port? chez:output-port?] + [flush-output-port flush-output]) + (rumble) + (thread)) + ;; ---------------------------------------- + ;; Tie knots: + + (define (path? v) (is-path? v)) + (define (path->string v) (1/path->string v)) + (define path->complete-path + (case-lambda + [(v) (1/path->complete-path v)] + [(v wrt) (1/path->complete-path v wrt)])) + (define (absolute-path? v) (1/absolute-path? v)) + (define (relative-path? v) (1/relative-path? v)) + + ;; ---------------------------------------- + + (module (|#%rktio-instance| ptr->address) + (meta define (convert-type t) + (syntax-case t (ref *ref rktio_bool_t rktio_const_string_t) + [(ref . _) #'uptr] + [(*ref rktio_const_string_t) #'uptr] + [(*ref . _) #'u8*] + [rktio_bool_t #'boolean] + [rktio_const_string_t #'u8*] + [else t])) + + (define-ftype intptr_t iptr) + (define-ftype uintptr_t uptr) + (define-ftype rktio_int64_t integer-64) + (define _uintptr _uint64) + (define NULL 0) + + (define (<< a b) (bitwise-arithmetic-shift-left a b)) + + (define-syntax define-constant + (syntax-rules () + [(_ id expr) (define id expr)])) + + (define-syntax (define-type stx) + (syntax-case stx (rktio_const_string_t rktio_ok_t rktio_bool_t) + [(_ rktio_const_string_t old_type) + ;; skip + #'(begin)] + [(_ rktio_ok_t old_type) + (with-syntax ([(_ type _) stx]) + #'(define-ftype type boolean))] + [(_ rktio_bool_t old_type) + (with-syntax ([(_ type _) stx]) + #'(define-ftype type boolean))] + [(_ type old-type) + (with-syntax ([old-type (convert-type #'old-type)]) + #'(define-ftype type old-type))])) + + (define-syntax (define-struct-type stx) + (syntax-case stx () + [(_ type ([old-type field] ...)) + (with-syntax ([(old-type ...) (map convert-type #'(old-type ...))]) + #'(define-ftype type (struct [field old-type] ...)))])) + + ;; Wrap foreign-pointer addressed in a record so that + ;; the value can be finalized + (define-record ptr (address)) + (define (ptr->address v) (if (eqv? v NULL) v (ptr-address v))) + (define (address->ptr v) (if (eqv? v NULL) v (make-ptr v))) + + (define-syntax (let-unwrappers stx) + ;; Unpack plain pointers; when an argument has type + ;; `rktio_const_string_t`, add an explicit NUL terminator byte; + ;; when an argument has a `nullable` wrapper, then add a #f -> 0 + ;; conversion + (syntax-case stx (rktio_const_string_t ref nullable) + [(_ () body) #'body] + [(_ ([rktio_const_string_t arg-name] . args) body) + #'(let ([arg-name (add-nul-terminator arg-name)]) + (let-unwrappers args body))] + [(_ ([(ref (nullable type)) arg-name] . args) body) + #'(let ([arg-name (ptr->address (or arg-name NULL))]) + (let-unwrappers args body))] + [(_ ([(ref type) arg-name] . args) body) + #'(let ([arg-name (ptr->address arg-name)]) + (let-unwrappers args body))] + [(_ ([(*ref rktio_const_string_t) arg-name] . args) body) + #'(let ([arg-name (ptr->address arg-name)]) + (let-unwrappers args body))] + [(_ (_ . args) body) + #'(let-unwrappers args body)])) + + (define (add-nul-terminator bstr) + (and bstr (bytes-append bstr '#vu8(0)))) + + (define-syntax (wrap-result stx) + (syntax-case stx (ref) + [(_ (ref _) v) #'(address->ptr v)] + [(_ _ v) #'v])) + + (meta define (convert-function stx) + (syntax-case stx () + [(_ (flag ...) orig-ret-type name ([orig-arg-type arg-name] ...)) + (with-syntax ([ret-type (convert-type #'orig-ret-type)] + [(arg-type ...) (map convert-type #'(orig-arg-type ...))] + [(conv ...) (if (#%memq 'blocking (map syntax->datum #'(flag ...))) + #'(__thread) + #'())]) + #'(let ([proc (foreign-procedure conv ... (rktio-lookup 'name) + (arg-type ...) + ret-type)]) + (lambda (arg-name ...) + (let-unwrappers + ([orig-arg-type arg-name] ...) + (wrap-result orig-ret-type (proc arg-name ...))))))])) + + (define-syntax (define-function stx) + (syntax-case stx () + [(_ _ _ name . _) + (with-syntax ([rhs (convert-function stx)]) + #'(define name rhs))])) + + (define-syntax (define-function*/errno stx) + (syntax-case stx () + [(_ err-val err-expr flags ret-type name ([rktio-type rktio] [arg-type arg] ...)) + (with-syntax ([rhs (convert-function + #'(define-function flags ret-type name ([rktio-type rktio] [arg-type arg] ...)))]) + #'(define name + (let ([proc rhs]) + (lambda (rktio arg ...) + (let ([v (proc rktio arg ...)]) + (if (eqv? v err-val) + err-expr + v))))))])) + + (define-syntax define-function/errno + (syntax-rules () + [(_ err-val flags ret-type name ([rktio-type rktio] [arg-type arg] ...)) + (define-function*/errno err-val + (vector (rktio_get_last_error_kind rktio) + (rktio_get_last_error rktio)) + flags ret-type name ([rktio-type rktio] [arg-type arg] ...))])) + + (define-syntax define-function/errno+step + (syntax-rules () + [(_ err-val flags ret-type name ([rktio-type rktio] [arg-type arg] ...)) + (define-function*/errno err-val + (vector (rktio_get_last_error_kind rktio) + (rktio_get_last_error rktio) + (rktio_get_last_error_step rktio)) + flags ret-type name ([rktio-type rktio] [arg-type arg] ...))])) + + (define loaded-librktio + (or (foreign-entry? "rktio_init") + (load-shared-object (string-append (string-append (current-directory) "/../../lib/librktio") + (utf8->string (system-type 'so-suffix)))))) + + (define (rktio-lookup name) + (foreign-entry (symbol->string name))) + + (include "../rktio/rktio.rktl") + + (define (rktio_filesize_ref fs) + (ftype-ref rktio_filesize_t () (make-ftype-pointer rktio_filesize_t (ptr->address fs)))) + (define (rktio_timestamp_ref fs) + (ftype-ref rktio_timestamp_t () (make-ftype-pointer rktio_timestamp_t (ptr->address fs)))) + (define (rktio_is_timestamp v) + (let ([radix (arithmetic-shift 1 (sub1 (* 8 (ftype-sizeof rktio_timestamp_t))))]) + (<= (- radix) v (sub1 radix)))) + + (define (rktio_recv_length_ref fs) + (ftype-ref rktio_length_and_addrinfo_t (len) (make-ftype-pointer rktio_length_and_addrinfo_t (ptr->address fs)) 0)) + + (define (rktio_recv_address_ref fs) + (ftype-ref rktio_length_and_addrinfo_t (address) (make-ftype-pointer rktio_length_and_addrinfo_t (ptr->address fs)) 0)) + + (define (rktio_identity_to_vector p) + (let ([p (make-ftype-pointer rktio_identity_t (ptr->address p))]) + (vector + (ftype-ref rktio_identity_t (a) p) + (ftype-ref rktio_identity_t (b) p) + (ftype-ref rktio_identity_t (c) p) + (ftype-ref rktio_identity_t (a_bits) p) + (ftype-ref rktio_identity_t (b_bits) p) + (ftype-ref rktio_identity_t (c_bits) p)))) + + (define (rktio_convert_result_to_vector p) + (let ([p (make-ftype-pointer rktio_convert_result_t (ptr->address p))]) + (vector + (ftype-ref rktio_convert_result_t (in_consumed) p) + (ftype-ref rktio_convert_result_t (out_produced) p) + (ftype-ref rktio_convert_result_t (converted) p)))) + (define (cast v from to) + (let ([p (malloc from)]) + (ptr-set! p from v) + (ptr-ref p to))) + + (define (rktio_to_bytes fs) + (cast (ptr->address fs) _uintptr _bytes)) + + (define (rktio_to_shorts fs) + (cast (ptr->address fs) _uintptr _short_bytes)) + + ;; Unlike `rktio_to_bytes`, frees the array and strings + (define rktio_to_bytes_list + (case-lambda + [(lls) (rktio_to_bytes_list lls #f)] + [(lls len) + (begin0 + (let loop ([i 0]) + (cond + [(and len (fx= i len)) + '()] + [else + (let ([bs (foreign-ref 'uptr (ptr->address lls) (* i (foreign-sizeof 'uptr)))]) + (if (not (eqv? NULL bs)) + (cons (begin0 + (cast bs _uintptr _bytes) + (rktio_free (make-ptr bs))) + (loop (add1 i))) + '()))])) + (rktio_free lls))])) + + ;; Allocates pointers that must be released via `rktio_free_bytes_list`: + (define (rktio_from_bytes_list bstrs) + (let ([p (foreign-alloc (fx* (length bstrs) (foreign-sizeof 'uptr)))]) + (let loop ([bstrs bstrs] [i 0]) + (cond + [(null? bstrs) p] + [else + (let* ([bstr (car bstrs)] + [len (bytes-length bstr)] + [s (foreign-alloc (fx+ len 1))]) + (let loop ([j 0]) + (cond + [(= j len) + (foreign-set! 'unsigned-8 s j 0)] + [else + (foreign-set! 'unsigned-8 s j (bytes-ref bstr j)) + (loop (fx+ 1 j))])) + (foreign-set! 'uptr p (fx* i (foreign-sizeof 'uptr)) s) + (loop (cdr bstrs) (fx+ 1 i)))])) + (address->ptr p))) + + (define (rktio_free_bytes_list lls len) + (rktio_to_bytes_list lls len) + (void)) + + (define (null-to-false v) (if (eqv? v NULL) #f v)) + + (define (rktio_process_result_stdin_fd r) + (null-to-false (address->ptr (ftype-ref rktio_process_result_t (stdin_fd) (make-ftype-pointer rktio_process_result_t (ptr->address r)))))) + (define (rktio_process_result_stdout_fd r) + (null-to-false (address->ptr (ftype-ref rktio_process_result_t (stdout_fd) (make-ftype-pointer rktio_process_result_t (ptr->address r)))))) + (define (rktio_process_result_stderr_fd r) + (null-to-false (address->ptr (ftype-ref rktio_process_result_t (stderr_fd) (make-ftype-pointer rktio_process_result_t (ptr->address r)))))) + (define (rktio_process_result_process r) + (address->ptr (ftype-ref rktio_process_result_t (process) (make-ftype-pointer rktio_process_result_t (ptr->address r))))) + + (define (rktio_status_running r) + (ftype-ref rktio_status_t (running) (make-ftype-pointer rktio_status_t (ptr->address r)))) + (define (rktio_status_result r) + (ftype-ref rktio_status_t (result) (make-ftype-pointer rktio_status_t (ptr->address r)))) + + (define (rktio_do_install_os_signal_handler rktio) + (rktio_install_os_signal_handler rktio)) + + (define (rktio_get_ctl_c_handler) + (get-ctl-c-handler)) + + (define |#%rktio-instance| + (let () + (define-syntax extract-functions + (syntax-rules (define-constant + define-type + define-struct-type + define-function + define-function/errno + define-function/errno+step) + [(_ accum) (hasheq . accum)] + [(_ accum (define-constant . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-struct-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-function _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno+step _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)])) + (define-syntax begin + (syntax-rules () + [(begin form ...) + (extract-functions ['rktio_NULL + NULL + 'rktio_filesize_ref rktio_filesize_ref + 'rktio_timestamp_ref rktio_timestamp_ref + 'rktio_is_timestamp rktio_is_timestamp + 'rktio_recv_length_ref rktio_recv_length_ref + 'rktio_recv_address_ref rktio_recv_address_ref + 'rktio_identity_to_vector rktio_identity_to_vector + 'rktio_convert_result_to_vector rktio_convert_result_to_vector + 'rktio_to_bytes rktio_to_bytes + 'rktio_to_bytes_list rktio_to_bytes_list + 'rktio_to_shorts rktio_to_shorts + 'rktio_from_bytes_list rktio_from_bytes_list + 'rktio_free_bytes_list rktio_free_bytes_list + 'rktio_from_bytes_list rktio_from_bytes_list + 'rktio_free_bytes_list rktio_free_bytes_list + 'rktio_process_result_stdin_fd rktio_process_result_stdin_fd + 'rktio_process_result_stdout_fd rktio_process_result_stdout_fd + 'rktio_process_result_stderr_fd rktio_process_result_stderr_fd + 'rktio_process_result_process rktio_process_result_process + 'rktio_status_running rktio_status_running + 'rktio_status_result rktio_status_result + 'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler + 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] + form ...)])) + (include "../rktio/rktio.rktl")))) + + ;; ---------------------------------------- + + (define format + (case-lambda + [(fmt arg) + (unless (equal? fmt "~s") + (raise-arguments-error 'format "should only be used as a fallback" + "format string" fmt + "argument" arg)) + (cond + [(and (record? arg) + (or (not (impersonator? arg)) + (record? (unsafe-struct*-ref arg 0)))) + (let ([arg (if (impersonator? arg) + (unsafe-struct*-ref arg 0) + arg)]) + (chez:format "#<~a>" (record-type-name (record-rtd arg))))] + [else + (chez:format "~s" arg)])] + [(fmt . args) + (raise-arguments-error 'format "should only be used as a fallback" + "format string" fmt + "arguments" args)])) + + ;; ---------------------------------------- + + (export system-library-subpath) + (define system-library-subpath + (case-lambda + [() (system-library-subpath (system-type 'gc))] + [(mode) + (1/string->path + (string-append + system-library-subpath-string + (cond + [(eq? mode '3m) (if (eq? 'windows (system-path-convention-type)) + "\\3m" + "/3m")] + [(eq? mode 'cs) (if (eq? 'windows (system-path-convention-type)) + "\\cs" + "/cs")] + [(or (eq? mode 'cgc) (not mode)) ""] + [else (raise-argument-error 'system-library-subpath + "(or/c '3m 'cgc 'cs #f)" + mode)])))])) + + (define (primitive-table key) + (case key + [(|#%thread|) |#%thread-instance|] + [(|#%rktio|) |#%rktio-instance|] + [else #f])) + + (include "include.ss") + (include-generated "io.scm") + + ;; Initialize: + (|#%app| 1/current-directory (current-directory)) + (|#%app| 1/current-directory-for-user (current-directory)) + (set-log-system-message! (lambda (level str) + (1/log-message (|#%app| 1/current-logger) level str #f))) + (set-error-display-eprintf! (lambda (fmt . args) + (apply 1/fprintf (|#%app| 1/current-error-port) fmt args))) + (set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ptr->address) + (set-async-callback-poll-wakeup! 1/unsafe-signal-received)) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls new file mode 100644 index 0000000000..53f514634b --- /dev/null +++ b/racket/src/cs/linklet.sls @@ -0,0 +1,1246 @@ +(library (linklet) + (export linklet? + compile-linklet + recompile-linklet + eval-linklet + read-compiled-linklet + instantiate-linklet + + read-on-demand-source + + linklet-import-variables + linklet-export-variables + + instance? + make-instance + instance-name + instance-data + instance-variable-names + instance-variable-value + instance-set-variable-value! + instance-unset-variable! + + linklet-directory? + hash->linklet-directory + linklet-directory->hash + + linklet-bundle? + hash->linklet-bundle + linklet-bundle->hash + + variable-reference? + variable-reference->instance + variable-reference-constant? + variable-reference-from-unsafe? + + compile-enforce-module-constants + compile-context-preservation-enabled + compile-allow-set!-undefined + eval-jit-enabled + load-on-demand-enabled + + primitive->compiled-position + compiled-position->primitive + primitive-in-category? + + platform-independent-zo-mode? ; not exported to racket + linklet-performance-init! ; not exported to racket + linklet-performance-report! ; not exported to racket + + install-linklet-primitive-tables! ; not exported to racket + + ;; schemify glue: + variable-set! + variable-set!/check-undefined + variable-ref + variable-ref/no-check + make-instance-variable-reference + jitified-extract-closed + jitified-extract + schemify-table) + (import (chezpart) + (only (chezscheme) printf) + (rumble) + (only (io) + path? + complete-path? + path->string + string->bytes/utf-8 + bytes->string/utf-8 + prop:custom-write + write-bytes + read-byte + read-bytes + open-output-bytes + get-output-bytes + file-position + current-logger + log-message) + (regexp) + (schemify)) + + (define linklet-compilation-mode + (cond + [(getenv "PLT_CS_JIT") 'jit] + [(getenv "PLT_CS_MACH") 'mach] + [else 'mach])) + + (define linklet-compilation-limit + (and (eq? linklet-compilation-mode 'mach) + (or (let ([s (getenv "PLT_CS_COMPILE_LIMIT")]) + (and s + (let ([n (string->number s)]) + (and (real? n) + n)))) + 10000))) + + ;; For "main.sps" to select the default ".zo" directory name: + (define platform-independent-zo-mode? (eq? linklet-compilation-mode 'jit)) + + (define (primitive->compiled-position prim) #f) + (define (compiled-position->primitive pos) #f) + (define (primitive-in-category? sym cat) #f) + + (define root-logger (|#%app| current-logger)) + + (define omit-debugging? (not (getenv "PLT_CS_DEBUG"))) + (define measure-performance? (getenv "PLT_LINKLET_TIMES")) + + (define gensym-on? (getenv "PLT_LINKLET_SHOW_GENSYM")) + (define pre-lift-on? (getenv "PLT_LINKLET_SHOW_PRE_LIFT")) + (define pre-jit-on? (getenv "PLT_LINKLET_SHOW_PRE_JIT")) + (define lambda-on? (getenv "PLT_LINKLET_SHOW_LAMBDA")) + (define post-lambda-on? (getenv "PLT_LINKLET_SHOW_POST_LAMBDA")) + (define post-interp-on? (getenv "PLT_LINKLET_SHOW_POST_INTERP")) + (define jit-demand-on? (getenv "PLT_LINKLET_SHOW_JIT_DEMAND")) + (define known-on? (getenv "PLT_LINKLET_SHOW_KNOWN")) + (define show-on? (or gensym-on? + pre-jit-on? + pre-lift-on? + post-lambda-on? + post-interp-on? + jit-demand-on? + known-on? + (getenv "PLT_LINKLET_SHOW"))) + (define show + (case-lambda + [(what v) (show show-on? what v)] + [(on? what v) + (when on? + (printf ";; ~a ---------------------\n" what) + (call-with-system-wind + (lambda () + (parameterize ([print-gensym gensym-on?] + [print-extended-identifiers #t]) + (pretty-print (strip-jit-wrapper + (strip-nested-annotations + (correlated->annotation v)))))))) + v])) + + (define region-times (make-eq-hashtable)) + (define region-counts (make-eq-hashtable)) + (define region-memories (make-eq-hashtable)) + (define current-start-time 0) + (define-syntax performance-region + (syntax-rules () + [(_ label e ...) (measure-performance-region label (lambda () e ...))])) + (define (measure-performance-region label thunk) + (cond + [measure-performance? + (let ([old-start current-start-time]) + (set! current-start-time (current-inexact-milliseconds)) + (begin0 + (thunk) + (let ([delta (- (current-inexact-milliseconds) current-start-time)]) + (hashtable-update! region-times label (lambda (v) (+ v delta)) 0) + (hashtable-update! region-counts label add1 0) + (set! current-start-time (+ old-start delta)))))] + [else (thunk)])) + (define (add-performance-memory! label delta) + (when measure-performance? + (hashtable-update! region-memories label (lambda (v) (+ v delta)) 0))) + (define (linklet-performance-init!) + (hashtable-set! region-times 'boot + (let ([t (sstats-cpu (statistics))]) + (+ (* 1000.0 (time-second t)) + (/ (time-nanosecond t) 1000000.0))))) + (define (linklet-performance-report!) + (when measure-performance? + (let ([total 0]) + (define (report label n units extra) + (define (pad v w) + (let ([s (chez:format "~a" v)]) + (string-append (make-string (max 0 (- w (string-length s))) #\space) + s))) + (chez:printf ";; ~a: ~a ~a~a\n" + (pad label 15) + (pad (round (inexact->exact n)) 5) + units + extra)) + (define (ht->sorted-list ht) + (list-sort (lambda (a b) (< (cdr a) (cdr b))) + (hash-table-map ht cons))) + (for-each (lambda (p) + (let ([label (car p)] + [n (cdr p)]) + (set! total (+ total n)) + (report label n 'ms (let ([c (hashtable-ref region-counts label 0)]) + (if (zero? c) + "" + (chez:format " ; ~a times" c)))))) + (ht->sorted-list region-times)) + (report 'total total 'ms "") + (chez:printf ";;\n") + (for-each (lambda (p) (report (car p) (/ (cdr p) 1024 1024) 'MB "")) + (ht->sorted-list region-memories))))) + + ;; `compile`, `interpret`, etc. have `dynamic-wind`-based state + ;; that need to be managed correctly when swapping Racket + ;; engines/threads. + (define (compile* e) + (call-with-system-wind (lambda () (compile e)))) + (define (interpret* e) + (call-with-system-wind (lambda () (interpret e)))) + (define (fasl-write* s o) + (call-with-system-wind (lambda () (fasl-write s o)))) + (define (compile-to-port* s o) + (call-with-system-wind (lambda () (compile-to-port s o)))) + + (define primitives (make-hasheq)) + (define (install-linklet-primitive-tables! . tables) + (for-each + (lambda (table) + (hash-for-each table (lambda (k v) (hash-set! primitives k v)))) + tables)) + + (define (outer-eval s format) + (if (eq? format 'interpret) + (interpret-linklet s primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure) + (compile* s))) + + (define (compile*-to-bytevector s) + (let-values ([(o get) (open-bytevector-output-port)]) + (compile-to-port* (list `(lambda () ,s)) o) + (get))) + + (define (compile-to-bytevector s format) + (bytevector-compress + (cond + [(eq? format 'interpret) + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write* s o) + (get))] + [else (compile*-to-bytevector s)]))) + + (define (eval-from-bytevector c-bv format) + (add-performance-memory! 'uncompress (bytevector-length c-bv)) + (let* ([bv (performance-region + 'uncompress + (bytevector-uncompress c-bv))]) + (add-performance-memory! 'faslin (bytevector-length bv)) + (cond + [(eq? format 'interpret) + (let ([r (performance-region + 'faslin + (fasl-read (open-bytevector-input-port bv)))]) + (performance-region + 'outer + (outer-eval r format)))] + [else + (performance-region + 'faslin + (code-from-bytevector bv))]))) + + (define (code-from-bytevector bv) + (let ([i (open-bytevector-input-port bv)]) + (performance-region + 'outer + ((load-compiled-from-port i))))) + + (define-record-type wrapped-code + (fields (mutable content) ; bytevector for 'lambda mode; annotation for 'jit mode + arity-mask + name) + (nongenerative #{wrapped-code p6o2m72rgmi36pm8vy559b-0})) + + (define (force-wrapped-code wc) + (let ([f (wrapped-code-content wc)]) + (if (procedure? f) + f + (performance-region + 'on-demand + (cond + [(bytevector? f) + (let* ([f (code-from-bytevector f)]) + (wrapped-code-content-set! wc f) + f)] + [else + (let* ([f (compile* (wrapped-code-content wc))]) + (when jit-demand-on? + (show "JIT demand" (strip-nested-annotations (wrapped-code-content wc)))) + (wrapped-code-content-set! wc f) + f)]))))) + + (define (jitified-extract-closed wc) + (let ([f (wrapped-code-content wc)]) + (if (#2%procedure? f) + ;; previously forced, so no need for a wrapper + f + ;; make a wrapper that has the right arity and name + ;; and that compiles/extracts when called: + (make-jit-procedure (lambda () (force-wrapped-code wc)) + (wrapped-code-arity-mask wc) + (wrapped-code-name wc))))) + + (define (jitified-extract wc) + (let ([f (wrapped-code-content wc)]) + (if (#2%procedure? f) + ;; previously forced, so no need for a wrapper + f + ;; make a wrapper that has the right arity and name + ;; and that compiles/extracts when called: + (lambda free-vars + (make-jit-procedure (lambda () + (apply (force-wrapped-code wc) + free-vars)) + (wrapped-code-arity-mask wc) + (wrapped-code-name wc)))))) + + (define (strip-jit-wrapper p) + (cond + [(wrapped-code? p) + (vector (strip-jit-wrapper (strip-nested-annotations (wrapped-code-content p))) + (wrapped-code-arity-mask p) + (wrapped-code-name p))] + [(pair? p) + (cons (strip-jit-wrapper (car p)) (strip-jit-wrapper (cdr p)))] + [else p])) + + ;; A linklet is implemented as a procedure that takes an argument + ;; for each import plus an `variable` for each export, and calling + ;; the procedure runs the linklet body. + + ;; A source linklet has a list of list of imports; those are all + ;; flattened into a sequence of arguments for the linklet procedure, + ;; followed by the arguments to receive the export `variable`s. Each + ;; import is either a `variable` or the variable's value as + ;; indicated by the "ABI" (which is based on information about which + ;; exports of an imported linklet are constants). + + ;; A linklet also has a table of information about its + + (define-record-type linklet + (fields (mutable code) ; the procedure + format ; 'compile or 'interpret (where the latter may have compiled internal parts) + (mutable preparation) ; 'faslable, 'faslable-strict, 'callable, or 'lazy + importss-abi ; ABI for each import, in parallel to `importss` + exports-info ; hash(sym -> known) for info about each export; see "known.rkt" + name ; name of the linklet (for debugging purposes) + importss ; list of list of import symbols + exports) ; list of export symbols + (nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-0})) + + (define (set-linklet-code linklet code preparation) + (make-linklet code + (linklet-format linklet) + preparation + (linklet-importss-abi linklet) + (linklet-exports-info linklet) + (linklet-name linklet) + (linklet-importss linklet) + (linklet-exports linklet))) + + (define compile-linklet + (case-lambda + [(c) (compile-linklet c #f #f (lambda (key) (values #f #f)) #t)] + [(c name) (compile-linklet c name #f (lambda (key) (values #f #f)) #t)] + [(c name import-keys) (compile-linklet c name import-keys (lambda (key) (values #f #f)) #t)] + [(c name import-keys get-import) (compile-linklet c name import-keys get-import #t)] + [(c name import-keys get-import serializable?) + (performance-region + 'schemify + (define jitify-mode? + (or (eq? linklet-compilation-mode 'jit) + (and (linklet-bigger-than? c linklet-compilation-limit serializable?) + (log-message root-logger 'info 'linklet "compiling only interior functions for large linklet" #f) + #t))) + (define format (if jitify-mode? 'interpret 'compile)) + ;; Convert the linklet S-expression to a `lambda` S-expression: + (define-values (impl-lam importss exports new-import-keys importss-abi exports-info) + (schemify-linklet (show "linklet" c) + serializable? + jitify-mode? + (|#%app| compile-allow-set!-undefined) + #f ;; safe mode + recorrelate + prim-knowns + ;; Callback to get a specific linklet for a + ;; given import: + (lambda (key) + (lookup-linklet-or-instance get-import key)) + import-keys)) + (define impl-lam/lifts + (lift-in-schemified-linklet (show pre-lift-on? "pre-lift" impl-lam) + recorrelate)) + (define impl-lam/jitified + (cond + [(not jitify-mode?) impl-lam/lifts] + [else + (jitify-schemified-linklet (case linklet-compilation-mode + [(jit) (show pre-jit-on? "pre-jitified" impl-lam/lifts)] + [else (show "schemified" impl-lam/lifts)]) + ;; don't need extract for non-serializable 'lambda mode + (or serializable? (eq? linklet-compilation-mode 'jit)) + ;; compilation threshold for ahead-of-time mode: + (and (eq? linklet-compilation-mode 'mach) + linklet-compilation-limit) + ;; correlation -> lambda + (case linklet-compilation-mode + [(jit) + ;; Preserve annotated `lambda` source for on-demand compilation: + (lambda (expr arity-mask name) + (make-wrapped-code (correlated->annotation expr) arity-mask name))] + [else + ;; Compile an individual `lambda`: + (lambda (expr arity-mask name) + (performance-region + 'compile + (let ([code ((if serializable? compile*-to-bytevector compile*) + (show lambda-on? "lambda" (correlated->annotation expr)))]) + (if serializable? + (make-wrapped-code code arity-mask name) + code))))]) + recorrelate)])) + (define impl-lam/interpable + (let ([impl-lam (case (and jitify-mode? + linklet-compilation-mode) + [(mach) (show post-lambda-on? "post-lambda" impl-lam/jitified)] + [else (show "schemified" impl-lam/jitified)])]) + (if jitify-mode? + (interpretable-jitified-linklet impl-lam correlated->datum) + (correlated->annotation impl-lam)))) + (when known-on? + (show "known" (hash-map exports-info (lambda (k v) (list k v))))) + (performance-region + 'compile + ;; Create the linklet: + (let ([lk (make-linklet (call-with-system-wind + (lambda () + ((if serializable? compile-to-bytevector outer-eval) + (show (and jitify-mode? post-interp-on?) "post-interp" impl-lam/interpable) + format))) + format + (if serializable? 'faslable 'callable) + importss-abi + exports-info + name + importss + exports)]) + (show "compiled" 'done) + ;; In general, `compile-linklet` is allowed to extend the set + ;; of linklet imports if `import-keys` is provided (e.g., for + ;; cross-linklet optimization where inlining needs a new + ;; direct import) + (if import-keys + (values lk new-import-keys) + lk))))])) + + (define (lookup-linklet-or-instance get-import key) + ;; Use the provided callback to get an linklet for the + ;; import at `index` + (cond + [key + (let-values ([(lnk/inst more-import-keys) (get-import key)]) + (cond + [(linklet? lnk/inst) + (values (linklet-exports-info lnk/inst) + ;; No conversion needed: + #f + more-import-keys)] + [(instance? lnk/inst) + (values (instance-hash lnk/inst) + variable->known + more-import-keys)] + [else (values #f #f #f)]))] + [else (values #f #f #f)])) + + (define (recompile-linklet lnk . args) lnk) + + ;; Intended to speed up reuse of a linklet in exchange for not being + ;; able to serialize anymore + (define (eval-linklet linklet) + (case (linklet-preparation linklet) + [(faslable) + (set-linklet-code linklet (linklet-code linklet) 'lazy)] + [(faslable-strict) + (set-linklet-code linklet (eval-from-bytevector (linklet-code linklet) (linklet-format linklet)) 'callable)] + [else + linklet])) + + (define instantiate-linklet + (case-lambda + [(linklet import-instances) + (instantiate-linklet linklet import-instances #f #f)] + [(linklet import-instances target-instance) + (instantiate-linklet linklet import-instances target-instance #f)] + [(linklet import-instances target-instance use-prompt?) + (cond + [target-instance + ;; Instantiate into the given instance and return the + ;; result of the linklet body: + (call/cc + (lambda (k) + (register-linklet-instantiate-continuation! k (instance-name target-instance)) + (when (eq? 'lazy (linklet-preparation linklet)) + ;; Trigger lazy conversion of code from bytevector + (let ([code (eval-from-bytevector (linklet-code linklet) (linklet-format linklet))]) + (with-interrupts-disabled + (when (eq? 'lazy (linklet-preparation linklet)) + (linklet-code-set! linklet code) + (linklet-preparation-set! linklet 'callable))))) + ;; Call the linklet: + (performance-region + 'instantiate + (apply + (if (eq? 'callable (linklet-preparation linklet)) + (linklet-code linklet) + (eval-from-bytevector (linklet-code linklet) (linklet-format linklet))) + (make-variable-reference target-instance #f) + (append (apply append + (map extract-variables + import-instances + (linklet-importss linklet) + (linklet-importss-abi linklet))) + (create-variables target-instance + (linklet-exports linklet)))))))] + [else + ;; Make a fresh instance, recur, and return the instance + (let ([i (make-instance (linklet-name linklet))]) + (instantiate-linklet linklet import-instances i use-prompt?) + i)])])) + + (define (linklet-import-variables linklet) + (linklet-importss linklet)) + + (define (linklet-export-variables linklet) + (linklet-exports linklet)) + + ;; ---------------------------------------- + + ;; A potentially mutable import or definition is accessed through + ;; the indirection of a `variable`; accessing a variable may include + ;; a check for undefined, since going through a `variable` + ;; sacrifices the undefined check of the host Scheme + + (define-record variable (val + name + constance ; #f (mutable), 'constant, or 'consistent (always the same shape) + inst-box)) ; weak pair with instance in `car` + + (define (variable-set! var val constance) + (cond + [(variable-constance var) + (raise + (|#%app| + exn:fail:contract:variable + (string-append (symbol->string (variable-name var)) + ": cannot modify constant") + (current-continuation-marks) + (variable-name var)))] + [else + (set-variable-val! var val) + (when constance + (set-variable-constance! var constance))])) + + (define (variable-set!/check-undefined var val constance) + (when (eq? (variable-val var) unsafe-undefined) + (raise-undefined var #t)) + (variable-set! var val constance)) + + (define (variable-ref var) + (let ([v (variable-val var)]) + (if (eq? v unsafe-undefined) + (raise-undefined var #f) + v))) + + (define (variable-ref/no-check var) + (variable-val var)) + + ;; Find variables or values needed from an instance for a linklet's + ;; imports + (define (extract-variables inst syms imports-abi) + (let ([ht (instance-hash inst)]) + (map (lambda (sym import-abi) + (let ([var (or (hash-ref ht sym #f) + (raise-arguments-error 'instantiate-linklet + "variable not found in imported instance" + "instance" inst + "name" sym))]) + (if import-abi + (variable-val var) + var))) + syms + imports-abi))) + + (define (identify-module var) + (let ([i (car (variable-inst-box var))]) + (cond + [(eq? i #!bwp) + ""] + [(instance-name i) + => (lambda (name) + (#%format "\n module: ~a" name))] + [else ""]))) + + (define (raise-undefined var set?) + (raise + (|#%app| + exn:fail:contract:variable + (cond + [set? + (string-append "set!: assignment disallowed;\n" + " cannot set variable before its definition\n" + " variable: " (symbol->string (variable-name var)) + (identify-module var))] + [else + (string-append (symbol->string (variable-name var)) + ": undefined;\n cannot reference undefined identifier" + (identify-module var))]) + (current-continuation-marks) + (variable-name var)))) + + ;; Create the variables needed for a linklet's exports + (define (create-variables inst syms) + (let ([ht (instance-hash inst)] + [inst-box (weak-cons inst #f)]) + (map (lambda (sym) + (or (hash-ref ht sym #f) + (let ([var (make-variable unsafe-undefined sym #f inst-box)]) + (hash-set! ht sym var) + var))) + syms))) + + (define (variable->known var) + (let ([constance (variable-constance var)]) + (cond + [(not constance) #f] + [(and (eq? constance 'consistent) + (#%procedure? (variable-val var))) + (known-procedure (#%procedure-arity-mask (variable-val var)))] + [else a-known-constant]))) + + ;; ---------------------------------------- + + ;; An instance represents the instantiation of a linklet + (define-record-type (instance new-instance instance?) + (fields name + data + hash)) ; symbol -> variable + + (define make-instance + (case-lambda + [(name) (make-instance name #f)] + [(name data) (make-instance name data #f)] + [(name data constance . content) + (let* ([ht (make-hasheq)] + [inst (new-instance name data ht)] + [inst-box (weak-cons inst #f)]) + (check-constance 'make-instance constance) + (let loop ([content content]) + (cond + [(null? content) (void)] + [else + (hash-set! ht (car content) (make-variable (cadr content) (car content) constance inst-box)) + (loop (cddr content))])) + inst)])) + + (define (instance-variable-names i) + (hash-map (instance-hash i) (lambda (k v) k))) + + (define instance-variable-value + (case-lambda + [(i sym fail-k) + (let* ([var (hash-ref (instance-hash i) sym unsafe-undefined)] + [v (if (eq? var unsafe-undefined) + unsafe-undefined + (variable-val var))]) + (if (eq? v unsafe-undefined) + (fail-k) + v))] + [(i sym) + (instance-variable-value i + sym + (lambda () + (raise-argument-error + 'instance-variable-value + "instance variable not found" + "name" sym)))])) + + (define instance-set-variable-value! + (case-lambda + [(i k v) (instance-set-variable-value! i k v #f)] + [(i k v mode) + (unless (instance? i) + (raise-argument-error 'instance-set-variable-value! "instance?" i)) + (unless (symbol? k) + (raise-argument-error 'instance-set-variable-value! "symbol?" i)) + (check-constance 'instance-set-variable-value! mode) + (let ([var (or (hash-ref (instance-hash i) k #f) + (let ([var (make-variable unsafe-undefined k #f (weak-cons i #f))]) + (hash-set! (instance-hash i) k var) + var))]) + (variable-set! var v mode))])) + + (define (instance-unset-variable! i k) + (unless (instance? i) + (raise-argument-error 'instance-unset-variable! "instance?" i)) + (unless (symbol? k) + (raise-argument-error 'instance-unset-variable! "symbol?" i)) + (let ([var (hash-ref (instance-hash i) k #f)]) + (when var + (set-variable-val! var unsafe-undefined)))) + + (define (check-constance who mode) + (unless (or (not mode) (eq? mode 'constant) (eq? mode 'consistent)) + (raise-argument-error who "(or/c #f 'constant 'consistant)" mode))) + + ;; -------------------------------------------------- + + (define-record-type linklet-directory + (fields hash) + (nongenerative #{linklet-directory cvqw30w53xy6hsjsc5ipep-0})) + + (define (hash->linklet-directory ht) + (make-linklet-directory ht)) + + (define (linklet-directory->hash ld) + (linklet-directory-hash ld)) + + (define-record-type (linklet-bundle make-linklet-bundle linklet-bundle?) + (fields (immutable hash)) + (nongenerative #{linklet-bundle chqh4u4pk0me3osmzzx8pq-0})) + + (define (install-linklet-bundle-write!) + (struct-property-set! prop:custom-write (record-type-descriptor linklet-bundle) write-linklet-bundle) + (struct-property-set! prop:custom-write (record-type-descriptor linklet-directory) write-linklet-directory)) + + (define (hash->linklet-bundle ht) + (make-linklet-bundle ht)) + + (define (linklet-bundle->hash b) + (linklet-bundle-hash b)) + + (define-record variable-reference (instance ; the use-site instance + var-or-info)) ; the referenced variable + + (define variable-reference->instance + (case-lambda + [(vr ref?) + (if ref? + (variable-reference-instance vr) + (variable-reference->instance vr))] + [(vr) + (let ([v (variable-reference-var-or-info vr)]) + (cond + [(not v) ;; anonymous + #f] + [(variable? v) + (let ([i (car (variable-inst-box v))]) + (if (eq? i #!bwp) + (variable-reference->instance vr #t) + i))] + [else + ;; Local variable, so same as use-site + (variable-reference->instance vr #t)]))])) + + (define (variable-reference-constant? vr) + (eq? (variable-reference-var-or-info vr) 'constant)) + + (define (variable-reference-from-unsafe? vr) + #f) + + (define (make-instance-variable-reference vr v) + (make-variable-reference (variable-reference-instance vr) v)) + + ;; ---------------------------------------- + + (define (write-linklet-bundle b port mode) + ;; Various tools expect a particular header: + ;; "#~" + ;; length of version byte string (< 64) as one byte + ;; version byte string + ;; "B" + ;; 20 bytes of SHA-1 hash + (write-bytes '#vu8(35 126) port) + (let ([vers (string->bytes/utf-8 (version))]) + (write-bytes (bytes (bytes-length vers)) port) + (write-bytes vers port)) + (write-bytes '#vu8(66) port) + (write-bytes (make-bytes 20 0) port) + ;; The rest is whatever we want. We'll simply fasl the bundle. + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write* b o) + (let ([bstr (get)]) + (write-int (bytes-length bstr) port) + (write-bytes bstr port)))) + + (define (linklet-bundle->bytes b) + (let ([o (open-output-bytes)]) + (write-linklet-bundle b o #t) + (get-output-bytes o))) + + (define (write-linklet-directory ld port mode) + ;; Various tools expect a particular header: + ;; "#~" + ;; length of version byte string (< 64) as one byte + ;; version byte string + ;; "D" + ;; bundle count as 4-byte integer + ;; binary tree: + ;; bundle-name length as 4-byte integer + ;; bundle name [encoding decribed below] + ;; bundle offset as 4-byte integer + ;; bundle size as 4-byte integer + ;; left-branch offset as 4-byte integer + ;; right-branch offset as 4-byte integer + ;; A bundle name corresponds to a list of symbols. Each symbol in the list is + ;; prefixed with either: its length as a byte if less than 255; 255 followed by + ;; a 4-byte integer for the length. + (write-bytes '#vu8(35 126) port) + (let ([vers (string->bytes/utf-8 (version))]) + (write-bytes (bytes (bytes-length vers)) port) + (write-bytes vers port) + (write-bytes '#vu8(68) port) + ;; Flatten a directory of bundles into a vector of pairs, where + ;; each pair has the encoded bundle name and the bundle bytes + (let* ([bundles (list->vector (flatten-linklet-directory ld '() '()))] + [len (vector-length bundles)] + [initial-offset (+ 2 ; "#~" + 1 ; version length + (bytes-length vers) + 1 ; D + 4)]) ; bundle count + (write-int len port) ; bundle count + (chez:vector-sort! (lambda (a b) (bytesbytes value)) + accum) + #t)] + [else + (loop (hash-iterate-next ht i) + (flatten-linklet-directory value (cons key rev-name-prefix) accum) + saw-bundle?)]))])))) + + ;; Encode a bundle name (as a reversed list of symbols) as a single + ;; byte string + (define (encode-name rev-name) + (define (encode-symbol s) + (let* ([bstr (string->bytes/utf-8 (symbol->string s))] + [len (bytes-length bstr)]) + (if (< len 255) + (list (bytes len) bstr) + (list (bytes 255) (integer->integer-bytes len 4 #f #f) bstr)))) + (let loop ([rev-name rev-name] [accum '()]) + (cond + [(null? rev-name) (apply bytes-append accum)] + [else + (loop (cdr rev-name) (append (encode-symbol (car rev-name)) + accum))]))) + + ;; Figure out how big the binary tree will be, which depends + ;; on the size of bundle-name byte strings + (define (compute-btree-size bundles len) + (let loop ([i 0] [size 0]) + (if (= i len) + size + (let ([nlen (bytes-length (car (vector-ref bundles i)))]) + ;; 5 numbers: name length, bundle offset, bundles size, lef, and right + (loop (fx1+ i) (+ size nlen (* 5 4))))))) + + ;; Compute the offset where each node in the binary tree will reside + ;; relative to the start of the bundle directory's "#~" + (define (compute-btree-node-offsets bundles len initial-offset) + (let ([node-offsets (make-vector len)]) + (let loop ([lo 0] [hi len] [offset initial-offset]) + (cond + [(= lo hi) offset] + [else + (let* ([mid (quotient (+ lo hi) 2)]) + (vector-set! node-offsets mid offset) + (let* ([nlen (bytes-length (car (vector-ref bundles mid)))] + [offset (+ offset 4 nlen 4 4 4 4)]) + (let ([offset (loop lo mid offset)]) + (loop (add1 mid) hi offset))))])) + node-offsets)) + + ;; Compute the offset where each bundle will reside relative + ;; to the start of the bundle directory's "#~" + (define (compute-bundle-offsets bundles len offset) + (let ([bundle-offsets (make-vector len)]) + (let loop ([i 0] [offset offset]) + (unless (= i len) + (vector-set! bundle-offsets i offset) + (loop (fx1+ i) (+ offset (bytes-length (cdr (vector-ref bundles i))))))) + bundle-offsets)) + + ;; Write the binary tree for the directory: + (define (write-directory-btree bundles node-offsets bundle-offsets len port) + (let loop ([lo 0] [hi len]) + (cond + [(= lo hi) (void)] + [else + (let* ([mid (quotient (+ lo hi) 2)] + [p (vector-ref bundles mid)] + [nlen (bytes-length (car p))]) + (write-int nlen port) + (write-bytes (car p) port) + (write-int (vector-ref bundle-offsets mid) port) + (write-int (bytes-length (cdr p)) port) + (cond + [(> mid lo) + (let ([left (quotient (+ lo mid) 2)]) + (write-int (vector-ref node-offsets left) port))] + [else + (write-int 0 port)]) + (cond + [(< (fx1+ mid) hi) + (let ([right (quotient (+ (fx1+ mid) hi) 2)]) + (write-int (vector-ref node-offsets right) port))] + [else + (write-int 0 port)]) + (loop lo mid) + (loop (fx1+ mid) hi))]))) + + (define (write-int n port) + (write-bytes (integer->integer-bytes n 4 #f #f) port)) + + ;; -------------------------------------------------- + + (define (read-compiled-linklet in) + (read-compiled-linklet-or-directory in #t)) + + (define (read-compiled-linklet-or-directory in initial?) + ;; `#~` has already been read + (let* ([start-pos (- (file-position in) 2)] + [vers-len (min 63 (read-byte in))] + [vers (read-bytes vers-len in)]) + (unless (equal? vers (string->bytes/utf-8 (version))) + (raise-arguments-error 'read-compiled-linklet + "version mismatch" + "expected" (version) + "found" (bytes->string/utf-8 vers #\?))) + (let ([tag (read-byte in)]) + (cond + [(equal? tag (char->integer #\B)) + (let ([sha-1 (read-bytes 20 in)]) + (let ([len (read-int in)]) + (let ([bstr (read-bytes len in)]) + (let ([b (fasl-read (open-bytevector-input-port bstr))]) + (add-hash-code (adjust-linklet-bundle-laziness + (if initial? + (strip-submodule-references b) + b)) + sha-1)))))] + [(equal? tag (char->integer #\D)) + (unless initial? + (raise-argument-error 'read-compiled-linklet + "expected a linklet bundle")) + (read-bundle-directory in start-pos)] + [else + (raise-arguments-error 'read-compiled-linklet + "expected a `B` or `D`")])))) + + (define (read-int in) + (integer-bytes->integer (read-bytes 4 in) #f #f)) + + (define (read-bundle-directory in pos) + (let ([count (read-int in)]) + (let ([position-to-name + (let loop ([count count] [accum (hasheqv)]) + (cond + [(zero? count) accum] + [else + (let ([bstr (read-bytes (read-int in) in)]) + (let* ([offset (read-int in)] + [len (read-int in)]) + (read-int in) ; left + (read-int in) ; right + (loop (fx1- count) + (hash-set accum offset bstr))))]))]) + (let loop ([count count] [accum '()]) + (cond + [(zero? count) + (list->bundle-directory accum)] + [else + (let ([name (hash-ref position-to-name (- (file-position in) pos) #f)]) + (unless name + (raise-arguments-error 'read-compiled-linklet + "bundle not at an expected file position")) + (let ([bstr (read-bytes 2 in)]) + (let ([bundle + (cond + [(equal? '#vu8(35 126) bstr) + (read-compiled-linklet in)] + [(equal? '#vu8(35 102) bstr) + #f] + [else + (raise-arguments-error 'read-compiled-linklet + "expected a `#~` or `#f` for a bundle")])]) + (loop (fx1- count) + (cons (cons (decode-name name 0) bundle) accum)))))]))))) + + (define (decode-name bstr pos) + (let ([blen (bytes-length bstr)] + [bad-bundle (lambda () + (raise-arguments-error 'read-compiled-linklet + "malformed bundle"))]) + (cond + [(= pos blen) + '()] + [(> pos blen) (bad-bundle)] + [else + (let ([len (bytes-ref bstr pos)]) + (when (> (+ pos len 1) blen) (bad-bundle)) + (if (= len 255) + (let ([len (integer-bytes->integer bstr #f #f (fx1+ pos) (fx+ pos 5))]) + (when (> (+ pos len 1) blen) (bad-bundle)) + (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx+ pos 5) (+ pos 5 len)) #\?)) + (decode-name bstr (+ pos 5 len)))) + (cons (string->symbol (bytes->string/utf-8 (subbytes bstr (fx1+ pos) (+ pos 1 len)) #\?)) + (decode-name bstr (+ pos 1 len)))))]))) + + ;; Convert a post-order list into a tree + (define (list->bundle-directory l) + ;; The bundles list is in post-order, so we can build directories + ;; bottom-up + (let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)]) + (when (null? l) + (raise-arguments-error 'read-compiled-linklet + "invalid bundle sequence")) + (let* ([p (car l)] + [path (car p)] + [v (cdr p)] + [len (length path)]) + (when (< len prev-len) + (raise-arguments-error 'read-compiled-linklet + "invalid bundle sequence")) + (let sloop ([prev-len prev-len] [stack stack] [accum accum]) + (cond + [(> len (fx1+ prev-len)) + (sloop (fx1+ prev-len) + (cons accum stack) + (hasheq))] + [else + (let ([path (list-tail path (fxmax 0 (fx1- prev-len)))]) + (cond + [(= len prev-len) + (let ([accum (if v + (hash-set accum #f v) + accum)]) + (if (zero? len) + (make-linklet-directory accum) + (loop (cdr l) + (fx1- prev-len) + (cdr stack) + (hash-set (car stack) (car path) (make-linklet-directory accum)))))] + [else + (let ([path (if (positive? prev-len) + (cdr path) + path)]) + (loop (cdr l) + prev-len + stack + (hash-set accum + (car path) + (make-linklet-directory (if v + (hasheq #f v) + (hasheq))))))]))]))))) + + ;; When a bundle is loaded by itself, remove any 'pre and 'post + ;; submodule descriptions: + (define (strip-submodule-references b) + (make-linklet-bundle (hash-remove (hash-remove (linklet-bundle-hash b) 'pre) 'post))) + + ;; If the bundle has a non-zero hash code, record it with the + ;; 'hash-code key to enable module caching + (define (add-hash-code b sha-1) + (if (bytevector=? sha-1 '#vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + b + (make-linklet-bundle (hash-set (linklet-bundle-hash b) 'hash-code sha-1)))) + + (define read-on-demand-source + (make-parameter #f + (lambda (v) + (unless (or (eq? v #t) (eq? v #f) (and (path? v) + (complete-path? v))) + (raise-argument-error 'read-on-demand-source + "(or/c #f #t (and/c path? complete-path?))" + v)) + v))) + + (define (adjust-linklet-bundle-laziness b) + (make-linklet-bundle + (let ([ht (linklet-bundle-hash b)]) + (let loop ([i (hash-iterate-first ht)]) + (cond + [(not i) (hasheq)] + [else + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (hash-set (loop (hash-iterate-next ht i)) + key + (if (linklet? val) + (adjust-linklet-laziness val) + val)))]))))) + + (define (adjust-linklet-laziness linklet) + (set-linklet-code linklet + (linklet-code linklet) + (if (|#%app| read-on-demand-source) + 'faslable + 'faslable-strict))) + + ;; -------------------------------------------------- + + (define (recorrelate old-term new-term) + (if (correlated? old-term) + (datum->correlated #f new-term old-term) + new-term)) + + ;; -------------------------------------------------- + + (define (correlated->annotation v) + (let-values ([(e stripped-e) (correlated->annotation* v)]) + e)) + + (define (correlated->annotation* v) + (cond + [(pair? v) (let-values ([(a stripped-a) (correlated->annotation* (car v))] + [(d stripped-d) (correlated->annotation* (cdr v))]) + (if (and (eq? a (car v)) + (eq? d (cdr v))) + (values v v) + (values (cons a d) + (cons stripped-a stripped-d))))] + [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))]) + (values (transfer-srcloc v e stripped-e) + stripped-e))] + ;; correlated will be nested only in pairs with current expander + [else (values v v)])) + + (define (transfer-srcloc v e stripped-e) + (let ([src (correlated-source v)] + [pos (correlated-position v)] + [line (correlated-line v)] + [column (correlated-column v)] + [span (correlated-span v)]) + (if (and pos span (or (path? src) (string? src))) + (let ([pos (sub1 pos)]) ; Racket positions are 1-based; host Scheme positions are 0-based + (make-annotation e + (if (and line column) + ;; Racket columns are 0-based; host-Scheme columns are 1-based + (make-source-object (source->sfd src) pos (+ pos span) line (add1 column)) + (make-source-object (source->sfd src) pos (+ pos span))) + stripped-e)) + e))) + + (define sfd-cache (make-weak-hash)) + + (define (source->sfd src) + (or (hash-ref sfd-cache src #f) + (let ([str (if (path? src) + (path->string src) + src)]) + ;; We'll use a file-position object in source objects, so + ;; the sfd checksum doesn't matter + (let ([sfd (source-file-descriptor str 0)]) + (hash-set! sfd-cache src sfd) + sfd)))) + + ;; -------------------------------------------------- + + (define (strip-nested-annotations s) + (cond + [(annotation? s) (annotation-stripped s)] + [(pair? s) + (let ([a (strip-nested-annotations (car s))] + [d (strip-nested-annotations (cdr s))]) + (if (and (eq? a (car s)) (eq? d (cdr s))) + s + (cons a d)))] + [else s])) + + ;; -------------------------------------------------- + + (define compile-enforce-module-constants + (make-parameter #t (lambda (v) (and v #t)))) + + (define compile-context-preservation-enabled + (make-parameter #f (lambda (v) (and v #t)))) + + (define compile-allow-set!-undefined + (make-parameter #f (lambda (v) (and v #t)))) + + (define eval-jit-enabled + (make-parameter #t (lambda (v) (and v #t)))) + + (define load-on-demand-enabled + (make-parameter #t (lambda (v) (and v #t)))) + + ;; -------------------------------------------------- + + (define-syntax primitive-table + (syntax-rules () + [(_ id ...) + (let ([ht (make-hasheq)]) + (hash-set! ht 'id id) ... + ht)])) + + (define schemify-table + (primitive-table + variable-set! + variable-set!/check-undefined + variable-ref + variable-ref/no-check + make-instance-variable-reference + unbox/check-undefined + set-box!/check-undefined + jitified-extract + jitified-extract-closed)) + + ;; -------------------------------------------------- + + (when omit-debugging? + (generate-inspector-information (not omit-debugging?)) + (generate-procedure-source-information #t)) + + (expand-omit-library-invocations #t) + + (install-linklet-bundle-write!)) diff --git a/racket/src/cs/main.sps b/racket/src/cs/main.sps new file mode 100644 index 0000000000..77daac3621 --- /dev/null +++ b/racket/src/cs/main.sps @@ -0,0 +1,484 @@ +(top-level-program + (import (except (chezpart) + eval + read) + (rumble) + (only (expander) + boot + current-command-line-arguments + use-compiled-file-paths + current-library-collection-links + find-library-collection-links + current-library-collection-paths + find-library-collection-paths + use-collection-link-paths + find-main-config + executable-yield-handler + load-on-demand-enabled + use-user-specific-search-paths + eval + read + load + dynamic-require + namespace-require + module-declared? + module->language-info + module-path-index-join + version + exit) + (regexp) + (io) + (thread) + (only (linklet) + platform-independent-zo-mode? + linklet-performance-init! + linklet-performance-report!)) + + (linklet-performance-init!) + + (define the-command-line-arguments + (or (and (top-level-bound? 'bytes-command-line-arguments) + (map (lambda (s) (bytes->string/locale s #\?)) + (top-level-value 'bytes-command-line-arguments))) + (command-line-arguments))) + + (unless (>= (length the-command-line-arguments) 5) + (error 'racket "expected `self`, `collects`, and `libs` paths plus `segment-offset` and `is-gui?` to start")) + (set-exec-file! (path->complete-path (car the-command-line-arguments))) + (define init-collects-dir (let ([s (cadr the-command-line-arguments)]) + (if (equal? s "") 'disable (string->path s)))) + (define init-config-dir (string->path (or (getenv "PLTCONFIGDIR") + (caddr the-command-line-arguments)))) + (define segment-offset (#%string->number (list-ref the-command-line-arguments 3))) + (define gracket? (string=? "true" (list-ref the-command-line-arguments 4))) + + (when (foreign-entry? "racket_exit") + (#%exit-handler (foreign-procedure "racket_exit" (int) void))) + + (|#%app| use-compiled-file-paths + (list (string->path (string-append "compiled/" + (cond + [(getenv "PLT_ZO_PATH") + => (lambda (s) + (unless (and (not (equal? s "")) + (relative-path? s)) + (error 'racket "PLT_ZO_PATH environment variable is not a valid path")) + s)] + [platform-independent-zo-mode? "cs"] + [else (symbol->string (machine-type))]))))) + + (define (see saw . args) + (let loop ([saw saw] [args args]) + (if (null? args) + saw + (loop (hash-set saw (car args) #t) (cdr args))))) + (define (saw? saw tag) + (hash-ref saw tag #f)) + + (define rx:logging-spec (pregexp "^[\\s]*(none|fatal|error|warning|info|debug)(?:@([^\\s @]+))?(.*)$")) + (define rx:all-whitespace (pregexp "^[\\s]*$")) + (define (parse-logging-spec str where exit-on-fail?) + (define (fail) + (let ([msg (string-append + "stderr " where " must be one of the following\n" + " s:\n" + " none fatal error warning info debug\n" + "or up to one such in whitespace-separated sequence of\n" + " @\n" + "given: " str)]) + (cond + [exit-on-fail? + (raise-user-error 'racket msg)] + [else + (eprintf "~a\n" msg)]))) + (let loop ([str str] [default #f]) + (let ([m (regexp-match rx:logging-spec str)]) + (cond + [m + (let ([level (string->symbol (cadr m))] + [topic (caddr m)]) + (cond + [topic + (cons level (cons (string->symbol topic) (loop (cadddr m) default)))] + [default (fail)] + [else (loop (cadddr m) level)]))] + [(regexp-match? rx:all-whitespace str) + (if default (list default) null)] + [else (fail)])))) + + (define (configure-runtime m) + ;; New-style configuration through a `configure-runtime` submodule: + (let ([config-m (module-path-index-join '(submod "." configure-runtime) m)]) + (when (module-declared? config-m #t) + (dynamic-require config-m #f))) + ;; Old-style configuration with module language info: + (let ([info (module->language-info m #t)]) + (when (and (vector? info) (= 3 (vector-length info))) + (let* ([info-load (lambda (info) + ((dynamic-require (vector-ref info 0) (vector-ref info 1)) (vector-ref info 2)))] + [get (info-load info)] + [infos (get 'configure-runtime '())]) + (unless (and (list? infos) + (andmap (lambda (info) (and (vector? info) (= 3 (vector-length info)))) + infos)) + (raise-argument-error 'runtime-configure "(listof (vector any any any))" infos)) + (for-each info-load infos))))) + + (define need-runtime-configure? #t) + (define (namespace-require+ mod) + (let ([m (module-path-index-join mod #f)]) + (when need-runtime-configure? + (configure-runtime m) + (set! need-runtime-configure? #f)) + (namespace-require m) + ;; Run `main` submodule, if any: + (let ([main-m (module-path-index-join '(submod "." main) m)]) + (when (module-declared? main-m #t) + (dynamic-require main-m #f))))) + + (define (get-repl-init-filename) + (call-with-continuation-prompt + (lambda () + (or (let ([p (build-path (find-system-path 'addon-dir) + (if gracket? + "gui-interactive.rkt" + "interactive.rkt"))]) + (and (file-exists? p) p)) + (hash-ref (call-with-input-file + (build-path (find-main-config) "config.rktd") + read) + (if gracket? 'gui-interactive-file 'interactive-file) + #f) + (if gracket? 'racket/interactive 'racket/gui/interactive))) + (default-continuation-prompt-tag) + (lambda args #f))) + + (define init-library (if gracket? + '(lib "racket/gui/init") + '(lib "racket/init"))) + (define loads '()) + (define repl? #f) + (define repl-init? #t) + (define version? #f) + (define stderr-logging-arg #f) + (define runtime-for-init? #t) + (define exit-value 0) + (define host-collects-dir init-collects-dir) + (define host-config-dir init-config-dir) + + (define (no-init! saw) + (unless (saw? saw 'top) + (set! init-library #f))) + + (define (next-arg what flag within-flag args) + (let loop ([args (cdr args)] [accum '()]) + (cond + [(null? args) + (error 'racket "missing ~a after ~a switch" what (or within-flag flag))] + [(pair? (car args)) + (loop (cdr args) (cons (car args) accum))] + [else + (values (car args) (append (reverse accum) (cdr args)))]))) + + (define (check-path-arg what flag within-flag) + (when (equal? what "") + (error 'racket "empty ~a after ~a switch" what (or within-flag flag)))) + + (define-syntax string-case + ;; Assumes that `arg` is a variable + (syntax-rules () + [(_ arg [else body ...]) + (let () body ...)] + [(_ arg [(str ...) body ...] rest ...) + (if (or (string=? arg str) ...) + (let () body ...) + (string-case arg rest ...))])) + + (let flags-loop ([args (list-tail the-command-line-arguments 5)] + [saw (hasheq)]) + ;; An element of `args` can become `(cons _arg _within-arg)` + ;; due to splitting multiple flags with a single "-" + (define (loop args) (flags-loop args saw)) + ;; Called to handle remaining non-switch arguments: + (define (finish args saw) + (cond + [(and (pair? args) + (not (saw? saw 'non-config))) + (loop (cons "-u" args))] + [else + (|#%app| current-command-line-arguments (list->vector args)) + (when (and (null? args) (not (saw? saw 'non-config))) + (set! repl? #t) + (unless gracket? + (set! version? #t)))])) + ;; Dispatch on first argument: + (if (null? args) + (finish args saw) + (let* ([arg (car args)] + [within-arg (and (pair? arg) (cdr arg))] + [arg (if (pair? arg) (car arg) arg)]) + (string-case + arg + [("-l" "--lib") + (let-values ([(lib-name rest-args) (next-arg "library name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (namespace-require+ `(lib ,lib-name))) + loads)) + (no-init! saw) + (flags-loop rest-args (see saw 'non-config 'lib)))] + [("-t" "--require") + (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (namespace-require+ `(file ,file-name))) + loads)) + (no-init! saw) + (flags-loop rest-args (see saw 'non-config 'lib)))] + [("-u" "--script") + (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (namespace-require+ `(file ,file-name))) + loads)) + (no-init! saw) + (flags-loop rest-args (see saw 'non-config 'lib)))] + [("-f" "--load") + (let-values ([(file-name rest-args) (next-arg "file name" arg within-arg args)]) + (set! loads + (cons + (lambda () + (load file-name)) + loads)) + (flags-loop rest-args (see saw 'non-config)))] + [("-e" "--eval") + (let-values ([(expr rest-args) (next-arg "expression" arg within-arg args)]) + (set! loads + (cons + (lambda () + (eval (read (open-input-string expr)))) + loads)) + (flags-loop rest-args (see saw 'non-config)))] + [("-i" "--repl") + (set! repl? #t) + (set! version? #t) + (flags-loop (cdr args) (see saw 'non-config 'top))] + [("-n" "--no-lib") + (set! init-library #f) + (flags-loop (cdr args) (see saw 'non-config))] + [("-v" "--version") + (set! version? #t) + (flags-loop (cddr args) (see saw 'non-config))] + [("-c" "--no-compiled") + (|#%app| use-compiled-file-paths '()) + (loop (cdr args))] + [("-I") + (let-values ([(lib-name rest-args) (next-arg "library name" arg within-arg args)]) + (when init-library + (set! init-library `(lib ,lib-name))) + (loop rest-args))] + [("-X" "--collects") + (let-values ([(collects-path rest-args) (next-arg "collects path" arg within-arg args)]) + (cond + [(equal? collects-path "") + (set! init-collects-dir 'disable)] + [else + (check-path-arg "collects path" arg within-arg) + (set! init-collects-dir (path->complete-path (string->path collects-path)))]) + (loop rest-args))] + [("-G" "--config") + (let-values ([(config-path rest-args) (next-arg "config path" arg within-arg args)]) + (check-path-arg "config path" arg within-arg) + (set! init-config-dir (path->complete-path (string->path config-path))) + (loop rest-args))] + [("-C" "--cross") + (set! host-config-dir init-config-dir) + (set! host-collects-dir init-collects-dir) + (loop (cdr args))] + [("-U" "--no-user-path") + (|#%app| use-user-specific-search-paths #f) + (loop (cdr args))] + [("-d") + (|#%app| load-on-demand-enabled #f) + (loop (cdr args))] + [("-q" "--no-init-file") + (set! repl-init? #f) + (loop (cdr args))] + [("-W" "--stderr") + (let-values ([(spec rest-args) (next-arg "stderr level" arg within-arg args)]) + (set! stderr-logging-arg (parse-logging-spec spec (format "after ~a switch" (or within-arg arg)) #t)) + (loop rest-args))] + [("-N" "--name") + (let-values ([(name rest-args) (next-arg "name" arg within-arg args)]) + (set-run-file! (string->path name)) + (loop rest-args))] + [("--") + (cond + [(or (null? (cdr args)) (not (pair? (cadr args)))) + (finish (cdr args) saw)] + [else + ;; Need to handle more switches from a combined flag + (loop (cons (cadr args) (cons (car args) (cddr args))))])] + [else + (cond + [(eqv? (string-ref arg 0) #\-) + (cond + [(and (> (string-length arg) 2) + (not (eqv? (string-ref arg 1) #\-))) + ;; Split flags + (loop (append (map (lambda (c) (cons (string #\- c) arg)) + (cdr (string->list arg))) + (cdr args)))] + [else + (raise-user-error 'racket "bad switch: ~a~a" + arg + (if within-arg + (format " within: ~a" within-arg) + ""))])] + [else + ;; Non-flag argument + (finish args saw)])])))) + + ;; Set up GC logging + (define-values (struct:gc-info make-gc-info gc-info? gc-info-ref gc-info-set!) + (make-struct-type 'gc-info #f 10 0 #f null 'prefab #f '(0 1 2 3 4 5 6 7 8 9))) + (define (K plus n) + (let* ([s (number->string (quotient (abs n) 1000))] + [len (string-length s)] + [len2 (+ len + (quotient (sub1 len) 3) + (if (or (< n 0) + (not (eq? "" plus))) + 1 + 0) + 1)] + [s2 (make-string len2)]) + (string-set! s2 (sub1 len2) #\K) + (let loop ([i len] + [j (sub1 len2)] + [digits 0]) + (cond + [(zero? i) + (cond + [(< n 0) (string-set! s2 0 #\-)] + [(not (eq? plus "")) (string-set! s2 0 (string-ref plus 0))]) + s2] + [(= 3 digits) + (let ([j (sub1 j)]) + (string-set! s2 j #\,) + (loop i j 0))] + [else + (let ([i (sub1 i)] + [j (sub1 j)]) + (string-set! s2 j (string-ref s i)) + (loop i j (add1 digits)))])))) + (define minor-gcs 0) + (define major-gcs 0) + (define auto-gcs 0) + (define peak-mem 0) + (set-garbage-collect-notify! + (let ([root-logger (|#%app| current-logger)]) + ;; This function can be called in any Chez Scheme thread + (lambda (gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time + post-allocated post-allocated+overhead post-time post-cpu-time) + (let ([minor? (< gen (collect-maximum-generation))]) + (if minor? + (set! minor-gcs (add1 minor-gcs)) + (set! major-gcs (add1 major-gcs))) + (set! peak-mem (max peak-mem pre-allocated)) + (let ([debug-GC? (log-level? root-logger 'debug 'GC)]) + (when (or debug-GC? + (and (not minor?) + (log-level? root-logger 'debug 'GC:major))) + (let ([delta (- pre-allocated post-allocated)]) + (log-message root-logger 'debug (if debug-GC? 'GC 'GC:major) + (chez:format "GC: 0:~a~a @ ~a(~a); free ~a(~a) ~ams @ ~a" + (if minor? "min" "MAJ") gen + (K "" pre-allocated) (K "+" (- pre-allocated+overhead pre-allocated)) + (K "" delta) (K "+" (- (- pre-allocated+overhead post-allocated+overhead) + delta)) + (- post-cpu-time pre-cpu-time) pre-cpu-time) + (make-gc-info (if minor? 'minor 'major) pre-allocated pre-allocated+overhead 0 + post-allocated post-allocated+overhead + pre-cpu-time post-cpu-time + pre-time post-time) + #f)))))))) + (|#%app| exit-handler + (let ([orig (|#%app| exit-handler)] + [root-logger (|#%app| current-logger)]) + (lambda (v) + (when (log-level? root-logger 'info 'GC) + (log-message root-logger 'info 'GC + (chez:format "0:atexit peak ~a; alloc ~a; major ~a; minor ~a; ~ams" + (K "" peak-mem) + (K "" (- (+ (bytes-deallocated) (bytes-allocated)) (initial-bytes-allocated))) + major-gcs + minor-gcs + (let ([t (sstats-gc-cpu (statistics))]) + (+ (* (time-second t) 1000) + (quotient (time-nanosecond t) 1000000)))) + #f)) + (linklet-performance-report!) + (|#%app| orig v)))) + + (define stderr-logging + (or stderr-logging-arg + (let ([spec (getenv "PLTSTDERR")]) + (if spec + (parse-logging-spec spec "in PLTSTDERR environment variable" #f) + '(error))))) + + (when (getenv "PLT_STATS_ON_BREAK") + (keyboard-interrupt-handler + (let ([orig (keyboard-interrupt-handler)]) + (lambda args + (dump-memory-stats) + (apply orig args))))) + + (when version? + (printf "Welcome to Racket v~a [cs]\n" (version))) + (call-in-main-thread + (lambda () + (boot) + (when (and stderr-logging + (not (null? stderr-logging))) + (apply add-stderr-log-receiver! (|#%app| current-logger) stderr-logging)) + (cond + [(eq? init-collects-dir 'disable) + (|#%app| use-collection-link-paths #f) + (set-collects-dir! (build-path 'same))] + [else + (set-collects-dir! init-collects-dir)]) + (set-config-dir! init-config-dir) + (unless (eq? init-collects-dir 'disable) + (|#%app| current-library-collection-links + (find-library-collection-links)) + (|#%app| current-library-collection-paths + (find-library-collection-paths))) + + (when init-library + (namespace-require+ init-library)) + + (for-each (lambda (ld) (ld)) + (reverse loads)) + + (when repl? + (when repl-init? + (let ([m (get-repl-init-filename)]) + (when m + (call-with-continuation-prompt + (lambda () (dynamic-require m 0)) + (default-continuation-prompt-tag) + (lambda args (set! exit-value 1)))))) + (|#%app| (if gracket? + (dynamic-require 'racket/gui/init 'graphical-read-eval-print-loop) + (dynamic-require 'racket/base 'read-eval-print-loop))) + (unless gracket? + (newline))) + + (|#%app| (|#%app| executable-yield-handler) 0) + + (exit exit-value)))) diff --git a/racket/src/cs/primitive/extfl.ss b/racket/src/cs/primitive/extfl.ss new file mode 100644 index 0000000000..cff2ca438e --- /dev/null +++ b/racket/src/cs/primitive/extfl.ss @@ -0,0 +1,47 @@ + +(define-primitive-table extfl-table + [->extfl (known-procedure 2)] + [extfl* (known-procedure 4)] + [extfl+ (known-procedure 4)] + [extfl- (known-procedure 4)] + [extfl->exact (known-procedure 2)] + [extfl->exact-integer (known-procedure 2)] + [extfl->floating-point-bytes (known-procedure 30)] + [extfl->fx (known-procedure 2)] + [extfl->inexact (known-procedure 2)] + [extfl/ (known-procedure 4)] + [extfl< (known-procedure 4)] + [extfl<= (known-procedure 4)] + [extfl= (known-procedure 4)] + [extfl> (known-procedure 4)] + [extfl>= (known-procedure 4)] + [extflabs (known-procedure 2)] + [extflacos (known-procedure 2)] + [extflasin (known-procedure 2)] + [extflatan (known-procedure 2)] + [extflceiling (known-procedure 2)] + [extflcos (known-procedure 2)] + [extflexp (known-procedure 2)] + [extflexpt (known-procedure 4)] + [extflfloor (known-procedure 2)] + [extfllog (known-procedure 2)] + [extflmax (known-procedure 4)] + [extflmin (known-procedure 4)] + [extflonum-available? (known-procedure 1)] + [extflonum? (known-procedure 2)] + [extflround (known-procedure 2)] + [extflsin (known-procedure 2)] + [extflsqrt (known-procedure 2)] + [extfltan (known-procedure 2)] + [extfltruncate (known-procedure 2)] + [extflvector (known-procedure -1)] + [extflvector-length (known-procedure 2)] + [extflvector-ref (known-procedure 4)] + [extflvector-set! (known-procedure 8)] + [extflvector? (known-procedure 2)] + [floating-point-bytes->extfl (known-procedure 30)] + [fx->extfl (known-procedure 2)] + [make-extflvector (known-procedure 6)] + [make-shared-extflvector (known-procedure 6)] + [real->extfl (known-procedure 2)] + [shared-extflvector (known-procedure -1)]) diff --git a/racket/src/cs/primitive/flfxnum.ss b/racket/src/cs/primitive/flfxnum.ss new file mode 100644 index 0000000000..7b4fd89f3f --- /dev/null +++ b/racket/src/cs/primitive/flfxnum.ss @@ -0,0 +1,73 @@ + +(define-primitive-table flfxnum-table + [->fl (known-procedure 2)] + [fl* (known-procedure 4)] + [fl+ (known-procedure 4)] + [fl- (known-procedure 4)] + [fl->exact-integer (known-procedure 2)] + [fl->fx (known-procedure 2)] + [fl/ (known-procedure 4)] + [fl< (known-procedure 4)] + [fl<= (known-procedure 4)] + [fl= (known-procedure 4)] + [fl> (known-procedure 4)] + [fl>= (known-procedure 4)] + [flabs (known-procedure 2)] + [flacos (known-procedure 2)] + [flasin (known-procedure 2)] + [flatan (known-procedure 2)] + [flceiling (known-procedure 2)] + [flcos (known-procedure 2)] + [flexp (known-procedure 2)] + [flexpt (known-procedure 4)] + [flfloor (known-procedure 2)] + [flimag-part (known-procedure 2)] + [fllog (known-procedure 2)] + [flmax (known-procedure 4)] + [flmin (known-procedure 4)] + [flreal-part (known-procedure 2)] + [flround (known-procedure 2)] + [flsin (known-procedure 2)] + [flsqrt (known-procedure 2)] + [fltan (known-procedure 2)] + [fltruncate (known-procedure 2)] + [flvector (known-procedure -1)] + [flvector-copy (known-procedure 14)] + [flvector-length (known-procedure 2)] + [flvector-ref (known-procedure 4)] + [flvector-set! (known-procedure 8)] + [flvector? (known-procedure 2)] + [fx* (known-procedure 4)] + [fx+ (known-procedure 4)] + [fx- (known-procedure 4)] + [fx->fl (known-procedure 2)] + [fx< (known-procedure 4)] + [fx<= (known-procedure 4)] + [fx= (known-procedure 4)] + [fx> (known-procedure 4)] + [fx>= (known-procedure 4)] + [fxabs (known-procedure 2)] + [fxand (known-procedure 4)] + [fxior (known-procedure 4)] + [fxlshift (known-procedure 4)] + [fxmax (known-procedure 4)] + [fxmin (known-procedure 4)] + [fxmodulo (known-procedure 4)] + [fxnot (known-procedure 2)] + [fxquotient (known-procedure 4)] + [fxremainder (known-procedure 4)] + [fxrshift (known-procedure 4)] + [fxvector (known-procedure -1)] + [fxvector-copy (known-procedure 14)] + [fxvector-length (known-procedure 2)] + [fxvector-ref (known-procedure 4)] + [fxvector-set! (known-procedure 8)] + [fxvector? (known-procedure 2)] + [fxxor (known-procedure 4)] + [make-flrectangular (known-procedure 4)] + [make-flvector (known-procedure 6)] + [make-fxvector (known-procedure 6)] + [make-shared-flvector (known-procedure 6)] + [make-shared-fxvector (known-procedure 6)] + [shared-flvector (known-procedure -1)] + [shared-fxvector (known-procedure -1)]) diff --git a/racket/src/cs/primitive/foreign.ss b/racket/src/cs/primitive/foreign.ss new file mode 100644 index 0000000000..07a5a55f90 --- /dev/null +++ b/racket/src/cs/primitive/foreign.ss @@ -0,0 +1,83 @@ + +(define-primitive-table foreign-table + [_bool (known-constant)] + [_bytes (known-constant)] + [_double (known-constant)] + [_double* (known-constant)] + [_fixint (known-constant)] + [_fixnum (known-constant)] + [_float (known-constant)] + [_fpointer (known-constant)] + [_gcpointer (known-constant)] + [_int16 (known-constant)] + [_int32 (known-constant)] + [_int64 (known-constant)] + [_int8 (known-constant)] + [_longdouble (known-constant)] + [_path (known-constant)] + [_pointer (known-constant)] + [_scheme (known-constant)] + [_stdbool (known-constant)] + [_string/ucs-4 (known-constant)] + [_string/utf-16 (known-constant)] + [_symbol (known-constant)] + [_ufixint (known-constant)] + [_ufixnum (known-constant)] + [_uint16 (known-constant)] + [_uint32 (known-constant)] + [_uint64 (known-constant)] + [_uint8 (known-constant)] + [_void (known-constant)] + [compiler-sizeof (known-procedure 2)] + [cpointer-gcable? (known-procedure 2)] + [cpointer-tag (known-procedure 2)] + [cpointer? (known-procedure 2)] + [ctype-alignof (known-procedure 2)] + [ctype-basetype (known-procedure 2)] + [ctype-c->scheme (known-procedure 2)] + [ctype-scheme->c (known-procedure 2)] + [ctype-sizeof (known-procedure 2)] + [ctype? (known-procedure 2)] + [end-stubborn-change (known-procedure 2)] + [extflvector->cpointer (known-procedure 2)] + [ffi-call (known-procedure 504)] + [ffi-call-maker (known-procedure 252)] + [ffi-callback (known-procedure 120)] + [ffi-callback? (known-procedure 2)] + [ffi-callback-maker (known-procedure 60)] + [ffi-lib (known-procedure 14)] + [ffi-lib-name (known-procedure 2)] + [ffi-lib? (known-procedure 2)] + [ffi-obj (known-procedure 4)] + [ffi-obj-lib (known-procedure 2)] + [ffi-obj-name (known-procedure 2)] + [ffi-obj? (known-procedure 2)] + [flvector->cpointer (known-procedure 2)] + [free (known-procedure 2)] + [free-immobile-cell (known-procedure 2)] + [lookup-errno (known-procedure 2)] + [make-array-type (known-procedure 4)] + [make-cstruct-type (known-procedure 14)] + [make-ctype (known-procedure 8)] + [make-late-weak-box (known-procedure 2)] + [make-late-weak-hasheq (known-procedure 1)] + [make-sized-byte-string (known-procedure 4)] + [make-stubborn-will-executor (known-procedure 1)] + [make-union-type (known-procedure -2)] + [malloc (known-procedure 62)] + [malloc-immobile-cell (known-procedure 2)] + [memcpy (known-procedure 120)] + [memmove (known-procedure 120)] + [memset (known-procedure 56)] + [offset-ptr? (known-procedure 2)] + [prop:cpointer (known-constant)] + [ptr-add (known-procedure 12)] + [ptr-add! (known-procedure 12)] + [ptr-equal? (known-procedure 4)] + [ptr-offset (known-procedure 2)] + [ptr-ref (known-procedure 28)] + [ptr-set! (known-procedure 56)] + [saved-errno (known-procedure 3)] + [set-cpointer-tag! (known-procedure 4)] + [set-ptr-offset! (known-procedure 12)] + [vector->cpointer (known-procedure 2)]) diff --git a/racket/src/cs/primitive/futures.ss b/racket/src/cs/primitive/futures.ss new file mode 100644 index 0000000000..5a52b61fd9 --- /dev/null +++ b/racket/src/cs/primitive/futures.ss @@ -0,0 +1,17 @@ + +(define-primitive-table futures-table + [current-future (known-procedure 1)] + [fsemaphore-count (known-procedure 2)] + [fsemaphore-post (known-procedure 2)] + [fsemaphore-try-wait? (known-procedure 2)] + [fsemaphore-wait (known-procedure 2)] + [fsemaphore? (known-procedure 2)] + [future (known-procedure 2)] + [future? (known-procedure 2)] + [futures-enabled? (known-procedure 1)] + [make-fsemaphore (known-procedure 2)] + [mark-future-trace-end! (known-procedure 1)] + [processor-count (known-procedure 1)] + [reset-future-logs-for-tracing! (known-procedure 1)] + [touch (known-procedure 2)] + [would-be-future (known-procedure 2)]) diff --git a/racket/src/cs/primitive/internal.ss b/racket/src/cs/primitive/internal.ss new file mode 100644 index 0000000000..f0af1ae15c --- /dev/null +++ b/racket/src/cs/primitive/internal.ss @@ -0,0 +1,32 @@ + +;; Exports that are not exposed to Racket, but +;; can be used in a linklet: + +(define-primitive-table internal-table + [call/cm (known-constant)] + [extract-procedure (known-constant)] + [set-ctl-c-handler! (known-constant)] + [register-linklet-instantiate-continuation! (known-constant)] + [impersonator-val (known-constant)] + [impersonate-ref (known-constant)] + [impersonate-set! (known-constant)] + [struct-type-install-properties! (known-constant)] + [structure-type-lookup-prefab-uid (known-constant)] + [struct-type-constructor-add-guards (known-constant)] + [register-struct-constructor! (known-constant)] + [register-struct-predicate! (known-constant)] + [register-struct-field-accessor! (known-constant)] + [register-struct-field-mutator! (known-constant)] + [struct-property-set! (known-constant)] + [|#%call-with-values| (known-constant)] + [unbox/check-undefined (known-constant)] + [set-box!/check-undefined (known-constant)] + + [make-record-type-descriptor (known-constant)] + [make-record-constructor-descriptor (known-constant)] + [record-constructor (known-constant)] + [record-predicate (known-constant)] + [record-accessor (known-constant)] + [record-mutator (known-constant)] + + [make-pthread-parameter (known-procedure 2)]) diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss new file mode 100644 index 0000000000..1d86395fa8 --- /dev/null +++ b/racket/src/cs/primitive/kernel.ss @@ -0,0 +1,978 @@ + +;; This table omits anything that the expander implements itself, +;; since the expander will export its own variant instead of the +;; `kernel-table` variant. + +(define-primitive-table kernel-table + [* (known-procedure -1)] + [+ (known-procedure -1)] + [- (known-procedure -2)] + [/ (known-procedure -2)] + [< (known-procedure -4)] + [<= (known-procedure -4)] + [= (known-procedure -4)] + [> (known-procedure -4)] + [>= (known-procedure -4)] + [abort-current-continuation (known-procedure -2)] + [abs (known-procedure 2)] + [absolute-path? (known-procedure 2)] + [acos (known-procedure 2)] + [add1 (known-procedure 2)] + [alarm-evt (known-procedure 2)] + [always-evt (known-constant)] + [andmap (known-procedure -4)] + [angle (known-procedure 2)] + [append (known-procedure -1)] + [apply (known-procedure -4)] + [arithmetic-shift (known-procedure 4)] + [arity-at-least (known-constant)] + [arity-at-least-value (known-procedure 2)] + [arity-at-least? (known-procedure/succeeds 2)] + [asin (known-procedure 2)] + [assoc (known-procedure 4)] + [assq (known-procedure 4)] + [assv (known-procedure 4)] + [atan (known-procedure 6)] + [banner (known-procedure 1)] + [bitwise-and (known-procedure -1)] + [bitwise-bit-field (known-procedure 8)] + [bitwise-bit-set? (known-procedure 4)] + [bitwise-ior (known-procedure -1)] + [bitwise-not (known-procedure 2)] + [bitwise-xor (known-procedure -1)] + [boolean? (known-procedure/succeeds 2)] + [bound-identifier=? (known-procedure 28)] + [box (known-procedure/succeeds 2)] + [box-cas! (known-procedure 8)] + [box-immutable (known-procedure 2)] + [box? (known-procedure/succeeds 2)] + [break-enabled (known-procedure 3)] + [break-thread (known-procedure 6)] + [build-path (known-procedure -2)] + [build-path/convention-type (known-procedure -4)] + [byte-pregexp (known-procedure 6)] + [byte-pregexp? (known-procedure 2)] + [byte-ready? (known-procedure 3)] + [byte-regexp (known-procedure 6)] + [byte-regexp? (known-procedure 2)] + [byte? (known-procedure/succeeds 2)] + [bytes (known-procedure -1)] + [bytes->immutable-bytes (known-procedure 2)] + [bytes->list (known-procedure 2)] + [bytes->path (known-procedure 6)] + [bytes->path-element (known-procedure 6)] + [bytes->string/latin-1 (known-procedure 30)] + [bytes->string/locale (known-procedure 30)] + [bytes->string/utf-8 (known-procedure 30)] + [bytes-append (known-procedure -1)] + [bytes-close-converter (known-procedure 2)] + [bytes-convert (known-procedure 254)] + [bytes-convert-end (known-procedure 15)] + [bytes-converter? (known-procedure 2)] + [bytes-copy (known-procedure 2)] + [bytes-copy! (known-procedure 56)] + [bytes-fill! (known-procedure 4)] + [bytes-length (known-procedure 2)] + [bytes-open-converter (known-procedure 4)] + [bytes-ref (known-procedure 4)] + [bytes-set! (known-procedure 8)] + [bytes-utf-8-index (known-procedure 28)] + [bytes-utf-8-length (known-procedure 30)] + [bytes-utf-8-ref (known-procedure 28)] + [bytes? (known-procedure -4)] + [bytes? (known-procedure/succeeds 2)] + [caaaar (known-procedure 2)] + [caaadr (known-procedure 2)] + [caaar (known-procedure 2)] + [caadar (known-procedure 2)] + [caaddr (known-procedure 2)] + [caadr (known-procedure 2)] + [caadr (known-procedure 2)] + [caar (known-procedure 2)] + [cadaar (known-procedure 2)] + [cadadr (known-procedure 2)] + [cadar (known-procedure 2)] + [caddar (known-procedure 2)] + [cadddr (known-procedure 2)] + [caddr (known-procedure 2)] + [cadr (known-procedure 2)] + [call-in-nested-thread (known-procedure 6)] + [call-with-composable-continuation (known-procedure 6)] + [call-with-continuation-barrier (known-procedure 2)] + [call-with-continuation-prompt (known-procedure -2)] + [call-with-current-continuation (known-procedure 6)] + [call-with-escape-continuation (known-procedure 2)] + [call-with-immediate-continuation-mark (known-procedure 12)] + [call-with-input-file (known-procedure 12)] + [call-with-output-file (known-procedure 28)] + [call-with-semaphore (known-procedure -4)] + [call-with-semaphore/enable-break (known-procedure -4)] + [call-with-values (known-procedure 4)] + [car (known-procedure 2)] + [cdaaar (known-procedure 2)] + [cdaadr (known-procedure 2)] + [cdaar (known-procedure 2)] + [cdadar (known-procedure 2)] + [cdaddr (known-procedure 2)] + [cdadr (known-procedure 2)] + [cdar (known-procedure 2)] + [cddaar (known-procedure 2)] + [cddadr (known-procedure 2)] + [cddar (known-procedure 2)] + [cdddar (known-procedure 2)] + [cddddr (known-procedure 2)] + [cdddr (known-procedure 2)] + [cddr (known-procedure 2)] + [cdr (known-procedure 2)] + [ceiling (known-procedure 2)] + [channel-put-evt (known-procedure 4)] + [channel-put-evt? (known-procedure 2)] + [channel? (known-procedure 2)] + [chaperone-box (known-procedure -8)] + [chaperone-channel (known-procedure -8)] + [chaperone-continuation-mark-key (known-procedure -8)] + [chaperone-evt (known-procedure -4)] + [chaperone-hash (known-procedure -32)] + [chaperone-of? (known-procedure 4)] + [chaperone-procedure (known-procedure -4)] + [chaperone-procedure* (known-procedure -4)] + [chaperone-prompt-tag (known-procedure -8)] + [chaperone-struct (known-procedure -2)] + [chaperone-struct-type (known-procedure -16)] + [chaperone-vector (known-procedure -8)] + [chaperone-vector* (known-procedure -8)] + [chaperone? (known-procedure/succeeds 2)] + [char->integer (known-procedure 2)] + [char-alphabetic? (known-procedure 2)] + [char-blank? (known-procedure 2)] + [char-ci<=? (known-procedure -4)] + [char-ci=? (known-procedure -4)] + [char-ci>? (known-procedure -4)] + [char-downcase (known-procedure 2)] + [char-foldcase (known-procedure 2)] + [char-general-category (known-procedure 2)] + [char-graphic? (known-procedure 2)] + [char-iso-control? (known-procedure 2)] + [char-lower-case? (known-procedure 2)] + [char-numeric? (known-procedure 2)] + [char-punctuation? (known-procedure 2)] + [char-ready? (known-procedure 3)] + [char-symbolic? (known-procedure 2)] + [char-title-case? (known-procedure 2)] + [char-titlecase (known-procedure 2)] + [char-upcase (known-procedure 2)] + [char-upper-case? (known-procedure 2)] + [char-utf-8-length (known-procedure 2)] + [char-whitespace? (known-procedure 2)] + [char<=? (known-procedure -4)] + [char=? (known-procedure -4)] + [char>? (known-procedure -4)] + [char? (known-procedure/succeeds 2)] + [checked-procedure-check-and-extract (known-procedure 32)] + [choice-evt (known-procedure -1)] + [cleanse-path (known-procedure 2)] + [close-input-port (known-procedure 2)] + [close-output-port (known-procedure 2)] + [collect-garbage (known-procedure 3)] + [compile (known-procedure 2)] + [compile-allow-set!-undefined (known-constant)] + [compile-context-preservation-enabled (known-constant)] + [compile-enforce-module-constants (known-constant)] + [complete-path? (known-procedure 2)] + [complex? (known-procedure/succeeds 2)] + [cons (known-procedure/succeeds 4)] + [continuation-mark-key? (known-procedure 2)] + [continuation-mark-set->context (known-procedure 2)] + [continuation-mark-set->list (known-procedure 12)] + [continuation-mark-set->list* (known-procedure 28)] + [continuation-mark-set-first (known-procedure 28)] + [continuation-mark-set? (known-procedure 2)] + [continuation-marks (known-procedure 6)] + [continuation-prompt-available? (known-procedure 6)] + [continuation-prompt-tag? (known-procedure 2)] + [continuation? (known-procedure 2)] + [copy-file (known-procedure 12)] + [cos (known-procedure 2)] + [current-code-inspector (known-constant)] + [current-command-line-arguments (known-constant)] + [current-continuation-marks (known-procedure 3)] + [current-custodian (known-constant)] + [current-directory (known-constant)] + [current-directory-for-user (known-constant)] + [current-drive (known-procedure 1)] + [current-environment-variables (known-constant)] + [current-error-port (known-constant)] + [current-evt-pseudo-random-generator (known-constant)] + [current-force-delete-permissions (known-constant)] + [current-gc-milliseconds (known-procedure 1)] + [current-get-interaction-input-port (known-constant)] + [current-inexact-milliseconds (known-procedure 1)] + [current-input-port (known-constant)] + [current-inspector (known-constant)] + [current-load-extension (known-constant)] + [current-load-relative-directory (known-constant)] + [current-locale (known-constant)] + [current-logger (known-constant)] + [current-memory-use (known-procedure 3)] + [current-milliseconds (known-procedure 1)] + [current-output-port (known-constant)] + [current-plumber (known-constant)] + [current-preserved-thread-cell-values (known-procedure 3)] + [current-print (known-constant)] + [current-process-milliseconds (known-procedure 3)] + [current-prompt-read (known-constant)] + [current-pseudo-random-generator (known-constant)] + [current-read-interaction (known-constant)] + [current-seconds (known-procedure 1)] + [current-security-guard (known-constant)] + [current-subprocess-custodian-mode (known-constant)] + [current-thread (known-procedure 1)] + [current-thread-group (known-constant)] + [current-thread-initial-stack-size (known-constant)] + [current-write-relative-directory (known-constant)] + [custodian-box-value (known-procedure 2)] + [custodian-box? (known-procedure 2)] + [custodian-limit-memory (known-procedure 12)] + [custodian-managed-list (known-procedure 4)] + [custodian-memory-accounting-available? (known-procedure 1)] + [custodian-require-memory (known-procedure 8)] + [custodian-shut-down? (known-procedure 2)] + [custodian-shutdown-all (known-procedure 2)] + [custodian? (known-procedure 2)] + [custom-print-quotable-accessor (known-procedure 2)] + [custom-print-quotable? (known-procedure 2)] + [custom-write-accessor (known-procedure 2)] + [custom-write? (known-procedure 2)] + [date (known-constant)] + [date* (known-constant)] + [date*-nanosecond (known-procedure 2)] + [date*-time-zone-name (known-procedure 2)] + [date*? (known-procedure 2)] + [date-day (known-procedure 2)] + [date-dst? (known-procedure 2)] + [date-hour (known-procedure 2)] + [date-minute (known-procedure 2)] + [date-month (known-procedure 2)] + [date-second (known-procedure 2)] + [date-time-zone-offset (known-procedure 2)] + [date-week-day (known-procedure 2)] + [date-year (known-procedure 2)] + [date-year-day (known-procedure 2)] + [date? (known-procedure/succeeds 2)] + [datum->syntax (known-procedure 60)] + [datum-intern-literal (known-procedure 2)] + [default-continuation-prompt-tag (known-procedure 1)] + [delete-directory (known-procedure 2)] + [delete-file (known-procedure 2)] + [denominator (known-procedure 2)] + [directory-exists? (known-procedure 2)] + [directory-list (known-procedure 3)] + [display (known-procedure 6)] + [double-flonum? (known-procedure 2)] + [dump-memory-stats (known-procedure -1)] + [dynamic-wind (known-procedure 8)] + [environment-variables-copy (known-procedure 2)] + [environment-variables-names (known-procedure 2)] + [environment-variables-ref (known-procedure 4)] + [environment-variables-set! (known-procedure 24)] + [environment-variables? (known-procedure 2)] + [eof (known-constant)] + [eof-object? (known-procedure/succeeds 2)] + [ephemeron-value (known-procedure 6)] + [ephemeron? (known-procedure/succeeds 2)] + [eprintf (known-procedure -2)] + [eq-hash-code (known-procedure 2)] + [eq? (known-procedure/succeeds 4)] + [equal-hash-code (known-procedure 2)] + [equal-secondary-hash-code (known-procedure 2)] + [equal? (known-procedure 4)] + [equal?/recur (known-procedure 8)] + [eqv-hash-code (known-procedure 2)] + [eqv? (known-procedure/succeeds 4)] + [error (known-procedure -2)] + [error-display-handler (known-constant)] + [error-escape-handler (known-constant)] + [error-print-context-length (known-constant)] + [error-print-source-location (known-constant)] + [error-print-width (known-constant)] + [error-value->string-handler (known-constant)] + [eval-jit-enabled (known-constant)] + [even? (known-procedure 2)] + [evt? (known-procedure 2)] + [exact->inexact (known-procedure 2)] + [exact-integer? (known-procedure/succeeds 2)] + [exact-nonnegative-integer? (known-procedure 2)] + [exact-positive-integer? (known-procedure/succeeds 2)] + [exact? (known-procedure 2)] + [executable-yield-handler (known-constant)] + [exit (known-procedure 3)] + [exit-handler (known-constant)] + [exn (known-constant)] + [exn-continuation-marks (known-procedure 2)] + [exn-continuation-marks (known-procedure 2)] + [exn-message (known-procedure 2)] + [exn-message (known-procedure 2)] + [exn:break (known-constant)] + [exn:break-continuation (known-procedure 2)] + [exn:break:hang-up (known-constant)] + [exn:break:hang-up? (known-procedure 2)] + [exn:break:terminate (known-constant)] + [exn:break:terminate? (known-procedure 2)] + [exn:break? (known-procedure 2)] + [exn:fail (known-constant)] + [exn:fail:contract (known-constant)] + [exn:fail:contract:arity (known-constant)] + [exn:fail:contract:arity? (known-procedure 2)] + [exn:fail:contract:continuation (known-constant)] + [exn:fail:contract:continuation? (known-procedure 2)] + [exn:fail:contract:divide-by-zero (known-constant)] + [exn:fail:contract:divide-by-zero? (known-procedure 2)] + [exn:fail:contract:non-fixnum-result (known-constant)] + [exn:fail:contract:non-fixnum-result? (known-procedure 2)] + [exn:fail:contract:variable (known-constant)] + [exn:fail:contract:variable-id (known-procedure 2)] + [exn:fail:contract:variable? (known-procedure 2)] + [exn:fail:contract? (known-procedure 2)] + [exn:fail:filesystem (known-constant)] + [exn:fail:filesystem:errno (known-constant)] + [exn:fail:filesystem:errno-errno (known-procedure 2)] + [exn:fail:filesystem:errno? (known-procedure 2)] + [exn:fail:filesystem:exists (known-constant)] + [exn:fail:filesystem:exists? (known-procedure 2)] + [exn:fail:filesystem:version (known-constant)] + [exn:fail:filesystem:version? (known-procedure 2)] + [exn:fail:filesystem? (known-procedure 2)] + [exn:fail:network (known-constant)] + [exn:fail:network:errno (known-constant)] + [exn:fail:network:errno-errno (known-procedure 2)] + [exn:fail:network:errno? (known-procedure 2)] + [exn:fail:network? (known-procedure 2)] + [exn:fail:out-of-memory (known-constant)] + [exn:fail:out-of-memory? (known-procedure 2)] + [exn:fail:read (known-constant)] + [exn:fail:read-srclocs (known-procedure 2)] + [exn:fail:read:eof (known-constant)] + [exn:fail:read:eof? (known-procedure 2)] + [exn:fail:read:non-char (known-constant)] + [exn:fail:read:non-char? (known-procedure 2)] + [exn:fail:read? (known-procedure 2)] + [exn:fail:unsupported (known-constant)] + [exn:fail:unsupported? (known-procedure 2)] + [exn:fail:user (known-constant)] + [exn:fail:user? (known-procedure 2)] + [exn:fail? (known-procedure 2)] + [exn:srclocs-accessor (known-procedure 2)] + [exn:srclocs? (known-procedure 2)] + [exn? (known-procedure 2)] + [exn? (known-procedure 2)] + [exp (known-procedure 2)] + [expand-user-path (known-procedure 2)] + [explode-path (known-procedure 2)] + [expt (known-procedure 4)] + [file-exists? (known-procedure 2)] + [file-or-directory-identity (known-procedure 6)] + [file-or-directory-modify-seconds (known-procedure 14)] + [file-or-directory-permissions (known-procedure 6)] + [file-position (known-procedure 6)] + [file-position* (known-procedure 2)] + [file-size (known-procedure 2)] + [file-stream-buffer-mode (known-procedure 6)] + [file-stream-port? (known-procedure 2)] + [file-truncate (known-procedure 4)] + [filesystem-change-evt (known-procedure 6)] + [filesystem-change-evt-cancel (known-procedure 2)] + [filesystem-change-evt? (known-procedure 2)] + [filesystem-root-list (known-procedure 1)] + [find-system-path (known-procedure 2)] + [fixnum? (known-procedure/succeeds 2)] + [floating-point-bytes->real (known-procedure 30)] + [flonum? (known-procedure/succeeds 2)] + [floor (known-procedure 2)] + [flush-output (known-procedure 3)] + [for-each (known-procedure -4)] + [format (known-procedure -2)] + [fprintf (known-procedure -4)] + [gcd (known-procedure -1)] + [gensym (known-procedure 3)] + [get-output-bytes (known-procedure 30)] + [get-output-string (known-procedure 2)] + [global-port-print-handler (known-constant)] + [handle-evt (known-procedure 4)] + [handle-evt? (known-procedure 2)] + [hash (known-procedure -1)] + [hash-clear (known-procedure 2)] + [hash-clear! (known-procedure 2)] + [hash-copy (known-procedure 2)] + [hash-count (known-procedure 2)] + [hash-eq? (known-procedure 2)] + [hash-equal? (known-procedure 2)] + [hash-eqv? (known-procedure 2)] + [hash-for-each (known-procedure 12)] + [hash-iterate-first (known-procedure 2)] + [hash-iterate-key (known-procedure 4)] + [hash-iterate-key+value (known-procedure 4)] + [hash-iterate-next (known-procedure 4)] + [hash-iterate-pair (known-procedure 4)] + [hash-iterate-value (known-procedure 4)] + [hash-keys-subset? (known-procedure 4)] + [hash-map (known-procedure 12)] + [hash-placeholder? (known-procedure 2)] + [hash-ref (known-procedure 12)] + [hash-remove (known-procedure 4)] + [hash-remove! (known-procedure 4)] + [hash-set (known-procedure 8)] + [hash-set! (known-procedure 8)] + [hash-weak? (known-procedure 2)] + [hash? (known-procedure/succeeds 2)] + [hasheq (known-procedure -1)] + [hasheqv (known-procedure -1)] + [imag-part (known-procedure 2)] + [immutable? (known-procedure/succeeds 2)] + [impersonate-box (known-procedure -8)] + [impersonate-channel (known-procedure -8)] + [impersonate-continuation-mark-key (known-procedure -8)] + [impersonate-hash (known-procedure -32)] + [impersonate-procedure (known-procedure -4)] + [impersonate-procedure* (known-procedure -4)] + [impersonate-prompt-tag (known-procedure -8)] + [impersonate-struct (known-procedure -2)] + [impersonate-vector (known-procedure -8)] + [impersonate-vector* (known-procedure -8)] + [impersonator-ephemeron (known-procedure 2)] + [impersonator-of? (known-procedure 4)] + [impersonator-prop:application-mark (known-constant)] + [impersonator-property-accessor-procedure? (known-procedure 2)] + [impersonator-property? (known-procedure 2)] + [impersonator? (known-procedure/succeeds 2)] + [inexact->exact (known-procedure 2)] + [inexact-real? (known-procedure 2)] + [inexact? (known-procedure 2)] + [input-port? (known-procedure 2)] + [inspector-superior? (known-procedure 4)] + [inspector? (known-procedure 2)] + [integer->char (known-procedure 2)] + [integer->integer-bytes (known-procedure 120)] + [integer-bytes->integer (known-procedure 60)] + [integer-length (known-procedure 2)] + [integer-sqrt (known-procedure 2)] + [integer-sqrt/remainder (known-procedure 2)] + [integer? (known-procedure 2)] + [interned-char? (known-procedure 2)] + [keyword->string (known-procedure 2)] + [keywordbytes (known-procedure 2)] + [list->string (known-procedure 2)] + [list->vector (known-procedure 2)] + [list-pair? (known-procedure 2)] + [list-ref (known-procedure 4)] + [list-tail (known-procedure 4)] + [list? (known-procedure 2)] + [load-on-demand-enabled (known-constant)] + [locale-string-encoding (known-procedure 1)] + [log (known-procedure 6)] + [log-all-levels (known-procedure 2)] + [log-level-evt (known-procedure 2)] + [log-level? (known-procedure 12)] + [log-max-level (known-procedure 6)] + [log-message (known-procedure 112)] + [log-receiver? (known-procedure 2)] + [logger-name (known-procedure 2)] + [logger? (known-procedure 2)] + [magnitude (known-procedure 2)] + [make-bytes (known-procedure 6)] + [make-channel (known-procedure 1)] + [make-continuation-mark-key (known-procedure 3)] + [make-continuation-prompt-tag (known-procedure 3)] + [make-custodian (known-procedure 3)] + [make-custodian-box (known-procedure 4)] + [make-date (known-constant)] + [make-date* (known-constant)] + [make-derived-parameter (known-procedure 8)] + [make-directory (known-procedure 2)] + [make-environment-variables (known-procedure -1)] + [make-ephemeron (known-procedure 4)] + [make-file-or-directory-link (known-procedure 4)] + [make-hash (known-procedure 3)] + [make-hash-placeholder (known-procedure 2)] + [make-hasheq (known-procedure 3)] + [make-hasheq-placeholder (known-procedure 2)] + [make-hasheqv (known-procedure 3)] + [make-hasheqv-placeholder (known-procedure 2)] + [make-immutable-hash (known-procedure 3)] + [make-immutable-hasheq (known-procedure 3)] + [make-immutable-hasheqv (known-procedure 3)] + [make-impersonator-property (known-procedure 2)] + [make-input-port (known-procedure 2032)] + [make-inspector (known-procedure 3)] + [make-known-char-range-list (known-procedure 1)] + [make-log-receiver (known-procedure -4)] + [make-logger (known-procedure -1)] + [make-output-port (known-procedure 4080)] + [make-parameter (known-procedure 6)] + [make-phantom-bytes (known-procedure 2)] + [make-pipe (known-procedure 15)] + [make-placeholder (known-procedure 2)] + [make-plumber (known-procedure 1)] + [make-polar (known-procedure 4)] + [make-prefab-struct (known-procedure -2)] + [make-pseudo-random-generator (known-procedure 1)] + [make-reader-graph (known-procedure 2)] + [make-rectangular (known-procedure 4)] + [make-security-guard (known-procedure 24)] + [make-semaphore (known-procedure 3)] + [make-shared-bytes (known-procedure 6)] + [make-sibling-inspector (known-procedure 3)] + [make-string (known-procedure 6)] + [make-struct-field-accessor (known-procedure 12)] + [make-struct-field-mutator (known-procedure 12)] + [make-struct-type (known-procedure 4080)] + [make-struct-type-property (known-procedure 30)] + [make-thread-cell (known-procedure 6)] + [make-thread-group (known-procedure 3)] + [make-vector (known-procedure 6)] + [make-weak-box (known-procedure 2)] + [make-weak-hash (known-procedure 3)] + [make-weak-hasheq (known-procedure 3)] + [make-weak-hasheqv (known-procedure 3)] + [make-will-executor (known-procedure 1)] + [map (known-procedure -4)] + [max (known-procedure -2)] + [mcar (known-procedure 2)] + [mcdr (known-procedure 2)] + [mcons (known-procedure/succeeds 4)] + [min (known-procedure -2)] + [modulo (known-procedure 4)] + [mpair? (known-procedure/succeeds 2)] + [nack-guard-evt (known-procedure 2)] + [negative? (known-procedure 2)] + [never-evt (known-constant)] + [newline (known-procedure 3)] + [not (known-procedure 2)] + [null (known-literal '(quote ()))] + [null? (known-procedure/succeeds 2)] + [number->string (known-procedure 6)] + [number? (known-procedure/succeeds 2)] + [numerator (known-procedure 2)] + [object-name (known-procedure 2)] + [odd? (known-procedure 2)] + [open-input-bytes (known-procedure 6)] + [open-input-file (known-procedure 14)] + [open-input-output-file (known-procedure 14)] + [open-input-string (known-procedure 6)] + [open-output-bytes (known-procedure 3)] + [open-output-file (known-procedure 14)] + [open-output-string (known-procedure 3)] + [ormap (known-procedure -4)] + [output-port? (known-procedure 2)] + [pair? (known-procedure/succeeds 2)] + [parameter-procedure=? (known-procedure 4)] + [parameter? (known-procedure 2)] + [parameterization? (known-procedure 2)] + [path->bytes (known-procedure 2)] + [path->complete-path (known-procedure 6)] + [path->directory-path (known-procedure 2)] + [path->string (known-procedure 2)] + [path-convention-type (known-procedure 2)] + [path-element->bytes (known-procedure 2)] + [path-element->string (known-procedure 2)] + [path-for-some-system? (known-procedure 2)] + [pathstruct-type (known-procedure 4)] + [prefab-key? (known-procedure 2)] + [prefab-struct-key (known-procedure 2)] + [pregexp (known-procedure 6)] + [pregexp? (known-procedure 2)] + [primitive-closure? (known-procedure 2)] + [primitive-result-arity (known-procedure 2)] + [primitive? (known-procedure 2)] + [print (known-procedure 14)] + [print-as-expression (known-constant)] + [print-boolean-long-form (known-constant)] + [print-box (known-constant)] + [print-graph (known-constant)] + [print-hash-table (known-constant)] + [print-mpair-curly-braces (known-constant)] + [print-pair-curly-braces (known-constant)] + [print-reader-abbreviations (known-constant)] + [print-struct (known-constant)] + [print-syntax-width (known-constant)] + [print-unreadable (known-constant)] + [print-vector-length (known-constant)] + [printf (known-procedure -2)] + [procedure->method (known-procedure 2)] + [procedure-arity (known-procedure 2)] + [procedure-arity-includes? (known-procedure 12)] + [procedure-arity? (known-procedure 2)] + [procedure-closure-contents-eq? (known-procedure 4)] + [procedure-extract-target (known-procedure 2)] + [procedure-impersonator*? (known-procedure 2)] + [procedure-reduce-arity (known-procedure 4)] + [procedure-rename (known-procedure 4)] + [procedure-result-arity (known-procedure 2)] + [procedure-specialize (known-procedure 2)] + [procedure-struct-type? (known-procedure 2)] + [procedure? (known-procedure/succeeds 2)] + [progress-evt? (known-procedure 6)] + [prop:arity-string (known-constant)] + [prop:authentic (known-struct-type-property/immediate-guard)] + [prop:checked-procedure (known-constant)] + [prop:custom-print-quotable (known-constant)] + [prop:custom-write (known-struct-type-property/immediate-guard)] + [prop:equal+hash (known-struct-type-property/immediate-guard)] + [prop:evt (known-struct-type-property/immediate-guard)] + [prop:exn:srclocs (known-constant)] + [prop:impersonator-of (known-constant)] + [prop:incomplete-arity (known-constant)] + [prop:input-port (known-constant)] + [prop:method-arity-error (known-constant)] + [prop:object-name (known-constant)] + [prop:output-port (known-constant)] + [prop:procedure (known-struct-type-property/immediate-guard)] + [pseudo-random-generator->vector (known-procedure 2)] + [pseudo-random-generator-vector? (known-procedure 2)] + [pseudo-random-generator? (known-procedure 2)] + [quotient (known-procedure 4)] + [quotient/remainder (known-procedure 4)] + [raise (known-procedure 6)] + [raise-argument-error (known-procedure -8)] + [raise-arguments-error (known-procedure -4)] + [raise-arity-error (known-procedure -4)] + [raise-mismatch-error (known-procedure -8)] + [raise-range-error (known-procedure 384)] + [raise-result-error (known-procedure -8)] + [raise-type-error (known-procedure -8)] + [raise-user-error (known-procedure -2)] + [random (known-procedure 7)] + [random-seed (known-procedure 2)] + [rational? (known-procedure 2)] + [read-accept-bar-quote (known-constant)] + [read-byte (known-procedure 3)] + [read-byte-or-special (known-procedure 15)] + [read-bytes (known-procedure 6)] + [read-bytes! (known-procedure 30)] + [read-bytes-avail! (known-procedure 30)] + [read-bytes-avail!* (known-procedure 30)] + [read-bytes-avail!/enable-break (known-procedure 30)] + [read-bytes-line (known-procedure 7)] + [read-case-sensitive (known-constant)] + [read-char (known-procedure 3)] + [read-char-or-special (known-procedure 15)] + [read-line (known-procedure 7)] + [read-on-demand-source (known-constant)] + [read-string (known-procedure 6)] + [read-string! (known-procedure 30)] + [real->double-flonum (known-procedure 2)] + [real->floating-point-bytes (known-procedure 60)] + [real->single-flonum (known-procedure 2)] + [real-part (known-procedure 2)] + [real? (known-procedure 2)] + [regexp (known-procedure 6)] + [regexp-match (known-procedure 124)] + [regexp-match-peek (known-procedure 124)] + [regexp-match-peek-immediate (known-procedure 124)] + [regexp-match-peek-positions (known-procedure 124)] + [regexp-match-peek-positions-immediate (known-procedure 124)] + [regexp-match-peek-positions-immediate/end (known-procedure 252)] + [regexp-match-peek-positions/end (known-procedure 252)] + [regexp-match-positions (known-procedure 124)] + [regexp-match-positions/end (known-procedure 252)] + [regexp-match/end (known-procedure 252)] + [regexp-match? (known-procedure 124)] + [regexp-max-lookbehind (known-procedure 2)] + [regexp-replace (known-procedure 24)] + [regexp-replace* (known-procedure 24)] + [regexp? (known-procedure 2)] + [relative-path? (known-procedure 2)] + [remainder (known-procedure 4)] + [rename-file-or-directory (known-procedure 12)] + [replace-evt (known-procedure 4)] + [resolve-path (known-procedure 2)] + [reverse (known-procedure 2)] + [round (known-procedure 2)] + [seconds->date (known-procedure 6)] + [security-guard? (known-procedure 2)] + [semaphore-peek-evt (known-procedure 2)] + [semaphore-peek-evt? (known-procedure 2)] + [semaphore-post (known-procedure 2)] + [semaphore-try-wait? (known-procedure 2)] + [semaphore-wait (known-procedure 2)] + [semaphore-wait/enable-break (known-procedure 2)] + [semaphore? (known-procedure 2)] + [set-box! (known-procedure 4)] + [set-box*! (known-procedure 4)] + [set-mcar! (known-procedure 4)] + [set-mcdr! (known-procedure 4)] + [set-phantom-bytes! (known-procedure 4)] + [set-port-next-location! (known-procedure 16)] + [shared-bytes (known-procedure -1)] + [shell-execute (known-procedure 32)] + [simplify-path (known-procedure 6)] + [sin (known-procedure 2)] + [single-flonum? (known-procedure 2)] + [sleep (known-procedure 3)] + [split-path (known-procedure 2)] + [sqrt (known-procedure 2)] + [srcloc (known-constant)] + [srcloc->string (known-procedure 2)] + [srcloc-column (known-procedure 2)] + [srcloc-line (known-procedure 2)] + [srcloc-position (known-procedure 2)] + [srcloc-source (known-procedure 2)] + [srcloc-span (known-procedure 2)] + [srcloc? (known-procedure 2)] + [string (known-procedure -1)] + [string->bytes/latin-1 (known-procedure 30)] + [string->bytes/locale (known-procedure 30)] + [string->bytes/utf-8 (known-procedure 30)] + [string->immutable-string (known-procedure 2)] + [string->keyword (known-procedure 2)] + [string->list (known-procedure 2)] + [string->number (known-procedure 30)] + [string->path (known-procedure 2)] + [string->path-element (known-procedure 2)] + [string->symbol (known-procedure 2)] + [string->uninterned-symbol (known-procedure 2)] + [string->unreadable-symbol (known-procedure 2)] + [string-append (known-procedure -1)] + [string-ci<=? (known-procedure -4)] + [string-ci=? (known-procedure -4)] + [string-ci>? (known-procedure -4)] + [string-copy (known-procedure 2)] + [string-copy! (known-procedure 56)] + [string-downcase (known-procedure 2)] + [string-fill! (known-procedure 4)] + [string-foldcase (known-procedure 2)] + [string-length (known-procedure 2)] + [string-locale-ci? (known-procedure -4)] + [string-locale-downcase (known-procedure 2)] + [string-locale-upcase (known-procedure 2)] + [string-locale? (known-procedure -4)] + [string-normalize-nfc (known-procedure 2)] + [string-normalize-nfd (known-procedure 2)] + [string-normalize-nfkc (known-procedure 2)] + [string-normalize-nfkd (known-procedure 2)] + [string-port? (known-procedure 2)] + [string-ref (known-procedure 4)] + [string-set! (known-procedure 8)] + [string-titlecase (known-procedure 2)] + [string-upcase (known-procedure 2)] + [string-utf-8-length (known-procedure 14)] + [string<=? (known-procedure -4)] + [string=? (known-procedure -4)] + [string>? (known-procedure -4)] + [string? (known-procedure/succeeds 2)] + [struct->vector (known-procedure 6)] + [struct-accessor-procedure? (known-procedure 2)] + [struct-constructor-procedure? (known-procedure 2)] + [struct-info (known-procedure 2)] + [struct-mutator-procedure? (known-procedure 2)] + [struct-predicate-procedure? (known-procedure 2)] + [struct-type-info (known-procedure 2)] + [struct-type-make-constructor (known-procedure 6)] + [struct-type-make-predicate (known-procedure 2)] + [struct-type-property-accessor-procedure? (known-procedure 2)] + [struct-type-property? (known-procedure 2)] + [struct-type? (known-procedure 2)] + [struct:arity-at-least (known-constant)] + [struct:date (known-constant)] + [struct:date* (known-constant)] + [struct:exn (known-constant)] + [struct:exn:break (known-constant)] + [struct:exn:break:hang-up (known-constant)] + [struct:exn:break:terminate (known-constant)] + [struct:exn:fail (known-constant)] + [struct:exn:fail:contract (known-constant)] + [struct:exn:fail:contract:arity (known-constant)] + [struct:exn:fail:contract:continuation (known-constant)] + [struct:exn:fail:contract:divide-by-zero (known-constant)] + [struct:exn:fail:contract:non-fixnum-result (known-constant)] + [struct:exn:fail:contract:variable (known-constant)] + [struct:exn:fail:filesystem (known-constant)] + [struct:exn:fail:filesystem:errno (known-constant)] + [struct:exn:fail:filesystem:exists (known-constant)] + [struct:exn:fail:filesystem:version (known-constant)] + [struct:exn:fail:network (known-constant)] + [struct:exn:fail:network:errno (known-constant)] + [struct:exn:fail:out-of-memory (known-constant)] + [struct:exn:fail:read (known-constant)] + [struct:exn:fail:read:eof (known-constant)] + [struct:exn:fail:read:non-char (known-constant)] + [struct:exn:fail:unsupported (known-constant)] + [struct:exn:fail:user (known-constant)] + [struct:srcloc (known-constant)] + [struct? (known-procedure 2)] + [sub1 (known-procedure 2)] + [subbytes (known-procedure 12)] + [subprocess (known-procedure -16)] + [subprocess-group-enabled (known-constant)] + [subprocess-kill (known-procedure 4)] + [subprocess-pid (known-procedure 2)] + [subprocess-status (known-procedure 2)] + [subprocess-wait (known-procedure 2)] + [subprocess? (known-procedure 2)] + [substring (known-procedure 12)] + [symbol->string (known-procedure 2)] + [symbol-interned? (known-procedure 2)] + [symbol-unreadable? (known-procedure 2)] + [symboldatum (known-procedure 2)] + [syntax-column (known-procedure 2)] + [syntax-e (known-procedure 2)] + [syntax-line (known-procedure 2)] + [syntax-position (known-procedure 2)] + [syntax-property (known-procedure 28)] + [syntax-property-symbol-keys (known-procedure 2)] + [syntax-source (known-procedure 2)] + [syntax-span (known-procedure 2)] + [syntax? (known-procedure 2)] + [system-big-endian? (known-procedure 1)] + [system-idle-evt (known-procedure 1)] + [system-language+country (known-procedure 1)] + [system-library-subpath (known-procedure 3)] + [system-path-convention-type (known-procedure 1)] + [system-type (known-procedure 3)] + [tan (known-procedure 2)] + [terminal-port? (known-procedure 2)] + [thread (known-procedure 2)] + [thread-cell-ref (known-procedure 2)] + [thread-cell-set! (known-procedure 4)] + [thread-cell-values? (known-procedure 2)] + [thread-cell? (known-procedure 2)] + [thread-dead-evt (known-procedure 2)] + [thread-dead? (known-procedure 2)] + [thread-group? (known-procedure 2)] + [thread-receive (known-procedure 1)] + [thread-receive (known-procedure 1)] + [thread-receive-evt (known-procedure 1)] + [thread-resume (known-procedure 6)] + [thread-resume-evt (known-procedure 2)] + [thread-rewind-receive (known-procedure 2)] + [thread-running? (known-procedure 2)] + [thread-send (known-procedure 12)] + [thread-suspend (known-procedure 2)] + [thread-suspend-evt (known-procedure 2)] + [thread-try-receive (known-procedure 1)] + [thread-wait (known-procedure 2)] + [thread/suspend-to-kill (known-procedure 2)] + [thread? (known-procedure 2)] + [time-apply (known-procedure 4)] + [true-object? (known-procedure/succeeds 2)] + [truncate (known-procedure 2)] + [unbox (known-procedure 2)] + [unbox* (known-procedure 2)] + [uncaught-exception-handler (known-constant)] + [unquoted-printing-string (known-procedure 2)] + [unquoted-printing-string-value (known-procedure 2)] + [unquoted-printing-string? (known-procedure 2)] + [values (known-procedure -1)] + [vector (known-procedure/succeeds -1)] + [vector->immutable-vector (known-procedure 2)] + [vector->list (known-procedure 2)] + [vector->pseudo-random-generator (known-procedure 2)] + [vector->pseudo-random-generator! (known-procedure 4)] + [vector->values (known-procedure 14)] + [vector-cas! (known-procedure 16)] + [vector-copy! (known-procedure 56)] + [vector-fill! (known-procedure 4)] + [vector-immutable (known-procedure -1)] + [vector-length (known-procedure 2)] + [vector-ref (known-procedure 4)] + [vector-set! (known-procedure 8)] + [vector-set-performance-stats! (known-procedure 6)] + [vector? (known-procedure/succeeds 2)] + [vector*-length (known-procedure 2)] + [vector*-ref (known-procedure 4)] + [vector*-set! (known-procedure 8)] + [version (known-procedure 1)] + [void (known-procedure/succeeds -1)] + [void? (known-procedure/succeeds 2)] + [weak-box-value (known-procedure 6)] + [weak-box? (known-procedure 2)] + [will-execute (known-procedure 2)] + [will-executor? (known-procedure 2)] + [will-register (known-procedure 8)] + [will-try-execute (known-procedure 2)] + [with-input-from-file (known-procedure 12)] + [with-output-to-file (known-procedure 28)] + [wrap-evt (known-procedure 4)] + [write (known-procedure 6)] + [write-byte (known-procedure 6)] + [write-bytes (known-procedure 30)] + [write-bytes-avail (known-procedure 30)] + [write-bytes-avail* (known-procedure 30)] + [write-bytes-avail-evt (known-procedure 30)] + [write-bytes-avail/enable-break (known-procedure 30)] + [write-char (known-procedure 6)] + [write-special (known-procedure 6)] + [write-special-avail* (known-procedure 6)] + [write-special-evt (known-procedure 4)] + [write-string (known-procedure 30)] + [zero? (known-procedure 2)]) diff --git a/racket/src/cs/primitive/linklet.ss b/racket/src/cs/primitive/linklet.ss new file mode 100644 index 0000000000..4a9f58ec05 --- /dev/null +++ b/racket/src/cs/primitive/linklet.ss @@ -0,0 +1,31 @@ + +(define-primitive-table linklet-table + [compile-linklet (known-procedure 62)] + [compiled-position->primitive (known-procedure 2)] + [eval-linklet (known-procedure 2)] + [hash->linklet-bundle (known-procedure 2)] + [hash->linklet-directory (known-procedure 2)] + [instance-data (known-procedure 2)] + [instance-name (known-procedure 2)] + [instance-set-variable-value! (known-procedure 24)] + [instance-unset-variable! (known-procedure 4)] + [instance-variable-names (known-procedure 2)] + [instance-variable-value (known-procedure 12)] + [instance? (known-procedure 2)] + [instantiate-linklet (known-procedure 28)] + [linklet-bundle->hash (known-procedure 2)] + [linklet-bundle? (known-procedure 2)] + [linklet-directory->hash (known-procedure 2)] + [linklet-directory? (known-procedure 2)] + [linklet-export-variables (known-procedure 2)] + [linklet-import-variables (known-procedure 2)] + [linklet? (known-procedure 2)] + [make-instance (known-procedure -2)] + [primitive->compiled-position (known-procedure 2)] + [primitive-table (known-procedure 6)] + [read-compiled-linklet (known-procedure 2)] + [recompile-linklet (known-procedure 30)] + [variable-reference->instance (known-procedure 6)] + [variable-reference-constant? (known-procedure 2)] + [variable-reference-from-unsafe? (known-procedure 2)] + [variable-reference? (known-procedure 2)]) diff --git a/racket/src/cs/primitive/network.ss b/racket/src/cs/primitive/network.ss new file mode 100644 index 0000000000..021e817e45 --- /dev/null +++ b/racket/src/cs/primitive/network.ss @@ -0,0 +1,43 @@ + +(define-primitive-table network-table + [tcp-abandon-port (known-procedure 2)] + [tcp-accept (known-procedure 2)] + [tcp-accept-evt (known-procedure 2)] + [tcp-accept-ready? (known-procedure 2)] + [tcp-accept/enable-break (known-procedure 2)] + [tcp-addresses (known-procedure 6)] + [tcp-close (known-procedure 2)] + [tcp-connect (known-procedure 28)] + [tcp-connect/enable-break (known-procedure 28)] + [tcp-listen (known-procedure 30)] + [tcp-listener? (known-procedure 2)] + [tcp-port? (known-procedure 2)] + [udp-bind! (known-procedure 24)] + [udp-bound? (known-procedure 2)] + [udp-close (known-procedure 2)] + [udp-connect! (known-procedure 8)] + [udp-connected? (known-procedure 2)] + [udp-multicast-interface (known-procedure 2)] + [udp-multicast-join-group! (known-procedure 8)] + [udp-multicast-leave-group! (known-procedure 8)] + [udp-multicast-loopback? (known-procedure 2)] + [udp-multicast-set-interface! (known-procedure 4)] + [udp-multicast-set-loopback! (known-procedure 4)] + [udp-multicast-set-ttl! (known-procedure 4)] + [udp-multicast-ttl (known-procedure 2)] + [udp-open-socket (known-procedure 7)] + [udp-receive! (known-procedure 28)] + [udp-receive!* (known-procedure 28)] + [udp-receive!-evt (known-procedure 28)] + [udp-receive!/enable-break (known-procedure 28)] + [udp-receive-ready-evt (known-procedure 2)] + [udp-send (known-procedure 28)] + [udp-send* (known-procedure 28)] + [udp-send-evt (known-procedure 28)] + [udp-send-ready-evt (known-procedure 2)] + [udp-send-to (known-procedure 112)] + [udp-send-to* (known-procedure 112)] + [udp-send-to-evt (known-procedure 112)] + [udp-send-to/enable-break (known-procedure 112)] + [udp-send/enable-break (known-procedure 28)] + [udp? (known-procedure 2)]) diff --git a/racket/src/cs/primitive/paramz.ss b/racket/src/cs/primitive/paramz.ss new file mode 100644 index 0000000000..012f632745 --- /dev/null +++ b/racket/src/cs/primitive/paramz.ss @@ -0,0 +1,12 @@ + +(define-primitive-table paramz-table + [break-enabled-key (known-constant)] + [cache-configuration (known-procedure 4)] + [check-for-break (known-procedure 1)] + [exception-handler-key (known-constant)] + [extend-parameterization (known-procedure -2)] + [parameterization-key (known-constant)] + [reparameterize (known-procedure 2)] + [security-guard-check-file (known-procedure 8)] + [security-guard-check-file-link (known-procedure 8)] + [security-guard-check-network (known-procedure 16)]) diff --git a/racket/src/cs/primitive/place.ss b/racket/src/cs/primitive/place.ss new file mode 100644 index 0000000000..bf23f98eb4 --- /dev/null +++ b/racket/src/cs/primitive/place.ss @@ -0,0 +1,17 @@ + +(define-primitive-table place-table + [dynamic-place (known-procedure 32)] + [place-break (known-procedure 6)] + [place-channel (known-procedure 1)] + [place-channel-get (known-procedure 2)] + [place-channel-put (known-procedure 4)] + [place-channel? (known-procedure 2)] + [place-dead-evt (known-procedure 2)] + [place-enabled? (known-procedure 1)] + [place-kill (known-procedure 2)] + [place-message-allowed? (known-procedure 2)] + [place-pumper-threads (known-procedure 6)] + [place-shared? (known-procedure 2)] + [place-sleep (known-procedure 2)] + [place-wait (known-procedure 2)] + [place? (known-procedure 2)]) diff --git a/racket/src/cs/primitive/unsafe.ss b/racket/src/cs/primitive/unsafe.ss new file mode 100644 index 0000000000..7b1ea29b71 --- /dev/null +++ b/racket/src/cs/primitive/unsafe.ss @@ -0,0 +1,163 @@ + +(define-primitive-table unsafe-table + [chaperone-struct-unsafe-undefined (known-procedure 2)] + [check-not-unsafe-undefined (known-procedure 4)] + [check-not-unsafe-undefined/assign (known-procedure 4)] + [prop:chaperone-unsafe-undefined (known-constant)] + [unsafe-abort-current-continuation/no-wind (known-procedure 4)] + [unsafe-box*-cas! (known-procedure 8)] + [unsafe-bytes-length (known-procedure/succeeds 2)] + [unsafe-bytes-ref (known-procedure 4)] + [unsafe-bytes-set! (known-procedure 8)] + [unsafe-call-in-os-thread (known-procedure 2)] + [unsafe-call-with-composable-continuation/no-wind (known-procedure 4)] + [unsafe-car (known-procedure/succeeds 2)] + [unsafe-cdr (known-procedure/succeeds 2)] + [unsafe-chaperone-procedure (known-procedure -4)] + [unsafe-chaperone-vector (known-procedure -4)] + [unsafe-cons-list (known-procedure/succeeds 4)] + [unsafe-custodian-register (known-procedure 32)] + [unsafe-custodian-unregister (known-procedure 4)] + [unsafe-end-atomic (known-procedure 1)] + [unsafe-end-breakable-atomic (known-procedure 1)] + [unsafe-extfl* (known-procedure/succeeds 4)] + [unsafe-extfl+ (known-procedure/succeeds 4)] + [unsafe-extfl- (known-procedure/succeeds 4)] + [unsafe-extfl->fx (known-procedure/succeeds 2)] + [unsafe-extfl/ (known-procedure/succeeds 4)] + [unsafe-extfl< (known-procedure/succeeds 4)] + [unsafe-extfl<= (known-procedure/succeeds 4)] + [unsafe-extfl= (known-procedure/succeeds 4)] + [unsafe-extfl> (known-procedure/succeeds 4)] + [unsafe-extfl>= (known-procedure/succeeds 4)] + [unsafe-extflabs (known-procedure/succeeds 2)] + [unsafe-extflmax (known-procedure/succeeds 4)] + [unsafe-extflmin (known-procedure/succeeds 4)] + [unsafe-extflsqrt (known-procedure/succeeds 2)] + [unsafe-extflvector-length (known-procedure/succeeds 2)] + [unsafe-extflvector-ref (known-procedure 4)] + [unsafe-extflvector-set! (known-procedure 8)] + [unsafe-f64vector-ref (known-procedure 4)] + [unsafe-f64vector-set! (known-procedure 8)] + [unsafe-f80vector-ref (known-procedure 4)] + [unsafe-f80vector-set! (known-procedure 8)] + [unsafe-file-descriptor->port (known-procedure 8)] + [unsafe-file-descriptor->semaphore (known-procedure 4)] + [unsafe-fl* (known-procedure/succeeds 4)] + [unsafe-fl+ (known-procedure/succeeds 4)] + [unsafe-fl- (known-procedure/succeeds 4)] + [unsafe-fl->fx (known-procedure/succeeds 2)] + [unsafe-fl/ (known-procedure/succeeds 4)] + [unsafe-fl< (known-procedure/succeeds 4)] + [unsafe-fl<= (known-procedure/succeeds 4)] + [unsafe-fl= (known-procedure/succeeds 4)] + [unsafe-fl> (known-procedure/succeeds 4)] + [unsafe-fl>= (known-procedure/succeeds 4)] + [unsafe-flabs (known-procedure/succeeds 2)] + [unsafe-flimag-part (known-procedure/succeeds 2)] + [unsafe-flmax (known-procedure/succeeds 4)] + [unsafe-flmin (known-procedure/succeeds 4)] + [unsafe-flrandom (known-procedure/succeeds 2)] + [unsafe-flreal-part (known-procedure/succeeds 2)] + [unsafe-flsqrt (known-procedure/succeeds 2)] + [unsafe-flvector-length (known-procedure/succeeds 2)] + [unsafe-flvector-ref (known-procedure 4)] + [unsafe-flvector-set! (known-procedure 8)] + [unsafe-fx* (known-procedure/succeeds 4)] + [unsafe-fx+ (known-procedure/succeeds 4)] + [unsafe-fx- (known-procedure/succeeds 4)] + [unsafe-fx->extfl (known-procedure/succeeds 2)] + [unsafe-fx->fl (known-procedure/succeeds 2)] + [unsafe-fx< (known-procedure/succeeds 4)] + [unsafe-fx<= (known-procedure/succeeds 4)] + [unsafe-fx= (known-procedure/succeeds 4)] + [unsafe-fx> (known-procedure/succeeds 4)] + [unsafe-fx>= (known-procedure/succeeds 4)] + [unsafe-fxabs (known-procedure/succeeds 2)] + [unsafe-fxand (known-procedure/succeeds 4)] + [unsafe-fxior (known-procedure/succeeds 4)] + [unsafe-fxlshift (known-procedure/succeeds 4)] + [unsafe-fxmax (known-procedure/succeeds 4)] + [unsafe-fxmin (known-procedure/succeeds 4)] + [unsafe-fxmodulo (known-procedure/succeeds 4)] + [unsafe-fxnot (known-procedure/succeeds 2)] + [unsafe-fxquotient (known-procedure/succeeds 4)] + [unsafe-fxremainder (known-procedure/succeeds 4)] + [unsafe-fxrshift (known-procedure/succeeds 4)] + [unsafe-fxvector-length (known-procedure/succeeds 2)] + [unsafe-fxvector-ref (known-procedure 4)] + [unsafe-fxvector-set! (known-procedure 8)] + [unsafe-fxxor (known-procedure/succeeds 4)] + [unsafe-get-place-table (known-procedure 1)] + [unsafe-immutable-hash-iterate-first (known-procedure/succeeds 2)] + [unsafe-immutable-hash-iterate-key (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-key+value (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-next (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-pair (known-procedure/succeeds 4)] + [unsafe-immutable-hash-iterate-value (known-procedure/succeeds 4)] + [unsafe-impersonate-procedure (known-procedure -4)] + [unsafe-impersonate-vector (known-procedure -4)] + [unsafe-in-atomic? (known-procedure 1)] + [unsafe-list-ref (known-procedure/succeeds 4)] + [unsafe-list-tail (known-procedure/succeeds 4)] + [unsafe-make-custodian-at-root (known-procedure 1)] + [unsafe-make-flrectangular (known-procedure/succeeds 4)] + [unsafe-make-os-semaphore (known-procedure 1)] + [unsafe-make-security-guard-at-root (known-procedure 15)] + [unsafe-mcar (known-procedure 2)] + [unsafe-mcdr (known-procedure 2)] + [unsafe-mutable-hash-iterate-first (known-procedure 2)] + [unsafe-mutable-hash-iterate-key (known-procedure 4)] + [unsafe-mutable-hash-iterate-key+value (known-procedure 4)] + [unsafe-mutable-hash-iterate-next (known-procedure 4)] + [unsafe-mutable-hash-iterate-pair (known-procedure 4)] + [unsafe-mutable-hash-iterate-value (known-procedure 4)] + [unsafe-os-semaphore-post (known-procedure 2)] + [unsafe-os-semaphore-wait (known-procedure 2)] + [unsafe-os-thread-enabled? (known-procedure 1)] + [unsafe-poll-ctx-eventmask-wakeup (known-procedure 4)] + [unsafe-poll-ctx-fd-wakeup (known-procedure 8)] + [unsafe-poll-ctx-milliseconds-wakeup (known-procedure 4)] + [unsafe-poller (known-constant)] + [unsafe-port->file-descriptor (known-procedure 2)] + [unsafe-port->socket (known-procedure 2)] + [unsafe-register-process-global (known-procedure 4)] + [unsafe-s16vector-ref (known-procedure 4)] + [unsafe-s16vector-set! (known-procedure 8)] + [unsafe-set-box! (known-procedure 4)] + [unsafe-set-box*! (known-procedure 4)] + [unsafe-set-mcar! (known-procedure 4)] + [unsafe-set-mcdr! (known-procedure 4)] + [unsafe-set-on-atomic-timeout! (known-procedure 2)] + [unsafe-set-sleep-in-thread! (known-procedure 4)] + [unsafe-signal-received (known-procedure 1)] + [unsafe-socket->port (known-procedure 8)] + [unsafe-socket->semaphore (known-procedure 4)] + [unsafe-start-atomic (known-procedure 1)] + [unsafe-start-breakable-atomic (known-procedure 1)] + [unsafe-string-length (known-procedure/succeeds 2)] + [unsafe-string-ref (known-procedure/succeeds 4)] + [unsafe-string-set! (known-procedure/succeeds 8)] + [unsafe-struct*-ref (known-procedure/succeeds 4)] + [unsafe-struct*-set! (known-procedure/succeeds 8)] + [unsafe-struct-ref (known-procedure/succeeds 4)] + [unsafe-struct-set! (known-procedure/succeeds 8)] + [unsafe-thread-at-root (known-procedure 2)] + [unsafe-u16vector-ref (known-procedure 4)] + [unsafe-u16vector-set! (known-procedure 8)] + [unsafe-unbox (known-procedure 2)] + [unsafe-unbox* (known-procedure 2)] + [unsafe-undefined (known-constant)] + [unsafe-vector*-cas! (known-procedure 16)] + [unsafe-vector*-length (known-procedure/succeeds 2)] + [unsafe-vector*-ref (known-procedure 4)] + [unsafe-vector*-set! (known-procedure 8)] + [unsafe-vector-length (known-procedure/succeeds 2)] + [unsafe-vector-ref (known-procedure 4)] + [unsafe-vector-set! (known-procedure 8)] + [unsafe-weak-hash-iterate-first (known-procedure 2)] + [unsafe-weak-hash-iterate-key (known-procedure 4)] + [unsafe-weak-hash-iterate-key+value (known-procedure 4)] + [unsafe-weak-hash-iterate-next (known-procedure 4)] + [unsafe-weak-hash-iterate-pair (known-procedure 4)] + [unsafe-weak-hash-iterate-value (known-procedure 4)]) diff --git a/racket/src/cs/regexp.sls b/racket/src/cs/regexp.sls new file mode 100644 index 0000000000..2b502f640b --- /dev/null +++ b/racket/src/cs/regexp.sls @@ -0,0 +1,8 @@ +(library (regexp) + (export) + (import (chezpart) + (rumble) + (io)) + (include "include.ss") + (include-generated "regexp.scm") + (set-intern-regexp?! 1/regexp?)) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls new file mode 100644 index 0000000000..3cd8231609 --- /dev/null +++ b/racket/src/cs/rumble.sls @@ -0,0 +1,738 @@ +(library (rumble) + (export version + banner + + null eof void void? + + begin0 + + dynamic-wind + call-with-current-continuation + call-with-composable-continuation + call-with-escape-continuation + continuation? + + make-continuation-prompt-tag + continuation-prompt-tag? + default-continuation-prompt-tag + root-continuation-prompt-tag + call-with-continuation-prompt + call-with-continuation-barrier + abort-current-continuation + continuation-prompt-available? + impersonate-prompt-tag + chaperone-prompt-tag + (rename [break-enabled-key rumble:break-enabled-key]) + set-break-enabled-transition-hook! ; not exported to Racket + unsafe-abort-current-continuation/no-wind + unsafe-call-with-composable-continuation/no-wind + + with-continuation-mark + call/cm ; not exported to Racket + call-with-immediate-continuation-mark + continuation-mark-set-first + continuation-mark-set->list + continuation-mark-set->list* + continuation-mark-set->context + current-continuation-marks + (rename [continuation-marks rumble:continuation-marks]) ; wrapped at threads layer + continuation-mark-set? + make-continuation-mark-key + continuation-mark-key? + impersonate-continuation-mark-key + chaperone-continuation-mark-key + call-with-system-wind ; not exported to Racket + + make-engine + engine-block + engine-return + current-engine-state ; not exported to Racket + set-ctl-c-handler! ; not exported to Racket + get-ctl-c-handler ; not exported to Racket + set-scheduler-lock-callbacks! ; not exported to Racket + set-scheduler-atomicity-callbacks! ; not exported to Racket + set-engine-exit-handler! ; not exported to Racket + + make-thread-cell + thread-cell? + thread-cell-ref + thread-cell-set! + current-preserved-thread-cell-values + thread-cell-values? + + parameterization-key + make-parameter + make-derived-parameter + parameter? + extend-parameterization + parameterization? + parameter-procedure=? + reparameterize + + raise + error-print-width + error-value->string-handler + error-print-context-length + exception-handler-key + uncaught-exception-handler + error-display-handler + error-escape-handler + register-linklet-instantiate-continuation! ; not exported to Racket + set-error-display-eprintf! ; not exported to Racket + set-log-system-message! ; not exported to Racket + + current-inspector + make-inspector + make-sibling-inspector + current-code-inspector + + struct:exn exn exn? exn-message exn-continuation-marks + struct:exn:break exn:break exn:break? exn:break-continuation + struct:exn:break:hang-up exn:break:hang-up exn:break:hang-up? + struct:exn:break:terminate exn:break:terminate exn:break:terminate? + struct:exn:fail exn:fail exn:fail? + struct:exn:fail:contract exn:fail:contract exn:fail:contract? + struct:exn:fail:contract:arity exn:fail:contract:arity exn:fail:contract:arity? + struct:exn:fail:contract:divide-by-zero exn:fail:contract:divide-by-zero exn:fail:contract:divide-by-zero? + struct:exn:fail:contract:non-fixnum-result exn:fail:contract:non-fixnum-result exn:fail:contract:non-fixnum-result? + struct:exn:fail:contract:continuation exn:fail:contract:continuation exn:fail:contract:continuation? + struct:exn:fail:contract:variable exn:fail:contract:variable exn:fail:contract:variable? exn:fail:contract:variable-id + struct:exn:fail:read exn:fail:read exn:fail:read? exn:fail:read-srclocs + struct:exn:fail:read:eof exn:fail:read:eof exn:fail:read:eof? + struct:exn:fail:read:non-char exn:fail:read:non-char exn:fail:read:non-char? + struct:exn:fail:filesystem exn:fail:filesystem exn:fail:filesystem? + struct:exn:fail:filesystem:exists exn:fail:filesystem:exists exn:fail:filesystem:exists? + struct:exn:fail:filesystem:version exn:fail:filesystem:version exn:fail:filesystem:version? + struct:exn:fail:filesystem:errno exn:fail:filesystem:errno exn:fail:filesystem:errno? exn:fail:filesystem:errno-errno + struct:exn:fail:network exn:fail:network exn:fail:network? + struct:exn:fail:network:errno exn:fail:network:errno exn:fail:network:errno? exn:fail:network:errno-errno + struct:exn:fail:out-of-memory exn:fail:out-of-memory exn:fail:out-of-memory? + struct:exn:fail:unsupported exn:fail:unsupported exn:fail:unsupported? + struct:exn:fail:user exn:fail:user exn:fail:user? + + struct:srcloc srcloc srcloc? + srcloc-source srcloc-line srcloc-column srcloc-position srcloc-span + prop:exn:srclocs exn:srclocs? exn:srclocs-accessor + + struct:date date? date make-date + date-second date-minute date-hour date-day date-month date-year + date-week-day date-year-day date-dst? date-time-zone-offset + + struct:date* date*? date* make-date* + date*-nanosecond date*-time-zone-name + + struct:arity-at-least arity-at-least arity-at-least? + arity-at-least-value + + prop:procedure + prop:incomplete-arity + prop:method-arity-error + prop:arity-string + apply + procedure? + procedure-specialize + |#%app| + |#%call-with-values| + extract-procedure ; not exported to Racket + procedure-arity-includes? + procedure-arity + procedure-result-arity + procedure-extract-target + procedure-closure-contents-eq? + procedure-reduce-arity + procedure-rename + procedure->method + procedure-arity? + prop:checked-procedure + checked-procedure-check-and-extract + primitive? + primitive-closure? + primitive-result-arity + make-jit-procedure ; not exported to racket + + equal? + equal?/recur + + impersonator? + chaperone? + impersonator-of? + chaperone-of? + impersonator-val ; not exported to Racket + impersonate-ref ; not exported to Racket + impersonate-set! ; not exported to Racket + impersonator-property? + make-impersonator-property + impersonator-property-accessor-procedure? + impersonator-ephemeron + prop:impersonator-of + + impersonate-procedure + chaperone-procedure + impersonate-procedure* + chaperone-procedure* + procedure-impersonator*? + impersonator-prop:application-mark + unsafe-impersonate-procedure + unsafe-chaperone-procedure + + raise-argument-error + raise-arguments-error + raise-result-error + raise-mismatch-error + raise-range-error + raise-arity-error + raise-type-error + raise-binding-result-arity-error ; not exported to Racket + + (rename [make-unquoted-printing-string unquoted-printing-string]) + unquoted-printing-string? + unquoted-printing-string-value + + make-struct-type-property + struct-type-property? + struct-type-property-accessor-procedure? + make-struct-type + struct-type-install-properties! ; not exported to Racket + structure-type-lookup-prefab-uid ; not exported to Racket + make-struct-field-accessor + make-struct-field-mutator + struct-type-constructor-add-guards ; not exported to Racket + register-struct-constructor! ; not exported to Racket + register-struct-predicate! ; not exported to Racket + register-struct-field-accessor! ; not exported to Racket + register-struct-field-mutator! ; not exported to Racket + struct-property-set! ; not exported to Racket + struct-constructor-procedure? + struct-predicate-procedure? + struct-accessor-procedure? + struct-mutator-procedure? + struct? + struct-type? + procedure-struct-type? + struct-type-info + struct-info + struct-type-make-constructor + struct-type-make-predicate + struct->vector + prefab-key? + prefab-struct-key + prefab-key->struct-type + make-prefab-struct + prop:authentic + prop:equal+hash + inspector? + inspector-superior? + impersonate-struct + chaperone-struct + chaperone-struct-unsafe-undefined + prop:chaperone-unsafe-undefined + chaperone-struct-type + + prop:object-name + object-name + + eq-hash-code + eqv-hash-code + equal-hash-code + equal-secondary-hash-code + + hash hasheqv hasheq + make-hash make-hasheqv make-hasheq + make-immutable-hash make-immutable-hasheqv make-immutable-hasheq + make-weak-hash make-weak-hasheq make-weak-hasheqv + hash-ref hash-set hash-set! hash-remove hash-remove! + hash-for-each hash-map hash-copy hash-clear hash-clear! + hash-iterate-first hash-iterate-next + hash-iterate-key hash-iterate-value + hash-iterate-key+value hash-iterate-pair + unsafe-immutable-hash-iterate-first unsafe-immutable-hash-iterate-next + unsafe-immutable-hash-iterate-key unsafe-immutable-hash-iterate-value + unsafe-immutable-hash-iterate-key+value unsafe-immutable-hash-iterate-pair + unsafe-mutable-hash-iterate-first unsafe-mutable-hash-iterate-next + unsafe-mutable-hash-iterate-key unsafe-mutable-hash-iterate-value + unsafe-mutable-hash-iterate-key+value unsafe-mutable-hash-iterate-pair + unsafe-weak-hash-iterate-first unsafe-weak-hash-iterate-next + unsafe-weak-hash-iterate-key unsafe-weak-hash-iterate-value + unsafe-weak-hash-iterate-key+value unsafe-weak-hash-iterate-pair + + hash? hash-eq? hash-equal? hash-eqv? hash-weak? immutable-hash? + hash-count + hash-keys-subset? + + datum-intern-literal + set-intern-regexp?! ; not exported to racket + + impersonate-hash + chaperone-hash + + true-object? + + bytes shared-bytes + bytes? + bytes-length + make-bytes make-shared-bytes + bytes-ref bytes-set! + bytes->list list->bytes + bytes->immutable-bytes + bytes-copy! bytes-copy bytes-fill! + bytes=? bytes? bytes<=? bytes>=? + bytes-append + subbytes + + string-copy! + substring + + char-blank? + char-iso-control? + char-punctuation? + char-graphic? + char-symbolic? + interned-char? + make-known-char-range-list + char-general-category + + gensym + symbol-interned? + symbol-unreadable? + string->uninterned-symbol + string->unreadable-symbol + symbol->string + + list? + list-pair? + (rename [|#%map| map] + [|#%for-each| for-each] + [|#%andmap| andmap] + [|#%ormap| ormap]) + + vector? + mutable-vector? + (rename [inline:vector-length vector-length] + [inline:vector-ref vector-ref] + [inline:vector-set! vector-set!]) + vector-copy + vector-copy! + vector-immutable + vector->values + vector-fill! + vector->immutable-vector + vector->list + vector*-length + vector*-ref + vector*-set! + + impersonate-vector + impersonate-vector* + chaperone-vector + chaperone-vector* + unsafe-impersonate-vector + unsafe-chaperone-vector + + box? + (rename [inline:unbox unbox] + [inline:set-box! set-box!]) + unbox* set-box*! + make-weak-box weak-box? weak-box-value + impersonate-box + chaperone-box + unbox/check-undefined ; not exported to Racket + set-box!/check-undefined ; not exported to Racket + + immutable? + + keyword? + keyword->string + string->keyword + keyworddouble-flonum + real->single-flonum + arithmetic-shift + integer-sqrt + integer-sqrt/remainder + integer->integer-bytes + integer-bytes->integer + real->floating-point-bytes + floating-point-bytes->real + system-big-endian? + string->number + number->string + quotient/remainder + fx->fl + fxrshift + fxlshift + fl->fx + ->fl + fl->exact-integer + flreal-part + flimag-part + make-flrectangular + gcd + lcm + + random + random-seed + pseudo-random-generator? + make-pseudo-random-generator + current-pseudo-random-generator + vector->pseudo-random-generator + vector->pseudo-random-generator! + pseudo-random-generator->vector + pseudo-random-generator-vector? + + mpair? + mcons + (rename [inline:mcar mcar] + [inline:mcdr mcdr] + [inline:set-mcar! set-mcar!] + [inline:set-mcdr! set-mcdr!]) + + flvector? + (rename [new-flvector flvector]) + make-flvector + flvector-length + flvector-ref + flvector-set! + flvector-copy + shared-flvector + make-shared-flvector + unsafe-flvector-length + unsafe-flvector-set! + unsafe-flvector-ref + + shared-fxvector + make-shared-fxvector + + correlated? + correlated-source + correlated-line + correlated-column + correlated-position + correlated-span + correlated-e + correlated->datum + datum->correlated + correlated-property + correlated-property-symbol-keys + + make-reader-graph + make-placeholder + placeholder? + placeholder-set! + placeholder-get + hash-placeholder? + make-hash-placeholder + make-hasheq-placeholder + make-hasheqv-placeholder + + time-apply + current-inexact-milliseconds + current-milliseconds + current-gc-milliseconds + current-seconds + seconds->date + + collect-garbage + current-memory-use + dump-memory-stats + phantom-bytes? + make-phantom-bytes + set-phantom-bytes! + set-garbage-collect-notify! ; not exported to Racket + + ;; not the same as Racket will executors: + (rename + [make-will-executor rumble:make-will-executor] + [make-stubborn-will-executor rumble:make-stubborn-will-executor] + [will-executor? rumble:will-executor?] + [will-register rumble:will-register] + [will-try-execute rumble:will-try-execute]) + poll-will-executors ; not exported to Racket + + make-ephemeron + ephemeron? + ephemeron-value + + system-type + system-path-convention-type + system-library-subpath-string ; not exported to Racket + + unsafe-car + unsafe-cdr + unsafe-list-tail + unsafe-list-ref + unsafe-cons-list + + unsafe-fx+ + unsafe-fx- + unsafe-fx* + unsafe-fxquotient + unsafe-fxremainder + unsafe-fxmodulo + unsafe-fxabs + unsafe-fxand + unsafe-fxior + unsafe-fxxor + unsafe-fxnot + unsafe-fxrshift + unsafe-fxlshift + + unsafe-fx= + unsafe-fx< + unsafe-fx> + unsafe-fx>= + unsafe-fx<= + unsafe-fxmin + unsafe-fxmax + + unsafe-fl+ + unsafe-fl- + unsafe-fl* + unsafe-fl/ + unsafe-flabs + + unsafe-fl= + unsafe-fl< + unsafe-fl> + unsafe-fl>= + unsafe-fl<= + unsafe-flmin + unsafe-flmax + + unsafe-fl->fx + unsafe-fx->fl + + unsafe-make-flrectangular + unsafe-flreal-part + unsafe-flimag-part + + unsafe-flround + unsafe-flfloor + unsafe-flceiling + unsafe-fltruncate + + unsafe-flsin + unsafe-flcos + unsafe-fltan + unsafe-flasin + unsafe-flacos + unsafe-flatan + unsafe-fllog + unsafe-flexp + unsafe-flsqrt + unsafe-flexpt + + unsafe-flrandom + + extfl* extfl+ extfl- ->extfl + extfl->exact extfl->exact-integer + extfl->floating-point-bytes extfl->fx + extfl->inexact + extfl/ extfl< extfl<= extfl= extfl> extfl>= + extflabs extflacos extflasin extflatan extflceiling + extflcos extflexp extflexpt floating-point-bytes->extfl + extflfloor fx->extfl extfllog make-shared-extflvector + make-extflvector extflmax extflmin extflonum-available? + extflonum? real->extfl extflround shared-extflvector + extflsin extflsqrt extfltan extfltruncate extflvector + extflvector-length extflvector-ref extflvector-set! extflvector? + + unsafe-extfl* unsafe-extfl+ unsafe-extfl- unsafe-extfl/ + unsafe-extfl< unsafe-extfl<= unsafe-extfl= unsafe-extfl> unsafe-extfl>= + unsafe-extflabs unsafe-extflmax unsafe-extflmin + unsafe-extfl->fx unsafe-fx->extfl unsafe-extflsqrt + unsafe-extflvector-length unsafe-extflvector-ref unsafe-extflvector-set! + + place-enabled? place? place-channel? place-break + place-channel-get place-channel-put place-sleep + place-channel place-dead-evt place-kill place-message-allowed? + dynamic-place place-wait place-pumper-threads place-shared? + unsafe-get-place-table + + _bool _bytes _short_bytes _double _double* _fixint _fixnum _float _fpointer _gcpointer + _int16 _int32 _int64 _int8 _longdouble _pointer _scheme _stdbool _void + _string/ucs-4 _string/utf-16 _symbol _ufixint _ufixnum _uint16 _uint32 _uint64 _uint8 + compiler-sizeof cpointer-gcable? cpointer-tag cpointer? + ctype-alignof ctype-basetype ctype-c->scheme ctype-scheme->c ctype-sizeof ctype? + end-stubborn-change extflvector->cpointer + ffi-call ffi-call-maker ffi-callback ffi-callback-maker ffi-callback? + ffi-lib-name ffi-lib? ffi-obj ffi-obj-lib + ffi-obj-name ffi-obj? flvector->cpointer free free-immobile-cell lookup-errno + make-array-type make-cstruct-type make-ctype make-late-weak-box make-late-weak-hasheq + make-sized-byte-string make-union-type malloc malloc-immobile-cell + memcpy memmove memset offset-ptr? prop:cpointer ptr-add ptr-add! ptr-equal? ptr-offset ptr-ref + ptr-set! saved-errno set-cpointer-tag! set-ptr-offset! vector->cpointer + unsafe-register-process-global + (rename [ffi-lib* ffi-lib]) + set-ffi-get-lib-and-obj! ; not exported to Racket + poll-async-callbacks ; not exported to Racket + set-async-callback-poll-wakeup! ; not exported to Racket + + unsafe-unbox + unsafe-unbox* + unsafe-set-box! + unsafe-set-box*! + unsafe-box*-cas! + + unsafe-mcar + unsafe-mcdr + unsafe-set-mcar! + unsafe-set-mcdr! + + unsafe-vector-ref + unsafe-vector-set! + unsafe-vector*-ref + unsafe-vector*-set! + unsafe-vector*-cas! + unsafe-vector-length + unsafe-vector*-length + + unsafe-fxvector-length + unsafe-fxvector-ref + unsafe-fxvector-set! + + unsafe-bytes-length + unsafe-bytes-ref + unsafe-bytes-set! + + unsafe-undefined + check-not-unsafe-undefined + check-not-unsafe-undefined/assign + + unsafe-string-length + unsafe-string-ref + unsafe-string-set! + + unsafe-struct-ref + unsafe-struct-set! + unsafe-struct*-ref + unsafe-struct*-set! + + unsafe-s16vector-ref + unsafe-s16vector-set! + unsafe-u16vector-ref + unsafe-u16vector-set! + unsafe-f64vector-ref + unsafe-f64vector-set! + unsafe-f80vector-set! + unsafe-f80vector-ref + + ;; --- not exported to Racket: --- + make-pthread-parameter + fork-pthread + pthread? + get-thread-id + make-condition + condition-wait + condition-signal + condition-broadcast + make-mutex + mutex-acquire + mutex-release + threaded? + set-future-callbacks!) + (import (rename (chezpart) + [define define/no-lift]) + (rename (only (chezscheme) sleep) + [sleep chez:sleep]) + (only (chezscheme) + thread? + threaded? + get-thread-id + format + fprintf + current-error-port + error + map for-each andmap ormap) + (only (chezscheme csv7) + record-field-accessor + record-field-mutator)) + + (define/no-lift none (chez:gensym "none")) + (define/no-lift none2 (chez:gensym "none2")) + + (include "rumble/define.ss") + (include "rumble/virtual-register.ss") + (include "rumble/version.ss") + (include "rumble/syntax-rule.ss") + (include "rumble/check.ss") + (include "rumble/constant.ss") + (include "rumble/hash-code.ss") + (include "rumble/symbol.ss") + (include "rumble/struct.ss") + (include "rumble/prefab.ss") + (include "rumble/impersonator.ss") + (include "rumble/equal.ss") + (include "rumble/number.ss") + (include "rumble/procedure.ss") + (include "rumble/object-name.ss") + (include "rumble/arity.ss") + (include "rumble/intmap.ss") + (include "rumble/hash.ss") + (include "rumble/datum.ss") + (include "rumble/thread-cell.ss") + (include "rumble/begin0.ss") + (include "rumble/pthread.ss") + (include "rumble/control.ss") + (include "rumble/interrupt.ss") + (include "rumble/parameter.ss") + (include "rumble/engine.ss") + (include "rumble/error.ss") + (include "rumble/srcloc.ss") + (include "rumble/boolean.ss") + (include "rumble/bytes.ss") + (include "rumble/string.ss") + (include "rumble/char.ss") + (include "rumble/list.ss") + (include "rumble/vector.ss") + (include "rumble/box.ss") + (include "rumble/immutable.ss") + (include "rumble/keyword.ss") + (include "rumble/mpair.ss") + (include "rumble/flvector.ss") + (include "rumble/correlated.ss") + (include "rumble/graph.ss") + (include "rumble/time.ss") + (include "rumble/random.ss") + (include "rumble/memory.ss") + (include "rumble/ephemeron.ss") + (include "rumble/will-executor.ss") + (include "rumble/system.ss") + (include "rumble/unsafe.ss") + (include "rumble/extfl.ss") + (include "rumble/lock.ss") + (include "rumble/place.ss") + (include "rumble/foreign.ss") + (include "rumble/future.ss") + (include "rumble/inline.ss") + + (define-virtual-registers-init init-virtual-registers) + (init-virtual-registers) + + (set-no-locate-source!) + ;; Note: if there's a bug in `rumble` that causes exception handling to error, + ;; the the following line will cause the error to loop with another error, etc., + ;; probably without printing anything: + (set-base-exception-handler!) + (register-as-place-main!) + (set-collect-handler!) + (set-primitive-applicables!) + (set-continuation-applicables!) + (set-impersonator-applicables!) + (set-mpair-hash!) + (set-hash-hash!) + (set-flvector-hash!) + (set-impersonator-hash!) + (set-procedure-impersonator-hash!) + (set-vector-impersonator-hash!) + (set-box-impersonator-hash!) + (set-cpointer-hash!)) diff --git a/racket/src/cs/rumble/arity.ss b/racket/src/cs/rumble/arity.ss new file mode 100644 index 0000000000..b5b27dc576 --- /dev/null +++ b/racket/src/cs/rumble/arity.ss @@ -0,0 +1,41 @@ + +(define (mask->arity mask) + (let loop ([mask mask] [pos 0]) + (cond + [(= mask 0) null] + [(= mask -1) (|#%app| arity-at-least pos)] + [(bitwise-bit-set? mask 0) + (let ([rest (loop (bitwise-arithmetic-shift-right mask 1) (add1 pos))]) + (cond + [(null? rest) pos] + [(pair? rest) (cons pos rest)] + [else (list pos rest)]))] + [else + (loop (bitwise-arithmetic-shift-right mask 1) (add1 pos))]))) + +(define (arity->mask a) + (cond + [(exact-nonnegative-integer? a) + (bitwise-arithmetic-shift-left 1 a)] + [(arity-at-least? a) + (bitwise-xor -1 (sub1 (bitwise-arithmetic-shift-left 1 (arity-at-least-value a))))] + [(list? a) + (let loop ([mask 0] [l a]) + (cond + [(null? l) mask] + [else + (let ([a (car l)]) + (cond + [(or (exact-nonnegative-integer? a) + (arity-at-least? a)) + (loop (bitwise-ior mask (arity->mask a)) (cdr l))] + [else #f]))]))] + [else #f])) + +(define (procedure-arity? a) + (and (arity->mask a) #t)) + +(define-struct arity-at-least (value) + :guard (lambda (value who) + (check who exact-nonnegative-integer? value) + value)) diff --git a/racket/src/cs/rumble/begin0.ss b/racket/src/cs/rumble/begin0.ss new file mode 100644 index 0000000000..70ddd190fe --- /dev/null +++ b/racket/src/cs/rumble/begin0.ss @@ -0,0 +1,16 @@ + +;; See copy in "expander.sls" +(define-syntax begin0 + (syntax-rules () + [(_ expr0 expr ...) + (call-with-values (lambda () + (call-with-values (lambda () expr0) + (case-lambda + [(x) (values x #f)] + [args (values args #t)]))) + (lambda (l apply?) + expr ... + (if apply? + (#%apply values l) + l)))])) + diff --git a/racket/src/cs/rumble/boolean.ss b/racket/src/cs/rumble/boolean.ss new file mode 100644 index 0000000000..5136f77ffc --- /dev/null +++ b/racket/src/cs/rumble/boolean.ss @@ -0,0 +1 @@ +(define (true-object? v) (eq? v #t)) diff --git a/racket/src/cs/rumble/box.ss b/racket/src/cs/rumble/box.ss new file mode 100644 index 0000000000..09014dc0e6 --- /dev/null +++ b/racket/src/cs/rumble/box.ss @@ -0,0 +1,146 @@ + +(define (unsafe-box*-cas+! b delta) + (let ([v (unsafe-unbox* b)]) + (unless (unsafe-box*-cas! b v (+ v delta)) + (unsafe-box*-cas+! b delta)))) + +;; ---------------------------------------- + +(define-record box-chaperone chaperone (ref set)) +(define-record box-impersonator impersonator (ref set)) + +(define (box? v) + (or (#%box? v) + (and (impersonator? v) + (#%box? (impersonator-val v))))) + +(define (unbox b) + (if (#%box? b) + (#3%unbox b) + (pariah (impersonate-unbox b)))) + +(define (unsafe-unbox b) + ;; must handle impersonators + (unbox b)) + +(define (unbox* b) + (#2%unbox b)) + +(define (set-box! b v) + (if (#%box? b) + (#3%set-box! b v) + (pariah (impersonate-set-box! b v)))) + +(define (unsafe-set-box! b v) + ;; must handle impersonators + (set-box! b v)) + +(define (set-box*! b v) + (#2%set-box! b v)) + +;; in schemified: +(define (unbox/check-undefined b name) + (check-not-unsafe-undefined (#3%unbox b) name)) + +;; in schemified: +(define (set-box!/check-undefined b v name) + (check-not-unsafe-undefined/assign (unbox b) name) + (#3%set-box! b v)) + +(define/who (chaperone-box b ref set . props) + (check who box? b) + (do-impersonate-box 'chaperone-box make-box-chaperone b ref set + make-props-chaperone props)) + +(define/who (impersonate-box b ref set . props) + (check who mutable-box? :contract "(and/c box? (not/c immutable?))" b) + (do-impersonate-box 'impersonate-box make-box-impersonator b ref set + make-props-chaperone props)) + +(define (do-impersonate-box who make-box-impersonator b ref set + make-props-impersonator props) + (check who (procedure-arity-includes/c 2) ref) + (check who (procedure-arity-includes/c 2) set) + (let ([val (if (impersonator? b) + (impersonator-val b) + b)] + [props (add-impersonator-properties who + props + (if (impersonator? b) + (impersonator-props b) + empty-hasheq))]) + (make-box-impersonator val b props ref set))) + +(define (impersonate-unbox orig) + (if (and (impersonator? orig) + (#%box? (impersonator-val orig))) + (let loop ([o orig]) + (cond + [(#%box? o) (#%unbox o)] + [(box-chaperone? o) + (let* ([val (loop (impersonator-next o))] + [new-val ((box-chaperone-ref o) o val)]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'unbox + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + new-val)] + [(box-impersonator? o) + (let ([val (loop (impersonator-next o))]) + ((box-impersonator-ref o) o val))] + [else (loop (impersonator-next o))])) + ;; Let primitive report the error: + (#2%unbox orig))) + +(define (impersonate-set-box! orig val) + (cond + [(not (and (impersonator? orig) + (mutable-box? (impersonator-val orig)))) + ;; Let primitive report the error: + (#2%set-box! orig val)] + [else + (let loop ([o orig] [val val]) + (cond + [(#%box? o) (#2%set-box! o val)] + [else + (let ([next (impersonator-next o)]) + (cond + [(box-chaperone? o) + (let ([new-val ((box-chaperone-set o) next val)]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'set-box! + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + (loop next val))] + [(box-impersonator? o) + (loop next ((box-impersonator-set o) next val))] + [else (loop next val)]))]))])) + +(define (set-box-impersonator-hash!) + (record-type-hash-procedure (record-type-descriptor box-chaperone) + (lambda (c hash-code) + (hash-code (box (unbox c))))) + (record-type-hash-procedure (record-type-descriptor box-impersonator) + (lambda (i hash-code) + (hash-code (box (unbox i)))))) + +;; ---------------------------------------- + +;; A wrapper to hide the pairness of weak pairs: +(define-record-type (weak-box create-weak-box weak-box?) + (fields p)) + +(define (make-weak-box v) + (create-weak-box (weak-cons v #t))) + +(define/who weak-box-value + (case-lambda + [(v no-value) + (check who weak-box? v) + (let ([c (car (weak-box-p v))]) + (if (eq? c #!bwp) + no-value + c))] + [(v) (weak-box-value v #f)])) diff --git a/racket/src/cs/rumble/bytes.ss b/racket/src/cs/rumble/bytes.ss new file mode 100644 index 0000000000..fa6cd08e27 --- /dev/null +++ b/racket/src/cs/rumble/bytes.ss @@ -0,0 +1,177 @@ +(define/who (bytes . args) + ;; `bytevector` allows negative numbers that fit in a byte, + ;; but `bytes` does not + (for-each (lambda (arg) + (check who byte? arg)) + args) + (apply #2%bytevector args)) + +(define/who (shared-bytes . args) + (for-each (lambda (arg) + (check who byte? arg)) + args) + (apply #2%bytevector args)) + +(define bytes? #2%bytevector?) + +(define bytes-length #2%bytevector-length) + +(define/who make-bytes + (case-lambda + [(n) (#2%make-bytevector n 0)] + [(n b) + (check who exact-nonnegative-integer? n) + (check who byte? b) + (#2%make-bytevector n b)])) + +(define/who make-shared-bytes + (case-lambda + [(n) (#2%make-bytevector n 0)] + [(n b) + (check who exact-nonnegative-integer? n) + (check who byte? b) + (#2%make-bytevector n b)])) + +(define/who (list->bytes lst) + (check who + :test (and (list? lst) (for-each byte? lst)) + :contract "(listof byte?)" + lst) + (u8-list->bytevector lst)) + +(define bytes->list #2%bytevector->u8-list) + +(define bytes-ref #2%bytevector-u8-ref) +(define bytes-set! #2%bytevector-u8-set!) +(define bytes->immutable-bytes #2%bytevector->immutable-bytevector) + +(define/who bytes-copy! + (case-lambda + [(dest d-start src) + (bytes-copy! dest d-start src 0 (bytes-length src))] + [(dest d-start src s-start) + (bytes-copy! dest d-start src s-start (bytes-length src))] + [(dest d-start src s-start s-end) + (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" dest) + (check who exact-nonnegative-integer? d-start) + (check who bytes? src) + (check who exact-nonnegative-integer? s-start) + (check who exact-nonnegative-integer? s-end) + (let ([d-len (bytevector-length dest)]) + (check-range who "byte string" dest d-start #f d-len) + (check-range who "byte string" src s-start s-end (bytevector-length src)) + (let ([s-len (fx- s-end s-start)]) + (check-space who "byte string" d-start d-len s-len) + (bytevector-copy! src s-start dest d-start s-len)))])) + +(define/who (bytes-fill! bstr b) + (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" bstr) + (check who byte? b) + (bytevector-fill! bstr b)) + +(define bytes-copy #2%bytevector-copy) + +(define-syntax-rule (define-bytes-compare name do-name) + (define/who name + (case-lambda + [(a b) + (check who bytes? a) + (check who bytes? b) + (do-name a b)] + [(a b . l) + (check who bytes? a) + (check who bytes? b) + (and (bytevector=? a b) + (let loop ([a b] [l l]) + (cond + [(null? l) #t] + [else (let ([b (car l)]) + (check who bytes? b) + (and (do-name a b) + (loop b (cdr l))))])))]))) + +(define-bytes-compare bytes=? bytevector=?) + +(define (do-bytes? a b) + (let ([alen (bytes-length a)] + [blen (bytes-length b)]) + (let loop ([i 0]) + (cond + [(= i alen) #f] + [(= i blen) #t] + [else + (let ([va (bytes-ref a i)] + [vb (bytes-ref b i)]) + (cond + [(fx> va vb) #t] + [(fx= va vb) (loop (fx1+ i))] + [else #f]))])))) + +(define (do-bytes>=? a b) (not (do-bytes? a b))) + +(define-bytes-compare bytes? do-bytes>?) +(define-bytes-compare bytes>=? do-bytes>=?) + +(define/who bytes-append + (case-lambda + [(a b) + (check who bytes? a) + (check who bytes? b) + (let ([alen (bytevector-length a)] + [blen (bytevector-length b)]) + (let ([c (make-bytevector (+ alen blen))]) + (bytevector-copy! a 0 c 0 alen) + (bytevector-copy! b 0 c alen blen) + c))] + [(a) + (check who bytes? a) + a] + [() #vu8()] + [args + (let* ([size (let loop ([args args]) + (cond + [(null? args) 0] + [else (+ (bytevector-length (car args)) + (loop (cdr args)))]))] + [c (make-bytevector size)]) + (let loop ([args args] [pos 0]) + (cond + [(null? args) c] + [else + (let ([len (bytevector-length (car args))]) + (bytevector-copy! (car args) 0 c pos len) + (loop (cdr args) (+ pos len)))])))])) + +(define/who subbytes + (case-lambda + [(bstr start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "byte string" bstr start end (bytevector-length bstr)) + (let* ([len (- end start)] + [c (make-bytevector len)]) + (bytevector-copy! bstr start c 0 len) + c)] + [(bstr start) + (subbytes bstr start (bytes-length bstr))])) diff --git a/racket/src/cs/rumble/char.ss b/racket/src/cs/rumble/char.ss new file mode 100644 index 0000000000..d15c08792c --- /dev/null +++ b/racket/src/cs/rumble/char.ss @@ -0,0 +1,642 @@ + +(define/who (char-blank? x) + (check who char? x) + (or (char=? x #\tab) + (eq? (#%char-general-category x) 'Zs))) + +(define/who (char-iso-control? x) + (check who char? x) + (or (char<=? #\nul x #\x1F) + (char<=? #\delete x #\x9F))) + +(define/who (char-punctuation? x) + (check who char? x) + (and (#%memq (#%char-general-category x) '(Pc Pd Ps Pe Pi Pf Po)) #t)) + +(define/who (char-graphic? x) + (check who char? x) + (or (char-numeric? x) + (char-alphabetic? x) + (and (#%memq (#%char-general-category x) '(Ll Lm Lo Lt Lu Nd Nl No Mn Mc Me + ;; char-symbolic?: + Sm Sc Sk So + ;; char-punctuation?: + Pc Pd Ps Pe Pi Pf Po)) + #t))) + +(define/who (char-symbolic? x) + (check who char? x) + (and (#%memq (#%char-general-category x) '(Sm Sc Sk So)) #t)) + +(define (interned-char? v) + (and (char? v) (< (char->integer v) 256))) + +(define (char-general-category ch) + (or (getprop (#%char-general-category ch) 'downcase #f) + (let* ([s (#%char-general-category ch)] + [ds (string->symbol (string-downcase (symbol->string s)))]) + (putprop s 'downcase ds) + ds))) + +;; FIXME +(define (make-known-char-range-list) + '((0 887 #f) + (890 895 #f) + (900 906 #f) + (908 908 #t) + (910 929 #f) + (931 1327 #f) + (1329 1366 #t) + (1369 1375 #f) + (1377 1415 #f) + (1417 1418 #f) + (1421 1423 #f) + (1425 1479 #f) + (1488 1514 #t) + (1520 1524 #f) + (1536 1564 #f) + (1566 1805 #f) + (1807 1866 #f) + (1869 1969 #f) + (1984 2042 #f) + (2048 2093 #f) + (2096 2110 #t) + (2112 2139 #f) + (2142 2142 #t) + (2208 2226 #t) + (2276 2435 #f) + (2437 2444 #t) + (2447 2448 #t) + (2451 2472 #t) + (2474 2480 #t) + (2482 2482 #t) + (2486 2489 #t) + (2492 2500 #f) + (2503 2504 #t) + (2507 2510 #f) + (2519 2519 #t) + (2524 2525 #t) + (2527 2531 #f) + (2534 2555 #f) + (2561 2563 #f) + (2565 2570 #t) + (2575 2576 #t) + (2579 2600 #t) + (2602 2608 #t) + (2610 2611 #f) + (2613 2614 #f) + (2616 2617 #t) + (2620 2620 #t) + (2622 2626 #f) + (2631 2632 #t) + (2635 2637 #f) + (2641 2641 #t) + (2649 2652 #f) + (2654 2654 #t) + (2662 2677 #f) + (2689 2691 #f) + (2693 2701 #t) + (2703 2705 #t) + (2707 2728 #t) + (2730 2736 #t) + (2738 2739 #t) + (2741 2745 #t) + (2748 2757 #f) + (2759 2761 #f) + (2763 2765 #f) + (2768 2768 #t) + (2784 2787 #f) + (2790 2801 #f) + (2817 2819 #f) + (2821 2828 #t) + (2831 2832 #t) + (2835 2856 #t) + (2858 2864 #t) + (2866 2867 #t) + (2869 2873 #t) + (2876 2884 #f) + (2887 2888 #f) + (2891 2893 #f) + (2902 2903 #f) + (2908 2909 #t) + (2911 2915 #f) + (2918 2935 #f) + (2946 2947 #f) + (2949 2954 #t) + (2958 2960 #t) + (2962 2965 #f) + (2969 2970 #t) + (2972 2972 #t) + (2974 2975 #t) + (2979 2980 #t) + (2984 2986 #t) + (2990 3001 #t) + (3006 3010 #f) + (3014 3016 #t) + (3018 3021 #f) + (3024 3024 #t) + (3031 3031 #t) + (3046 3066 #f) + (3072 3075 #f) + (3077 3084 #t) + (3086 3088 #t) + (3090 3112 #t) + (3114 3129 #t) + (3133 3140 #f) + (3142 3144 #f) + (3146 3149 #f) + (3157 3158 #f) + (3160 3161 #t) + (3168 3171 #f) + (3174 3183 #t) + (3192 3199 #f) + (3201 3203 #f) + (3205 3212 #t) + (3214 3216 #t) + (3218 3240 #t) + (3242 3251 #t) + (3253 3257 #t) + (3260 3268 #f) + (3270 3272 #f) + (3274 3277 #f) + (3285 3286 #t) + (3294 3294 #t) + (3296 3299 #f) + (3302 3311 #t) + (3313 3314 #t) + (3329 3331 #f) + (3333 3340 #t) + (3342 3344 #t) + (3346 3386 #t) + (3389 3396 #f) + (3398 3400 #t) + (3402 3406 #f) + (3415 3415 #t) + (3424 3427 #f) + (3430 3445 #f) + (3449 3455 #f) + (3458 3459 #t) + (3461 3478 #t) + (3482 3505 #t) + (3507 3515 #t) + (3517 3517 #t) + (3520 3526 #t) + (3530 3530 #t) + (3535 3540 #f) + (3542 3542 #t) + (3544 3551 #f) + (3558 3567 #t) + (3570 3572 #f) + (3585 3642 #f) + (3647 3675 #f) + (3713 3714 #t) + (3716 3716 #t) + (3719 3720 #t) + (3722 3722 #t) + (3725 3725 #t) + (3732 3735 #t) + (3737 3743 #t) + (3745 3747 #t) + (3749 3749 #t) + (3751 3751 #t) + (3754 3755 #t) + (3757 3769 #f) + (3771 3773 #f) + (3776 3780 #t) + (3782 3782 #t) + (3784 3789 #f) + (3792 3801 #t) + (3804 3807 #f) + (3840 3911 #f) + (3913 3948 #f) + (3953 3991 #f) + (3993 4028 #f) + (4030 4044 #f) + (4046 4058 #f) + (4096 4293 #f) + (4295 4295 #t) + (4301 4301 #t) + (4304 4680 #f) + (4682 4685 #t) + (4688 4694 #t) + (4696 4696 #t) + (4698 4701 #t) + (4704 4744 #t) + (4746 4749 #t) + (4752 4784 #t) + (4786 4789 #t) + (4792 4798 #t) + (4800 4800 #t) + (4802 4805 #t) + (4808 4822 #t) + (4824 4880 #t) + (4882 4885 #t) + (4888 4954 #t) + (4957 4988 #f) + (4992 5017 #f) + (5024 5108 #t) + (5120 5788 #f) + (5792 5880 #f) + (5888 5900 #t) + (5902 5908 #f) + (5920 5942 #f) + (5952 5971 #f) + (5984 5996 #t) + (5998 6000 #t) + (6002 6003 #t) + (6016 6109 #f) + (6112 6121 #t) + (6128 6137 #t) + (6144 6158 #f) + (6160 6169 #t) + (6176 6263 #f) + (6272 6314 #f) + (6320 6389 #t) + (6400 6430 #t) + (6432 6443 #f) + (6448 6459 #f) + (6464 6464 #t) + (6468 6509 #f) + (6512 6516 #t) + (6528 6571 #t) + (6576 6601 #f) + (6608 6618 #f) + (6622 6683 #f) + (6686 6750 #f) + (6752 6780 #f) + (6783 6793 #f) + (6800 6809 #t) + (6816 6829 #f) + (6832 6846 #f) + (6912 6987 #f) + (6992 7036 #f) + (7040 7155 #f) + (7164 7223 #f) + (7227 7241 #f) + (7245 7295 #f) + (7360 7367 #t) + (7376 7414 #f) + (7416 7417 #t) + (7424 7669 #f) + (7676 7957 #f) + (7960 7965 #t) + (7968 8005 #f) + (8008 8013 #t) + (8016 8023 #f) + (8025 8025 #t) + (8027 8027 #t) + (8029 8029 #t) + (8031 8061 #f) + (8064 8116 #f) + (8118 8132 #f) + (8134 8147 #f) + (8150 8155 #f) + (8157 8175 #f) + (8178 8180 #f) + (8182 8190 #f) + (8192 8292 #f) + (8294 8305 #f) + (8308 8334 #f) + (8336 8348 #t) + (8352 8381 #f) + (8400 8432 #f) + (8448 8585 #f) + (8592 9210 #f) + (9216 9254 #t) + (9280 9290 #t) + (9312 11123 #f) + (11126 11157 #t) + (11160 11193 #t) + (11197 11208 #t) + (11210 11217 #t) + (11264 11310 #t) + (11312 11358 #t) + (11360 11507 #f) + (11513 11557 #f) + (11559 11559 #t) + (11565 11565 #t) + (11568 11623 #t) + (11631 11632 #f) + (11647 11670 #f) + (11680 11686 #t) + (11688 11694 #t) + (11696 11702 #t) + (11704 11710 #t) + (11712 11718 #t) + (11720 11726 #t) + (11728 11734 #t) + (11736 11742 #t) + (11744 11842 #f) + (11904 11929 #t) + (11931 12019 #f) + (12032 12245 #t) + (12272 12283 #t) + (12288 12351 #f) + (12353 12438 #f) + (12441 12543 #f) + (12549 12589 #t) + (12593 12686 #t) + (12688 12730 #f) + (12736 12771 #t) + (12784 12830 #f) + (12832 13054 #f) + (13056 19893 #f) + (19904 40908 #f) + (40960 42124 #f) + (42128 42182 #t) + (42192 42539 #f) + (42560 42653 #f) + (42655 42743 #f) + (42752 42894 #f) + (42896 42925 #f) + (42928 42929 #f) + (42999 43051 #f) + (43056 43065 #f) + (43072 43127 #f) + (43136 43204 #f) + (43214 43225 #f) + (43232 43259 #f) + (43264 43347 #f) + (43359 43388 #f) + (43392 43469 #f) + (43471 43481 #f) + (43486 43518 #f) + (43520 43574 #f) + (43584 43597 #f) + (43600 43609 #t) + (43612 43714 #f) + (43739 43766 #f) + (43777 43782 #t) + (43785 43790 #t) + (43793 43798 #t) + (43808 43814 #t) + (43816 43822 #t) + (43824 43871 #f) + (43876 43877 #t) + (43968 44013 #f) + (44016 44025 #t) + (44032 55203 #t) + (55216 55238 #t) + (55243 55291 #t) + (57344 64109 #f) + (64112 64217 #t) + (64256 64262 #t) + (64275 64279 #t) + (64285 64310 #f) + (64312 64316 #t) + (64318 64318 #t) + (64320 64321 #t) + (64323 64324 #t) + (64326 64449 #f) + (64467 64831 #f) + (64848 64911 #t) + (64914 64967 #t) + (65008 65021 #f) + (65024 65049 #f) + (65056 65069 #f) + (65072 65106 #f) + (65108 65126 #f) + (65128 65131 #f) + (65136 65140 #f) + (65142 65276 #t) + (65279 65279 #t) + (65281 65470 #f) + (65474 65479 #t) + (65482 65487 #t) + (65490 65495 #t) + (65498 65500 #t) + (65504 65510 #f) + (65512 65518 #f) + (65529 65533 #f) + (65536 65547 #t) + (65549 65574 #t) + (65576 65594 #t) + (65596 65597 #t) + (65599 65613 #t) + (65616 65629 #t) + (65664 65786 #t) + (65792 65794 #t) + (65799 65843 #t) + (65847 65932 #f) + (65936 65947 #t) + (65952 65952 #t) + (66000 66045 #f) + (66176 66204 #t) + (66208 66256 #t) + (66272 66299 #f) + (66304 66339 #f) + (66352 66378 #f) + (66384 66426 #f) + (66432 66461 #t) + (66463 66499 #f) + (66504 66517 #f) + (66560 66717 #f) + (66720 66729 #t) + (66816 66855 #t) + (66864 66915 #t) + (66927 66927 #t) + (67072 67382 #t) + (67392 67413 #t) + (67424 67431 #t) + (67584 67589 #t) + (67592 67592 #t) + (67594 67637 #t) + (67639 67640 #t) + (67644 67644 #t) + (67647 67669 #t) + (67671 67742 #f) + (67751 67759 #t) + (67840 67867 #f) + (67871 67897 #f) + (67903 67903 #t) + (67968 68023 #t) + (68030 68031 #t) + (68096 68099 #f) + (68101 68102 #t) + (68108 68115 #f) + (68117 68119 #t) + (68121 68147 #t) + (68152 68154 #f) + (68159 68167 #f) + (68176 68184 #t) + (68192 68255 #f) + (68288 68326 #f) + (68331 68342 #f) + (68352 68405 #t) + (68409 68437 #f) + (68440 68466 #f) + (68472 68497 #f) + (68505 68508 #t) + (68521 68527 #t) + (68608 68680 #t) + (69216 69246 #f) + (69632 69709 #f) + (69714 69743 #f) + (69759 69825 #f) + (69840 69864 #t) + (69872 69881 #t) + (69888 69940 #f) + (69942 69955 #f) + (69968 70006 #f) + (70016 70088 #f) + (70093 70093 #t) + (70096 70106 #f) + (70113 70132 #t) + (70144 70161 #t) + (70163 70205 #f) + (70320 70378 #f) + (70384 70393 #t) + (70401 70403 #f) + (70405 70412 #t) + (70415 70416 #t) + (70419 70440 #t) + (70442 70448 #t) + (70450 70451 #t) + (70453 70457 #t) + (70460 70468 #f) + (70471 70472 #t) + (70475 70477 #f) + (70487 70487 #t) + (70493 70499 #f) + (70502 70508 #t) + (70512 70516 #t) + (70784 70855 #f) + (70864 70873 #t) + (71040 71093 #f) + (71096 71113 #f) + (71168 71236 #f) + (71248 71257 #t) + (71296 71351 #f) + (71360 71369 #t) + (71840 71922 #f) + (71935 71935 #t) + (72384 72440 #t) + (73728 74648 #t) + (74752 74862 #t) + (74864 74868 #t) + (77824 78894 #t) + (92160 92728 #t) + (92736 92766 #t) + (92768 92777 #t) + (92782 92783 #t) + (92880 92909 #t) + (92912 92917 #f) + (92928 92997 #f) + (93008 93017 #t) + (93019 93025 #t) + (93027 93047 #t) + (93053 93071 #t) + (93952 94020 #t) + (94032 94078 #f) + (94095 94111 #f) + (110592 110593 #t) + (113664 113770 #t) + (113776 113788 #t) + (113792 113800 #t) + (113808 113817 #t) + (113820 113827 #f) + (118784 119029 #t) + (119040 119078 #t) + (119081 119261 #f) + (119296 119365 #f) + (119552 119638 #t) + (119648 119665 #t) + (119808 119892 #f) + (119894 119964 #f) + (119966 119967 #t) + (119970 119970 #t) + (119973 119974 #t) + (119977 119980 #t) + (119982 119993 #f) + (119995 119995 #t) + (119997 120003 #t) + (120005 120069 #f) + (120071 120074 #t) + (120077 120084 #t) + (120086 120092 #t) + (120094 120121 #f) + (120123 120126 #t) + (120128 120132 #t) + (120134 120134 #t) + (120138 120144 #t) + (120146 120485 #f) + (120488 120779 #f) + (120782 120831 #t) + (124928 125124 #t) + (125127 125142 #f) + (126464 126467 #t) + (126469 126495 #t) + (126497 126498 #t) + (126500 126500 #t) + (126503 126503 #t) + (126505 126514 #t) + (126516 126519 #t) + (126521 126521 #t) + (126523 126523 #t) + (126530 126530 #t) + (126535 126535 #t) + (126537 126537 #t) + (126539 126539 #t) + (126541 126543 #t) + (126545 126546 #t) + (126548 126548 #t) + (126551 126551 #t) + (126553 126553 #t) + (126555 126555 #t) + (126557 126557 #t) + (126559 126559 #t) + (126561 126562 #t) + (126564 126564 #t) + (126567 126570 #t) + (126572 126578 #t) + (126580 126583 #t) + (126585 126588 #t) + (126590 126590 #t) + (126592 126601 #t) + (126603 126619 #t) + (126625 126627 #t) + (126629 126633 #t) + (126635 126651 #t) + (126704 126705 #t) + (126976 127019 #t) + (127024 127123 #t) + (127136 127150 #t) + (127153 127167 #t) + (127169 127183 #t) + (127185 127221 #t) + (127232 127244 #f) + (127248 127278 #t) + (127280 127339 #f) + (127344 127386 #f) + (127462 127490 #f) + (127504 127546 #t) + (127552 127560 #t) + (127568 127569 #t) + (127744 127788 #t) + (127792 127869 #t) + (127872 127950 #t) + (127956 127991 #t) + (128000 128254 #t) + (128256 128330 #t) + (128336 128377 #t) + (128379 128419 #t) + (128421 128578 #t) + (128581 128719 #t) + (128736 128748 #t) + (128752 128755 #t) + (128768 128883 #t) + (128896 128980 #t) + (129024 129035 #t) + (129040 129095 #t) + (129104 129113 #t) + (129120 129159 #t) + (129168 129197 #t) + (131072 173782 #t) + (173824 177972 #t) + (177984 178205 #t) + (194560 195101 #t) + (917505 917505 #t) + (917536 917631 #t) + (917760 917999 #t) + (983040 1048573 #t) + (1048576 1114109 #t))) diff --git a/racket/src/cs/rumble/check.ss b/racket/src/cs/rumble/check.ss new file mode 100644 index 0000000000..c059ce4c10 --- /dev/null +++ b/racket/src/cs/rumble/check.ss @@ -0,0 +1,77 @@ + +(define-syntax (who stx) + (syntax-error stx "not bound")) + +(define-syntax-rule (define-define/who define/who define) + (... + (define-syntax (define/who stx) + (syntax-case stx () + [(_ (id . args) body ...) + #'(define id + (fluid-let-syntax ([who (lambda (stx) + #''id)]) + (lambda args body ...)))] + [(_ id rhs) + #'(define id + (fluid-let-syntax ([who (lambda (stx) + #''id)]) + rhs))])))) + +(define-define/who define/who define) +(define-define/who define/lift/who define/lift) +(define-define/who define/no-lift/who define/no-lift) + +(define-syntax (check stx) + (syntax-case stx (:test :contract :or-false) + [(_ who pred :contract ctc v) + #`(unless (pred v) + (raise-argument-error who ctc v))] + [(_ who :test test-expr :contract ctc v) + #`(unless test-expr + (raise-argument-error who ctc v))] + [(_ who :or-false pred v) + #`(unless (or (not v) (pred v)) + (raise-argument-error who #,(format "(or/c #f ~a)" (syntax->datum #'pred)) v))] + [(_ who pred :or-false v) + #`(unless (or (not v) (pred v)) + (raise-argument-error who #,(format "(or/c ~a #f)" (syntax->datum #'pred)) v))] + [(_ who pred v) + #`(check who pred :contract #,(format "~a" (syntax->datum #'pred)) v)])) + +(define-syntax (procedure-arity-includes/c stx) + (syntax-case stx () + [(_ n) + (let ([n (syntax->datum #'n)]) + (and (integer? n) + (exact? n) + (not (negative? n)))) + #'(lambda (p) + (and (procedure? p) + (procedure-arity-includes? p n)))])) + +(define (check-space who what d-start d-len s-len) + (unless (fx<= (fx+ d-start s-len) d-len) + (raise-arguments-error who (string-append "not enough room in target " what) + "target length" d-len + "needed length" s-len))) + +(define (check-range who what in-value start end len) + (unless (<= start len) + (raise-range-error who what "starting " start in-value 0 len)) + (when end + (unless (<= start end len) + (raise-range-error who what "ending " end in-value start len 0)))) + +(define (check-errno who errno) + (check who + :test (and (pair? errno) + (exact-integer? (car errno)) + (chez:memq (cdr errno) '(posix windows gai))) + :contract "(cons/c exact-integer? (or/c 'posix 'windows 'gai))" + errno)) + +(define (check-integer who lo hi v) + (unless (and (integer? v) + (exact? v) + (<= lo v hi)) + (raise-argument-error who v (format "(integer-in ~a ~a)" lo hi)))) diff --git a/racket/src/cs/rumble/constant.ss b/racket/src/cs/rumble/constant.ss new file mode 100644 index 0000000000..01673cbe0f --- /dev/null +++ b/racket/src/cs/rumble/constant.ss @@ -0,0 +1,5 @@ +(define null '()) +(define eof #!eof) + +(define (void . args) (chez:void)) +(define (void? v) (eq? v (chez:void))) diff --git a/racket/src/cs/rumble/control.ss b/racket/src/cs/rumble/control.ss new file mode 100644 index 0000000000..9e05f5494f --- /dev/null +++ b/racket/src/cs/rumble/control.ss @@ -0,0 +1,1845 @@ +;; The full continuation is a chain of metacontinuations. Each +;; metacontinuation contains a host Scheme continuation, and +;; every prompt is on a boundary between metacontinuations. When +;; a composable continuation is applied, the composition boundary +;; is also a metacontinuation boundary. + +;; "Continuation" as exported from Rumble is "metacontinuation" +;; here. So, `call-with-current-continuation` defined here and +;; exported captures the current metacontinuation (up to a prompt). +;; The `call/cc` function is the host's notion of continuation, which +;; corresponds to a single metacontinuation frame. + +;; A picture where the continuation grows down: + +;; [root empty continuation] +;; --- empty-k +;; metacontinuation | +;; frame | +;; |--- resume-k +;; |<-- tag represents this point +;; --- empty-k +;; metacontinuation | +;; frame | +;; | +;; |--- resume-k +;; |<-- tag represents this point +;; --- empty-k +;; current host | +;; continuation | +;; v + +;; Concretely, the metacontinuation is the current host continuation +;; plus the frames in the list `(current-metacontinuation)`, where the +;; shallowest (= lowest in the picture above) frame is first in the +;; list. The `empty-k` value of the current host continuation is +;; in `current-empty-k`. + +;; The shallowest metacontinuation frame's `empty-k` continuation is +;; used to detect when the current host continuation is empty (i.e., +;; when it matches the `current-empty-k` value). When it's empty, then +;; calling a composable continuation doesn't need to add a new +;; metacontinuation frame, and the application gets the right "tail" +;; behavior. + +;; The shallowest metacontinuation frame's `empty-k` continuation also +;; indicates which continuation's marks (if any) should be spliced +;; into a new context when captured in a composable continuation. See +;; also `current-mark-splice` below. + +;; A metacontinuation frame's `resume-k` is called when control +;; returns or aborts to the frame: +;; +;; * When returning normally to a metacontinuation frame, the +;; `resume-k` continuation receives a function for values returned +;; to the frame. +;; +;; * When aborting to a prompt tag, the `resume-k` continination +;; receives a special value that indicates an abort with arguments. +;; +;; Calling a non-composable continuation is similar to aborting, +;; except that the target prompt's abort handler is not called. In +;; fact, the metacontinuation-frame unwinding process stops before the +;; frame with the target prompt tag (since that prompt is meant to be +;; preserved). + +;; The `dynamic-wind` winders for the frame represented by the current +;; host continuation are kept in `current-winders`. Each winder has a +;; continuation for the point where the winder applies, and when +;; winding or unwinding, control is oved to that continuation, which +;; is needed especially for space-safe unwinding to avoid retaining +;; the continuation where the jump starts. + +;; The continuation marks for the frame represented by the current +;; host continuation are kept in `current-mark-stack`. When a +;; metacontinuation frame is created, it takes the current +;; `current-mark-stack` value and `current-mark-stack` is set back to +;; empty. To keep winders and the mark stack in sync, a `dynamic-wind` +;; pre or post thunk resets the mark stack on entry. + +;; When a composable continuation is applied in a continuation frame +;; that has marks, then the marks are moved into `current-mark-splice`, +;; which is conceptually merged into the tai of `current-mark-stack`. +;; Having a separate `current-mark-splice` enables `dynamic-wind` +;; pre and post thunks adapt correctly to the splicing while jumping +;; into or out of the continuation. + +;; A metacontinuation frame has an extra cache slot to contain a list +;; of mark-stack lists down to the root continuation. When a delimited +;; sequence of metacontinuation frames are copied out of or into the +;; metacontinuation, the slot is flushed and will be reset on demand. + +;; Continuations are used to implement engines, but it's important +;; that an engine doesn't get swapped out (or, more generally, +;; asynchronous signals are handled at the Racket level) while we're +;; manipulating the continuation representation. A bad time for a swap +;; is an "interrupted" region. The `begin-uninterrupted` and +;; `end-uninterrupted` functions bracket such regions dynamically. See +;; also "rumble/engine.ss" and "rumble/interrupt.ss" + +(define-virtual-register current-metacontinuation '()) + +(define-virtual-register current-empty-k #f) + +(define-record metacontinuation-frame (tag ; continuation prompt tag or #f + resume-k ; delivers values to the prompt + empty-k ; deepest end of this frame + winders ; `dynamic-wind` winders + mark-stack ; mark stack to restore + mark-splice ; extra part of mark stack to restore + mark-chain ; #f or a cached list of mark-chain-frame or elem+cache + traces ; #f or a cached list of traces + cc-guard)) ; for impersonated tag, initially #f + +;; Messages to `resume-k[/no-wind]`: +(define-record aborting (args)) + +(define-record-type (continuation-prompt-tag create-continuation-prompt-tag authentic-continuation-prompt-tag?) + (fields (mutable name))) ; mutable => constructor generates fresh instances + +(define the-default-continuation-prompt-tag (create-continuation-prompt-tag 'default)) + +;; Not actually set, but allows access to the full continuation: +(define the-root-continuation-prompt-tag (create-continuation-prompt-tag 'root)) + +;; Tag for a metacontinuation created for composing a continuation +(define the-compose-prompt-tag (create-continuation-prompt-tag 'compose)) + +;; Detected to prevent some jumps: +(define the-barrier-prompt-tag (create-continuation-prompt-tag 'barrier)) + +(define/who make-continuation-prompt-tag + (case-lambda + [() (create-continuation-prompt-tag #f)] + [(name) + (check who symbol? name) + (create-continuation-prompt-tag name)])) + +(define (default-continuation-prompt-tag) the-default-continuation-prompt-tag) +(define (root-continuation-prompt-tag) the-root-continuation-prompt-tag) + +;; To support special treatment of break parameterizations, and also +;; to initialize disabled breaks for `dynamic-wind` pre and post +;; thunks: +(define break-enabled-key (gensym 'break-enabled)) + +;; FIXME: add caching to avoid full traversal +(define/who (continuation-prompt-available? tag) + (check who continuation-prompt-tag? tag) + (let ([tag (strip-impersonator tag)]) + (or (eq? tag the-default-continuation-prompt-tag) + (eq? tag the-root-continuation-prompt-tag) + (let loop ([mc (current-metacontinuation)]) + (cond + [(null? mc) + (eq? tag the-default-continuation-prompt-tag)] + [(eq? tag (strip-impersonator (metacontinuation-frame-tag (car mc)))) + #t] + [else (loop (cdr mc))]))))) + +(define/who (maybe-future-barricade tag) + (when (future? (current-future)) ;; running in a future + (check who continuation-prompt-tag? tag) + (let ([fp (strip-impersonator (current-future-prompt))] + [tag (strip-impersonator tag)]) + (cond + [(eq? tag the-root-continuation-prompt-tag) + (block)] + [else + (let loop ([mc (current-metacontinuation)]) + (cond + [(null? mc) + ;; Won't happen normally, since every thread starts with a explicit prompt + (block)] + [(eq? tag (strip-impersonator (metacontinuation-frame-tag (car mc)))) + (void)] + [(eq? (metacontinuation-frame-tag (car mc)) fp) + ;; tag must be above future prompt + (block)] + [else + (loop (cdr mc))]))])))) + +(define/who call-with-continuation-prompt + (case-lambda + [(proc) (call-with-continuation-prompt proc the-default-continuation-prompt-tag #f)] + [(proc tag) (call-with-continuation-prompt proc tag #f)] + [(proc tag handler . args) + (check who procedure? proc) + (check who continuation-prompt-tag? tag) + (check who :or-false procedure? handler) + (start-uninterrupted 'prompt) + (call-in-empty-metacontinuation-frame + tag + (wrap-handler-for-impersonator + tag + (or handler (make-default-abort-handler tag))) + #f ; not a tail call + (lambda () + (end-uninterrupted 'prompt) + ;; Make room for a slicing continuation-mark frame, in case this + ;; metacontinuation frame is capture and composed in a context + ;; that already has marks: + (call-with-splice-k + (lambda () + ;; Finally, apply the given function: + (apply proc args)))))])) + +(define (make-default-abort-handler tag) + (lambda (abort-thunk) + (check 'default-continuation-prompt-handler (procedure-arity-includes/c 0) abort-thunk) + (call-with-continuation-prompt abort-thunk tag #f))) + +(define (resume-metacontinuation results) + ;; pop a metacontinuation frame + (cond + [(null? (current-metacontinuation)) (engine-return)] + [else + (start-uninterrupted 'resume-mc) + (let ([mf (car (current-metacontinuation))]) + (pop-metacontinuation-frame) + ;; resume + ((metacontinuation-frame-resume-k mf) results))])) + +(define (pop-metacontinuation-frame) + (let ([mf (car (current-metacontinuation))]) + (current-metacontinuation (cdr (current-metacontinuation))) + (current-winders (metacontinuation-frame-winders mf)) + (current-mark-stack (metacontinuation-frame-mark-stack mf)) + (current-mark-splice (metacontinuation-frame-mark-splice mf)) + (current-empty-k (metacontinuation-frame-empty-k mf)))) + +(define (call-in-empty-metacontinuation-frame tag handler tail? proc) + ;; Call `proc` in an empty metacontinuation frame, reifying the + ;; current metacontinuation as needed (i.e., if non-empty) as a new + ;; frame on `*metacontinuations*`; if the tag is #f and the + ;; current metacontinuation frame is already empty, don't push more + (assert-in-uninterrupted) + (assert-not-in-system-wind) + (call/cc + (lambda (tail-k) + (cond + [(and (eq? tag the-compose-prompt-tag) + (eq? tail-k (current-empty-k))) + ;; empty continuation in the current frame; don't push a new + ;; metacontinuation frame; if the mark stack is non-empty, + ;; merge it into the mark splice + (current-mark-splice (merge-mark-splice (current-mark-stack) (current-mark-splice))) + (current-mark-stack '()) + (proc)] + [else + (let ([r ; a list of results, or a non-list for special handling + (call/cc + (lambda (k) + ;; Push another continuation frame so we can drop its `next` + (call-as-non-tail + (lambda () + ;; drop the rest of the current continuation from the + ;; new metacontinuation frame: + (#%$current-stack-link #%$null-continuation) + (let-values ([results + (call/cc + ;; remember the "empty" continuation frame + ;; that just continues the metacontinuation: + (lambda (empty-k) + (let ([mf (make-metacontinuation-frame tag + k + (current-empty-k) + (current-winders) + (if tail? + (prune-immediate-frame (current-mark-stack) tail-k) + (current-mark-stack)) + (current-mark-splice) + #f + #f + #f)]) + (current-winders '()) + (current-empty-k empty-k) + (current-mark-splice (and tail? + (keep-immediate-frame (current-mark-stack) tail-k empty-k))) + (current-mark-stack #f) + ;; push the metacontinuation: + (current-metacontinuation (cons mf (current-metacontinuation))) + ;; ready: + (proc))))]) + ;; Prepare to use cc-guard, if one was enabled: + (let ([cc-guard (or (metacontinuation-frame-cc-guard (car (current-metacontinuation))) + values)]) + ;; Continue normally; the metacontinuation could be different + ;; than when we captured this metafunction frame, though: + (resume-metacontinuation + ;; Apply the cc-guard, if any, outside of the prompt: + (lambda () (apply cc-guard results)))))))))]) + (cond + [(aborting? r) + ;; Remove the prompt as we call the handler: + (pop-metacontinuation-frame) + (end-uninterrupted 'handle) + (apply handler + (aborting-args r))] + [else + ;; We're returning normally; the metacontinuation frame has + ;; been popped already by `resume-metacontinuation` + (end-uninterrupted 'resume) + (r)]))])))) + +(define (call-as-non-tail proc) + (proc) + '(error 'call-as-non-tail "shouldn't get to frame that was meant to be discarded")) + +(define (metacontinuation-frame-update-mark-stack current-mf mark-stack mark-splice) + (make-metacontinuation-frame (metacontinuation-frame-tag current-mf) + (metacontinuation-frame-resume-k current-mf) + (metacontinuation-frame-empty-k current-mf) + (metacontinuation-frame-winders current-mf) + mark-stack + mark-splice + #f + #f + (metacontinuation-frame-cc-guard current-mf))) + +(define (metacontinuation-frame-update-cc-guard current-mf cc-guard) + ;; Ok to keep caches, since the cc-guard doesn't affect them + (make-metacontinuation-frame (metacontinuation-frame-tag current-mf) + (metacontinuation-frame-resume-k current-mf) + (metacontinuation-frame-empty-k current-mf) + (metacontinuation-frame-winders current-mf) + (metacontinuation-frame-mark-stack current-mf) + (metacontinuation-frame-mark-splice current-mf) + (metacontinuation-frame-mark-chain current-mf) + (metacontinuation-frame-traces current-mf) + cc-guard)) + +;; ---------------------------------------- + +(define/who (abort-current-continuation tag . args) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (check-prompt-tag-available who (strip-impersonator tag)) + (start-uninterrupted 'abort) + (let ([args (apply-impersonator-abort-wrapper tag args)] + [tag (strip-impersonator tag)]) + (do-abort-current-continuation who tag args #t))) + +(define/who (unsafe-abort-current-continuation/no-wind tag arg) + (start-uninterrupted 'abort) + (let ([args (apply-impersonator-abort-wrapper tag (list arg))] + [tag (strip-impersonator tag)]) + (do-abort-current-continuation who tag args #f))) + +(define (do-abort-current-continuation who tag args wind?) + (assert-in-uninterrupted) + (cond + [(null? (current-metacontinuation)) + ;; A reset handler must end the uninterrupted region: + ((reset-handler))] + [(or (not wind?) + (null? (current-winders))) + (let ([mf (car (current-metacontinuation))]) + (cond + [(eq? tag (strip-impersonator (metacontinuation-frame-tag mf))) + ((metacontinuation-frame-resume-k mf) + (make-aborting args))] + [else + ;; Aborting to an enclosing prompt, so keep going: + (pop-metacontinuation-frame) + (do-abort-current-continuation who tag args wind?)]))] + [else + (wind-to + '() + ;; No winders left: + (lambda () + (do-abort-current-continuation who tag args wind?)) + ;; If the metacontinuation changes, check target before retrying: + (lambda () + (check-prompt-still-available who tag) + (do-abort-current-continuation who tag args wind?)))])) + +(define (check-prompt-still-available who tag) + (unless (continuation-prompt-available? tag) + (end-uninterrupted 'escape-fail) + (raise-continuation-error who + (string-append + "lost target;\n" + (if (eq? who 'abort-current-continuation) + (string-append + " abort in progress, but the current continuation includes no prompt with\n" + " the given tag after a `dynamic-wind` post-thunk return") + (string-append + " jump to escape continuation in progress, and the target is not in the\n" + " current continuation after a `dynamic-wind` post-thunk return")))))) + +;; ---------------------------------------- + +(define/who (call-with-continuation-barrier p) + (check who (procedure-arity-includes/c 0) p) + (start-uninterrupted 'barrier) + (call-in-empty-metacontinuation-frame + the-barrier-prompt-tag ; <- recognized as a barrier by continuation capture or call + #f + #f ; not a tail call + (lambda () + (end-uninterrupted 'barrier) + (|#%app| p)))) + +;; ---------------------------------------- +;; Capturing and applying continuations + +(define-record continuation ()) +(define-record full-continuation continuation (k winders mark-stack mark-splice empty-k mc)) +(define-record composable-continuation full-continuation ()) +(define-record composable-continuation/no-wind composable-continuation ()) +(define-record non-composable-continuation full-continuation (tag)) +(define-record escape-continuation continuation (tag)) + +(define/who call-with-current-continuation + (case-lambda + [(proc) (call-with-current-continuation proc + the-default-continuation-prompt-tag)] + [(proc tag) + (check who (procedure-arity-includes/c 1) proc) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (call-with-end-uninterrupted + (lambda () + (call/cc + (lambda (k) + (|#%app| + proc + (make-non-composable-continuation + k + (current-winders) + (current-mark-stack) + (current-mark-splice) + (current-empty-k) + (extract-metacontinuation 'call-with-current-continuation (strip-impersonator tag) #t) + tag))))))])) + +(define/who call-with-composable-continuation + (case-lambda + [(p) (call-with-composable-continuation p the-default-continuation-prompt-tag)] + [(p tag) + (check who (procedure-arity-includes/c 1) p) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (call-with-composable-continuation* p tag #t)])) + +(define (call-with-composable-continuation* p tag wind?) + (call-with-end-uninterrupted + (lambda () + (call/cc + (lambda (k) + (|#%app| + p + ((if wind? + make-composable-continuation + make-composable-continuation/no-wind) + k + (current-winders) + (current-mark-stack) + (current-mark-splice) + (current-empty-k) + (extract-metacontinuation 'call-with-composable-continuation (strip-impersonator tag) #f)))))))) + +(define (unsafe-call-with-composable-continuation/no-wind p tag) + (call-with-composable-continuation* p tag #f)) + +(define/who (call-with-escape-continuation p) + (check who (procedure-arity-includes/c 1) p) + (let ([tag (make-continuation-prompt-tag)]) + (call-with-continuation-prompt + (lambda () + (|#%app| p (make-escape-continuation tag))) + tag + values))) + +;; Applying a continuation calls this internal function: +(define (apply-continuation c args) + (start-uninterrupted 'continue) + (cond + [(composable-continuation? c) + ;; To compose the metacontinuation, first make sure the current + ;; continuation is reified in `(current-metacontinuation)`: + (call-in-empty-metacontinuation-frame + the-compose-prompt-tag + fail-abort-to-delimit-continuation + #t ; a tail call + (lambda () + ;; The current metacontinuation frame has an + ;; empty continuation, so we can "replace" that + ;; with the composable one: + (if (composable-continuation/no-wind? c) + (apply-immediate-continuation/no-wind c args) + (apply-immediate-continuation c (reverse (full-continuation-mc c)) args))))] + [(non-composable-continuation? c) + (apply-non-composable-continuation c args)] + [(escape-continuation? c) + (let ([tag (escape-continuation-tag c)]) + (unless (continuation-prompt-available? tag) + (end-uninterrupted 'escape-fail) + (raise-continuation-error '|continuation application| + "attempt to jump into an escape continuation")) + (do-abort-current-continuation '|continuation application| tag args #t))])) + +(define (apply-non-composable-continuation c args) + (assert-in-uninterrupted) + (let* ([tag (non-composable-continuation-tag c)]) + (let-values ([(common-mc ; shared part of the current metacontinuation + rmc-append) ; non-shared part of the destination metacontinuation + ;; We check every time, just in case control operations + ;; change the current continuation out from under us. + (find-common-metacontinuation (full-continuation-mc c) + (current-metacontinuation) + (strip-impersonator tag))]) + (let loop () + (cond + [(eq? common-mc (current-metacontinuation)) + ;; Replace the current metacontinuation frame's continuation + ;; with the saved one; this replacement will take care of any + ;; shared winders within the frame. + (apply-immediate-continuation c rmc-append args)] + [else + ;; Unwind this metacontinuation frame: + (wind-to + '() + ;; If all winders complete simply: + (lambda () + (pop-metacontinuation-frame) + (loop)) + ;; If a winder changes the metacontinuation, then + ;; start again: + (lambda () + (apply-non-composable-continuation c args)))]))))) + +;; Apply a continuation within the current metacontinuation frame: +(define (apply-immediate-continuation c rmc args) + (assert-in-uninterrupted) + (call-with-appended-metacontinuation + rmc + c + args + (lambda () + (let ([mark-stack (full-continuation-mark-stack c)] + [empty-k (full-continuation-empty-k c)]) + (current-mark-splice (let ([mark-splice (full-continuation-mark-splice c)]) + (if (composable-continuation? c) + (prune-mark-splice (merge-mark-splice mark-splice (current-mark-splice)) + mark-stack + empty-k) + mark-splice))) + (current-empty-k empty-k) + (wind-to + (full-continuation-winders c) + ;; When no winders are left: + (lambda () + (current-mark-stack mark-stack) + (when (non-composable-continuation? c) + ;; Activate/add cc-guards in target prompt; any user-level + ;; callbacks here are run with a continuation barrier, so + ;; the metacontinuation won't change (except by escaping): + (activate-and-wrap-cc-guard-for-impersonator! + (non-composable-continuation-tag c))) + (apply (full-continuation-k c) args)) + ;; If a winder changed the meta-continuation, try again for a + ;; non-composable continuation: + (and (non-composable-continuation? c) + (lambda () + (apply-non-composable-continuation c args)))))))) + +;; Like `apply-immediate-continuation`, but don't run winders +(define (apply-immediate-continuation/no-wind c args) + (current-metacontinuation (append + (map metacontinuation-frame-clear-cache (full-continuation-mc c)) + (current-metacontinuation))) + (current-winders (full-continuation-winders c)) + (current-mark-stack (full-continuation-mark-stack c)) + (current-mark-splice (full-continuation-mark-splice c)) + (current-empty-k (full-continuation-empty-k c)) + (apply (full-continuation-k c) args)) + +;; Used as a "handler" for a prompt without a tag, which is used for +;; composable continuations +(define (fail-abort-to-delimit-continuation . args) + (error 'abort "trying to abort to a delimiter continuation frame")) + +;; Find common metacontinuation to keep due to a combination of: +;; the metacontinuation is beyond the relevant prompt, or the +;; metacontinuation fragment before the prompt is also shared +;; with the composable continuation's metacontinuation (so we +;; should not unwind and rewind those metacontinuation frames) +(define (find-common-metacontinuation mc current-mc tag) + (let-values ([(rev-current ; (list (cons mf mc) ...) + base-current-mc) + ;; Get the reversed prefix of `current-mc` that is to be + ;; replaced by `mc`: + (let loop ([current-mc current-mc] [accum null]) + (cond + [(null? current-mc) + (unless (or (eq? tag the-default-continuation-prompt-tag) + (eq? tag the-root-continuation-prompt-tag)) + (do-raise-arguments-error '|continuation application| + "continuation includes no prompt with the given tag" + exn:fail:contract:continuation + (list "tag" tag))) + (values accum null)] + [(eq? tag (strip-impersonator (metacontinuation-frame-tag (car current-mc)))) + (values accum current-mc)] + [else + (loop (cdr current-mc) + ;; Accumulate this frame plus the chain that + ;; we should keep if this frame is shared: + (cons (cons (car current-mc) current-mc) + accum))]))]) + (let ([rev-mc (reverse mc)]) + ;; Work from the tail backwards (which is forward in the reverse + ;; lists): If the continuations are the same for the two frames, + ;; then the metacontinuation frame should not be unwound + (let loop ([rev-current rev-current] + [rev-mc rev-mc] + [base-current-mc base-current-mc]) + (cond + [(null? rev-mc) (values base-current-mc '())] + [(null? rev-current) + (check-for-barriers rev-mc) + ;; Return the shared part plus the unshared-to-append part + (values base-current-mc rev-mc)] + [(eq? (metacontinuation-frame-resume-k (car rev-mc)) + (metacontinuation-frame-resume-k (caar rev-current))) + ;; Matches, so update base and look shallower + (loop (cdr rev-current) + (cdr rev-mc) + (cdar rev-current))] + [else + ;; Doesn't match, so we've found the shared part; + ;; check for barriers that we'd have to reintroduce + (check-for-barriers rev-mc) + ;; Return the shared part plus the unshared-to-append part + (values (cdr (cdar rev-current)) rev-mc)]))))) + +(define (check-for-barriers rev-mc) + (unless (null? rev-mc) + (when (eq? (metacontinuation-frame-tag (car rev-mc)) + the-barrier-prompt-tag) + (raise-barrier-error)) + (check-for-barriers (cdr rev-mc)))) + +(define (raise-barrier-error) + (end-uninterrupted 'hit-barrier) + (raise-continuation-error '|continuation application| + "attempt to cross a continuation barrier")) + +(define (call-with-end-uninterrupted thunk) + ;; Using `call/cm` with a key of `none` ensures that we have an + ;; `(end-uninterrupted)` in the immediate continuation, but + ;; keeping the illusion that `thunk` is called in tail position. + (call/cm none #f thunk)) + +;; Update `splice-k` to be the "inside" of a continuation prompt. +(define (call-with-splice-k thunk) + (call-with-end-uninterrupted + (lambda () + (call/cc + (lambda (k) + (current-empty-k k) + (thunk)))))) + +(define (set-continuation-applicables!) + (let ([add (lambda (rtd) + (struct-property-set! prop:procedure + rtd + (lambda (c . args) + (apply-continuation c args))))]) + (add (record-type-descriptor composable-continuation)) + (add (record-type-descriptor composable-continuation/no-wind)) + (add (record-type-descriptor non-composable-continuation)) + (add (record-type-descriptor escape-continuation)))) + +;; ---------------------------------------- +;; Metacontinuation operations for continutions + +;; Extract a prefix of `(current-metacontinuation)` up to `tag` +(define (extract-metacontinuation who tag barrier-ok?) + (let ([check-barrier-ok + (lambda (saw-barrier?) + (when (and saw-barrier? (not barrier-ok?)) + (raise-continuation-error who "cannot capture past continuation barrier")))]) + (let loop ([mc (current-metacontinuation)] [saw-barrier? #f]) + (cond + [(null? mc) + (unless (or (eq? tag the-root-continuation-prompt-tag) + (eq? tag the-default-continuation-prompt-tag)) + (do-raise-arguments-error who "continuation includes no prompt with the given tag" + exn:fail:contract:continuation + (list "tag" tag))) + (check-barrier-ok saw-barrier?) + '()] + [else + (let ([a-tag (strip-impersonator (metacontinuation-frame-tag (car mc)))]) + (cond + [(eq? a-tag tag) + (check-barrier-ok saw-barrier?) + '()] + [else + (cons (metacontinuation-frame-clear-cache (car mc)) + (loop (cdr mc) (or saw-barrier? + (eq? a-tag the-barrier-prompt-tag))))]))])))) + +(define (check-prompt-tag-available who tag) + (unless (continuation-prompt-available? tag) + (do-raise-arguments-error who "continuation includes no prompt with the given tag" + exn:fail:contract:continuation + (list "tag" tag)))) + +(define (call-with-appended-metacontinuation rmc dest-c dest-args proc) + ;; Assumes that the current metacontinuation frame is ready to be + ;; replaced with `mc` (reversed as `rmc`) plus `proc`. + ;; In the simple case of no winders and an empty frame immediate + ;; metacontinuation fame, we could just + ;; (current-metacontinuation (append mc (current-metacontinuation))) + ;; But, to run winders and replace anything in the current frame, + ;; we proceed frame-by-frame in `mc`. + (assert-in-uninterrupted) + (let loop ([rmc rmc]) + (cond + [(null? rmc) (proc)] + [else + (let ([mf (maybe-merge-splice (composable-continuation? dest-c) + (metacontinuation-frame-clear-cache (car rmc)))] + [rmc (cdr rmc)]) + ;; Set splice before jumping, so it can be used by winders + (current-mark-splice (metacontinuation-frame-mark-splice mf)) + ;; Run "in" winders for the metacontinuation + (wind-to + (metacontinuation-frame-winders mf) + ;; When all winders done for this frame: + (lambda () + (current-metacontinuation (cons mf (current-metacontinuation))) + (current-winders '()) + (loop rmc)) + ;; When a winder changes the metacontinuation, try again + ;; for a non-composable continuation: + (and (non-composable-continuation? dest-c) + (lambda () + (apply-non-composable-continuation dest-c dest-args)))))]))) + +(define (metacontinuation-frame-clear-cache mf) + (metacontinuation-frame-update-mark-stack mf + (metacontinuation-frame-mark-stack mf) + (metacontinuation-frame-mark-splice mf))) + +;; Get/cache a converted list of marks for a metacontinuation +(define (metacontinuation-marks mc) + (cond + [(null? mc) null] + [else (let ([mf (car mc)]) + (or (metacontinuation-frame-mark-chain mf) + (let* ([r (metacontinuation-marks (cdr mc))] + [m (let ([mark-splice (metacontinuation-frame-mark-splice mf)]) + (if mark-splice + (cons (make-mark-chain-frame + (strip-impersonator (metacontinuation-frame-tag mf)) + ;; maybe splicing: + (mark-stack-tail-matches? (metacontinuation-frame-mark-stack mf) + (mark-stack-frame-k mark-splice)) + (mark-stack-to-marks mark-splice)) + r) + r))] + [l (cons (make-mark-chain-frame + (strip-impersonator (metacontinuation-frame-tag mf)) + #t ; not splicing + (mark-stack-to-marks + (metacontinuation-frame-mark-stack mf))) + m)]) + (set-metacontinuation-frame-mark-chain! mf l) + l)))])) + +(define (maybe-merge-splice splice? mf) + (cond + [(and splice? (current-mark-splice)) + => (lambda (mark-splice) + (current-mark-splice #f) + (metacontinuation-frame-update-mark-stack mf + (metacontinuation-frame-mark-stack mf) + (merge-mark-splice (metacontinuation-frame-mark-splice mf) + mark-splice)))] + [else mf])) + +;; ---------------------------------------- +;; Continuation marks + +(define-record continuation-mark-set (mark-chain traces)) +(define-record mark-stack-frame (prev ; prev frame + k ; continuation for this frame + table ; intmap mapping keys to values + flat)) ; #f or cached list that contains only tables and elem+caches + +;; A mark stack is made of marks-stack frames: +(define-virtual-register current-mark-stack #f) + +;; An extra mark stack of size 0 or 1 that is conceptually appended to +;; the end of `current-mark-stack`, mainly to support composable +;; continuations and `dynamic-wind`. If the last frame of +;; `current-mark-stack` has the same `k` as a frame in +;; `current-mark-stack-splice`, then then frames are conceptually +;; merged, so no key should be inthe mark-splice frame if it's in the +;; mark-stack frame. +(define-virtual-register current-mark-splice #f) + +;; See copy in "expander.sls" +(define-syntax with-continuation-mark + (syntax-rules () + [(_ key val body) + (call/cm key val (lambda () body))])) + +;; Sets a continuation mark. +;; Using `none` as a key ensures that a +;; stack-restoring frame is pushed without +;; adding a key--value mapping. +(define (call/cm key val proc) + (call/cc + (lambda (k) + (when (eq? k (current-empty-k)) + ;; Need to merge the main stack and splice, if both are active + (when (current-mark-splice) + (merge-mark-splice!))) + (let ([mark-stack (current-mark-stack)]) + (cond + [(and mark-stack + (eq? k (mark-stack-frame-k mark-stack))) + (unless (eq? key none) + (current-mark-stack (make-mark-stack-frame (mark-stack-frame-prev mark-stack) + k + (intmap-set/cm-key (mark-stack-frame-table mark-stack) + key + val) + #f))) + (proc)] + [else + (begin0 + (call/cc + (lambda (new-k) + (current-mark-stack + (make-mark-stack-frame mark-stack + new-k + (if (eq? key none) + empty-hasheq + (intmap-set/cm-key empty-hasheq key val)) + #f)) + (proc))) + (current-mark-stack (mark-stack-frame-prev (current-mark-stack))) + ;; To support exiting an uninterrupted region on resumption of + ;; a continuation (see `call-with-end-uninterrupted`): + (when (current-in-uninterrupted) + (pariah (end-uninterrupted/call-hook 'cm))))]))))) + +;; For internal use, such as `dynamic-wind` pre thunks: +(define (call/cm/nontail key val proc) + (current-mark-stack + (make-mark-stack-frame (current-mark-stack) + #f + (intmap-set empty-hasheq key val) + #f)) + (proc) + ;; If we're in an escape process, then `(current-mark-stack)` might not + ;; match, and that's ok; it doesn't matter what we set the mark stack to + ;; in that case, so we do something that's right for the non-escape case + (when (current-mark-stack) + (current-mark-stack (mark-stack-frame-prev (current-mark-stack))))) + +(define (current-mark-chain) + (get-current-mark-chain (current-mark-stack) (current-mark-splice) (current-metacontinuation))) + +(define (mark-stack-to-marks mark-stack) + (let loop ([mark-stack mark-stack]) + (cond + [(not mark-stack) null] + [(mark-stack-frame-flat mark-stack) => (lambda (l) l)] + [else + (let ([l (cons (mark-stack-frame-table mark-stack) + (loop (mark-stack-frame-prev mark-stack)))]) + (set-mark-stack-frame-flat! mark-stack l) + l)]))) + +(define-record mark-chain-frame (tag splice? marks)) + +(define (get-current-mark-chain mark-stack mark-splice mc) + (let ([hd (make-mark-chain-frame + #f ; no tag + #f ; not a splice + (mark-stack-to-marks mark-stack))] + [mid (and mark-splice + (make-mark-chain-frame + #f ; no tag + (mark-stack-tail-matches? mark-stack (mark-stack-frame-k mark-splice)) ; maybe splicing + (mark-stack-to-marks mark-splice)))] + [tl (metacontinuation-marks mc)]) + (if mid + (cons hd (cons mid tl)) + (cons hd tl)))) + +(define (mark-stack-tail-matches? mark-stack k) + (and mark-stack + (let ([prev (mark-stack-frame-prev mark-stack)]) + (or (and (not prev) + (eq? (mark-stack-frame-k mark-stack) k)) + (mark-stack-tail-matches? prev k))))) + +(define (prune-mark-chain-prefix tag mark-chain) + (cond + [(eq? tag (mark-chain-frame-tag (elem+cache-strip (car mark-chain)))) + mark-chain] + [else + (prune-mark-chain-prefix tag (cdr mark-chain))])) + +(define (prune-mark-chain-suffix tag mark-chain) + (cond + [(null? mark-chain) null] + [(eq? tag (mark-chain-frame-tag (elem+cache-strip (car mark-chain)))) + null] + [else + (let ([rest-mark-chain (prune-mark-chain-suffix tag (cdr mark-chain))]) + (if (eq? rest-mark-chain (cdr mark-chain)) + mark-chain + (cons (car mark-chain) + rest-mark-chain)))])) + +;; Used by `continuation-mark-set->list*` to determine when to splice +(define (splice-next? mark-chain) + (and (pair? mark-chain) + (pair? (cdr mark-chain)) + (mark-chain-frame-splice? (elem+cache-strip (cadr mark-chain))))) + +;; Called when the curent continuation is `(current-empty-k)`, +;; merge anything in `(current-mark-splice)` into `(current-mark-stack)` +(define (merge-mark-splice!) + (let ([mark-splice (current-mark-splice)]) + (when mark-splice + (current-mark-stack (merge-mark-splice (current-mark-stack) + mark-splice)) + (current-mark-splice #f)))) + +;; Merge immediate frame of `mark-splice` into immediate frame of +;; `mark-stack`, where `mark-stack` takes precedence. We expect that +;; each argument is a stack of length 0 or 1, since that's when +;; merging makes sense. +(define (merge-mark-splice mark-stack mark-splice) + (cond + [(not mark-stack) mark-splice] + [(not mark-splice) mark-stack] + [else + (make-mark-stack-frame #f + (mark-stack-frame-k mark-stack) + (merge-mark-table (mark-stack-frame-table mark-stack) + (mark-stack-frame-table mark-splice)) + #f)])) + +(define (merge-mark-table a b) + (cond + [(eq? empty-hasheq a) b] + [(eq? empty-hasheq b) a] + [else + (let loop ([b b] [i (hash-iterate-first a)]) + (cond + [(not i) b] + [else (let-values ([(key val) (hash-iterate-key+value a i)]) + (loop (hash-set b key val) + (hash-iterate-next a i)))]))])) + +;; If `mark-stack` ends with a frame that is conceptually +;; merged with one in `mark-splice`, then discard any keys +;; in `mark-splice` that are in the `mark-stack` frame. +;; Also, update `mark-splice` to use `empty-k`. +(define (prune-mark-splice mark-splice mark-stack empty-k) + (cond + [(not mark-splice) #f] + [else + (let loop ([mark-stack mark-stack]) + (cond + [(not mark-stack) (make-mark-stack-frame #f + empty-k + (mark-stack-frame-table mark-splice) + #f)] + [else + (let ([prev (mark-stack-frame-prev mark-stack)]) + (cond + [(and (not prev) (eq? (mark-stack-frame-k mark-stack) empty-k)) + (make-mark-stack-frame #f + empty-k + (prune-mark-table (mark-stack-frame-table mark-stack) + (mark-stack-frame-table mark-splice)) + #f)] + [else (loop prev)]))]))])) + +(define (prune-mark-table a b) + (cond + [(eq? empty-hasheq a) b] + [(eq? empty-hasheq b) a] + [else + (let loop ([b b] [i (hash-iterate-first a)]) + (cond + [(not i) b] + [else (loop (hash-remove b (hash-iterate-key a i)) + (hash-iterate-next a i))]))])) + +(define (mark-stack-starts-with? mark-stack k) + (and mark-stack + (eq? k (mark-stack-frame-k mark-stack)))) + +;; Drop any marks on the immediate frame --- used when +;; moving a frame across a metacontinuation boundary +(define (prune-immediate-frame mark-stack k) + (cond + [(mark-stack-starts-with? mark-stack k) + (make-mark-stack-frame (mark-stack-frame-prev mark-stack) + (mark-stack-frame-k mark-stack) + empty-hasheq + #f)] + [else mark-stack])) + +(define (keep-immediate-frame mark-stack k empty-k) + (cond + [(mark-stack-starts-with? mark-stack k) + (make-mark-stack-frame #f + empty-k + (mark-stack-frame-table mark-stack) + #f)] + [else #f])) + +(define (mark-stack-append a b) + (cond + [(not a) b] + [(not b) a] + [else + (make-mark-stack-frame (mark-stack-append (mark-stack-frame-prev a) b) + (mark-stack-frame-k a) + (mark-stack-frame-table a) + #f)])) + +;; ---------------------------------------- +;; Continuation-mark caching + +;; A `elem+cache` can replace a plain table in a "flat" variant of the +;; mark stack within a metacontinuation frame, or in a mark-stack +;; chain for a metacontinuation. The cache is a table that records +;; results found later in the list, which allows +;; `continuation-mark-set-first` to take amortized constant time. +(define-record elem+cache (elem cache)) +(define (elem+cache-strip t) (if (elem+cache? t) (elem+cache-elem t) t)) + +(define/who call-with-immediate-continuation-mark + (case-lambda + [(key proc) (call-with-immediate-continuation-mark key proc #f)] + [(key proc default-v) + (check who (procedure-arity-includes/c 1) proc) + (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'call-with-immediate-continuation-mark key)]) + (cond + [(not (current-mark-stack)) (|#%app| proc default-v)] + [else + (call/cc (lambda (k) + (when (eq? k (current-empty-k)) (merge-mark-splice!)) + (if (eq? k (mark-stack-frame-k (current-mark-stack))) + (|#%app| proc (let ([v (intmap-ref (mark-stack-frame-table (current-mark-stack)) + key + none)]) + (if (eq? v none) + default-v + (wrapper v)))) + (|#%app| proc default-v))))]))])) + +(define/who continuation-mark-set-first + (case-lambda + [(marks key) (continuation-mark-set-first marks key #f)] + [(marks key none-v) + (continuation-mark-set-first marks key none-v + ;; Treat `break-enabled-key` and `parameterization-key`, specially + ;; so that things like `current-break-parameterization` work without + ;; referencing the root continuation prompt tag + (if (or (eq? key break-enabled-key) + (eq? key parameterization-key)) + the-root-continuation-prompt-tag + the-default-continuation-prompt-tag))] + [(marks key none-v prompt-tag) + (check who continuation-mark-set? :or-false marks) + (check who continuation-prompt-tag? prompt-tag) + (maybe-future-barricade prompt-tag) + (let ([prompt-tag (strip-impersonator prompt-tag)]) + (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'continuation-mark-set-first key)]) + (let ([v (marks-search (or (and marks + (continuation-mark-set-mark-chain marks)) + (current-mark-chain)) + key + #t ; at-outer? + prompt-tag)]) + (cond + [(eq? v none) + ;; More special treatment of built-in keys + (cond + [(eq? key parameterization-key) + empty-parameterization] + [(eq? key break-enabled-key) + (current-engine-init-break-enabled-cell none-v)] + [else + none-v])] + [else (wrapper v)]))))])) + +;; To make `continuation-mark-set-first` constant-time, if we traverse +;; N elements to get an answer, then cache the answer at N/2 elements. +(define (marks-search elems key at-outer? prompt-tag) + (let loop ([elems elems] [elems/cache-pos elems] [cache-step? #f] [depth 0]) + (cond + [(or (null? elems) + (and at-outer? + (eq? (mark-chain-frame-tag (elem+cache-strip (car elems))) prompt-tag))) + ;; Not found + (cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag) + none] + [else + (let ([t (car elems)] + [check-elem + (lambda (t) + (let ([v (if at-outer? + ;; Search within the metacontinuation frame: + (let ([marks (mark-chain-frame-marks t)]) + (marks-search marks key #f #f)) + ;; We're looking at just one frame: + (intmap-ref t key none))]) + (cond + [(eq? v none) + ;; Not found at this point; keep looking + (loop (cdr elems) + (if cache-step? (cdr elems/cache-pos) elems/cache-pos) + (not cache-step?) + (fx+ 1 depth))] + [else + ;; Found it + (cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag) + v])))]) + (cond + [(elem+cache? t) + (let ([v (intmap-ref (elem+cache-cache t) key none2)]) + (cond + [(eq? v none2) + ;; No mapping in cache, so try the element and continue: + (check-elem (elem+cache-elem t))] + [else + (let ([v (if at-outer? + ;; strip & combine --- cache results at the metacontinuation + ;; level should depend on the prompt tag, so make the cache + ;; value another table level mapping the prompt tag to the value: + (hash-ref v prompt-tag none2) + v)]) + (cond + [(eq? v none2) + ;; Strip filtered this cache entry away, so try the element: + (check-elem (elem+cache-elem t))] + [(eq? v none) + ;; The cache records that it's not in the rest: + (cache-result! elems elems/cache-pos depth key none at-outer? prompt-tag) + none] + [else + ;; The cache provides a value from the rest: + (cache-result! elems elems/cache-pos depth key v at-outer? prompt-tag) + v]))]))] + [else + ;; Try the element: + (check-elem t)]))]))) + +;; To make `continuation-mark-set-first` constant-time, cache +;; a key--value mapping at a point that's half-way in +(define (cache-result! marks marks/cache-pos depth key v at-outer? prompt-tag) + (unless (< depth 16) + (let* ([t (car marks/cache-pos)] + [new-t (if (elem+cache? t) + t + (make-elem+cache t empty-hasheq))]) + (unless (eq? t new-t) + (set-car! marks/cache-pos new-t)) + (set-elem+cache-cache! new-t (intmap-set (elem+cache-cache new-t) + key + (if at-outer? + ;; At the metacontinuation level, cache depends on the + ;; prompt tag: + (let ([old (intmap-ref (elem+cache-cache new-t) key none2)]) + (intmap-set (if (eq? old none2) empty-hasheq old) prompt-tag v)) + v)))))) + +(define/who continuation-mark-set->list + (case-lambda + [(marks key) (continuation-mark-set->list marks key the-default-continuation-prompt-tag)] + [(marks key prompt-tag) + (check who continuation-mark-set? :or-false marks) + (check who continuation-prompt-tag? prompt-tag) + (maybe-future-barricade prompt-tag) + (let ([prompt-tag (strip-impersonator prompt-tag)]) + (let-values ([(key wrapper) (extract-continuation-mark-key-and-wrapper 'continuation-mark-set->list key)]) + (let chain-loop ([mark-chain (or (and marks + (continuation-mark-set-mark-chain marks)) + (current-mark-chain))]) + (cond + [(null? mark-chain) + null] + [else + (let* ([mcf (elem+cache-strip (car mark-chain))]) + (cond + [(eq? (mark-chain-frame-tag mcf) prompt-tag) + null] + [else + (let loop ([marks (mark-chain-frame-marks mcf)]) + (cond + [(null? marks) + (chain-loop (cdr mark-chain))] + [else + (let* ([v (intmap-ref (elem+cache-strip (car marks)) key none)]) + (if (eq? v none) + (loop (cdr marks)) + (cons (wrapper v) (loop (cdr marks)))))]))]))]))))])) + +(define/who continuation-mark-set->list* + (case-lambda + [(marks keys) (continuation-mark-set->list* marks keys the-default-continuation-prompt-tag #f)] + [(marks keys prompt-tag) (continuation-mark-set->list* marks keys prompt-tag #f)] + [(marks keys prompt-tag none-v) + (check who continuation-mark-set? :or-false marks) + (check who list? keys) + (check who continuation-prompt-tag? prompt-tag) + (maybe-future-barricade prompt-tag) + (let ([prompt-tag (strip-impersonator prompt-tag)]) + (let-values ([(all-keys all-wrappers) + (map/2-values (lambda (k) + (extract-continuation-mark-key-and-wrapper 'continuation-mark-set->list* k)) + keys)]) + (let* ([n (length all-keys)] + [tmp (make-vector n)]) + (let chain-loop ([mark-chain (or (and marks + (continuation-mark-set-mark-chain marks)) + (current-mark-chain))]) + (cond + [(null? mark-chain) + null] + [else + (let* ([mcf (elem+cache-strip (car mark-chain))]) + (cond + [(eq? (mark-chain-frame-tag mcf) prompt-tag) + null] + [else + (let loop ([marks (let ([marks (mark-chain-frame-marks mcf)]) + (if (splice-next? mark-chain) + ;; handle splicing (created by applying a composable + ;; continuation to a context that had marks already) + (append marks + (mark-chain-frame-marks (elem+cache-strip (cadr mark-chain)))) + marks))]) + (cond + [(null? marks) + (chain-loop (if (splice-next? mark-chain) + (cddr mark-chain) + (cdr mark-chain)))] + [else + (let ([t (elem+cache-strip (car marks))]) + (let key-loop ([keys all-keys] [wrappers all-wrappers] [i 0] [found? #f]) + (cond + [(null? keys) + (if found? + (let ([vec (vector-copy tmp)]) + (cons vec (loop (cdr marks)))) + (loop (cdr marks)))] + [else + (let ([v (intmap-ref t (car keys) none)]) + (cond + [(eq? v none) + (vector-set! tmp i none-v) + (key-loop (cdr keys) (cdr wrappers) (add1 i) found?)] + [else + (vector-set! tmp i ((car wrappers) v)) + (key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))])) + +(define/who (continuation-mark-set->context marks) + (check who continuation-mark-set? marks) + (traces->context (continuation-mark-set-traces marks))) + +(define/who current-continuation-marks + (case-lambda + [() (current-continuation-marks the-default-continuation-prompt-tag)] + [(tag) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (call/cc + (lambda (k) + (make-continuation-mark-set (prune-mark-chain-suffix (strip-impersonator tag) (current-mark-chain)) + (cons (continuation->trace k) + (get-metacontinuation-traces (current-metacontinuation))))))])) + +;; Wrapped a threads layer to handle thread arguments: +(define/who continuation-marks + (case-lambda + [(k) (continuation-marks k (default-continuation-prompt-tag))] + [(k tag) + ;; If `k` is a procedure, we assume that it's an engine + (check who (lambda (p) (or (not p) + (continuation? p) + (and (#%procedure? p) (procedure-arity-includes? p 0)))) + :contract "(or/c continuation? engine-procedure? #f)" + k) + (check who continuation-prompt-tag? tag) + (maybe-future-barricade tag) + (let ([tag (strip-impersonator tag)]) + (cond + [(#%procedure? k) + (let ([mc (saved-metacontinuation-mc (k))]) + (make-continuation-mark-set + (prune-mark-chain-suffix + tag + (get-current-mark-chain #f #f mc)) + (get-metacontinuation-traces mc)))] + [(full-continuation? k) + (make-continuation-mark-set + (prune-mark-chain-suffix + tag + (get-current-mark-chain (full-continuation-mark-stack k) + (full-continuation-mark-splice k) + (full-continuation-mc k))) + (cons (continuation->trace (full-continuation-k k)) + (get-metacontinuation-traces (full-continuation-mc k))))] + [(escape-continuation? k) + (unless (continuation-prompt-available? (escape-continuation-tag k)) + (raise-continuation-error '|continuation application| + "escape continuation not in the current continuation")) + (make-continuation-mark-set + (prune-mark-chain-suffix + tag + (prune-mark-chain-prefix (escape-continuation-tag k) (current-mark-chain))) + null)] + [else + (make-continuation-mark-set null null)]))])) + +(define (get-metacontinuation-traces mc) + (cond + [(null? mc) '()] + [(metacontinuation-frame-traces (car mc)) + => (lambda (traces) traces)] + [else + (let ([traces + (cons (continuation->trace (metacontinuation-frame-resume-k (car mc))) + (get-metacontinuation-traces (cdr mc)))]) + (set-metacontinuation-frame-traces! (car mc) traces) + traces)])) + +;; ---------------------------------------- +;; Continuation-mark keys: impersonators, and chaperones + +(define-record-type (continuation-mark-key create-continuation-mark-key authentic-continuation-mark-key?) + (fields (mutable name))) ; `mutable` ensures that `create-...` allocates + +(define-record continuation-mark-key-impersonator impersonator (get set)) +(define-record continuation-mark-key-chaperone chaperone (get set)) + +(define make-continuation-mark-key + (case-lambda + [() (make-continuation-mark-key (gensym))] + [(name) (create-continuation-mark-key name)])) + +(define (continuation-mark-key? v) + (or (authentic-continuation-mark-key? v) + (and (impersonator? v) + (authentic-continuation-mark-key? (impersonator-val v))))) + +;; Like `intmap-set`, but handles continuation-mark-key impersonators +(define (intmap-set/cm-key ht k v) + (cond + [(and (impersonator? k) + (authentic-continuation-mark-key? (impersonator-val k))) + (let loop ([k k] [v v]) + (cond + [(or (continuation-mark-key-impersonator? k) + (continuation-mark-key-chaperone? k)) + (let ([new-v (|#%app| + (if (continuation-mark-key-impersonator? k) + (continuation-mark-key-impersonator-set k) + (continuation-mark-key-chaperone-set k)) + v)]) + (unless (or (continuation-mark-key-impersonator? k) + (chaperone-of? new-v v)) + (raise-chaperone-error 'with-continuation-mark "value" v new-v)) + (loop (impersonator-next k) new-v))] + [(impersonator? k) + (loop (impersonator-next k) v)] + [else + (intmap-set ht k v)]))] + [else (intmap-set ht k v)])) + +;; Extracts the key and converts the wrapper functions into +;; a single function: +(define (extract-continuation-mark-key-and-wrapper who k) + (cond + [(and (impersonator? k) + (authentic-continuation-mark-key? (impersonator-val k))) + (values + (impersonator-val k) + (let loop ([k k]) + (cond + [(or (continuation-mark-key-impersonator? k) + (continuation-mark-key-chaperone? k)) + (let ([get (if (continuation-mark-key-impersonator? k) + (continuation-mark-key-impersonator-get k) + (continuation-mark-key-chaperone-get k))] + [get-rest (loop (impersonator-next k))]) + (lambda (v) + (let* ([v (get-rest v)] + [new-v (|#%app| get v)]) + (unless (or (continuation-mark-key-impersonator? k) + (chaperone-of? new-v v)) + (raise-chaperone-error who "value" v new-v)) + new-v)))] + [(impersonator? k) + (loop (impersonator-next k))] + [else + (lambda (v) v)])))] + [else + (values k (lambda (v) v))])) + +(define (map/2-values f l) + (cond + [(null? l) (values '() '())] + [else + (let-values ([(a b) (f (car l))]) + (let-values ([(a-r b-r) (map/2-values f (cdr l))]) + (values (cons a a-r) (cons b b-r))))])) + +(define (impersonate-continuation-mark-key key get set . props) + (do-impersonate-continuation-mark-key 'impersonate-continuation-mark-key + key get set props + make-continuation-mark-key-impersonator)) + +(define (chaperone-continuation-mark-key key get set . props) + (do-impersonate-continuation-mark-key 'chaperone-continuation-mark-key + key get set props + make-continuation-mark-key-chaperone)) + +(define (do-impersonate-continuation-mark-key who + key get set props + make-continuation-mark-key-impersonator) + (check who continuation-mark-key? key) + (check who (procedure-arity-includes/c 1) get) + (check who (procedure-arity-includes/c 1) set) + (make-continuation-mark-key-impersonator (strip-impersonator key) + key + (add-impersonator-properties who + props + (if (impersonator? key) + (impersonator-props key) + empty-hasheq)) + get + set)) + +;; ---------------------------------------- +;; Continuation prompt tags: impersonators, and chaperones + +(define (continuation-prompt-tag? v) + (or (authentic-continuation-prompt-tag? v) + (and (impersonator? v) + (authentic-continuation-prompt-tag? (impersonator-val v))))) + +(define-record continuation-prompt-tag-impersonator impersonator (procs)) +(define-record continuation-prompt-tag-chaperone chaperone (procs)) + +(define-record continuation-prompt-tag-procs (handler abort cc-guard cc-impersonate)) + +(define (continuation-prompt-tag-impersonator-or-chaperone? tag) + (or (continuation-prompt-tag-impersonator? tag) + (continuation-prompt-tag-chaperone? tag))) + +(define (continuation-prompt-tag-impersonator-or-chaperone-procs tag) + (if (continuation-prompt-tag-impersonator? tag) + (continuation-prompt-tag-impersonator-procs tag) + (continuation-prompt-tag-chaperone-procs tag))) + +(define (impersonate-prompt-tag tag handler abort . args) + (do-impersonate-prompt-tag 'impersonate-prompt-tag tag handler abort args + make-continuation-prompt-tag-impersonator)) + +(define (chaperone-prompt-tag tag handler abort . args) + (do-impersonate-prompt-tag 'chaperone-prompt-tag tag handler abort args + make-continuation-prompt-tag-chaperone)) + + +(define (do-impersonate-prompt-tag who tag handler abort args + make-continuation-prompt-tag-impersonator) + (check who continuation-prompt-tag? tag) + (check who procedure? handler) + (check who procedure? abort) + (let* ([cc-guard (and (pair? args) + (procedure? (car args)) + (car args))] + [args (if cc-guard (cdr args) args)] + [callcc-impersonate (and (pair? args) + (procedure? (car args)) + (car args))] + [args (if callcc-impersonate (cdr args) args)]) + (when callcc-impersonate + (check who (procedure-arity-includes/c 1) callcc-impersonate)) + (make-continuation-prompt-tag-impersonator + (strip-impersonator tag) + tag + (add-impersonator-properties who + args + (if (impersonator? tag) + (impersonator-props tag) + empty-hasheq)) + (make-continuation-prompt-tag-procs handler abort cc-guard (or callcc-impersonate values))))) + +(define (apply-prompt-tag-interposition who at-when what + wrapper args chaperone?) + (call-with-values (lambda () (apply wrapper args)) + (lambda new-args + (unless (= (length args) (length new-args)) + (raise-result-arity-error at-when (length args) new-args)) + (when chaperone? + (for-each (lambda (arg new-arg) + (unless (chaperone-of? new-arg arg) + (raise-chaperone-error who what arg new-arg))) + args new-args)) + new-args))) + +(define (wrap-handler-for-impersonator tag handler) + (let loop ([tag tag]) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([handler (loop (impersonator-next tag))] + [h (continuation-prompt-tag-procs-handler + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (lambda args + (apply handler + (apply-prompt-tag-interposition 'call-with-continuation-prompt + "use of prompt-handler redirecting procedure" + "prompt-handler argument" + h args chaperone?))))] + [(impersonator? tag) + (loop (impersonator-next tag))] + [else handler]))) + +(define (apply-impersonator-abort-wrapper tag args) + (let loop ([tag tag] [args args]) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([a (continuation-prompt-tag-procs-abort + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (loop (impersonator-next tag) + (apply-prompt-tag-interposition 'abort-current-continuation + "use of prompt-abort redirecting procedure" + "prompt-abort argument" + a args chaperone?)))] + [(impersonator? tag) + (loop (impersonator-next tag) args)] + [else args]))) + +(define (activate-and-wrap-cc-guard-for-impersonator! tag) + (assert-in-uninterrupted) + (current-metacontinuation + (let loop ([mc (current-metacontinuation)]) + (cond + [(null? mc) mc] + [(eq? (strip-impersonator tag) + (strip-impersonator (metacontinuation-frame-tag (car mc)))) + (let* ([mf (car mc)] + [mf-tag (metacontinuation-frame-tag mf)] + [mf-cc-guard (metacontinuation-frame-cc-guard mf)]) + (cond + [(or (continuation-prompt-tag-impersonator-or-chaperone? tag) + (and (continuation-prompt-tag-impersonator-or-chaperone? mf-tag) + (not mf-cc-guard))) + (cons (metacontinuation-frame-update-cc-guard + mf + (wrap-cc-guard-for-impersonator tag + (or mf-cc-guard + (compose-cc-guard-for-impersonator mf-tag values)))) + (cdr mc))] + [else mc]))] + [else + (let ([r (loop (cdr mc))]) + (if (eq? r (cdr mc)) + mc + (cons (car mc) r)))])))) + +(define (compose-cc-guard-for-impersonator tag guard) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([cc-guard (continuation-prompt-tag-procs-cc-guard + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (let ([guard (compose-cc-guard-for-impersonator (impersonator-next tag) + guard)]) + (cond + [cc-guard + (lambda args + (apply guard + (apply-prompt-tag-interposition 'call-with-continuation-prompt + "use of `call/cc` result guard" + "prompt-result argument" + cc-guard args chaperone?)))] + [else guard])))] + [(impersonator? tag) + (compose-cc-guard-for-impersonator (impersonator-next tag) guard)] + [else guard])) + +(define (wrap-cc-guard-for-impersonator tag cc-guard) + (assert-in-uninterrupted) + (cond + [(continuation-prompt-tag-impersonator-or-chaperone? tag) + (let ([cc-impersonate (continuation-prompt-tag-procs-cc-impersonate + (continuation-prompt-tag-impersonator-or-chaperone-procs tag))] + [chaperone? (continuation-prompt-tag-chaperone? tag)]) + (let ([cc-guard (wrap-cc-guard-for-impersonator (impersonator-next tag) cc-guard)]) + (let ([new-cc-guard (call-with-continuation-barrier + (lambda () + (end-uninterrupted 'cc-guard) + (begin0 + (|#%app| cc-impersonate cc-guard) + (start-uninterrupted 'cc-guard))))]) + (when chaperone? + (unless (chaperone-of? new-cc-guard cc-guard) + (raise-chaperone-error 'call-with-current-continuation + "continuation-result guard" + cc-guard + new-cc-guard))) + new-cc-guard)))] + [(impersonator? tag) + (wrap-cc-guard-for-impersonator (impersonator-next tag) cc-guard)] + [else cc-guard])) + +;; ---------------------------------------- + +(define-virtual-register current-winders '()) + +(define-record winder (depth k pre post mark-stack)) + +;; Jobs for `dynamic-wind`: + +;; 1. Set the mark stack on entry and exit to the saved mark stack. +;; The saved mark stack is confined to the current metacontinuation +;; frame, so it's ok to use it if the current continuation is later +;; applied to a different metacontinuation. + +;; 2. Start and end uninterrupted regions on the boundaries of +;; transitions between thunks. + +;; 3. Perform a built-in `(parameterize-break #f ...)` around the pre +;; and post thunks. This break parameterization needs to be built +;; in so that it's put in place before exiting the uninterrupted region, +;; but it assumes a particular implementation of break +;; parameterizations. + +(define (dynamic-wind pre thunk post) + ((call/cc + (lambda (k) + (let* ([winders (current-winders)] + [winder (make-winder (if (null? winders) + 0 + (fx+ 1 (winder-depth (car winders)))) + k + pre + post + (current-mark-stack))]) + (start-uninterrupted 'dw) + (begin + (call-winder-thunk 'dw-pre pre) + (current-winders (cons winder winders)) + (end-uninterrupted/call-hook 'dw-body) + (call-with-values thunk + (lambda args + (start-uninterrupted 'dw-body) + (current-winders winders) + (call-winder-thunk 'dw-post post) + (end-uninterrupted/call-hook 'dw) + (lambda () (apply values args)))))))))) + +(define (call-winder-thunk who thunk) + (call/cm/nontail + break-enabled-key (make-thread-cell #f #t) + (lambda () + (end-uninterrupted who) + (thunk) + (start-uninterrupted who)))) + +(define (wind-in winders k) + (do-wind 'dw-pre winders winder-pre k)) + +(define (wind-out k) + (do-wind 'dw-post (current-winders) winder-post k)) + +(define (do-wind who winders winder-thunk k) + (assert-in-uninterrupted) + (let ([winder (car winders)] + [winders (cdr winders)]) + (current-winders winders) + (current-mark-stack (winder-mark-stack winder)) + (let ([thunk (winder-thunk winder)]) + ((winder-k winder) + (lambda () + (call-winder-thunk who thunk) + (k)))))) + +(define (wind-to dest-winders done-k retry-k) + (let ([starting-metacontinuation (current-metacontinuation)]) + (let loop ([rev-dest-winders-head '()] + [dest-winders-tail dest-winders]) + (cond + [(and retry-k + (not (eq? starting-metacontinuation (current-metacontinuation)))) + (retry-k)] + [else + (let ([winders (current-winders)]) + (cond + [(same-winders? winders dest-winders-tail) + ;; No winders to leave + (cond + [(null? rev-dest-winders-head) + (done-k)] + [else + ;; Go in one winder + (let ([new-winders (cons (car rev-dest-winders-head) winders)] + [rev-dest-winders-head (cdr rev-dest-winders-head)]) + (wind-in new-winders + (lambda () + (current-winders new-winders) + (loop rev-dest-winders-head new-winders))))])] + [(or (null? dest-winders-tail) + (and (pair? winders) + (> (winder-depth (car winders)) (winder-depth (car dest-winders-tail))))) + ;; Go out by one winder + (wind-out (lambda () (loop rev-dest-winders-head dest-winders-tail)))] + [else + ;; Move a dest winder from tail to head: + (loop (cons (car dest-winders-tail) rev-dest-winders-head) + (cdr dest-winders-tail))]))])))) + +(define (same-winders? winders dest-winders-tail) + (or (and (null? winders) + (null? dest-winders-tail)) + (and (pair? winders) + (pair? dest-winders-tail) + (eq? (car winders) (car dest-winders-tail))))) + +;; ---------------------------------------- + +(define (raise-continuation-error who msg) + (raise + (|#%app| + exn:fail:contract:continuation + (string-append (symbol->string who) ": " msg) + (current-continuation-marks)))) + +;; ---------------------------------------- +;; Breaks + +(define (call-with-break-disabled thunk) + (call/cm + break-enabled-key (make-thread-cell #f #t) + thunk)) + +;; Some points where we jump out of uninterrupted mode are also points +;; where we might jump to a context where breaks are allowed. The +;; `continuation-mark-change-hook` function allows a thread scheduler to +;; inject a check at those points. +(define (end-uninterrupted/call-hook who) + (end-uninterrupted who) + (break-enabled-transition-hook)) + +(define break-enabled-transition-hook void) + +(define (set-break-enabled-transition-hook! proc) + (set! break-enabled-transition-hook proc)) + +;; ---------------------------------------- +;; Metacontinuation swapping for engines + +(define-record saved-metacontinuation (mc system-winders exn-state)) + +(define empty-metacontinuation (make-saved-metacontinuation '() '() (create-exception-state))) + +;; Similar to `call-with-current-continuation` plus +;; applying an old continuation, but does not run winders; +;; this operation makes sense for thread or engine context +;; switches +(define (swap-metacontinuation saved proc) + (cond + [(current-system-wind-start-k) + => (lambda (k) (swap-metacontinuation-with-system-wind saved proc k))] + [else + (call-in-empty-metacontinuation-frame + #f + fail-abort-to-delimit-continuation + #f ; don't try to shift continuation marks + (lambda () + (let ([now-saved (make-saved-metacontinuation + (current-metacontinuation) + (#%$current-winders) + (current-exception-state))]) + (current-metacontinuation (saved-metacontinuation-mc saved)) + (#%$current-winders (saved-metacontinuation-system-winders saved)) + (current-exception-state (saved-metacontinuation-exn-state saved)) + (current-empty-k #f) + (set! saved #f) ; break link for space safety + (proc now-saved))))])) + +;; ---------------------------------------- + +;; In "system-wind" mode for the current metacontinuation frame, run +;; the frame's winders when jumping out of the frame or back in, +;; because the frame uses host-Scheme parameters and/or `fluid-let`. +;; For example, jumping out/in the host compiler needs to save/restore +;; compiler state. +(define-virtual-register current-system-wind-start-k #f) + +;; During `call-with-system-wind`, the current metacontinuation frame +;; must remain as the most recent one, so that `swap-metacontinuation` +;; can capture the system-wind part +(define (call-with-system-wind proc) + ((call/cc + (lambda (k) + (current-system-wind-start-k k) + (#%dynamic-wind + void + (lambda () + (call-with-values + proc + (lambda args + (lambda () + (apply values args))))) + (lambda () (current-system-wind-start-k #f))))))) + +(define (swap-metacontinuation-with-system-wind saved proc start-k) + (current-system-wind-start-k #f) + (call/cc + (lambda (system-wind-k) ; continuation with system `dynamic-wind` behavior + ;; escape to starting point, running winders, before + ;; capturing the rest of the metacontinuation: + (start-k (lambda () + (let ([prefix (swap-metacontinuation saved proc)]) + (current-system-wind-start-k start-k) + (system-wind-k prefix))))))) + +(define (assert-not-in-system-wind) + (CHECK-uninterrupted + (when (current-system-wind-start-k) + (internal-error 'not-in-system-wind "assertion failed")))) diff --git a/racket/src/cs/rumble/correlated.ss b/racket/src/cs/rumble/correlated.ss new file mode 100644 index 0000000000..543b5237fc --- /dev/null +++ b/racket/src/cs/rumble/correlated.ss @@ -0,0 +1,102 @@ + +;; This correlated-like layer is meant to be for just source locations +;; and properties that the compiler might inspect. It's exported as +;; `correlated?`, etc., from `racket/linklet`, but as `syntax?`, etc. +;; from '#%kernel. + +;; Unlike the real syntax-object layer, a correlated object is not +;; required to have correlated objects inside. + +(define-record correlated (e srcloc props)) + +(define/who (datum->correlated ignored datum src) + (check who + :test (or (not src) (correlated? src) (srcloc? src) (encoded-srcloc? src)) + :contract (string-append "(or #f syntax? srcloc?\n" + " (list/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f))\n" + " (vector/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)))") + src) + (if (correlated? datum) + datum + (make-correlated datum (extract-srcloc src) empty-hasheq))) + +(define (correlated->datum e) + (cond + [(correlated? e) (correlated->datum (correlated-e e))] + [(pair? e) (let ([a (correlated->datum (car e))] + [d (correlated->datum (cdr e))]) + (if (and (eq? a (car e)) + (eq? d (cdr e))) + e + (cons a d)))] + [else e])) + +(define/who (correlated-property-symbol-keys v) + (check who correlated? v) + (hash-map (correlated-props v) (lambda (k v) k))) + +(define/who correlated-property + (case-lambda + [(v k) + (check who correlated? v) + (hash-ref (correlated-props v) k #f)] + [(v k val) + (check who correlated? v) + (make-correlated (correlated-e v) + (correlated-srcloc v) + (hash-set (correlated-props v) k val))])) + +(define/who (correlated-srcloc-field who v srcloc-x) + (check who correlated? v) + (let ([s (correlated-srcloc v)]) + (and s (srcloc-x s)))) + +(define (correlated-source v) + (correlated-srcloc-field 'correlated-source v srcloc-source)) +(define (correlated-line v) + (correlated-srcloc-field 'correlated-line v srcloc-line)) +(define (correlated-column v) + (correlated-srcloc-field 'correlated-column v srcloc-column)) +(define (correlated-position v) + (correlated-srcloc-field 'correlated-position v srcloc-position)) +(define (correlated-span v) + (correlated-srcloc-field 'correlated-span v srcloc-span)) + +(define (encoded-srcloc? v) + (or (and (list? v) + (= (length v) 5) + (srcloc-vector? (list->vector v))) + (and (vector? v) + (= (vector-length v) 5) + (srcloc-vector? v)))) + +(define (srcloc-vector? v) + (and (or (not (vector-ref v 1)) + (exact-positive-integer? (vector-ref v 1))) + (or (not (vector-ref v 2)) + (exact-nonnegative-integer? (vector-ref v 2))) + (or (not (vector-ref v 3)) + (exact-positive-integer? (vector-ref v 3))) + (or (not (vector-ref v 4)) + (exact-nonnegative-integer? (vector-ref v 4))))) + +(define (extract-srcloc src) + (cond + [(not src) #f] + [(correlated? src) (correlated-srcloc src)] + [(vector? src) (|#%app| + srcloc + (vector-ref src 0) + (vector-ref src 1) + (vector-ref src 2) + (vector-ref src 3) + (vector-ref src 4))] + [else (apply srcloc src)])) diff --git a/racket/src/cs/rumble/datum.ss b/racket/src/cs/rumble/datum.ss new file mode 100644 index 0000000000..08e00d448a --- /dev/null +++ b/racket/src/cs/rumble/datum.ss @@ -0,0 +1,22 @@ +(define datums (make-weak-hash)) + +(define intern-regexp? #f) +(define (set-intern-regexp?! p) (set! intern-regexp? p)) + +(define (datum-intern-literal v) + (cond + [(or (and (number? v) + ;; `eq?` doesn't work on flonums + (not (flonum? v))) + (string? v) + (char? v) + (bytes? v) + (intern-regexp? v)) + (or (weak-hash-ref-key datums v) + (let ([v (cond + [(string? v) (string->immutable-string v)] + [(bytes? v) (bytes->immutable-bytes v)] + [else v])]) + (hash-set! datums v #t) + v))] + [else v])) diff --git a/racket/src/cs/rumble/define.ss b/racket/src/cs/rumble/define.ss new file mode 100644 index 0000000000..045b2fda6c --- /dev/null +++ b/racket/src/cs/rumble/define.ss @@ -0,0 +1,480 @@ +;; Replace `define` to perform simple function lifting, which avoids +;; having to allocate closures for local loops (i.e., a more +;; Racket-like allocation model). Since it only has to work for +;; Rumble's implementation, the lifter doesn't have to be general or +;; scalable. The lifter transforms unexpanded source expressions, so +;; it needs to recognize all of the forms that are used inside +;; `define` forms. + +;; Only functions bound with named `let`, normal `let` with `lambda`, +;; and `let*` with `lamdba` are lifted, and the lifter assumes that a +;; named `let`'s identifier is used only in application position. +;; Local `define` is not allowed. + +;; To bind a `let`-bound function that is not used only in an +;; application position, wrap it with `escapes-ok`. + +;; If a function F includes a call to a function G, function G has a +;; free variable X, and function F has an argument X, then the lifter +;; doesn't work (and it reports an error). Help the lifter in that +;; case by picking a different name for one of the Xs. + +;; If a "loop" is a non-tail loop or if has many free variables, then +;; lifting may be counterproductive (by making a bad trade for less +;; allocation but slower GCs). Use `define/no-lift` in that case. + +;; Select `define/lift` as the default mode: +(define-syntax (define stx) + (syntax-case stx () + [(_ . r) #'(define/lift . r)])) + +(define-syntax (define/lift stx) + (letrec ([lift-local-functions + ;; Convert `e` to return + ;; (list new-list (list lifted-defn ...)) + ;; The `env` argument is a list of symbols (not identifiers), + ;; and the `binds` argument is a list of syntax bindings + ;; #`(bind-form ([id rhs] ...)) + ;; to be copied over to any lifted form. Also, the `rhs` + ;; of a `bind-form` can contain free-variable and + ;; called-variable information for a previously lifted + ;; function, so that its free variables can be added + ;; as needed to a newly lifted function that calls the + ;; lifted one. + ;; Earlier entries in `binds` shadow later ones, and + ;; entires in `env` shadow `binds` entries. + (lambda (e env binds mutated) + (syntax-case e (quote begin lambda case-lambda + let letrec let* let-values + fluid-let-syntax let-syntax + cond define set!) + [(define . _) + (syntax-error e "don't use nested `define`:")] + [(quote _) + (list e '())] + [(begin e) + (lift-local-functions #'e env binds mutated)] + [(seq e ...) + (and (symbol? (syntax->datum #'seq)) + (or (free-identifier=? #'seq #'begin) + (free-identifier=? #'seq #'begin0) + (free-identifier=? #'seq #'if))) + (with-syntax ([((new-e lifts) ...) + (map (lambda (e) + (lift-local-functions e env binds mutated)) + #'(e ...))]) + (list #'(seq new-e ...) + (append-all #'(lifts ...))))] + [(lambda args e ...) + (with-syntax ([(body lifts) + (lift-local-functions #'(begin e ...) + (add-args env #'args) + binds + mutated)]) + #`((lambda args body) + lifts))] + [(case-lambda [args e ...] ...) + (with-syntax ([((body lifts) ...) + (map (lambda (args body) + (lift-local-functions body + (add-args env args) + binds + mutated)) + #'(args ...) + #'((begin e ...) ...))]) + (list #'(case-lambda [args body] ...) + (append-all #'(lifts ...))))] + [(let loop ([arg val] ...) e ...) + (symbol? (syntax->datum #'loop)) + (generate-lifted env binds mutated + #'loop ; name + #'(arg ...) ; argument names + #'(begin e ...) ; body + #t ; recursive + (lambda (defn-to-lift new-loop-name free-vars wrap-bind-of-lifted) + (with-syntax ([(free-var ...) free-vars] + [new-loop-name new-loop-name] + [defn-to-lift defn-to-lift]) + #`((new-loop-name val ... free-var ...) + (defn-to-lift)))))] + [(let* () e ...) + (lift-local-functions #`(begin e ...) env binds mutated)] + [(let* ([id rhs] . more-binds) e ...) + (lift-local-functions #`(let ([id rhs]) (let* more-binds e ...)) env binds mutated)] + [(let . _) + (lift-local-functions-in-let/lift-immediate e env binds mutated)] + [(letrec . _) + (lift-local-functions-in-let e env binds mutated #t)] + [(let-values ([(id ...) rhs] ...) e ...) + (with-syntax ([((new-rhs lifts) ...) + (map (lambda (rhs) + (lift-local-functions rhs env binds mutated)) + #'(rhs ...))]) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) + (add-args env (#%apply append #'((id ...) ...))) + binds + mutated)]) + (list #'(let-values ([(id ...) new-rhs] ...) new-body) + (append #'body-lifts (append-all #'(lifts ...))))))] + [(fluid-let-syntax ([id rhs] ...) e ...) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) + (remove-args env #'(id ...)) + (cons #'(fluid-let-syntax ([id rhs] ...)) + binds) + mutated)]) + #`((fluid-let-syntax ([id rhs] ...) new-body) + body-lifts))] + [(let-syntax ([id rhs] ...) e ...) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) + (remove-args env #'(id ...)) + (cons #'(let-syntax ([id rhs] ...)) + binds) + mutated)]) + #`((let-syntax ([id rhs] ...) new-body) + body-lifts))] + [(cond [e ...] ...) + (with-syntax ([(((new-e lifts) ...) ...) + (map (lambda (es) + (map (lambda (e) + (lift-local-functions e env binds mutated)) + es)) + #'((e ...) ...))]) + (list #'(cond [new-e ...] ...) + (append-all (append-all #'((lifts ...) ...)))))] + [(set! id rhs) + (track-mutated! mutated #'id 'mutated) + (with-syntax ([(new-rhs lifts) (lift-local-functions #'rhs env binds mutated)]) + #'((set! id new-rhs) + lifts))] + [(rator rand ...) + (with-syntax ([((new-e lifts) ...) + (map (lambda (e) + (lift-local-functions e env binds mutated)) + #'(rator rand ...))]) + (list #'(new-e ...) + (append-all #'(lifts ...))))] + [_ (list e '())]))] + + [lift-local-functions-in-let + (lambda (e env binds mutated rec?) + (syntax-case e () + [(form ([id rhs] ...) e ...) + (let ([body-env (add-args env #'(id ...))]) + (with-syntax ([((new-rhs lifts) ...) + (map (lambda (rhs) + (lift-local-functions rhs (if rec? body-env env) binds mutated)) + #'(rhs ...))]) + (with-syntax ([(new-body body-lifts) + (lift-local-functions #'(begin e ...) body-env binds mutated)]) + (list #'(form ([id new-rhs] ...) new-body) + (append #'body-lifts (append-all #'(lifts ...)))))))]))] + + [lift-local-functions-in-let/lift-immediate + ;; Split `lambda` bindings for other bindings, then lift the `lambda`s + (lambda (e env binds mutated) + (syntax-case e () + [(form ([id rhs] ...) . body) + (let ([body-env (add-args env #'(id ...))]) + (let-values ([(proc-binds other-binds) + (split-proc-binds #'([id rhs] ...))]) + (cond + [(null? proc-binds) + (lift-local-functions-in-let e env binds mutated #f)] + [else + (let loop ([proc-binds proc-binds] + [e (with-syntax ([other-binds other-binds]) + #'(form other-binds . body))] + [lifts '()]) + (cond + [(null? proc-binds) + (with-syntax ([(new-e e-lifts) (lift-local-functions e env binds mutated)]) + (list #'new-e + (append lifts #'e-lifts)))] + [else + (with-syntax ([[id (_ rhs-args rhs-e ...)] (car proc-binds)]) + (generate-lifted + env binds mutated + #'id ; name + #'rhs-args ; argument names + #'(begin rhs-e ...) ; body + #f ; not recursive + (lambda (defn-to-lift new-id free-vars wrap-bind-of-lifted) + (loop (cdr proc-binds) + (wrap-bind-of-lifted e) + (cons defn-to-lift lifts)))))]))])))]))] + + [split-proc-binds + ;; Helper to split `lambda` from non-`lambda` + (lambda (form-binds) + (let loop ([binds form-binds] [proc-binds '()] [other-binds '()]) + (cond + [(null? binds) + (values (reverse proc-binds) + (reverse other-binds))] + [else + (syntax-case (car binds) (lambda) + [[_ (lambda (arg ...) . _)] + (loop (cdr binds) + (cons (car binds) proc-binds) + other-binds)] + [_ + (loop (cdr binds) + proc-binds + (cons (car binds) other-binds))])])))] + + [generate-lifted + ;; Takes pieces for a function to lift an generates the lifted version + (lambda (env binds mutated name args body rec? k) + (let* ([ids (if rec? (cons name args) args)] + [binds (filter-shadowed-binds binds (add-args env ids))] + [body-env (remove-args env ids)] + [direct-free-vars (extract-free-vars body body-env)] + [direct-called-vars (extract-free-vars body (binds-to-env binds))]) + (for-each (lambda (free-var) (track-mutated! mutated free-var 'must-not)) direct-free-vars) + (let-values ([(free-vars called-vars) (extract-bind-vars binds body-env direct-free-vars direct-called-vars)]) + (let ([free-vars (unique-ids free-vars)] + [called-vars (unique-ids called-vars)]) + (with-syntax ([(free-var ...) free-vars] + [(called-var ...) called-vars] + [new-name (datum->syntax + name + (chez:gensym (chez:symbol->string (syntax->datum name))))] + [body (let loop ([body body] + [binds binds]) + (cond + [(null? binds) body] + [else (with-syntax ([(form form-binds) (car binds)] + [body body]) + (loop #'(form form-binds body) + (cdr binds)))]))] + [name name] + [(arg ...) args]) + (let ([wrap-bind-of-lifted + (lambda (body) + (with-syntax ([body body]) + #'(let-syntax ([name (begin ; this pattern is recognized by `extract-bind-free-vars` + '(FREE-VARS free-var ...) + '(CALLED-VARS called-var ...) + (lambda (stx) + (syntax-case stx () + [(_ call-arg (... ...)) + #'(new-name call-arg (... ...) free-var ...)] + [_ (syntax-error stx "lifted procedure escapes:")])))]) + body)))]) + (with-syntax ([wrapped-body (if rec? + (wrap-bind-of-lifted #'body) + #'body)]) + (k #`(define/lift new-name + (lambda (arg ... free-var ...) + wrapped-body)) + #'new-name + free-vars + wrap-bind-of-lifted))))))))] + + [extract-free-vars + ;; For an expression that is going to be lifted, find all the free + ;; variables so they can be added to call sites of the enclosing + ;; lifted function. Only variables in `env` are candidate free + ;; variables. + (lambda (e env) + (syntax-case e (quote begin lambda case-lambda + let* let letrec let-values + fluid-let-syntax let-syntax + set!) + [id + (symbol? (syntax->datum #'id)) + (if (chez:memq (syntax->datum #'id) env) + (list #'id) + '())] + [(set! id rhs) + (if (chez:memq (syntax->datum #'id) env) + (syntax-error #'id "cannot mutate variable added to lifted procedure:") + (extract-free-vars #'rhs env))] + [(quote _) '()] + [(seq e ...) + (and (symbol? (syntax->datum #'seq)) + (or (free-identifier=? #'seq #'begin) + (free-identifier=? #'seq #'begin0) + (free-identifier=? #'seq #'if) + (free-identifier=? #'seq #'cond))) + (#%apply append (map (lambda (e) + (extract-free-vars e env)) + #'(e ...)))] + [(lambda args e ...) + (extract-free-vars #'(begin e ...) + (remove-args env #'args))] + [(case-lambda [args e ...] ...) + (#%apply + append + (map (lambda (args body) + (extract-free-vars body (remove-args env args))) + #'(args ...) + #'((begin e ...) ...)))] + [(let loop ([arg val] ...) e ...) + (symbol? (syntax->datum #'loop)) + (append + (extract-free-vars #'(begin val ...) env) + (extract-free-vars #'(begin e ...) + (remove-args env #'(loop arg ...))))] + [(let* () e ...) + (extract-free-vars #`(begin e ...) env)] + [(let* ([id rhs] . binds) e ...) + (extract-free-vars #`(let ([id rhs]) (let* binds e ...)) env)] + [(let ([id rhs] ...) e ...) + (append + (extract-free-vars #'(begin rhs ...) env) + (extract-free-vars #'(begin e ...) (remove-args env #'(id ...))))] + [(let-values ([(id ...) rhs] ...) e ...) + (append + (extract-free-vars #'(begin rhs ...) env) + (extract-free-vars #'(begin e ...) (remove-args env (#%apply append #'((id ...) ...)))))] + [(letrec ([id rhs] ...) e ...) + (extract-free-vars #'(begin rhs ... e ...) (remove-args env #'(id ...)))] + [(fluid-let-syntax ([id rhs] ...) e ...) + (extract-free-vars #'(begin e ...) (remove-args env #'(id ...)))] + [(let-syntax ([id rhs] ...) e ...) + (extract-free-vars #'(begin e ...) (remove-args env #'(id ...)))] + [(rator rand ...) + (extract-free-vars #'(begin rator rand ...) env)] + [_ '()]))] + + [filter-shadowed-binds + ;; Simplify `binds` to drop bindings that are shadowned by + ;; `env` or by earlier bindings + (lambda (binds env) + (let loop ([binds binds] + [env env]) + (cond + [(null? binds) '()] + [else (with-syntax ([(form ([id rhs] ...)) (car binds)]) + (with-syntax ([([id rhs] ...) + ;; Filter any `ids` that are shadowed + (let loop ([ids #'(id ...)] [rhss #'(rhs ...)]) + (cond + [(null? ids) '()] + [(chez:memq (syntax->datum (car ids)) env) + (loop (cdr ids) (cdr rhss))] + [else (cons (list (car ids) (car rhss)) + (loop (cdr ids) (cdr rhss)))]))]) + (cons #'(form ([id rhs] ...)) + (loop (cdr binds) + (add-args env #'(id ...))))))])))] + + [binds-to-env + ;; Extract the identifiers of `binds` into an environment + (lambda (binds) + (let loop ([binds binds] [env '()]) + (cond + [(null? binds) env] + [else + (loop (cdr binds) + (syntax-case (car binds) () + [(form ([id rhs] ...)) + (add-args env #'(id ...))]))])))] + + [extract-bind-vars + ;; Add new variables to `free-vars` and `called-vars` based on + ;; entries in `all-binds` that will be called (because they're + ;; referenced in `called-vars`). A fixpoint calculation is needed, + ;; since calling a lifted function may add new free variables and + ;; new called variables. + (lambda (all-binds env free-vars called-vars) + (let loop ([binds all-binds] [added? #f] [free-vars free-vars] [called-vars called-vars] [did-ids '()]) + (cond + [(null? binds) (if added? + ;; Loop to fixpoint + (loop all-binds #f free-vars called-vars did-ids) + ;; Found fixpoint + (values free-vars called-vars))] + [else (syntax-case (car binds) (FREE-VARS CALLED-VARS begin quote) + [(form ([id (begin + '(FREE-VARS free-var ...) + '(CALLED-VARS called-var ...) + _)])) + (and (id-member? #'id called-vars) + (not (chez:memq (syntax->datum #'id) did-ids))) + (loop (cdr binds) + #t + (append (#%map (lambda (free-var) + (if (chez:memq (syntax->datum free-var) env) + free-var + (syntax-error free-var "wrong variable at call site; lifter needs your help by renaming:"))) + #'(free-var ...)) + free-vars) + (append #'(called-var ...) + called-vars) + (cons (syntax->datum #'id) did-ids))] + [_ + ;; Not a lifted-function binding + (loop (cdr binds) added? free-vars called-vars did-ids)])])))] + + [add-args + ;; Add identifiers (accomdating rest args) to an environment + (lambda (env args) + (let add-args ([env env] [args (syntax->datum args)]) + (cond + [(null? args) env] + [(pair? args) (add-args (cons (car args) env) + (cdr args))] + [else (cons args env)])))] + + [remove-args + ;; Remove identifiers (accomdating rest args) from an environment + (lambda (env args) + (let remove-args ([env env] [args (syntax->datum args)]) + (cond + [(null? args) env] + [(pair? args) (remove-args (#%remq (car args) env) + (cdr args))] + [else (#%remq args env)])))] + + [track-mutated! + (lambda (mutated id state) + (let ([old-state (hashtable-ref mutated (syntax->datum id) #f)]) + (when (and old-state + (not (eq? old-state state))) + (syntax-error id "lift seems to need to close over mutated variable:")) + (hashtable-set! mutated (syntax->datum id) state)))] + + [unique-ids + (lambda (l) + (let loop ([l l]) + (cond + [(null? l) '()] + [(id-member? (car l) (cdr l)) + (loop (cdr l))] + [else (cons (car l) (loop (cdr l)))])))] + + [id-member? + (lambda (id l) + (let loop ([l l]) + (cond + [(null? l) #f] + [else (or (free-identifier=? id (car l)) + (loop (cdr l)))])))] + + [append-all + (lambda (l) + (#%apply append l))]) + + ;; Traverse the right-hand side of a definition to extract lifts + (syntax-case stx () + [(_ (id . args) e ...) + #'(define/lift id (lambda args e ...))] + [(_ id rhs) + (with-syntax ([(new-rhs (lift ...)) (lift-local-functions + #'rhs + '() + '() + (make-eq-hashtable))]) + #'(define/no-lift id + (let () + lift ... + new-rhs)))]))) + +(define-syntax (escapes-ok stx) + (syntax-case stx () + [(_ e) #'e])) diff --git a/racket/src/cs/rumble/engine.ss b/racket/src/cs/rumble/engine.ss new file mode 100644 index 0000000000..d0fa66c215 --- /dev/null +++ b/racket/src/cs/rumble/engine.ss @@ -0,0 +1,151 @@ +;; Like Chez's engine API, but +;; - works with delimited-continuations extensions in "control.ss" +;; - doesn't run winders when suspending or resuming an engine +;; - accepts an extra "prefix" argument to run code within an engine +;; just before resuming the engine's continuation + +;; Don't mix Chez engines with this implementation, because we take +;; over the timer. + +(define-record engine-state (mc complete expire thread-cell-values init-break-enabled-cell reset-handler)) + +(define-virtual-register current-engine-state #f) + +(define (set-ctl-c-handler! proc) + (keyboard-interrupt-handler (case-lambda + [() (proc 'break)] + [(kind) (proc kind)]))) +(define (get-ctl-c-handler) + (keyboard-interrupt-handler)) + +(define (engine-exit v) + (chez:exit v)) + +(define (set-engine-exit-handler! proc) + (set! engine-exit proc)) + +(define (make-engine thunk init-break-enabled-cell empty-config?) + (let ([paramz (if empty-config? + empty-parameterization + (current-parameterization))]) + (create-engine empty-metacontinuation + (lambda (prefix) + (with-continuation-mark + parameterization-key paramz + (begin + (prefix) + (call-with-values (lambda () (|#%app| thunk)) engine-return)))) + (if empty-config? + (make-empty-thread-cell-values) + (new-engine-thread-cell-values)) + init-break-enabled-cell))) + +(define (create-engine to-saves proc thread-cell-values init-break-enabled-cell) + (case-lambda + ;; For `continuation-marks`: + [() to-saves] + ;; Normal engine case: + [(ticks prefix complete expire) + (start-implicit-uninterrupted 'create) + ((swap-metacontinuation + to-saves + (lambda (saves) + (current-engine-state (make-engine-state saves complete expire thread-cell-values + init-break-enabled-cell (reset-handler))) + (reset-handler (lambda () + (end-uninterrupted 'reset) + (if (current-engine-state) + (engine-return (void)) + (chez:exit)))) + (timer-interrupt-handler engine-block-via-timer) + (end-implicit-uninterrupted 'create) + (set-timer ticks) + (proc prefix))))])) + +(define (engine-block-via-timer) + (cond + [(current-in-uninterrupted) + (pending-interrupt-callback engine-block)] + [else + (engine-block)])) + +(define (engine-block) + (assert-not-in-uninterrupted) + (timer-interrupt-handler void) + (let ([es (current-engine-state)]) + (unless es + (error 'engine-block "not currently running an engine")) + (reset-handler (engine-state-reset-handler es)) + (start-implicit-uninterrupted 'block) + ;; Extra pair of parens around swap is to apply a prefix + ;; function on swapping back in: + ((swap-metacontinuation + (engine-state-mc es) + (lambda (saves) + (end-implicit-uninterrupted 'block) + (current-engine-state #f) + (lambda () ; returned to the `swap-continuation` in `create-engine` + ((engine-state-expire es) + (create-engine + saves + (lambda (prefix) prefix) ; returns `prefix` to the above "((" + (engine-state-thread-cell-values es) + (engine-state-init-break-enabled-cell es))))))))) + +(define (engine-return . args) + (assert-not-in-uninterrupted) + (timer-interrupt-handler void) + (let ([es (current-engine-state)]) + (unless es + (error 'engine-return "not currently running an engine")) + (reset-handler (engine-state-reset-handler es)) + (let ([remain-ticks (set-timer 0)]) + (start-implicit-uninterrupted 'return) + (swap-metacontinuation + (engine-state-mc es) + (lambda (saves) + (current-engine-state #f) + (end-implicit-uninterrupted 'return) + (lambda () ; returned to the `swap-continuation` in `create-engine` + (apply (engine-state-complete es) remain-ticks args))))))) + +(define (make-empty-thread-cell-values) + (make-ephemeron-eq-hashtable)) + +(define root-thread-cell-values (make-empty-thread-cell-values)) + +(define (current-engine-thread-cell-values) + (let ([es (current-engine-state)]) + (if es + (engine-state-thread-cell-values es) + root-thread-cell-values))) + +(define (set-current-engine-thread-cell-values! new-t) + (let ([current-t (current-engine-thread-cell-values)]) + (with-interrupts-disabled + (hash-table-for-each + current-t + (lambda (c v) + (when (thread-cell-preserved? c) + (hashtable-delete! current-t c)))) + (hash-table-for-each + new-t + (lambda (c v) + (hashtable-set! current-t c v)))))) + +(define (new-engine-thread-cell-values) + (let ([current-t (current-engine-thread-cell-values)] + [new-t (make-ephemeron-eq-hashtable)]) + (when current-t + (hash-table-for-each + current-t + (lambda (c v) + (when (thread-cell-preserved? c) + (hashtable-set! new-t c v))))) + new-t)) + +(define (current-engine-init-break-enabled-cell none-v) + (let ([es (current-engine-state)]) + (if es + (engine-state-init-break-enabled-cell es) + none-v))) diff --git a/racket/src/cs/rumble/ephemeron.ss b/racket/src/cs/rumble/ephemeron.ss new file mode 100644 index 0000000000..ba9ca12f41 --- /dev/null +++ b/racket/src/cs/rumble/ephemeron.ss @@ -0,0 +1,17 @@ + +;; A wrapper to hide the pairness of ephemeron pairs: +(define-record-type (ephemeron create-ephemeron ephemeron?) + (fields p)) + +(define (make-ephemeron key val) + (create-ephemeron (ephemeron-cons key val))) + +(define/who ephemeron-value + (case-lambda + [(e) (ephemeron-value e #f)] + [(e gced-v) + (check who ephemeron? e) + (let ([v (cdr (ephemeron-p e))]) + (if (eq? v #!bwp) + gced-v + v))])) diff --git a/racket/src/cs/rumble/equal.ss b/racket/src/cs/rumble/equal.ss new file mode 100644 index 0000000000..5c0b76e44d --- /dev/null +++ b/racket/src/cs/rumble/equal.ss @@ -0,0 +1,225 @@ + +;; Re-implement `equal?` to support impersonators and chaperones + +(define (do-equal? orig-a orig-b mode eql?) + (let equal? ([orig-a orig-a] [orig-b orig-b] [ctx #f]) + (let loop ([a orig-a] [b orig-b]) + (or (eqv? a b) + (cond + [(and (hash-impersonator? a) + (hash-impersonator? b) + (not (eq? mode 'chaperone-of?))) + ;; For immutable hashes, it's ok for the two objects to not be eq, + ;; as long as the interpositions are the same and the underlying + ;; values are `{impersonator,chaperone}-of?`: + (and (eq? (hash-impersonator-procs a) + (hash-impersonator-procs b)) + (loop (impersonator-next a) + (impersonator-next b)))] + [(and (hash-chaperone? a) + (hash-chaperone? b)) + ;; Same as above + (and (eq? (hash-chaperone-procs a) + (hash-chaperone-procs b)) + (loop (impersonator-next a) + (impersonator-next b)))] + [(and (props-impersonator? b) + (not (eq? mode 'chaperone-of?))) + (loop a (impersonator-next b))] + [(props-chaperone? b) + (loop a (impersonator-next b))] + [(and (impersonator? a) + (or (not (eq? mode 'chaperone-of?)) + (chaperone? a))) + (loop (impersonator-next a) b)] + [(impersonator? b) + (cond + [(eq? mode 'impersonator-of?) + ;; stop here, unless `prop:impersonator-of` is relevant + (let ([a2 (extract-impersonator-of mode a)]) + (cond + [a2 (or (check-union-find ctx a b) + (let ([ctx (deeper-context ctx)]) + (equal? a2 b ctx)))] + [else #f]))] + [(and (eq? mode 'chaperone-of?) + (chaperone? b)) + ;; `a` does not include `b`, so give up + #f] + [else + (loop a (impersonator-next b))])] + [(#%vector? a) + (and (#%vector? b) + (or (not (eq? mode 'chaperone-of?)) + (and (immutable-vector? a) + (immutable-vector? b))) + (let ([len (#%vector-length a)]) + (and (fx= len (#%vector-length b)) + (or + (check-union-find ctx a b) + (let ([ctx (deeper-context ctx)]) + (let loop ([i 0]) + (or (fx= i len) + (and (if eql? + (eql? (vector-ref orig-a i) + (vector-ref orig-b i)) + (equal? (vector-ref orig-a i) + (vector-ref orig-b i) + ctx)) + (loop (fx1+ i))))))))))] + [(pair? a) + (and (pair? b) + (or (check-union-find ctx a b) + (if eql? + (and (eql? (car a) (car b)) + (eql? (cdr a) (cdr b))) + (let ([ctx (deeper-context ctx)]) + (and + (equal? (car a) (car b) ctx) + (equal? (cdr a) (cdr b) ctx))))))] + [(#%box? a) + (and (#%box? b) + (or (not (eq? mode 'chaperone-of?)) + (and (immutable-box? a) + (immutable-box? b))) + (or (check-union-find ctx a b) + (if eql? + (eql? (unbox orig-a) (unbox orig-b)) + (let ([ctx (deeper-context ctx)]) + (equal? (unbox orig-a) (unbox orig-b) ctx)))))] + [(record? a) + (and (record? b) + ;; Check for for `prop:impersonator-of` + (let ([a2 (and (not (eq? mode 'chaperone-of?)) + (extract-impersonator-of mode a))] + [b2 (and (eq? mode 'equal?) + (extract-impersonator-of mode b))]) + (cond + [(or a2 b2) + ;; `prop:impersonator-of` takes precedence over + ;; other forms of checking + (or (check-union-find ctx a b) + (let ([ctx (deeper-context ctx)]) + (equal? (or a a2) (or b b2) ctx)))] + [else + ;; No `prop:impersonator-of`, so check for + ;; `prop:equal+hash` or transparency + (let ([rec-equal? (record-equal-procedure a b)]) + (and rec-equal? + (or (check-union-find ctx a b) + (if eql? + (rec-equal? orig-a orig-b eql?) + (let ([ctx (deeper-context ctx)]) + (rec-equal? orig-a orig-b + (lambda (a b) + (equal? a b ctx))))))))])))] + [(and (eq? mode 'chaperone-of?) + ;; Mutable strings and bytevectors must be `eq?` for `chaperone-of?` + (or (mutable-string? a) + (mutable-string? b) + (mutable-bytevector? a) + (mutable-bytevector? b))) + #f] + [else + (#%equal? a b)]))))) + +(define (equal? a b) (do-equal? a b 'equal? #f)) +(define (impersonator-of? a b) (do-equal? a b 'impersonator-of? #f)) +(define (chaperone-of? a b) (do-equal? a b 'chaperone-of? #f)) + +(define/who (equal?/recur a b eql?) + (check who (procedure-arity-includes/c 2) eql?) + (do-equal? a b (lambda (x) #f) eql?)) + +;; ---------------------------------------- + +;; Use a hash table to detect cycles and sharing, +;; but only start using it if a comparison goes +;; deep enough. + +(define (deeper-context ctx) + (cond + [ctx + (let ([v (#%unbox ctx)]) + (when (fixnum? v) + (if (fx= v 0) + (#%set-box! ctx (make-eq-hashtable)) + (#%set-box! ctx (fx1- v))))) + ctx] + [else (box 32)])) + +(define (check-union-find ctx a b) + (cond + [(and ctx + (hashtable? (#%unbox ctx))) + (let ([ht (#%unbox ctx)]) + (let ([av (union-find ht a)] + [bv (union-find ht b)]) + (or (eq? av bv) + (begin + (hashtable-set! ht av bv) + #f))))] + [else #f])) + +(define (union-find ht a) + (let ([av (let loop ([a a]) + (let ([next-a (hashtable-ref ht a #f)]) + (if next-a + (loop next-a) + a)))]) + (unless (eq? av a) + (let loop ([a a]) + (let ([next-a (hashtable-ref ht a #f)]) + (unless (eq? next-a av) + (hashtable-set! ht a next-a) + (loop next-a))))) + av)) + +;; ---------------------------------------- + +;; The `key-equal-hash-code` and `key-equal?` functions allow +;; interposition on key equality through a hash table impersonator. +;; They call `equal-hash-code` or `equal?` unless the current +;; continuation maps `key-equality-wrap-key` to a key-wrapping +;; function. + +(define key-equality-wrap-key (gensym)) + +;; Looking in the continaution is expensive relative to `equal?`, so +;; look in a box as a quick pre-test. Multiple threads may increment +;; the counter in the box, so that's why it's only a pre-test. +(define key-equality-maybe-redirect (box 0)) + +(define (key-equal-hash-code k) + (let ([get-k (and (fx> (unbox key-equality-maybe-redirect) 0) + (continuation-mark-set-first #f key-equality-wrap-key))]) + (if get-k + (with-continuation-mark key-equality-wrap-key #f + (equal-hash-code (get-k k))) + (equal-hash-code k)))) + +(define (key-equal? k1 k2) + (let ([get-k (and (fx> (unbox key-equality-maybe-redirect) 0) + (continuation-mark-set-first #f key-equality-wrap-key))]) + (if get-k + (with-continuation-mark key-equality-wrap-key #f + (equal? (get-k k1) (get-k k2))) + (equal? k1 k2)))) + +(define (call-with-equality-wrap get-k key thunk) + (unsafe-box*-cas+! key-equality-maybe-redirect 1) + (let ([get-k + (if (eq? key none) + get-k + ;; record `(get-k key)` so that we + ;; don't have to compute it multiple + ;; times: + (let ([got-k (get-k key)]) + (lambda (k2) + (if (eq? k2 key) + got-k + (get-k k2)))))]) + (let ([r (with-continuation-mark key-equality-wrap-key get-k + (thunk))]) + (unsafe-box*-cas+! key-equality-maybe-redirect -1) + r))) diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss new file mode 100644 index 0000000000..057c45ee3c --- /dev/null +++ b/racket/src/cs/rumble/error.ss @@ -0,0 +1,747 @@ + +(define raise + (case-lambda + [(v) (raise v #t)] + [(v barrier?) + (if barrier? + (call-with-continuation-barrier + (lambda () + (chez:raise v))) + (chez:raise v))])) + +;; ---------------------------------------- + +(define/who error-print-width + (make-parameter 256 + (lambda (v) + (check who + :test (and (integer? v) + (exact? v) + (>= v 3)) + :contract "(and/c exact-integer? (>=/c 3))" + v) + v))) + +(define/who error-value->string-handler + (make-parameter (lambda (v len) + (cond + [(or (number? v) + (boolean? v) + (string? v) + (symbol? v)) + (chez:format "~s" v)] + [else + "[?error-value->string-handler not ready?]"])) + (lambda (v) + (check who (procedure-arity-includes/c 2) v) + v))) + +(define/who error-print-context-length + (make-parameter 16 + (lambda (v) + (check who exact-nonnegative-integer? v) + v))) + +;; ---------------------------------------- + +(struct exn (message continuation-marks) :guard (lambda (msg cm who) + (check who string? msg) + (check who continuation-mark-set? cm) + (values (string->immutable-string msg) + cm))) +(struct exn:break exn (continuation) :guard (lambda (msg cm k who) + (check who escape-continuation? k) + (values msg cm k))) +(struct exn:break:hang-up exn:break ()) +(struct exn:break:terminate exn:break ()) +(struct exn:fail exn ()) +(struct exn:fail:contract exn:fail ()) +(struct exn:fail:contract:arity exn:fail:contract ()) +(struct exn:fail:contract:divide-by-zero exn:fail:contract ()) +(struct exn:fail:contract:non-fixnum-result exn:fail:contract ()) +(struct exn:fail:contract:continuation exn:fail:contract ()) +(struct exn:fail:contract:variable exn:fail:contract (id) :guard (lambda (msg cm id who) + (check who symbol? id) + (values msg cm id))) +(struct exn:fail:read exn:fail (srclocs) :guard (lambda (msg cm srclocs who) + (check who + :test (and (list srclocs) + (andmap srcloc? srclocs)) + :contract "(listof srcloc?)" + srclocs) + (values msg cm srclocs))) +(struct exn:fail:read:non-char exn:fail:read ()) +(struct exn:fail:read:eof exn:fail:read ()) +(struct exn:fail:filesystem exn:fail ()) +(struct exn:fail:filesystem:exists exn:fail:filesystem ()) +(struct exn:fail:filesystem:version exn:fail:filesystem ()) +(struct exn:fail:filesystem:errno exn:fail:filesystem (errno) :guard (lambda (msg cm errno who) + (check-errno who errno) + (values msg cm errno))) +(struct exn:fail:network exn:fail ()) +(struct exn:fail:network:errno exn:fail:network (errno) :guard (lambda (msg cm errno who) + (check-errno who errno) + (values msg cm errno))) +(struct exn:fail:out-of-memory exn:fail ()) +(struct exn:fail:unsupported exn:fail ()) +(struct exn:fail:user exn:fail ()) + +;; ---------------------------------------- + +(define (raise-arguments-error who what . more) + (unless (symbol? who) + (raise-argument-error 'raise-arguments-error "symbol?" who)) + (unless (string? what) + (raise-argument-error 'raise-arguments-error "string?" what)) + (do-raise-arguments-error who what exn:fail:contract more)) + +(define (do-raise-arguments-error who what exn:fail:contract more) + (raise + (|#%app| + exn:fail:contract + (apply + string-append + (symbol->string who) + ": " + what + (let loop ([more more]) + (cond + [(null? more) '()] + [(string? (car more)) + (cond + [(null? more) + (raise-arguments-error 'raise-arguments-error + "missing value after field string" + "string" + (car more))] + [else + (cons (string-append "\n " + (car more) ": " + (let ([val (cadr more)]) + (if (unquoted-printing-string? val) + (unquoted-printing-string-value val) + (error-value->string val)))) + (loop (cddr more)))])] + [else + (raise-argument-error 'raise-arguments-error "string?" (car more))]))) + (current-continuation-marks)))) + +(define (do-raise-argument-error e-who tag who what pos arg args) + (unless (symbol? who) + (raise-argument-error e-who "symbol?" who)) + (unless (string? what) + (raise-argument-error e-who "string?" what)) + (when pos + (unless (and (integer? pos) + (exact? pos) + (not (negative? pos))) + (raise-argument-error e-who "exact-nonnegative-integer?" pos))) + (raise + (|#%app| + exn:fail:contract + (string-append (symbol->string who) + ": contract violation\n expected: " + (reindent what (string-length " expected: ")) + "\n " tag ": " + (error-value->string + (if pos (list-ref (cons arg args) pos) arg)) + (if (and pos (pair? args)) + (apply + string-append + "\n other arguments:" + (let loop ([pos pos] [args (cons arg args)]) + (cond + [(null? args) '()] + [(zero? pos) (loop (sub1 pos) (cdr args))] + [else (cons (string-append "\n " (error-value->string (car args))) + (loop (sub1 pos) (cdr args)))]))) + "")) + (current-continuation-marks)))) + +(define (reindent s amt) + (let loop ([i (string-length s)] [s s] [end (string-length s)]) + (cond + [(zero? i) + (if (= end (string-length s)) + s + (substring s 0 end))] + [else + (let ([i (fx1- i)]) + (cond + [(eqv? #\newline (string-ref s i)) + (string-append + (loop i s (fx1+ i)) + (make-string amt #\space) + (substring s (fx1+ i) end))] + [else + (loop i s end)]))]))) + +(define (error-value->string v) + ((|#%app| error-value->string-handler) + v + (|#%app| error-print-width))) + +(define raise-argument-error + (case-lambda + [(who what arg) + (do-raise-argument-error 'raise-argument-error "given" who what #f arg #f)] + [(who what pos arg . args) + (do-raise-argument-error 'raise-argument-error "given" who what pos arg args)])) + +(define (raise-result-error who what arg) + (do-raise-argument-error 'raise-result-error "result" who what #f arg #f)) + +(define (do-raise-type-error e-who tag who what pos arg args) + (unless (symbol? who) + (raise-argument-error e-who "symbol?" who)) + (unless (string? what) + (raise-argument-error e-who "string?" what)) + (when pos + (unless (and (integer? pos) + (exact? pos) + (not (negative? pos))) + (raise-argument-error e-who "exact-nonnegative-integer?" pos))) + (raise + (|#%app| + exn:fail:contract + (string-append (symbol->string who) + ": expected argument ot type <" what ">" + "; given: " + (error-value->string + (if pos (list-ref (cons arg args) pos) arg)) + (if (and pos (pair? args)) + (apply + string-append + "; other arguments:" + (let loop ([pos pos] [args (cons arg args)]) + (cond + [(null? args) '()] + [(zero? pos) (loop (sub1 pos) (cdr args))] + [else (cons (string-append " " (error-value->string (car args))) + (loop (sub1 pos) (cdr args)))]))) + "")) + (current-continuation-marks)))) + +(define raise-type-error + (case-lambda + [(who what arg) + (do-raise-type-error 'raise-argument-error "given" who what #f arg #f)] + [(who what pos arg . args) + (do-raise-type-error 'raise-argument-error "given" who what pos arg args)])) + +(define/who (raise-mismatch-error in-who what . more) + (check who symbol? in-who) + (check who string? what) + (raise + (|#%app| + exn:fail:contract + (apply + string-append + (symbol->string in-who) + ": " + what + (let loop ([more more]) + (cond + [(null? more) '()] + [else + (cons (error-value->string (car more)) + (loop (cdr more)))]))) + (current-continuation-marks)))) + +(define/who raise-range-error + (case-lambda + [(in-who + type-description + index-prefix + index + in-value + lower-bound + upper-bound + alt-lower-bound) + (check who symbol? in-who) + (check who string? type-description) + (check who string? index-prefix) + (check who exact-integer? index) + (check who exact-integer? lower-bound) + (check who exact-integer? upper-bound) + (check who :or-false exact-integer? alt-lower-bound) + (raise + (|#%app| + exn:fail:contract + (string-append (symbol->string in-who) + ": " + index-prefix "index is " + (cond + [(< upper-bound lower-bound) + (string-append "out of range for empty " type-description "\n" + " index: " (number->string index))] + [else + (string-append + (cond + [(and alt-lower-bound + (>= index alt-lower-bound) + (< index upper-bound)) + (string-append "smaller than starting index\n" + " " index-prefix "index: " (number->string index) "\n" + " starting index: " (number->string lower-bound) "\n")] + [else + (string-append "out of range\n" + " " index-prefix "index: " (number->string index) "\n")]) + " valid range: [" + (number->string (or alt-lower-bound lower-bound)) ", " + (number->string upper-bound) "]" "\n" + " " type-description ": " (error-value->string in-value))])) + (current-continuation-marks)))] + [(who + type-description + index-prefix + index + in-value + lower-bound + upper-bound) + (raise-range-error who + type-description + index-prefix + index + in-value + lower-bound + upper-bound + #f)])) + +(define/who (raise-arity-error name arity . args) + (check who (lambda (p) (or (symbol? name) (procedure? name))) + :contract "(or/c symbol? procedure?)" + name) + (check who procedure-arity? arity) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + (let ([name (if (procedure? name) + (object-name name) + name)]) + (if (symbol? name) + (string-append (symbol->string name) ": ") + "")) + "arity mismatch;\n" + " the expected number of arguments does not match the given number\n" + (expected-arity-string arity) + " given: " (number->string (length args))) + (current-continuation-marks)))) + +(define (expected-arity-string arity) + (let ([expected + (lambda (s) (string-append " expected: " s "\n"))]) + (cond + [(number? arity) (expected (number->string arity))] + [(arity-at-least? arity) (expected + (string-append "at least " + (number->string (arity-at-least-value arity))))] + [else ""]))) + +(define (raise-result-arity-error where num-expected-args args) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + "result arity mismatch;\n" + " expected number of values not received\n" + " received: " (number->string (length args)) "\n" + " expected: " (number->string num-expected-args) "\n" + " in: " where) + (current-continuation-marks)))) + +(define (raise-binding-result-arity-error expected-args args) + (raise-result-arity-error "local-binding form" (length expected-args) args)) + +(define raise-unsupported-error + (case-lambda + [(id msg) + (raise + (|#%app| + exn:fail:unsupported + (string-append (symbol->string id) ": " msg) + (current-continuation-marks)))] + [(id) (raise-unsupported-error id "unsupported")])) + +;; ---------------------------------------- + +(define-record-type (unquoted-printing-string new-unquoted-printing-string unquoted-printing-string?) + (fields value)) + +(define make-unquoted-printing-string + (let ([unquoted-printing-string + (escapes-ok + (lambda (s) + (check 'unquoted-printing-string string? s) + (new-unquoted-printing-string s)))]) + unquoted-printing-string)) + +;; ---------------------------------------- + +(define (nth-str n) + (string-append + (number->string n) + (case (modulo n 10) + [(1) "st"] + [(2) "nd"] + [(3) "rd"] + [else "th"]))) + +;; ---------------------------------------- + +(define exception-handler-key (gensym "exception-handler-key")) + +(define (default-uncaught-exception-handler exn) + (let ([message (if (exn? exn) + (exn-message exn) + (string-append "uncaught exception: " + (error-value->string exn)))]) + (unless (exn:break:hang-up? exn) + (let ([display-handler (|#%app| error-display-handler)]) + (call-with-parameterization + error-display-handler + (if (eq? display-handler default-error-display-handler) + emergency-error-display-handler + default-error-display-handler) + (lambda () + (call-with-exception-handler + (make-nested-exception-handler "error display handler" exn) + (lambda () + (call-with-break-disabled + (lambda () + (|#%app| display-handler message exn))))))))) + (when (or (exn:break:hang-up? exn) + (exn:break:terminate? exn)) + (engine-exit 1)) + (let ([escape-handler (|#%app| error-escape-handler)]) + (call-with-parameterization + error-display-handler + default-error-display-handler + (lambda () + (call-with-parameterization + error-escape-handler + default-error-escape-handler + (lambda () + (call-with-exception-handler + (make-nested-exception-handler "error escape handler" exn) + (lambda () + (call-with-break-disabled + (lambda () + (|#%app| escape-handler)))))))))) + ;; In case the escape handler doesn't escape: + (default-error-escape-handler))) + +(define link-instantiate-continuations (make-ephemeron-eq-hashtable)) + +;; For `instantiate-linklet` to help report which linklet is being run: +(define (register-linklet-instantiate-continuation! k name) + (when name + (hashtable-set! link-instantiate-continuations k name))) + +;; Convert a contination to a list of function-name and +;; source information. Cache the result half-way up the +;; traversal, so that it's amortized constant time. +(define cached-traces (make-ephemeron-eq-hashtable)) +(define (continuation->trace k) + (let ([i (inspect/object k)]) + (call-with-values + (lambda () + (let loop ([i i] [slow-i i] [move? #f]) + (cond + [(not (eq? (i 'type) 'continuation)) + (values (slow-i 'value) '())] + [else + (let ([k (i 'value)]) + (cond + [(hashtable-ref cached-traces k #f) + => (lambda (l) + (values slow-i l))] + [else + (let* ([name (or (let ([n (hashtable-ref link-instantiate-continuations + k + #f)]) + (and n + (string->symbol (format "body of ~a" n)))) + (let* ([c (i 'code)] + [n (c 'name)]) + n))] + [desc + (let* ([src (or + ;; when per-expression inspector info is available: + (i 'source-object) + ;; when only per-function source location is available: + ((i 'code) 'source-object))]) + (and (or name src) + (cons name src)))]) + (call-with-values + (lambda () (loop (i 'link) (if move? (slow-i 'link) slow-i) (not move?))) + (lambda (slow-k l) + (let ([l (if desc + (cons desc l) + l)]) + (when (eq? k slow-k) + (hashtable-set! cached-traces (i 'value) l)) + (values slow-k l)))))]))]))) + (lambda (slow-k l) + l)))) + +(define (traces->context ls) + (let loop ([l '()] [ls ls]) + (cond + [(null? l) + (if (null? ls) + '() + (loop (car ls) (cdr ls)))] + [else + (let* ([p (car l)] + [name (car p)] + [loc (and (cdr p) + (call-with-values (lambda () + (let* ([src (cdr p)] + [path (source-file-descriptor-path (source-object-sfd src))]) + (if (source-object-line src) + (values path + (source-object-line src) + (source-object-column src)) + (values path + (source-object-bfp src))))) + (case-lambda + [() #f] + [(path line col) (|#%app| srcloc path line (sub1 col) #f #f)] + [(path pos) (|#%app| srcloc path #f #f (add1 pos) #f)])))]) + (if (or name loc) + (cons (cons name loc) (loop (cdr l) ls)) + (loop (cdr l) ls)))]))) + +(define (default-error-display-handler msg v) + (eprintf "~a" msg) + (when (or (continuation-condition? v) + (and (exn? v) + (not (exn:fail:user? v)))) + (eprintf "\n context...:") + (let loop ([l (traces->context + (if (exn? v) + (continuation-mark-set-traces (exn-continuation-marks v)) + (list (continuation->trace (condition-continuation v)))))] + [n (|#%app| error-print-context-length)]) + (unless (or (null? l) (zero? n)) + (let* ([p (car l)] + [s (cdr p)]) + (cond + [(and s + (srcloc-line s) + (srcloc-column s)) + (eprintf "\n ~a:~a:~a" (srcloc-source s) (srcloc-line s) (srcloc-column s)) + (when (car p) + (eprintf ": ~a" (car p)))] + [(and s (srcloc-position s)) + (eprintf "\n ~a::~a" (srcloc-source s) (srcloc-position s)) + (when (car p) + (eprintf ": ~a" (car p)))] + [(car p) + (eprintf "\n ~a" (car p))])) + (loop (cdr l) (sub1 n))))) + (eprintf "\n")) + +(define eprintf + (lambda (fmt . args) + (apply fprintf (current-error-port) fmt args))) + +(define (emergency-error-display-handler msg v) + (log-system-message 'error msg)) + +(define (set-error-display-eprintf! proc) + (set! eprintf proc)) + +(define (default-error-escape-handler) + (abort-current-continuation (default-continuation-prompt-tag) void)) + +(define (exn->string v) + (format "~a~a" + (if (who-condition? v) + (format "~a: " (condition-who v)) + "") + (cond + [(exn? v) + (exn-message v)] + [(format-condition? v) + (apply format + (condition-message v) + (condition-irritants v))] + [(syntax-violation? v) + (let ([show (lambda (s) + (cond + [(not s) ""] + [else (format " ~s" (syntax->datum s))]))]) + (format "~a~a~a" + (condition-message v) + (show (syntax-violation-form v)) + (show (syntax-violation-subform v))))] + [(message-condition? v) + (condition-message v)] + [else (format "~s" v)]))) + +(define (condition->exn v) + (if (condition? v) + (cond + [(and (format-condition? v) + (irritants-condition? v) + (string-prefix? "incorrect number of arguments" (condition-message v)) + (pair? (condition-irritants v)) + (procedure? (car (condition-irritants v)))) + (let* ([proc (car (condition-irritants v))] + [name (object-name proc)] + [arity (procedure-arity proc)]) + (|#%app| + exn:fail:contract:arity + (string-append + (if (symbol? name) (symbol->string name) "#") + ": arity mismatch;\n the expected number of arguments does not match the given number" + (cond + [(list? arity) + ""] + [else + (string-append + "\n expected: " + (cond + [(arity-at-least? arity) (string-append "at least " (number->string (arity-at-least-value arity)))] + [else (number->string arity)]))])) + (current-continuation-marks)))] + [else + (|#%app| + (cond + [(and (format-condition? v) + (or (string-prefix? "incorrect number of arguments" (condition-message v)) + (string-suffix? "values to single value return context" (condition-message v)) + (string-prefix? "incorrect number of values received in multiple value context" (condition-message v)))) + exn:fail:contract:arity] + [(and (format-condition? v) + (who-condition? v) + (eq? '/ (condition-who v)) + (string=? "undefined for ~s" (condition-message v))) + exn:fail:contract:divide-by-zero] + [(and (format-condition? v) + (string=? "attempt to reference undefined variable ~s" (condition-message v))) + (lambda (msg marks) + (|#%app| exn:fail:contract:variable msg marks (car (condition-irritants v))))] + [else + exn:fail:contract]) + (exn->string v) + (current-continuation-marks))]) + v)) + +(define (string-prefix? p str) + (and (>= (string-length str) (string-length p)) + (string=? (substring str 0 (string-length p)) p))) + +(define (string-suffix? p str) + (and (>= (string-length str) (string-length p)) + (string=? (substring str (- (string-length str) (string-length p)) (string-length str)) p))) + +(define/who uncaught-exception-handler + (make-parameter default-uncaught-exception-handler + (lambda (v) + (check who (procedure-arity-includes/c 1) v) + v))) + +(define/who error-display-handler + (make-parameter default-error-display-handler + (lambda (v) + (check who (procedure-arity-includes/c 2) v) + v))) + +(define/who error-escape-handler + (make-parameter default-error-escape-handler + (lambda (v) + (check who (procedure-arity-includes/c 0) v) + v))) + +(define (set-no-locate-source!) + ;; Disable searching through the filesystem to convert a source + + ;; position to line and column information. Instead, Racket + ;; constructs source objects that preserve the line and column if + ;; available. + (current-locate-source-object-source + (lambda (src start? cache?) + (cond + [(source-object-line src) + ;; Line and column are available without searching + (values (source-file-descriptor-path (source-object-sfd src)) + (source-object-column src) + (source-object-column src))] + [else + ;; Don't search + (values)])))) + +(define (set-base-exception-handler!) + (current-exception-state (create-exception-state)) + (base-exception-handler + (lambda (v) + (cond + [(and (warning? v) + (not (non-continuable-violation? v))) + (log-system-message 'warning (exn->string exn))] + [else + (let ([hs (continuation-mark-set->list (current-continuation-marks the-root-continuation-prompt-tag) + exception-handler-key + the-root-continuation-prompt-tag)] + [init-v (condition->exn v)]) + (let ([call-with-nested-handler + (lambda (thunk) + (call-with-exception-handler + (make-nested-exception-handler "exception handler" init-v) + (lambda () + (call-with-break-disabled thunk))))]) + (let loop ([hs hs] [v init-v]) + (cond + [(null? hs) + (call-with-nested-handler + (lambda () (|#%app| (|#%app| uncaught-exception-handler) v))) + ;; Use `nested-exception-handler` if the uncaught-exception + ;; handler doesn't escape: + ((make-nested-exception-handler #f v) #f)] + [else + (let ([h (car hs)] + [hs (cdr hs)]) + (let ([new-v (call-with-nested-handler + (lambda () (|#%app| h v)))]) + (loop hs new-v)))]))))])))) + +(define (make-nested-exception-handler what old-exn) + (lambda (exn) + (let ([msg + (string-append + (cond + [(not what) + "handler for uncaught exceptions: did not escape"] + [else + (string-append + (cond [(exn? exn) + (string-append "exception raised by " what)] + [else + (string-append "raise called (with non-exception value) by " what)]) + ": " + (if (exn? exn) + (exn-message exn) + (error-value->string exn)))]) + "; original " + (if (exn? old-exn) + "exception raised" + "raise called (with non-exception value)") + ": " + (if (exn? old-exn) + (exn-message old-exn) + (error-value->string old-exn)))]) + (default-uncaught-exception-handler + (|#%app| exn:fail msg (current-continuation-marks)))))) + +(define (call-with-exception-handler proc thunk) + (call/cm exception-handler-key proc thunk)) + +;; ---------------------------------------- + +(define log-system-message void) + +(define (set-log-system-message! proc) + (set! log-system-message proc)) diff --git a/racket/src/cs/rumble/extfl.ss b/racket/src/cs/rumble/extfl.ss new file mode 100644 index 0000000000..4c3de043a4 --- /dev/null +++ b/racket/src/cs/rumble/extfl.ss @@ -0,0 +1,88 @@ + +(define-record-type extflonum + (fields str) + (nongenerative #{extflonum lb32cq34kbljz9rpowkzge-0})) + +;; used by `string->number` +(define (extflonum-string? s) + ;; It's an extflonum if there's any #\t + (let loop ([i (string-length s)]) + (and (fx> i 0) + (let ([i (sub1 i)]) + (let ([c (string-ref s i)]) + (or (char=? #\t c) (char=? #\T c) + (loop i))))))) + +(define (extflonum-available?) #f) +(define (extflvector? v) #f) + +(define-syntax (define-extfl-ids stx) + (syntax-case stx () + [(_ id ...) + #'(begin + (define (id v) + (raise-unsupported-error 'id)) + ...)])) + +(define-extfl-ids + extfl* + extfl+ + extfl- + ->extfl + extfl->exact + extfl->exact-integer + extfl->floating-point-bytes + extfl->fx + extfl->inexact + extfl/ + extfl< + extfl<= + extfl= + extfl> + extfl>= + extflabs + extflacos + extflasin + extflatan + extflceiling + extflcos + extflexp + extflexpt + floating-point-bytes->extfl + extflfloor + fx->extfl + extfllog + make-shared-extflvector + make-extflvector + extflmax + extflmin + real->extfl + extflround + shared-extflvector + extflsin + extflsqrt + extfltan + extfltruncate + extflvector + extflvector-length + extflvector-ref + extflvector-set! + + unsafe-extfl* + unsafe-extfl+ + unsafe-extfl- + unsafe-extfl/ + unsafe-extfl< + unsafe-extfl<= + unsafe-extfl= + unsafe-extfl> + unsafe-extfl>= + unsafe-extflabs + unsafe-extflmax + unsafe-extflmin + unsafe-extflsqrt + unsafe-extfl->fx + unsafe-fx->extfl + unsafe-extflvector-length + unsafe-extflvector-ref + unsafe-extflvector-set!) diff --git a/racket/src/cs/rumble/flvector.ss b/racket/src/cs/rumble/flvector.ss new file mode 100644 index 0000000000..be6dc93e70 --- /dev/null +++ b/racket/src/cs/rumble/flvector.ss @@ -0,0 +1,119 @@ + +(define-record-type (flvector create-flvector flvector?) + (fields bstr)) + +(define (flvector=? a b eql?) + (bytevector=? (flvector-bstr a) (flvector-bstr b))) + +(define (flvector-hash-code a hc) + (hc (flvector-bstr a))) + +(define (do-flvector who xs) + (let ([bstr (make-bytevector (* 8 (length xs)))]) + (let loop ([xs xs] [i 0]) + (unless (null? xs) + (let ([x (car xs)]) + (check who flonum? x) + (bytevector-ieee-double-set! bstr i x (native-endianness)) + (loop (cdr xs) (fx+ i 8))))) + (create-flvector bstr))) + +(define new-flvector + (let ([flvector + (lambda xs + (do-flvector 'flvector xs))]) + flvector)) + +(define (do-make-flvector who size init) + (check who exact-nonnegative-integer? size) + (cond + [(eqv? init 0.0) + ;; 0-fill bytevector => 0.0-fill flvector + (create-flvector (make-bytevector (bitwise-arithmetic-shift-left size 3) 0))] + [else + (check who flonum? init) + (let* ([bsize (* 8 size)] + [bstr (make-bytevector bsize)]) + (let loop ([i 0]) + (unless (= i bsize) + (bytevector-ieee-double-set! bstr i init (native-endianness)) + (loop (fx+ i 8)))) + (create-flvector bstr))])) + +(define make-flvector + (case-lambda + [(size) (make-flvector size 0.0)] + [(size init) (do-make-flvector 'make-flvector size init)])) + +(define/who (flvector-length flvec) + (check who flvector? flvec) + (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)) + +(define (unsafe-flvector-length flvec) + (#3%fxsrl (#3%bytevector-length (flvector-bstr flvec)) 3)) + +(define/who (flvector-ref flvec pos) + (check who flvector? flvec) + (let ([len (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)]) + (check who exact-nonnegative-integer? pos) + (unless (and (>= pos 0) + (< pos len)) + (raise-range-error who "flvector" "" pos flvec 0 len))) + (bytevector-ieee-double-ref (flvector-bstr flvec) + (bitwise-arithmetic-shift-left pos 3) + (native-endianness))) + +(define (unsafe-flvector-ref flvec pos) + (#3%bytevector-ieee-double-ref (flvector-bstr flvec) + (#3%fxsll pos 3) + (native-endianness))) + +(define/who (flvector-set! flvec pos val) + (check who flvector? flvec) + (let ([len (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)]) + (check who exact-nonnegative-integer? pos) + (unless (and (>= pos 0) + (< pos len)) + (raise-range-error who "flvector" "" pos flvec 0 len))) + (check who flonum? val) + (bytevector-ieee-double-set! (flvector-bstr flvec) + (bitwise-arithmetic-shift-left pos 3) + val + (native-endianness))) + +(define (unsafe-flvector-set! flvec pos val) + (#3%bytevector-ieee-double-set! (flvector-bstr flvec) + (#3%fxsll pos 3) + val + (native-endianness))) + +(define/who flvector-copy + (case-lambda + [(flvec) (flvector-copy flvec 0 (flvector-length flvec))] + [(flvec start) (flvector-copy flvec start (flvector-length flvec))] + [(flvec start end) + (check who flvector? flvec) + (let ([len (bitwise-arithmetic-shift-right (bytevector-length (flvector-bstr flvec)) 3)]) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "flvector" flvec start end len) + (let* ([new-len (bitwise-arithmetic-shift-left (- end start) 3)] + [bstr (make-bytevector new-len)]) + (bytes-copy! bstr 0 (flvector-bstr flvec) (bitwise-arithmetic-shift-left start 3) new-len) + (create-flvector bstr)))])) + +(define/who (shared-flvector . xs) + (do-flvector who xs)) + +(define make-shared-flvector + (case-lambda + [(size) (make-shared-flvector size 0.0)] + [(size init) (do-make-flvector 'make-shared-flvector size init)])) + +;; ---------------------------------------- + +(define (set-flvector-hash!) + (record-type-equal-procedure (record-type-descriptor flvector) + flvector=?) + (record-type-hash-procedure (record-type-descriptor flvector) + flvector-hash-code)) diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss new file mode 100644 index 0000000000..78c21658a0 --- /dev/null +++ b/racket/src/cs/rumble/foreign.ss @@ -0,0 +1,1718 @@ + +(define (cpointer? v) + (or (authentic-cpointer? v) + (not v) + (bytes? v) + (has-cpointer-property? v))) + +;; A cpointer's `memory` is either a raw foreign address (i.e., a +;; number), a vector, or a byte string. A bytevector is used +;; for GCable atomic memory, and a vector is used for GCable +;; non-atomic memory. +(define-record-type (cpointer make-cpointer authentic-cpointer?) + (fields memory (mutable tags))) +(define-record-type cpointer+offset + (parent cpointer) + (fields (mutable offset))) + +(define-values (prop:cpointer has-cpointer-property? cpointer-property-ref) + (make-struct-type-property 'cpointer + (lambda (v info) + (cond + [(exact-nonnegative-integer? v) + (unless (< v (list-ref info 1)) + (raise-arguments-error 'prop:cpointer + "index is out of range" + "index" v)) + (unless (chez:memv v (list-ref info 5)) + (raise-arguments-error 'prop:cpointer + "index does not refer to an immutable field" + "index" v)) + (+ v (let ([p (list-ref info 6)]) + (if p + (struct-type-total*-field-count p) + 0)))] + [(and (procedure? v) + (procedure-arity-includes? v 1)) + v] + [(cpointer? v) v] + [else + (raise-argument-error 'prop:cpointer + (string-append + "(or/c exact-nonnegative-integer?\n" + " (procedure-arity-includes/c 1)\n" + " cpointer?)") + v)])))) + +;; Gets a primitive cpointer type by following a `prop:evt` property +;; as needed. Call with function *before* disabling GC interrupts. +(define (unwrap-cpointer who p) + (cond + [(authentic-cpointer? p) p] + [(not p) p] + [(bytes? p) p] + [(ffi-callback? p) p] + [else (let ([v (cpointer-property-ref p)]) + (cond + [(exact-nonnegative-integer? v) + (let ([v (unsafe-struct-ref p v)]) + (if (cpointer? v) + (unwrap-cpointer who v) + #f))] + [(procedure? v) + (let ([p2 (v p)]) + (unless (cpointer? p2) + (raise-result-error 'prop:cpointer-accessor + "cpointer?" + p2)) + (unwrap-cpointer who p2))] + [else + (unwrap-cpointer who v)]))])) + +;; Like `unwrap-cpointer*`, but also allows an integer as a raw +;; foreign address: +(define (unwrap-cpointer* who p) + (if (integer? p) + p + (unwrap-cpointer who p))) + +(define (offset-ptr? p) + (unless (cpointer? p) + (raise-argument-error 'offset-ptr? "cpointer?" p)) + (cpointer+offset? p)) + +(define/who (set-cpointer-tag! p t) + (if (authentic-cpointer? p) + (cpointer-tags-set! p t) + (if (cpointer? p) + (let ([q (unwrap-cpointer who p)]) + (if (authentic-cpointer? q) + (set-cpointer-tag! q t) + (raise-arguments-error who + "cannot set tag on given cpointer" + "given" p + "tag" t))) + (raise-argument-error who "cpointer?" p)))) + +(define/who (cpointer-tag p) + (if (authentic-cpointer? p) + (cpointer-tags p) + (if (cpointer? p) + (let ([q (unwrap-cpointer who p)]) + (if (authentic-cpointer? q) + (cpointer-tag q) + #f)) + (raise-argument-error who "cpointer?" p)))) + +;; Convert a `memory` --- typically a raw foreign address, but possibly +;; a byte string or vector --- to a cpointer, using #f for a NULL +;; address: +(define (memory->cpointer x) + (cond + [(or (not x) (authentic-cpointer? x)) + ;; This happens when a pointer is converted without going through + ;; `cpointer-address` such as a `ptr-ref` on a struct or array type + x] + [(eqv? x 0) #f] + [else (make-cpointer x #f)])) + +;; Works on unwrapped cpointers: +(define (cpointer-nonatomic? p) + (and (authentic-cpointer? p) + (#%vector? (cpointer-memory p)))) + +;; ---------------------------------------- + +;; Hack: use `s_fxmul` as an identity function +;; to corece a bytevector's start to an address +(define bytevector->addr ; call with GC disabled + (foreign-procedure "(cs)fxmul" + (u8* uptr) + uptr)) +(define object->addr ; call with GC disabled + (foreign-procedure "(cs)fxmul" + (scheme-object uptr) + uptr)) +(define address->object ; call with GC disabled + (foreign-procedure "(cs)fxmul" + (uptr uptr) + scheme-object)) + +(define vector-content-offset + ;; Hack: we rely on the implementation detail of bytevectors and vectors + ;; having the same offset from the address to the content. + (let ([s (make-bytevector 1)]) + ;; Disable interrupts to avoid a GC: + (with-interrupts-disabled + (- (bytevector->addr s 1) + (object->addr s 1))))) + +;; Converts a primitive cpointer (normally the result of +;; `unwrap-cpointer`) to a raw foreign address. The +;; GC must be disabled while extracting an address, +;; which might be the address of a byte string that +;; could otherwise change due to a GC. +(define (cpointer-address p) ; call with GC disabled + (cond + [(not p) 0] + [(bytes? p) (memory-address p)] + [(cpointer+offset? p) + (let ([memory (cpointer-memory p)]) + (+ (memory-address memory) (cpointer+offset-offset p)))] + [(authentic-cpointer? p) + (memory-address (cpointer-memory p))] + [(ffi-callback? p) + (foreign-callable-entry-point (callback-code p))] + [else + (raise-arguments-error 'internal-error "bad case extracting a cpointer address" + "value" p)])) + +;; Like `cpointer-address`, but allows a raw foreign +;; address to pass through: +(define (cpointer*-address p) ; call with GC disabled + (if (number? p) + p + (cpointer-address p))) + +;; Convert a `memory` (as in a cpointer) to a raw foreign address. +(define (memory-address memory) ; call with GC disabled + (cond + [(integer? memory) memory] + [(bytes? memory) (bytevector->addr memory 1)] + [else + (+ (object->addr memory 1) + vector-content-offset)])) + +;; Convert a raw foreign address to a Scheme value on the +;; assumption that the address is the payload of a byte +;; string or vector: +(define (addr->gcpointer-memory v) ; call with GC disabled + (address->object (- v vector-content-offset) 1)) + +;; ---------------------------------------- + +(define (cpointer-strip p) + (cond + [(not p) 0] + [(bytes? p) p] + [(and (authentic-cpointer? p) + (or (not (cpointer+offset? p)) + (zero? (cpointer+offset-offset p)))) + (cpointer-memory p)] + [else none])) + +(define (stripped-cpointer? v) + (or (eqv? v 0) + (bytes? v) + (vector? v))) + +;; ---------------------------------------- + +(define/who (ptr-equal? p1 p2) + (let ([p1 (unwrap-cpointer who p1)] + [p2 (unwrap-cpointer who p2)]) + (with-interrupts-disabled ; disable GC while extracting addresses + (= (cpointer-address p1) (cpointer-address p2))))) + +(define/who (ptr-offset p) + (let ([p (unwrap-cpointer who p)]) + (ptr-offset* p))) + +(define (ptr-offset* p) + (if (cpointer+offset? p) + (cpointer+offset-offset p) + 0)) + +(define (set-ptr-offset! p n) + (unless (cpointer+offset? p) + (raise-argument-error 'ptr-offset "(and/c cpointer? ptr-offset?)" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-offset "exact-integer?" n)) + (cpointer+offset-offset-set! p n)) + +(define ptr-add + (case-lambda + [(p n type) + (unless (cpointer? p) + (raise-argument-error 'ptr-add "cpointer?" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add "exact-integer?" n)) + (unless (ctype? type) + (raise-argument-error 'ptr-add "ctype?" type)) + (do-ptr-add p (* n (ctype-sizeof type)) #t)] + [(p n) + (unless (cpointer? p) + (raise-argument-error 'ptr-add "cpointer?" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add "exact-integer?" n)) + (do-ptr-add p n #t)])) + +(define (do-ptr-add p n save-tags?) + (cond + [(authentic-cpointer? p) + (make-cpointer+offset (cpointer-memory p) + (and save-tags? (cpointer-tag p)) + (+ n (ptr-offset* p)))] + [(has-cpointer-property? p) + (do-ptr-add (unwrap-cpointer 'do-ptr-add p) n save-tags?)] + [else + (make-cpointer+offset (or p 0) #f n)])) + +(define ptr-add! + (case-lambda + [(p n type) + (unless (cpointer+offset? p) + (raise-argument-error 'ptr-add! "(and/c cpointer? offset-ptr?)" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add! "exact-integer?" n)) + (unless (ctype? type) + (raise-argument-error 'ptr-add! "ctype?" type)) + (do-ptr-add! p (* n (ctype-sizeof type)))] + [(p n) + (unless (cpointer+offset? p) + (raise-argument-error 'ptr-add! "(and/c cpointer? offset-ptr?)" p)) + (unless (exact-integer? n) + (raise-argument-error 'ptr-add! "exact-integer?" n)) + (do-ptr-add! p n)])) + +(define (do-ptr-add! p n) + (unless (cpointer+offset? p) + (raise-arguments-error 'ptr-add! + "given cpointer does not have an offset" + "given" p)) + (cpointer+offset-offset-set! p (+ n (cpointer+offset-offset p)))) + +;; ---------------------------------------- + +(define-record-type (ctype create-ctype ctype?) + (fields host-rep ; host-Scheme representation description, 'struct, 'union, or 'array + our-rep ; Racket representation description + basetype ; parent ctype or the same as `our-rep` + scheme->c ; converter of values to `basetype` + c->scheme)) ; converter of values from `basetype` + +;; A `compound-ctype` is used for structs, unions, and arrays +(define-record-type (compound-ctype create-compound-ctype compound-ctype?) + (parent ctype) + (fields get-decls + size + alignment)) + +(define/who (make-ctype type racket-to-c c-to-racket) + (check who ctype? type) + (check who (procedure-arity-includes/c 1) :or-false racket-to-c) + (check who (procedure-arity-includes/c 1) :or-false c-to-racket) + (cond + [(compound-ctype? type) + (create-compound-ctype (ctype-host-rep type) + (ctype-our-rep type) + type + racket-to-c + c-to-racket + (compound-ctype-get-decls type) + (compound-ctype-size type) + (compound-ctype-alignment type))] + [else + (create-ctype (ctype-host-rep type) + (ctype-our-rep type) + type + racket-to-c + c-to-racket)])) + +;; Apply all the conversion wrappers of `type` to the Scheme value `v` +(define (s->c type v) + (let* ([racket-to-c (ctype-scheme->c type)] + [v (if racket-to-c + (|#%app| racket-to-c v) + v)] + [next (ctype-basetype type)]) + (if (ctype? next) + (s->c next v) + v))) + +;; Apply all the conversion wrapper of `type` to the C value `v` +(define (c->s type v) + (let* ([next (ctype-basetype type)] + [v (if (ctype? next) + (c->s next v) + v)] + [c-to-racket (ctype-c->scheme type)]) + (if c-to-racket + (|#%app| c-to-racket v) + v))) + +;; ---------------------------------------- + +(define-syntax define-ctype + (syntax-rules () + [(_ id host-rep basetype) + (define/who id (create-ctype host-rep basetype basetype #f #f))] + [(_ id host-rep basetype s->c) + (define/who id (create-ctype host-rep basetype basetype s->c #f))] + [(_ id host-rep basetype s->c c->s) + (define/who id (create-ctype host-rep basetype basetype s->c c->s))])) + +;; We need `s->c` checks, even if they seem redundant, to make sure +;; that the checks happen early enough --- outside of atomic and +;; foreign-thread regions. Also, the integer checks built into Chez +;; Scheme are more permissive than Racket's. + +(define-syntax-rule (checker who ?) (lambda (x) (if (? x) x (bad-ctype-value who x)))) +(define-syntax integer-checker + (syntax-rules (signed unsigned) + [(_ who signed n int?) (checker who (lambda (x) (and (int? x) (<= (- (expt 2 (- n 1))) x (- (expt 2 (- n 1)) 1)))))] + [(_ who unsigned n int?) (checker who (lambda (x) (and (int? x) (<= 0 x (- (expt 2 n) 1)))))])) + +(define-ctype _bool 'boolean 'bool) +(define-ctype _double 'double 'double (checker who flonum?)) +(define-ctype _fixnum 'fixnum 'fixnum (checker who fixnum?)) +(define-ctype _float 'float 'float (checker who flonum?)) +(define-ctype _int8 'integer-8 'int8 (integer-checker who signed 8 fixnum?)) +(define-ctype _int16 'integer-16 'int16 (integer-checker who signed 16 fixnum?)) +(define-ctype _int32 'integer-32 'int32 (integer-checker who signed 32 exact-integer?)) +(define-ctype _int64 'integer-64 'int64 (integer-checker who signed 64 exact-integer?)) +(define-ctype _uint8 'unsigned-8 'uint8 (integer-checker who unsigned 8 fixnum?)) +(define-ctype _uint16 'unsigned-16 'uint16 (integer-checker who unsigned 16 fixnum?)) +(define-ctype _uint32 'unsigned-32 'uint32 (integer-checker who unsigned 32 exact-integer?)) +(define-ctype _uint64 'unsigned-64 'uint64 (integer-checker who unsigned 64 exact-integer?)) +(define-ctype _scheme 'scheme-object 'scheme) +(define-ctype _string/ucs-4 (if (system-big-endian?) 'utf-32be 'utf-32le) 'string/ucs-4 + (checker who string?)) +(define-ctype _string/utf-16 (if (system-big-endian?) 'utf-16be 'utf-16le) 'string/utf-16 + (checker who string?)) +(define-ctype _void 'void 'void (checker who void)) + +(define (bad-ctype-value type-name v) + (raise-arguments-error 'apply + "bad value for conversion" + "ctype" (make-unquoted-printing-string (symbol->string type-name)) + "value" v)) + +;; Unlike traditional Racket, copies when converting from C: +(define-ctype _bytes 'void* 'bytes + (checker who (lambda (x) (or (not x) (bytes? x)))) + (lambda (x) + (cond + [(not x) ; happens with non-atomic memory reference + x] + [(bytes? x) ; happens with non-atomic memory reference + ;; For consistency, truncate byte string at any NUL byte + (let ([len (bytes-length x)]) + (let loop ([i 0]) + (cond + [(fx= i len) x] + [(fx= 0 (bytes-ref x i)) + (subbytes x 0 i)] + [else (loop (fx+ i 1))])))] + [(eqv? x 0) #f] + [else + (let loop ([i 0]) + (if (fx= 0 (foreign-ref 'unsigned-8 x i)) + (let ([bstr (make-bytes i)]) + (memcpy* bstr 0 x 0 i #f) + bstr) + (loop (add1 i))))]))) + +(define-ctype _short_bytes 'void* 'bytes + (lambda (x) x) + (lambda (x) (let loop ([i 0]) + (if (fx= 0 (foreign-ref 'unsigned-16 x i)) + (let ([bstr (make-bytes i)]) + (memcpy* bstr 0 x 0 i #f) + bstr) + (loop (+ i 2)))))) + +(define-ctype _double* 'double 'double + (lambda (x) (if (real? x) + (exact->inexact x) + (bad-ctype-value who x)))) + +(define-ctype _ufixnum 'fixnum 'fixnum (checker who fixnum?)) ; historically, no sign check +(define-ctype _fixint 'integer-32 'fixint (checker who fixnum?)) +(define-ctype _ufixint 'unsigned-32 'ufixint (checker who fixnum?)) ; historically, no sign check + +(define-ctype _symbol 'string 'string + (lambda (x) (if (symbol? x) + (symbol->string x) + (bad-ctype-value who x))) + (lambda (s) (string->symbol s))) + +(define-ctype _longdouble 'double 'double + (lambda (x) (bad-ctype-value who x))) + +(define-ctype _pointer 'void* 'pointer + (lambda (v) (unwrap-cpointer who v)) ; resolved to an address later (with the GC disabled) + (lambda (x) (memory->cpointer x))) + +;; Treated specially by `ptr-ref` +(define-ctype _fpointer 'void* 'fpointer + (lambda (v) (unwrap-cpointer who v)) ; resolved to an address later (with the GC disabled) + (lambda (x) + (if (ffi-obj? x) ; check for `ptr-ref` special case on `ffi-obj`s + x + (memory->cpointer x)))) + +(define-ctype _gcpointer 'void* 'gcpointer + (lambda (v) (unwrap-cpointer who v)) ; like `_pointer`: resolved later + (lambda (x) + ;; `x` must have been converted to a bytevector or vector before + ;; the GC was re-enabled + (memory->cpointer x))) + +;; FIXME: +(define-ctype _stdbool 'integer-8 'stdbool + (lambda (x) (and x 0)) + (lambda (v) (not (zero? v)))) + +(define make-cstruct-type + (case-lambda + [(types) (make-cstruct-type types #f #f)] + [(types abi) (make-cstruct-type types abi #f)] + [(types abi alignment) + (let ([make-decls + (escapes-ok + (lambda (id) + (let-values ([(reps decls) (types->reps types)]) + (append decls + `((define-ftype ,id + (struct ,@(map (lambda (rep) + `[,(gensym) ,rep]) + reps))))))))]) + (let-values ([(size alignment) (ctypes-sizeof+alignof types alignment)]) + (create-compound-ctype 'struct + 'struct + types + (lambda (s) (unwrap-cpointer '_struct s)) ; like `_pointer`: resolved later + (lambda (c) (memory->cpointer c)) + make-decls + size + alignment)))])) + +(define/who (make-union-type . types) + (for-each (lambda (type) (check who ctype? type)) + types) + (let ([make-decls + (escapes-ok + (lambda (id) + (let-values ([(reps decls) (types->reps types)]) + (append decls + `((define-ftype ,id + (union ,@(map (lambda (rep) + `[,(gensym) ,rep]) + reps))))))))] + [size (apply max (map ctype-sizeof types))] + [alignment (apply max (map ctype-alignof types))]) + (create-compound-ctype 'union + 'union + types + (lambda (s) (unwrap-cpointer '_union s)) ; like `_pointer`: resolved later + (lambda (c) (memory->cpointer c)) + make-decls + size + alignment))) + +(define/who (make-array-type type count) + (check who ctype? type) + (check who exact-nonnegative-integer? count) + (let ([make-decls + (escapes-ok + (lambda (id) + (let-values ([(reps decls) (types->reps (list type))]) + (append decls + `((define-ftype ,id + (array ,count ,(car reps))))))))] + [size (* count (ctype-sizeof type))] + [alignment (ctype-alignof type)]) + (create-compound-ctype 'array + 'array + (vector type count) + (lambda (s) (unwrap-cpointer '_array s)) ; like `_pointer`: resolved later + (lambda (c) (memory->cpointer c)) + make-decls + size + alignment))) + +(define (compiler-sizeof sl) + (let ([rest (lambda (sl) (if (pair? sl) (cdr sl) '()))]) + (unless (or (symbol? sl) + (list? sl)) + (raise-argument-error 'compiler-sizeof + "(or/c ctype-symbol? (listof ctype-symbol?))" + sl)) + (let loop ([sl sl] [base-type #f] [star? #f] [size #f]) + (cond + [(null? sl) + (cond + [(eq? base-type 'void) + (when size + (raise-arguments-error 'compiler-sizeof "cannot qualify 'void")) + (if star? + (foreign-sizeof 'void*) + (raise-arguments-error 'compiler-sizeof "cannot use 'void without a '*"))] + [(or (not base-type) + (eq? base-type 'int)) + (if star? + (foreign-sizeof 'void*) + (foreign-sizeof (or size 'int)))] + [(eq? base-type 'double) + (case size + [(long) + (if star? + (foreign-sizeof 'void*) + ;; FIXME: + (foreign-sizeof 'double))] + [(#f) + (if star? + (foreign-sizeof 'void*) + (foreign-sizeof 'double))] + [else + (raise-arguments-error 'compiler-sizeof "bad qualifiers for 'double")])] + [(eq? base-type 'float) + (case size + [(#f) + (if star? + (foreign-sizeof 'void*) + (foreign-sizeof 'float))] + [else + (raise-arguments-error 'compiler-sizeof "bad qualifiers for 'float")])] + [size + (raise-arguments-error 'compiler-sizeof (format "cannot qualify '~a" base-type))])] + [else + (let ([s (if (pair? sl) (car sl) sl)]) + (case s + [(int char float double void) + (cond + [base-type + (raise-arguments-error 'compiler-sizeof + (format "extraneous type: '~a" s))] + [else + (loop (rest sl) s star? size)])] + [(short) + (case size + [(short) + (raise-arguments-error 'compiler-sizeof + "cannot handle more than one 'short")] + [(long) + (raise-arguments-error 'compiler-sizeof + "cannot use both 'short and 'long")] + [(#f) (loop (rest sl) base-type star? 'short)])] + [(long) + (case size + [(short) + (raise-arguments-error 'compiler-sizeof + "cannot use both 'short and 'long")] + [(long-long) + (raise-arguments-error 'compiler-sizeof + "cannot handle more than two 'long")] + [(long) + (loop (rest sl) base-type star? 'long-long)] + [(#f) + (loop (rest sl) base-type star? 'long)])] + [(*) + (if star? + (raise-arguments-error 'compiler-sizeof + "cannot handle more than one '*") + (loop (rest sl) base-type #t size))] + [else + (raise-argument-error 'compiler-sizeof + "(or/c ctype-symbol? (listof ctype-symbol?))" + sl)]))])))) + +(define (ctype-malloc-mode c) + (let ([t (ctype-our-rep c)]) + (if (or (eq? t 'gcpointer) (eq? t 'scheme)) + 'nonatomic + 'atomic))) + +(define/who (ctype-sizeof c) + (check who ctype? c) + (case (ctype-host-rep c) + [(void) 0] + [(boolean int) 4] + [(double) 8] + [(float) 4] + [(integer-8 unsigned-8) 1] + [(integer-16 unsigned-16) 2] + [(integer-32 unsigned-32) 4] + [(integer-64 unsigned-64) 8] + [else + (if (compound-ctype? c) + (compound-ctype-size c) + ;; Everything else is pointer-sized: + (foreign-sizeof 'void*))])) + +(define (ctypes-sizeof+alignof base alignment) + (let ([align (lambda (size algn) + (let ([amt (modulo size (or alignment algn))]) + (if (zero? amt) + size + (+ size (- algn amt)))))]) + (let loop ([types base] [size 0] [max-align 1]) + (cond + [(null? types) (values (align size max-align) + max-align)] + [else (let ([sz (ctype-sizeof (car types))] + [algn (ctype-alignof (car types))]) + (loop (cdr types) + (+ (align size algn) + sz) + (max algn max-align)))])))) + +(define/who (ctype-alignof c) + (check who ctype? c) + (cond + [(compound-ctype? c) + (compound-ctype-alignment c)] + [else + (ctype-sizeof c)])) + +(define/who (cpointer-gcable? p) + (let ([p (unwrap-cpointer who p)]) + (or (bytes? p) + (and (authentic-cpointer? p) + (let ([memory (cpointer-memory p)]) + (or (bytes? memory) + (#%vector? memory))))))) + +;; ---------------------------------------- + +(define-record-type (ffi-lib make-ffi-lib ffi-lib?) + (fields handle name)) + +(define ffi-lib* + (case-lambda + [(name) (ffi-lib* name #f #f)] + [(name fail-as-false?) (ffi-lib* name fail-as-false? #f)] + [(name fail-as-false? as-global?) + (let ([name (if (string? name) + (string->immutable-string name) + name)]) + (ffi-get-lib 'ffi-lib + name + as-global? + fail-as-false? + (lambda (h) + (make-ffi-lib h name))))])) + +(define-record-type (cpointer/ffi-obj make-ffi-obj ffi-obj?) + (parent cpointer) + (fields lib name)) + +(define/who (ffi-obj name lib) + (check who bytes? name) + (check who ffi-lib? lib) + (let ([name (bytes->immutable-bytes name)]) + (ffi-get-obj who + (ffi-lib-handle lib) + (ffi-lib-name lib) + name + (lambda (ptr) + (make-ffi-obj (ffi-ptr->address ptr) #f lib name))))) + +(define (ffi-obj-name obj) + (cpointer/ffi-obj-name obj)) + +(define (ffi-obj-lib obj) + (cpointer/ffi-obj-lib obj)) + +(define ffi-get-lib + ;; Placeholder implementation that either fails + ;; or returns a dummy value: + (lambda (who name as-global? fail-as-false? success-k) + (if fail-as-false? + #f + (success-k #f)))) + +(define ffi-get-obj + ;; Placeholder implementation that always fails: + (lambda (who lib lib-name name success-k) + (raise + (|#%app| + exn:fail:filesystem + (format "~a: not yet ready\n name: ~a" who name) + (current-continuation-marks))))) + +(define ffi-ptr->address + ;; Placeholder implementation + (lambda (p) p)) + +(define (set-ffi-get-lib-and-obj! do-ffi-get-lib do-ffi-get-obj do-ffi-ptr->address) + (set! ffi-get-lib do-ffi-get-lib) + (set! ffi-get-obj do-ffi-get-obj) + (set! ffi-ptr->address do-ffi-ptr->address)) + +;; ---------------------------------------- + +(define/who ptr-ref + (case-lambda + [(p type) + (check who cpointer? p) + (check who ctype? type) + (c->s type (foreign-ref* type p 0))] + [(p type offset) + (check who cpointer? p) + (check who ctype? type) + (check who exact-integer? offset) + (c->s type (foreign-ref* type + p + (* (ctype-sizeof type) offset)))] + [(p type abs-tag offset) + (check who cpointer? p) + (check who ctype? type) + (check who (lambda (p) (eq? p 'abs)) :contract "'abs" abs-tag) + (check who exact-integer? offset) + (c->s type (foreign-ref* type p offset))])) + +(define (foreign-ref* type orig-p offset) + (cond + [(and (ffi-obj? orig-p) + (eq? 'fpointer (ctype-our-rep type))) + ;; Special case for `ptr-ref` on a function-type ffi-object: + ;; cancel a level of indirection and preserve `ffi-obj`ness + ;; to keep its name + orig-p] + [else + (cond + [(compound-ctype? type) + ;; Instead of copying, get a pointer within `p`: + (do-ptr-add orig-p offset #f)] + [else + (let ([p (unwrap-cpointer 'foreign-ref* orig-p)] + [host-rep (ctype-host-rep type)]) + (cond + [(cpointer-nonatomic? p) + (let ([offset (+ offset (ptr-offset* p))]) + (cond + [(and (word-aligned? offset) + (or (eq? 'void* host-rep) + (eq? 'scheme-object host-rep))) + (let* ([i (fxsrl offset log-ptr-size-in-bytes)] + [v (vector-ref (cpointer-memory p) i)]) + (cond + [(eq? 'scheme-object host-rep) v] + [(stripped-cpointer? v) v] + [else + (raise-arguments-error 'ptr-ref + "cannot convert value to a cpointer" + "extracted value" v + "source" orig-p)]))] + [else + (raise-arguments-error 'ptr-ref "unsupported access into non-atomic memory" + "offset" offset + "representation" host-rep + "source" orig-p)]))] + [else + ;; Disable interrupts to avoid a GC: + (with-interrupts-disabled + ;; Special treatment is needed for 'scheme-object, since the + ;; host Scheme rejects the use of 'scheme-object with + ;; `foreign-ref` + (let ([v (foreign-ref (if (eq? host-rep 'scheme-object) + 'uptr + host-rep) + (cpointer-address p) + offset)]) + (case host-rep + [(scheme-object) (address->object v 1)] + [else + (case (ctype-our-rep type) + [(gcpointer) (addr->gcpointer-memory v)] + [else v])])))]))])])) + +(define/who ptr-set! + (case-lambda + [(p type v) + (check who cpointer? p) + (check who ctype? type) + (foreign-set!* type + p + 0 + v)] + [(p type offset v) + (check who cpointer? p) + (check who ctype? type) + (check who exact-integer? offset) + (foreign-set!* type + p + (* (ctype-sizeof type) offset) + v)] + [(p type abs-tag offset v) + (check who cpointer? p) + (check who ctype? type) + (check who (lambda (p) (eq? p 'abs)) :contract "'abs" abs-tag) + (check who exact-integer? offset) + (foreign-set!* type + p + offset + v)])) + +(define ptr-size-in-bytes (foreign-sizeof 'void*)) +(define log-ptr-size-in-bytes (- (integer-length ptr-size-in-bytes) 1)) + +(define (word-aligned? offset) + (zero? (fxand offset (fx- ptr-size-in-bytes 1)))) + +(define (foreign-set!* type orig-p offset orig-v) + (let ([p (unwrap-cpointer 'foreign-set!* orig-p)]) + (cond + [(compound-ctype? type) + ;; Corresponds to a copy, since `v` is represented by a pointer + (memcpy* p offset + (s->c type orig-v) 0 + (compound-ctype-size type) + #f)] + [else + (let ([host-rep (ctype-host-rep type)] + [v (s->c type orig-v)]) + (cond + [(cpointer-nonatomic? p) + (let ([offset (+ offset (ptr-offset* p))]) + (cond + [(and (word-aligned? offset) + (or (eq? 'void* host-rep) + (eq? 'scheme-object host-rep))) + (let ([i (fxsrl offset log-ptr-size-in-bytes)]) + (if (eq? host-rep 'scheme-object) + (vector-set! (cpointer-memory p) i v) + (let ([v (cpointer-strip v)]) + (if (eq? v none) + (raise-arguments-error 'ptr-set! + "cannot install value into non-atomic memory" + "value" orig-v + "destination" orig-p) + (vector-set! (cpointer-memory p) i v)))))] + [else + (raise-arguments-error 'ptr-set! "unsupported access into non-atomic memory" + "offset" offset + "representation" host-rep + "value" orig-v + "destination" orig-p)]))] + [(and (cpointer-nonatomic? v) + (not (cpointer/cell? v))) + (raise-arguments-error 'ptr-set! + "cannot install non-atomic pointer into atomic memory" + "non-atomic pointer" orig-v + "destination" orig-p)] + [else + ;; Disable interrupts to avoid a GC: + (with-interrupts-disabled + ;; Special treatment is needed for 'scheme-object, since + ;; the host Scheme rejects the use of 'scheme-object with + ;; `foreign-set!` + (foreign-set! (if (eq? host-rep 'scheme-object) + 'uptr + host-rep) + (cpointer-address p) + offset + (case host-rep + [(scheme-object) (object->addr v 1)] + [(void*) (cpointer-address v)] + [else v])))]))]))) + +(define (memcpy* to to-offset from from-offset len move?) + (let ([to (unwrap-cpointer* 'memcpy to)] + [from (unwrap-cpointer* 'memcpy from)]) + (cond + [(or (cpointer-nonatomic? to) + (cpointer-nonatomic? from)) + (cond + [(and (cpointer-nonatomic? to) + (cpointer-nonatomic? from)) + (let ([to-offset (+ to-offset (ptr-offset* to))] + [from-offset (+ from-offset (ptr-offset* from))]) + (cond + [(and (word-aligned? to-offset) + (word-aligned? from-offset) + (word-aligned? len)) + (let ([to-i (fxsrl to-offset log-ptr-size-in-bytes)] + [from-i (fxsrl from-offset log-ptr-size-in-bytes)] + [n (fxsrl len log-ptr-size-in-bytes)]) + (vector-copy! (cpointer-memory to) to-i + (cpointer-memory from) from-i + (+ from-i n)))] + [else + (raise-arguments-error (if move? 'memmove 'memcpy) "unaligned non-atomic memory transfer" + "destination" to + "source" from + "destination offset" to-offset + "source offset" from-offset + "count" len)]))] + [else + (raise-arguments-error (if move? 'memmove 'memcpy) "cannot copy non-atomic to/from atomic" + "destination" to + "source" from)])] + [else + (with-interrupts-disabled + (let ([to (fx+ (cpointer*-address to) to-offset)] + [from (fx+ (cpointer*-address from) from-offset)]) + (cond + [(and move? + ;; overlap? + (or (<= to from (fx+ to len -1)) + (<= from to (fx+ from len -1))) + ;; shifting up? + (< from to)) + ;; Copy from high to low to move in overlapping region + (let loop ([to (+ to len)] [from (+ from len)] [len len]) + (unless (fx= len 0) + (cond + #; + [(fx>= len 8) + (let ([to (fx- to 8)] + [from (fx- from 8)]) + (foreign-set! 'integer-64 to 0 + (foreign-ref 'integer-64 from 0)) + (loop to from (fx- len 8)))] + [(and (meta-cond [(> (fixnum-width) 32) #t] [else #f]) + (fx>= len 4)) + (let ([to (fx- to 4)] + [from (fx- from 4)]) + (foreign-set! 'integer-32 to 0 + (foreign-ref 'integer-32 from 0)) + (loop to from (fx- len 4)))] + [(fx>= len 2) + (let ([to (fx- to 2)] + [from (fx- from 2)]) + (foreign-set! 'integer-16 to 0 + (foreign-ref 'integer-16 from 0)) + (loop to from (fx- len 2)))] + [else + (let ([to (fx- to 1)] + [from (fx- from 1)]) + (foreign-set! 'integer-8 to 0 + (foreign-ref 'integer-8 from 0)) + (loop to from (fx- len 1)))])))] + [else + (let loop ([to to] [from from] [len len]) + (unless (fx= len 0) + (cond + #; + [(fx>= len 8) + (foreign-set! 'integer-64 to 0 + (foreign-ref 'integer-64 from 0)) + (loop (fx+ to 8) (fx+ from 8) (fx- len 8))] + [(and (meta-cond [(> (fixnum-width) 32) #t] [else #f]) + (fx>= len 4)) + (foreign-set! 'integer-32 to 0 + (foreign-ref 'integer-32 from 0)) + (loop (fx+ to 4) (fx+ from 4) (fx- len 4))] + [(fx>= len 2) + (foreign-set! 'integer-16 to 0 + (foreign-ref 'integer-16 from 0)) + (loop (fx+ to 2) (fx+ from 2) (fx- len 2))] + [else + (foreign-set! 'integer-8 to 0 + (foreign-ref 'integer-8 from 0)) + (loop (fx+ to 1) (fx+ from 1) (fx- len 1))])))])))]))) + +(define memcpy/memmove + (case-lambda + [(who cptr src-cptr count) + (check who cpointer? cptr) + (check who cpointer? src-cptr) + (check who exact-nonnegative-integer? count) + (memcpy* cptr 0 src-cptr 0 count (eq? who 'memmove))] + [(who cptr offset/src-cptr/src-cptr src-cptr/offset/count count/count/type) + (check who cpointer? cptr) + (cond + [(cpointer? offset/src-cptr/src-cptr) + ;; use y or z of x/y/z + (cond + [(ctype? count/count/type) + ;; use z of x/y/z + (check who exact-nonnegative-integer? src-cptr/offset/count) + (memcpy* cptr 0 (unwrap-cpointer who offset/src-cptr/src-cptr) 0 (* src-cptr/offset/count (ctype-sizeof count/count/type)) (eq? who 'memmove))] + [else + ;; use y of x/y/z + (check who exact-integer? src-cptr/offset/count) + (check who exact-nonnegative-integer? count/count/type) + (memcpy* cptr 0 (unwrap-cpointer who offset/src-cptr/src-cptr) src-cptr/offset/count src-cptr/offset/count (eq? who 'memmove))])] + [else + ;; use x of x/y/z + (check who exact-integer? offset/src-cptr/src-cptr) + (check who cpointer? src-cptr/offset/count) + (check who exact-nonnegative-integer? count/count/type) + (memcpy* cptr offset/src-cptr/src-cptr src-cptr/offset/count 0 count/count/type (eq? who 'memmove))])] + [(who cptr offset src-cptr src-offset/count count/type) + (check who cpointer? cptr) + (check who exact-integer? offset) + (check who cpointer? src-cptr) + (cond + [(ctype? count/type) + ;; use y of x/y + (check who exact-nonnegative-integer? src-offset/count) + (let ([sz (ctype-sizeof count/type)]) + (memcpy* cptr (* sz offset) src-cptr 0 (* src-offset/count sz) (eq? who 'memmove)))] + [else + ;; use x of x/y + (check who exact-integer? src-offset/count) + (check who exact-nonnegative-integer? count/type) + (memcpy* cptr offset src-cptr src-offset/count count/type (eq? who 'memmove))])] + [(who cptr offset src-cptr src-offset count type) + (check who cpointer? cptr) + (check who exact-integer? offset) + (check who cpointer? src-cptr) + (check who exact-integer? src-offset) + (check who ctype? type) + (let ([sz (ctype-sizeof type)]) + (memcpy* cptr (* offset sz) src-cptr (* src-offset sz) (* count sz) (eq? who 'memmove)))])) + +(define/who memcpy + (case-lambda + [(cptr src-cptr count) + (memcpy/memmove who cptr src-cptr count)] + [(cptr offset/src-cptr src-cptr/count count/type) + (memcpy/memmove who cptr offset/src-cptr src-cptr/count count/type)] + [(cptr offset src-cptr src-offset/count count/type) + (memcpy/memmove who cptr offset src-cptr src-offset/count count/type)] + [(cptr offset src-cptr src-offset count type) + (memcpy/memmove who cptr offset src-cptr src-offset count type)])) + +(define/who memmove + (case-lambda + [(cptr src-cptr count) + (memcpy/memmove who cptr src-cptr count)] + [(cptr offset/src-cptr src-cptr/count count/type) + (memcpy/memmove who cptr offset/src-cptr src-cptr/count count/type)] + [(cptr offset src-cptr src-offset/count count/type) + (memcpy/memmove who cptr offset src-cptr src-offset/count count/type)] + [(cptr offset src-cptr src-offset count type) + (memcpy/memmove who cptr offset src-cptr src-offset count type)])) + +;; ---------------------------------------- + +(define (memset* to to-offset byte len) + (let ([to (unwrap-cpointer* 'memset to)]) + (cond + [(cpointer-nonatomic? to) + (raise-arguments-error 'memset "cannot set non-atomic" + "destination" to)] + [else + (with-interrupts-disabled + (let ([to (fx+ (cpointer*-address to) to-offset)]) + (let loop ([to to] [len len]) + (unless (fx= len 0) + (foreign-set! 'unsigned-8 to 0 byte) + (loop (fx+ to 1) (fx- len 1))))))]))) + +(define/who memset + (case-lambda + [(cptr byte count) + (check who cpointer? cptr) + (check who byte? byte) + (check who exact-nonnegative-integer? count) + (memset* cptr 0 byte count)] + [(cptr byte/offset count/byte type/count) + (check who cpointer? cptr) + (cond + [(ctype? type/count) + (check who byte? byte/offset) + (check who exact-nonnegative-integer? count/byte) + (memset* cptr 0 byte/offset (fx* count/byte (ctype-sizeof type/count)))] + [else + (check who exact-integer? byte/offset) + (check who byte? count/byte) + (check who exact-nonnegative-integer? type/count) + (memset* cptr byte/offset count/byte type/count)])] + [(cptr offset byte count type) + (check who cpointer? cptr) + (check who exact-integer? offset) + (check who byte? byte) + (check who exact-nonnegative-integer? count) + (check who ctype? type) + (memset* cptr (fx* offset (ctype-sizeof type)) byte (fx* count (ctype-sizeof type)))])) + +;; ---------------------------------------- + +;; With finalization through an ordered guardian, +;; a "late" weak hash table is just a hash table. +(define (make-late-weak-hasheq) + (make-weak-hasheq)) + +;; Same for late weak boxes: +(define (make-late-weak-box b) + (make-weak-box b)) + +(define malloc + ;; Recognize common ordering as fast cases, and dispatch to + ;; a general handler to arbtrary argument order + (case-lambda + [(arg1) + (cond + [(nonnegative-fixnum? arg1) + (normalized-malloc arg1 'atomic)] + [(ctype? arg1) + (normalized-malloc (ctype-sizeof arg1) (ctype-malloc-mode arg1))] + [else + (do-malloc (list arg1))])] + [(arg1 arg2) + (cond + [(and (nonnegative-fixnum? arg1) + (ctype? arg2)) + (normalized-malloc (* arg1 (ctype-sizeof arg2)) (ctype-malloc-mode arg2))] + [(and (ctype? arg1) + (nonnegative-fixnum? arg2)) + (normalized-malloc (* arg2 (ctype-sizeof arg1)) (ctype-malloc-mode arg1))] + [(and (nonnegative-fixnum? arg1) + (malloc-mode? arg2)) + (normalized-malloc arg1 arg2)] + [else + (do-malloc (list arg1 arg2))])] + [(arg1 arg2 arg3) (do-malloc (list arg1 arg2 arg3))] + [(arg1 arg2 arg3 arg4) (do-malloc (list arg1 arg2 arg3 arg4))] + [(arg1 arg2 arg3 arg4 arg5) (do-malloc (list arg1 arg2 arg3 arg4 arg5))])) + +(define (do-malloc args) + (let ([duplicate-argument + (lambda (what a1 a2) + (raise-arguments-error 'malloc + (string-append "mulitple " what " arguments") + "first" a1 + "second" a2))]) + (let loop ([args args] [count #f] [type #f] [copy-from #f] [mode #f] [fail-mode #f]) + (cond + [(null? args) + (let* ([len (* (or count 1) (if type (ctype-sizeof type) 1))] + [p (normalized-malloc len + (or mode (if type (ctype-malloc-mode type) 'atomic)))]) + (when copy-from + (memcpy* p 0 copy-from 0 len #f)) + p)] + [(nonnegative-fixnum? (car args)) + (if count + (duplicate-argument "size" count (car args)) + (loop (cdr args) (car args) type copy-from mode fail-mode))] + [(ctype? (car args)) + (if type + (duplicate-argument "type" type (car args)) + (loop (cdr args) count (car args) copy-from mode fail-mode))] + [(and (cpointer? (car args)) (car args)) + (if copy-from + (duplicate-argument "source for copy" copy-from (car args)) + (loop (cdr args) count type (car args) mode fail-mode))] + [(malloc-mode? (car args)) + (if copy-from + (duplicate-argument "mode" mode (car args)) + (loop (cdr args) count type copy-from (car args) fail-mode))] + [(eq? (car args) 'failok) + (if copy-from + (duplicate-argument "failure mode" fail-mode (car args)) + (loop (cdr args) count type copy-from mode (car args)))] + [else + (raise-argument-error 'malloc + (string-append "(or/c (and/c exact-nonnegative-integer? fixnum?)\n" + " ctype? cpointer?\n" + " (or/c 'raw 'atomic 'nonatomic 'tagged\n" + " 'atomic-interior 'interior\n" + " 'stubborn 'uncollectable 'eternal)\n" + " 'fail-ok)") + (car args))])))) + +(define (normalized-malloc size mode) + (cond + [(eqv? size 0) #f] + [(eq? mode 'raw) + (make-cpointer (foreign-alloc size) #f)] + [(eq? mode 'atomic) + (make-cpointer (make-bytevector size) #f)] + [(eq? mode 'nonatomic) + (make-cpointer (make-vector (quotient size 8) 0) #f)] + [(eq? mode 'atomic-interior) + ;; This is not quite the same as traditional Racket, because + ;; a finalizer is associated with the cpointer (as opposed to + ;; the address that is wrapped by the cpointer). Also, interior + ;; pointers are not allowed as GCable pointers. + (let* ([bstr (make-bytevector size)] + [p (make-cpointer bstr #f)]) + (lock-object bstr) + (the-foreign-guardian p (lambda () (unlock-object bstr))) + p)] + [else + (raise-unsupported-error 'malloc + (format "'~a mode is not supported" mode))])) + +(define/who (free p) + (let ([p (unwrap-cpointer who p)]) + (with-interrupts-disabled + (foreign-free (cpointer-address p))))) + +(define-record-type (cpointer/cell make-cpointer/cell cpointer/cell?) + (parent cpointer) + (fields)) + +(define (malloc-immobile-cell v) + (let ([vec (vector v)]) + (lock-object vec) + (make-cpointer/cell vec #f))) + +(define (free-immobile-cell b) + (unlock-object (cpointer-memory b))) + +(define (malloc-mode? v) + (chez:memq v '(raw atomic nonatomic tagged + atomic-interior interior + stubborn uncollectable eternal))) + +(define (end-stubborn-change p) + (raise-unsupported-error 'end-stubborn-change)) + +(define (extflvector->cpointer extfl-vector) + (raise-unsupported-error 'extflvector->cpointer)) + +(define (vector->cpointer vec) + (make-cpointer vec #f)) + +(define (flvector->cpointer flvec) + (make-cpointer (flvector-bstr flvec) #f)) + +;; ---------------------------------------- + +(define the-foreign-guardian (make-guardian)) + +;; Can be called in any host thread +(define (poll-foreign-guardian) + (let ([v (the-foreign-guardian)]) + (when v + (v) + (poll-foreign-guardian)))) + +;; ---------------------------------------- + +(define/who ffi-call + (case-lambda + [(p in-types out-type) + (ffi-call p in-types out-type #f #f #f)] + [(p in-types out-type abi) + (ffi-call p in-types out-type abi #f #f)] + [(p in-types out-type abi save-errno) + (ffi-call p in-types out-type abi save-errno #f)] + [(p in-types out-type abi save-errno orig-place?) + (ffi-call p in-types out-type abi save-errno orig-place? #f)] + [(p in-types out-type abi save-errno orig-place? lock-name) + (ffi-call p in-types out-type abi save-errno orig-place? lock-name #f)] + [(p in-types out-type abi save-errno orig-place? lock-name blocking?) + (check who cpointer? p) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + ((ffi-call/callable #t in-types out-type abi save-errno blocking? #f #f) p)])) + +(define/who ffi-call-maker + (case-lambda + [(in-types out-type) + (ffi-call-maker in-types out-type #f #f #f)] + [(in-types out-type abi) + (ffi-call-maker in-types out-type abi #f #f)] + [(in-types out-type abi save-errno) + (ffi-call-maker in-types out-type abi save-errno #f)] + [(in-types out-type abi save-errno orig-place?) + (ffi-call-maker in-types out-type abi save-errno orig-place? #f)] + [(in-types out-type abi save-errno orig-place? lock-name) + (ffi-call-maker in-types out-type abi save-errno orig-place? lock-name #f)] + [(in-types out-type abi save-errno orig-place? lock-name blocking?) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + (ffi-call/callable #t in-types out-type abi save-errno blocking? #f #f)])) + +(define (ffi-call/callable call? in-types out-type abi save-errno blocking? atomic? async-apply) + (let* ([conv (case abi + [(stdcall) '__stdcall] + [(sysv) '__cdecl] + [else #f])] + [by-value? (lambda (type) + ;; An 'array rep is compound, but should be + ;; passed as a pointer, so only pass 'struct and + ;; 'union "by value": + (chez:memq (ctype-host-rep type) '(struct union)))] + [array-rep-to-pointer-rep (lambda (host-rep) + (if (eq? host-rep 'array) + 'void* + host-rep))] + [ids (map (lambda (in-type) + (and (by-value? in-type) + (gensym))) + in-types)] + [ret-id (and (by-value? out-type) + (gensym))] + [decls (let loop ([in-types in-types] [ids ids] [decls '()]) + (cond + [(null? in-types) decls] + [(car ids) + (let ([id-decls ((compound-ctype-get-decls (car in-types)) (car ids))]) + (loop (cdr in-types) (cdr ids) (append decls id-decls)))] + [else + (loop (cdr in-types) (cdr ids) decls)]))] + [ret-decls (if ret-id + ((compound-ctype-get-decls out-type) ret-id) + '())] + [ret-size (and ret-id (ctype-sizeof out-type))] + [gen-proc+ret-maker+arg-makers + (let ([expr `(let () + ,@decls + ,@ret-decls + (list + (lambda (to-wrap) + (,(if call? 'foreign-procedure 'foreign-callable) + ,conv + ,@(if (or blocking? async-apply) '(__thread) '()) + to-wrap + ,(map (lambda (in-type id) + (if id + `(& ,id) + (array-rep-to-pointer-rep + (ctype-host-rep in-type)))) + in-types ids) + ,(if ret-id + `(& ,ret-id) + (array-rep-to-pointer-rep + (ctype-host-rep out-type))))) + ,(and call? + ret-id + `(lambda (p) + (make-ftype-pointer ,ret-id p))) + ,@(if call? + (map (lambda (id) + (and id + `(lambda (p) + (make-ftype-pointer ,id p)))) + ids) + '())))]) + (call-with-system-wind (lambda () (eval expr))))] + [gen-proc (car gen-proc+ret-maker+arg-makers)] + [ret-maker (cadr gen-proc+ret-maker+arg-makers)] + [arg-makers (cddr gen-proc+ret-maker+arg-makers)] + [async-callback-queue (and (procedure? async-apply) (current-async-callback-queue))]) + (cond + [call? + (lambda (to-wrap) + (let* ([proc-p (unwrap-cpointer 'ffi-call to-wrap)]) + (lambda args + (let* ([args (map (lambda (orig-arg in-type) + (let ([arg (s->c in-type orig-arg)]) + (if (and (cpointer? arg) + (not (eq? 'scheme-object (ctype-host-rep in-type)))) + (let ([p (unwrap-cpointer 'ffi-call arg)]) + (when (and (cpointer-nonatomic? p) + (not (cpointer/cell? p))) + (disallow-nonatomic-pointer 'argument orig-arg proc-p)) + p) + arg))) + args in-types)] + [r (let ([ret-ptr (and ret-id + ;; result is a struct type; need to allocate space for it + (make-bytevector ret-size))]) + (with-interrupts-disabled + (let ([r (#%apply (gen-proc (cpointer-address proc-p)) + (append + (if ret-ptr + (list (ret-maker (memory-address ret-ptr))) + '()) + (map (lambda (arg in-type maker) + (let ([host-rep (array-rep-to-pointer-rep + (ctype-host-rep in-type))]) + (case host-rep + [(void*) (cpointer-address arg)] + [(struct union) + (maker (cpointer-address arg))] + [else arg]))) + args in-types arg-makers)))]) + (case save-errno + [(posix) (thread-cell-set! errno-cell (get-errno))] + [(windows) (thread-cell-set! errno-cell (get-last-error))]) + (cond + [ret-ptr + (make-cpointer ret-ptr #f)] + [(eq? (ctype-our-rep out-type) 'gcpointer) + (addr->gcpointer-memory r)] + [else r]))))]) + (c->s out-type r)))))] + [else ; callable + (lambda (to-wrap) + (gen-proc (lambda args ; if ret-id, includes an extra initial argument to receive the result + (let ([v (call-as-atomic-callback + (lambda () + (s->c + out-type + (apply to-wrap + (let loop ([args (if ret-id (cdr args) args)] [in-types in-types]) + (cond + [(null? args) '()] + [else + (let* ([arg (car args)] + [type (car in-types)] + [arg (c->s type + (case (ctype-host-rep type) + [(struct union) + (let* ([size (compound-ctype-size type)] + [addr (ftype-pointer-address arg)] + [bstr (make-bytevector size)]) + (memcpy* bstr 0 addr 0 size #f) + (make-cpointer bstr #f))] + [else + (cond + [(eq? (ctype-our-rep type) 'gcpointer) + (addr->gcpointer-memory arg)] + [else arg])]))]) + (cons arg (loop (cdr args) (cdr in-types))))]))))) + atomic? + async-apply + async-callback-queue)]) + (if ret-id + (let* ([size (compound-ctype-size out-type)] + [addr (ftype-pointer-address (car args))]) + (memcpy* addr 0 v 0 size #f)) + (case (ctype-host-rep out-type) + [(void*) (cpointer-address v)] + [else v]))))))]))) + +(define (types->reps types) + (let loop ([types types] [reps '()] [decls '()]) + (cond + [(null? types) (values (reverse reps) decls)] + [else + (let ([type (car types)]) + (if (compound-ctype? type) + (let* ([id (gensym)] + [id-decls ((compound-ctype-get-decls type) id)]) + (loop (cdr types) (cons id reps) (append id-decls decls))) + (loop (cdr types) (cons (ctype-host-rep type) reps) decls)))]))) + +(define (disallow-nonatomic-pointer what arg proc-p) + (raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function" + "pointer" arg + "function" (or (and (ffi-obj? proc-p) + (cpointer/ffi-obj-name proc-p)) + 'unknown))) + +;; Rely on the fact that a virtual register defaults to 0 to detect a +;; thread that we didn't start. For a thread that we did start, a +(define PLACE-UNKNOWN-THREAD 0) +(define PLACE-KNOWN-THREAD 1) +(define PLACE-MAIN-THREAD 2) +(define-virtual-register place-thread-category PLACE-KNOWN-THREAD) +(define (register-as-place-main!) + (place-thread-category PLACE-MAIN-THREAD) + (current-async-callback-queue (make-async-callback-queue (make-mutex) + (make-condition) + '()))) + +;; Can be called in any Scheme thread +(define (call-as-atomic-callback thunk atomic? async-apply async-callback-queue) + (cond + [(eqv? (place-thread-category) PLACE-MAIN-THREAD) + ;; In the main thread of a place. We must have gotten here by a + ;; foreign call that called back, so interrupts are currently + ;; disabled. + (cond + [(not atomic?) + ;; reenable interrupts + (enable-interrupts) + (let ([v (thunk)]) + (disable-interrupts) + v)] + [else + ;; Inform the scheduler that it's in atomic mode + (scheduler-start-atomic) + (let ([v (thunk)]) + (scheduler-end-atomic) + v)])] + [(box? async-apply) + ;; Not in a place's main thread; return the box's content + (unbox async-apply)] + [else + ;; Not in a place's main thread; queue an async callback + ;; and wait for the response + (let* ([result-done? (box #f)] + [result #f] + [q async-callback-queue] + [m (async-callback-queue-lock q)] + [need-interrupts? + ;; If we created this therad by `fork-pthread`, we must + ;; have gotten here by a foreign call, so interrupts are + ;; currently disabled + (eqv? (place-thread-category) PLACE-KNOWN-THREAD)]) + (mutex-acquire m) + (set-async-callback-queue-in! q (cons (lambda () + (set! result (|#%app| async-apply thunk)) + (mutex-acquire m) + (set-box! result-done? #t) + (condition-broadcast (async-callback-queue-condition q)) + (mutex-release m)) + (async-callback-queue-in q))) + (async-callback-poll-wakeup) + (let loop () + (unless (unbox result-done?) + (when need-interrupts? + ;; Enable interrupts so that the thread is deactivated + ;; when we wait on the condition + (enable-interrupts)) + (condition-wait (async-callback-queue-condition q) m) + (when need-interrupts? (disable-interrupts)) + (loop))) + (mutex-release m) + result)])) + +(define scheduler-start-atomic void) +(define scheduler-end-atomic void) +(define (set-scheduler-atomicity-callbacks! start-atomic end-atomic) + (set! scheduler-start-atomic start-atomic) + (set! scheduler-end-atomic end-atomic)) + +(define async-callback-poll-wakeup void) +(define (set-async-callback-poll-wakeup! wakeup) + (set! async-callback-poll-wakeup wakeup)) + +(define-record async-callback-queue (lock condition in)) + +(define-virtual-register current-async-callback-queue #f) + +;; Returns callbacks to run in atomic mode +(define (poll-async-callbacks) + (let ([q (current-async-callback-queue)]) + (mutex-acquire (async-callback-queue-lock q)) + (let ([in (async-callback-queue-in q)]) + (cond + [(null? in) + (mutex-release (async-callback-queue-lock q)) + '()] + [else + (set-async-callback-queue-in! q '()) + (mutex-release (async-callback-queue-lock q)) + (reverse in)])))) + +;; ---------------------------------------- + +(define-record-type (callback create-callback ffi-callback?) + (fields code)) + +(define/who ffi-callback + (case-lambda + [(proc in-types out-type) + (ffi-callback proc in-types out-type #f #f #f)] + [(proc in-types out-type abi) + (ffi-callback proc in-types out-type abi #f #f)] + [(proc in-types out-type abi atomic?) + (ffi-callback proc in-types out-type abi atomic? #f)] + [(proc in-types out-type abi atomic? async-apply) + (check who procedure? proc) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + ((ffi-callback-maker in-types out-type abi atomic? async-apply) proc)])) + +(define/who ffi-callback-maker + (case-lambda + [(in-types out-type) + (ffi-callback-maker in-types out-type #f #f #f)] + [(in-types out-type abi) + (ffi-callback-maker in-types out-type abi #f #f)] + [(in-types out-type abi atomic?) + (ffi-callback-maker in-types out-type abi atomic? #f)] + [(in-types out-type abi atomic? async-apply) + (check who (lambda (l) + (and (list? l) + (andmap ctype? l))) + :contract "(listof ctype?)" + in-types) + (check who ctype? out-type) + (let ([make-code (ffi-call/callable #f in-types out-type abi #f #f (and atomic? #t) async-apply)]) + (lambda (proc) + (check 'make-ffi-callback procedure? proc) + (let* ([code (make-code proc)] + [cb (create-callback code)]) + (lock-object code) + (the-foreign-guardian cb (lambda () (unlock-object code))) + cb)))])) + +;; ---------------------------------------- + +(define/who (make-sized-byte-string cptr len) + (check who cpointer? cptr) + (check who exact-nonnegative-integer? len) + (raise-unsupported-error who)) + +(define errno-cell (make-thread-cell 0)) + +(define/who saved-errno + (case-lambda + [() (thread-cell-ref errno-cell)] + [(v) + (check who exact-integer? v) + (thread-cell-set! errno-cell v)])) + +(define/who (lookup-errno sym) + (check who symbol? sym) + (raise-unsupported-error who)) + +;; function is called with interrupts disabled +(define get-errno + (let ([get-&errno-name + (case (machine-type) + [(a6nt ta6nt i3nt ti3nt) + (load-shared-object "msvcrt.dll") + "_errno"] + [(a6osx ta6osx i3osx ti3osx) + (load-shared-object "libc.dylib") + "__error"] + [(a6le ta6le i3le ti3le) + (load-shared-object "libc.so.6") + "__errno_location"] + [else + ;; FIXME for more platforms + (load-shared-object "libc.so") + "__error"])]) + (let ([get-&errno (foreign-procedure get-&errno-name () void*)]) + (lambda () + (foreign-ref 'int (get-&errno) 0))))) + +;; function is called with interrupts disabled +(define get-last-error + (case (machine-type) + [(a6nt ta6nt i3nt ti3nt) + (load-shared-object "kernel32.dll") + (foreign-procedure "GetLastError" () int)] + [else (lambda () 0)])) + +;; ---------------------------------------- + +(define process-global-table (make-hashtable equal-hash-code equal?)) +(define process-table-lock (make-mutex)) + +(define (unsafe-register-process-global key val) + (with-interrupts-disabled + (mutex-acquire process-table-lock) + (let ([result (cond + [(not val) + (hashtable-ref process-global-table key #f)] + [else + (let ([old-val (hashtable-ref process-global-table key #f)]) + (cond + [(not old-val) + (hashtable-set! process-global-table key val) + #f] + [else old-val]))])]) + (mutex-release process-table-lock) + result))) + +;; ---------------------------------------- + +(define (set-cpointer-hash!) + (record-type-equal-procedure (record-type-descriptor cpointer) + (lambda (a b eql?) + (ptr-equal? a b))) + (record-type-hash-procedure (record-type-descriptor cpointer) + (lambda (a hc) + (if (number? (cpointer-memory a)) + (hc (+ (cpointer-memory a) + (ptr-offset* a))) + (eq-hash-code (cpointer-memory a)))))) diff --git a/racket/src/cs/rumble/fsemaphore.ss b/racket/src/cs/rumble/fsemaphore.ss new file mode 100644 index 0000000000..41766e8334 --- /dev/null +++ b/racket/src/cs/rumble/fsemaphore.ss @@ -0,0 +1,20 @@ +;; future semaphores + +;; just copied from expander-compat.scm +(define-record-type (fsemaphore create-fsemaphore fsemaphore?) + (fields sema)) + +(define (make-fsemaphore init) + (create-fsemaphore (make-semaphore init))) + +(define (fsemaphore-post fsema) + (semaphore-post (fsemaphore-sema f))) + +(define (fsemaphore-wait fsema) + (semaphore-wait (fsemaphore-sema f))) + +(define (fsemaphore-try-wait fsema) + (semaphore-try-wait? (fsemaphore-sema f))) + +(define (fsemaphore-count fsema) + (semaphore-count (fsemaphore-sema f))) diff --git a/racket/src/cs/rumble/future.ss b/racket/src/cs/rumble/future.ss new file mode 100644 index 0000000000..b3593cf4c4 --- /dev/null +++ b/racket/src/cs/rumble/future.ss @@ -0,0 +1,14 @@ +;; Futures API + +(define future? (lambda (f) #f)) +(define current-future (lambda () #f)) +(define block (lambda () (void))) +(define current-future-prompt (lambda () (void))) +(define future-wait (lambda () (void))) + +(define (set-future-callbacks! _future? _current-future _block wait cfp) + (set! future? _future?) + (set! current-future _current-future) + (set! block _block) + (set! future-wait wait) + (set! current-future-prompt cfp)) diff --git a/racket/src/cs/rumble/graph.ss b/racket/src/cs/rumble/graph.ss new file mode 100644 index 0000000000..e5a8c08ecb --- /dev/null +++ b/racket/src/cs/rumble/graph.ss @@ -0,0 +1,172 @@ + +(define-record placeholder (val)) +(define-record-type (hash-placeholder create-hash-placeholder hash-placeholder?) + (fields (mutable alist))) +(define-record-type (hasheq-placeholder create-hasheq-placeholder hasheq-placeholder?) + (parent hash-placeholder) + (fields)) +(define-record-type (hasheqv-placeholder create-hasheqv-placeholder hasheqv-placeholder?) + (parent hash-placeholder) + (fields)) + +(define (placeholder-set! ph datum) + (set-placeholder-val! ph datum)) + +(define (placeholder-get ph) + (placeholder-val ph)) + +(define/who (make-hash-placeholder alst) + (check who + :test (and (list? alst) + (andmap pair? alst)) + :contract "(listof pair?)" + alst) + (create-hash-placeholder alst)) + +(define/who (make-hasheq-placeholder alst) + (check who + :test (and (list? alst) + (andmap pair? alst)) + :contract "(listof pair?)" + alst) + (create-hasheq-placeholder alst)) + +(define/who (make-hasheqv-placeholder alst) + (check who + :test (and (list? alst) + (andmap pair? alst)) + :contract "(listof pair?)" + alst) + (create-hasheqv-placeholder alst)) + +(define/who (make-reader-graph orig-v) + (let ([ht (make-eq-hashtable)]) + (let loop ([v orig-v]) + (cond + [(hashtable-ref ht v #f) + => (lambda (p) p)] + [(placeholder? v) + (let ([next (placeholder-val v)]) + (when (eq? v next) + (raise-arguments-error who + "illegal placeholder cycle in value" + "value" orig-v)) + (loop next))] + [(pair? v) + (let ([p (cons #f #f)]) + (hashtable-set! ht v p) + (set-car! p (loop (car v))) + (set-cdr! p (loop (cdr v))) + (cond + [(and (eq? (car p) (car v)) + (eq? (cdr p) (cdr v))) + ;; No change, so we don't have to make a copy: + (hashtable-set! ht v v) + v] + [else p]))] + [(vector? v) + (let* ([len (vector-length v)] + [p (make-vector len)]) + (hashtable-set! ht v p) + (let vloop ([i 0] [diff? #f]) + (cond + [(fx= i len) + (cond + [diff? + (if (mutable-vector? v) + p + (begin + (#%$vector-set-immutable! p) + p))] + [else + (hashtable-set! ht v v) + v])] + [else + (vector-set! p i (loop (vector-ref v i))) + (vloop (fx1+ i) (or diff? (not (eq? (vector-ref v i) (vector-ref p i)))))])))] + [(box? v) + (let ([p (box #f)]) + (hashtable-set! ht v p) + (set-box! p (loop (unbox v))) + (cond + [(eq? (unbox p) (unbox v)) + (hashtable-set! ht v v) + v] + [(mutable-box? v) + p] + [else + ;; FIXME: need a way to change a box to immutable + p]))] + [(hash? v) + (let* ([mutable? (mutable-hash? v)] + [orig-p (if mutable? + (if (hash-weak? v) + (cond + [(hash-eq? v) (make-weak-hasheq)] + [(hash-eqv? v) (make-weak-hasheqv)] + [else (make-weak-hasheq)]) + (cond + [(hash-eq? v) (make-hasheq)] + [(hash-eqv? v) (make-hasheqv)] + [else (make-hasheq)])) + (cond + [(hash-eq? v) (make-intmap-shell 'eq)] + [(hash-eqv? v) (make-intmap-shell 'eqv)] + [else (make-intmap-shell 'equal)]))]) + (hashtable-set! ht v orig-p) + (let hloop ([p orig-p] [i (hash-iterate-first v)] [diff? #f]) + (cond + [(not i) + (cond + [diff? + (cond + [mutable? orig-p] + [else + (intmap-shell-sync! orig-p p) + orig-p])] + [else + (hashtable-set! ht v v) + v])] + [else + (let-values ([(key val) (hash-iterate-key+value v i)]) + (let ([new-key (loop key)] + [new-val (loop val)]) + (hloop (if mutable? + (hash-set! orig-p key val) + (hash-set p key val)) + (hash-iterate-next v i) + (or diff? (not (and (eq? key new-key) (eq? val new-val)))))))])))] + [(hash-placeholder? v) + (let* ([orig-p (cond + [(hasheq-placeholder? v) (make-intmap-shell 'eq)] + [(hasheqv-placeholder? v) (make-intmap-shell 'eqv)] + [else (make-intmap-shell 'equal)])]) + (hashtable-set! ht v orig-p) + (let hloop ([p orig-p] [alst (hash-placeholder-alist v)]) + (cond + [(null? alst) + (intmap-shell-sync! orig-p p) + orig-p] + [else + (hloop (hash-set p (loop (caar alst)) (loop (cdar alst))) + (cdr alst))])))] + [(prefab-struct-key v) + => (lambda (key) + (let ([args (cdr (vector->list (struct->vector v)))]) + (let ([p (apply make-prefab-struct key args)]) + (hashtable-set! ht v p) + (let aloop ([args args] [i 0] [diff? #f]) + (cond + [(null? args) + (cond + [diff? p] + [else + (hashtable-set! ht v v) + v])] + [else + (let* ([a (car args)] + [new-a (loop a)]) + (unless (eq? a new-a) + (unsafe-struct-set! p i new-a)) + (aloop (cdr args) (fx1+ i) (or diff? (not (eq? a new-a)))))])))))] + [else v])))) diff --git a/racket/src/cs/rumble/hamt.ss b/racket/src/cs/rumble/hamt.ss new file mode 100644 index 0000000000..aaf77631b3 --- /dev/null +++ b/racket/src/cs/rumble/hamt.ss @@ -0,0 +1,932 @@ +;; HAMT + +;; the absence of something +(define NOTHING (gensym 'nothing)) + +;; 16-bit popcount +(define (popcount x) + (let* ([x (fx- x (fxand (fxsrl x 1) #x5555))] + [x (fx+ (fxand x #x3333) (fxand (fxsrl x 2) #x3333))] + [x (fxand (fx+ x (fxsrl x 4)) #x0f0f)] + [x (fx+ x (fxsrl x 8))]) + (fxand x #x1f))) + +;; record types +(define-record-type hnode + [fields (immutable eqtype) + (mutable count) + (mutable keys) + (mutable vals)] + [nongenerative #{hnode pfwh8wvaevt3r6pcwsqn90ry8-0}]) + +(meta-cond + [(> (most-positive-fixnum) (expt 2 32)) + + ;; 64-bit bnode (pack the bitmaps into a single fixnum) + (define-record-type (bnode make-raw-bnode bnode?) + [parent hnode] + [fields (mutable bitmap)] + [nongenerative #{bnode pfwhzqkm2ycuuyedzz2nxjx2e-0}] + [sealed #t]) + + (define (make-bnode eqtype count keys vals keymap childmap) + (let ([bitmap (fxior keymap (fxsll childmap 16))]) + (make-raw-bnode eqtype count keys vals bitmap))) + + (define (bnode-keymap n) + (fxand #xffff (bnode-bitmap n))) + + (define (bnode-childmap n) + (fxsrl (bnode-bitmap n) 16)) + + (define (bnode-copy-bitmaps! dest src) + (bnode-bitmap-set! dest (bnode-bitmap src)))] + + [else + + ;; 32-bit bnode (separate bitmaps) + (define-record-type bnode + [parent hnode] + [fields (mutable keymap) + (mutable childmap)] + [nongenerative #{bnode pfwhzqkm2ycuuyedzz2nxjx2e-1}] + [sealed #t]) + + (define (bnode-copy-bitmaps! dest src) + (bnode-set-keymap! dest (bnode-keymap src)) + (bnode-set-childmap! dest (bnode-childmap src)))]) + +(define-record-type cnode + [parent hnode] + [fields (immutable hash)] + [nongenerative #{cnode pfwh0bwrq2nqlke97ikru0ds2-0}] + [sealed #t]) + +(define (make-empty-bnode eqtype) + (make-bnode eqtype + 0 + (vector) + #f + 0 + 0)) + +(define empty-hasheq (make-empty-bnode 'eq)) +(define empty-hasheqv (make-empty-bnode 'eqv)) +(define empty-hash (make-empty-bnode 'equal)) + +(define (make-hamt-shell eqtype) + (make-empty-bnode eqtype)) + +(define (hamt-shell-sync! dest src) + (hnode-count-set! dest (hnode-count src)) + (hnode-keys-set! dest (hnode-keys src)) + (hnode-vals-set! dest (hnode-vals src)) + (bnode-copy-bitmaps! dest src)) + +;; hamt interface +(define hamt? hnode?) +(define immutable-hash? hnode?) + +(define (hamt-eq? h) + (eq? (hnode-eqtype h) 'eq)) + +(define (hamt-eqv? h) + (eq? (hnode-eqtype h) 'eqv)) + +(define (hamt-equal? h) + (eq? (hnode-eqtype h) 'equal)) + +(define (hamt-has-key? h key) + (node-has-key? h key (hash-code h key) 0)) + +(define (node-has-key? n key keyhash shift) + (cond [(bnode? n) (bnode-has-key? n key keyhash shift)] + [else (cnode-has-key? n key)])) + +(define (hamt-ref h key default) + (cond + [(hamt-empty? h) + ;; Access on an empty HAMT is common, so don't even hash in that case + (if (procedure? default) + (default) + default)] + [else + (let ([res (bnode-ref h key (hash-code h key) 0)]) + (if (eq? res NOTHING) + (if (procedure? default) + (default) + default) + res))])) + +(define (hamt-set h key val) + (bnode-set h key val (hash-code h key) 0)) + +(define (hamt-remove h key) + (bnode-remove h key (hash-code h key) 0)) + +(define (hamt-count h) + (hnode-count h)) + +(define (hamt-empty? h) + (fxzero? (hamt-count h))) + +(define (hamt=? a b eql?) + (and (eq? (hnode-eqtype a) + (hnode-eqtype b)) + (node=? a b eql? 0))) + +(define (hamt-hash-code a hash) + (node-hash-code a hash 0)) + +(define ignored/hamt + (begin + ;; Go through generic `hash` versions to support `a` + ;; and `b` as impersonated hash tables + (record-type-equal-procedure (record-type-descriptor bnode) + (lambda (a b eql?) + (hash=? a b eql?))) + (record-type-hash-procedure (record-type-descriptor bnode) + (lambda (a hash) + (hash-hash-code a hash))))) + +(define (hamt-keys-subset? a b) + (or (hamt-empty? a) + (node-keys-subset? a b 0))) + +(define (hamt-foldk h f nil kont) + (bnode-foldk h f nil kont)) + +(define (hamt-fold h nil fn) + (hamt-foldk + h + (lambda (key val nil k) + (k (fn key val nil))) + nil + (lambda (x) x))) + +(define (hamt->list h) + (hamt-fold h '() (lambda (k v xs) (cons (cons k v) xs)))) + +(define (hamt-keys h) + (hamt-fold h '() (lambda (k _ xs) (cons k xs)))) + +(define (hamt-values h) + (hamt-fold h '() (lambda (_ v xs) (cons v xs)))) + +(define (hamt-for-each h proc) + (hamt-fold h (void) (lambda (k v _) (proc k v) (void)))) + +(define (hamt-map h proc) + (hamt-fold h '() (lambda (k v xs) (cons (proc k v) xs)))) + +;; generatic iteration by counting +(define (hamt-iterate-first h) + (and (not (hamt-empty? h)) + 0)) + +(define (hamt-iterate-next h pos) + (let ([pos (fx1+ pos)]) + (and (not (fx= pos (hamt-count h))) + pos))) + +(define (hamt-iterate-key h pos fail) + (let ([p (node-entry-at-position h pos)]) + (if p + (car p) + fail))) + +(define (hamt-iterate-value h pos fail) + (let ([p (node-entry-at-position h pos)]) + (if p + (cdr p) + fail))) + +(define (hamt-iterate-key+value h pos fail) + (let ([p (node-entry-at-position h pos)]) + (if p + (values (car p) (cdr p)) + fail))) + +(define (hamt-iterate-pair h pos fail) + (let ([p (node-entry-at-position h pos)]) + (or p fail))) + +;; unsafe iteration; position is a stack +;; represented by a list of (cons node index) +(define (unsafe-hamt-iterate-first h) + (and (not (hamt-empty? h)) + (unsafe-node-iterate-first h '()))) + +(define (unsafe-node-iterate-first n stack) + (cond + [(bnode? n) + (let ([i (fx1- (#%vector-length (hnode-keys n)))] + [key-count (popcount (bnode-keymap n))]) + (let ([stack (cons (cons n i) stack)]) + (if (fx>= i key-count) + (unsafe-node-iterate-first (key-ref n i) stack) + stack)))] + [(cnode? n) + (let ([i (fx1- (#%vector-length (hnode-keys n)))]) + (cons (cons n i) stack))])) + +(define (unsafe-hamt-iterate-next h pos) + (unsafe-node-iterate-next pos)) + +(define (unsafe-node-iterate-next pos) + (cond + [(null? pos) + ;; Stack is empty, so we're done + #f] + [else + (let ([p (car pos)] + [stack (cdr pos)]) + (let ([n (car p)] + [i (cdr p)]) + (cond + [(fx= 0 i) + ;; Exhausted this node, so return to parent node + (unsafe-node-iterate-next stack)] + [else + ;; Move to next (lower) index in the current node + (let ([i (fx1- i)]) + (cond + [(bnode? n) + (let ([key-count (popcount (bnode-keymap n))] + [stack (cons (cons n i) stack)]) + (if (fx>= i key-count) + (unsafe-node-iterate-first (key-ref n i) stack) + stack))] + [(cnode? n) + (cons (cons n i) stack)]))])))])) + +(define (unsafe-hamt-iterate-key h pos) + (let ([p (car pos)]) + (key-ref (car p) (cdr p)))) + +(define (unsafe-hamt-iterate-value h pos) + (let ([p (car pos)]) + (val-ref (car p) (cdr p)))) + +(define (unsafe-hamt-iterate-key+value h pos) + (let ([p (car pos)]) + (let ([n (car p)] + [i (cdr p)]) + (values (key-ref n i) + (val-ref n i))))) + +(define (unsafe-hamt-iterate-pair h pos) + (let ([p (car pos)]) + (let ([n (car p)] + [i (cdr p)]) + (cons (key-ref n i) + (val-ref n i))))) + +;; constants +(define HASHCODE-BITS (fxbit-count (most-positive-fixnum))) +(define BNODE-BITS 4) +(define BNODE-MASK (fx1- (fxsll 1 BNODE-BITS))) + +;; vector operations +(define (vector-insert v i x) + (let* ([len (#%vector-length v)] + [new (make-vector (fx1+ len))]) + (vector*-copy! new 0 v 0 i) + (#%vector-set! new i x) + (vector*-copy! new (fx1+ i) v i len) + new)) + +(define (vector-remove v i) + (let* ([len (#%vector-length v)] + [new (make-vector (fx1- len))]) + (vector*-copy! new 0 v 0 i) + (vector*-copy! new i v (fx1+ i) len) + new)) + +;; hnode operations +(define (key=? n k1 k2) + (case (hnode-eqtype n) + [(eq) (eq? k1 k2)] + [(eqv) (eqv? k1 k2)] + [else (key-equal? k1 k2)])) + +(define (hash-code n k) + (case (hnode-eqtype n) + [(eq) (eq-hash-code k)] + [(eqv) (eqv-hash-code k)] + [else (key-equal-hash-code k)])) + +(define (key-ref n i) + (#%vector-ref (hnode-keys n) i)) + +(define (val-ref n i) + (let ([vals (hnode-vals n)]) + (or (not vals) + (#%vector-ref vals i)))) + +(define (node-ref n key keyhash shift) + (cond [(bnode? n) (bnode-ref n key keyhash shift)] + [else (cnode-ref n key)])) + +(define (node-set n key val keyhash shift) + (cond [(bnode? n) (bnode-set n key val keyhash shift)] + [else (cnode-set n key val)])) + +(define (node-remove n key keyhash shift) + (cond [(bnode? n) (bnode-remove n key keyhash shift)] + [else (cnode-remove n key keyhash)])) + +(define (node-singleton? node) + (fx= (hnode-count node) 1)) + +(define (node=? a b eql? shift) + (or (eq? a b) + (and (fx= (hnode-count a) (hnode-count b)) + (cond [(bnode? a) (bnode=? a b eql? shift)] + [else (cnode=? a b eql?)])))) + +(define (node-hash-code n hash hc) + (cond + [(bnode? n) + (let* ([bm (fxior (bnode-keymap n) (bnode-childmap n))] + [hc (hash-code-combine hc bm)] + [len (#%vector-length (hnode-keys n))] + [key-count (popcount (bnode-keymap n))]) + (let loop ([i 0] [hc hc]) + (cond + [(fx= i len) hc] + [else + (let ([x (key-ref n i)]) + (cond + [(fx>= i key-count) + (loop (fx1+ i) + (node-hash-code x hash hc))] + [else + (loop (fx1+ i) + (hash-code-combine hc (hash (val-ref n i))))]))])))] + [else + ;; Hash code needs to be order-independent, so + ;; collision nodes are a problem; simplify by just + ;; using the hash code and hope that collisions are + ;; rare. + (hash-code-combine hc (cnode-hash n))])) + +(define (node-keys-subset? a b shift) + (or (eq? a b) + (and (fx<= (hnode-count a) (hnode-count b)) + (cond [(bnode? a) (bnode-keys-subset? a b shift)] + [else (cnode-keys-subset? a b shift)])))) + +(define (node-entry-at-position n pos) + (cond [(bnode? n) (bnode-entry-at-position n pos)] + [else (cnode-entry-at-position n pos)])) + +(define (node-foldk n f nil kont) + (cond [(bnode? n) (bnode-foldk n f nil kont)] + [else (cnode-foldk n f nil kont)])) + +;; bnode operations +(define (bnode-ref node key keyhash shift) + (let ([bit (bnode-bit-pos keyhash shift)]) + (cond + [(bnode-maps-key? node bit) + (let* ([ki (bnode-key-index node bit)] + [k (key-ref node ki)]) + (if (key=? node key k) + (val-ref node ki) + NOTHING))] + + [(bnode-maps-child? node bit) + (let* ([ci (bnode-child-index node bit)] + [c (child-ref node ci)]) + (node-ref c key keyhash (down shift)))] + + [else + NOTHING]))) + +(define (bnode-has-key? n key keyhash shift) + (not (eq? NOTHING (bnode-ref n key keyhash shift)))) + +(define (bnode-set node key val keyhash shift) + (let ([bit (bnode-bit-pos keyhash shift)]) + + (cond + [(bnode-maps-key? node bit) + (let* ([ki (bnode-key-index node bit)] + [k (key-ref node ki)] + [v (val-ref node ki)]) + (cond + [(key=? node key k) + (if (eq? val v) + node + (bnode-replace-val node ki val))] + [else + (let* ([h (hash-code node k)] + [eqtype (hnode-eqtype node)] + [child (node-merge eqtype k v h key val keyhash (down shift))]) + (bnode-add-child node child ki bit))]))] + + [(bnode-maps-child? node bit) + (let* ([ci (bnode-child-index node bit)] + [child (child-ref node ci)] + [new-child (node-set child key val keyhash (down shift))]) + (if (eq? new-child child) + node + (bnode-replace-child node child new-child ci)))] + + [else + (bnode-add-key node key val bit)]))) + +(define (bnode-remove node key keyhash shift) + (let ([bit (bnode-bit-pos keyhash shift)]) + + (cond + [(bnode-maps-key? node bit) + (let* ([ki (bnode-key-index node bit)] + [k (key-ref node ki)]) + (cond + [(key=? node key k) + (let ([km (bnode-keymap node)] + [cm (bnode-childmap node)]) + (if (and (fx= (popcount km) 2) + (fxzero? cm)) + (bnode-singleton node ki bit keyhash shift) + (bnode-remove-key node ki bit)))] + [else + node]))] + + [(bnode-maps-child? node bit) + (let* ([ci (bnode-child-index node bit)] + [child (child-ref node ci)] + [new-child (node-remove child key keyhash (down shift))]) + (cond + [(eq? new-child child) node] + [(node-singleton? new-child) + (if (and (fxzero? (bnode-childmap node)) + (fx= (popcount (bnode-keymap node)) 1)) + new-child + (bnode-remove-child node new-child ci bit))] + [else + (bnode-replace-child node child new-child ci)]))] + + [else + node]))) + +(define (bnode=? a b eql? shift) + (and + (bnode? b) + (fx= (bnode-keymap a) (bnode-keymap b)) + (fx= (bnode-childmap a) (bnode-childmap b)) + + (let* ([keys (hnode-keys a)] + [len (#%vector-length keys)] + [key-count (popcount (bnode-keymap a))]) + (let loop ([i 0]) + (cond + [(fx= i len) #t] + [else + (let ([ak (key-ref a i)] + [bk (key-ref b i)]) + (and + (cond + [(fx>= i key-count) + (node=? ak bk eql? (down shift))] + [else + (and (key=? a ak bk) + (eql? (val-ref a i) (val-ref b i)))]) + (loop (fx1+ i))))]))))) + +(define (bnode-keys-subset? a b shift) + (cond + [(bnode? b) + (let* ([akm (bnode-keymap a)] + [bkm (bnode-keymap b)] + [acm (bnode-childmap a)] + [bcm (bnode-childmap b)] + [abm (fxior akm acm)] + [bbm (fxior bkm bcm)]) + (and + (fx= abm (fxand abm bbm)) + + (let loop ([abm abm] [bit 0] [aki 0] [bki 0] [aci 0] [bci 0]) + (cond + [(fxzero? abm) #t] + [(fxbit-set? akm bit) + (cond + [(fxbit-set? bkm bit) + (and + (key=? a (key-ref a aki) (key-ref b bki)) + (loop (fxsrl abm 1) (fx1+ bit) (fx1+ aki) (fx1+ bki) aci bci))] + [else + (and + (let ([akey (key-ref a aki)] + [bchild (child-ref b bci)]) + (node-has-key? bchild akey (hash-code a akey) (down shift))) + (loop (fxsrl abm 1) (fx1+ bit) (fx1+ aki) bki aci (fx1+ bci)))])] + [(fxbit-set? acm bit) + (cond + [(fxbit-set? bkm bit) #f] + [else + (and + (node-keys-subset? (child-ref a aci) (child-ref b bci) (down shift)) + (loop (fxsrl abm 1) (fx1+ bit) aki bki (fx1+ aci) (fx1+ bci)))])] + [(fxbit-set? bkm bit) + (loop (fxsrl abm 1) (fx1+ bit) aki (fx1+ bki) aci bci)] + [(fxbit-set? bcm bit) + (loop (fxsrl abm 1) (fx1+ bit) aki bki aci (fx1+ bci))] + [else + (loop (fxsrl abm 1) (fx1+ bit) aki bki aci bci)]))))] + + [else + (let* ([akeys (hnode-keys a)] + [len (#%vector-length akeys)]) + (and (fx= len 1) + (let ([x (#%vector-ref akeys 0)]) + (if (fx= 0 (bnode-keymap a)) + (node-keys-subset? x b (down shift)) + (not (not (cnode-index b x)))))))])) + +(define (bnode-bit-pos hash shift) + (fxsll 1 (bnode-mask hash shift))) + +(define (bnode-mask hash shift) + (fxand (fxsrl hash shift) BNODE-MASK)) + +(define (bnode-maps-key? node bit) + (bnode-maps-bit? (bnode-keymap node) bit)) + +(define (bnode-maps-child? node bit) + (bnode-maps-bit? (bnode-childmap node) bit)) + +(define (bnode-maps-bit? bitmap bit) + (not (fxzero? (fxand bitmap bit)))) + +(define (bnode-index bitmap bit) + (popcount (fxand bitmap (fx1- bit)))) + +(define (bnode-key-index node bit) + (bnode-index (bnode-keymap node) bit)) + +(define (bnode-child-index node bit) + (bnode-index (bnode-childmap node) bit)) + +(define (child-ref n i) + (let ([keys (hnode-keys n)]) + (#%vector-ref keys (fx- (#%vector-length keys) 1 i)))) + +(define (down shift) + (fx+ shift BNODE-BITS)) + +(define (bnode-add-key node key val bit) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [ki (bnode-key-index node bit)] + [new-keys (vector-insert keys ki key)] + [new-vals + (cond + [vals (vector-insert vals ki val)] + [(eq? val #t) #f] + [else ; reify values + (pariah + (let* ([pop (popcount (bnode-keymap node))] + [v (make-vector (fx1+ pop) #t)]) + (#%vector-set! v ki val) + v))])]) + + (make-bnode (hnode-eqtype node) + (fx1+ (hnode-count node)) + new-keys + new-vals + (fxior (bnode-keymap node) bit) + (bnode-childmap node)))) + +(define (bnode-remove-key node ki bit) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [new-keys (vector-remove keys ki)] + [new-vals (and vals (vector-remove vals ki))]) + + (make-bnode (hnode-eqtype node) + (fx1- (hnode-count node)) + new-keys + new-vals + (fxxor (bnode-keymap node) bit) + (bnode-childmap node)))) + +(define (bnode-replace-val node ki val) + (let* ([vals (hnode-vals node)] + [new-vals + (if vals + (#%vector-copy vals) + (pariah ; reify values + (let ([pop (popcount (bnode-keymap node))]) + (make-vector pop #t))))]) + + (#%vector-set! new-vals ki val) + + (make-bnode (hnode-eqtype node) + (hnode-count node) + (hnode-keys node) + new-vals + (bnode-keymap node) + (bnode-childmap node)))) + +(define (bnode-add-child node child ki bit) + ;; We're removing a key from, and adding a child to, node. + ;; So length stays the same. + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [new-keys (make-vector len)] + [ci (fx- len 1 (bnode-child-index node bit))]) + + (vector*-copy! new-keys 0 keys 0 ki) + (vector*-copy! new-keys ki keys (fx1+ ki) (fx1+ ci)) + (#%vector-set! new-keys ci child) + (vector*-copy! new-keys (fx1+ ci) keys (fx1+ ci) len) + + (make-bnode (hnode-eqtype node) + (fx1+ (hnode-count node)) + new-keys + (and vals (vector-remove vals ki)) + (fxxor (bnode-keymap node) bit) + (fxior (bnode-childmap node) bit)))) + +;; `child` is a singleton. +;; `lci` is the logical child index; the physical index is computed below. +(define (bnode-remove-child node child lci bit) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [ci (fx- len 1 lci)] + [ki (bnode-key-index node bit)] + [k (key-ref child 0)] + [v (val-ref child 0)] + + [new-keys + (let ([cpy (make-vector len)]) + (vector*-copy! cpy 0 keys 0 ki) + (#%vector-set! cpy ki k) + (vector*-copy! cpy (fx1+ ki) keys ki ci) + (vector*-copy! cpy (fx1+ ci) keys (fx1+ ci) len) + cpy)] + + [new-vals + (cond + [vals (vector-insert vals ki v)] + [(eq? v #t) #f] + [else ; reify values + (pariah + (let* ([pop (popcount (bnode-keymap node))] + [cpy (make-vector (fx1+ pop) #t)]) + (#%vector-set! cpy ki v) + cpy))])]) + + (make-bnode (hnode-eqtype node) + (fx1- (hnode-count node)) + new-keys + new-vals + (fxior (bnode-keymap node) bit) + (fxxor (bnode-childmap node) bit)))) + +(define (bnode-replace-child node old-child new-child ci) + (let* ([keys (hnode-keys node)] + [len (#%vector-length keys)] + [new-keys (vector-copy keys)]) + (#%vector-set! new-keys (fx- len 1 ci) new-child) + + (make-bnode (hnode-eqtype node) + (fx+ (hnode-count node) + (fx- (hnode-count new-child) + (hnode-count old-child))) + new-keys + (hnode-vals node) + (bnode-keymap node) + (bnode-childmap node)))) + +(define (bnode-singleton node ki bit keyhash shift) + (let* ([km (bnode-keymap node)] + [new-km + ;; I'll admit: I do not understand the false arm of this + ;; conditional. Shouldn't the new keymap use the hash of + ;; the key that will remain, rather than the one that's + ;; being removed? + (if (fxzero? shift) + (fxxor km bit) + (bnode-bit-pos keyhash 0))] + [idx (if (fxzero? ki) 1 0)] + [val (val-ref node idx)]) + + (make-bnode (hnode-eqtype node) + 1 + (vector (key-ref node idx)) + (if (eq? val #t) #f (vector val)) + new-km + 0))) + +(define (node-merge eqtype k1 v1 h1 k2 v2 h2 shift) + (cond + [(and (fx< HASHCODE-BITS shift) + (fx= h1 h2)) + (pariah + ;; hash collision: make a cnode + (let ([vals + (if (and (eq? v1 #t) (eq? v2 #t)) + #f + (vector v1 v2))]) + (make-cnode eqtype 2 (vector k1 k2) vals h1)))] + + [else + (let ([m1 (bnode-mask h1 shift)] + [m2 (bnode-mask h2 shift)]) + (cond + [(fx= m1 m2) + ;; partial collision: descend + (let* ([child (node-merge eqtype k1 v1 h1 k2 v2 h2 (down shift))] + [count (hnode-count child)] + [cm (bnode-bit-pos h1 shift)]) + (make-bnode eqtype count (vector child) #f 0 cm))] + + [else + ;; no collision + (let ([km (fxior (bnode-bit-pos h1 shift) + (bnode-bit-pos h2 shift))]) + (if (and (eq? v1 #t) (eq? v2 #t)) + (if (fx< m1 m2) + (make-bnode eqtype 2 (vector k1 k2) #f km 0) + (make-bnode eqtype 2 (vector k2 k1) #f km 0)) + (if (fx< m1 m2) + (make-bnode eqtype 2 (vector k1 k2) (vector v1 v2) km 0) + (make-bnode eqtype 2 (vector k2 k1) (vector v2 v1) km 0))))]))])) + +(define (bnode-entry-at-position n pos) + (let ([kpop (popcount (bnode-keymap n))]) + (cond + [(fx< pos kpop) + (cons (key-ref n pos) (val-ref n pos))] + [else + (let ([cpop (popcount (bnode-childmap n))]) + (let loop ([i 0] [pos (fx- pos kpop)]) + (cond + [(fx= i cpop) #f] + [else + (let* ([child (child-ref n i)] + [count (hnode-count child)]) + (if (fx< pos count) + (node-entry-at-position child pos) + (loop (fx1+ i) (fx- pos count))))])))]))) + +(define (bnode-foldk n f nil kont) + (let ([kpop (popcount (bnode-keymap n))]) + (keys-foldk kpop n f nil + (lambda (nil) (child-foldk kpop n f nil kont))))) + +(define (keys-foldk pop n f nil kont) + (let loop ([i 0] [nil nil] [kont kont]) + (cond + [(fx= i pop) (kont nil)] + [else + (f (key-ref n i) (val-ref n i) nil + (lambda (nil) (loop (fx1+ i) nil kont)))]))) + +(define (child-foldk pop n f nil kont) + (let* ([keys (hnode-keys n)] + [len (#%vector-length keys)]) + (let loop ([i pop] [nil nil] [kont kont]) + (cond + [(fx= i len) (kont nil)] + [else + (node-foldk (#%vector-ref keys i) f nil + (lambda (nil) (loop (fx1+ i) nil kont)))])))) + +;; cnode operations +(define (cnode-index node key) + (let* ([keys (hnode-keys node)] + [len (#%vector-length keys)]) + (let loop ([i 0]) + (cond [(fx= i len) #f] + [(key=? node key (#%vector-ref keys i)) i] + [else (loop (fx1+ i))])))) + +(define (cnode-ref node key) + (let ([i (cnode-index node key)]) + (if i + (val-ref node i) + NOTHING))) + +(define (cnode-has-key? n key) + (not (not (cnode-index n key)))) + +(define (cnode-set node key val) + (let* ([i (cnode-index node key)] + [keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)]) + (if i + (cnode-replace-val node i val) + (cnode-add-key node key val)))) + +(define (cnode-remove node key keyhash) + (let ([ki (cnode-index node key)] + [eqtype (hnode-eqtype node)]) + (cond + [ki + (case (hnode-count node) + [(1) + (make-empty-bnode eqtype)] + [(2) + (let ([empty (make-empty-bnode eqtype)] + [i (if (fx= ki 0) 1 0)]) + (bnode-set empty (key-ref node i) (val-ref node i) keyhash 0))] + [else + (make-cnode eqtype + (fx1- (hnode-count node)) + (vector-remove (hnode-keys node) ki) + (let ([vals (hnode-vals node)]) + (and vals (vector-remove vals ki))) + (cnode-hash node))])] + [else + node]))) + +(define (cnode=? a b eql?) + (and + (cnode? b) + (fx= (cnode-hash a) (cnode-hash b)) + (let* ([akeys (hnode-keys a)] + [alen (#%vector-length akeys)]) + (and (let loop ([i 0]) + (cond + [(fx= i alen) #t] + [else + (let* ([akey (key-ref a i)] + [bval (cnode-ref b akey)]) + (and + (eql? (val-ref a i) bval) + (loop (fx1+ i))))])))))) + +(define (cnode-keys-subset? a b shift) + (cond + [(cnode? b) + (and (fx= (cnode-hash a) (cnode-hash b)) + (let loop ([i (hnode-count a)]) + (cond + [(fxzero? i) #t] + [else + (and (cnode-index b (key-ref a (fx1- i))) + (loop (fx1- i)))])))] + [else + (let loop ([i (hnode-count a)]) + (cond + [(fxzero? i) #t] + [else + (let ([k (key-ref a (fx1- i))]) + (and (bnode-has-key? b k (hash-code a k) shift) + (loop (fx1- i))))]))])) + +(define (cnode-replace-val node i val) + (let ([v (val-ref node i)]) + (cond + [(eq? v val) + node] + + [else + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [new-vals + (if vals + (#%vector-copy vals) + (make-vector len #t))]) + (#%vector-set! new-vals i val) + + (make-cnode (hnode-eqtype node) + (hnode-count node) + keys + new-vals + (cnode-hash node)))]))) + +(define (cnode-add-key node key val) + (let* ([keys (hnode-keys node)] + [vals (hnode-vals node)] + [len (#%vector-length keys)] + [new-vals + (cond + [vals (vector-insert vals len val)] + [(eq? val #t) #f] + [else + (let ([vec (make-vector (fx1+ len) #t)]) + (#%vector-set! vec len val) + vec)])]) + + (make-cnode (hnode-eqtype node) + (fx1+ (hnode-count node)) + (vector-insert keys len key) + new-vals + (cnode-hash node)))) + +(define (cnode-entry-at-position n pos) + (and (fx< pos (hnode-count n)) + (cons (key-ref n pos) (val-ref n pos)))) + +(define (cnode-foldk n f nil kont) + (keys-foldk (hnode-count n) n f nil kont)) diff --git a/racket/src/cs/rumble/hash-code.ss b/racket/src/cs/rumble/hash-code.ss new file mode 100644 index 0000000000..16ea2ed094 --- /dev/null +++ b/racket/src/cs/rumble/hash-code.ss @@ -0,0 +1,150 @@ +;;; Parts from "newhash.ss" in Chez Scheme's implementation + +;;; newhash.ss +;;; Copyright 1984-2016 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define codes (make-weak-eq-hashtable)) +(define counter 12345) + +(define (eq-hash-code x) + (cond + [(and (symbol? x) + ;; Avoid forcing the universal name of a gensym, + ;; which is more expensive than registering in + ;; the `codes` table. + (not (gensym? x))) + (symbol-hash x)] + [(number? x) (number-hash x)] + [(char? x) (char->integer x)] + [else + (or (eq-hashtable-ref codes x #f) + (let ([c (fx1+ counter)]) + (set! counter c) + (eq-hashtable-set! codes x counter) + c))])) + +;; Mostly copied from Chez Scheme's "newhash.ss": +(define number-hash + (lambda (z) + (cond + [(fixnum? z) (if (fx< z 0) (fxnot z) z)] + [(flonum? z) (#3%$flhash z)] + [(bignum? z) (modulo z (most-positive-fixnum))] + [(ratnum? z) (number-hash (+ (* (numerator z) 5) (denominator z)))] + [else (logand (logxor (lognot (number-hash (real-part z))) (number-hash (imag-part z))) + (most-positive-fixnum))]))) + +(define (eqv-hash-code x) + (cond + [(number? x) (number-hash x)] + [(char? x) (char->integer x)] + [else (eq-hash-code x)])) + +;; We don't use `equal-hash` because we need impersonators to be able +;; to generate the same hash code as the unwrapped value. +(define (equal-hash-code x) + (call-with-values (lambda () (equal-hash-loop x 0 0)) + (lambda (hc burn) (logand hc (most-positive-fixnum))))) + +(define (equal-secondary-hash-code x) + (cond + [(boolean? x) 1] + [(null? x) 2] + [(number? x) 3] + [(char? x) 4] + [(symbol? x) 5] + [(string? x) 6] + [(bytevector? x) 7] + [(box? x) 8] + [(pair? x) 9] + [(vector? x) (vector-length x)] + [(#%$record? x) (eq-hash-code (record-rtd x))] + [(impersonator? x) (equal-secondary-hash-code (impersonator-val x))] + [else 100])) + +(define MAX-HASH-BURN 128) + +(define (equal-hash-loop x burn hc) + (let* ([+/fx + (lambda (hc k) + (#3%fx+ hc k))] + [sll/fs + (lambda (hc i) + (#3%fxsll hc i))] + [->fx + (lambda (v) + (if (fixnum? v) + v + (modulo v (greatest-fixnum))))] + [mix1 + (lambda (hc) + (+/fx hc (sll/fs hc 3)))] + [mix2 + (lambda (hc) + (+/fx hc (sll/fs hc 5)))]) + (cond + [(fx> burn MAX-HASH-BURN) (values hc burn)] + [(boolean? x) (values (+/fx hc (if x #x0ace0120 #x0cafe121)) burn)] + [(null? x) (values (+/fx hc #x0cabd122) burn)] + [(number? x) (values (+/fx hc (number-hash x)) burn)] + [(char? x) (values (+/fx hc (char->integer x)) burn)] + [(symbol? x) (values (+/fx hc (symbol-hash x)) burn)] + [(string? x) (values (+/fx hc (string-hash x)) burn)] + [(bytevector? x) (values (+/fx hc (equal-hash x)) burn)] + [(box? x) (equal-hash-loop (unbox x) (fx+ burn 1) (+/fx hc 1))] + [(pair? x) + (let-values ([(hc0 burn) (equal-hash-loop (car x) (fx+ burn 2) 0)]) + (let ([hc (+/fx (mix1 hc) hc0)] + [r (cdr x)]) + (if (and (pair? r) (list? r)) + ;; If it continues as a list, don't count cdr direction as burn: + (equal-hash-loop r (fx- burn 2) hc) + (equal-hash-loop r burn hc))))] + [(vector? x) + (let ([len (vector-length x)]) + (cond + [(fx= len 0) (values (+/fx hc 1) burn)] + [else + (let vec-loop ([i 0] [burn burn] [hc hc]) + (cond + [(fx= i len) (values hc burn)] + [else + (let-values ([(hc0 burn) (equal-hash-loop (vector-ref x i) burn 0)]) + (vec-loop (fx+ i 1) + burn + (+/fx (mix2 hc) hc0)))]))]))] + [(and (#%$record? x) (#%$record-hash-procedure x)) + => (lambda (rec-hash) + (let ([burn (fx+ burn 2)]) + (let ([hc (+/fx hc (->fx (rec-hash x (lambda (x) + (let-values ([(hc0 burn0) (equal-hash-loop x burn 0)]) + (set! burn burn0) + hc0)))))]) + (values hc burn))))] + [(impersonator? x) + ;; If an impersonator wraps a value where `equal?` hashing is + ;; `eq?` hashing, such as for a procedure, then make sure + ;; we discard the impersonator wrapper. + (equal-hash-loop (impersonator-val x) burn hc)] + [else (values (+/fx hc (eq-hash-code x)) burn)]))) + +(define (hash-code-combine hc v) + (bitwise-and (+ (bitwise-arithmetic-shift-left hc 2) + v) + (greatest-fixnum))) + +(define (hash-code-combine-unordered hc v) + (bitwise-and (+ hc v) + (greatest-fixnum))) diff --git a/racket/src/cs/rumble/hash.ss b/racket/src/cs/rumble/hash.ss new file mode 100644 index 0000000000..e04bba4e97 --- /dev/null +++ b/racket/src/cs/rumble/hash.ss @@ -0,0 +1,1207 @@ +;; To support iteration and locking, we wrap Chez's mutable hash +;; tables in a `mutable-hash` record: +(define-record mutable-hash (ht ; Chez Scheme hashtable + keys ; vector of keys for iteration + keys-removed ; 'check or a weak, `eqv?`-based mapping of `keys` values + lock)) +(define (create-mutable-hash ht kind) (make-mutable-hash ht #f #f (make-lock kind))) + +(define (authentic-hash? v) (or (intmap? v) (mutable-hash? v) (weak-equal-hash? v))) +(define (hash? v) (or (authentic-hash? v) + (and (impersonator? v) + (authentic-hash? (impersonator-val v))))) + +(define make-hash + (case-lambda + [() (create-mutable-hash (make-hashtable key-equal-hash-code key-equal?) 'equal?)] + [(alist) (fill-hash! 'make-hash (make-hash) alist)])) + +(define make-hasheq + (case-lambda + [() (create-mutable-hash (make-eq-hashtable) 'eq?)] + [(alist) (fill-hash! 'make-hasheq (make-hasheq) alist)])) + +(define make-weak-hasheq + (case-lambda + [() (create-mutable-hash (make-weak-eq-hashtable) 'eq?)] + [(alist) (fill-hash! 'make-weak-hasheq (make-weak-hasheq) alist)])) + +(define make-hasheqv + (case-lambda + [() (create-mutable-hash (make-eqv-hashtable) 'eqv?)] + [(alist) (fill-hash! 'make-hasheqv (make-hasheqv) alist)])) + +(define make-weak-hasheqv + (case-lambda + [() (create-mutable-hash (make-weak-eqv-hashtable) 'eqv?)] + [(alist) (fill-hash! 'make-weak-hasheqv (make-weak-hasheqv) alist)])) + +(define/who (fill-hash! who ht alist) + (check who :test (and (list? alist) (andmap pair? alist)) :contract "(listof pair?)" alist) + (for-each (lambda (p) + (hash-set! ht (car p) (cdr p))) + alist) + ht) + +(define-syntax define-hash-constructors + (syntax-rules () + [(_ vararg-ctor list-ctor empty-hash) + (begin + (define (vararg-ctor . kvs) + (let loop ([kvs kvs] [h empty-hash]) + (cond [(null? kvs) h] + [else + (loop (cddr kvs) (intmap-set h (car kvs) (cadr kvs)))]))) + + (define list-ctor + (case-lambda + [() (vararg-ctor)] + [(alist) + (check 'list-ctor + :test (and (list? alist) (andmap pair? alist)) + :contract "(listof pair?)" + alist) + (let loop ([h (vararg-ctor)] [alist alist]) + (if (null? alist) + h + (loop (intmap-set h (caar alist) (cdar alist)) + (cdr alist))))])))])) + +(define-hash-constructors hash make-immutable-hash empty-hash) +(define-hash-constructors hasheqv make-immutable-hasheqv empty-hasheqv) +(define-hash-constructors hasheq make-immutable-hasheq empty-hasheq) + +(define (hash-set! ht k v) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (when (and (mutable-hash-keys ht) + (not (hashtable-contains? (mutable-hash-ht ht) k))) + (set-mutable-hash-keys! ht #f) + (set-mutable-hash-keys-removed! ht #f)) + (hashtable-set! (mutable-hash-ht ht) k v) + (lock-release (mutable-hash-lock ht))] + [(weak-equal-hash? ht) (weak-hash-set! ht k v)] + [(and (impersonator? ht) + (let ([ht (impersonator-val ht)]) + (or (mutable-hash? ht) + (weak-equal-hash? ht)))) + (impersonate-hash-set! ht k v)] + [else (raise-argument-error 'hash-set! "(and/c hash? (not/c immutable?))" ht)])) + +(define (hash-remove! ht k) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (when (mutable-hash-keys ht) + (cond + [(hash-equal? ht) + ;; Track which keys in the vector are no longer mapped + (unless (mutable-hash-keys-removed ht) + ;; We use an `eqv?` table to work with flonums + (set-mutable-hash-keys-removed! ht (make-weak-eqv-hashtable))) + ;; Get specific key that is currently mapped for `k` + ;; by getting the entry pair: + (let ([e (hashtable-cell (mutable-hash-ht ht) k #f)]) + (hashtable-set! (mutable-hash-keys-removed ht) (car e) #t))] + [else + ; Record that we need to check the table: + (set-mutable-hash-keys-removed! ht 'check)])) + (hashtable-delete! (mutable-hash-ht ht) k) + (lock-release (mutable-hash-lock ht))] + [(weak-equal-hash? ht) (weak-hash-remove! ht k)] + [(and (impersonator? ht) + (let ([ht (impersonator-val ht)]) + (or (mutable-hash? ht) + (weak-equal-hash? ht)))) + (impersonate-hash-remove! ht k)] + [else (raise-argument-error 'hash-remove! "(and/c hash? (not/c immutable?))" ht)])) + +(define (hash-clear! ht) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (set-mutable-hash-keys! ht #f) + (set-mutable-hash-keys-removed! ht #f) + (hashtable-clear! (mutable-hash-ht ht)) + (lock-release (mutable-hash-lock ht))] + [(weak-equal-hash? ht) (weak-hash-clear! ht)] + [(and (impersonator? ht) + (let ([ht (impersonator-val ht)]) + (or (mutable-hash? ht) + (weak-equal-hash? ht)))) + (impersonate-hash-clear! ht)] + [else (raise-argument-error 'hash-clear! "(and/c hash? (not/c immutable?))" ht)])) + +(define (hash-copy ht) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (let ([new-ht (create-mutable-hash (hashtable-copy (mutable-hash-ht ht) #t) + (cond + [(hash-eq? ht) 'eq?] + [(hash-eqv? ht) 'eqv?] + [else 'equal?]))]) + (lock-release (mutable-hash-lock ht)) + new-ht)] + [(weak-equal-hash? ht) (weak-hash-copy ht)] + [(intmap? ht) + (let ([new-ht (cond + [(intmap-eq? ht) (make-hasheq)] + [(intmap-eqv? ht) (make-hasheqv)] + [else (make-hash)])]) + (let loop ([i (intmap-iterate-first ht)]) + (when i + (let-values ([(k v) (intmap-iterate-key+value ht i #f)]) + (hash-set! new-ht k v) + (loop (intmap-iterate-next ht i))))) + new-ht)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (impersonate-hash-copy ht)] + [else (raise-argument-error 'hash-copy "hash?" ht)])) + +(define (hash-set ht k v) + (cond + [(intmap? ht) (intmap-set ht k v)] + [(and (impersonator? ht) + (intmap? (impersonator-val ht))) + (impersonate-hash-set ht k v)] + [else (raise-argument-error 'hash-set! "(and/c hash? immutable?)" ht)])) + +(define (hash-remove ht k) + (cond + [(intmap? ht) (intmap-remove ht k)] + [(and (impersonator? ht) + (intmap? (impersonator-val ht))) + (impersonate-hash-remove ht k)] + [else (raise-argument-error 'hash-remove "(and/c hash? immutable?)" ht)])) + +(define (hash-clear ht) + (cond + [(intmap? ht) + (cond + [(hash-eq? ht) empty-hasheq] + [(hash-eqv? ht) empty-hasheqv] + [else empty-hash])] + [(and (impersonator? ht) + (intmap? (impersonator-val ht))) + (let loop ([ht ht]) + (let ([i (hash-iterate-first ht)]) + (if i + (loop (hash-remove ht (hash-iterate-key ht i))) + ht)))] + [else (raise-argument-error 'hash-clear! "(and/c hash? immutable?)" ht)])) + +(define (hash-eq? ht) + (cond + [(mutable-hash? ht) + (eq? (hashtable-equivalence-function (mutable-hash-ht ht)) eq?)] + [(intmap? ht) + (intmap-eq? ht)] + [(weak-equal-hash? ht) #f] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-eq? (impersonator-val ht))] + [else (raise-argument-error 'hash-eq? "hash?" ht)])) + +(define (hash-eqv? ht) + (cond + [(mutable-hash? ht) + (eq? (hashtable-equivalence-function (mutable-hash-ht ht)) eqv?)] + [(intmap? ht) + (intmap-eqv? ht)] + [(weak-equal-hash? ht) #f] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-eqv? (impersonator-val ht))] + [else (raise-argument-error 'hash-eqv? "hash?" ht)])) + +(define (hash-equal? ht) + (cond + [(mutable-hash? ht) + (eq? (hashtable-equivalence-function (mutable-hash-ht ht)) key-equal?)] + [(intmap? ht) + (intmap-equal? ht)] + [(weak-equal-hash? ht) #t] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-equal? (impersonator-val ht))] + [else (raise-argument-error 'hash-equal? "hash?" ht)])) + +(define (hash-weak? ht) + (cond + [(mutable-hash? ht) + (hashtable-weak? (mutable-hash-ht ht))] + [(intmap? ht) #f] + [(weak-equal-hash? ht) #t] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-weak? (impersonator-val ht))] + [else (raise-argument-error 'hash-weak? "hash?" ht)])) + +(define hash-ref + (case-lambda + [(ht k) + (let ([v (hash-ref ht k none)]) + (if (eq? v none) + (raise-arguments-error + 'hash-ref + "no value found for key" + "key" k) + v))] + [(ht k fail) + (cond + [(mutable-hash? ht) + (lock-acquire (mutable-hash-lock ht)) + (let ([v (hashtable-ref (mutable-hash-ht ht) k none)]) + (lock-release (mutable-hash-lock ht)) + (if (eq? v none) + (if (procedure? fail) + (|#%app| fail) + fail) + v))] + [(intmap? ht) (intmap-ref ht k fail)] + [(weak-equal-hash? ht) (weak-hash-ref ht k fail)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (let ([v (impersonate-hash-ref ht k)]) + (if (eq? v none) + (if (procedure? fail) + (|#%app| fail) + fail) + v))] + [else (raise-argument-error 'hash-ref "hash?" ht)])])) + +(define/who hash-for-each + (case-lambda + [(ht proc) (hash-for-each ht proc #f)] + [(ht proc try-order?) + (check who hash? ht) + (check who (procedure-arity-includes/c 2) proc) + (cond + [(mutable-hash? ht) + (let loop ([i (hash-iterate-first ht)]) + (when i + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (|#%app| proc key val)) + (loop (hash-iterate-next ht i))))] + [(intmap? ht) (intmap-for-each ht proc)] + [(weak-equal-hash? ht) (weak-hash-for-each ht proc)] + [else + ;; impersonated + (let loop ([i (hash-iterate-first ht)]) + (when i + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (|#%app| proc key val) + (loop (hash-iterate-next ht i)))))])])) + +(define/who hash-map + (case-lambda + [(ht proc) + (check who hash? ht) + (check who (procedure-arity-includes/c 2) proc) + (cond + [(mutable-hash? ht) + (let loop ([i (hash-iterate-first ht)]) + (if (not i) + '() + (cons + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (|#%app| proc key val)) + (loop (hash-iterate-next ht i)))))] + [(intmap? ht) (intmap-map ht proc)] + [(weak-equal-hash? ht) (weak-hash-map ht proc)] + [else + ;; impersonated + (let loop ([i (hash-iterate-first ht)]) + (cond + [(not i) '()] + [else + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (cons (|#%app| proc key val) + (loop (hash-iterate-next ht i))))]))])] + [(ht proc try-order?) + (hash-map ht proc)])) + +(define (hash-count ht) + (cond + [(mutable-hash? ht) (hashtable-size (mutable-hash-ht ht))] + [(intmap? ht) (intmap-count ht)] + [(weak-equal-hash? ht) (weak-hash-count ht)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (hash-count (impersonator-val ht))] + [else (raise-argument-error 'hash-count "hash?" ht)])) + +(define (hash-keys-subset? ht1 ht2) + (cond + [(and (intmap? ht1) + (intmap? ht2) + (or (and (intmap-eq? ht1) + (intmap-eq? ht2)) + (and (intmap-eqv? ht1) + (intmap-eqv? ht2)) + (and (intmap-equal? ht1) + (intmap-equal? ht2)))) + (intmap-keys-subset? ht1 ht2)] + [(and (hash? ht1) + (hash? ht2) + (or (and (hash-eq? ht1) + (hash-eq? ht2)) + (and (hash-eqv? ht1) + (hash-eqv? ht2)) + (and (hash-equal? ht1) + (hash-equal? ht2)))) + (and (<= (hash-count ht1) (hash-count ht2)) + (let ([ok? #t]) + (hash-for-each + ht1 + (lambda (k v) + (when ok? + (set! ok? (not (eq? none (hash-ref ht2 k none))))))) + ok?))] + [(not (hash? ht1)) + (raise-argument-error 'hash-keys-subset? "hash?" ht1)] + [(not (hash? ht2)) + (raise-argument-error 'hash-keys-subset? "hash?" ht2)] + [else + (raise-arguments-error 'hash-keys-subset? + "given hash tables do not use the same key comparison" + "first table" ht1 + "first table" ht2)])) + +;; Use `eql?` for recursive comparisons +(define (hash=? ht1 ht2 eql?) + (cond + [(and (intmap? ht1) + (intmap? ht2)) + (intmap=? ht1 ht2 eql?)] + [(and (hash? ht1) + (hash? ht2) + (or (and (hash-eq? ht1) + (hash-eq? ht2)) + (and (hash-eqv? ht1) + (hash-eqv? ht2)) + (and (hash-equal? ht1) + (hash-equal? ht2))) + (eq? (hash-weak? ht1) (hash-weak? ht2))) + (and (= (hash-count ht1) (hash-count ht2)) + ;; This generic comparison supports impersonators + (let loop ([i (hash-iterate-first ht1)]) + (cond + [(not i) #t] + [else + (let-values ([(key val) (hash-iterate-key+value ht1 i)]) + (let ([val2 (hash-ref ht2 key none)]) + (cond + [(eq? val2 none) #f] + [else (and (eql? val val2) + (loop (hash-iterate-next ht1 i)))])))])))] + [else #f])) + + +;; Use `hash` for recursive hashing +(define (hash-hash-code ht hash) + (cond + [(intmap? ht) (intmap-hash-code ht hash)] + [else + ;; This generic hashing supports impersonators + (let loop ([hc 0] [i (hash-iterate-first ht)]) + (cond + [(not i) hc] + [else + (let* ([eq-key? (hash-eq? ht)] + [eqv-key? (and (not eq?) (hash-eqv? ht))]) + (let-values ([(key val) (hash-iterate-key+value ht i)]) + (let ([hc (hash-code-combine-unordered hc + (cond + [eq-key? (eq-hash-code key)] + [eqv-key? (eqv-hash-code key)] + [else (hash key)]))]) + (loop (hash-code-combine-unordered hc (hash val)) + (hash-iterate-next ht i)))))]))])) + + +;; A `hash-iterate-first` operation triggers an O(n) +;; gathering of the keys of a mutable hash table. That's +;; unfortunate, but there appears to be no way around it. +(define (prepare-iterate! ht i) + (lock-acquire (mutable-hash-lock ht)) + (let ([vec (mutable-hash-keys ht)]) + (cond + [vec + (lock-release (mutable-hash-lock ht)) + vec] + [else + (let ([vec (hashtable-keys (mutable-hash-ht ht))]) + ;; Keep a weak reference to each key, in case + ;; it's removed or we have a weak hash table: + (let loop ([i (vector-length vec)]) + (unless (zero? i) + (let* ([i (sub1 i)] + [key (vector-ref vec i)]) + (vector-set! vec i (weak/fl-cons key #f)) + (loop i)))) + (set-mutable-hash-keys! ht vec) + (set-mutable-hash-keys-removed! ht #f) + (lock-release (mutable-hash-lock ht)) + vec)]))) + +(define/who (hash-iterate-first ht) + (cond + [(intmap? ht) + (intmap-iterate-first ht)] + [(mutable-hash? ht) + (mutable-hash-iterate-next ht #f)] + [(weak-equal-hash? ht) (weak-hash-iterate-first ht)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + ;; `hash-iterate-first` must not hash any keys: + (hash-iterate-first (impersonator-val ht))] + [else (raise-argument-error who "hash?" ht)])) + +(define (check-i who i) + (check who exact-nonnegative-integer? i)) + +(define/who (hash-iterate-next ht i) + (cond + [(intmap? ht) + (check-i 'hash-iterate-next i) + (intmap-iterate-next ht i)] + [(mutable-hash? ht) + (check-i 'hash-iterate-next i) + (mutable-hash-iterate-next ht i)] + [(weak-equal-hash? ht) + (check-i 'hash-iterate-next i) + (weak-hash-iterate-next ht i)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + ;; `hash-iterate-next` must not hash any keys: + (hash-iterate-next (impersonator-val ht) i)] + [else (raise-argument-error who "hash?" ht)])) + +(define (mutable-hash-iterate-next ht init-i) + (let* ([vec (prepare-iterate! ht init-i)] ; vec expected to have > `init-i` elements + [len (vector-length vec)]) + (let loop ([i (or init-i -1)]) + (let ([i (add1 i)]) + (cond + [(> i len) + (raise-arguments-error 'hash-iterate-next "no element at index" + "index" init-i + "within length" len + "vec" vec)] + [(= i len) + #f] + [else + (let* ([p (vector-ref vec i)] + [key (car p)]) + (cond + [(bwp-object? key) + ;; A hash table change or disappeared weak reference + (loop i)] + [(mutable-hash-keys-removed ht) + => (lambda (keys-removed) + (lock-acquire (mutable-hash-lock ht)) + (let ([removed? + (if (eq? keys-removed 'check) + (not (hashtable-contains? (mutable-hash-ht ht) key)) + (hashtable-contains? keys-removed key))]) + (lock-release (mutable-hash-lock ht)) + (if removed? + ;; Skip, due to a hash table change + (loop i) + ;; Key is still mapped: + i)))] + [else i]))]))))) + +(define (do-hash-iterate-key+value who ht i + intmap-iterate-key+value + weak-hash-iterate-key+value + key? value? pair?) + (cond + [(intmap? ht) + (check-i who i) + (call-with-values (lambda () (intmap-iterate-key+value ht i none)) + (case-lambda + [(v) (if (eq? v none) + (raise-arguments-error who "no element at index" + "index" i) + v)] + [(k v) (values k v)]))] + [(mutable-hash? ht) + (check-i who i) + (let* ([vec (prepare-iterate! ht i)] + [len (vector-length vec)] + [p (if (< i len) + (vector-ref vec i) + '(#f . #f))] + [key (car p)] + [v (if (bwp-object? key) + none + (cond + [(not value?) + ;; We need to check whether the key is still + ;; mapped by the hash table, but impersonator + ;; support relies on not `equal?`-hashing the + ;; candidate key at this point. The `keys-removed` + ;; weak `eq?`-based table serves that purpose. + (cond + [(mutable-hash-keys-removed ht) + => (lambda (keys-removed) + (lock-acquire (mutable-hash-lock ht)) + (let ([removed? + (if (eq? keys-removed 'check) + (not (hashtable-contains? (mutable-hash-ht ht) key)) + (hashtable-contains? keys-removed key))]) + (lock-release (mutable-hash-lock ht)) + (if removed? none #t)))] + [else #t])] + [else + (lock-acquire (mutable-hash-lock ht)) + (let ([v (hashtable-ref (mutable-hash-ht ht) key none)]) + (lock-release (mutable-hash-lock ht)) + v)]))]) + (if (eq? v none) + (raise-arguments-error who "no element at index" + "index" i) + (cond + [(and key? value?) + (if pair? + (cons key v) + (values key v))] + [key? key] + [else v])))] + [(weak-equal-hash? ht) + (check-i who i) + (weak-hash-iterate-key+value ht i)] + [(and (impersonator? ht) + (authentic-hash? (impersonator-val ht))) + (impersonate-hash-iterate-key+value who ht i key? value? pair?)] + [else (raise-argument-error who "hash?" ht)])) + +(define (hash-iterate-key ht i) + (do-hash-iterate-key+value 'hash-iterate-key ht i + intmap-iterate-key + weak-hash-iterate-key + #t #f #f)) + +(define (hash-iterate-value ht i) + (do-hash-iterate-key+value 'hash-iterate-value ht i + intmap-iterate-value + weak-hash-iterate-value + #f #t #f)) + +(define (hash-iterate-key+value ht i) + (do-hash-iterate-key+value 'hash-iterate-key+value ht i + intmap-iterate-key+value + weak-hash-iterate-key+value + #t #t #f)) + +(define (hash-iterate-pair ht i) + (do-hash-iterate-key+value 'hash-iterate-pair ht i + intmap-iterate-pair + weak-hash-iterate-pair + #t #t #t)) + +(define (unsafe-immutable-hash-iterate-first ht) + (if (impersonator? ht) + (hash-iterate-first ht) + (unsafe-intmap-iterate-first ht))) + +(define (iterator-for-impersonator? i) (fixnum? i)) + +(define (unsafe-immutable-hash-iterate-next ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-next ht i) + (unsafe-intmap-iterate-next ht i))) + +(define (unsafe-immutable-hash-iterate-key ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-key ht i) + (unsafe-intmap-iterate-key ht i))) + +(define (unsafe-immutable-hash-iterate-value ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-value ht i) + (unsafe-intmap-iterate-value ht i))) + +(define (unsafe-immutable-hash-iterate-key+value ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-key+value ht i) + (unsafe-intmap-iterate-key+value ht i))) + +(define (unsafe-immutable-hash-iterate-pair ht i) + (if (iterator-for-impersonator? i) + (hash-iterate-pair ht i) + (unsafe-intmap-iterate-pair ht i))) + +(define unsafe-mutable-hash-iterate-first hash-iterate-first) +(define unsafe-mutable-hash-iterate-next hash-iterate-next) +(define unsafe-mutable-hash-iterate-key hash-iterate-key) +(define unsafe-mutable-hash-iterate-value hash-iterate-value) +(define unsafe-mutable-hash-iterate-key+value hash-iterate-key+value) +(define unsafe-mutable-hash-iterate-pair hash-iterate-pair) + +(define unsafe-weak-hash-iterate-first hash-iterate-first) +(define unsafe-weak-hash-iterate-next hash-iterate-next) +(define unsafe-weak-hash-iterate-key hash-iterate-key) +(define unsafe-weak-hash-iterate-value hash-iterate-value) +(define unsafe-weak-hash-iterate-key+value hash-iterate-key+value) +(define unsafe-weak-hash-iterate-pair hash-iterate-pair) + +;; ---------------------------------------- + +;; Chez Scheme doesn't provide weak hash table with `equal?` comparisons, +;; so build our own + +(define-record weak-equal-hash (keys-ht ; integer[equal hash code] -> weak list of keys + vals-ht ; weak, eq?-based hash table: key -> value + count ; number of items in the table (= sum of list lengths) + prune-at ; count at which we should try to prune empty weak boxes + keys)) ; for iteration: a vector that is enlarged on demand + +(define make-weak-hash + (case-lambda + [() (make-weak-equal-hash (hasheqv) (make-weak-eq-hashtable) 0 128 #f)] + [(alist) (fill-hash! 'make-weak-hash (make-weak-hash) alist)])) + +(define (weak-hash-copy ht) + (make-weak-equal-hash (weak-equal-hash-keys-ht ht) + (hashtable-copy (weak-equal-hash-vals-ht ht) #t) + (weak-equal-hash-count ht) + (weak-equal-hash-prune-at ht) + #f)) + +(define (weak-hash-ref t key fail) + (let* ([code (key-equal-hash-code key)] + [keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]) + (let loop ([keys keys]) + (cond + [(null? keys) + ;; Not in the table: + (if (procedure? fail) + (|#%app| fail) + fail)] + [(key-equal? (car keys) key) + (let ([v (hashtable-ref (weak-equal-hash-vals-ht t) (car keys) none)]) + (if (eq? v none) + (if (procedure? fail) + (|#%app| fail) + fail) + v))] + [else (loop (cdr keys))])))) + +(define (weak-hash-ref-key ht key) + (let* ([code (key-equal-hash-code key)] + [keys (intmap-ref (weak-equal-hash-keys-ht ht) code '())]) + (let loop ([keys keys]) + (cond + [(null? keys) #f] + [(key-equal? (car keys) key) (car keys)] + [else (loop (cdr keys))])))) + +(define (weak-hash-set! t k v) + (let* ([code (key-equal-hash-code k)] + [keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]) + (let loop ([keys keys]) + (cond + [(null? keys) + ;; Not in the table: + (set-weak-equal-hash-keys! t #f) + (when (= (weak-equal-hash-count t) (weak-equal-hash-prune-at t)) + (prune-table! t)) + (let* ([ht (weak-equal-hash-keys-ht t)]) + (set-weak-equal-hash-count! t + (add1 (weak-equal-hash-count t))) + (set-weak-equal-hash-keys-ht! t + (intmap-set ht code + (weak/fl-cons k + (intmap-ref ht code '())))) + (hashtable-set! (weak-equal-hash-vals-ht t) k v))] + [(key-equal? (car keys) k) + (hashtable-set! (weak-equal-hash-vals-ht t) (car keys) v)] + [else (loop (cdr keys))])))) + +(define (weak-hash-remove! t k) + (let* ([code (key-equal-hash-code k)] + [keys (intmap-ref (weak-equal-hash-keys-ht t) code '())] + [keep-bwp? + ;; If we have a `keys` array, then preserve the shape of + ;; each key lst in `(weak-equal-hash-keys-ht t)` so that + ;; the `keys` array remains consistent with that shape + (and (weak-equal-hash-keys t) #t)] + [new-keys + (let loop ([keys keys]) + (cond + [(null? keys) + ;; Not in the table + #f] + [(key-equal? (car keys) k) + (hashtable-delete! (weak-equal-hash-vals-ht t) (car keys)) + (if keep-bwp? + (cons #!bwp keys) + (cdr keys))] + [else + (let ([new-keys (loop (cdr keys))]) + (and new-keys + (if (and (not keep-bwp?) + (bwp-object? (car keys))) + new-keys + (weak/fl-cons (car keys) new-keys))))]))]) + (when new-keys + (set-weak-equal-hash-keys-ht! t + (if (null? new-keys) + (intmap-remove (weak-equal-hash-keys-ht t) code) + (intmap-set (weak-equal-hash-keys-ht t) code new-keys)))))) + +(define (weak-hash-clear! t) + (set-weak-equal-hash-keys-ht! t (hasheqv)) + (hashtable-clear! (weak-equal-hash-vals-ht t)) + (set-weak-equal-hash-count! t 0) + (set-weak-equal-hash-prune-at! t 128) + (set-weak-equal-hash-keys! t #f)) + +(define (weak-hash-for-each t proc) + (let* ([ht (weak-equal-hash-vals-ht t)] + [keys (hashtable-keys ht)] + [len (#%vector-length keys)]) + (let loop ([i 0]) + (unless (fx= i len) + (let ([key (#%vector-ref keys i)]) + (|#%app| proc key (hashtable-ref ht key #f))) + (loop (fx1+ i)))))) + +(define (weak-hash-map t proc) + (let* ([ht (weak-equal-hash-vals-ht t)] + [keys (hashtable-keys ht)] + [len (#%vector-length keys)]) + (let loop ([i 0]) + (cond + [(fx= i len) '()] + [else + (let ([key (#%vector-ref keys i)]) + (cons (|#%app| proc key (hashtable-ref ht key #f)) + (loop (fx1+ i))))])))) + +(define (weak-hash-count t) + (hashtable-size (weak-equal-hash-vals-ht t))) + +(define (prepare-weak-iterate! ht i) + (let* ([current-vec (weak-equal-hash-keys ht)]) + (or (and current-vec + (> (vector-length current-vec) (or i 1)) + current-vec) + (let* ([len (max 16 + (* 2 (if current-vec + (vector-length current-vec) + 0)) + (if i (* 2 i) 0))] + [vec (make-vector len #f)] + [pos (box 0)]) + (call/cc + (lambda (esc) + (intmap-for-each + (weak-equal-hash-keys-ht ht) + (lambda (k l) + (let loop ([l l]) + (cond + [(null? l) (void)] + [else + ;; Add `l` even if the key is #!bwp, + ;; so that iteration works right if a key + ;; is removed + (vector-set! vec (unbox pos) l) + (set-box! pos (add1 (unbox pos))) + (if (= (unbox pos) len) + ;; That's enough keys + (esc (void)) + (loop (cdr l)))])))))) + (set-weak-equal-hash-keys! ht vec) + vec)))) + +(define (weak-hash-iterate-first ht) + (weak-hash-iterate-next ht #f)) + +(define (weak-hash-iterate-next ht init-i) + (let retry ([i (and init-i (add1 init-i))]) + (let* ([vec (prepare-weak-iterate! ht i)] + [len (vector-length vec)]) + (let loop ([i (or i 0)]) + (cond + [(= i len) + ;; expand set of prepared keys + (retry i)] + [(> i len) + (raise-arguments-error 'hash-iterate-next "no element at weak index" + "index" init-i)] + [else + (let ([p (vector-ref vec i)]) + (cond + [(not p) + ;; no more keys available + #f] + [(bwp-object? (car p)) (loop (add1 i))] + [(not (hashtable-contains? (weak-equal-hash-vals-ht ht) (car p))) + ;; key was removed from table after `keys` array was formed + (loop (add1 i))] + [else i]))]))))) + +(define (do-weak-hash-iterate-key who ht i) + (let* ([vec (weak-equal-hash-keys ht)] + [p (and vec + (< i (vector-length vec)) + (vector-ref vec i))] + [k (if p + (car p) + #!bwp)]) + (cond + [(bwp-object? k) + (raise-arguments-error who "no element at index" + "index" i)] + [else k]))) + +(define (weak-hash-iterate-key ht i) + (do-weak-hash-iterate-key 'hash-iterate-key ht i)) + +(define (weak-hash-iterate-value ht i) + (let* ([key (do-weak-hash-iterate-key 'hash-iterate-value ht i)] + [val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) + (if (eq? val none) + (raise-arguments-error + 'weak-hash-iterate-value "no element at index" + "index" i) + val))) + +(define (weak-hash-iterate-key+value ht i) + (let ([key (do-weak-hash-iterate-key 'hash-iterate-key+value ht i)]) + (values key + (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) + (if (eq? val none) + (raise-arguments-error + 'weak-hash-iterate-key+value "no element at index" + "index" i) + val))))) + +(define (weak-hash-iterate-pair ht i) + (let ([key (do-weak-hash-iterate-key 'hash-iterate-pair ht i)]) + (cons key + (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) + (if (eq? val none) + (raise-arguments-error + 'weak-hash-iterate-paur "no element at index" + "index" i) + val))))) + +;; Remove empty weak boxes from a table. Count the number +;; of remaining entries, and remember to prune again when +;; the number of entries doubles (up to at least reaches 128) +(define (prune-table! t) + (let ([ht (weak-equal-hash-keys-ht t)]) + (let-values ([(new-ht count) + (let loop ([ht ht] + [i (intmap-iterate-first ht)] + [count 0]) + (cond + [(not i) (values ht count)] + [else + (let-values ([(key l) (intmap-iterate-key+value ht i #f)]) + (let ([l (let loop ([l l]) + (cond + [(null? l) l] + [(bwp-object? (car l)) (loop (cdr l))] + [else (weak/fl-cons (car l) (loop (cdr l)))]))]) + (loop (if (null? l) + ht + (hash-set ht key l)) + (intmap-iterate-next ht i) + (+ count (length l)))))]))]) + (set-weak-equal-hash-keys-ht! t new-ht) + (set-weak-equal-hash-count! t count) + (set-weak-equal-hash-prune-at! t (max 128 (* 2 count)))))) + +;; ---------------------------------------- + +(define (weak/fl-cons key d) + ;; Special case for flonums, which are never retained in weak pairs, + ;; but we want to treat them like fixnums and other immediates: + (if (flonum? key) + (cons key d) + (weak-cons key d))) + +;; ---------------------------------------- + +(define (set-hash-hash!) + (record-type-equal-procedure (record-type-descriptor mutable-hash) + hash=?) + (record-type-hash-procedure (record-type-descriptor mutable-hash) + hash-hash-code) + (record-type-equal-procedure (record-type-descriptor weak-equal-hash) + hash=?) + (record-type-hash-procedure (record-type-descriptor weak-equal-hash) + hash-hash-code) + + (record-type-hash-procedure (record-type-descriptor hash-impersonator) + hash-hash-code) + (record-type-hash-procedure (record-type-descriptor hash-chaperone) + hash-hash-code)) + +;; ---------------------------------------- + +;; `eq?` identity of a `hash-procs` instance matters for +;; `impersonator-of?` and `chaperone-of?`: +(define-record hash-procs (ref set remove key clear equal-key)) + +(define-record hash-impersonator impersonator (procs)) +(define-record hash-chaperone chaperone (procs)) + +(define/who (impersonate-hash ht ref set remove key . args) + (check who + (lambda (p) (let ([p (strip-impersonator p)]) + (or (mutable-hash? p) (weak-equal-hash? p)))) + :contract "(and/c hash? (not/c immutable?))" + ht) + (do-impersonate-hash who ht ref set remove key args + make-hash-impersonator)) + +(define/who (chaperone-hash ht ref set remove key . args) + (check who hash? ht) + (do-impersonate-hash who ht ref set remove key args + make-hash-chaperone)) + +(define (do-impersonate-hash who ht ref set remove key args + make-hash-chaperone) + (check who (procedure-arity-includes/c 2) ref) + (check who (procedure-arity-includes/c 3) set) + (check who (procedure-arity-includes/c 2) remove) + (check who (procedure-arity-includes/c 2) key) + (let* ([clear-given? (and (pair? args) + (or (not (car args)) + (and (procedure? (car args)) + (procedure-arity-includes? (car args) 1))))] + [clear (if clear-given? (car args) void)] + [args (if clear-given? (cdr args) args)] + [equal-key-given? (and (pair? args) + (or (not (car args)) + (and (procedure? (car args)) + (procedure-arity-includes? (car args) 2))))] + [equal-key (if equal-key-given? + (car args) + (lambda (ht k) k))] + [args (if equal-key-given? (cdr args) args)]) + (make-hash-chaperone (strip-impersonator ht) + ht + (add-impersonator-properties who + args + (if (impersonator? ht) + (impersonator-props ht) + empty-hasheq)) + (make-hash-procs ref set remove key clear equal-key)))) + +;; ---------------------------------------- + +(define (impersonate-hash-ref ht k) + (impersonate-hash-ref/set 'hash-ref #f + (lambda (ht k v) (hash-ref ht k none)) + (lambda (procs ht k none-v) + ((hash-procs-ref procs) ht k)) + hash-procs-ref + ht k none)) + +(define (impersonate-hash-set! ht k v) + (impersonate-hash-ref/set 'hash-set! #t + hash-set! + (lambda (procs ht k v) + ((hash-procs-set procs) ht k v)) + hash-procs-set + ht k v)) + +(define (impersonate-hash-set ht k v) + (impersonate-hash-ref/set 'hash-set #t + hash-set + (lambda (procs ht k v) + ((hash-procs-set procs) ht k v)) + hash-procs-set + ht k v)) + +(define (impersonate-hash-remove! ht k) + (impersonate-hash-ref/set 'hash-remove! #t + (lambda (ht k false-v) (hash-remove! ht k)) + (lambda (procs ht k false-v) + (values ((hash-procs-remove procs) ht k) #f)) + hash-procs-remove + ht k #f)) + +(define (impersonate-hash-remove ht k) + (impersonate-hash-ref/set 'hash-remove #t + (lambda (ht k false-v) (hash-remove ht k)) + (lambda (procs ht k false-v) + (values ((hash-procs-remove procs) ht k) #f)) + hash-procs-remove + ht k #f)) + +(define (impersonate-hash-ref/set who set? authentic-op apply-wrapper get-wrapper ht k v) + (let ([wrap-key? (hash-equal? ht)]) + (let loop ([ht ht] [get-k (and wrap-key? values)] [k k] [v v]) + (cond + [(or (hash-impersonator? ht) + (hash-chaperone? ht)) + (let ([chaperone? (hash-chaperone? ht)] + [procs (if (hash-impersonator? ht) + (hash-impersonator-procs ht) + (hash-chaperone-procs ht))] + [next-ht (impersonator-next ht)]) + (let ([get-k (and wrap-key? (extend-get-k who get-k procs next-ht chaperone?))]) + (call-with-values + (lambda () (apply-wrapper procs next-ht k v)) + (case-lambda + [(new-k new-v-or-wrap) + ;; In `ref` mode, `new-v-or-wrap` is a wrapper procedure for the result. + ;; In `set` mode, `new-v-or-wrap` is a replacement value. + (when chaperone? + (unless (or (not chaperone?) (chaperone-of? new-k k)) + (raise-chaperone-error who "key" new-k k)) + (when set? + (unless (or (not chaperone?) (chaperone-of? new-v-or-wrap v)) + (raise-chaperone-error who "value" new-v-or-wrap v)))) + ;; Recur... + (let ([r (loop next-ht get-k new-k (if set? new-v-or-wrap none))]) + ;; In `ref` mode, `r` is the result value. + ;; In `set` mode, `r` is void or an updated hash table. + (cond + [(and set? (void? r)) + (void)] + [set? + ((if chaperone? make-hash-chaperone make-hash-impersonator) + (strip-impersonator r) + r + (impersonator-props ht) + procs)] + [(eq? r none) none] + [else + (let ([new-r (new-v-or-wrap next-ht new-k r)]) + (when chaperone? + (unless (chaperone-of? new-r r) + (raise-chaperone-error who "value" new-r r))) + new-r)]))] + [args + (raise-arguments-error who + (string-append (if chaperone? "chaperone" "impersonator") + " did not return 2 values") + (string-append (if chaperone? "chaperone" "impersonator") + " procedure") + (get-wrapper procs) + "number of returned values" (length args))]))))] + [(impersonator? ht) + (let ([r (loop (impersonator-next ht) get-k k v)]) + (cond + [(and set? (void? r)) + (void)] + [set? + (rewrap-props-impersonator ht r)] + [else r]))] + [else + (if (and get-k (not (eq? get-k values))) + (call-with-equality-wrap + get-k + k + (lambda () (authentic-op ht k v))) + (authentic-op ht k v))])))) + +;; Add a layer of interposition on `equal?` and `equal-hash-code`: +(define (extend-get-k who get-k procs next-ht chaperone?) + (lambda (k) + (let* ([k (get-k k)] + [new-k ((hash-procs-equal-key procs) next-ht k)]) + (unless (or (not chaperone?) (chaperone-of? new-k k)) + (raise-chaperone-error who "key" new-k k)) + new-k))) + +(define (impersonate-hash-clear! ht) + (let loop ([ht ht]) + (cond + [(or (hash-impersonator? ht) + (hash-chaperone? ht)) + (let ([procs (if (hash-impersonator? ht) + (hash-impersonator-procs ht) + (hash-chaperone-procs ht))] + [ht (impersonator-next ht)]) + ((hash-procs-clear procs) ht) + (loop ht))] + [(impersonator? ht) + (loop (impersonator-next ht))] + [else + (hash-clear! ht)]))) + +(define (impersonate-hash-copy ht) + (let* ([val-ht (impersonator-val ht)] + [mutable? (mutable-hash? val-ht)] + [new-ht + (cond + [mutable? + (cond + [(hash-weak? ht) + (cond + [(hash-eq? val-ht) (make-weak-hasheq)] + [(hash-eqv? val-ht) (make-weak-hasheq)] + [else (make-weak-hash)])] + [else + (cond + [(hash-eq? val-ht) (make-hasheq)] + [(hash-eqv? val-ht) (make-hasheq)] + [else (make-hash)])])] + [else + (cond + [(hash-eq? val-ht) (make-hasheq)] + [(hash-eqv? val-ht) (make-hasheqv)] + [else (make-hash)])])]) + (let loop ([i (hash-iterate-first ht)]) + (cond + [i (let-values ([(key val) (hash-iterate-key+value ht i)]) + (hash-set! new-ht key val) + (loop (hash-iterate-next ht i)))] + [else new-ht])))) + +(define (impersonate-hash-iterate-key+value who ht i key? value? pair?) + (let ([key (impersonate-hash-iterate-key who ht i)]) + (cond + [(not value?) key] + [else + (let ([val (hash-ref ht key none)]) + (cond + [(eq? val none) + (raise-arguments-error who + (string-append "no value found for post-" + (if (impersonator? ht) "impersonator" "chaperone") + " key") + "key" key)] + [pair? (cons key val)] + [key? (values key val)] + [else val]))]))) + +(define (impersonate-hash-iterate-key who ht i) + ;; We don't have to set up `get-k`, because `hash-iterate-key` + ;; is prohibited from hashing any keys + (let loop ([ht ht]) + (cond + [(hash-impersonator? ht) + (let ([procs (hash-impersonator-procs ht)] + [ht (impersonator-next ht)]) + ((hash-procs-key procs) ht (loop ht)))] + [(hash-chaperone? ht) + (let ([procs (hash-chaperone-procs ht)] + [ht (impersonator-next ht)]) + (let* ([k (loop ht)] + [new-k ((hash-procs-key procs) ht k)]) + (unless (chaperone-of? new-k k) + (raise-chaperone-error who "key" new-k k)) + new-k))] + [(impersonator? ht) + (loop (impersonator-next ht))] + [else + ;; The same as `hash-iterate-key`, but with the correct `who`: + (do-hash-iterate-key+value who ht i + intmap-iterate-key + weak-hash-iterate-key + #t #f #f)]))) diff --git a/racket/src/cs/rumble/immutable.ss b/racket/src/cs/rumble/immutable.ss new file mode 100644 index 0000000000..ea1b9101a8 --- /dev/null +++ b/racket/src/cs/rumble/immutable.ss @@ -0,0 +1,8 @@ + +(define (immutable? v) + (let ([v (strip-impersonator v)]) + (or (intmap? v) + (immutable-string? v) + (immutable-bytevector? v) + (immutable-vector? v) + (immutable-box? v)))) diff --git a/racket/src/cs/rumble/impersonator.ss b/racket/src/cs/rumble/impersonator.ss new file mode 100644 index 0000000000..effd98edac --- /dev/null +++ b/racket/src/cs/rumble/impersonator.ss @@ -0,0 +1,591 @@ + +(define-record impersonator (val next props)) +(define-record chaperone impersonator ()) + +(define (impersonator-ephemeron i) + (if (impersonator? i) + (make-ephemeron (impersonator-val i) i) + ;; This is a useless ephemeron, but we create one for consistency + ;; with the case that we have an impersonator: + (make-ephemeron i i))) + +(define (strip-impersonator v) + (if (impersonator? v) + (impersonator-val v) + v)) + +(define (raise-chaperone-error who what e e2) + (raise-arguments-error + who + (string-append "non-chaperone result; received a" (if (equal? what "argument") "n" "") " " what + " that is not a chaperone of the original " what) + "original" e + "received" e2)) + +(define (impersonate-ref acc rtd pos orig) + (impersonate-struct-or-property-ref acc rtd (cons rtd pos) orig)) + +(define (impersonate-struct-or-property-ref acc rtd key orig) + (cond + [(and (impersonator? orig) + (or (not rtd) + (record? (impersonator-val orig) rtd))) + (let loop ([v orig]) + (cond + [(or (struct-impersonator? v) + (struct-chaperone? v)) + (let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) key #f)]) + (cond + [wrapper + (let* ([r (cond + [(pair? wrapper) + (|#%app| (car wrapper) (impersonator-next v))] + [else + (loop (impersonator-next v))])] + [new-r (cond + [(pair? wrapper) + (|#%app| (cdr wrapper) orig r)] + [else (|#%app| wrapper orig r)])]) + (when (struct-chaperone? v) + (unless (chaperone-of? new-r r) + (raise-chaperone-error 'struct-ref "value" r new-r))) + new-r)] + [else + (loop (impersonator-next v))]))] + [(and (struct-undefined-chaperone? v) + rtd) + (let ([r (loop (impersonator-next v))]) + (when (eq? r unsafe-undefined) + (raise-unsafe-undefined 'struct-ref "undefined" "use" acc (impersonator-val v) (cdr key))) + r)] + [(impersonator? v) + (loop (impersonator-next v))] + [else (|#%app| acc v)]))] + [else + ;; Let accessor report the error: + (|#%app| acc orig)])) + +(define (impersonate-set! set rtd pos abs-pos orig a) + (cond + [(and (impersonator? orig) + (record? (impersonator-val orig) rtd)) + (let ([key (vector rtd pos)]) + (let loop ([v orig] [a a]) + (cond + [(or (struct-impersonator? v) + (struct-chaperone? v)) + (let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) key #f)]) + (cond + [wrapper + (let ([new-a (cond + [(pair? wrapper) + (|#%app| (cdr wrapper) orig a)] + [else (wrapper orig a)])]) + (when (struct-chaperone? v) + (unless (chaperone-of? new-a a) + (raise-chaperone-error 'struct-set! "value" a new-a))) + (cond + [(pair? wrapper) + (|#%app| (car wrapper) (impersonator-next v) new-a)] + [else + (loop (impersonator-next v) new-a)]))] + [else + (loop (impersonator-next v) a)]))] + [(struct-undefined-chaperone? v) + (when (eq? (unsafe-struct*-ref (impersonator-val v) abs-pos) unsafe-undefined) + (unless (eq? (continuation-mark-set-first #f prop:chaperone-unsafe-undefined) + unsafe-undefined) + (raise-unsafe-undefined 'struct-set! "assignment disallowed" "assign" set (impersonator-val v) pos))) + (loop (impersonator-next v) a)] + [(impersonator? v) + (loop (impersonator-next v) a)] + [else (set v a)])))] + [else + ;; Let mutator report the error: + (set orig a)])) + +(define (impersonate-struct-info orig) + (let loop ([v orig]) + (cond + [(struct-chaperone? v) + (let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) struct-info #f)]) + (cond + [wrapper + (let-values ([(rtd skipped?) (loop (impersonator-next v))]) + (cond + [(not rtd) (values #f skipped?)] + [else + (call-with-values (lambda () (wrapper rtd skipped?)) + (case-lambda + [(new-rtd new-skipped?) + (unless (chaperone-of? new-rtd rtd) + (raise-chaperone-error 'struct-info "value" rtd new-rtd)) + (unless (chaperone-of? new-skipped? skipped?) + (raise-chaperone-error 'struct-info "value" skipped? new-skipped?)) + (values new-rtd new-skipped?)] + [args (raise-impersonator-result-arity-error 'struct-info orig 2 args)]))]))] + [else + (loop (impersonator-next v))]))] + [(impersonator? v) + (loop (impersonator-next v))] + [else (struct-info v)]))) + +(define (raise-impersonator-result-arity-error who orig n args) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + (symbol->string who) ": arity mismatch;\n" + " received wrong number of values from a chaperone's replacement procedure\n" + " expected: " (number->string n) "\n" + " received: " (number->string (length args)) "\n" + " chaperone: " (error-value->string orig))))) + +;; ---------------------------------------- + +(define-record struct-type-chaperone chaperone (struct-info make-constructor guard)) + +(define/who (chaperone-struct-type rtd struct-info-proc make-constructor-proc guard-proc . props) + (check who struct-type? rtd) + (check who (procedure-arity-includes/c 8) struct-info-proc) + (check who (procedure-arity-includes/c 1) make-constructor-proc) + (check who procedure? guard-proc) + (make-struct-type-chaperone + (strip-impersonator rtd) + rtd + (add-impersonator-properties who + props + (if (impersonator? rtd) + (impersonator-props rtd) + empty-hasheq)) + struct-info-proc + make-constructor-proc + guard-proc)) + +(define (chaperone-constructor rtd ctr) + (let loop ([rtd rtd]) + (cond + [(struct-type-chaperone? rtd) + (let* ([ctr (loop (impersonator-next rtd))] + [new-ctr ((struct-type-chaperone-make-constructor rtd) ctr)]) + (unless (chaperone-of? new-ctr ctr) + (raise-chaperone-error 'struct-type-make-constructor "value" ctr new-ctr)) + new-ctr)] + [(impersonator? rtd) + (loop (impersonator-next rtd))] + [else ctr]))) + +(define (chaperone-struct-type-info orig-rtd get-results) + (apply + values + (let loop ([rtd orig-rtd]) + (cond + [(struct-type-chaperone? rtd) + (let ([results (loop (impersonator-next rtd))]) + (let-values ([new-results (apply (struct-type-chaperone-struct-info rtd) results)]) + (cond + [(= (length results) (length new-results)) + (for-each (lambda (r new-r) + (unless (chaperone-of? new-r r) + (raise-chaperone-error 'struct-type-info "value" r new-r))) + results + new-results) + new-results] + [else + (raise-impersonator-result-arity-error 'struct-type-info orig-rtd (length results) new-results)])))] + [(impersonator? rtd) + (loop (impersonator-next rtd))] + [else (call-with-values get-results list)])))) + +;; ---------------------------------------- + +(define-record-type (impersonator-property create-impersonator-property impersonator-property?) + (fields name)) + +(define-record-type (impersonator-property-accessor-procedure + make-impersonator-property-accessor-procedure + raw:impersonator-property-accessor-procedure?) + (fields proc name)) + +(define/who (make-impersonator-property name) + (check who symbol? name) + (let ([p (create-impersonator-property name)] + [predicate-name (string->symbol (format "~a?" name))] + [accessor-name (string->symbol (format "~a-accessor" name))]) + (letrec ([predicate + (lambda (v) + (if (impersonator? v) + (not (eq? none (hash-ref (impersonator-props v) p none))) + (let ([iv (extract-impersonator-of predicate-name v)]) + (and iv + (predicate iv)))))] + [accessor + (lambda (v) + (if (impersonator? v) + (let ([pv (hash-ref (impersonator-props v) p none)]) + (if (eq? none pv) + (raise-argument-error accessor-name + (format "~a?" name) + v) + pv)) + (let ([iv (extract-impersonator-of accessor-name v)]) + (and iv + (accessor iv)))))]) + (values p + (make-named-procedure predicate predicate-name) + (make-impersonator-property-accessor-procedure accessor accessor-name))))) + +(define (impersonator-property-accessor-procedure? v) + (or (raw:impersonator-property-accessor-procedure? v) + (and (impersonator? v) (raw:impersonator-property-accessor-procedure? (impersonator-val v))))) + +;; ---------------------------------------- + +(define-record props-impersonator impersonator ()) +(define-record props-chaperone chaperone ()) + +;; Applicable variants: +(define-record props-procedure-impersonator props-impersonator ()) +(define-record props-procedure-chaperone props-chaperone ()) + +(define (add-impersonator-properties who props base-props) + (let loop ([props props] [base-props base-props]) + (cond + [(null? props) + base-props] + [(impersonator-property? (car props)) + (when (null? (cdr props)) + (raise-arguments-error who "missing value argument after an imperonsonator-property argument" + "impersonator property" (car props))) + (loop (cddr props) (hash-set base-props (car props) (cadr props)))] + [else + (raise-argument-error who "impersonator-property?" (car props))]))) + +(define (rewrap-props-impersonator orig new) + ((cond + [(props-procedure-impersonator? orig) make-props-procedure-impersonator] + [(props-procedure-chaperone? orig) make-props-procedure-chaperone] + [(props-chaperone? orig) make-props-chaperone] + [(props-impersonator? orig) make-props-impersonator] + [else (raise-arguments-error 'rewrap-props-impersonator "internal error: unknown impersonator variant")]) + (strip-impersonator new) + new + (impersonator-props orig))) + +;; ---------------------------------------- + +(define-record struct-impersonator impersonator (procs)) ; hash of proc -> (cons orig-orig wrapper-proc) +(define-record struct-chaperone chaperone (procs)) + +(define (struct-impersonator/chaperone-procs i) + (if (struct-impersonator? i) + (struct-impersonator-procs i) + (struct-chaperone-procs i))) + +(define-record procedure-struct-impersonator struct-impersonator ()) +(define-record procedure-struct-chaperone struct-chaperone ()) + +(define (impersonate-struct v . args) + (do-impersonate-struct 'impersonate-struct #f v args make-struct-impersonator make-procedure-struct-impersonator)) + +(define (chaperone-struct v . args) + (do-impersonate-struct 'chaperone-struct #t v args make-struct-chaperone make-procedure-struct-chaperone)) + +(define (do-impersonate-struct who as-chaperone? v args make-struct-impersonator make-procedure-struct-impersonator) + (cond + [(null? args) v] + [else + (let* ([st (if (struct-type? (car args)) + (car args) + #f)] + [orig-args (if st (cdr args) args)] + [val (strip-impersonator v)] + [orig-iprops (if (impersonator? v) (impersonator-props v) empty-hasheq)]) + (unless (or (not st) (record? val (strip-impersonator st))) + (raise-arguments-error who "given value is not an instance of the given structure type" + "struct type" st + "value" v)) + (let loop ([first? (not st)] + [args orig-args] + [props empty-hash] + [saw-props empty-hash] + [witnessed? (and st #t)] + [iprops orig-iprops]) + (let ([get-proc + (lambda (what args arity proc->key key-applies?) + (let* ([key-proc (strip-impersonator (car args))] + [key (proc->key key-proc)]) + (when (hash-ref saw-props key #f) + (raise-arguments-error who + "given operation accesses the same value as a previous operation argument" + "operation kind" what + "operation procedure" (car args))) + (when key-applies? + (unless (key-applies? key val) + (raise-arguments-error who + "operation does not apply to given value" + "operation kind" what + "operation procedure" (car args) + "value" v))) + (when (null? (cdr args)) + (raise-arguments-error who + "missing redirection procedure after operation" + "operation kind" what + "operation procedure" (car args))) + (let ([proc (cadr args)]) + (when proc + (unless (procedure-arity-includes? proc arity) + (raise-arguments-error who + "operation's redirection procedure does not match the expected arity" + "given" proc + "expected" (string-append + "(or/c #f (procedure-arity-includes/c " (number->string arity) "))") + "operation kind" what + "operation procedure" (car args)))) + (loop #f + (cddr args) + (if proc + (hash-set props key + (if (impersonator? (car args)) + (cons (car args) ; save original accessor, in case it's impersonated + proc) ; the interposition proc + proc)) + props) + (hash-set saw-props key #t) + (or witnessed? key-applies?) + iprops))))]) + (cond + [(null? args) + (unless as-chaperone? + (check-accessors-paired-with-mutators who orig-args v)) + (unless witnessed? + (raise-arguments-error who + (string-append "cannot " + (if as-chaperone? "chaperone" "impersonate") + " value as a structure without a witness") + "explanation" (string-append + "a structure type, accessor, or mutator acts as a witness\n" + " that the given value's representation can be chaperoned or impersonated") + "given value" v)) + (when (authentic? v) + (raise-arguments-error who + (string-append "cannot " + (if as-chaperone? "chaperone" "impersonate") + " instance of an authentic structure type") + "given value" v)) + (if (and (zero? (hash-count props)) + (eq? iprops orig-iprops)) + v + (let ([mk (if (procedure? v) make-procedure-struct-impersonator make-struct-impersonator)]) + (mk val v iprops props)))] + [(impersonator-property? (car args)) + (loop #f + '() + props + saw-props + witnessed? + (add-impersonator-properties who args iprops))] + [(struct-accessor-procedure? (car args)) + (get-proc "accessor" args 2 + struct-accessor-procedure-rtd+pos + (lambda (rtd+pos v) + (and (record? v (car rtd+pos)) + (begin + (unless (or as-chaperone? + (struct-type-field-mutable? (car rtd+pos) (cdr rtd+pos))) + (raise-arguments-error who + "cannot replace operation for an immutable field" + "operation kind" "property accessor" + "operation procedure" (car args))) + #t))))] + [(struct-mutator-procedure? (car args)) + (get-proc "mutator" args 2 + (lambda (proc) + (let ([rtd+pos (struct-mutator-procedure-rtd+pos proc)]) + (vector (car rtd+pos) (cdr rtd+pos)))) + (lambda (rtd++pos v) + (record? v (vector-ref rtd++pos 0))))] + [(struct-type-property-accessor-procedure? (car args)) + (get-proc "property accessor" args 2 + (lambda (proc) proc) + (lambda (proc v) + (unless (or as-chaperone? + (struct-type-property-accessor-procedure-can-impersonate? proc)) + (raise-arguments-error who + "operation cannot be impersonated" + "operation kind" "property accessor" + "operation procedure" (car args))) + ((struct-type-property-accessor-procedure-pred proc) v)))] + [(and as-chaperone? + (equal? struct-info (car args))) + (get-proc "struct-info procedure" args 2 (lambda (proc) proc) #f)] + [else + (raise-argument-error who + (string-append + "(or/c " + (if first? "struct-type?\n " "") + "struct-accessor-procedure?" + "\n struct-mutator-procedure?" + "\n struct-type-property-accessor-procedure?" + (if as-chaperone? "\n struct-info" "") + ")") + (car args))]))))])) + +(define (check-accessors-paired-with-mutators who args v) + (let ([mutator-reps + (let loop ([args args]) + (cond + [(null? args) empty-hash] + [(struct-mutator-procedure? (car args)) + (hash-set (loop (cddr args)) + (struct-mutator-procedure-rtd+pos (strip-impersonator (car args))) + #t)] + [else + (loop (cddr args))]))]) + (let loop ([args args]) + (cond + [(null? args) empty-hash] + [(struct-accessor-procedure? (car args)) + (let ([rtd+pos (struct-accessor-procedure-rtd+pos (strip-impersonator (car args)))]) + (unless (or (struct-type-immediate-transparent? (car rtd+pos)) + (hash-ref mutator-reps rtd+pos #f)) + (raise-arguments-error who + "accessor redirection for a non-transparent field requires a mutator redirection" + "explanation" "a mutator redirection acts as a witness that access is allowed" + "accessor" (car args) + "value to impersonate" v))) + (loop (cddr args))] + [else + (loop (cddr args))])))) + +;; ---------------------------------------- + +(define-record struct-undefined-chaperone chaperone ()) +(define-record procedure-struct-undefined-chaperone chaperone ()) + +(define-values (prop:chaperone-unsafe-undefined chaperone-unsafe-undefined? chaperone-unsafe-undefined-ref) + (make-struct-type-property 'chaperone-unsafe-undefined + (lambda (v info) + (check 'guard-for-prop:chaperone-unsafe-undefined + (lambda (v) (and (list? v) (andmap symbol? v))) + :contract "(listof symbol?)" + v) + v))) + +(define (chaperone-struct-unsafe-undefined v) + (cond + [(not (record? v)) + v] + [else + ((if (procedure? v) + make-procedure-struct-undefined-chaperone + make-struct-undefined-chaperone) + (strip-impersonator v) + v + (if (impersonator? v) + (impersonator-props v) + empty-hasheq))])) + +(define (raise-unsafe-undefined who short-msg what orig-proc v pos) + (let* ([names (if (chaperone-unsafe-undefined? v) + (chaperone-unsafe-undefined-ref v) + '())] + [len (length names)]) + (cond + [(< pos len) + (let ([n (list-ref names (- len pos 1))]) + (raise + (|#%app| + exn:fail:contract:variable + (format "~a: ~a;\n cannot ~a field before initialization" + n short-msg what) + (current-continuation-marks) + n)))] + [else + (raise + (|#%app| + exn:fail:contract + (format "~a: ~a;\n cannot ~as field before initialization" + (object-name orig-proc) short-msg what) + (current-continuation-marks)))]))) + +;; ---------------------------------------- + +(define-values (prop:impersonator-of impersonator-of-redirect? impersonator-of-ref) + (make-struct-type-property 'impersonator-of + (lambda (v info) + (check 'guard-for-prop:impersonator-of (procedure-arity-includes/c 1) v) + ;; Add a tag to track origin of the `prop:impersonator-of` value + (cons (gensym "tag") v)))) + +(define (extract-impersonator-of who a) + (and (impersonator-of-redirect? a) + (let* ([tag+ref (impersonator-of-ref a)] + [a2 (|#%app| (cdr tag+ref) a)]) + (cond + [(not a2) + ;; `prop:impersonator-of` function can report #f to mean + ;; "not an impersonator, after all" + #f] + [else + (let ([different + (lambda (what) + (raise-arguments-error who (format (string-append "impersonator-of property procedure returned a" + " value with a different `~a` source") + what) + "original value" a + "returned value" a2))]) + (unless (and (impersonator-of-redirect? a2) + (eq? (car tag+ref) + (car (impersonator-of-ref a2)))) + (different 'prop:impersonator-of)) + (unless (record-equal-procedure a (strip-impersonator a2)) + (different 'prop:equal+hash)) + a2)])))) + +;; ---------------------------------------- + +(define (set-impersonator-applicables!) + (struct-property-set! prop:procedure + (record-type-descriptor props-procedure-impersonator) + impersonate-apply) + (struct-property-set! prop:procedure + (record-type-descriptor props-procedure-chaperone) + impersonate-apply) + (struct-property-set! prop:procedure-arity + (record-type-descriptor props-procedure-impersonator) + 0) + (struct-property-set! prop:procedure-arity + (record-type-descriptor props-procedure-chaperone) + 0) + + (struct-property-set! prop:procedure + (record-type-descriptor impersonator-property-accessor-procedure) + 0)) + +(define (set-impersonator-hash!) + (let ([struct-impersonator-hash-code + (escapes-ok + (lambda (c hash-code) + ((record-type-hash-procedure + (record-rtd (impersonator-val c))) + c + hash-code)))]) + (let ([add (lambda (rtd) + (record-type-hash-procedure rtd struct-impersonator-hash-code))]) + (add (record-type-descriptor struct-impersonator)) + (add (record-type-descriptor struct-chaperone)) + (add (record-type-descriptor procedure-struct-impersonator)) + (add (record-type-descriptor procedure-struct-chaperone))) + (let ([add (lambda (rtd) + (record-type-hash-procedure rtd + (lambda (c hash-code) + (cond + [(record? (impersonator-val c)) + (struct-impersonator-hash-code c hash-code)] + [else + (hash-code (impersonator-next c))]))))]) + (add (record-type-descriptor props-impersonator)) + (add (record-type-descriptor props-chaperone)) + (add (record-type-descriptor props-procedure-impersonator)) + (add (record-type-descriptor props-procedure-chaperone))))) diff --git a/racket/src/cs/rumble/inline.ss b/racket/src/cs/rumble/inline.ss new file mode 100644 index 0000000000..afc438daf9 --- /dev/null +++ b/racket/src/cs/rumble/inline.ss @@ -0,0 +1,57 @@ +;; Force inlining of the fast path for various primitives that are +;; otherwise wrapped with impersonator checks + +(define-syntax (define-inline stx) + (syntax-case stx () + [(_ (orig-id arg ...) guard op) + (with-syntax ([(tmp ...) (generate-temporaries #'(arg ...))] + [id (datum->syntax #'orig-id + (#%string->symbol + (string-append "inline:" + (#%symbol->string (syntax->datum #'orig-id)))))]) + #'(define-syntax (id stx) + (syntax-case stx () + [(_ tmp ...) + #'(let ([arg tmp] ...) + (if guard + op + (orig-id arg ...)))] + [(_ . args) + #'(orig-id . args)] + [_ #'orig-id])))])) + +(define-inline (vector-length v) + (#%vector? v) + (#3%vector-length v)) + +(define-inline (vector-ref v i) + (#%vector? v) + (#2%vector-ref v i)) + +(define-inline (vector-set! v i n) + (#%vector? v) + (#2%vector-set! v i n)) + +(define-inline (unbox b) + (#%box? b) + (#3%unbox b)) + +(define-inline (set-box! b v) + (#%mutable-box? b) + (#3%set-box! b v)) + +(define-inline (mcar p) + (mpair? p) + (unsafe-mcar p)) + +(define-inline (mcdr p) + (mpair? p) + (unsafe-mcdr p)) + +(define-inline (set-mcar! p v) + (mpair? p) + (unsafe-set-mcar! p v)) + +(define-inline (set-mcdr! p v) + (mpair? p) + (unsafe-set-mcdr! p v)) diff --git a/racket/src/cs/rumble/interrupt.ss b/racket/src/cs/rumble/interrupt.ss new file mode 100644 index 0000000000..13219d5967 --- /dev/null +++ b/racket/src/cs/rumble/interrupt.ss @@ -0,0 +1,59 @@ + +;; Enabling uninterrupted mode defers a timer callback +;; until leaving uninterrupted mode. This is the same +;; as disabling and enabling interrupts at the Chez +;; level, but cheaper and more limited. + +(define-virtual-register current-in-uninterrupted #f) +(define-virtual-register pending-interrupt-callback #f) + +(define-syntax CHECK-uninterrupted + (syntax-rules () + [(_ e ...) (void) #;(begin e ...)])) + +(define (start-uninterrupted who) + (CHECK-uninterrupted + (when (current-in-uninterrupted) + (internal-error 'start-uninterrupted (format "~a: already started" who)))) + (current-in-uninterrupted #t)) + +(define (end-uninterrupted who) + (CHECK-uninterrupted + (unless (current-in-uninterrupted) + (internal-error 'end-uninterrupted (format "~a: not started" who)))) + (current-in-uninterrupted #f) + (when (pending-interrupt-callback) + (pariah + (let ([callback (pending-interrupt-callback)]) + (pending-interrupt-callback #f) + (callback))))) + +(define (assert-in-uninterrupted) + (CHECK-uninterrupted + (unless (current-in-uninterrupted) + (internal-error 'assert-in-uninterrupted "assertion failed")))) + +(define (assert-not-in-uninterrupted) + (CHECK-uninterrupted + (when (current-in-uninterrupted) + (internal-error 'assert-not-in-uninterrupted "assertion failed")))) + +;; An implicit context is when a relevant interrupt can't happen, but +;; `assert-in-uninterrupted` might be called. + +(define (start-implicit-uninterrupted who) + (CHECK-uninterrupted + (when (current-in-uninterrupted) + (internal-error 'start-implicit-uninterrupted "already started")) + (current-in-uninterrupted #t))) + +(define (end-implicit-uninterrupted who) + (CHECK-uninterrupted + (unless (current-in-uninterrupted) + (internal-error 'end-implicit-uninterrupted "not started")) + (current-in-uninterrupted #f))) + +(define (internal-error who s) + (CHECK-uninterrupted + (chez:fprintf (current-error-port) "~a: ~a\n" who s) + (chez:exit 1))) diff --git a/racket/src/cs/rumble/intmap.ss b/racket/src/cs/rumble/intmap.ss new file mode 100644 index 0000000000..afc363279d --- /dev/null +++ b/racket/src/cs/rumble/intmap.ss @@ -0,0 +1,469 @@ +;; Immutable maps represented as big-endian Patricia tries. +;; Based on Okasaki & Gill's "Fast Mergeable Integer Maps," +;; (1998) with an added collision node. +;; +;; I also consulted Leijen and Palamarchuk's Haskell implementation +;; of Data.IntMap. + +(define-record-type intmap + [fields (immutable eqtype) + (mutable root)] + [nongenerative #{intmap pfwguidjcvqbvofiirp097jco-0}] + [sealed #t]) + +(define-record-type Br + [fields (immutable count) + (immutable prefix) + (immutable mask) + (immutable left) + (immutable right)] + [nongenerative #{Br pfwguidjcvqbvofiirp097jco-1}] + [sealed #t]) + +(define-record-type Lf + [fields (immutable hash) + (immutable key) + (immutable value)] + [nongenerative #{Lf pfwguidjcvqbvofiirp097jco-2}] + [sealed #t]) + +(define-record-type Co + [fields (immutable hash) + (immutable pairs)] + [nongenerative #{Co pfwguidjcvqbvofiirp097jco-3}] + [sealed #t]) + +(define *nothing* (gensym)) + +(define immutable-hash? intmap?) + +(define empty-hash (make-intmap 'equal #f)) +(define empty-hasheqv (make-intmap 'eqv #f)) +(define empty-hasheq (make-intmap 'eq #f)) + +(define (make-intmap-shell et) + (make-intmap et #f)) + +(define (intmap-shell-sync! dst src) + (intmap-root-set! dst (intmap-root src))) + +(define (intmap-equal? t) (eq? 'equal (intmap-eqtype t))) +(define (intmap-eqv? t) (eq? 'eqv (intmap-eqtype t))) +(define (intmap-eq? t) (eq? 'eq (intmap-eqtype t))) + +(define (intmap-count t) + ($intmap-count (intmap-root t))) + +(define (intmap-empty? t) + (fx= 0 (intmap-count t))) + +(define ($intmap-count t) + (cond [(Br? t) (Br-count t)] + [(Lf? t) 1] + [(Co? t) (length (Co-pairs t))] + [else 0])) + +(define (intmap-ref t key def) + (let ([et (intmap-eqtype t)] + [root (intmap-root t)]) + (if root + ($intmap-ref et root (hash-code et key) key def) + ($fail def)))) + +(define ($intmap-ref et t h key def) + (cond + [(Br? t) + (if (fx<= h (Br-prefix t)) + ($intmap-ref et (Br-left t) h key def) + ($intmap-ref et (Br-right t) h key def))] + + [(Lf? t) + (if (key=? et key (Lf-key t)) + (Lf-value t) + ($fail def))] + + [(Co? t) + (if (fx= h (Co-hash t)) + ($collision-ref et t key def) + ($fail def))] + + [else + ($fail def)])) + +(define ($intmap-has-key? et t h key) + (not (eq? *nothing* ($intmap-ref et t h key *nothing*)))) + +(define (intmap-set t key val) + (let ([et (intmap-eqtype t)]) + (make-intmap + et + ($intmap-set et (intmap-root t) (hash-code et key) key val)))) + +(define ($intmap-set et t h key val) + (cond + [(Br? t) + (let ([p (Br-prefix t)] + [m (Br-mask t)]) + (cond + [(not (match-prefix? h p m)) + (join h (make-Lf h key val) p t)] + [(fx<= h p) + (br p m ($intmap-set et (Br-left t) h key val) (Br-right t))] + [else + (br p m (Br-left t) ($intmap-set et (Br-right t) h key val))]))] + + [(Lf? t) + (let ([j (Lf-hash t)]) + (cond + [(not (fx= h j)) + (join h (make-Lf h key val) j t)] + [(key=? et key (Lf-key t)) + (make-Lf h key val)] + [else + (make-Co h (list (cons key val) (cons (Lf-key t) (Lf-value t))))]))] + + [(Co? t) + (let ([j (Co-hash t)]) + (if (fx= h j) + (make-Co j ($collision-set et t key val)) + (join h (make-Lf h key val) j t)))] + + [else + (make-Lf h key val)])) + +(define (join p0 t0 p1 t1) + (let* ([m (branching-bit p0 p1)] + [p (mask p0 m)]) + (if (fx<= p0 p1) + (br p m t0 t1) + (br p m t1 t0)))) + +(define (intmap-remove t key) + (let ([et (intmap-eqtype t)]) + (make-intmap + et + ($intmap-remove et (intmap-root t) (hash-code et key) key)))) + +(define ($intmap-remove et t h key) + (cond + [(Br? t) + (let ([p (Br-prefix t)] + [m (Br-mask t)]) + (cond + [(not (match-prefix? h p m)) + t] + [(fx<= h p) + (br/check-left p m ($intmap-remove et (Br-left t) h key) (Br-right t))] + [else + (br/check-right p m (Br-left t) ($intmap-remove et (Br-right t) h key))]))] + + [(Lf? t) + (if (key=? et key (Lf-key t)) + #f + t)] + + [(Co? t) + (cond + [(fx=? h (Co-hash t)) + ;; A collision node always has at least 2 key-value pairs, + ;; so when we remove one, we know the resulting list is non-empty. + (let ([pairs ($collision-remove et t key)]) + (if (null? (cdr pairs)) + (make-Lf h (caar pairs) (cdar pairs)) + (make-Co h pairs)))] + [else + t])] + + [else + #f])) + +;; collision ops +(define ($collision-ref et t key def) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) ($fail def)] + [(key=? et key (caar xs)) (cdar xs)] + [else (loop (cdr xs))]))) + +(define ($collision-set et t key val) + (cons (cons key val) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) '()] + [(key=? et key (caar xs)) (loop (cdr xs))] + [else (cons (car xs) (loop (cdr xs)))])))) + +(define ($collision-remove et t key) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) '()] + [(key=? et key (caar xs)) (loop (cdr xs))] + [else (cons (car xs) (loop (cdr xs)))]))) + +(define ($collision-has-key? et t key) + (let loop ([xs (Co-pairs t)]) + (cond [(null? xs) #f] + [(key=? et key (caar xs)) #t] + [else (loop (cdr xs))]))) + +;; bit twiddling +(define-syntax-rule (match-prefix? h p m) + (fx= (mask h m) p)) + +(define-syntax-rule (mask h m) + (fxand (fxior h (fx1- m)) (fxnot m))) + +(define-syntax-rule (branching-bit p m) + (highest-set-bit (fxxor p m))) + +(define-syntax-rule (highest-set-bit x1) + (let* ([x2 (fxior x1 (fxsrl x1 1))] + [x3 (fxior x2 (fxsrl x2 2))] + [x4 (fxior x3 (fxsrl x3 4))] + [x5 (fxior x4 (fxsrl x4 8))] + [x6 (fxior x5 (fxsrl x5 16))] + [x7 (fxior x6 (fxsrl x6 32))]) + (fxxor x7 (fxsrl x7 1)))) + +;; basic utils +(define (br p m l r) + (let ([c (fx+ ($intmap-count l) ($intmap-count r))]) + (make-Br c p m l r))) + +(define (br/check-left p m l r) + (if l + (br p m l r) + r)) + +(define (br/check-right p m l r) + (if r + (br p m l r) + l)) + +(define-syntax-rule (key=? et k1 k2) + (cond [(eq? et 'eq) (eq? k1 k2)] + [(eq? et 'eqv) (eqv? k1 k2)] + [else (equal? k1 k2)])) + +(define-syntax-rule (hash-code et k) + (cond [(eq? et 'eq) (eq-hash-code k)] + [(eq? et 'eqv) (eqv-hash-code k)] + [else (key-equal-hash-code k)])) + +(define ($fail default) + (if (procedure? default) + (|#%app| default) + default)) + +;; iteration +(define (intmap-iterate-first t) + (and (fx> (intmap-count t) 0) + 0)) + +(define (intmap-iterate-next t pos) + (let ([pos (fx1+ pos)]) + (and (fx< pos (intmap-count t)) + pos))) + +(define (intmap-iterate-pair t pos fail) + (or ($intmap-nth (intmap-root t) pos) + fail)) + +(define (intmap-iterate-key t pos fail) + (let ([p ($intmap-nth (intmap-root t) pos)]) + (if p (car p) fail))) + +(define (intmap-iterate-value t pos fail) + (let ([p ($intmap-nth (intmap-root t) pos)]) + (if p (cdr p) fail))) + +(define (intmap-iterate-key+value t pos fail) + (let ([p ($intmap-nth (intmap-root t) pos)]) + (if p + (values (car p) (cdr p)) + fail))) + +(define ($intmap-nth t n) + (cond + [(Br? t) + (let* ([left (Br-left t)] + [left-count ($intmap-count left)]) + (if (fx< n left-count) + ($intmap-nth left n) + ($intmap-nth (Br-right t) (fx- n left-count))))] + + [(Lf? t) + (and (fx= 0 n) + (cons (Lf-key t) (Lf-value t)))] + + [(Co? t) + (let ([pairs (Co-pairs t)]) + (and (fx< n (length pairs)) + (list-ref pairs n)))] + + [else + #f])) + +(define (unsafe-intmap-iterate-first t) + ($intmap-enum (intmap-root t) #f)) + +(define (unsafe-intmap-iterate-next t pos) + (let ([next (cdr pos)]) + (and next + ($intmap-enum (car next) (cdr next))))) + +(define (unsafe-intmap-iterate-pair t pos) + (car pos)) + +(define (unsafe-intmap-iterate-key t pos) + (caar pos)) + +(define (unsafe-intmap-iterate-value t pos) + (cdar pos)) + +(define (unsafe-intmap-iterate-key+value t pos) + (values (caar pos) (cdar pos))) + +(define ($intmap-enum t next) + (cond + [(Br? t) + ($intmap-enum (Br-left t) (cons (Br-right t) next))] + + [(Lf? t) + (cons (cons (Lf-key t) (Lf-value t)) next)] + + [(Co? t) + (let ([pairs (Co-pairs t)]) + (let ([fst (car pairs)] + [rst (cdr pairs)]) + (if (null? rst) + (cons fst next) + (cons fst (cons (make-Co #f rst) next)))))] + + [else + next])) + +(define (intmap-fold t nil proc) + (let loop ([pos (unsafe-intmap-iterate-first t)] [nil nil]) + (cond + [pos + (let ([p (unsafe-intmap-iterate-pair t pos)]) + (loop (unsafe-intmap-iterate-next t pos) + (proc (car p) (cdr p) nil)))] + [else + nil]))) + +(define (intmap-for-each t proc) + (intmap-fold t (void) (lambda (k v _) (|#%app| proc k v) (void)))) + +(define (intmap-map t proc) + (intmap-fold t '() (lambda (k v xs) (cons (|#%app| proc k v) xs)))) + +;; equality +(define (intmap=? a b eql?) + (and (eq? (intmap-eqtype a) (intmap-eqtype b)) + ($intmap=? (intmap-eqtype a) (intmap-root a) (intmap-root b) eql?))) + +(define ($intmap=? et a b eql?) + (or + (eq? a b) + + (cond + [(Br? a) + (and (Br? b) + (fx= (Br-count a) (Br-count b)) + (fx= (Br-prefix a) (Br-prefix b)) + (fx= (Br-mask a) (Br-mask b)) + ($intmap=? et (Br-left a) (Br-left b) eql?) + ($intmap=? et (Br-right a) (Br-right b) eql?))] + + [(Lf? a) + (and (Lf? b) + (key=? et (Lf-key a) (Lf-key b)) + (eql? (Lf-value a) (Lf-value b)))] + + [(Co? a) + (and (Co? b) + (let ([xs (Co-pairs a)]) + (and (fx= (length xs) (length (Co-pairs b))) + (let loop ([xs xs]) + (cond [(null? xs) #t] + [($collision-has-key? et b (caar xs)) (loop (cdr xs))] + [else #f])))))] + + [else (and (not a) (not b))]))) + +;; hash code +(define (intmap-hash-code t hash) + ($intmap-hash-code (intmap-root t) hash 0)) + +(define ($intmap-hash-code t hash hc) + (cond + [(Br? t) + (let* ([hc (hash-code-combine hc (hash (Br-prefix t)))] + [hc (hash-code-combine hc (hash (Br-mask t)))] + [hc (hash-code-combine hc ($intmap-hash-code (Br-left t) hash hc))] + [hc (hash-code-combine hc ($intmap-hash-code (Br-right t) hash hc))]) + hc)] + + [(Lf? t) + (let* ([hc (hash-code-combine hc (Lf-hash t))] + [hc (hash-code-combine hc (hash (Lf-value t)))]) + hc)] + + [(Co? t) + (hash-code-combine hc (Co-hash t))] + + [else + (hash-code-combine hc (hash #f))])) + +(define ignored/intmap + (begin + ;; Go through generic `hash` versions to support `a` + ;; and `b` as impersonated hash tables + (record-type-equal-procedure (record-type-descriptor intmap) + (lambda (a b eql?) + (hash=? a b eql?))) + (record-type-hash-procedure (record-type-descriptor intmap) + (lambda (a hash) + (hash-hash-code a hash))))) + +;; subset +(define (intmap-keys-subset? a b) + ($intmap-keys-subset? (intmap-eqtype a) (intmap-root a) (intmap-root b))) + +(define ($intmap-keys-subset? et a b) + (or + (eq? a b) + + (cond + [(Br? a) + (and + (Br? b) + + (let ([p1 (Br-prefix a)] + [m1 (Br-mask a)] + [p2 (Br-prefix b)] + [m2 (Br-mask b)]) + (cond + [(fx> m1 m2) #f] + [(fx> m2 m1) + (and (match-prefix? p1 p2 m2) + (if (fx<= p1 p2) + ($intmap-keys-subset? et a (Br-left b)) + ($intmap-keys-subset? et a (Br-right b))))] + [else + (and (fx= p1 p2) + ($intmap-keys-subset? et (Br-left a) (Br-left b)) + ($intmap-keys-subset? et (Br-right a) (Br-right b)))])))] + + [(Lf? a) + (if (Lf? b) + (key=? et (Lf-key a) (Lf-key b)) + ($intmap-has-key? et b (Lf-hash a) (Lf-key a)))] + + [(Co? a) + (let loop ([xs (Co-pairs a)]) + (cond [(null? xs) #t] + [($intmap-has-key? et b (Co-hash a) (caar xs)) (loop (cdr xs))] + [else #f]))] + + [else + #t]))) diff --git a/racket/src/cs/rumble/keyword.ss b/racket/src/cs/rumble/keyword.ss new file mode 100644 index 0000000000..a5730c9a98 --- /dev/null +++ b/racket/src/cs/rumble/keyword.ss @@ -0,0 +1,38 @@ + +(define-record-type keyword + (fields symbol) + (nongenerative #{keyword dhghafpy3v03qbye1a9lwf-0})) + +(define keywords (make-weak-eq-hashtable)) + +(define/who (string->keyword s) + (check who string? s) + (let ([sym (string->symbol s)]) + (let ([e (eq-hashtable-ref keywords sym #f)]) + (or (and e + (ephemeron-value e)) + (let ([kw (make-keyword sym)]) + (eq-hashtable-set! keywords sym (make-ephemeron sym kw)) + kw))))) + +(define/who (keyword->string kw) + (check who keyword? kw) + (symbol->string (keyword-symbol kw))) + +(define/who keyword (add1 this-counter) (bitwise-arithmetic-shift-left 1 (* log-collect-generation-radix (sub1 (collect-maximum-generation))))) + (set! gc-counter 1) + (set! gc-counter (add1 this-counter))) + (let ([gen (cond + [(and (not g) + (>= pre-allocated (* 2 allocated-after-major))) + ;; Force a major collection if memory use has doubled + (collect-maximum-generation)] + [else + ;; Find the minor generation implied by the counter + (let loop ([c this-counter] [gen 0]) + (cond + [(zero? (bitwise-and c collect-generation-radix-mask)) + (loop (bitwise-arithmetic-shift-right c log-collect-generation-radix) (add1 gen))] + [else gen]))])]) + (collect gen) + (let ([post-allocated (bytes-allocated)]) + (when (= gen (collect-maximum-generation)) + (set! allocated-after-major post-allocated)) + (garbage-collect-notify gen + pre-allocated pre-allocated+overhead pre-time pre-cpu-time + post-allocated (current-memory-bytes) (real-time) (cpu-time))) + (poll-foreign-guardian)))) + +(define collect-garbage + (case-lambda + [() (collect-garbage 'major)] + [(request) + (cond + [(eq? request 'incremental) + (void)] + [else + (let ([req (case request + [(minor) 0] + [(major) (collect-maximum-generation)] + [else + (raise-argument-error 'collect-garbage + "(or/c 'major 'minor 'incremental)" + request)])]) + (let loop () + (let ([current-req (unbox collect-request)]) + (unless (#%box-cas! collect-request current-req (max req (or current-req 0))) + (loop)))) + (collect-rendezvous))])])) + +(define current-memory-use + (case-lambda + [() (bytes-allocated)] + [(mode) + (cond + [(not mode) (bytes-allocated)] + [(eq? mode 'cumulative) (sstats-bytes (statistics))] + [else + ;; must be a custodian... + (bytes-allocated)])])) + +(define prev-stats-objects #f) + +(define (dump-memory-stats . args) + (let-values ([(backtrace-predicate use-prev? max-path-length) (parse-dump-memory-stats-arguments args)]) + (enable-object-counts #t) + (enable-object-backreferences (and backtrace-predicate #t)) + (collect (collect-maximum-generation)) + (let* ([counts (object-counts)] + [backreferences (object-backreferences)] + [extract (lambda (static? cxr) + (lambda (c) (if (or static? (not (eq? (car c) 'static))) + (cxr c) + 0)))] + [get-count (lambda (static?) (lambda (e) (apply + (map (extract static? cadr) (cdr e)))))] + [get-bytes (lambda (static?) (lambda (e) (apply + (map (extract static? cddr) (cdr e)))))] + [pad (lambda (s n) + (string-append (make-string (max 0 (- n (string-length s))) #\space) s))] + [pad-right (lambda (s n) + (string-append s (make-string (max 0 (- n (string-length s))) #\space)))] + [commas (lambda (n) + (let* ([l (string->list (number->string n))] + [len (length l)]) + (list->string + (cons #\space + (let loop ([l l] [len len]) + (cond + [(<= len 3) l] + [else + (let ([m (modulo len 3)]) + (case m + [(0) (list* (car l) + (cadr l) + (caddr l) + #\, + (loop (cdddr l) (- len 3)))] + [(2) (list* (car l) + (cadr l) + #\, + (loop (cddr l) (- len 2)))] + [else (list* (car l) + #\, + (loop (cdr l) (- len 1)))]))]))))))] + [count-width 11] + [size-width 13] + [trim-type (lambda (s) + (let ([len (string-length s)]) + (cond + [(and (> len 14) + (string=? (substring s 2 14) "record type ")) + (string-append "#<" (substring s 14 len))] + [else s])))] + [layout (lambda args + (let loop ([args args] [actual-col 0] [want-col 0]) + (cond + [(null? args) "\n"] + [(< actual-col want-col) + (string-append (make-string (- want-col actual-col) #\space) + (loop args want-col want-col))] + [(integer? (car args)) + (loop (cons (pad (commas (car args)) + (- (+ want-col (sub1 (cadr args))) + actual-col)) + (cdr args)) + actual-col + want-col)] + [else + (string-append (car args) + (loop (cddr args) + (+ actual-col (string-length (car args))) + (+ want-col (cadr args))))])))] + [layout-line (lambda (label c1 s1 c2 s2) + (layout " " 1 + (trim-type label) 22 + c1 count-width + s1 size-width + " | " 3 + c2 count-width + s2 size-width))]) + (enable-object-counts #f) + (enable-object-backreferences #f) + (chez:fprintf (current-error-port) "Begin Dump\n") + (chez:fprintf (current-error-port) "Current memory use: ~a\n" (bytes-allocated)) + (chez:fprintf (current-error-port) "Begin RacketCS\n") + (for-each (lambda (e) + (chez:fprintf (current-error-port) + (layout-line (chez:format "~a" (car e)) + ((get-count #f) e) ((get-bytes #f) e) + ((get-count #t) e) ((get-bytes #t) e)))) + (list-sort (lambda (a b) (< ((get-bytes #f) a) ((get-bytes #f) b))) counts)) + (chez:fprintf (current-error-port) (layout-line "total" + (apply + (map (get-count #f) counts)) + (apply + (map (get-bytes #f) counts)) + (apply + (map (get-count #t) counts)) + (apply + (map (get-bytes #t) counts)))) + (chez:fprintf (current-error-port) "End RacketCS\n") + (when backtrace-predicate + (when (and use-prev? (not prev-stats-objects)) + (set! prev-stats-objects (make-weak-eq-hashtable))) + (let ([backreference-ht (make-eq-hashtable)]) + (for-each (lambda (l) + (for-each (lambda (p) + (hashtable-set! backreference-ht (car p) (cdr p))) + l)) + backreferences) + (chez:fprintf (current-error-port) "Begin Traces\n") + (let ([prev-trace (box '())]) + (for-each (lambda (l) + (for-each (lambda (p) + (when (backtrace-predicate (car p)) + (unless (and use-prev? + (hashtable-ref prev-stats-objects (car p) #f)) + (when use-prev? + (hashtable-set! prev-stats-objects (car p) #t)) + (unless (eqv? 0 max-path-length) + (chez:printf "*== ~a" (object->backreference-string (car p))) + (let loop ([prev (car p)] [o (cdr p)] [accum '()] [len (sub1 (or max-path-length +inf.0))]) + (cond + [(zero? len) (void)] + [(not o) (set-box! prev-trace (reverse accum))] + [(chez:memq o (unbox prev-trace)) + => (lambda (l) + (chez:printf " <- DITTO\n") + (set-box! prev-trace (append (reverse accum) l)))] + [else + (chez:printf " <- ~a" (object->backreference-string + (cond + [(and (pair? o) + (eq? prev (car o))) + (cons 'PREV (cdr o))] + [(and (pair? o) + (eq? prev (cdr o))) + (cons (car o) 'PREV)] + [else o]))) + (loop o (hashtable-ref backreference-ht o #f) (cons o accum) (sub1 len))])))))) + l)) + backreferences)) + (chez:fprintf (current-error-port) "End Traces\n"))) + (chez:fprintf (current-error-port) "End Dump\n")))) + +(define (parse-dump-memory-stats-arguments args) + (values + ;; backtrace predicate: + (cond + [(null? args) #f] + [(eq? (car args) 'struct) #f] + [(and (list? (car args)) + (= 2 (length (car args))) + (eq? (caar args) 'struct) + (symbol? (cadar args))) + (let ([struct-name (cadar args)]) + (lambda (o) + (and (#%$record? o) + (eq? (record-type-name (#%$record-type-descriptor o)) struct-name))))] + [(eq? 'code (car args)) + #%$code?] + [(eq? 'ephemeron (car args)) + ephemeron-pair?] + [(symbol? (car args)) + (let ([type (car args)]) + (lambda (o) + (eq? ((inspect/object o) 'type) type)))] + [else #f]) + ;; 'new mode for backtrace? + (and (pair? args) + (pair? (cdr args)) + (eq? 'new (cadr args))) + ;; max path length + (and (pair? args) + (pair? (cdr args)) + (or (and (exact-nonnegative-integer? (cadr args)) + (cadr args)) + (and (pair? (cddr args)) + (exact-nonnegative-integer? (caddr args)) + (caddr args)))))) + +(define (object->backreference-string o) + (parameterize ([print-level 3]) + (let ([s (call-with-string-output-port + (lambda (dest) + (pretty-print o dest)))]) + (if (> (string-length s) 256) + (let ([s (substring s 0 256)]) + (string-set! s 252 #\.) + (string-set! s 253 #\.) + (string-set! s 254 #\.) + (string-set! s 255 #\newline) + s) + s)))) + +;; ---------------------------------------- + +(define-record-type (phantom-bytes create-phantom-bytes phantom-bytes?) + (fields [mutable size])) + +(define/who (make-phantom-bytes k) + (check who exact-nonnegative-integer? k) + (create-phantom-bytes k)) + +(define/who (set-phantom-bytes! phantom-bstr k) + (check who phantom-bytes? phantom-bstr) + (check who exact-nonnegative-integer? k) + (phantom-bytes-size-set! phantom-bstr k)) diff --git a/racket/src/cs/rumble/mpair.ss b/racket/src/cs/rumble/mpair.ss new file mode 100644 index 0000000000..177138ee7b --- /dev/null +++ b/racket/src/cs/rumble/mpair.ss @@ -0,0 +1,42 @@ +(define-record mpair (car cdr)) + +(define (mcons a b) + (make-mpair a b)) + +(define/who (mcar m) + (check who mpair? m) + (mpair-car m)) + +(define/who (mcdr m) + (check who mpair? m) + (mpair-cdr m)) + +(define/who (set-mcar! m v) + (check who mpair? m) + (set-mpair-car! m v)) + +(define/who (set-mcdr! m v) + (check who mpair? m) + (set-mpair-cdr! m v)) + +(define (unsafe-mcar m) + (mpair-car m)) + +(define (unsafe-mcdr m) + (mpair-cdr m)) + +(define (unsafe-set-mcar! m v) + (set-mpair-car! m v)) + +(define (unsafe-set-mcdr! m v) + (set-mpair-cdr! m v)) + +(define (set-mpair-hash!) + (record-type-equal-procedure (record-type-descriptor mpair) + (lambda (a b eql?) + (and (eql? (mcar a) (mcar b)) + (eql? (mcdr a) (mcdr b))))) + (record-type-hash-procedure (record-type-descriptor mpair) + (lambda (a hc) + (hash-code-combine (hc (mcar a)) + (hc (mcar a)))))) diff --git a/racket/src/cs/rumble/number.ss b/racket/src/cs/rumble/number.ss new file mode 100644 index 0000000000..a4fbfeb462 --- /dev/null +++ b/racket/src/cs/rumble/number.ss @@ -0,0 +1,295 @@ + +(define (nonnegative-fixnum? n) (and (fixnum? n) (fx>= n 0))) + +(define (exact-integer? n) (and (integer? n) (exact? n))) +(define (exact-nonnegative-integer? n) (and (exact-integer? n) (>= n 0))) +(define (exact-positive-integer? n) (and (exact-integer? n) (> n 0))) +(define (inexact-real? n) (and (real? n) (inexact? n))) +(define (byte? n) (and (exact-integer? n) (>= n 0) (<= n 255))) + +(define (double-flonum? x) (flonum? x)) +(define (single-flonum? x) #f) + +(define/who (real->double-flonum x) + (check who real? x) + (exact->inexact x)) + +(define (real->single-flonum x) + (raise-unsupported-error 'real->single-flonum)) + +(define arithmetic-shift bitwise-arithmetic-shift) + +(define/who (integer-sqrt n) + (check who integer? n) + (cond + [(negative? n) (* (integer-sqrt (- n)) 0+1i)] + [(positive? n) + (let-values ([(s r) (exact-integer-sqrt (inexact->exact n))]) + (if (inexact? n) + (exact->inexact s) + s))])) + +(define/who (integer-sqrt/remainder n) + (check who integer? n) + (let ([m (integer-sqrt n)]) + (values m (- n (* m m))))) + +(define fx->fl fixnum->flonum) +(define fxrshift fxarithmetic-shift-right) +(define fxlshift fxarithmetic-shift-left) + +(define fl->fx flonum->fixnum) +(define ->fl real->flonum) +(define/who (fl->exact-integer fl) + (check who flonum? fl) + (inexact->exact (flfloor fl))) + +(define/who (flreal-part a) + (or (and + (complex? a) + (not (real? a)) ; => complex imaginary part + (let ([r (real-part a)]) + (and (flonum? r) r))) + (check who (lambda (a) #f) + :contract (string-append + "(and/c complex?\n" + " (lambda (c) (flonum? (real-part c)))\n" + " (lambda (c) (flonum? (imag-part c))))") + a))) + +(define/who (flimag-part a) + (or (and + (complex? a) + (let ([r (imag-part a)]) + (and (flonum? r) ; => complex real part + r))) + (check who (lambda (a) #f) + :contract (string-append + "(and/c complex?\n" + " (lambda (c) (flonum? (real-part c)))\n" + " (lambda (c) (flonum? (imag-part c))))") + a))) + +(define/who (make-flrectangular a b) + (check who flonum? a) + (check who flonum? b) + (make-rectangular a b)) + +(define (system-big-endian?) + (eq? (native-endianness) (endianness big))) + +(define/who integer->integer-bytes + (case-lambda + [(num size signed? big-endian? bstr start) + (check who bytes? bstr) + (case size + [(2) + (if signed? + (bytevector-s16-set! bstr start num (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u16-set! bstr start num (if big-endian? + (endianness big) + (endianness little))))] + [(4) + (if signed? + (bytevector-s32-set! bstr start num (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u32-set! bstr start num (if big-endian? + (endianness big) + (endianness little))))] + [(8) + (if signed? + (bytevector-s64-set! bstr start num (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u64-set! bstr start num (if big-endian? + (endianness big) + (endianness little))))] + [else + (raise-argument-error 'integer->integer-bytes + "(or/c 2 4 8)" size)]) + bstr] + [(num size signed?) + (integer->integer-bytes num size signed? (system-big-endian?) + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size signed? big-endian?) + (integer->integer-bytes num size signed? big-endian? + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size signed? big-endian? bstr) + (integer->integer-bytes num size signed? big-endian? bstr 0)])) + +(define/who integer-bytes->integer + (case-lambda + [(bstr signed? big-endian? start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (case (- end start) + [(2) + (if signed? + (bytevector-s16-ref bstr start (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u16-ref bstr start (if big-endian? + (endianness big) + (endianness little))))] + [(4) + (if signed? + (bytevector-s32-ref bstr start (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u32-ref bstr start (if big-endian? + (endianness big) + (endianness little))))] + [(8) + (if signed? + (bytevector-s64-ref bstr start (if big-endian? + (endianness big) + (endianness little))) + (bytevector-u64-ref bstr start (if big-endian? + (endianness big) + (endianness little))))] + [else + (raise-arguments-error 'integer-bytes->integer + "length is not 2, 4, or 8 bytes" + "length" (- end start))])] + [(bstr signed?) + (integer-bytes->integer bstr signed? (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr signed? big-endian?) + (integer-bytes->integer bstr signed? big-endian? 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr signed? big-endian? start) + (integer-bytes->integer bstr signed? big-endian? start (and (bytes? bstr) (bytes-length bstr)))])) + +(define/who real->floating-point-bytes + (case-lambda + [(num size big-endian? bstr start) + (check who bytes? bstr) + (case size + [(4) + (bytevector-ieee-single-set! bstr start num (if big-endian? + (endianness big) + (endianness little)))] + [(8) + (bytevector-ieee-double-set! bstr start num (if big-endian? + (endianness big) + (endianness little)))] + [else + (raise-argument-error 'real->floating-point-bytes + "(or/c 4 8)" size)]) + bstr] + [(num size) + (real->floating-point-bytes num size (system-big-endian?) + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size big-endian?) + (real->floating-point-bytes num size big-endian? + (and (exact-integer? size) (<= 2 size 8) (make-bytevector size)) 0)] + [(num size big-endian? bstr) + (real->floating-point-bytes num size big-endian? bstr 0)])) + +(define/who floating-point-bytes->real + (case-lambda + [(bstr big-endian? start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (case (- end start) + [(4) + (bytevector-ieee-single-ref bstr start (if big-endian? + (endianness big) + (endianness little)))] + [(8) + (bytevector-ieee-double-ref bstr start (if big-endian? + (endianness big) + (endianness little)))] + [else + (raise-arguments-error 'floating-point-bytes->real + "length is not 4 or 8 bytes" + "length" (- end start))])] + [(bstr) + (floating-point-bytes->real bstr (system-big-endian?) 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr big-endian?) + (floating-point-bytes->real bstr big-endian? 0 (and (bytes? bstr) (bytes-length bstr)))] + [(bstr big-endian? start) + (floating-point-bytes->real bstr big-endian? start (and (bytes? bstr) (bytes-length bstr)))])) + +(define string->number + (case-lambda + [(s) (string->number s 10 #f 'decimal-as-inexact)] + [(s radix) (string->number s radix #f 'decimal-as-inexact)] + [(s radix mode) (string->number s radix mode 'decimal-as-inexact)] + [(s radix mode decimal) + (if (and (eq? mode 'read) ; => need to watch out for extflonums + (extflonum-string? s)) + (make-extflonum s) + ;; The argument is constrained to fixnum, bignum, and flonum forms + (chez:string->number s radix))])) + +(define/who number->string + (case-lambda + [(n) (number->string n 10)] + [(n radix) + (check who number? n) + (cond + [(eq? radix 16) + ;; Host generates uppercase letters, Racket generates lowercase + (string-downcase (chez:number->string n 16))] + [else + (check who (lambda (radix) (or (eq? radix 2) (eq? radix 8) (eq? radix 10) (eq? radix 16))) + :contract "(or/c 2 8 10 16)" + radix) + (chez:number->string n radix)])])) + +(define/who (quotient/remainder n m) + (check who integer? n) + (check who integer? m) + (values (quotient n m) (remainder n m))) + +(define/who gcd + (case-lambda + [(n) + (check who rational? n) + n] + [(n m) + (check who rational? n) + (check who rational? m) + (cond + [(and (integer? n) + (integer? m)) + (chez:gcd n m)] + [else + (let ([n-n (numerator n)] + [n-d (denominator n)] + [m-n (numerator m)] + [m-d (denominator m)]) + (/ (chez:gcd n-n m-n) + (chez:lcm n-d m-d)))])] + [(n . ms) + (check who rational? n) + (let loop ([n n] [ms ms]) + (cond + [(null? ms) n] + [else (loop (gcd n (car ms)) (cdr ms))]))])) + +(define/who lcm + (case-lambda + [(n) + (check who rational? n) + n] + [(n m) + (check who rational? n) + (check who rational? m) + (cond + [(and (integer? n) + (integer? m)) + (chez:lcm n m)] + [else + (let ([d (gcd n m)]) + (* n (/ m d)))])] + [(n . ms) + (check who rational? n) + (let loop ([n n] [ms ms]) + (cond + [(null? ms) n] + [else (loop (lcm n (car ms)) (cdr ms))]))])) diff --git a/racket/src/cs/rumble/object-name.ss b/racket/src/cs/rumble/object-name.ss new file mode 100644 index 0000000000..9ed25e6e04 --- /dev/null +++ b/racket/src/cs/rumble/object-name.ss @@ -0,0 +1,62 @@ + +(define-values (prop:object-name object-name? object-name-ref) + (make-struct-type-property 'object-name + (lambda (v info) + (cond + [(exact-nonnegative-integer? v) + (unless (< v (list-ref info 1)) + (raise-arguments-error 'guard-for-prop:object-name + "field index >= initialized-field count for structure type" + "field index" v + "initialized-field count" (list-ref info 1))) + (unless (chez:memv v (list-ref info 5)) + (raise-arguments-error 'guard-for-prop:object-name "field index not declared immutable" + "field index" v)) + (+ v (let ([p (list-ref info 6)]) + (if p + (struct-type-total*-field-count p) + 0)))] + [(and (procedure? v) + (procedure-arity-includes? v 1)) + v] + [else + (raise-argument-error 'guard-for-prop:object-name + "(or/c exact-nonnegative-integer? (procedure-arity-includes/c 1))" + v)])))) + +(define (object-name v) + (cond + [(object-name? v) + (let ([n (object-name-ref v)]) + (cond + [(exact-integer? n) + (unsafe-struct-ref v n)] + [else + (n v)]))] + [(#%procedure? v) + (cond + [(arity-wrapper-procedure? v) + (extract-jit-procedure-name v)] + [else + (let ([name (((inspect/object v) 'code) 'name)]) + (and name + (string->symbol name)))])] + [(impersonator? v) + (object-name (impersonator-val v))] + [(procedure? v) + (extract-procedure-name v)] + [(struct-type? v) + (record-type-name v)] + [(struct-type-property? v) + (struct-type-prop-name v)] + [(record? v) + (struct-object-name v)] + [else #f])) + +(define (struct-object-name v) + (let ([rtd (record-rtd v)]) + (and + ;; Having an entry in `rtd-props` is a sign that + ;; this structure type was created with `make-struct-type`: + (hashtable-contains? rtd-props rtd) + (object-name (record-rtd v))))) diff --git a/racket/src/cs/rumble/parameter.ss b/racket/src/cs/rumble/parameter.ss new file mode 100644 index 0000000000..6cdaac2743 --- /dev/null +++ b/racket/src/cs/rumble/parameter.ss @@ -0,0 +1,121 @@ + +;; Continuation-mark key: +(define parameterization-key (gensym "parameterization-key")) + +(define-record parameterization (ht)) + +(define empty-parameterization (make-parameterization empty-hasheq)) + +(define/who (extend-parameterization p . args) + (check who parameterization? p) + (let loop ([ht (parameterization-ht p)] [args args]) + (cond + [(null? args) (make-parameterization ht)] + [(and (parameter? (car args)) + (pair? (cdr args))) + (let dloop ([p (car args)] [v (cadr args)]) + (cond + [(impersonator? p) + (dloop (impersonator-val p) (impersonate-apply/parameter p #f (list v)))] + [(derived-parameter? p) + (dloop (derived-parameter-next p) (|#%app| (parameter-guard p) v))] + [else + (let* ([guard (parameter-guard p)] + [v (if guard + (|#%app| guard v) + v)]) + (loop (intmap-set ht p (make-thread-cell v #t)) + (cddr args)))]))] + [(parameter? (car args)) + (raise-arguments-error 'extend-parameterization + "missing value for parameter" + "parameter" (car args))] + [else + (raise-argument-error 'extend-parameterization "parameter?" (car args))]))) + +(define (call-with-parameterization parameter value thunk) + (call/cm + parameterization-key + (extend-parameterization (current-parameterization) parameter value) + thunk)) + +(define (current-parameterization) + (continuation-mark-set-first + #f + parameterization-key + empty-parameterization + the-root-continuation-prompt-tag)) + +(define (parameter-cell key) + (intmap-ref (parameterization-ht + (current-parameterization)) + key + #f)) + +(define-record-type (parameter create-parameter authentic-parameter?) + (fields proc guard)) + +(define-record-type (derived-parameter create-derived-parameter derived-parameter?) + (parent parameter) + (fields next)) + +(define (parameter? v) + (authentic-parameter? (strip-impersonator v))) + +(define/who make-parameter + (case-lambda + [(v) (make-parameter v #f)] + [(v guard) + (check who (procedure-arity-includes/c 1) :or-false guard) + (let ([default-c (make-thread-cell v #t)]) + (letrec ([self + (create-parameter + (case-lambda + [() + (let ([c (or (parameter-cell self) + default-c)]) + (thread-cell-ref c))] + [(v) + (let ([c (or (parameter-cell self) + default-c)]) + (thread-cell-set! c (if guard + (guard v) + v)))]) + guard)]) + self))])) + +(define/who (make-derived-parameter p guard wrap) + (check who authentic-parameter? + :contract "(and/c parameter? (not/c impersonator?))" + p) + (check who (procedure-arity-includes/c 1) guard) + (check who (procedure-arity-includes/c 1) wrap) + (create-derived-parameter (let ([self (parameter-proc p)]) + (case-lambda + [(v) (self (guard v))] + [() (wrap (self))])) + guard + p)) + +(define/who (parameter-procedure=? a b) + (check who parameter? a) + (check who parameter? b) + (eq? (strip-impersonator a) (strip-impersonator b))) + +(define/who (reparameterize p) + (check who parameterization? p) + p) + +;; ---------------------------------------- + +(define/who current-inspector + (make-parameter root-inspector + (lambda (v) + (check who inspector? v) + v))) + +(define/who current-code-inspector + (make-parameter root-inspector + (lambda (v) + (check who inspector? v) + v))) diff --git a/racket/src/cs/rumble/place.ss b/racket/src/cs/rumble/place.ss new file mode 100644 index 0000000000..06dd059532 --- /dev/null +++ b/racket/src/cs/rumble/place.ss @@ -0,0 +1,36 @@ + +(define (place-enabled?) + #f) + +(define (place? v) + #f) + +(define (place-channel? v) + #f) + +(define place-specific-table (make-hasheq)) + +(define (unsafe-get-place-table) + place-specific-table) + +(define-syntax define-place-not-yet-available + (syntax-rules () + [(_ id) + (define (id . args) + (error 'id "place API not yet supported"))] + [(_ id ...) + (begin (define-place-not-yet-available id) ...)])) + +(define-place-not-yet-available + place-break + place-channel-get + place-channel-put + place-sleep + place-channel + place-dead-evt + place-kill + place-message-allowed? + dynamic-place + place-wait + place-pumper-threads + place-shared?) diff --git a/racket/src/cs/rumble/prefab.ss b/racket/src/cs/rumble/prefab.ss new file mode 100644 index 0000000000..e0d72e389f --- /dev/null +++ b/racket/src/cs/rumble/prefab.ss @@ -0,0 +1,331 @@ +;; maps (cons prefab-key total-field-count) to rtd: +(define prefabs #f) + +(define (prefab-struct-key v) + (let ([v (strip-impersonator v)]) + (and (record? v) + (let ([p (getprop (record-type-uid (record-rtd v)) 'prefab-key+count #f)]) + (and p (car p)))))) + +(define/who (prefab-key->struct-type key field-count) + (prefab-key+count->rtd + (cons (normalized-prefab-key/check who key field-count) + field-count))) + +(define/who (make-prefab-struct key . args) + (let* ([field-count (length args)] + [norm-key (normalized-prefab-key/check who key field-count)]) + (let ([rtd (prefab-key->struct-type key field-count)]) + (apply (record-constructor rtd) args)))) + +;; ---------------------------------------- + +;; Check that `k` is valid as a prefab key +(define (prefab-key? k) + (or (symbol? k) + (and (pair? k) + (symbol? (car k)) + (let* ([k (cdr k)] ; skip name + [prev-k k] + ;; The initial field count can be omitted: + [k (if (and (pair? k) + (exact-nonnegative-integer? (car k))) + (cdr k) + k)] + [field-count (if (eq? prev-k k) + #f + (car prev-k))]) + (let loop ([field-count field-count] [k k]) ; `k` is after name and field count + (or (null? k) + (and (pair? k) + (let* ([prev-k k] + [k (if (and (pair? (car k)) + (pair? (cdar k)) + (null? (cddar k)) + (exact-nonnegative-integer? (caar k))) + ;; Has a (list ) element + (cdr k) + ;; Doesn't have auto-value element: + k)] + [auto-count (if (eq? prev-k k) + 0 + (caar prev-k))]) + (or (null? k) + (and (pair? k) + (let* ([k (if (and (pair? k) + (vector? (car k))) + ;; Make sure it's a vector of indices + ;; that are in range and distinct: + (let* ([vec (car k)] + [len (vector-length vec)]) + (let loop ([i 0] [set 0]) + (cond + [(= i len) (cdr k)] + [else + (let ([pos (vector-ref vec i)]) + (and (exact-nonnegative-integer? pos) + (or (not field-count) + (< pos (+ field-count auto-count))) + (not (bitwise-bit-set? set pos)) + (loop (add1 i) (bitwise-ior set (bitwise-arithmetic-shift-left 1 pos)))))]))) + k)]) + (or (null? k) + (and (pair? k) + ;; Supertype: make sure it's a pair with a + ;; symbol and a field count, and loop: + (symbol? (car k)) + (pair? (cdr k)) + (exact-nonnegative-integer? (cadr k)) + (loop (cadr k) (cddr k))))))))))))))) + +;; Assuming `(prefab-key? k)`, check that it's consistent with the +;; given total field count +(define (prefab-key-compatible-count? k total-field-count) + (letrec ([field-count-after-name+count + (lambda (k) + (cond + [(null? k) 0] + [(pair? (car k)) + (+ (caar k) + (field-count-after-name+count+auto (cdr k)))] + [else + (field-count-after-name+count+auto k)]))] + [field-count-after-name+count+auto + (lambda (k) + (cond + [(null? k) 0] + [(vector? (car k)) + (if (null? (cdr k)) + 0 + (field-count (cdr k)))] + [else (field-count k)]))] + [field-count + (lambda (k) ; k has symbol and count + (+ (cadr k) + (field-count-after-name+count (cddr k))))]) + (cond + [(symbol? k) #t] + [(null? (cdr k)) #t] + [(exact-integer? (cadr k)) + ;; Info must match exactly + (= total-field-count + (+ (cadr k) (field-count-after-name+count (cddr k))))] + [else + (let ([n (field-count-after-name+count (cdr k))]) + (and + ;; Field count must be <= total-field-count + (>= total-field-count n) + ;; Initial mutables vector (if any) must be in range + ;; for the target field count; any later immutables vector + ;; has been checked already by `prefab-key?` + (let* ([k (cdr k)] + [auto (and (pair? (car k)) + (car k))] + [k (if auto + (cdr k) + k)]) + (or (null? k) + (not (vector? (car k))) + (let* ([n (- total-field-count + (if auto + (car auto) + 0))] + [vec (car k)] + [len (vector-length vec)]) + (let loop ([i 0]) + (or (= i len) + (let ([m (vector-ref vec i)]) + (and (exact-nonnegative-integer? m) ; in case the vector is mutated + (< m n) + (loop (fx1+ i)))))))))))]))) + +;; Convert a prefab key to normalized, compact from +(define (normalize-prefab-key k keep-count?) + (cond + [(symbol? k) k] + [else + (let* ([name (car k)] + [k (cdr k)] + [count (if (and (pair? k) + (exact-nonnegative-integer? (car k))) + (car k) + #f)] + [k (if count + (cdr k) + k)] + [auto (if (and (pair? k) + (pair? (car k))) + (car k) + #f)] + [k (if auto + (cdr k) + k)] + [mutables (if (and (pair? k) + (vector? (car k))) + (car k) + #f)] + [k (if mutables + (cdr k) + k)] + [norm-auto (cond + [(not auto) #f] + [(eq? 0 (car auto)) #f] + [else auto])] + [norm-mutables (cond + [(not mutables) #f] + [(zero? (vector-length mutables)) #f] + [else + (vector->immutable-vector + (chez:vector-sort (lambda (a b) + ;; Double-check exact integers, just in case + ;; a mutation happens; we'll have tou double-check + ;; that the result is still a prefab + (if (and (exact-nonnegative-integer? a) + (exact-nonnegative-integer? b)) + (< a b) + #f)) + mutables))])] + [r (if (null? k) + '() + (normalize-prefab-key k #t))] + [r (if norm-mutables + (cons norm-mutables + r) + r)] + [r (if norm-auto + (cons norm-auto r) + r)]) + (if keep-count? + (cons name (cons count r)) + (if (null? r) + name + (cons name r))))])) + +(define (normalized-prefab-key/check who key field-count) + (check who prefab-key? key) + (unless (prefab-key-compatible-count? key field-count) + (raise-arguments-error who + "mismatch between prefab key and field count" + "prefab key" key + "field count" field-count)) + (let ([norm-key (normalize-prefab-key key #f)]) + (unless (and (prefab-key? norm-key) + (prefab-key-compatible-count? norm-key field-count)) + (raise-arguments-error who + "prefab key mutated after initial check" + "prefab key" key)) + norm-key)) + +(define (prefab-key+size->prefab-key-tail key+size) + (let ([key (car key+size)]) + (cond + [(symbol? key) + (list key (cdr key+size))] + [else + (cons* (car key) + (- (cdr key+size) + (prefab-key-count-explicit-fields key)) + (cdr key))]))) + +(define (prefab-key-count-explicit-fields key) + ;; Count fields other than initial non-auto: + (let loop ([k (cdr key)]) + (let* ([count (and (pair? k) + (exact-integer? (car k)) + (car k))] + [k (if count + (cdr k) + k)] + [mutable (and (pair? k) + (pair? (car k)) + (car k))] + [k (if mutable + (cdr k) + k)] + [k (if (and (pair? k) + (vector? (car k))) + (cdr k) + k)]) + (+ (or count 0) + (if mutable (car mutable) 0) + (cond + [(null? k) 0] + [else (loop (cdr k))]))))) + +(define (prefab-key->parent-prefab-key+count key) + (cond + [(symbol? key) #f] + [else + (let* ([k (cdr key)] ; skip name; non-auto count will no be present + [k (if (and (pair? k) + (pair? (car k))) + (cdr k) + k)] + [k (if (and (pair? k) + (vector? (car k))) + (cdr k) + k)]) + (if (null? k) + #f + ;; Normalize parent by dropping auto field count out: + (let* ([name (car k)] + [count (cadr k)] + [rest-k (cddr k)] + [total-count (prefab-key-count-explicit-fields k)]) + (cond + [(null? rest-k) + (cons name total-count)] + [else + (cons (cons name rest-k) total-count)]))))])) + +(define (derive-prefab-key name parent-key+size fields-count immutables auto-fields auto-val) + (let* ([l (if parent-key+size + (prefab-key+size->prefab-key-tail parent-key+size) + '())] + [l (let ([mutables (immutables->mutables immutables fields-count)]) + (if (fx= 0 (#%vector-length mutables)) + l + (cons mutables l)))] + [l (if (zero? auto-fields) + l + (cons (list auto-fields auto-val) + l))]) + (if (null? l) + name + (cons name l)))) + +(define (prefab-key-mutables prefab-key) + (if (pair? prefab-key) + (if (vector? (cadr prefab-key)) + (cadr prefab-key) + (if (and (pair? (cddr prefab-key)) + (vector? (caddr prefab-key))) + (caddr prefab-key) + '#())) + '#())) + +(define (encode-prefab-key+count-as-symbol prefab-key+count) + (string->symbol (chez:format "~a" prefab-key+count))) + +(define (immutables->mutables immutables init-count) + (vector->immutable-vector + (list->vector + (let loop ([i 0]) + (cond + [(= i init-count) null] + [(chez:member i immutables) (loop (add1 i))] + [else (cons i (loop (add1 i)))]))))) + +(define (mutables->immutables mutables init-count) + (let loop ([i 0]) + (cond + [(fx= i init-count) '()] + [else + (let jloop ([j (vector-length mutables)]) + (cond + [(fx= j 0) (cons i (loop (fx1+ i)))] + [else + (let ([j (fx1- j)]) + (if (eqv? i (vector-ref mutables j)) + (loop (fx1+ i)) + (jloop j)))]))]))) diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss new file mode 100644 index 0000000000..9964a4bdf7 --- /dev/null +++ b/racket/src/cs/rumble/procedure.ss @@ -0,0 +1,755 @@ +(define-values (prop:method-arity-error method-arity-error? method-arity-error-ref) + (make-struct-type-property 'method-arity-error)) + +(define-values (prop:arity-string arity-string? arity-string-ref) + (make-struct-type-property 'arity-string)) + +(define-values (prop:procedure procedure-struct? procedure-struct-ref) + (make-struct-type-property 'procedure (lambda (v info) + ;; We don't have to check whether `v` is valid here, + ;; because `make-struct-type` handles `prop:procedure` + ;; directly; we just convert a relative position to + ;; an absolute one + (if (exact-integer? v) + (+ v (let ([p (list-ref info 6)]) + (if p + (struct-type-total*-field-count p) + 0))) + v)))) + +(define-values (prop:incomplete-arity incomplete-arity? incomplete-arity-ref) + (make-struct-type-property 'incomplete-arity)) + +;; Integer value is a field to use; boxed value is a field that provides a mask +(define-values (prop:procedure-arity procedure-arity-prop? procedure-arity-ref) + (make-struct-type-property 'procedure-arity)) + +(define (procedure? v) + (or (chez:procedure? v) + (and (record? v) + (not (eq? (struct-property-ref prop:procedure (record-rtd v) none) none))))) + +(define/who (procedure-specialize proc) + (check who procedure? proc) + proc) + +(define apply + (case-lambda + [(proc args) + (if (chez:procedure? proc) + (chez:apply proc args) + (chez:apply (extract-procedure proc (length args)) args))] + [(proc) + (raise-arity-error 'apply (|#%app| arity-at-least 2) proc)] + [(proc . argss) + (if (chez:procedure? proc) + (chez:apply chez:apply proc argss) + (let ([len (let loop ([argss argss]) + (cond + [(null? (cdr argss)) (length (car argss))] + [else (fx+ 1 (loop (cdr argss)))]))]) + (chez:apply chez:apply (extract-procedure proc len) argss)))])) + +;; See copy in "expander.sls" +(define-syntax (|#%app| stx) + (syntax-case stx () + [(_ rator rand ...) + (with-syntax ([n-args (length #'(rand ...))]) + #'((extract-procedure rator n-args) rand ...))])) + +(define (|#%call-with-values| generator receiver) + (call-with-values (if (chez:procedure? generator) + generator + (lambda () (|#%app| generator))) + (if (chez:procedure? receiver) + receiver + (lambda args (apply receiver args))))) + +(define (extract-procedure f n-args) + (cond + [(chez:procedure? f) f] + [else (or (try-extract-procedure/check-arity f n-args) + (not-a-procedure f))])) + +;; returns #f or a host-Scheme procedure, and checks arity so that +;; checking and reporting use the right top-level function +(define (try-extract-procedure/check-arity f n-args) + (let ([v (try-extract-procedure f)]) + (cond + [(not v) #f] + [(procedure-arity-includes? f n-args) v] + [else (wrong-arity-wrapper f)]))) + +(define (try-extract-procedure f) + (cond + [(chez:procedure? f) f] + [(record? f) + (let ([v (struct-property-ref prop:procedure (record-rtd f) none)]) + (cond + [(eq? v none) #f] + [(fixnum? v) + (try-extract-procedure (unsafe-struct-ref f v))] + [(eq? v 'unsafe) + (try-extract-procedure + (if (chaperone? f) + (unsafe-procedure-chaperone-replace-proc f) + (unsafe-procedure-impersonator-replace-proc f)))] + [else + (let ([v (try-extract-procedure v)]) + (cond + [(not v) (case-lambda)] + [else + (case-lambda + [() (v f)] + [(a) (v f a)] + [(a b) (v f a b)] + [(a b c) (v f a b c)] + [args (chez:apply v f args)])]))]))] + [else #f])) + +(define (extract-procedure-name f) + (cond + [(and (reduced-arity-procedure? f) + (reduced-arity-procedure-name f)) + => (lambda (name) name)] + [(record? f) + (let* ([v (struct-property-ref prop:procedure (record-rtd f) #f)]) + (cond + [(fixnum? v) + (let ([v (unsafe-struct-ref f v)]) + (cond + [(procedure? v) (object-name v)] + [else (struct-object-name f)]))] + [else (struct-object-name f)]))] + [else #f])) + +(define/who procedure-arity-includes? + (case-lambda + [(f n incomplete-ok?) + (let ([mask (get-procedure-arity-mask who f incomplete-ok?)]) + (check who exact-nonnegative-integer? n) + (bitwise-bit-set? mask n))] + [(f n) (procedure-arity-includes? f n #f)])) + +(define (chez:procedure-arity-includes? proc n) + (bitwise-bit-set? (#%procedure-arity-mask proc) n)) + +(define (procedure-arity orig-f) + (mask->arity (get-procedure-arity-mask 'procedure-arity orig-f #t))) + +(define/who (procedure-arity-mask orig-f) + (get-procedure-arity-mask who orig-f #t)) + +(define (get-procedure-arity-mask who orig-f incomplete-ok?) + (cond + [(chez:procedure? orig-f) + (#%procedure-arity-mask orig-f)] + [else + (let proc-arity-mask ([f orig-f] [shift 0]) + (cond + [(chez:procedure? f) + (bitwise-arithmetic-shift-right (#%procedure-arity-mask f) shift)] + [(record? f) + (cond + [(and (not incomplete-ok?) + (incomplete-arity? f)) + 0] + [else + (let* ([rtd (record-rtd f)] + [a (struct-property-ref prop:procedure-arity rtd #f)]) + (cond + [a + (if (exact-integer? a) + (proc-arity-mask (unsafe-struct*-ref f a) shift) + (bitwise-arithmetic-shift-right (unsafe-struct*-ref f (unbox a)) shift))] + [else + (let ([v (struct-property-ref prop:procedure rtd #f)]) + (cond + [(fixnum? v) + (proc-arity-mask (unsafe-struct-ref f v) shift)] + [else + (proc-arity-mask v (add1 shift))]))]))])] + [(eq? f orig-f) + (raise-argument-error who "procedure?" orig-f)] + [else 0]))])) + +;; Public, limited variant: +(define/who (procedure-extract-target f) + (cond + [(record? f) + (let* ([rtd (record-rtd f)] + [v (struct-property-ref prop:procedure rtd #f)]) + (cond + [(fixnum? v) + (let ([v (unsafe-struct-ref f v)]) + (and (chez:procedure? v) v))] + [else + (check who procedure? f) + #f]))] + [else + (check who procedure? f) + #f])) + +(define (not-a-procedure f) + (raise-arguments-error 'application + "not a procedure;\n expected a procedure that can be applied to arguments" + "given" f)) + +(define (wrong-arity-wrapper f) + (lambda args + (cond + [(procedure-is-method? f) + (chez:apply raise-arity-error + f + (let ([m (procedure-arity-mask f)]) + (if (not (bitwise-bit-set? m 0)) + (mask->arity (bitwise-arithmetic-shift-right m 1)) + (mask->arity m))) + (cdr args))] + [else + (chez:apply raise-arity-error f (procedure-arity f) args)]))) + +(define/who (procedure-result-arity p) + (check who procedure? p) + #f) + +;; ---------------------------------------- + +(define-record method-procedure (proc)) + +(define/who (procedure->method proc) + (check who procedure? proc) + (if (procedure-is-method? proc) + proc + (make-method-procedure proc))) + +(define (procedure-is-method? f) + (cond + [(chez:procedure? f) #f] + [(record? f) + (or (method-arity-error? f) + (let ([v (struct-property-ref prop:procedure (record-rtd f) #f)]) + (cond + [(fixnum? v) + (procedure-is-method? (unsafe-struct-ref f v))] + [(eq? v 'unsafe) + (procedure-is-method? (impersonator-val f))] + [else (procedure-is-method? v)])))] + [else #f])) + +;; ---------------------------------------- + +(define-record reduced-arity-procedure (proc mask name)) + +(define/who (procedure-reduce-arity proc a) + (check who procedure? proc) + (let ([mask (arity->mask a)]) + (unless mask + (raise-arguments-error who "procedure-arity?" a)) + (unless (= mask (bitwise-and mask (procedure-arity-mask proc))) + (raise-arguments-error who + "arity of procedure does not include requested arity" + "procedure" proc + "requested arity" a)) + (make-reduced-arity-procedure + (lambda args + (unless (bitwise-bit-set? mask (length args)) + (apply raise-arity-error + (or (object-name proc) 'procedure) + (mask->arity mask) + args)) + (apply proc args)) + mask + (object-name proc)))) + +;; ---------------------------------------- + +(define-record named-procedure (proc name)) + +(define/who (procedure-rename proc name) + (cond + [(reduced-arity-procedure? proc) + ;; Avoid an extra wrapper layer, and also work before + ;; `procedure?` is fully filled in + (check who symbol? name) + (make-reduced-arity-procedure + (reduced-arity-procedure-proc proc) + (reduced-arity-procedure-mask proc) + name)] + [else + (check who procedure? proc) + (check who symbol? name) + (make-named-procedure proc name)])) + +(define (procedure-maybe-rename proc name) + (if name + (procedure-rename proc name) + proc)) + +;; ---------------------------------------- + +(define (make-jit-procedure force mask name) + (letrec ([p (make-arity-wrapper-procedure + (lambda args + (let ([f (force)]) + (with-interrupts-disabled + ;; atomic with respect to Racket threads, + (let ([name (arity-wrapper-procedure-data p)]) + (unless (#%box? name) + (set-arity-wrapper-procedure! p f) + (set-arity-wrapper-procedure-data! p (box name))))) + (apply p args))) + mask + name)]) + p)) + +(define (extract-jit-procedure-name p) + (let ([name (arity-wrapper-procedure-data p)]) + (if (#%box? name) + (#%unbox name) + name))) + +;; ---------------------------------------- + +(define-record procedure-impersonator impersonator (wrapper)) +(define-record procedure-chaperone chaperone (wrapper)) + +(define-record procedure*-impersonator procedure-impersonator ()) +(define-record procedure*-chaperone procedure-chaperone ()) + +(define-values (impersonator-prop:application-mark application-mark? application-mark-ref) + (make-impersonator-property 'application-mark)) + +(define/who (impersonate-procedure proc wrapper . props) + (do-impersonate-procedure who make-procedure-impersonator proc wrapper + make-props-procedure-impersonator props + values "")) + +(define/who (chaperone-procedure proc wrapper . props) + (do-impersonate-procedure who make-procedure-chaperone proc wrapper + make-props-procedure-chaperone props + values "")) + +(define/who (impersonate-procedure* proc wrapper . props) + (do-impersonate-procedure who make-procedure*-impersonator proc wrapper + make-props-procedure-impersonator props + (lambda (n) (bitwise-arithmetic-shift-right n 1)) " (adding an extra argument)")) + +(define/who (chaperone-procedure* proc wrapper . props) + (do-impersonate-procedure who make-procedure*-chaperone proc wrapper + make-props-procedure-chaperone props + (lambda (n) (bitwise-arithmetic-shift-right n 1)) " (adding an extra argument)")) + +(define (do-impersonate-procedure who make-procedure-impersonator proc wrapper + make-props-procedure-impersonator props + arity-shift arity-shift-str) + (check who procedure? proc) + (when wrapper + (check who procedure? wrapper) + (let ([m (procedure-arity-mask proc)]) + (unless (= m (bitwise-and m (arity-shift (procedure-arity-mask wrapper)))) + (raise-arguments-error who + (string-append + "arity of wrapper procedure does not cover arity of original procedure" + arity-shift-str) + "wrapper" wrapper + "original" proc)))) + (let ([val (if (impersonator? proc) + (impersonator-val proc) + proc)] + [props (add-impersonator-properties who + props + (if (impersonator? proc) + (impersonator-props proc) + empty-hasheq))]) + (if wrapper + (make-procedure-impersonator val proc props wrapper) + (make-props-procedure-impersonator val proc props)))) + +(define (procedure-impersonator*? v) + (or (procedure*-impersonator? v) + (procedure*-chaperone? v) + (and (impersonator? v) + (procedure-impersonator*? (impersonator-next v))))) + +(define (call-with-application-mark props k) + (let ([mark (intmap-ref props impersonator-prop:application-mark #f)]) + (cond + [(pair? mark) + (call-with-immediate-continuation-mark + (car mark) + (lambda (v) + (if (eq? v none) + (k mark #f #f) + (k mark #t v))) + none)] + [else + (k #f #f #f)]))) + +(define (impersonate-apply proc . args) + (impersonate-apply/parameter proc #t args)) + +;; If `actually-call?` is #f, then don't call the procedure in `proc`, +;; because we're trying to get an inpersonated-parameter value +(define (impersonate-apply/parameter proc actually-call? args) + (let ([n (length args)]) + (cond + [(not (procedure-arity-includes? (impersonator-val proc) n)) + ;; Let primitive application complain: + (|#%app| (impersonator-val proc) args)] + [else + ;; Loop through wrappers so that `{chaperone,impersonate}-procedure*` + ;; wrappers can receive the original `proc` argument + (let loop ([p proc] [args args]) + (cond + [(or (procedure-impersonator? p) + (procedure-chaperone? p)) + ;; Check for `impersonator-prop:application-mark`, since we'll need + ;; to grab any immediately available mark in that case + (call-with-application-mark + (impersonator-props p) + ;; The `mark-pair` argument is the `impersonator-prop:application-mark` value, + ;; and `has-current-mark?` indincates whether `current-mark-val` is the value + ;; of that mark on the current continuation frame + (lambda (mark-pair has-current-mark? current-mark-val) + (let* ([chaperone? (procedure-chaperone? p)] + [wrapper (if chaperone? + (procedure-chaperone-wrapper p) + (procedure-impersonator-wrapper p))] + [next-p (impersonator-next p)] + [new-args + ;; Call the wrapper procedure, propagating the current value + ;; (if any) of the `impersonator-prop:application-mark`-specified mark + (call-with-values + (lambda () + (let ([call + (lambda () + ;; Calling convention is different for `procedure*` + ;; and non-`procedure*` variants: + (if (if chaperone? + (procedure*-chaperone? p) + (procedure*-impersonator? p)) + (apply wrapper proc args) + (apply wrapper args)))]) + ;; Set mark, if any, while calling: + (cond + [has-current-mark? + (with-continuation-mark (car mark-pair) current-mark-val (call))] + [else (call)]))) + list)] + [nn (length new-args)] + [check + (lambda (who args new-args) + (when chaperone? + (for-each (lambda (e e2) + (unless (chaperone-of? e2 e) + (raise-chaperone-error who "argument" e e2))) + args + new-args)))] + [continue + ;; To continue iterating through wrappers: + (lambda (new-args) + (if mark-pair + (with-continuation-mark (car mark-pair) (cdr mark-pair) + (loop next-p new-args)) + (loop next-p new-args)))]) + ;; Loop to check for extra post proc or `'mark ` + (let loop ([nn nn] [new-args new-args] [post-proc #f] [pos 0]) + (cond + [(fx= n nn) + ;; No more extra results, so `new-args` should match up with `args`: + (check '|procedure chaperone| args new-args) + (cond + [post-proc + (call-with-values + (lambda () (continue new-args)) + (lambda results + (let ([new-results (call-with-values (lambda () (apply post-proc results)) list)]) + (unless (= (length results) (length new-results)) + (raise-result-wrapper-result-arity-error)) + (check '|procedure-result chaperone| results new-results) + (#%apply values new-results))))] + [else + (continue new-args)])] + [(and (fx> nn n) + (not post-proc) + (procedure? (car new-args))) + ;; Extra procedure result => wrapper to apply to function results + (loop (fx1- nn) (cdr new-args) (car new-args) (fx1+ pos))] + [(and (fx> nn n) + (eq? 'mark (car new-args))) + ;; 'mark => wrap call with a continuation mark + (unless (fx>= (fx- nn 3) n) + (raise-mark-missing-key-or-val-error chaperone? pos next-p wrapper)) + (with-continuation-mark (cadr new-args) (caddr new-args) + (loop (fx- nn 3) (cdddr new-args) post-proc (fx+ pos 3)))] + [(fx> nn n) + (raise-wrapper-bad-extra-result-error chaperone? pos (car new-args) next-p wrapper)] + [else + (raise-wrapper-result-arity-error chaperone? proc wrapper n nn)])))))] + [(unsafe-procedure-impersonator? p) + (apply p args)] + [(unsafe-procedure-chaperone? p) + (apply p args)] + [(impersonator? p) + (loop (impersonator-next p) args)] + [(not actually-call?) + (apply values args)] + [else + ;; If `p` is a structure whose `prop:procedure` value is an + ;; integer `i`, then we should extract the field at position + ;; `i` from `proc`, not from `p`, so that any interpositions + ;; on that access are performed. + (let ([v (and (record? p) + (struct-property-ref prop:procedure (record-rtd p) #f))]) + (cond + [(integer? v) + (apply (unsafe-struct-ref proc v) args)] + [else + (apply p args)]))]))]))) + +(define (set-procedure-impersonator-hash!) + (record-type-hash-procedure (record-type-descriptor procedure-chaperone) + (lambda (c hash-code) + (hash-code (impersonator-next c)))) + (record-type-hash-procedure (record-type-descriptor procedure-impersonator) + (lambda (i hash-code) + (hash-code (impersonator-next i))))) + +(define (raise-result-wrapper-result-arity-error) + (raise + (|#%app| + exn:fail:contract:arity + (string-append "procedure-result chaperone: result arity mismatch;\n" + " expected number of values not received from wrapper on the original procedure's result") + (current-continuation-marks)))) + +(define (raise-mark-missing-key-or-val-error chaperone? pos next-p wrapper) + (raise-arguments-error (if chaperone? + '|procedure chaperone| + '|procedure impersonator|) + (string-append + "wrapper's " (nth-str pos) " result needs addition extra results;\n" + " " (nth-str pos) " extra result (before original argument count) needs an additional\n" + " two results after 'mark") + "original" next-p + "wrapper" wrapper)) + +(define (raise-wrapper-bad-extra-result-error chaperone? pos v next-p wrapper) + (raise-arguments-error (if chaperone? + '|procedure chaperone| + '|procedure impersonator|) + (string-append + "wrapper's " (nth-str pos) " result is not valid;\n" + " " (nth-str pos) " extra result (before original argument count) should be\n" + " 'mark" (if (zero? pos) + " or a wrapper for the original procedure's result" + "")) + "original" next-p + "wrapper" wrapper + "received" v)) + +(define (raise-wrapper-result-arity-error chaperone? proc wrapper expected-n got-n) + (raise + (|#%app| + exn:fail:contract:arity + (string-append + (if chaperone? + "procedure chaperone" + "procedure impersonator") + ": arity mismatch;\n" + " expected number of results not received from wrapper on the original\n" + " procedure's arguments\n" + " original: " (error-value->string proc) + "\n" + " wrapper: " (error-value->string wrapper) + "\n" + " expected: " (number->string expected-n) " or more\n" + " received: " (number->string got-n)) + (current-continuation-marks)))) + +;; ---------------------------------------- + +(define-record unsafe-procedure-impersonator impersonator (replace-proc)) +(define-record unsafe-procedure-chaperone chaperone (replace-proc)) + +(define/who (unsafe-impersonate-procedure proc replace-proc . props) + (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator + proc replace-proc props)) + +(define/who (unsafe-chaperone-procedure proc replace-proc . props) + (do-unsafe-impersonate-procedure who make-unsafe-procedure-chaperone + proc replace-proc props)) + +(define (do-unsafe-impersonate-procedure who make-unsafe-procedure-impersonator proc replace-proc props) + (let ([m (procedure-arity-mask proc)]) + (unless (= m (bitwise-and m (procedure-arity-mask replace-proc))) + (raise-arguments-error who + "arity of replacement procedure does not cover arity of original procedure" + "replacement" replace-proc + "original" proc)) + (make-unsafe-procedure-impersonator + (strip-impersonator proc) + proc + (add-impersonator-properties who + props + (if (impersonator? proc) + (impersonator-props proc) + empty-hasheq)) + replace-proc))) + +;; ---------------------------------------- + +(define/who (procedure-closure-contents-eq? p1 p2) + (check who procedure? p1) + (check who procedure? p2) + (when (and (#%procedure? p1) + (#%procedure? p2)) + (let* ([i1 (inspect/object p1)] + [i2 (inspect/object p2)] + [l1 (i2 'length)] + [l2 (i2 'length)]) + (and (eq? ((i1 'code) 'value) + ((i2 'code) 'value)) + (= l1 l2) + (let loop ([i 0]) + (or (fx= i l1) + (and (eq? (((i1 'ref i) 'ref) 'value) (((i2 'ref i) 'ref) 'value)) + (loop (fx1+ i))))))))) + +;; ---------------------------------------- + +(define-values (prop:checked-procedure checked-procedure? checked-procedure-ref) + (make-struct-type-property 'checked-procedure + (lambda (v s) + (unless (not (list-ref s 6)) + (raise-arguments-error 'prop:checked-procedure + "not allowed on a structure type with a supertype")) + (unless (>= (+ (list-ref s 1) (list-ref s 2)) 2) + (raise-arguments-error 'prop:checked-procedure + "need at least two fields in the structure type")) + #t))) + +(define/who (checked-procedure-check-and-extract st v alt-proc v1 v2) + (check who record-type-descriptor? + :contract "(and/c struct-type? (not/c impersonator?))" + st) + (if (and (checked-procedure? v) + (record? v st) + (|#%app| (unsafe-struct*-ref v 0) v1 v2)) + (unsafe-struct*-ref v 1) + (|#%app| alt-proc v v1 v2))) + +;; ---------------------------------------- + +(define (primitive? v) + (or (eq? v make-struct-type-property) + (eq? v make-struct-type))) + +(define (primitive-closure? v) #f) + +(define (primitive-result-arity prim) + (cond + [(eq? prim make-struct-type-property) 3] + [(eq? prim make-struct-type) 5] + [else + (raise-argument-error 'primitive-result-arity "primitive?" prim)])) + +;; ---------------------------------------- + +(define (set-primitive-applicables!) + (struct-property-set! prop:procedure + (record-type-descriptor parameter) + 0) + (struct-property-set! prop:procedure + (record-type-descriptor derived-parameter) + 0) + + (struct-property-set! prop:procedure + (record-type-descriptor position-based-accessor) + (lambda (pba s p) + (cond + [(and (record? s (position-based-accessor-rtd pba)) + (fixnum? p) + (fx>= p 0) + (fx< p (position-based-accessor-field-count pba))) + (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))] + [(and (impersonator? s) + (record? (impersonator-val s) (position-based-accessor-rtd pba)) + (fixnum? p) + (fx>= p 0) + (fx< p (position-based-accessor-field-count pba))) + (impersonate-ref (lambda (s) + (unsafe-struct*-ref s (+ p (position-based-accessor-offset pba)))) + (position-based-accessor-rtd pba) + p + s)] + [else (error 'struct-ref "bad access")]))) + + (struct-property-set! prop:procedure + (record-type-descriptor position-based-mutator) + (lambda (pbm s p v) + (cond + [(and (record? s (position-based-mutator-rtd pbm)) + (fixnum? p) + (fx>= p 0) + (< p (position-based-mutator-field-count pbm))) + (unsafe-struct-set! s (+ p (position-based-mutator-offset pbm)) v)] + [(and (impersonator? s) + (record? (impersonator-val s) (position-based-mutator-rtd pbm)) + (fixnum? p) + (fx>= p 0) + (< p (position-based-mutator-field-count pbm))) + (let ([abs-pos (+ p (position-based-mutator-offset pbm))]) + (impersonate-set! (lambda (s v) + (unsafe-struct-set! s abs-pos v)) + (position-based-mutator-rtd pbm) + p + abs-pos + s + v))] + [else + (error 'struct-set! "bad assignment")]))) + + (struct-property-set! prop:procedure + (record-type-descriptor named-procedure) + 0) + (struct-property-set! prop:object-name + (record-type-descriptor named-procedure) + 1) + + (struct-property-set! prop:procedure + (record-type-descriptor reduced-arity-procedure) + 0) + (struct-property-set! prop:procedure-arity + (record-type-descriptor reduced-arity-procedure) + (box 1)) + (struct-property-set! prop:object-name + (record-type-descriptor reduced-arity-procedure) + 2) + + (struct-property-set! prop:procedure + (record-type-descriptor method-procedure) + 0) + (struct-property-set! prop:method-arity-error + (record-type-descriptor method-procedure) + #t) + + (let ([register-procedure-impersonator-struct-type! + (lambda (rtd) + (struct-property-set! prop:procedure rtd impersonate-apply) + (struct-property-set! prop:procedure-arity rtd 0))]) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-chaperone)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-impersonator)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-chaperone)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure*-impersonator)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-chaperone)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-impersonator)) + (register-procedure-impersonator-struct-type! (record-type-descriptor procedure-struct-undefined-chaperone))) + + (let ([register-unsafe-procedure-impersonator-struct-type! + (lambda (rtd) + (struct-property-set! prop:procedure rtd 'unsafe) + (struct-property-set! prop:procedure-arity rtd 0))]) + (register-unsafe-procedure-impersonator-struct-type! (record-type-descriptor unsafe-procedure-impersonator)) + (register-unsafe-procedure-impersonator-struct-type! (record-type-descriptor unsafe-procedure-chaperone)))) diff --git a/racket/src/cs/rumble/pthread.ss b/racket/src/cs/rumble/pthread.ss new file mode 100644 index 0000000000..3cb5661ca5 --- /dev/null +++ b/racket/src/cs/rumble/pthread.ss @@ -0,0 +1,33 @@ +(meta-cond + [(threaded?) + (define make-pthread-parameter make-thread-parameter) + (define (fork-pthread thunk) + (fork-thread (lambda () + (init-virtual-registers) + (thunk)))) + (define pthread? thread?) + ;; make-condition + ;; condition-wait + ;; condition-signal + ;; condition-broadcast + ;; make-mutex + ;; mutex-acquire + ;; mutex-release + ] + [else + (define make-pthread-parameter #%make-parameter) + (define (fork-pthread) (void)) + (define (pthread?) #f) + (define (make-condition) (void)) + (define (condition-wait c m) (void)) + (define (condition-signal c) (void)) + (define (condition-broadcast c) (void)) + (define (make-mutex) (void)) + (define mutex-acquire + (case-lambda + [(m block?) (void)] + [(m) (void)])) + (define (mutex-release m) (void)) + ]) + +(define (active-pthreads) #%$active-threads) diff --git a/racket/src/cs/rumble/random.ss b/racket/src/cs/rumble/random.ss new file mode 100644 index 0000000000..e938b0ef56 --- /dev/null +++ b/racket/src/cs/rumble/random.ss @@ -0,0 +1,275 @@ +;; /* +;; Based on +;; +;; Implementation of SRFI-27 core generator in C for Racket. +;; dvanhorn@cs.uvm.edu +;; +;; and +;; +;; 54-BIT (double) IMPLEMENTATION IN C OF THE "MRG32K3A" GENERATOR +;; =============================================================== +;; +;; Sebastian.Egner@philips.com, Mar-2002, in ANSI-C and Scheme 48 0.57 +;; +;; This code is a C-implementation of Pierre L'Ecuyer's MRG32k3a generator. +;; The code uses (double)-arithmetics, assuming that it covers the range +;; {-2^53..2^53-1} exactly (!). The code of the generator is based on the +;; L'Ecuyer's own implementation of the generator. Please refer to the +;; file 'mrg32k3a.scm' for more information about the method. +;; */ + +;; The Generator +;; ============= + +;; moduli of the components +(define Im1 #xffffff2f) +(define Im2 #xffffa6bb) +(define m1 4294967087.0) +(define m2 4294944443.0) + +;; recursion coefficients of the components +(define a12 1403580.0) +(define a13n 810728.0) +(define a21 527612.0) +(define a23n 1370589.0) + +;; normalization factor 1/(m1 + 1) +(define norm 2.328306549295728e-10) + +;; the actual generator + +(define-record-type (pseudo-random-generator new-pseudo-random-generator pseudo-random-generator?) + (fields (mutable x10) (mutable x11) (mutable x12) (mutable x20) (mutable x21) (mutable x22)) + (nongenerative)) + +(define (mrg32k3a s) ;; -> flonum in {0..m1-1} + ;; component 1 + (let* ([x10 (fl- (fl* a12 (pseudo-random-generator-x11 s)) + (fl* a13n (pseudo-random-generator-x12 s)))] + [k10 (fltruncate (fl/ x10 m1))] + [x10 (fl- x10 (fl* k10 m1))] + [x10 (if (fl< x10 0.0) + (fl+ x10 m1) + x10)]) + (pseudo-random-generator-x12-set! s (pseudo-random-generator-x11 s)) + (pseudo-random-generator-x11-set! s (pseudo-random-generator-x10 s)) + (pseudo-random-generator-x10-set! s x10) + + ;; component 2 + (let* ([x20 (fl- (fl* a21 (pseudo-random-generator-x20 s)) + (fl* a23n (pseudo-random-generator-x22 s)))] + [k20 (fltruncate (fl/ x20 m2))] + [x20 (fl- x20 (fl* k20 m2))] + [x20 (if (fl< x20 0.0) + (fl+ x20 m2) + x20)]) + (pseudo-random-generator-x22-set! s (pseudo-random-generator-x21 s)) + (pseudo-random-generator-x21-set! s (pseudo-random-generator-x20 s)) + (pseudo-random-generator-x20-set! s x20) + + ;; combination of components + (let* ([y (fl- x10 x20)]) + (if (fl< y 0.0) + (fl+ y m1) + y))))) + +(define (make-pseudo-random-generator) + (let ([s (new-pseudo-random-generator 1.0 1.0 1.0 1.0 1.0 1.0)]) + (pseudo-random-generator-seed! s (current-milliseconds)) + s)) + +(define (pseudo-random-generator-seed! s x) + ;; Initial values are from Sebastian Egner's implementation: + (pseudo-random-generator-x10-set! s 1062452522.0) + (pseudo-random-generator-x11-set! s 2961816100.0) + (pseudo-random-generator-x12-set! s 342112271.0) + (pseudo-random-generator-x20-set! s 2854655037.0) + (pseudo-random-generator-x21-set! s 3321940838.0) + (pseudo-random-generator-x22-set! s 3542344109.0) + (srand-half! s (bitwise-and x #xFFFF)) + (srand-half! s (bitwise-and (bitwise-arithmetic-shift-right x 16) #xFFFF))) + +(define (srand-half! s x) + (let* ([x (random-n! x + (- Im1 1) + (lambda (z) + (pseudo-random-generator-x10-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x10 s)) + z) + (- Im1 1)))))))] + [x (random-n! x + Im1 + (lambda (z) + (pseudo-random-generator-x11-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x11 s)) + z) + Im1))))))] + [x (random-n! x + Im1 + (lambda (z) + (pseudo-random-generator-x12-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x12 s)) + z) + Im1))))))] + [x (random-n! x + (- Im2 1) + (lambda (z) + (pseudo-random-generator-x20-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x20 s)) + z) + (- Im2 1)))))))] + [x (random-n! x + Im2 + (lambda (z) + (pseudo-random-generator-x21-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x21 s)) + z) + Im2))))))] + [x (random-n! x + Im2 + (lambda (z) + (pseudo-random-generator-x22-set! + s + (exact->inexact + (+ 1 (modulo + (+ (inexact->exact (pseudo-random-generator-x22 s)) + z) + Im2))))))]) + (void))) + +(define (random-n! x Im k) + (let* ([y1 (bitwise-and x #xFFFF)] + [x (+ (* 30903 y1) (bitwise-arithmetic-shift-right x 16))] + [y2 (bitwise-and x #xFFFF)] + [x (+ (* 30903 y2) (bitwise-arithmetic-shift-right x 16))]) + (k (modulo (+ (arithmetic-shift y1 16) y2) Im)) + x)) + +(define/who (pseudo-random-generator->vector s) + (check who pseudo-random-generator? s) + (vector (inexact->exact (pseudo-random-generator-x10 s)) + (inexact->exact (pseudo-random-generator-x11 s)) + (inexact->exact (pseudo-random-generator-x12 s)) + (inexact->exact (pseudo-random-generator-x20 s)) + (inexact->exact (pseudo-random-generator-x21 s)) + (inexact->exact (pseudo-random-generator-x22 s)))) + +(define (pseudo-random-generator-vector? v) + (let ([in-range? + (lambda (i mx) + (let ([x (vector-ref v i)]) + (and (exact-nonnegative-integer? x) + (<= x mx))))] + [nonzero? + (lambda (i) + (not (zero? (vector-ref v i))))]) + (and (vector? v) + (= 6 (vector-length v)) + (in-range? 0 4294967086) + (in-range? 1 4294967086) + (in-range? 2 4294967086) + (in-range? 3 4294944442) + (in-range? 4 4294944442) + (in-range? 5 4294944442) + (or (nonzero? 0) (nonzero? 1) (nonzero? 2)) + (or (nonzero? 3) (nonzero? 4) (nonzero? 5))))) + +(define/who (vector->pseudo-random-generator orig-v) + (let ([iv (and (vector? orig-v) + (= 6 (vector-length orig-v)) + (vector->immutable-vector orig-v))]) + (check who pseudo-random-generator-vector? iv) + (let ([r (lambda (i) (exact->inexact (vector-ref iv i)))]) + (new-pseudo-random-generator (r 0) + (r 1) + (r 2) + (r 3) + (r 4) + (r 5))))) + +(define/who (vector->pseudo-random-generator! s orig-v) + (check who pseudo-random-generator? s) + (let ([iv (and (vector? orig-v) + (= 6 (vector-length orig-v)) + (vector->immutable-vector orig-v))]) + (unless (pseudo-random-generator-vector? iv) + (raise-argument-error 'vector->pseudo-random-generator! "pseudo-random-generator-vector?" orig-v)) + (let ([r (lambda (i) (exact->inexact (vector-ref iv i)))]) + (pseudo-random-generator-x10-set! s (r 0)) + (pseudo-random-generator-x11-set! s (r 1)) + (pseudo-random-generator-x12-set! s (r 2)) + (pseudo-random-generator-x20-set! s (r 3)) + (pseudo-random-generator-x21-set! s (r 4)) + (pseudo-random-generator-x22-set! s (r 5))))) + +(define (pseudo-random-generator-integer! s n) + ;; generate result in {0..n-1} using the rejection method + (let* ([n (exact->inexact n)] + [q (fltruncate (fl/ m1 n))] + [qn (fl* q n)] + [x (let loop () + (let ([x (mrg32k3a s)]) + (if (fl>= x qn) + (loop) + x)))] + [xq (fl/ x q)]) + (inexact->exact (flfloor xq)))) + +(define (pseudo-random-generator-real! s) + (fl* (fl+ (mrg32k3a s) 1.0) norm)) + +;; ---------------------------------------- + +(define/who current-pseudo-random-generator + (make-parameter (make-pseudo-random-generator) + (lambda (v) + (check who pseudo-random-generator? v) + v))) + +(define/who random + (case-lambda + [() (pseudo-random-generator-real! (|#%app| current-pseudo-random-generator))] + [(n) + (cond + [(pseudo-random-generator? n) + (pseudo-random-generator-real! n)] + [else + (check who + :test (and (integer? n) + (exact? n) + (<= 1 n 4294967087)) + :contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" + n) + (pseudo-random-generator-integer! (|#%app| current-pseudo-random-generator) n)])] + [(n prg) + (check who + :test (and (integer? n) + (exact? n) + (<= 1 n 4294967087)) + :contract "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" + n) + (check who pseudo-random-generator? prg) + (pseudo-random-generator-integer! prg n)])) + +(define/who (random-seed k) + (check who + :test (and (exact-nonnegative-integer? k) + (<= k (sub1 (expt 2 31)))) + :contract "(integer-in 0 (sub1 (expt 2 31)))" + k) + (pseudo-random-generator-seed! (|#%app| current-pseudo-random-generator) k)) diff --git a/racket/src/cs/rumble/srcloc.ss b/racket/src/cs/rumble/srcloc.ss new file mode 100644 index 0000000000..2dce34da76 --- /dev/null +++ b/racket/src/cs/rumble/srcloc.ss @@ -0,0 +1,14 @@ + +(define-struct srcloc (source line column position span) + :guard (lambda (source line column position span who) + (check who exact-positive-integer? :or-false line) + (check who exact-nonnegative-integer? :or-false column) + (check who exact-positive-integer? :or-false position) + (check who exact-nonnegative-integer? :or-false span) + (values source line column position span))) + +(define-values (prop:exn:srclocs exn:srclocs? exn:srclocs-accessor) + (make-struct-type-property 'exn:srclocs + (lambda (v info) + (check 'guard-for-prop:exn:srclocs (procedure-arity-includes/c 1) v) + v))) diff --git a/racket/src/cs/rumble/string.ss b/racket/src/cs/rumble/string.ss new file mode 100644 index 0000000000..f34d37ce7f --- /dev/null +++ b/racket/src/cs/rumble/string.ss @@ -0,0 +1,28 @@ +(define/who string-copy! + (case-lambda + [(dest d-start src) + (string-copy! dest d-start src 0 (and (string? src) (string-length src)))] + [(dest d-start src s-start) + (string-copy! dest d-start src s-start (and (string? src) (string-length src)))] + [(dest d-start src s-start s-end) + (check who mutable-string? :contract "(and/c string? (not/c immutable?))" dest) + (check who exact-nonnegative-integer? d-start) + (check who string? src) + (check who exact-nonnegative-integer? s-start) + (check who exact-nonnegative-integer? s-end) + (let ([d-len (string-length dest)]) + (check-range who "string" dest d-start #f d-len) + (check-range who "string" src s-start s-end (string-length src)) + (let ([s-len (fx- s-end s-start)]) + (check-space who "string" d-start d-len s-len) + (#%string-copy! src s-start dest d-start s-len)))])) + +(define/who substring + (case-lambda + [(s start) (substring s start (and (string? s) (string-length s)))] + [(s start end) + (check who string? s) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "string" s start end (string-length s)) + (#%substring s start end)])) diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss new file mode 100644 index 0000000000..b4667359fc --- /dev/null +++ b/racket/src/cs/rumble/struct.ss @@ -0,0 +1,1151 @@ +;; Naming conventions: +;; - `rtd*` means an rtd that is not impersonators +;; - `init-count` means the number of fields supplied to the constructor, +;; not counting inherited fields +;; - `init*-count` means `init-count` plus inherited constructed fields +;; - `auto-count` means the number of fields automatically added, +;; not counting inherited fields +;; - `auto*-count` means `auto-count` plus inherited auto fields +;; - `total-count` means `init-count` plus `auto-count` +;; - `total*-count` means `init*-count` plus `auto*-count` +;; - `prefab-key+count` has a `total*-count` + +(define-record struct-type-prop (name guard supers)) + +;; Record the properties that are implemented by each rtd: +(define rtd-props (make-ephemeron-eq-hashtable)) + +;; Maps a property-accessor function to `(cons predicate-proc can-impersonate)`: +(define property-accessors (make-ephemeron-eq-hashtable)) + +(define (struct-type-property? v) + (struct-type-prop? v)) + +(define/who make-struct-type-property + (case-lambda + [(name) (make-struct-type-property name #f '() #f)] + [(name guard) (make-struct-type-property name guard '() #f)] + [(name guard supers) (make-struct-type-property name guard supers #f)] + [(name guard supers can-impersonate?) + (check who symbol? name) + (unless (or (not guard) + (eq? guard 'can-impersonate) + (and (#%procedure? guard) ; avoid `procedure?` until it's defined + (bitwise-bit-set? (#%procedure-arity-mask guard) 2)) + (and (procedure? guard) + (procedure-arity-includes? guard 2))) + (raise-argument-error who "(or/c (procedure-arity-includes/c 2) #f 'can-impersonate)" guard)) + (unless (and (or (null? supers) ; avoid `list?` until it's defined + (list? supers)) + (andmap (lambda (p) + (and (pair? p) + (struct-type-property? (car p)) + (procedure? (cdr p)) + (procedure-arity-includes? (cdr p) 1))) + supers)) + (raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers)) + (let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)] + [st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)] + [pred (escapes-ok + (lambda (v) + (let* ([v (strip-impersonator v)] + [rtd (if (record-type-descriptor? v) + v + (and (record? v) + (record-rtd v)))]) + (and rtd + (not (eq? none (struct-property-ref st rtd none)))))))] + [accessor-name (string->symbol (string-append + (symbol->string name) + "-ref"))] + [predicate-name (string->symbol + (string-append + (symbol->string name) + "?"))] + [default-fail + (escapes-ok + (lambda (v) + (raise-argument-error accessor-name + (symbol->string predicate-name) + v)))] + [do-fail (lambda (fail v) + (cond + [(eq? fail default-fail) (default-fail v)] + [(procedure? fail) (|#%app| fail)] + [else fail]))]) + (letrec ([acc + (case-lambda + [(v fail) + (cond + [(and (impersonator? v) + (pred v)) + (impersonate-struct-or-property-ref acc #f acc v)] + [else + (let* ([rtd (if (record-type-descriptor? v) + v + (and (record? v) + (record-rtd v)))]) + (if rtd + (let ([pv (struct-property-ref st rtd none)]) + (if (eq? pv none) + (do-fail fail v) + pv)) + (do-fail fail v)))])] + [(v) (acc v default-fail)])]) + (hashtable-set! property-accessors + acc + (cons pred can-impersonate?)) + (values st + pred + acc)))])) + +(define (struct-type-property-accessor-procedure? v) + (and (procedure? v) + (let ([v (strip-impersonator v)]) + (hashtable-ref property-accessors v #f)) + #t)) + +(define (struct-type-property-accessor-procedure-pred v) + (car (hashtable-ref property-accessors v #f))) + +(define (struct-type-property-accessor-procedure-can-impersonate? v) + (cdr (hashtable-ref property-accessors v #f))) + +(define (struct-property-ref prop rtd default) + (getprop (record-type-uid rtd) prop default)) + +(define (struct-property-set! prop rtd val) + (putprop (record-type-uid rtd) prop val)) + +;; ---------------------------------------- + +(define-record-type (inspector new-inspector inspector?) (fields parent)) + +(define root-inspector (new-inspector #f)) + +(define/who make-inspector + (case-lambda + [() (new-inspector (|#%app| current-inspector))] + [(i) + (check who inspector? i) + (new-inspector i)])) + +(define/who make-sibling-inspector + (case-lambda + [() (make-sibling-inspector (current-inspector))] + [(i) + (check who inspector? i) + (make-inspector (inspector-parent i))])) + +(define/who (inspector-superior? sup-insp sub-insp) + (check who inspector? sup-insp) + (check who inspector? sub-insp) + (if (eq? sub-insp root-inspector) + #f + (let ([parent (inspector-parent sub-insp)]) + (or (eq? parent sup-insp) + (inspector-superior? sup-insp parent))))) + +(define (inspector-ref rtd) + (getprop (record-type-uid rtd) 'inspector none)) + +(define (inspector-set! rtd insp) + (putprop (record-type-uid rtd) 'inspector insp)) + +;; ---------------------------------------- + +(define (check-make-struct-type-arguments who name parent-rtd init-count auto-count + props insp proc-spec immutables guard constructor-name) + (check who symbol? name) + (check who :or-false struct-type? parent-rtd) + (check who exact-nonnegative-integer? init-count) + (check who exact-nonnegative-integer? auto-count) + (check who + :test (or (not proc-spec) + (procedure? proc-spec) + (exact-nonnegative-integer? proc-spec)) + :contract "(or/c procedure? exact-nonnegative-integer? #f)" + proc-spec) + (check who + :test (and (list props) + (andmap (lambda (i) (and (pair? i) (struct-type-property? (car i)))) + props)) + :contract "(listof (cons/c struct-type-property? any/c))" + props) + (check who + :test (or (not insp) + (inspector? insp) + (eq? insp 'prefab)) + :contract "(or/c inspector? #f 'prefab)" + insp) + (check who + :test (and (list? immutables) + (andmap exact-nonnegative-integer? immutables)) + :contract "(listof exact-nonnegative-integer?)" + immutables) + (check who :or-false procedure? guard) + (check who :or-false symbol? constructor-name) + + ;; The rest has to be delayed until we have an rtd: + (lambda (rtd parent-rtd* all-immutables) + (let ([props-ht + ;; Check for duplicates and record property values + (let ([get-struct-info + (escapes-ok + (lambda () + (let ([parent-total*-count (if parent-rtd* + (struct-type-total*-field-count parent-rtd*) + 0)]) + (list name + init-count + auto-count + (make-position-based-accessor rtd parent-total*-count (+ init-count auto-count)) + (make-position-based-mutator rtd parent-total*-count (+ init-count auto-count)) + all-immutables + parent-rtd + #f))))]) + (let loop ([props props] [ht empty-hasheq]) + (cond + [(null? props) + (if proc-spec + (let-values ([(ht props) (check-and-add-property who prop:procedure proc-spec rtd ht '() + get-struct-info)]) + ht) + ht)] + [else + (let-values ([(ht props) (check-and-add-property who (caar props) (cdar props) rtd ht (cdr props) + get-struct-info)]) + (loop props ht))])))]) + + (when (eq? insp 'prefab) + (let ([bad + (or (and (impersonator? parent-rtd) + "chaperoned supertype disallowed for non-generative structure type") + (and parent-rtd + (not (eq? (inspector-ref parent-rtd) 'prefab)) + "generative supertype disallowed for non-generative structure type") + (and (pair? props) + "properties disallowed for non-generative structure type") + (and proc-spec + "procedure specification disallowed for non-generative structure type") + (and guard + "guard disallowed for non-generative structure type"))]) + (when bad + (raise-arguments-error who bad + "structure type name" name)))) + + (let loop ([ht empty-hasheqv] [imms immutables]) + (cond + [(null? imms) (void)] + [else + (let ([i (car imms)]) + (when (hash-ref ht i #f) + (raise-arguments-error who + "redundant immutable field index" + "index" i + "in list" immutables)) + (unless (< i init-count) + (raise-arguments-error who + "index for immutable field >= initialized-field count" + "index" i + "initialized-field count" init-count + "in list" immutables)) + (loop (hash-set ht i #t) (cdr imms)))])) + + (let ([v (hash-ref props-ht prop:procedure #f)]) + (when v + (cond + [(exact-nonnegative-integer? v) + (unless (< v init-count) + (raise-arguments-error who + "index for procedure >= initialized-field count" + "index" v + "field count" init-count)) + (unless (or (eq? v proc-spec) (chez:memv v immutables)) + (raise-arguments-error who + "field is not specified as immutable for a prop:procedure index" + "index" v))] + [(procedure? v) + (void)] + [else + (raise-arguments-error who + "given value did not satisfy the contract for prop:procedure" + "expected" "(or/c procedure? exact-nonnegative-integer?)" + "given" v)]))) + + (let ([parent-rtd* (strip-impersonator parent-rtd)]) + (when parent-rtd* + (let ([authentic? (not (eq? (hash-ref props-ht prop:authentic none) none))] + [authentic-parent? (struct-property-ref prop:authentic parent-rtd* #f)]) + (when (not (eq? authentic? authentic-parent?)) + (if authentic? + (raise-arguments-error who + "cannot make an authentic subtype of a non-authentic type" + "type name" name + "non-authentic type" parent-rtd) + (raise-arguments-error who + "cannot make a non-authentic subtype of an authentic type" + "type name" name + "authentic type" parent-rtd))))) + + (when guard + (let ([expected-count (+ 1 + init-count + (if parent-rtd* + (get-field-info-init*-count (struct-type-field-info parent-rtd*)) + 0))]) + (unless (procedure-arity-includes? guard expected-count) + (raise-arguments-error who + (string-append + "guard procedure does not accept correct number of arguments;\n" + " should accept one more than the number of constructor arguments") + "guard procedure" guard + "expected arity" expected-count)))))))) + +(define (check-and-add-property who prop val rtd ht props get-struct-info) + (let* ([guarded-val + (let ([guard (struct-type-prop-guard prop)]) + (if guard + (|#%app| guard val (get-struct-info)) + val))] + [check-val (cond + [(eq? prop prop:procedure) + ;; Save and check the original value, since the true + ;; guard is in `check-make-struct-type-arguments` + ;; (for historical reasons) + val] + [else guarded-val])] + [old-v (hash-ref ht prop none)]) + (unless (or (eq? old-v none) + (eq? old-v check-val)) + (raise-arguments-error who + "duplicate property binding" + "property" prop)) + (when (eq? prop prop:equal+hash) + (record-type-equal-procedure rtd (let ([p (cadr guarded-val)]) + (if (#%procedure? p) + p + (lambda (v1 v2 e?) (|#%app| p v1 v2 e?))))) + (record-type-hash-procedure rtd (let ([p (caddr guarded-val)]) + (if (#%procedure? p) + p + (lambda (v h) (|#%app| p v h)))))) + (struct-property-set! prop rtd guarded-val) + (values (hash-set ht prop check-val) + (append + (if (eq? old-v none) + (map (lambda (super) + (cons (car super) + (|#%app| (cdr super) guarded-val))) + (struct-type-prop-supers prop)) + ;; skip supers, because property is already added + null) + props)))) + +;; ---------------------------------------- + +;; Records which fields of an rtd are mutable, where an rtd that is +;; not in the table has no mutable fields: +(define rtd-mutables (make-ephemeron-eq-hashtable)) + +;; Accessors and mutators that need a position are wrapped in these records: +(define-record position-based-accessor (rtd offset field-count)) +(define-record position-based-mutator (rtd offset field-count)) + +;; Register other procedures in hash tables; avoid wrapping to +;; avoid making the procedures slower +(define struct-constructors (make-ephemeron-eq-hashtable)) +(define struct-predicates (make-ephemeron-eq-hashtable)) +(define struct-field-accessors (make-ephemeron-eq-hashtable)) +(define struct-field-mutators (make-ephemeron-eq-hashtable)) + +(define (register-struct-constructor! p) + (hashtable-set! struct-constructors p #t)) + +(define (register-struct-predicate! p) + (hashtable-set! struct-predicates p #t)) + +(define (register-struct-field-accessor! p rtd pos) + (hashtable-set! struct-field-accessors p (cons rtd pos))) + +(define (register-struct-field-mutator! p rtd pos) + (hashtable-set! struct-field-mutators p (cons rtd pos))) + +(define (struct-constructor-procedure? v) + (and (procedure? v) + (hashtable-ref struct-constructors (strip-impersonator v) #f))) + +(define (struct-predicate-procedure? v) + (and (procedure? v) + (hashtable-ref struct-predicates (strip-impersonator v) #f))) + +(define (struct-accessor-procedure? v) + (and (procedure? v) + (let ([v (strip-impersonator v)]) + (or (position-based-accessor? v) + (hashtable-ref struct-field-accessors v #f))) + #t)) + +(define (struct-mutator-procedure? v) + (and (procedure? v) + (let ([v (strip-impersonator v)]) + (or (position-based-mutator? v) + (hashtable-ref struct-field-mutators v #f))) + #t)) + +(define (struct-accessor-procedure-rtd+pos v) + (hashtable-ref struct-field-accessors v #f)) + +(define (struct-mutator-procedure-rtd+pos v) + (hashtable-ref struct-field-mutators v #f)) + +;; ---------------------------------------- + +;; General structure-type creation, but not called when a `schemify` +;; transformation keeps the record type exposed to the compiler +(define make-struct-type + (case-lambda + [(name parent-rtd init-count auto-count) + (make-struct-type name parent-rtd init-count auto-count #f '() (|#%app| current-inspector) #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val) + (make-struct-type name parent-rtd init-count auto-count auto-val '() (|#%app| current-inspector) #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val props) + (make-struct-type name parent-rtd init-count auto-count auto-val props (|#%app| current-inspector) #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val props insp) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp #f '() #f name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec '() #f name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables #f name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard) + (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard name)] + [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard constructor-name) + (let* ([install-props! + (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count + props insp proc-spec immutables guard constructor-name)] + [prefab-uid (and (eq? insp 'prefab) + (structure-type-lookup-prefab-uid name parent-rtd init-count auto-count auto-val immutables))] + [parent-rtd* (strip-impersonator parent-rtd)] + [parent-fi (if parent-rtd* + (struct-type-field-info parent-rtd*) + empty-field-info)] + [rtd (make-record-type-descriptor name + parent-rtd* + prefab-uid #f #f + (make-fields (+ init-count auto-count)))] + [parent-auto*-count (get-field-info-auto*-count parent-fi)] + [parent-init*-count (get-field-info-init*-count parent-fi)] + [parent-total*-count (get-field-info-total*-count parent-fi)] + [init*-count (+ init-count parent-init*-count)] + [auto*-count (+ auto-count parent-auto*-count)] + [auto-field-adder (and (positive? auto*-count) + (let ([pfa (get-field-info-auto-adder parent-fi)]) + (lambda (args) + (args-insert args init-count auto-count auto-val pfa))))]) + (when (or parent-rtd* auto-field-adder) + (putprop (record-type-uid rtd) 'field-info (make-field-info init*-count auto*-count auto-field-adder))) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd + props insp proc-spec immutables guard constructor-name + install-props!) + (let ([ctr (struct-type-constructor-add-guards + (let ([c (record-constructor rtd)]) + (if (zero? auto*-count) + c + (procedure-rename + (procedure-reduce-arity + (lambda args + (apply c (reverse (auto-field-adder (reverse args))))) + init*-count) + (or constructor-name name)))) + rtd + (or constructor-name name))] + [pred (escapes-ok + (lambda (v) + (or (record? v rtd) + (and (impersonator? v) + (record? (impersonator-val v) rtd)))))]) + (register-struct-constructor! ctr) + (register-struct-constructor! pred) + (values rtd + ctr + pred + (make-position-based-accessor rtd parent-total*-count (+ init-count auto-count)) + (make-position-based-mutator rtd parent-total*-count (+ init-count auto-count)))))])) + +;; Called both by `make-struct-type` and by a `schemify` transformation: +(define struct-type-install-properties! + (case-lambda + [(rtd name init-count auto-count parent-rtd) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (|#%app| current-inspector) #f '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props (|#%app| current-inspector) #f '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec '() #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables #f name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name) + (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name #f)] + [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name install-props!) + (let ([install-props! + (or install-props! + (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count + props insp proc-spec immutables guard constructor-name))]) + (unless (eq? insp 'prefab) ; everything for prefab must be covered in `prefab-key+count->rtd` + (let* ([parent-rtd* (strip-impersonator parent-rtd)] + [parent-props + (if parent-rtd* + (hashtable-ref rtd-props parent-rtd* '()) + '())] + [all-immutables (if (integer? proc-spec) + (cons proc-spec immutables) + immutables)] + [mutables (immutables->mutables all-immutables init-count)]) + (when (not parent-rtd*) + (record-type-equal-procedure rtd default-struct-equal?) + (record-type-hash-procedure rtd default-struct-hash)) + ;; Record properties implemented by this type: + (hashtable-set! rtd-props rtd (let ([props (append (map car props) parent-props)]) + (if proc-spec + (cons prop:procedure props) + props))) + (unless (equal? '#() mutables) + (hashtable-set! rtd-mutables rtd mutables)) + ;; Copy parent properties for this type: + (for-each (lambda (prop) + (let loop ([prop prop]) + (struct-property-set! prop rtd (struct-property-ref prop parent-rtd* #f)) + (for-each (lambda (super) + (loop (car super))) + (struct-type-prop-supers prop)))) + parent-props) + ;; Finish checking and install new property values: + (install-props! rtd parent-rtd* all-immutables) + ;; Record inspector + (inspector-set! rtd insp) + ;; Register guard + (register-guards! rtd parent-rtd guard 'at-start))))])) + +;; Used by a `schemify` transformation: +(define (structure-type-lookup-prefab-uid name parent-rtd* init-count auto-count auto-val immutables) + ;; Return a UID for a prefab structure type. We can assume that + ;; `immutables` is well-formed, and checking an error reporting will + ;; happen latter if necessary. + (let ([prefab-key (derive-prefab-key name + (and parent-rtd* + (getprop (record-type-uid parent-rtd*) 'prefab-key+count)) + init-count + immutables auto-count auto-val)] + [total*-count (+ (if parent-rtd* + (struct-type-total*-field-count parent-rtd*) + 0) + init-count + auto-count)]) + (record-type-uid + (prefab-key+count->rtd (cons prefab-key total*-count))))) + +(define (prefab-key+count->rtd prefab-key+count) + (cond + [(and prefabs + (hash-ref prefabs prefab-key+count #f)) + => (lambda (rtd) rtd)] + [else + (let* ([prefab-key (car prefab-key+count)] + [name (if (symbol? prefab-key) + prefab-key + (car prefab-key))] + [parent-prefab-key+count + (prefab-key->parent-prefab-key+count (car prefab-key+count))] + [parent-rtd (and parent-prefab-key+count + (prefab-key+count->rtd parent-prefab-key+count))] + [total-count (- (cdr prefab-key+count) + (if parent-prefab-key+count + (cdr parent-prefab-key+count) + 0))] + [uid (encode-prefab-key+count-as-symbol prefab-key+count)] + [rtd (make-record-type-descriptor name + parent-rtd + uid #f #f + (make-fields total-count))] + [mutables (prefab-key-mutables prefab-key)]) + (with-interrupts-disabled + (cond + [(and prefabs + (hash-ref prefabs prefab-key+count #f)) + ;; rtd was created concurrently + => (lambda (rtd) rtd)] + [else + (putprop uid 'prefab-key+count prefab-key+count) + (unless prefabs (set! prefabs (make-weak-hash))) + (hash-set! prefabs prefab-key+count rtd) + (unless parent-rtd + (record-type-equal-procedure rtd default-struct-equal?) + (record-type-hash-procedure rtd default-struct-hash)) + (unless (equal? mutables '#()) + (hashtable-set! rtd-mutables rtd mutables)) + (inspector-set! rtd 'prefab) + rtd])))])) + +(define (check-accessor-or-mutator-index who rtd pos) + (let* ([total-count (#%vector-length (record-type-field-names rtd))]) + (unless (< pos total-count) + (if (zero? total-count) + (raise-arguments-error who + "index too large; no fields accessible" + "index" pos + "structure type" rtd) + (raise-arguments-error who + "index too large" + "index" pos + "maximum allowed index" (sub1 total-count) + "structure type" rtd))))) + +(define/who make-struct-field-accessor + (case-lambda + [(pba pos name) + (check who position-based-accessor? + :contract "(and/c struct-accessor-procedure? (procedure-arity-includes/c 2))" + pba) + (check who exact-nonnegative-integer? pos) + (check who symbol? :or-false name) + (let ([rtd (position-based-accessor-rtd pba)]) + (check-accessor-or-mutator-index who rtd pos) + (let* ([p (record-field-accessor rtd + (+ pos (position-based-accessor-offset pba)))] + [wrap-p + (escapes-ok + (lambda (v) + (if (impersonator? v) + (impersonate-ref p rtd pos v) + (p v))))]) + (register-struct-field-accessor! wrap-p rtd pos) + wrap-p))] + [(pba pos) + (make-struct-field-accessor pba pos #f)])) + +(define/who make-struct-field-mutator + (case-lambda + [(pbm pos name) + (check who position-based-mutator? + :contract "(and/c struct-mutator-procedure? (procedure-arity-includes/c 3))" + pbm) + (check who exact-nonnegative-integer? pos) + (check who symbol? :or-false name) + (let ([rtd (position-based-mutator-rtd pbm)]) + (check-accessor-or-mutator-index who rtd pos) + (let* ([abs-pos (+ pos (position-based-mutator-offset pbm))] + [p (record-field-mutator rtd abs-pos)] + [wrap-p + (escapes-ok + (lambda (v a) + (if (impersonator? v) + (impersonate-set! p rtd pos abs-pos v a) + (p v a))))]) + (register-struct-field-mutator! wrap-p rtd pos) + wrap-p))] + [(pbm pos) + (make-struct-field-mutator pbm pos #f)])) + +;; Takes constructor arguments and adds auto-argument values. +;; Receives and returns `args` is in reverse order. +(define (args-insert args fields-count auto-count auto-val pfa) + (let loop ([auto-count auto-count]) + (if (zero? auto-count) + (if pfa + (let loop ([fields-count fields-count] [args args]) + (if (zero? fields-count) + (pfa args) + (cons (car args) (loop (fx1- fields-count) (cdr args))))) + args) + (cons auto-val (loop (fx1- auto-count)))))) + +;; ---------------------------------------- + +(define (struct-type? v) (record-type-descriptor? (strip-impersonator v))) + +(define/who (procedure-struct-type? v) + (check who struct-type? v) + (procedure-struct? v)) + +(define (struct? v) + (let ([v (strip-impersonator v)]) + (and (record? v) + (struct-type-any-transparent? (record-rtd v))))) + +(define (struct-info v) + (cond + [(impersonator? v) + (if (record? (impersonator-val v)) + (impersonate-struct-info v) + (values #f #t))] + [(not (record? v)) (values #f #t)] + [else (next-visible-struct-type (record-rtd v))])) + +(define (next-visible-struct-type rtd) + (let loop ([rtd rtd] [skipped? #f]) + (cond + [(struct-type-immediate-transparent? rtd) + (values rtd skipped?)] + [else + (let ([parent-rtd (record-type-parent rtd)]) + (if parent-rtd + (loop parent-rtd #t) + (values #f #t)))]))) + +(define/who (struct-type-info rtd) + (check who struct-type? rtd) + (let ([rtd* (strip-impersonator rtd)]) + (check-inspector-access 'struct-type-info rtd*) + (let* ([fi (struct-type-field-info rtd*)] + [parent-rtd* (record-type-parent rtd*)] + [parent-fi (if parent-rtd* + (struct-type-field-info parent-rtd*) + empty-field-info)] + [init-count (get-field-info-init-count fi parent-fi)] + [auto-count (get-field-info-auto-count fi parent-fi)] + [parent-total*-count (get-field-info-total*-count parent-fi)]) + (let-values ([(next-rtd* skipped?) + (if parent-rtd* + (next-visible-struct-type parent-rtd*) + (values #f #f))]) + (letrec ([get-results + (lambda () + (values (record-type-name rtd*) + init-count + auto-count + (make-position-based-accessor rtd* parent-total*-count (+ init-count auto-count)) + (make-position-based-mutator rtd* parent-total*-count (+ init-count auto-count)) + (mutables->immutables (hashtable-ref rtd-mutables rtd* '#()) init-count) + next-rtd* + skipped?))]) + (cond + [(struct-type-chaperone? rtd) + (chaperone-struct-type-info rtd get-results)] + [else + (get-results)])))))) + +(define (check-inspector-access who rtd) + (unless (struct-type-immediate-transparent? rtd) + (raise-arguments-error who + "current inspector cannot extract info for structure type" + "structure type" rtd))) + +(define/who (struct-type-make-constructor rtd) + (check who struct-type? rtd) + (let ([rtd* (strip-impersonator rtd)]) + (check-inspector-access who rtd*) + (let ([ctr (struct-type-constructor-add-guards + (let* ([c (record-constructor rtd*)] + [fi (struct-type-field-info rtd*)] + [auto-field-adder (get-field-info-auto-adder fi)]) + (cond + [auto-field-adder + (procedure-maybe-rename + (procedure-reduce-arity + (lambda args + (apply c (reverse (auto-field-adder (reverse args))))) + (get-field-info-init*-count fi)) + (object-name c))] + [else c])) + rtd* + #f)]) + (register-struct-constructor! ctr) + (cond + [(struct-type-chaperone? rtd) + (chaperone-constructor rtd ctr)] + [else ctr])))) + +;; Called directly from a schemified declaration that has a guard: +(define (struct-type-constructor-add-guards ctr rtd name) + (let ([guards (struct-type-guards rtd)] + [chaparone-undefined? (chaperone-unsafe-undefined? rtd)]) + (if (and (null? guards) + (not chaparone-undefined?)) + ctr + (procedure-maybe-rename + (procedure-reduce-arity + (let ([base-ctr + (if (null? guards) + ctr + (let ([name (record-type-name rtd)]) + (lambda args + (let loop ([guards guards] [args args]) + (cond + [(null? guards) + (apply ctr args)] + [else + (let ([guard (caar guards)] + [init*-count (cdar guards)]) + (call-with-values + (lambda () + (apply guard (append-n args init*-count (list name)))) + (lambda results + (unless (= (length results) init*-count) + (raise-result-arity-error "calling guard procedure" init*-count results)) + (loop (cdr guards) + (if (= init*-count (length args)) + results + (append results (list-tail args init*-count)))))))])))))]) + (if chaparone-undefined? + (lambda args + (chaperone-struct-unsafe-undefined (apply base-ctr args))) + base-ctr)) + (get-field-info-init*-count (struct-type-field-info rtd))) + (or name (object-name ctr)))))) + +(define (struct-type-constructor-add-guards* ctr rtd guard name) + (register-guards! rtd #f guard 'at-end) + (struct-type-constructor-add-guards ctr rtd name)) + +(define/who (struct-type-make-predicate rtd) + (check who struct-type? rtd) + (let ([rtd* (strip-impersonator rtd)]) + (check-inspector-access who rtd*) + (let ([pred (escapes-ok + (lambda (v) + (or (record? v rtd*) + (and (impersonator? v) + (record? (impersonator-val v) rtd*)))))]) + (register-struct-constructor! pred) + pred))) + +;; ---------------------------------------- + +(define-record field-info (init*-count ; includes parent init fields + auto*-count ; includes parent auto fields + auto-adder)) ; #f or procedure to add auto fields for constructor + +(define empty-field-info 0) + +;; Returns either a `field-info` record or a fixnum N that +;; corresponds to `(make-field-info N 0 #f)`. +(define (struct-type-field-info rtd*) + (or (getprop (record-type-uid rtd*) 'field-info #f) + (let ([n (#%vector-length (record-type-field-names rtd*))] + [parent-rtd* (record-type-parent rtd*)]) + ;; If `parent-rtd` is not #f, then we'll get here + ;; only if were still in the process of setting up + ;; `rtd`, so we won't have to recur far or often + ;; construct field-info records + (if parent-rtd* + (let ([parent-fi (struct-type-field-info parent-rtd*)]) + (if (fixnum? parent-fi) + (+ n parent-fi) + (make-field-info (+ n (field-info-init*-count parent-fi)) + (field-info-auto*-count parent-fi) + #f))) + n)))) + +(define (get-field-info-init*-count fi) + (if (fixnum? fi) + fi + (field-info-init*-count fi))) + +(define (get-field-info-auto*-count fi) + (if (fixnum? fi) + 0 + (field-info-auto*-count fi))) + +(define (get-field-info-total*-count fi) + (if (fixnum? fi) + fi + (+ (field-info-init*-count fi) + (field-info-auto*-count fi)))) + +(define (get-field-info-init-count fi parent-fi) + (- (get-field-info-init*-count fi) + (get-field-info-init*-count parent-fi))) + +(define (get-field-info-auto-count fi parent-fi) + (- (get-field-info-auto*-count fi) + (get-field-info-auto*-count parent-fi))) + +(define (get-field-info-auto-adder fi) + (if (fixnum? fi) + #f + (field-info-auto-adder fi))) + +(define (struct-type-total*-field-count rtd*) + (get-field-info-total*-count (struct-type-field-info rtd*))) + +(define (struct-type-parent-total*-count rtd*) + (let ([p-rtd* (record-type-parent rtd*)]) + (if p-rtd* + (struct-type-total*-field-count p-rtd*) + 0))) + +;; ---------------------------------------- + +(define (struct-type-field-mutable? rtd pos) + (let ([mutables (hashtable-ref rtd-mutables rtd '#())]) + (let loop ([j (#%vector-length mutables)]) + (cond + [(fx= j 0) #f] + [else + (let ([j (fx1- j)]) + (or (eqv? pos (#%vector-ref mutables j)) + (loop j)))])))) + +;; Returns a list of (cons guard-proc field-count) +(define (struct-type-guards rtd) + (getprop (record-type-uid rtd) 'guards '())) + +(define (register-guards! rtd parent-rtd guard which-end) + (let* ([parent-rtd* (record-type-parent rtd)] + [parent-guards (if parent-rtd* + (struct-type-guards parent-rtd*) + '())]) + (when (or guard (pair? parent-guards) (struct-type-chaperone? parent-rtd)) + (let* ([fi (struct-type-field-info rtd)] + [parent-guards (if (struct-type-chaperone? parent-rtd) + (cons (cons (struct-type-chaperone-guard parent-rtd) + (get-field-info-init*-count + (struct-type-field-info parent-rtd*))) + parent-guards) + parent-guards)]) + (putprop (record-type-uid rtd) 'guards (if guard + (if (eq? which-end 'at-start) + ;; Normal: + (cons (cons guard (get-field-info-init*-count fi)) + parent-guards) + ;; Internal, makes primitive guards have a natural + ;; error order: + (append parent-guards + (list (cons guard (get-field-info-init*-count fi))))) + parent-guards)))))) + +(define (unsafe-struct*-ref s i) + (#3%vector-ref s i)) +(define (unsafe-struct*-set! s i v) + (#3%vector-set! s i v)) + +(define (unsafe-struct-ref s i) + (if (impersonator? s) + (let loop ([rtd* (record-rtd (impersonator-val s))]) + (let ([pos (- i (struct-type-parent-total*-count rtd*))]) + (if (fx>= pos 0) + (impersonate-ref (record-field-accessor rtd* i) rtd* pos s) + (loop (record-type-parent rtd*))))) + (unsafe-struct*-ref s i))) + +(define (unsafe-struct-set! s i v) + (if (impersonator? s) + (let loop ([rtd* (record-rtd (impersonator-val s))]) + (let* ([pos (- i (struct-type-parent-total*-count rtd*))]) + (if (fx>= pos 0) + (impersonate-set! (record-field-mutator rtd* i) rtd* pos i s v) + (loop (record-type-parent rtd*))))) + (unsafe-struct*-set! s i v))) + +(define-values (prop:equal+hash equal+hash? equal+hash-ref) + (make-struct-type-property 'equal+hash + (lambda (val info) + (check 'guard-for-prop:equal+hash + :test (and (list? val) + (= 3 (length val)) + (andmap procedure? val) + (procedure-arity-includes? (car val) 3) + (procedure-arity-includes? (cadr val) 2) + (procedure-arity-includes? (caddr val) 2)) + :contract (string-append + "(list/c (procedure-arity-includes/c 3)\n" + " (procedure-arity-includes/c 2)\n" + " (procedure-arity-includes/c 2))") + val) + (cons (gensym) val)))) + +(define-values (prop:authentic authentic? authentic-ref) + (make-struct-type-property 'authentic (lambda (val info) #t))) + +(define (struct-type-immediate-transparent? rtd) + (let ([insp (inspector-ref rtd)]) + (and (not (eq? insp none)) + (or (not insp) + (eq? insp 'prefab) + (inspector-superior? (|#%app| current-inspector) insp))))) + +;; Check whether a structure type is fully transparent +(define (struct-type-transparent? rtd) + (and (struct-type-immediate-transparent? rtd) + (let ([p-rtd (record-type-parent rtd)]) + (or (not p-rtd) + (struct-type-transparent? p-rtd))))) + +;; Checks whether a structure type is at least partially trasparent +(define (struct-type-any-transparent? rtd) + (or (struct-type-immediate-transparent? rtd) + (let ([p-rtd (record-type-parent rtd)]) + (and p-rtd + (struct-type-any-transparent? p-rtd))))) + +(define (default-struct-equal? s1 s2 eql?) + (let ([t1 (record-rtd (strip-impersonator s1))] + [t2 (record-rtd (strip-impersonator s2))]) + (and (eq? t1 t2) + (struct-type-transparent? t1) + (let ([n (struct-type-total*-field-count t1)]) + (let loop ([j 0]) + (if (fx= j n) + #t + (and (eql? (unsafe-struct-ref s1 j) + (unsafe-struct-ref s2 j)) + (loop (fx+ j 1))))))))) + +(define (default-struct-hash s hash-code) + (cond + [(not (impersonator? s)) + ;; Same as the loop below, but uses `unsafe-struct*-ref`: + (let ([t (record-rtd s)]) + (if (struct-type-transparent? t) + (let ([n (struct-type-total*-field-count t)]) + (let loop ([j 0] [hc 0]) + (if (fx= j n) + hc + (loop (fx+ j 1) + (hash-code-combine hc (hash-code (unsafe-struct*-ref s j))))))) + (eq-hash-code s)))] + [else + ;; Impersonator variant uses `unsafe-struct-ref` to trigger wrappers: + (let ([raw-s (impersonator-val s)]) + (let ([t (record-rtd raw-s)]) + (if (struct-type-transparent? t) + (let ([n (struct-type-total*-field-count t)]) + (let loop ([j 0] [hc 0]) + (if (fx= j n) + hc + (loop (fx+ j 1) + (hash-code-combine hc (hash-code (unsafe-struct-ref s j))))))) + (eq-hash-code raw-s))))])) + +(define struct->vector + (case-lambda + [(s dots) + (if (record? (strip-impersonator s)) + (let ([rtd (record-rtd (strip-impersonator s))]) + ;; Create that vector that has '... for opaque ranges and each field + ;; value otherwise + (let-values ([(vec-len rec-len) + ;; First, get the vector and record sizes + (let loop ([vec-len 1] [rec-len 0] [rtd rtd] [dots-already? #f]) + (cond + [(not rtd) (values vec-len rec-len)] + [else + (let ([len (#%vector-length (record-type-field-names rtd))]) + (cond + [(struct-type-immediate-transparent? rtd) + ;; A transparent region + (loop (+ vec-len len) (+ rec-len len) (record-type-parent rtd) #f)] + [dots-already? + ;; An opaque region that follows an opaque region + (loop vec-len (+ rec-len len) (record-type-parent rtd) #t)] + [else + ;; The start of opaque regions + (loop (add1 vec-len) (+ rec-len len) (record-type-parent rtd) #t)]))]))]) + ;; Walk though the record's types again, this time filling in the vector + (let ([vec (make-vector vec-len dots)]) + (vector-set! vec 0 (string->symbol (format "struct:~a" (record-type-name rtd)))) + (let loop ([vec-pos vec-len] [rec-pos rec-len] [rtd rtd] [dots-already? #f]) + (when rtd + (let* ([len (#%vector-length (record-type-field-names rtd))] + [rec-pos (- rec-pos len)]) + (cond + [(struct-type-immediate-transparent? rtd) + ;; Copy over a transparent region + (let ([vec-pos (- vec-pos len)]) + (let floop ([n 0]) + (cond + [(= n len) (loop vec-pos rec-pos (record-type-parent rtd) #f)] + [else + (vector-set! vec (+ vec-pos n) (unsafe-struct-ref s (+ rec-pos n))) + (floop (add1 n))])))] + [dots-already? + ;; Skip another opaque region + (loop vec-pos rec-pos (record-type-parent rtd) #t)] + [else + ;; The vector already has `dots` + (loop (sub1 vec-pos) rec-pos (record-type-parent rtd) #t)])))) + vec))) + ;; Any value that is not implemented as a record is treated as + ;; a fully opaque struct + (vector (string->symbol (format "struct:~a" ((inspect/object s) 'type))) dots))] + [(s) (struct->vector s '...)])) + +;; ---------------------------------------- + +(define (make-fields field-count) + (list->vector + (let loop ([i 0]) + (if (= i field-count) + '() + (cons `(mutable ,(string->symbol (format "f~a" i))) + (loop (fx1+ i))))))) + +;; ---------------------------------------- +;; Convenience for Rumble implementation: + +(define-syntax struct + (lambda (stx) + (syntax-case stx (:guard) + [(_ name (field ...)) + #'(struct name #f (field ...))] + [(_ name (field ...) :guard guard-expr) + #'(struct name #f (field ...) :guard guard-expr)] + [(_ name parent (field ...)) + #'(struct name parent (field ...) :guard #f)] + [(_ name parent (field ...) :guard guard-expr) + (let ([make-id (lambda (id fmt . args) + (datum->syntax id + (string->symbol (chez:apply format fmt args))))]) + (with-syntax ([struct:name (make-id #'name "struct:~a" (syntax->datum #'name))] + [authentic-name? (make-id #'name "authentic-~a?" (syntax->datum #'name))] + [name? (make-id #'name "~a?" (syntax->datum #'name))] + [(name-field ...) (map (lambda (field) + (make-id field "~a-~a" (syntax->datum #'name) (syntax->datum field))) + #'(field ...))] + [(field-index ...) (let loop ([fields #'(field ...)] [accum '()] [pos 0]) + (cond + [(null? fields) (reverse accum)] + [else (loop (cdr fields) (cons pos accum) (add1 pos))]))] + [struct:parent (if (syntax->datum #'parent) + (make-id #'parent "struct:~a" (syntax->datum #'parent)) + #f)]) + (with-syntax ([ctr-expr (with-syntax ([mk #'(record-constructor (make-record-constructor-descriptor struct:name #f #f))]) + (if (or (syntax->datum #'parent) (syntax->datum #'guard-expr)) + #'(struct-type-constructor-add-guards* mk struct:name guard-expr 'name) + #'mk))] + [uid (datum->syntax #'name ((current-generate-id) (syntax->datum #'name)))]) + #'(begin + (define struct:name (make-record-type-descriptor 'name struct:parent 'uid #f #f '#((immutable field) ...))) + (define name ctr-expr) + (define authentic-name? (record-predicate struct:name)) + (define name? (lambda (v) (or (authentic-name? v) + (and (impersonator? v) + (authentic-name? (impersonator-val v)))))) + (define name-field + (let ([name-field (record-accessor struct:name field-index)]) + (lambda (v) + (if (authentic-name? v) + (name-field v) + (pariah (impersonate-ref name-field struct:name field-index v)))))) + ... + (define dummy + (begin + (register-struct-constructor! name) + (register-struct-field-accessor! name-field struct:name field-index) ... + (record-type-equal-procedure struct:name default-struct-equal?) + (record-type-hash-procedure struct:name default-struct-hash) + (inspector-set! struct:name #f)))))))]))) + +(define-syntax define-struct + (lambda (stx) + (syntax-case stx () + [(_ name . rest) + (with-syntax ([make-name + (datum->syntax #'name + (string->symbol (format "make-~a" (syntax->datum #'name))))]) + #'(begin + (struct name . rest) + (define make-name name)))]))) diff --git a/racket/src/cs/rumble/symbol.ss b/racket/src/cs/rumble/symbol.ss new file mode 100644 index 0000000000..deedad4cb9 --- /dev/null +++ b/racket/src/cs/rumble/symbol.ss @@ -0,0 +1,53 @@ + +(define gensym + (case-lambda + [() (chez:gensym)] + [(s) (cond + [(string? s) (chez:gensym (string->immutable-string s))] + [(symbol? s) (chez:gensym (chez:symbol->string s))] + [else (raise-argument-error + 'gensym + "(or/c symbol? string?)" + s)])])) + +(define/who (symbol-interned? s) + (check who symbol? s) + (not (gensym? s))) + +(define unreadable-unique-name "gr8mwsuasnvzbl9jjo6e9b-") + +(define/who (symbol-unreadable? s) + (check who symbol? s) + (and (gensym? s) + (equal? (gensym->unique-string s) + (string-append unreadable-unique-name (symbol->string s))))) + +(define/who (symbol->string s) + (check who symbol? s) + (string-copy (chez:symbol->string s))) + +(define/who (string->uninterned-symbol str) + (check who string? str) + (chez:gensym (string->immutable-string str))) + +(define/who (string->unreadable-symbol str) + (check who string? str) + (chez:gensym (string->immutable-string str) + (string-append unreadable-unique-name str))) + +(define/who symbolstring a) + (symbol->string b))] + [(a . as) + (check who symbol? a) + (let loop ([a a] [as as] [r #t]) + (cond + [(null? as) r] + [else + (let ([b (car as)]) + (check who symbol? b) + (loop b (cdr as) (and r (symbol (fixnum-width) 32) 64 32)] + [(gc) 'cs] + [(link) 'framework] + [(machine) "localhost info..."] + [(so-suffix) (case (machine-type) + [(a6osx ta6osx i3osx ti3osx) (string->utf8 ".dylib")] + [(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")] + [else (string->utf8 ".so")])] + [(so-mode) 'local] + [(fs-change) '#(#f #f #f #f)] + [(cross) 'infer] + [else (raise-argument-error 'system-type + (string-append + "(or/c 'os 'word 'vm 'gc 'link 'machine\n" + " 'so-suffix 'so-mode 'fs-change 'cross)") + mode)])) + +(define (system-path-convention-type) + (case (machine-type) + [(a6nt ta6nt i3nt ti3nt) 'windows] + [else 'unix])) + +(define system-library-subpath-string + (case (machine-type) + [(a6nt ta6nt) "win32\\x86_64"] + [(i3nt ti3nt) "win32\\i386"] + [(a6osx ta6osx) (if unix-style-macos? "x86_64-darwin" "x86_64-macosx")] + [(i3osx ti3osx) (if unix-style-macos? "i386-darwin" "i386-macosx")] + [(a6le ta6le) "x86_64-linux"] + [(i3le ti3le) "i386-linux"] + [(arm32le tarm32le) "arm-linux"] + [(ppc32le tppc32le) "ppc-linux"] + [(i3ob ti3ob) "i386-openbsd"] + [(a6ob ta6ob) "x86_64-openbsd"] + [(i3ob ti3ob) "i386-openbsd"] + [(a6fb ta6fb) "x86_64-freebsd"] + [(i3fb ti3fb) "i386-freebsd"] + [(a6nb ta6nb) "x86_64-netbsd"] + [(i3nb ti3nb) "i386-netbsd"] + [(a6s2 ta6s2) "x86_64-solaris"] + [(i3s2 ti3s2) "i386-solaris"] + [else "unix"])) diff --git a/racket/src/cs/rumble/thread-cell.ss b/racket/src/cs/rumble/thread-cell.ss new file mode 100644 index 0000000000..af92980a8d --- /dev/null +++ b/racket/src/cs/rumble/thread-cell.ss @@ -0,0 +1,38 @@ +;; A "thread cell" is actually an "engine cell" at the Rumble level + +(define-record-type (thread-cell create-thread-cell thread-cell?) + (fields (mutable default-value) ; declare mutable so allocated each time + preserved?)) + +(define make-thread-cell + (case-lambda + [(v) (make-thread-cell v #f)] + [(v preserved?) (create-thread-cell v (and preserved? #t))])) + +(define/who (thread-cell-ref c) + (check who thread-cell? c) + (let* ([t (current-engine-thread-cell-values)] + [v (if t + (hashtable-ref t c none) + none)]) + (cond + [(eq? v none) + (thread-cell-default-value c)] + [else v]))) + +(define/who (thread-cell-set! c v) + (check who thread-cell? c) + (hashtable-set! (current-engine-thread-cell-values) + c + v)) + +;; ---------------------------------------- + +(define-record thread-cell-values (t)) + +(define/who current-preserved-thread-cell-values + (case-lambda + [() (make-thread-cell-values (new-engine-thread-cell-values))] + [(tcvs) + (check who thread-cell-values? tcvs) + (set-current-engine-thread-cell-values! (thread-cell-values-t tcvs))])) diff --git a/racket/src/cs/rumble/time.ss b/racket/src/cs/rumble/time.ss new file mode 100644 index 0000000000..b679dd3bbd --- /dev/null +++ b/racket/src/cs/rumble/time.ss @@ -0,0 +1,136 @@ +(define-struct date (second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset) + :guard (lambda (second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset + who) + (check-integer who 0 60 second) + (check-integer who 0 59 minute) + (check-integer who 0 23 hour) + (check-integer who 1 31 day) + (check-integer who 1 12 month) + (check who exact-integer? year) + (check-integer who 0 6 week-day) + (check-integer who 0 365 year-day) + (check who boolean? dst?) + (check who exact-integer? time-zone-offset) + (values second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset))) + +(define-struct date* date (nanosecond time-zone-name) + :guard (lambda (second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset + nanosecond + time-zone-name + who) + (check-integer who 0 999999999 nanosecond) + (check who string? time-zone-name) + (values second + minute + hour + day + month + year + week-day + year-day + dst? + time-zone-offset + nanosecond + (string->immutable-string time-zone-name)))) + +;; Direct constructor to avoid checks: +(define make-date*/direct + (record-constructor (make-record-constructor-descriptor struct:date* #f #f))) + +(define (time->ms t) + (+ (* 1000. (time-second t)) + (/ (time-nanosecond t) 1000000.))) + +(define (time-apply f extra) + (let ([stats (statistics)]) + (call-with-values (lambda () (apply f extra)) + (lambda args + (let ([new-stats (statistics)]) + (values + args + (inexact->exact (floor (time->ms + (time-difference (sstats-cpu new-stats) + (sstats-cpu stats))))) + (inexact->exact (floor (time->ms + (time-difference (sstats-real new-stats) + (sstats-real stats))))) + (inexact->exact (floor (time->ms + (time-difference (sstats-gc-cpu new-stats) + (sstats-gc-cpu stats))))))))))) + +(define (current-gc-milliseconds) + (let ([stats (statistics)]) + (inexact->exact (floor (time->ms (sstats-gc-cpu stats)))))) + +(define (current-milliseconds) + (inexact->exact (floor (current-inexact-milliseconds)))) + +(define (current-inexact-milliseconds) + (time->ms (current-time 'time-utc))) + +(define (current-seconds) + (let ((t (current-time 'time-utc))) + (time-second t))) + +(define/who seconds->date + (case-lambda + [(s) (seconds->date s #t)] + [(s local?) + (check who real? s) + (let* ([s (inexact->exact s)] + [tm (make-time 'time-utc + (floor (* (- s (floor s)) 1000000000)) + (floor s))] + [d (if local? + (time-utc->date tm) + (time-utc->date tm 0))]) + (make-date*/direct (chez:date-second d) + (chez:date-minute d) + (chez:date-hour d) + (chez:date-day d) + (chez:date-month d) + (chez:date-year d) + (chez:date-week-day d) + (chez:date-year-day d) + (chez:date-dst? d) + (date-zone-offset d) + (date-nanosecond d) + (or (date-zone-name d) utc-string)))])) + +(define utc-string (string->immutable-string "UTC")) diff --git a/racket/src/cs/rumble/unsafe.ss b/racket/src/cs/rumble/unsafe.ss new file mode 100644 index 0000000000..434a2a1418 --- /dev/null +++ b/racket/src/cs/rumble/unsafe.ss @@ -0,0 +1,147 @@ +(define unsafe-car #3%car) +(define unsafe-cdr #3%cdr) +(define unsafe-list-tail #3%list-tail) +(define unsafe-list-ref #3%list-ref) + +(define unsafe-fx+ #3%fx+) +(define unsafe-fx- #3%fx-) +(define unsafe-fx* #3%fx*) +(define unsafe-fxquotient #3%fxquotient) +(define unsafe-fxremainder #3%fxremainder) +(define unsafe-fxmodulo #3%fxmodulo) +(define unsafe-fxabs #3%fxabs) +(define unsafe-fxand #3%fxand) +(define unsafe-fxior #3%fxior) +(define unsafe-fxxor #3%fxxor) +(define unsafe-fxnot #3%fxnot) +(define unsafe-fxrshift #3%fxarithmetic-shift-right) +(define unsafe-fxlshift #3%fxarithmetic-shift-left) + +(define unsafe-fx= #3%fx=) +(define unsafe-fx< #3%fx<) +(define unsafe-fx> #3%fx>) +(define unsafe-fx>= #3%fx>=) +(define unsafe-fx<= #3%fx<=) +(define unsafe-fxmin #3%fxmin) +(define unsafe-fxmax #3%fxmax) + +(define unsafe-fl+ #3%fl+) +(define unsafe-fl- #3%fl-) +(define unsafe-fl* #3%fl*) +(define unsafe-fl/ #3%fl/) +(define unsafe-flabs #3%flabs) + +(define unsafe-fl= #3%fl=) +(define unsafe-fl< #3%fl<) +(define unsafe-fl> #3%fl>) +(define unsafe-fl>= #3%fl>=) +(define unsafe-fl<= #3%fl<=) +(define unsafe-flmin #3%flmin) +(define unsafe-flmax #3%flmax) + +(define unsafe-fx->fl #3%fixnum->flonum) +(define unsafe-fl->fx #3%flonum->fixnum) + +(define unsafe-flround #3%flround) +(define unsafe-flfloor #3%flfloor) +(define unsafe-flceiling #3%flceiling) +(define unsafe-fltruncate #3%fltruncate) + +(define unsafe-flsin #3%flsin) +(define unsafe-flcos #3%flcos) +(define unsafe-fltan #3%fltan) +(define unsafe-flasin #3%flasin) +(define unsafe-flacos #3%flacos) +(define unsafe-flatan #3%flatan) +(define unsafe-fllog #3%fllog) +(define unsafe-flexp #3%flexp) +(define unsafe-flsqrt #3%flsqrt) +(define unsafe-flexpt #3%flexpt) + +(define (unsafe-flrandom gen) (random gen)) + +(define unsafe-vector*-length #3%vector-length) +(define unsafe-vector*-ref #3%vector-ref) +(define unsafe-vector*-set! #3%vector-set!) +(define unsafe-vector*-cas! #3%vector-cas!) + +(define unsafe-unbox* #3%unbox) +(define unsafe-set-box*! #3%set-box!) +(define unsafe-box*-cas! #3%box-cas!) + +(define unsafe-bytes-length #3%bytevector-length) +(define unsafe-bytes-ref #3%bytevector-u8-ref) +(define unsafe-bytes-set! #3%bytevector-u8-set!) + +(define unsafe-string-length #3%string-length) +(define unsafe-string-ref #3%string-ref) +(define unsafe-string-set! #3%string-set!) + +(define unsafe-fxvector-length #3%fxvector-length) +(define unsafe-fxvector-ref #3%fxvector-ref) +(define unsafe-fxvector-set! #3%fxvector-set!) + +(define (unsafe-s16vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-s16-native-ref mem k) + (foreign-ref 'int16 mem k)))) +(define (unsafe-s16vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-s16-native-set! mem k v) + (foreign-set! 'int16 mem k v)))) + +(define (unsafe-u16vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-u16-native-ref mem k) + (foreign-ref 'uint16 mem k)))) +(define (unsafe-u16vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-u16-native-set! mem k v) + (foreign-set! 'uint16 mem k v)))) + +(define (unsafe-f64vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-ref mem k) + (foreign-ref 'double mem k)))) +(define (unsafe-f64vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-set! mem k v) + (foreign-set! 'double mem k v)))) + +;; FIXME +(define (unsafe-f80vector-ref cptr k) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-ref mem k) + (foreign-ref 'double mem k)))) +(define (unsafe-f80vector-set! cptr k v) + (let ([mem (cpointer-memory cptr)]) + (if (bytes? mem) + (bytevector-ieee-double-native-set! mem k v) + (foreign-set! 'double mem k v)))) + +(define (unsafe-make-flrectangular r i) + (#3%make-rectangular r i)) +(define (unsafe-flreal-part c) + (#3%real-part c)) +(define (unsafe-flimag-part c) + (#3%imag-part c)) + +(define unsafe-undefined (let ([p (make-record-type "undefined" '())]) + ((record-constructor p)))) + +(define (check-not-unsafe-undefined v sym) + (when (eq? v unsafe-undefined) + (raise-arguments-error sym "undefined;\n cannot use before initialization")) + v) + +(define (check-not-unsafe-undefined/assign v sym) + (when (eq? v unsafe-undefined) + (raise-arguments-error sym "assignment disallowed;\n cannot assign before initialization")) + v) diff --git a/racket/src/cs/rumble/variable.ss b/racket/src/cs/rumble/variable.ss new file mode 100644 index 0000000000..32e97db325 --- /dev/null +++ b/racket/src/cs/rumble/variable.ss @@ -0,0 +1,22 @@ +;; A "variable" is a linklet import or export + +(define undefined (gensym "undefined")) + +(define-record-type variable (fields (mutable val) name)) + +(define (variable-set! var val) + (variable-val-set! var val)) + +(define (variable-ref var) + (define v (variable-val var)) + (if (eq? v undefined) + (raise-undefined var) + v)) + +(define (raise-undefined var) + (raise + (|#%app| + exn:fail:contract:variable + (string-append (symbol->string (variable-name var)) + ": undefined;\n cannot reference undefined identifier") + (current-continuation-marks)))) diff --git a/racket/src/cs/rumble/vector.ss b/racket/src/cs/rumble/vector.ss new file mode 100644 index 0000000000..f9be7f3ac9 --- /dev/null +++ b/racket/src/cs/rumble/vector.ss @@ -0,0 +1,400 @@ +(define (vector-immutable . args) + (if (null? args) + (vector->immutable-vector '#()) + (let ([vec (apply vector args)]) + (#%$vector-set-immutable! vec) + vec))) + +;; ---------------------------------------- + +(define (vector? v) + (or (#%vector? v) + (and (impersonator? v) + (#%vector? (impersonator-val v))))) + +(define (mutable-vector? v) + (or (#%mutable-vector? v) + (and (impersonator? v) + (#%mutable-vector? (impersonator-val v))))) + +;; ---------------------------------------- + +(define-record vector-chaperone chaperone (ref set)) +(define-record vector-impersonator impersonator (ref set)) + +(define/who (chaperone-vector vec ref set . props) + (check who vector? vec) + (do-impersonate-vector who make-vector-chaperone vec ref set + make-props-chaperone props)) + +(define/who (impersonate-vector vec ref set . props) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec) + (do-impersonate-vector who make-vector-impersonator vec ref set + make-props-impersonator props)) + +(define (do-impersonate-vector who make-vector-impersonator vec ref set + make-props-impersonator props) + (check who (procedure-arity-includes/c 3) :or-false ref) + (check who (procedure-arity-includes/c 3) :or-false set) + (check-vector-wrapper-consistent who ref set) + (let ([val (if (impersonator? vec) + (impersonator-val vec) + vec)] + [props (add-impersonator-properties who + props + (if (impersonator? vec) + (impersonator-props vec) + empty-hasheq))]) + (if (or ref set) + (make-vector-impersonator val vec props ref set) + (make-props-impersonator val vec props)))) + +(define (set-vector-impersonator-hash!) + (record-type-hash-procedure (record-type-descriptor vector-chaperone) + (lambda (c hash-code) + (hash-code (vector-copy c)))) + (record-type-hash-procedure (record-type-descriptor vector-impersonator) + (lambda (i hash-code) + (hash-code (vector-copy i))))) + +(define (check-vector-wrapper-consistent who ref set) + (unless (eq? (not ref) (not set)) + (raise-arguments-error who + "accessor and mutator wrapper must be both `#f` or neither `#f`" + "accessor wrapper" ref + "mutator wrapper" set))) + +;; ---------------------------------------- + +(define-record vector*-chaperone vector-chaperone ()) +(define-record vector*-impersonator vector-impersonator ()) + +(define/who (chaperone-vector* vec ref set . props) + (check who vector? vec) + (do-impersonate-vector* who make-vector*-chaperone vec ref set + make-props-chaperone props)) + +(define/who (impersonate-vector* vec ref set . props) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec) + (do-impersonate-vector* who make-vector*-impersonator vec ref set + make-props-impersonator props)) + +(define (do-impersonate-vector* who make-vector*-impersonator vec ref set + make-props-impersonator props) + (check who (procedure-arity-includes/c 4) :or-false ref) + (check who (procedure-arity-includes/c 4) :or-false set) + (check-vector-wrapper-consistent who ref set) + (let ([val (if (impersonator? vec) + (impersonator-val vec) + vec)] + [props (add-impersonator-properties who + props + (if (impersonator? vec) + (impersonator-props vec) + empty-hasheq))]) + (if (or ref set) + (make-vector*-impersonator val vec props ref set) + (make-props-impersonator val vec props)))) + +;; ---------------------------------------- + +(define-record vector-unsafe-chaperone chaperone (vec)) +(define-record vector-unsafe-impersonator impersonator (vec)) + +(define/who (unsafe-impersonate-vector vec alt-vec . props) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec) + (check who (lambda (p) (and (vector? p) (not (impersonator? p)))) + :contract "(and/c vector? (not/c impersonator?))" + alt-vec) + (do-unsafe-impersonate-vector who make-vector-unsafe-impersonator vec alt-vec props)) + +(define/who (unsafe-chaperone-vector vec alt-vec . props) + (check who vector? vec) + (check who (lambda (p) (and (vector? p) (not (impersonator? p)))) + :contract "(and/c vector? (not/c impersonator?))" + alt-vec) + (do-unsafe-impersonate-vector who make-vector-unsafe-chaperone vec alt-vec props)) + +(define (do-unsafe-impersonate-vector who make-vector-unsafe-impersonator vec alt-vec props) + (let ([val (if (impersonator? vec) + (impersonator-val vec) + vec)] + [props (add-impersonator-properties who + props + (if (impersonator? vec) + (impersonator-props vec) + empty-hasheq))]) + (make-vector-unsafe-impersonator val vec props alt-vec))) + +;; ---------------------------------------- + +(define (vector-length vec) + (if (#%vector? vec) + (#3%vector-length vec) + (pariah (impersonate-vector-length vec)))) + +(define (unsafe-vector-length vec) + (vector-length vec)) + +(define (vector*-length vec) + (#2%vector-length vec)) + +(define (impersonate-vector-length vec) + (if (and (impersonator? vec) + (#%vector? (impersonator-val vec))) + (cond + [(vector-unsafe-chaperone? vec) + (#%vector-length (vector-unsafe-chaperone-vec vec))] + [(vector-unsafe-impersonator? vec) + (#%vector-length (vector-unsafe-impersonator-vec vec))] + [else + (#%vector-length (impersonator-val vec))]) + ;; Let primitive report the error: + (#2%vector-length vec))) + +;; ---------------------------------------- + +(define (vector-ref vec idx) + (if (#%vector? vec) + (#2%vector-ref vec idx) + (pariah (impersonate-vector-ref vec idx)))) + +(define (unsafe-vector-ref vec idx) + (if (#%vector? vec) + (#3%vector-ref vec idx) + (pariah (impersonate-vector-ref vec idx)))) + +(define (vector*-ref vec idx) + (#2%vector-ref vec idx)) + +(define (impersonate-vector-ref orig idx) + (if (and (impersonator? orig) + (#%vector? (impersonator-val orig))) + (let loop ([o orig]) + (cond + [(#%vector? o) (#%vector-ref o idx)] + [(vector-chaperone? o) + (let* ([o-next (impersonator-next o)] + [val (loop o-next)] + [new-val (if (vector*-chaperone? o) + ((vector-chaperone-ref o) orig o-next idx val) + ((vector-chaperone-ref o) o-next idx val))]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'vector-ref + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + new-val)] + [(vector-impersonator? o) + (let* ([o-next (impersonator-next o)] + [val (loop o-next)]) + (if (vector*-impersonator? o) + ((vector-impersonator-ref o) orig o-next idx val) + ((vector-impersonator-ref o) o-next idx val)))] + [(vector-unsafe-impersonator? o) + (vector-ref (vector-unsafe-impersonator-vec o) idx)] + [(vector-unsafe-chaperone? o) + (vector-ref (vector-unsafe-chaperone-vec o) idx)] + [else (loop (impersonator-next o))])) + ;; Let primitive report the error: + (#2%vector-ref orig idx))) + +;; ---------------------------------------- + +(define (vector-set! vec idx val) + (if (#%vector? vec) + (#2%vector-set! vec idx val) + (pariah (impersonate-vector-set! vec idx val)))) + +(define (unsafe-vector-set! vec idx val) + (if (#%vector? vec) + (#3%vector-set! vec idx val) + (pariah (impersonate-vector-set! vec idx val)))) + +(define (vector*-set! vec idx val) + (#2%vector-set! vec idx val)) + +(define (impersonate-vector-set! orig idx val) + (cond + [(not (and (impersonator? orig) + (mutable-vector? (impersonator-val orig)))) + ;; Let primitive report the error: + (#2%vector-set! orig idx val)] + [(or (not (exact-nonnegative-integer? idx)) + (>= idx (vector-length (impersonator-val orig)))) + ;; Let primitive report the index error: + (#2%vector-set! (impersonator-val orig) idx val)] + [else + (let loop ([o orig] [val val]) + (cond + [(#%vector? o) (#2%vector-set! o idx val)] + [else + (let ([next (impersonator-next o)]) + (cond + [(vector-chaperone? o) + (let ([new-val (if (vector*-chaperone? o) + ((vector-chaperone-set o) orig next idx val) + ((vector-chaperone-set o) next idx val))]) + (unless (chaperone-of? new-val val) + (raise-arguments-error 'vector-set! + "chaperone produced a result that is not a chaperone of the original result" + "chaperone result" new-val + "original result" val)) + (loop next val))] + [(vector-impersonator? o) + (loop next + (if (vector*-impersonator? o) + ((vector-impersonator-set o) orig next idx val) + ((vector-impersonator-set o) next idx val)))] + [(vector-unsafe-impersonator? o) + (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)] + [(vector-unsafe-chaperone? o) + (#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)] + [else (loop next val)]))]))])) + +;; ---------------------------------------- + +(define/who (vector->list vec) + (cond + [(#%vector? vec) + (#3%vector->list vec)] + [(vector? vec) + (let ([len (vector-length vec)]) + (let loop ([i len] [accum '()]) + (cond + [(fx= i 0) accum] + [else + (let ([i (fx- i 1)]) + (loop i (cons (vector-ref vec i) accum)))])))] + [else + (raise-argument-error who "vector?" vec)])) + +;; ---------------------------------------- + +(define/who (vector-copy vec) + (cond + [(#%vector? vec) + (#3%vector-copy vec)] + [(vector? vec) + (let* ([len (vector-length vec)] + [vec2 (make-vector len)]) + (vector-copy! vec2 0 vec) + vec2)] + [else + (raise-argument-error who "vector?" vec)])) + +(define/who vector-copy! + (case-lambda + [(dest d-start src) + (vector-copy! dest d-start src 0 (and (vector? src) (vector-length src)))] + [(src s-start dest d-start) + (vector-copy! dest d-start src s-start (and (vector? src) (vector-length src)))] + [(dest d-start src s-start s-end) + (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" dest) + (check who exact-nonnegative-integer? d-start) + (check who vector? src) + (check who exact-nonnegative-integer? s-start) + (check who exact-nonnegative-integer? s-end) + (let ([d-len (vector-length dest)]) + (check-range who "vector" dest d-start #f d-len) + (check-range who "vector" src s-start s-end (vector-length src)) + (let ([len (fx- s-end s-start)]) + (check-space who "vector" d-start d-len len) + (cond + [(and (#%vector? src) (#%vector? dest)) + (vector*-copy! dest d-start src s-start s-end)] + [(and (eq? (strip-impersonator dest) + (strip-impersonator src)) + (< d-start s-start)) + ;; Need to copy from low to high to be memmove-like + (let loop ([i 0]) + (unless (fx= i len) + (vector-set! dest (fx+ d-start i) (vector-ref src (fx+ s-start i))) + (loop (fx+ i 1))))] + [else + (let loop ([i len]) + (unless (fx= 0 i) + (let ([i (fx1- i)]) + (vector-set! dest (fx+ d-start i) (vector-ref src (fx+ s-start i))) + (loop i))))])))])) + +;; Like `vector-copy!`, but doesn't work on impersonators, and doesn't +;; add its own tests on the vector or range (so unsafe if Rumble is +;; compiled as unsafe) +(define/who vector*-copy! + (case-lambda + [(dest dest-start src) + (vector*-copy! dest dest-start src 0 (#%vector-length src))] + [(src src-start dest dest-start) + (vector*-copy! dest dest-start src src-start (#%vector-length src))] + [(dest dest-start src src-start src-end) + (let ([len (fx- src-end src-start)]) + (cond + [(and (eq? (strip-impersonator dest) + (strip-impersonator src)) + (< dest-start src-start)) + ;; Need to copy from low to high to be memmove-like + (let loop ([i 0]) + (unless (fx= len i) + (#%vector-set! dest (fx+ dest-start i) (vector-ref src (fx+ src-start i))) + (loop (fx+ i 1))))] + [else + (let loop ([i len]) + (unless (fx= 0 i) + (let ([i (fx1- i)]) + (#%vector-set! dest (fx+ dest-start i) (vector-ref src (fx+ src-start i))) + (loop i))))]))])) + +(define/who vector->values + (case-lambda + [(vec) + (check who vector? vec) + (let ([len (vector-length vec)]) + (cond + [(fx= len 0) (values)] + [(fx= len 1) (vector-ref vec 0)] + [(fx= len 2) (values (vector-ref vec 0) (vector-ref vec 1))] + [(fx= len 3) (values (vector-ref vec 0) (vector-ref vec 1) (vector-ref vec 2))] + [else (chez:apply values (vector->list vec))]))] + [(vec start) + (vector->values vec start (and (vector? vec) (vector-length vec)))] + [(vec start end) + (check who vector? vec) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who "vector" vec start end (vector-length vec)) + (chez:apply values + (let loop ([start start]) + (cond + [(fx= start end) null] + [else (cons (vector-ref vec start) + (loop (fx1+ start)))])))])) + +(define/who (vector-fill! vec v) + (cond + [(#%vector? vec) + (#3%vector-fill! vec v)] + [(vector? vec) + (check who mutable-vector? :contract "(and/c vector? (not immutable?))" v) + (let ([len (vector-length vec)]) + (let loop ([i 0]) + (unless (= i len) + (vector-set! vec i v) + (loop (fx1+ i)))))] + [else + (raise-argument-error who "vector?" vec)])) + +(define/who (vector->immutable-vector v) + (cond + [(#%vector? v) + (#3%vector->immutable-vector v)] + [(vector? v) + (if (mutable-vector? v) + (#3%vector->immutable-vector + (vector-copy v)) + v)] + [else + (raise-argument-error who "vector?" v)])) + +(define shared-fxvector fxvector) +(define make-shared-fxvector make-fxvector) diff --git a/racket/src/cs/rumble/version.ss b/racket/src/cs/rumble/version.ss new file mode 100644 index 0000000000..92813364d2 --- /dev/null +++ b/racket/src/cs/rumble/version.ss @@ -0,0 +1,25 @@ + +(define-syntax (extract-version-string stx) + (chez:call-with-input-file + "../racket/src/schvers.h" + (lambda (i) + (let ([to-find "#define MZSCHEME_VERSION \""]) + (let loop ([pos 0]) + (cond + [(= pos (string-length to-find)) + (list->string + (let loop () + (let ([ch (chez:read-char i)]) + (if (char=? ch #\") + '() + (cons ch (loop))))))] + [else + (let ([ch (chez:read-char i)]) + (cond + [(char=? ch (string-ref to-find pos)) + (loop (add1 pos))] + [else + (loop 0)]))])))))) + +(define (version) (extract-version-string)) +(define (banner) (string-append "Welcome to Racket " (version) "\n")) diff --git a/racket/src/cs/rumble/virtual-register.ss b/racket/src/cs/rumble/virtual-register.ss new file mode 100644 index 0000000000..ddf2b286ba --- /dev/null +++ b/racket/src/cs/rumble/virtual-register.ss @@ -0,0 +1,34 @@ +;; We get a small number of virtual registers for fast, +;; pthread-specific bindings. + +;; The last virtual register is reserved for use by the thread system +(meta define num-reserved-virtual-registers 1) + +(meta define virtual-register-initial-values '()) + +(define-syntax (define-virtual-register stx) + (syntax-case stx () + [(_ id init-val) + (with-syntax ([pos (datum->syntax #'here (length virtual-register-initial-values))]) + (set! virtual-register-initial-values (cons #'init-val virtual-register-initial-values)) + (when (>= (length virtual-register-initial-values) (- (virtual-register-count) + num-reserved-virtual-registers)) + (syntax-error stx "too many virtual-register definitions:")) + #`(define-syntax id + (syntax-rules () + [(_) (virtual-register pos)] + [(_ v) (set-virtual-register! pos v)])))])) + +(define-syntax (define-virtual-registers-init stx) + (syntax-case stx () + [(_ id) + (with-syntax ([(init ...) + (let loop ([l (reverse virtual-register-initial-values)] + [pos 0]) + (cond + [(null? l) '()] + [else (cons (with-syntax ([pos (datum->syntax #'here pos)] + [init (car l)]) + #'(set-virtual-register! pos init)) + (loop (cdr l) (add1 pos)))]))]) + #'(define (id) init ...))])) diff --git a/racket/src/cs/rumble/will-executor.ss b/racket/src/cs/rumble/will-executor.ss new file mode 100644 index 0000000000..7946b33522 --- /dev/null +++ b/racket/src/cs/rumble/will-executor.ss @@ -0,0 +1,93 @@ + +;; Implements a variant of will executors with polling and a callback +;; for when a will becomes ready + +(define the-will-guardian (make-guardian)) +(define the-stubborn-will-guardian (make-guardian #t)) + +;; Guardian callbacks are called fifo, but will executors are called +;; lifo. The `will-stacks` tables map a finalized value to a list +;; of finalizers, where each finalizer is an ephemeron pairing a will +;; executor with a will function (so that the function is not retained +;; if the will executor is dropped) +(define the-will-stacks (make-weak-eq-hashtable)) +(define the-stubborn-will-stacks (make-weak-eq-hashtable)) + +(define-record-type (will-executor create-will-executor will-executor?) + (fields guardian will-stacks (mutable ready) notify)) + +(define (make-will-executor notify) + (create-will-executor the-will-guardian the-will-stacks '() notify)) + +;; A "stubborn" will executor corresponds to an ordered guardian. It +;; doesn't need to make any guarantees about order for multiple +;; registrations, so use a fresh guardian each time. +(define (make-stubborn-will-executor notify) + (create-will-executor the-stubborn-will-guardian the-stubborn-will-stacks '() notify)) + +(define/who (will-register executor v proc) + (check who will-executor? executor) + (check who (procedure-arity-includes/c 1) proc) + (disable-interrupts) + (let ([l (hashtable-ref (will-executor-will-stacks executor) v '())] + ;; By using an ephemeron pair, if the excutor becomes + ;; unreachable, then we can drop the finalizer procedure. That + ;; pattern prevents unbreakable cycles by an untrusted process + ;; that has no access to a will executor that outlives the + ;; process. + [e+proc (ephemeron-cons executor proc)]) + (hashtable-set! (will-executor-will-stacks executor) v (cons e+proc l)) + (when (null? l) + ((will-executor-guardian executor) v))) + (enable-interrupts) + (void)) + +;; Returns #f or a pair: procedure and value +(define/who (will-try-execute executor) + (check who will-executor? executor) + (disable-interrupts) + (poll-guardian (will-executor-guardian executor) + (will-executor-will-stacks executor)) + (let ([l (will-executor-ready executor)]) + (cond + [(pair? l) + (will-executor-ready-set! executor (cdr l)) + (enable-interrupts) + (car l)] + [else + (enable-interrupts) + #f]))) + +;; Call with interrupts disabled or from the thread scheduler +(define (poll-guardian guardian will-stacks) + ;; Poll the guardian (which is shared among will executors) + ;; for ready values, and add any ready value to the receiving will + ;; executor + (let loop () + (let ([v (guardian)]) + (when v + (let we-loop ([l (hashtable-ref will-stacks v '())]) + (when (pair? l) + (let* ([e+proc (car l)] + [e (car e+proc)] + [proc (cdr e+proc)] + [l (cdr l)]) + (cond + [(eq? #!bwp e) + ;; The will executor became inaccesible, so continue looking + (we-loop l)] + [else + (cond + [(null? l) + (hashtable-delete! will-stacks v)] + [else + ;; Re-finalize for the next will registration + (hashtable-set! will-stacks v l) + (guardian v)]) + ((will-executor-notify e)) + (will-executor-ready-set! e (cons (cons proc v) (will-executor-ready e)))])))) + (loop))))) + +(define (poll-will-executors) + (poll-guardian the-will-guardian the-will-stacks) + (poll-guardian the-stubborn-will-guardian the-stubborn-will-stacks)) diff --git a/racket/src/cs/schemify.sls b/racket/src/cs/schemify.sls new file mode 100644 index 0000000000..6758675837 --- /dev/null +++ b/racket/src/cs/schemify.sls @@ -0,0 +1,66 @@ +(library (schemify) + (export schemify-linklet + lift-in-schemified-linklet + jitify-schemified-linklet + interpretable-jitified-linklet + interpret-linklet + linklet-bigger-than? + prim-knowns + known-procedure + a-known-constant) + (import (chezpart) + (rename (rumble) + [correlated? rumble:correlated?] + [correlated-e rumble:correlated-e] + [correlated-property rumble:correlated-property]) + (regexp) + (io)) + + ;; Bridge for flattened "schemify/wrap.rkt" + ;; and "schemify/wrap-annotation.rkt" + (define (primitive-table name) + (case name + [(|#%kernel|) + ;; Normally, schemify is schemified so that these are accessed + ;; directly, instead: + (hash 'syntax? rumble:correlated? + 'syntax-e rumble:correlated-e + 'syntax-property rumble:correlated-property)] + [else #f])) + + ;; For direct access by schemified schemify: + (define syntax? rumble:correlated?) + (define syntax-e rumble:correlated-e) + (define syntax-property rumble:correlated-property) + + (include "include.ss") + (include-generated "schemify.scm") + + (define prim-knowns + (let-syntax ([gen + (lambda (stx) + (include-generated "known.scm") + ;; Constructed a quoted literal hash table that + ;; maps symbols to `known` prefabs + (let ([known-l '()]) + (define-syntax define-primitive-table + (syntax-rules () + [(_ id [prim known] ...) + (begin (set! known-l (cons (cons 'prim known) known-l)) + ...)])) + (include "primitive/kernel.ss") + (include "primitive/unsafe.ss") + (include "primitive/flfxnum.ss") + (include "primitive/paramz.ss") + (include "primitive/extfl.ss") + (include "primitive/network.ss") + (include "primitive/futures.ss") + (include "primitive/place.ss") + (include "primitive/foreign.ss") + (include "primitive/linklet.ss") + (let loop ([l known-l] [knowns (hasheq)]) + (if (null? l) + #`(quote #,knowns) + (loop (cdr l) + (hash-set knowns (caar l) (cdar l)))))))]) + (gen)))) diff --git a/racket/src/cs/strip.ss b/racket/src/cs/strip.ss new file mode 100644 index 0000000000..88f5fc45f5 --- /dev/null +++ b/racket/src/cs/strip.ss @@ -0,0 +1,6 @@ + +(for-each (lambda (so) + (when (file-exists? so) + (printf "Stripping ~s\n" so) + (strip-fasl-file so so (fasl-strip-options inspector-source source-annotations)))) + (command-line-arguments)) diff --git a/racket/src/cs/thread.sls b/racket/src/cs/thread.sls new file mode 100644 index 0000000000..8a752a0b42 --- /dev/null +++ b/racket/src/cs/thread.sls @@ -0,0 +1,121 @@ +(library (thread) + (export) + (import (rename (chezpart) + [define chez:define]) + (rename (only (chezscheme) + sleep + printf) + [sleep chez:sleep]) + (rename (rumble) + [rumble:break-enabled-key break-enabled-key] + ;; These are extracted via `#%linklet`: + [make-engine rumble:make-engine] + [engine-block rumble:engine-block] + [engine-return rumble:engine-return] + [current-engine-state rumble:current-engine-state] + [make-condition rumble:make-condition] + [condition-wait rumble:condition-wait] + [condition-signal rumble:condition-signal] + [condition-broadcast rumble:condition-broadcast] + [make-mutex rumble:make-mutex] + [mutex-acquire rumble:mutex-acquire] + [mutex-release rumble:mutex-release] + [pthread? rumble:thread?] + [fork-pthread rumble:fork-thread] + [threaded? rumble:threaded?] + [get-thread-id rumble:get-thread-id] + [set-ctl-c-handler! rumble:set-ctl-c-handler!] + [root-continuation-prompt-tag rumble:root-continuation-prompt-tag] + [set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook!])) + + ;; Special handling of `current-atomic`: use the last virtual register. + ;; We rely on the fact that the register's default value is 0. + (define-syntax (define stx) + (syntax-case stx (current-atomic make-pthread-parameter) + [(_ current-atomic (make-pthread-parameter 0)) + (with-syntax ([(_ id _) stx] + [n (datum->syntax #'here (sub1 (virtual-register-count)))]) + #'(define-syntax id + (syntax-rules () + [(_) (virtual-register n)] + [(_ v) (set-virtual-register! n v)])))] + [(_ . rest) #'(chez:define . rest)])) + + (define (exit n) + (chez:exit n)) + + (define (sleep secs) + (define isecs (inexact->exact (floor secs))) + (chez:sleep (make-time 'time-duration + (inexact->exact (floor (* (- secs isecs) 1e9))) + isecs))) + + (define (primitive-table key) + (case key + [(|#%pthread|) + ;; Entries in the `#%pthread` table are referenced more + ;; directly in "compiled/thread.scm". To make that work, the + ;; entries need to be registered as built-in names with the + ;; expander, and they need to be listed in + ;; "primitives/internal.ss". + (hash + 'make-pthread-parameter make-pthread-parameter)] + [(|#%engine|) + (hash + 'make-engine rumble:make-engine + 'engine-block rumble:engine-block + 'engine-return rumble:engine-return + 'current-engine-state (lambda (v) (rumble:current-engine-state v)) + 'set-ctl-c-handler! rumble:set-ctl-c-handler! + 'root-continuation-prompt-tag rumble:root-continuation-prompt-tag + 'poll-will-executors poll-will-executors + 'make-will-executor rumble:make-will-executor + 'make-stubborn-will-executor rumble:make-stubborn-will-executor + 'will-executor? rumble:will-executor? + 'will-register rumble:will-register + 'will-try-execute rumble:will-try-execute + 'break-enabled-key break-enabled-key + 'set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook! + 'continuation-marks rumble:continuation-marks + 'exn:break/non-engine exn:break + 'exn:break:hang-up/non-engine exn:break:hang-up + 'exn:break:terminate/non-engine exn:break:terminate + 'current-process-milliseconds cpu-time + 'poll-async-callbacks poll-async-callbacks + 'disable-interrupts disable-interrupts + 'enable-interrupts enable-interrupts + 'fork-pthread rumble:fork-thread + 'pthread? rumble:thread? + 'get-thread-id rumble:get-thread-id + 'make-condition rumble:make-condition + 'condition-wait rumble:condition-wait + 'condition-signal rumble:condition-signal + 'condition-broadcast rumble:condition-broadcast + 'make-mutex rumble:make-mutex + 'mutex-acquire rumble:mutex-acquire + 'mutex-release rumble:mutex-release + 'threaded? rumble:threaded?)] + [else #f])) + + ;; Tie knots: + (define (check-for-break) (1/check-for-break)) + (define (break-enabled) (1/break-enabled)) + + (include "include.ss") + (include-generated "thread.scm") + + (set-engine-exit-handler! + (lambda (v) + (|#%app| (|#%app| 1/exit-handler) v))) + + (set-scheduler-lock-callbacks! (lambda () (1/make-semaphore 1)) + 1/semaphore-wait + 1/semaphore-post) + + (set-scheduler-atomicity-callbacks! (lambda () + (current-atomic (fx+ (current-atomic) 1))) + (lambda () + (current-atomic (fx- (current-atomic) 1)))) + + (set-future-callbacks! 1/future? 1/current-future + future-block future-wait current-future-prompt)) diff --git a/racket/src/expander/Makefile b/racket/src/expander/Makefile new file mode 100644 index 0000000000..9049caffc0 --- /dev/null +++ b/racket/src/expander/Makefile @@ -0,0 +1,80 @@ +# This makefile can be used directly, in which case it writes to a +# "compiled" subdirectory, or it can be driven by other makefiles that +# redirect to a different build dierctory by setting `BUILDDIR` and +# other variables. + +# Beware that this makefile is used both for GNU make and for nmake! + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Tree for collections: +TREE = ../.. + +# See "boot/read-primitive.rkt" for more info: +KNOT = ++knot read read/api.rkt \ + ++knot read read/primitive-parameter.rkt \ + ++knot read read/readtable-parameter.rkt \ + ++knot read read/readtable.rkt \ + ++knot read read/number.rkt + +# When flattening, replace a dynamic lookup from a primitive table to +# a direct use of the primitive name: +DIRECT = ++direct linklet ++direct kernel + +# The linklet compiler's simple inference cannot tell that this +# module's keyword-function declarations will have no side effect, but +# we promise that it's pure: +PURE = ++pure $(TREE)/collects/racket/private/collect.rkt + +# Set `BUILDDIR` as a prefix on "compiled" output (defaults to empty). +# Set `DEPENDSDIR` as the same sort of prefix in the generated +# makefile-dependency file (also defaults to empty). The `BUILDDIR` +# and `DEPENDSDIR` settings are different, because `BUILDDIR` is +# relative to here, while makefile dependencies may be needed relative +# to makefile driving the one. + +expander: + $(RACO) make bootstrap-run.rkt + $(RACKET) bootstrap-run.rkt -c compiled/cache-src $(KNOT) $(DIRECT) $(PURE) -O $(TREE) + +expander-src: + $(RACO) make bootstrap-run.rkt + $(MAKE) expander-src-generate + +GENERATE_ARGS = -c $(BUILDDIR)compiled/cache-src \ + --check-depends $(BUILDDIR)compiled/expander-dep.rktd \ + ++depend-module bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/expander-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/expander.rktl $(BUILDDIR)compiled/expander.d \ + $(KNOT) $(DIRECT) $(PURE) -k $(TREE) -s -x \ + -o $(BUILDDIR)compiled/expander.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +expander-src-generate: + $(RACKET) bootstrap-run.rkt $(GENERATE_ARGS) + +demo: + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +run: + $(RACO) make run.rkt + $(RACKET) $(RKT_ARGS) run.rkt -c compiled/cache $(ARGS) + +# Like `run`, but with source as compiled (as used for flattening) +run-src: + $(RACO) make bootstrap-run.rkt + $(RACKET) $(RKT_ARGS) bootstrap-run.rkt -s -c compiled/cache-src $(ARGS) + +# Like `run`, but without using a cache for expanded and compiled linklets +run-no-cache: + $(RACO) make run.rkt + $(RACKET) $(RKT_ARGS) run.rkt $(ARGS) + +# Writes the extracted, compiled, decompiled expander to compiled/exp.rkt +decompile: + $(RACO) make bootstrap-run.rkt + $(RACKET) $(RKT_ARGS) bootstrap-run.rkt -c compiled/cache-src $(KNOT) -s -x -D -o compiled/exp.rkt + +.PHONY: expander expander-src expander-src-generate demo run run-no-cache diff --git a/racket/src/expander/README.txt b/racket/src/expander/README.txt new file mode 100644 index 0000000000..3564eacd42 --- /dev/null +++ b/racket/src/expander/README.txt @@ -0,0 +1,240 @@ +This package contains the implementation of Racket's front-end: macro +expander, reader, and module systems. A copy of this implementation is +extracted and built into the Racket executable, so normally this +package's modules are not run directly. The expander or reader can be +run separately, however, and the Racket expander is updated by +modifying this package as it exists in the main Racket Git repository. + +Running: + + % racket demo.rkt + or + % racket bootstrap-demo.rkt + + Runs the examples/tests in "demo.rkt". The tests are not remotely + complete, but they're a quick and useful sanity check. The + "demo.rkt" module uses the somewhat internal interface exported by + `main`, where the expansion, compilation, and evaluation are less + overloaded and more controllable. + + Use the "bootstrap-demo.rkt" when running in an older version of + Racket that is not built with this expander (but that version of + Racket must be new enough to provide a primitive '#%linklet module + as a bootstrapping hook). + + % racket run.rkt -c + or + % racket bootstrap-run.rkt -c + + Runs the expander to load itself from source. Expanded and compiled + modules are stored in , somewhat like bytecode files. + Dependency tracking doesn't take into account the expander itself, + so throw away if the expander changes in a way that you want + reflected in compilation results. + + % racket run.rkt -c -l + % racket run.rkt -c -t + + Runs the expander to load the specified module (instead of the + default module, which is the expander itself). + + When running with a new enough version of Racket that "run.rkt" + works (as opposed to "bootstrap-run.rkt"), the performance of the + expander in this mode should be close to the performance when the + expander is built into the Racket executable. Beware, however, that + "run.rkt" implements just enough of the module loader protocol to + work as a bridge, so module loading and caching can have very + different performance than in an embedding build. + + Beware also that the flags above cause bytecode for the target + module to be cached, so running a second time will not test the + expander a second time. Prime the cache directory with modules that + don't change, and then use `-r` to load a module with a read-only + cache. + + % racket run.rkt -c -f + + Loads the given file as a sequence of top-level forms. + + % racket run.rkt -c -e -l + + Expands the given file, instead of compiling and running it. + + % racket run.rkt -c --linklets -l + + Compiles the given file to a set of linklets in S-expression form, + instead of compiling and running it. + + % racket run.rkt -c -x + + Checks possibility of converting a module to a stand-alone linklet + with no imports --- used mainly to extract the expander itself. + + % racket bootstrap-run.rkt -c -sx -t -o + + Expands and extracts as a single linklet to + . + + % racket bootstrap-run.rkt -c -O /racket + + Compiles the expander to source files in --- note that + "bootstrap-run.rkt" must be used to get source compiles --- and + writes the flattened linklet to "startup.inc" in a Git checkout of + a linklet-based Racket. Be sure to increment the target Racket + version if you change the serialization of syntax objects or the + linklet protocol. + + When you `make`, then "startup.inc" will be automatically compiled + to bytecode for for embedding into the Racket executable. If you + change the expander in a way that makes existing compiled files + invalid, be sure to update "schvers.h". (Updating "schvers.h" is + important both for bytecode files and the makefile/preprocessor + dance that generates the bytecode version of the expander itself.) + + % make + + A shortcut for the above: When this package resides in an existing + in-place build from the main Racket repo, then the makefile uses + that copy of Racket to build the expander and drop a replacement + into the "src" directory. Re-making the Racket tree will then use + the updated expander. You may have to manually discard + "compiled/cache-src" when things change. + + % make demo + % make run ARGS=" ..." + + More shortcuts. Use `make run ARGS=" ..."` as a shorthand for `racket + run.rkt -c compiled/cache ...`. + + See "Makefile" for more information and other shortcuts. + +---------------------------------------- + +Roadmap to the implementation: + + read/ - the readers + demo.rkt - simple examples/tests for the reader + + syntax/ - syntax-object and binding representation + syntax.rkt - syntax-object structure + scope.rkt - scope sets and binding + binding.rkt - binding representations + binding-table.rkt - managing sets of bindings + + namespace/ - namespaces and module instances + + expand/ - expander loop and core forms + + common/ - utilities + module-path.rkt - [resolved] module path [indexes] + performance.rkt - performance instrumentation; enable statistic + gathering and reporting by changing this module + + compile/ - from expanded to S-expression linklet + main.rkt - compiler functions called from "eval/main.rkt" + + eval/ - evaluation + main.rkt - top-level evaluation, with top-level `module` forms as + an important special case; the `compile-to-linklets` + function compiles to a set of S-expression linklets + api.rkt - wrappers that implement `eval`, `compile`, and `expand` + for `racket/base` + + boot/ - internal initialization + handler.rkt - implements the default module name resolver, eval + handler, and compiler handler + ...-primitive.rkt - export built-in functions as modules + + run/ - helpers to drive the expander; not part of the resulting + expander's implementation + linklet.rkt - a bootstrapping implementation of `linklet` by + compilation into `lambda` plus primitives + + extract/ - extracts a module and its dependencies to a single + linklet, especially for extracting the compiler itself + (via "run.rkt"); not part of the resulting expander's + implementation + + main.rkt - installs eval handler, etc.; entry point for directly + running the expander/compiler/evaluator, and the provided + variables of this module become the entry points for the + embedded expander + + demo.rkt - exercises the expander and compiler (uses "main.rkt") + + run.rkt - starts a Racket replacement (uses "main.rkt") + + bootstrap-run.rkt - like "run.rkt", but for a host Racket that + does not include linklet support + + bootstrap-demo.rkt - like "demo.rkt", but for a host Racket that + does not include linklet support + +Beware that names are routinely shadowed when they are provided by +`racket/base` but replaced by the expander's implementation. For +example, `syntax?` is shadowed, and any part of the expander that +needs `syntax?` must import "syntax/syntax.rkt" or +"syntax/checked-syntax.rkt". + +---------------------------------------- + +Implementation guidelines: + + * Do not rely on more than `racket/base` for code that will be + extracted as the compiler implementation. (Relying on more in + "run/" or "extract/" is allowed.) + + * The runtime implementation of the expander must not itself use any + syntax objects or syntax function as provided by the Racket + implementation used to compile the expander. That means, for + example, that the contract system cannot be used in the + implementation of the expander, since the contract system manages + some information with syntax objects at run time. The + expander-extraction process double-checks that the expander is + independent of its host in this way. + + * The runtime implementation of the expander can refer (via + `#%kernel`) to reader primitives that are to be implemented by the + reader that is bundled with the expander. The extraction process + simply redirects those references to the implemented variants. + Beware that adjusting parameters from `#%kernel` will not change + the behavior of the bundled reader during bootrstapping of the + expander (i.e., for bootstrapping, always refer to the parameters + from the implementation in the "read" directory). + +---------------------------------------- + +Some naming conventions: + + s or stx - a syntax object + + sc - a scope + + scs - a set or list of scopes + + id - an identifier (obviously) + + b - a binding; sometimes spelled out as `binding` + + m - a result of syntax matching + + m - a module + + ns - a namespace + + ctx - an expansion context (including the expand-time environment) + + cctx - a compilation context (including a compile-time environment) + + insp - an inspector + + mpi - a module path index + + mod-name - a resolved module path, usually; sometimes used for other + forms of module reference + + c and ec - character and "effective" character (after readtable + mapping) in the reader + + - - like , but specifically one for + ; for example, `m-ns` is a namespace for some module diff --git a/racket/src/expander/boot/core-primitive.rkt b/racket/src/expander/boot/core-primitive.rkt new file mode 100644 index 0000000000..0ad8276f7c --- /dev/null +++ b/racket/src/expander/boot/core-primitive.rkt @@ -0,0 +1,201 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/srcloc.rkt" + "../common/phase.rkt" + (except-in "../syntax/scope.rkt" + syntax-e + bound-identifier=? + syntax-shift-phase-level) + "../namespace/namespace.rkt" + (except-in "../syntax/binding.rkt" + free-identifier=? + identifier-binding + identifier-binding-symbol) + "../namespace/core.rkt" + "../expand/set-bang-trans.rkt" + "../expand/rename-trans.rkt" + "../expand/liberal-def-ctx.rkt" + "../expand/syntax-local.rkt" + "../expand/definition-context.rkt" + "../expand/local-expand.rkt" + "../syntax/api.rkt" + "../syntax/api-taint.rkt" + "../syntax/error.rkt" + "../read/api.rkt" + "../common/module-path.rkt" + "../namespace/variable-reference.rkt" + "../expand/allowed-context.rkt" + "../expand/missing-module.rkt") + +(provide primitive-ids) + +;; Register core primitives: +(define-syntax-rule (add-core-primitives! #:table primitive-ids id ...) + (begin + (define primitive-ids (seteq 'id ...)) + (void + (begin + (add-core-primitive! 'id id) + ...)))) + +(add-core-primitives! #:table primitive-ids + + syntax? + syntax-e + syntax->datum + datum->syntax + + bound-identifier=? + free-identifier=? + free-transformer-identifier=? + free-template-identifier=? + free-label-identifier=? + identifier-binding + identifier-transformer-binding + identifier-template-binding + identifier-label-binding + identifier-binding-symbol + identifier-prune-lexical-context + syntax-debug-info + syntax-track-origin + syntax-shift-phase-level + syntax-source-module + identifier-prune-to-source-module + + syntax-source + syntax-line + syntax-column + syntax-position + syntax-span + syntax->list + syntax-property + syntax-property-preserved? + syntax-property-symbol-keys + syntax-original? + + syntax-tainted? + syntax-arm + syntax-disarm + syntax-rearm + syntax-taint + + raise-syntax-error + struct:exn:fail:syntax + exn:fail:syntax + make-exn:fail:syntax + exn:fail:syntax? + exn:fail:syntax-exprs + struct:exn:fail:syntax:unbound + exn:fail:syntax:unbound + make-exn:fail:syntax:unbound + exn:fail:syntax:unbound? + + current-module-path-for-load + prop:missing-module + exn:missing-module? + exn:missing-module-accessor + struct:exn:fail:filesystem:missing-module + exn:fail:filesystem:missing-module + make-exn:fail:filesystem:missing-module + exn:fail:filesystem:missing-module? + exn:fail:filesystem:missing-module-path + struct:exn:fail:syntax:missing-module + exn:fail:syntax:missing-module + make-exn:fail:syntax:missing-module + exn:fail:syntax:missing-module? + exn:fail:syntax:missing-module-path + + syntax-transforming? + syntax-transforming-with-lifts? + syntax-transforming-module-expression? + syntax-local-transforming-module-provides? + + syntax-local-context + syntax-local-introduce + syntax-local-identifier-as-binding + syntax-local-phase-level + syntax-local-name + + make-syntax-introducer + make-syntax-delta-introducer + + syntax-local-value + syntax-local-value/immediate + + syntax-local-lift-expression + syntax-local-lift-values-expression + syntax-local-lift-context + + syntax-local-lift-module + + syntax-local-lift-require + syntax-local-lift-provide + syntax-local-lift-module-end-declaration + + syntax-local-module-defined-identifiers + syntax-local-module-required-identifiers + syntax-local-module-exports + syntax-local-submodules + + syntax-local-get-shadower + + local-expand + local-expand/capture-lifts + local-transformer-expand + local-transformer-expand/capture-lifts + syntax-local-expand-expression + + internal-definition-context? + syntax-local-make-definition-context + syntax-local-bind-syntaxes + internal-definition-context-binding-identifiers + internal-definition-context-introduce + internal-definition-context-seal + identifier-remove-from-definition-context + + make-set!-transformer + prop:set!-transformer + set!-transformer? + set!-transformer-procedure + + rename-transformer? + prop:rename-transformer + make-rename-transformer + rename-transformer-target + + prop:liberal-define-context + liberal-define-context? + + prop:expansion-contexts + + module-path? + + resolved-module-path? + make-resolved-module-path + resolved-module-path-name + + module-path-index? + module-path-index-resolve + module-path-index-join + module-path-index-split + module-path-index-submodule + + current-module-name-resolver + current-module-declare-name + current-module-declare-source + + current-namespace + namespace-module-registry + namespace? + + variable-reference->empty-namespace + variable-reference->namespace + variable-reference->resolved-module-path + variable-reference->module-path-index + variable-reference->module-source + variable-reference->phase + variable-reference->module-base-phase + variable-reference->module-declaration-inspector + + read-syntax + read-syntax/recursive) diff --git a/racket/src/expander/boot/expobs-primitive.rkt b/racket/src/expander/boot/expobs-primitive.rkt new file mode 100644 index 0000000000..8f2d6e1c5a --- /dev/null +++ b/racket/src/expander/boot/expobs-primitive.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(require "../expand/context.rkt") + +(provide expobs-primitives) + +(define expobs-primitives + (hasheq 'current-expand-observe current-expand-observe)) diff --git a/racket/src/expander/boot/handler.rkt b/racket/src/expander/boot/handler.rkt new file mode 100644 index 0000000000..d0535191ac --- /dev/null +++ b/racket/src/expander/boot/handler.rkt @@ -0,0 +1,683 @@ +#lang racket/base +(require '#%paramz + "../eval/collection.rkt" + "../syntax/api.rkt" + "../syntax/error.rkt" + "../syntax/srcloc.rkt" + "../namespace/namespace.rkt" + "../eval/parameter.rkt" + "../eval/main.rkt" + "../eval/dynamic-require.rkt" + "../namespace/api.rkt" + "../common/module-path.rkt" + "../eval/module-read.rkt" + "../expand/missing-module.rkt" + "../read/api.rkt" + "../read/primitive-parameter.rkt" + "load-handler.rkt") + +(provide boot + seal + orig-paramz + + boot-primitives) + +(define-values (dll-suffix) + (system-type 'so-suffix)) + +(define default-load/use-compiled + (let* ([resolve (lambda (s) + (if (complete-path? s) + s + (let ([d (current-load-relative-directory)]) + (if d (path->complete-path s d) s))))] + [date-of-1 (lambda (a) + (let ([v (file-or-directory-modify-seconds a #f (lambda () #f))]) + (and v (cons a v))))] + [date-of (lambda (a modes roots) + (ormap (lambda (root-dir) + (ormap + (lambda (compiled-dir) + (let ([a (a root-dir compiled-dir)]) + (date-of-1 a))) + modes)) + roots))] + [date>=? + (lambda (modes roots a bm) + (and a + (let ([am (date-of a modes roots)]) + (or (and (not bm) am) + (and am bm (>= (cdr am) (cdr bm)) am)))))] + [with-dir* (lambda (base t) + (parameterize ([current-load-relative-directory + (if (path? base) + base + (current-directory))]) + (t)))]) + (lambda (path expect-module) + (unless (path-string? path) + (raise-argument-error 'load/use-compiled "path-string?" path)) + (unless (or (not expect-module) + (symbol? expect-module) + (and (list? expect-module) + ((length expect-module) . > . 1) + (or (symbol? (car expect-module)) + (not (car expect-module))) + (andmap symbol? (cdr expect-module)))) + (raise-argument-error 'load/use-compiled "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))" path)) + (define name (and expect-module (current-module-declare-name))) + (define ns-hts (and name (registry-table-ref (namespace-module-registry (current-namespace))))) + (define use-path/src (and ns-hts (hash-ref (cdr ns-hts) name #f))) + (if use-path/src + ;; Use previous decision of .zo vs. source: + (parameterize ([current-module-declare-source (cadr use-path/src)]) + (with-dir* (caddr use-path/src) + (lambda () ((current-load) (car use-path/src) expect-module)))) + ;; Check .zo vs. src dates, etc.: + (let*-values ([(orig-path) (resolve path)] + [(base orig-file dir?) (split-path path)] + [(file alt-file) (if expect-module + (let* ([b (path->bytes orig-file)] + [len (bytes-length b)]) + (cond + [(and (len . >= . 4) + (bytes=? #".rkt" (subbytes b (- len 4)))) + ;; .rkt => try .rkt then .ss + (values orig-file + (bytes->path (bytes-append (subbytes b 0 (- len 4)) #".ss")))] + [else + ;; No search path + (values orig-file #f)])) + (values orig-file #f))] + [(path) (if (eq? file orig-file) + orig-path + (build-path base file))] + [(alt-path) (and alt-file + (if (eq? alt-file orig-file) + orig-path + (build-path base alt-file)))] + [(base) (if (eq? base 'relative) 'same base)] + [(modes) (use-compiled-file-paths)] + [(roots) (current-compiled-file-roots)] + [(reroot) (lambda (p d) + (cond + [(eq? d 'same) p] + [(relative-path? d) (build-path p d)] + [else (reroot-path p d)]))]) + (let* ([main-path-d (date-of-1 path)] + [alt-path-d (and alt-path + (not main-path-d) + (date-of-1 alt-path))] + [path-d (or main-path-d alt-path-d)] + [get-so (lambda (file rep-sfx?) + (lambda (root-dir compiled-dir) + (build-path (reroot base root-dir) + compiled-dir + "native" + (system-library-subpath) + (if rep-sfx? + (path-add-extension + file + dll-suffix) + file))))] + [zo (lambda (root-dir compiled-dir) + (build-path (reroot base root-dir) + compiled-dir + (path-add-extension file #".zo")))] + [alt-zo (lambda (root-dir compiled-dir) + (build-path (reroot base root-dir) + compiled-dir + (path-add-extension alt-file #".zo")))] + [so (get-so file #t)] + [alt-so (get-so alt-file #t)] + [try-main? (or main-path-d (not alt-path-d))] + [try-alt? (and alt-file (or alt-path-d (not main-path-d)))] + [with-dir (lambda (t) (with-dir* base t))]) + (cond + [(and try-main? + (date>=? modes roots so path-d)) + => (lambda (so-d) + (parameterize ([current-module-declare-source #f]) + (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] + [(and try-alt? + (date>=? modes roots alt-so alt-path-d)) + => (lambda (so-d) + (parameterize ([current-module-declare-source alt-path]) + (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] + [(and try-main? + (date>=? modes roots zo path-d)) + => (lambda (zo-d) + (register-zo-path name ns-hts (car zo-d) #f base) + (parameterize ([current-module-declare-source #f]) + (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] + [(and try-alt? + (date>=? modes roots alt-zo path-d)) + => (lambda (zo-d) + (register-zo-path name ns-hts (car zo-d) alt-path base) + (parameterize ([current-module-declare-source alt-path]) + (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] + [(or (not (pair? expect-module)) + (car expect-module)) + (let ([p (if try-main? path alt-path)]) + ;; "quiet" failure when asking for a submodule: + (unless (and (pair? expect-module) + (not (file-exists? p))) + (parameterize ([current-module-declare-source (and expect-module + (not try-main?) + p)]) + (with-dir (lambda () ((current-load) p expect-module))))))]))))))) + +(define (register-zo-path name ns-hts path src-path base) + (when ns-hts + (hash-set! (cdr ns-hts) name (list path src-path base)))) + +(define (default-reader-guard path) + path) + +;; weak map from namespace to pair of module-name hts +(define -module-hash-table-table + (make-weak-hasheq)) + +(define (registry-table-ref reg) + (define e (hash-ref -module-hash-table-table + reg + #f)) + (and e (ephemeron-value e))) + +(define (registry-table-set! reg v) + (hash-set! -module-hash-table-table + reg + (make-ephemeron reg v))) + +;; weak map from `lib' path + current-library-paths to symbols: +;; We'd like to use a weak `equal?'-based hash table here, +;; but that's not kill-safe. Instead, we use a non-thread-safe +;; custom hash table; a race could lose cache entries, but +;; that's ok. +(define CACHE-N 512) +(define -path-cache (make-vector CACHE-N #f)) +(define (path-cache-get p) + (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] + [w (vector-ref -path-cache i)] + [l (and w (weak-box-value w))]) + (and l + (let ([a (assoc p l)]) + (and a (cdr a)))))) +(define (path-cache-set! p v) + (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] + [w (vector-ref -path-cache i)] + [l (and w (weak-box-value w))]) + (vector-set! -path-cache i (make-weak-box (cons (cons p v) (or l null)))))) + +(define -loading-filename (gensym)) +(define -loading-prompt-tag (make-continuation-prompt-tag 'module-loading)) +(define -prev-relto #f) +(define -prev-relto-dir #f) + +(define (split-relative-string s coll-mode?) + (let ([l (let loop ([s s]) + (let ([len (string-length s)]) + (let iloop ([i 0]) + (cond + [(= i len) (list s)] + [(char=? #\/ (string-ref s i)) + (cons (substring s 0 i) + (loop (substring s (add1 i))))] + [else (iloop (add1 i))]))))]) + (if coll-mode? + l + (let loop ([l l]) + (if (null? (cdr l)) + (values null (car l)) + (let-values ([(c f) (loop (cdr l))]) + (values (cons (car l) c) f))))))) + +(define (format-source-location stx) + (srcloc->string (srcloc (syntax-source stx) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx)))) + +(define orig-paramz #f) + +(define-values (standard-module-name-resolver) + (let-values () + (define-values (planet-resolver) #f) + (define-values (prep-planet-resolver!) + (lambda () + (unless planet-resolver + (with-continuation-mark + parameterization-key + orig-paramz + (set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver)))))) + (define-values (standard-module-name-resolver) + (case-lambda + [(s from-namespace) + (unless (resolved-module-path? s) + (raise-argument-error 'standard-module-name-resolver + "resolved-module-path?" + s)) + (unless (or (not from-namespace) (namespace? from-namespace)) + (raise-argument-error 'standard-module-name-resolver + "(or/c #f namespace?)" + from-namespace)) + (when planet-resolver + ;; Let planet resolver register, too: + (planet-resolver s)) + ;; Register s as loaded: + (let ([hts (or (registry-table-ref (namespace-module-registry (current-namespace))) + (let ([hts (cons (make-hasheq) (make-hasheq))]) + (registry-table-set! (namespace-module-registry (current-namespace)) + hts) + hts))]) + (hash-set! (car hts) s 'declared) + ;; If attach from another namespace, copy over source-file path, if any: + (when from-namespace + (let ([root-name (if (pair? (resolved-module-path-name s)) + (make-resolved-module-path (car (resolved-module-path-name s))) + s)] + [from-hts (registry-table-ref (namespace-module-registry from-namespace))]) + (when from-hts + (let ([use-path/src (hash-ref (cdr from-hts) root-name #f)]) + (when use-path/src + (hash-set! (cdr hts) root-name use-path/src)))))))] + [(s relto stx) ; for backward-compatibility + (log-message (current-logger) 'error + "default module name resolver called with three arguments (deprecated)" + #f) + (standard-module-name-resolver s relto stx #t)] + [(s relto stx load?) + ;; If stx is not #f, raise syntax error for ill-formed paths + (unless (module-path? s) + (if (syntax? stx) + (raise-syntax-error #f + "bad module path" + stx) + (raise-argument-error 'standard-module-name-resolver + "module-path?" + s))) + (unless (or (not relto) (resolved-module-path? relto)) + (raise-argument-error 'standard-module-name-resolver + "(or/c #f resolved-module-path?)" + relto)) + (unless (or (not stx) (syntax? stx)) + (raise-argument-error 'standard-module-name-resolver + "(or/c #f syntax?)" + stx)) + (define (flatten-sub-path base orig-l) + (let loop ([a null] [l orig-l]) + (cond + [(null? l) (if (null? a) + base + (cons base (reverse a)))] + [(equal? (car l) "..") + (if (null? a) + (error + 'standard-module-name-resolver + "too many \"..\"s in submodule path: ~.s" + (list* 'submod + (if (equal? base ".") + base + (if (path? base) + base + (list (if (symbol? base) 'quote 'file) base))) + orig-l)) + (loop (cdr a) (cdr l)))] + [else (loop (cons (car l) a) (cdr l))]))) + (cond + [(and (pair? s) (eq? (car s) 'quote)) + (make-resolved-module-path (cadr s))] + [(and (pair? s) (eq? (car s) 'submod) + (pair? (cadr s)) (eq? (caadr s) 'quote)) + (make-resolved-module-path (flatten-sub-path (cadadr s) (cddr s)))] + [(and (pair? s) (eq? (car s) 'submod) + (or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + (and relto + (let ([p (resolved-module-path-name relto)]) + (or (symbol? p) + (and (pair? p) (symbol? (car p))))))) + (define rp (resolved-module-path-name relto)) + (make-resolved-module-path (flatten-sub-path (if (pair? rp) (car rp) rp) + (let ([r (if (equal? (cadr s) "..") + (cdr s) + (cddr s))]) + (if (pair? rp) + (append (cdr rp) r) + r))))] + [(and (pair? s) (eq? (car s) 'planet)) + (prep-planet-resolver!) + (planet-resolver s relto stx load? #f orig-paramz)] + [(and (pair? s) + (eq? (car s) 'submod) + (pair? (cadr s)) + (eq? (caadr s) 'planet)) + (prep-planet-resolver!) + (planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)] + [else + (let ([get-dir (lambda () + (or (and relto + (if (eq? relto -prev-relto) + -prev-relto-dir + (let ([p (resolved-module-path-name relto)]) + (let ([p (if (pair? p) (car p) p)]) + (and (path? p) + (let-values ([(base n d?) (split-path p)]) + (set! -prev-relto relto) + (set! -prev-relto-dir base) + base)))))) + (current-load-relative-directory) + (current-directory)))] + [get-reg (lambda () + (namespace-module-registry (current-namespace)))] + [show-collection-err (lambda (msg) + (let ([msg (string-append + (or (and stx + (error-print-source-location) + (format-source-location stx)) + "standard-module-name-resolver") + ": " + (regexp-replace #rx"\n" + msg + (format "\n for module path: ~s\n" + s)))]) + (raise + (if stx + (exn:fail:syntax:missing-module + msg + (current-continuation-marks) + (list stx) + s) + (exn:fail:filesystem:missing-module + msg + (current-continuation-marks) + s)))))] + [ss->rkt (lambda (s) + (let ([len (string-length s)]) + (if (and (len . >= . 3) + ;; ".ss" + (equal? #\. (string-ref s (- len 3))) + (equal? #\s (string-ref s (- len 2))) + (equal? #\s (string-ref s (- len 1)))) + (string-append (substring s 0 (- len 3)) ".rkt") + s)))] + [path-ss->rkt (lambda (p) + (let-values ([(base name dir?) (split-path p)]) + (if (regexp-match #rx"[.]ss$" (path->bytes name)) + (path-replace-extension p #".rkt") + p)))] + [s (if (and (pair? s) (eq? 'submod (car s))) + (let ([v (cadr s)]) + (if (or (equal? v ".") + (equal? v "..")) + (if relto + ;; must have a path inside, or we wouldn't get here + (let ([p (resolved-module-path-name relto)]) + (if (pair? p) + (car p) + p)) + (error 'standard-module-name-resolver + "no base path for relative submodule path: ~.s" + s)) + v)) + s)] + [subm-path (if (and (pair? s) (eq? 'submod (car s))) + (let ([p (if (and (or (equal? (cadr s) ".") + (equal? (cadr s) "..")) + relto) + (let ([p (resolved-module-path-name relto)] + [r (if (equal? (cadr s) "..") + (cdr s) + (cddr s))]) + (if (pair? p) + (flatten-sub-path (car p) (append (cdr p) r)) + (flatten-sub-path p r))) + (flatten-sub-path "." + (if (equal? (cadr s) "..") + (cdr s) + (cddr s))))]) + ;; flattening may erase the submodule path: + (if (pair? p) + (cdr p) + #f)) + #f)]) + (let ([s-parsed + ;; Non-string result represents an error + (cond + [(symbol? s) + (or (path-cache-get (cons s (get-reg))) + (let-values ([(cols file) (split-relative-string (symbol->string s) #f)]) + (let* ([f-file (if (null? cols) + "main.rkt" + (string-append file ".rkt"))]) + (find-col-file show-collection-err + (if (null? cols) file (car cols)) + (if (null? cols) null (cdr cols)) + f-file + #t))))] + [(string? s) + (let* ([dir (get-dir)]) + (or (path-cache-get (cons s dir)) + (let-values ([(cols file) (split-relative-string s #f)]) + (if (null? cols) + (build-path dir (ss->rkt file)) + (apply build-path + dir + (append + (map (lambda (s) + (cond + [(string=? s ".") 'same] + [(string=? s "..") 'up] + [else s])) + cols) + (list (ss->rkt file))))))))] + [(path? s) + ;; Use filesystem-sensitive `simplify-path' here: + (path-ss->rkt (simplify-path (if (complete-path? s) + s + (path->complete-path s (get-dir)))))] + [(eq? (car s) 'lib) + (or (path-cache-get (cons s (get-reg))) + (let*-values ([(cols file) (split-relative-string (cadr s) #f)] + [(old-style?) (if (null? (cddr s)) + (and (null? cols) + (regexp-match? #rx"[.]" file)) + #t)]) + (let* ([f-file (if old-style? + (ss->rkt file) + (if (null? cols) + "main.rkt" + (if (regexp-match? #rx"[.]" file) + (ss->rkt file) + (string-append file ".rkt"))))]) + (let-values ([(cols) + (if old-style? + (append (if (null? (cddr s)) + '("mzlib") + (apply append + (map (lambda (p) + (split-relative-string p #t)) + (cddr s)))) + cols) + (if (null? cols) + (list file) + cols))]) + (find-col-file show-collection-err + (car cols) + (cdr cols) + f-file + #t)))))] + [(eq? (car s) 'file) + ;; Use filesystem-sensitive `simplify-path' here: + (path-ss->rkt + (simplify-path (path->complete-path (expand-user-path (cadr s)) (get-dir))))])]) + (unless (or (path? s-parsed) + (vector? s-parsed)) + (if stx + (raise-syntax-error + 'require + (format "bad module path~a" (if s-parsed + (car s-parsed) + "")) + stx) + (raise-argument-error + 'standard-module-name-resolver + "module-path?" + s))) + ;; At this point, s-parsed is a complete path (or a cached vector) + (let* ([filename (if (vector? s-parsed) + (vector-ref s-parsed 0) + (simplify-path (cleanse-path s-parsed) #f))] + [normal-filename (if (vector? s-parsed) + (vector-ref s-parsed 1) + (normal-case-path filename))]) + (let-values ([(base name dir?) (if (vector? s-parsed) + (values 'ignored (vector-ref s-parsed 2) 'ignored) + (split-path filename))]) + (let* ([no-sfx (if (vector? s-parsed) + (vector-ref s-parsed 3) + (path-replace-extension name #""))]) + (let* ([root-modname (if (vector? s-parsed) + (vector-ref s-parsed 4) + (make-resolved-module-path filename))] + [hts (or (registry-table-ref (get-reg)) + (let ([hts (cons (make-hasheq) (make-hasheq))]) + (registry-table-set! (get-reg) + hts) + hts))] + [modname (if subm-path + (make-resolved-module-path + (cons (resolved-module-path-name root-modname) + subm-path)) + root-modname)]) + ;; Loaded already? + (when load? + (let ([got (hash-ref (car hts) modname #f)]) + (unless got + ;; Currently loading? + (let ([loading + (let ([tag (if (continuation-prompt-available? -loading-prompt-tag) + -loading-prompt-tag + (default-continuation-prompt-tag))]) + (continuation-mark-set-first + #f + -loading-filename + null + tag))] + [nsr (get-reg)]) + (for-each + (lambda (s) + (when (and (equal? (cdr s) normal-filename) + (eq? (car s) nsr)) + (error + 'standard-module-name-resolver + "cycle in loading\n at path: ~a\n paths:~a" + filename + (apply string-append + (let loop ([l (reverse loading)]) + (if (null? l) + '() + (list* "\n " (path->string (cdar l)) (loop (cdr l))))))))) + loading) + ((if (continuation-prompt-available? -loading-prompt-tag) + (lambda (f) (f)) + (lambda (f) (call-with-continuation-prompt f -loading-prompt-tag))) + (lambda () + (with-continuation-mark -loading-filename (cons (cons nsr normal-filename) + loading) + (parameterize ([current-module-declare-name root-modname] + [current-module-path-for-load + ;; If `s' is an absolute module path, then + ;; keep it as-is, the better to let a tool + ;; recommend how to get an unavailable module; + ;; also, propagate the source location. + ((if stx + (lambda (p) (datum->syntax #f p stx)) + values) + (cond + [(symbol? s) s] + [(and (pair? s) (eq? (car s) 'lib)) s] + [else (if (resolved-module-path? root-modname) + (let ([src (resolved-module-path-name root-modname)]) + (if (symbol? src) + (list 'quote src) + src)) + root-modname)]))]) + ((current-load/use-compiled) + filename + (let ([sym (string->symbol (path->string no-sfx))]) + (if subm-path + (if (hash-ref (car hts) root-modname #f) + ;; Root is already loaded, so only use .zo + (cons #f subm-path) + ;; Root isn't loaded, so it's ok to load form source: + (cons sym subm-path)) + sym))))))))))) + ;; If a `lib' path, cache pathname manipulations + (when (and (not (vector? s-parsed)) + load? + (or (string? s) + (symbol? s) + (and (pair? s) + (eq? (car s) 'lib)))) + (path-cache-set! (if (string? s) + (cons s (get-dir)) + (cons s (get-reg))) + (vector filename + normal-filename + name + no-sfx + root-modname))) + ;; Result is the module name: + modname))))))])])) + standard-module-name-resolver)) + +(define default-eval-handler + (lambda (s) + (eval s + (current-namespace) + (let ([c (current-compile)]) + (lambda (e ns) + ;; `ns` is `(current-namespace)`, but possibly + ;; phase-shifted + (if (eq? ns (current-namespace)) + (c e #t) + (parameterize ([current-namespace ns]) + (c e #t)))))))) + +(define default-compile-handler + ;; Constrained to a single argument: + (lambda (s immediate-eval?) (compile s + (current-namespace) + (not immediate-eval?)))) + +(define (default-read-interaction src in) + (unless (input-port? in) + (raise-argument-error 'default-read-interaction "input-port?" in)) + (parameterize ([read-accept-reader #t] + [read-accept-lang #f]) + (read-syntax src in))) + +(define (boot) + (seal) + (current-module-name-resolver standard-module-name-resolver) + (current-load/use-compiled default-load/use-compiled) + (current-reader-guard default-reader-guard) + (current-eval default-eval-handler) + (current-compile default-compile-handler) + (current-load default-load-handler) + (current-read-interaction default-read-interaction)) + +(define (seal) + (set! orig-paramz + (reparameterize + (continuation-mark-set-first #f parameterization-key)))) + +;; ---------------------------------------- +;; For historical uses of '#%boot + +(define boot-primitives + (hash 'boot boot + 'seal seal + 'orig-paramz orig-paramz)) diff --git a/racket/src/expander/boot/kernel.rkt b/racket/src/expander/boot/kernel.rkt new file mode 100644 index 0000000000..6547e57643 --- /dev/null +++ b/racket/src/expander/boot/kernel.rkt @@ -0,0 +1,120 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../namespace/core.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/provided.rkt" + "../syntax/binding.rkt" + "core-primitive.rkt" + "../common/module-path.rkt" + "../expand/require+provide.rkt" + "../host/linklet.rkt" + "../compile/built-in-symbol.rkt") + +;; The '#%kernel module combines '#%core, '#%runtime, and '#%main + +(provide declare-kernel-module! + copy-runtime-module! + declare-hash-based-module! + declare-reexporting-module!) + +(define (declare-kernel-module! ns + #:eval eval + #:main-ids main-ids + #:read-ids read-ids) + (copy-runtime-module! '#%kernel + #:to '#%runtime + #:skip (set-union primitive-ids + (set-union main-ids + read-ids)) + #:extras (hasheq 'variable-reference? variable-reference? + 'variable-reference-constant? variable-reference-constant? + 'variable-reference-from-unsafe? variable-reference-from-unsafe?) + #:namespace ns) + (declare-reexporting-module! '#%kernel '(#%core #%runtime #%main #%read) + #:namespace ns)) + +(define (copy-runtime-module! name + #:to [to-name name] + #:namespace ns + #:skip [skip-syms (seteq)] + #:alts [alts #hasheq()] + #:extras [extras #hasheq()] + #:primitive? [primitive? #t] + #:protected? [protected? #f]) + (define prims (primitive-table name)) + (for ([sym (in-hash-keys prims)]) + (register-built-in-symbol! sym)) + (define ht (for/hasheq ([(sym val) (in-hash prims)] + #:unless (set-member? skip-syms sym)) + (values sym + (or (hash-ref alts sym #f) val)))) + (define ht+extras (for/fold ([ht ht]) ([(k v) (in-hash extras)]) + (hash-set ht k v))) + (declare-hash-based-module! to-name ht+extras + #:namespace ns + #:primitive? primitive? + #:protected? protected?)) + +(define (declare-hash-based-module! name ht + #:namespace ns + #:primitive? [primitive? #f] + #:protected? [protected? #f] + #:protected [protected-syms null] + #:register-builtin? [register-builtin? #f]) + (define mpi (module-path-index-join (list 'quote name) #f)) + (declare-module! + ns + (make-module #:cross-phase-persistent? #t + #:primitive? primitive? + #:predefined? #t + #:no-protected? (not protected?) + #:self mpi + #:provides + (hasheqv 0 (for/hash ([sym (in-hash-keys ht)]) + (when register-builtin? + (register-built-in-symbol! sym)) + (define binding (make-module-binding mpi 0 sym)) + (values sym + (if (or protected? + (member sym protected-syms)) + (provided binding #t #f) + binding)))) + #:instantiate-phase-callback + (lambda (data-box ns phase-shift phase-level self bulk-binding-registry insp) + (when (= 0 phase-level) + (for ([(sym val) (in-hash ht)]) + (namespace-set-variable! ns 0 sym val))))) + (module-path-index-resolve mpi))) + +(define (declare-reexporting-module! name require-names + #:reexport? [reexport? #t] + #:namespace ns) + (define mpi (module-path-index-join (list 'quote name) #f)) + (define require-mpis (for/list ([require-name (in-list require-names)]) + (module-path-index-join (list 'quote require-name) #f))) + (declare-module! + ns + (make-module #:cross-phase-persistent? #t + #:predefined? #t + #:self mpi + #:requires (list (cons 0 require-mpis)) + #:provides + (if reexport? + (hasheqv 0 + (for*/hash ([require-mpi (in-list require-mpis)] + [m (in-value (namespace->module + ns + (module-path-index-resolve require-mpi)))] + [(sym binding) (in-hash + (hash-ref + (shift-provides-module-path-index + (module-provides m) + (module-self m) + require-mpi) + 0))]) + (values sym binding))) + #hasheqv()) + #:instantiate-phase-callback void) + (module-path-index-resolve mpi))) diff --git a/racket/src/expander/boot/linklet-primitive.rkt b/racket/src/expander/boot/linklet-primitive.rkt new file mode 100644 index 0000000000..f83c15baaa --- /dev/null +++ b/racket/src/expander/boot/linklet-primitive.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(require "../host/linklet.rkt" + "../common/reflect-hash.rkt" + "../run/linklet-operation.rkt") + +(provide linklet-primitives) + +(define linklet-primitives + (linklet-operations=> reflect-hash)) diff --git a/racket/src/expander/boot/load-handler.rkt b/racket/src/expander/boot/load-handler.rkt new file mode 100644 index 0000000000..c5f32ecbbd --- /dev/null +++ b/racket/src/expander/boot/load-handler.rkt @@ -0,0 +1,222 @@ +#lang racket/base +(require '#%paramz + "../eval/collection.rkt" + "../syntax/api.rkt" + "../eval/main.rkt" + "../eval/dynamic-require.rkt" + "../eval/parameter.rkt" + "../host/linklet.rkt" + "../namespace/namespace.rkt" + "../namespace/api.rkt" + "../eval/module-read.rkt" + "../eval/module-cache.rkt" + "../eval/reflect.rkt" + "../read/api.rkt" + "../read/primitive-parameter.rkt") + +(provide default-load-handler) + +(define default-load-handler + (lambda (path expected-mod) + (unless (path-string? path) + (raise-argument-error 'default-load-handler "path-string?" path)) + (unless (or (not expected-mod) + (symbol? expected-mod) + (and (pair? expected-mod) + (list? expected-mod) + (or (not (car expected-mod)) (symbol? (car expected-mod))) + (andmap symbol? (cdr expected-mod)))) + (raise-argument-error 'default-load-handler + "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))" + expected-mod)) + (define (maybe-count-lines! i) + (unless (regexp-match? #rx"[.]zo$" path) + (port-count-lines! i))) + (cond + [expected-mod + ((call-with-input-module-file + path + (lambda (i) + (maybe-count-lines! i) + (with-module-reading-parameterization+delay-source + path + (lambda () + (cond + [(linklet-directory-start i) + => (lambda (pos) + ;; Find and load individual submodule + (define b-pos (search-directory i pos (encode-symbols expected-mod))) + (cond + [b-pos + (file-position i b-pos) + (or (cached-bundle i) + (let ([v (read i)]) + (if (compiled-module-expression? v) + (lambda () ((current-eval) v)) + (error 'default-load-handler + (string-append "expected a compiled module\n" + " in: ~e\n" + " found: ~e") + (object-name i) + v))))] + [(and (pair? expected-mod)) + ;; Cannot load submodule, so do nothing + void] + [else + (error 'default-load-handler + (string-append "could not find main module\n" + " in: ~e") + (object-name i))]))] + [(and (pair? expected-mod) (not (car expected-mod))) + ;; Cannot load submodule independently, so do nothing + void] + [(cached-bundle i) + => (lambda (thunk) thunk)] + [else + (define s (read-syntax (object-name i) i)) + (when (eof-object? s) + (error 'default-load-handler + (string-append "expected a `module' declaration;\n" + " found end-of-file\n" + " in: ~e") + (object-name i))) + (define m-s (check-module-form s path)) + (define s2 (read-syntax (object-name i) i)) + (unless (eof-object? s2) + (error 'default-load-handler + (string-append "expected a `module' declaration;\n" + " found an extra form\n" + " in: ~e\n" + " found: ~.s") + (object-name i) + s2)) + (lambda () ((current-eval) m-s))]))))))] + [else + (define (add-top-interaction s) + (namespace-syntax-introduce + (datum->syntax #f (cons '#%top-interaction s)))) + (call-with-input-file* + path + (lambda (i) + (maybe-count-lines! i) + (let loop ([vals (list (void))]) + (define s + (parameterize ([read-accept-compiled #t] + [read-accept-reader #t] + [read-accept-lang #t]) + (if (load-on-demand-enabled) + (parameterize ([read-on-demand-source (path->complete-path path)]) + (read-syntax (object-name i) i)) + (read-syntax (object-name i) i)))) + (if (eof-object? s) + (apply values vals) + (loop + (call-with-continuation-prompt + (lambda () + (call-with-values (lambda () ((current-eval) (add-top-interaction s))) list)) + (default-continuation-prompt-tag) + (lambda args + (apply abort-current-continuation (default-continuation-prompt-tag) args))))))))]))) + +(define (linklet-bundle-or-directory-start i tag) + (define version-length (string-length (version))) + (and (equal? (peek-byte i) (char->integer #\#)) + (equal? (peek-byte i 1) (char->integer #\~)) + (equal? (peek-byte i 2) version-length) + (equal? (peek-bytes version-length 3 i) (string->bytes/utf-8 (version))) + (equal? (peek-byte i (+ 3 version-length)) (char->integer tag)) + (+ version-length + ;; "#~" and tag and length byte: + 4))) + +(define (linklet-directory-start i) + (define pos (linklet-bundle-or-directory-start i #\D)) + (and pos (+ pos + ;; Bundle count: + 4))) + +(define (linklet-bundle-hash-code i) + (define pos (linklet-bundle-or-directory-start i #\B)) + (define hash-code (and pos (peek-bytes 20 pos i))) + (and (bytes? hash-code) + (= 20 (bytes-length hash-code)) + (for/or ([c (in-bytes hash-code)]) + (not (eq? c 0))) + hash-code)) + +(define (cached-bundle i) + (cond + [(module-cache-ref (make-module-cache-key (linklet-bundle-hash-code i))) + => (lambda (declare-module) + ;; The `declare-module` function has registered in the cace by + ;; `eval-module` in "eval/module.rkt"; we can call the function + ;; instead of loading from scratch and `eval`ing; + ;; FIXME: go though `current-eval` + (lambda () + (declare-module (current-namespace))))] + [else #f])) + +(define (read-number i) + (define (read-byte/not-eof i) + (define v (read-byte i)) + (if (eof-object? v) 0 v)) + (bitwise-ior (read-byte/not-eof i) + (arithmetic-shift (read-byte/not-eof i) 8) + (arithmetic-shift (read-byte/not-eof i) 16) + (arithmetic-shift (read-byte/not-eof i) 24))) + +(define (search-directory i pos bstr) + (cond + [(zero? pos) #f] + [else + (file-position i pos) + (define name-len (read-number i)) + (define v (read-bytes name-len i)) + (unless (and (bytes? v) (= (bytes-length v) name-len)) + (error 'deafult-load-handler + (string-append "failure getting submodule path\n" + " in: ~e\n" + " at position: ~a\n" + " expected bytes: ~a\n" + " read bytes: ~e") + (object-name i) + pos + name-len + v)) + (cond + [(bytes=? bstr v) (read-number i)] + [(bytesbytes/utf-8 (symbol->string s))) + (define len (bytes-length bstr)) + (cond + [(len . < . 255) (bytes-append (bytes len) bstr)] + [else (bytes-append 255 (integer->integer-bytes len 4 #f #f) bstr)])))])) + +(define (with-module-reading-parameterization+delay-source path thunk) + (if (load-on-demand-enabled) + (parameterize ([read-on-demand-source (path->complete-path path)]) + (with-module-reading-parameterization thunk)) + (with-module-reading-parameterization thunk))) + +(define (call-with-input-module-file path proc) + (define i #f) + (dynamic-wind + (lambda () (set! i (open-input-file path #:for-module? #t))) + (lambda () (proc i)) + (lambda () (close-input-port i)))) diff --git a/racket/src/expander/boot/main-primitive.rkt b/racket/src/expander/boot/main-primitive.rkt new file mode 100644 index 0000000000..4fee1a9b8d --- /dev/null +++ b/racket/src/expander/boot/main-primitive.rkt @@ -0,0 +1,90 @@ +#lang racket/base +(require "../eval/main.rkt" + "../eval/dynamic-require.rkt" + "../eval/reflect.rkt" + "../eval/load.rkt" + "../eval/parameter.rkt" + "../eval/collection.rkt" + (prefix-in wrapper: "../eval/api.rkt") + "../compile/recompile.rkt" + "../namespace/namespace.rkt" + "../namespace/api.rkt" + "../namespace/attach.rkt" + "../namespace/api-module.rkt") + +(provide main-primitives) + +(define main-primitives + (hasheq 'eval wrapper:eval + 'eval-syntax wrapper:eval-syntax + 'compile wrapper:compile + 'compile-syntax wrapper:compile-syntax + 'expand wrapper:expand + 'expand-syntax wrapper:expand-syntax + 'expand-once wrapper:expand-once + 'expand-syntax-once wrapper:expand-syntax-once + 'expand-to-top-form wrapper:expand-to-top-form + 'expand-syntax-to-top-form wrapper:expand-syntax-to-top-form + 'dynamic-require dynamic-require + 'dynamic-require-for-syntax dynamic-require-for-syntax + 'load load + 'load-extension load-extension + 'load/use-compiled load/use-compiled + + 'current-eval current-eval + 'current-compile current-compile + 'current-load current-load + 'current-load/use-compiled current-load/use-compiled + + 'collection-path collection-path + 'collection-file-path collection-file-path + 'find-library-collection-paths find-library-collection-paths + 'find-library-collection-links find-library-collection-links + + 'current-library-collection-paths current-library-collection-paths + 'current-library-collection-links current-library-collection-links + 'use-compiled-file-paths use-compiled-file-paths + 'current-compiled-file-roots current-compiled-file-roots + 'use-compiled-file-check use-compiled-file-check + 'use-collection-link-paths use-collection-link-paths + 'use-user-specific-search-paths use-user-specific-search-paths + + 'compiled-expression? compiled-expression? + 'compiled-module-expression? compiled-module-expression? + 'module-compiled-name module-compiled-name + 'module-compiled-submodules module-compiled-submodules + 'module-compiled-language-info module-compiled-language-info + 'module-compiled-imports module-compiled-imports + 'module-compiled-exports module-compiled-exports + 'module-compiled-indirect-exports module-compiled-indirect-exports + + 'compiled-expression-recompile compiled-expression-recompile + + 'make-empty-namespace make-empty-namespace + + 'namespace-attach-module namespace-attach-module + 'namespace-attach-module-declaration namespace-attach-module-declaration + + 'namespace-symbol->identifier namespace-symbol->identifier + 'namespace-module-identifier namespace-module-identifier + 'namespace-syntax-introduce namespace-syntax-introduce + 'namespace-require namespace-require + 'namespace-require/copy namespace-require/copy + 'namespace-require/constant namespace-require/constant + 'namespace-require/expansion-time namespace-require/expansion-time + 'namespace-variable-value namespace-variable-value + 'namespace-set-variable-value! namespace-set-variable-value! + 'namespace-undefine-variable! namespace-undefine-variable! + 'namespace-mapped-symbols namespace-mapped-symbols + 'namespace-base-phase namespace-base-phase + + 'module-declared? module-declared? + 'module-predefined? module-predefined? + 'module->language-info module->language-info + 'module->imports module->imports + 'module->exports module->exports + 'module->indirect-exports module->indirect-exports + 'module-compiled-cross-phase-persistent? module-compiled-cross-phase-persistent? + 'module-provide-protected? module-provide-protected? + 'module->namespace module->namespace + 'namespace-unprotect-module namespace-unprotect-module)) diff --git a/racket/src/expander/boot/place-primitive.rkt b/racket/src/expander/boot/place-primitive.rkt new file mode 100644 index 0000000000..5a88442f04 --- /dev/null +++ b/racket/src/expander/boot/place-primitive.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +;; When places are implemented by plain old threads, +;; place channels need to be shared across namespaces, +;; so `#%place-struct' is included in builtins. + +(provide place-struct-primitives) + +(define-values (struct:TH-place-channel TH-place-channel TH-place-channel? + TH-place-channel-ref TH-place-channel-set!) + (make-struct-type 'TH-place-channel #f 2 0 #f (list (cons prop:evt (lambda (x) (TH-place-channel-ref x 0)))))) + +(define-values (TH-place-channel-in TH-place-channel-out) + (values + (lambda (x) (TH-place-channel-ref x 0)) + (lambda (x) (TH-place-channel-ref x 1)))) + +(define place-struct-primitives + (hasheq 'struct:TH-place-channel struct:TH-place-channel + 'TH-place-channel TH-place-channel + 'TH-place-channel? TH-place-channel? + 'TH-place-channel-in TH-place-channel-in + 'TH-place-channel-out TH-place-channel-out)) diff --git a/racket/src/expander/boot/read-primitive.rkt b/racket/src/expander/boot/read-primitive.rkt new file mode 100644 index 0000000000..30d921e0ae --- /dev/null +++ b/racket/src/expander/boot/read-primitive.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require "../common/reflect-hash.rkt" + "../read/api.rkt" + "../read/primitive-parameter.rkt" + "../read/readtable.rkt" + "../read/special-comment.rkt" + "../read/number.rkt") + +;; Reader primitives are in their own module so that they can be +;; treated specially by the bootstrapped flattened. The expanded form +;; of the expander can refer to the host's implementations, and those +;; references are replaced by these implementations. + +(provide read-primitives) + +(define read-primitives + (reflect-hash read + read/recursive + read-language + + string->number + + current-reader-guard + ;; read-case-sensitive - shared with printer + read-square-bracket-as-paren + read-curly-brace-as-paren + read-square-bracket-with-tag + read-curly-brace-with-tag + read-cdot + read-accept-graph + read-accept-compiled + read-accept-box + ;; read-accept-bar-quote - shared with printer + read-decimal-as-inexact + read-accept-dot + read-accept-infix-dot + read-accept-quasiquote + read-accept-reader + read-accept-lang + + current-readtable + readtable? + make-readtable + readtable-mapping + + special-comment? + make-special-comment + special-comment-value)) diff --git a/racket/src/expander/boot/runtime-primitive.rkt b/racket/src/expander/boot/runtime-primitive.rkt new file mode 100644 index 0000000000..1a49e73005 --- /dev/null +++ b/racket/src/expander/boot/runtime-primitive.rkt @@ -0,0 +1,52 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../common/module-path.rkt") + +(provide runtime-stx + runtime-module-name + + runtime-instances) + +;; Runtime primitives are implemented in the runtime system (and not +;; shadowed by the expander's primitives). They're re-exported by +;; '#%kernel, but originally exported by a '#%runtime module. The +;; expander needs to generate references to some '#%runtime` bindings. + +(define runtime-scope (new-multi-scope)) +(define runtime-stx (add-scope empty-syntax runtime-scope)) + +(define runtime-module-name (make-resolved-module-path '#%runtime)) +(define runtime-mpi (module-path-index-join ''#%runtime #f)) + +(define (add-runtime-primitive! sym) + (add-binding-in-scopes! (syntax-scope-set runtime-stx 0) + sym + (make-module-binding runtime-mpi 0 sym))) + +;; This is only a subset that we need to have bound; +;; the rest are added in "kernel.rkt" +(void + (begin + (add-runtime-primitive! 'values) + (add-runtime-primitive! 'cons) + (add-runtime-primitive! 'list) + (add-runtime-primitive! 'make-struct-type) + (add-runtime-primitive! 'make-struct-type-property) + (add-runtime-primitive! 'gensym) + (add-runtime-primitive! 'string->uninterned-symbol))) + +;; Instances that are built into the runtime system, but +;; not including '#%linklet +(define runtime-instances + '(#%kernel + #%paramz + #%foreign + #%unsafe + #%flfxnum + #%extfl + #%network + #%place + #%futures)) diff --git a/racket/src/expander/boot/utils-primitive.rkt b/racket/src/expander/boot/utils-primitive.rkt new file mode 100644 index 0000000000..8070f2dd12 --- /dev/null +++ b/racket/src/expander/boot/utils-primitive.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require racket/private/config + racket/private/executable-path + "../common/reflect-hash.rkt" + (only-in "../eval/load.rkt" load/use-compiled) + "../eval/collection.rkt") + +(provide utils-primitives) + +;; These functions are a small step away from `#%kernel`, and they +;; have traditionally been available as the `#%utils` module. Don't +;; use `#%utils` in `racket/base`, since that's where the actual +;; implementation sometimes is. We turn the functions into a +;; "primitive" module using this table in a bootstrapped load. + +(define utils-primitives + (reflect-hash path-string? + normal-case-path + path-replace-extension + path-add-extension + reroot-path + + path-list-string->path-list + + find-executable-path + + call-with-default-reading-parameterization + + collection-path + collection-file-path + find-library-collection-paths + find-library-collection-links + + load/use-compiled + + find-main-config + find-main-collects)) diff --git a/racket/src/expander/bootstrap-demo.rkt b/racket/src/expander/bootstrap-demo.rkt new file mode 100644 index 0000000000..ae8be8c19f --- /dev/null +++ b/racket/src/expander/bootstrap-demo.rkt @@ -0,0 +1,3 @@ +#lang racket/base +(require "run/bootstrap.rkt" ; must be before anything that uses "host/linklet.rkt" + "demo.rkt") diff --git a/racket/src/expander/bootstrap-run.rkt b/racket/src/expander/bootstrap-run.rkt new file mode 100644 index 0000000000..0a977a00ca --- /dev/null +++ b/racket/src/expander/bootstrap-run.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require "run/bootstrap.rkt" ; must be before anything that uses "host/linklet.rkt" + "run.rkt") + diff --git a/racket/src/expander/common/contract.rkt b/racket/src/expander/common/contract.rkt new file mode 100644 index 0000000000..f1d2274c6b --- /dev/null +++ b/racket/src/expander/common/contract.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide check) + +(define-syntax-rule (check who pred arg) + (unless (pred arg) + (raise-argument-error who (as-string pred) arg))) + +(define-syntax (as-string stx) + (syntax-case stx () + [(_ id) + (datum->syntax stx (symbol->string (syntax-e #'id)) stx)])) diff --git a/racket/src/expander/common/inline.rkt b/racket/src/expander/common/inline.rkt new file mode 100644 index 0000000000..66a52a44b7 --- /dev/null +++ b/racket/src/expander/common/inline.rkt @@ -0,0 +1,30 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide define-inline) + +(define-syntax (define-inline stx) + (syntax-case stx () + [(_ (proc-id arg ...) body ...) + (with-syntax ([(arg-id ...) + (for/list ([arg (in-list (syntax->list #'(arg ...)))]) + (syntax-case arg () + [(id def-val) #'id] + [else arg]))]) + (with-syntax ([(gen-id ...) + (generate-temporaries #'(arg-id ...))]) + #`(define-syntax proc-id + (syntax-rules () + [(_ gen-id ...) + (let ([arg-id gen-id] ...) + body ...)] + #,@(let loop ([args (syntax->list #'(arg ...))] [ids null]) + (cond + [(null? args) null] + [(identifier? (car args)) (loop (cdr args) (cons (car args) ids))] + [else + (syntax-case (car args) () + [(id def-expr) + (cons #`[(_ #,@(reverse ids)) + (proc-id #,@(reverse ids) def-expr)] + (loop (cdr args) (cons #'id ids)))])]))))))])) diff --git a/racket/src/expander/common/intern.rkt b/racket/src/expander/common/intern.rkt new file mode 100644 index 0000000000..ea32177ee5 --- /dev/null +++ b/racket/src/expander/common/intern.rkt @@ -0,0 +1,139 @@ +#lang racket/base + +(provide make-weak-intern-table + weak-intern!) + +;; We can't always use Racket's weak hash tables for interning, +;; because those have a lock for `equal?` comparisons. This +;; implementation uses a box and `box-cas!` to transactionally update +;; the table after failing to find an entry (and if the transaction +;; fails, we look again for an entry). + +(struct weak-intern-table (box)) +(struct table (ht ; integer[hash code] -> list of weak boxes + count ; number of items in the table (= sum of list lengths) + prune-at)) ; count at which we should try to prune empty weak boxes + +(define (make-weak-intern-table) + (weak-intern-table (box (table (hasheqv) 0 128)))) + +(define (weak-intern! tt v) + (define b (weak-intern-table-box tt)) + (define t (unbox b)) + + (define code (equal-hash-code v)) + (define vals (hash-ref (table-ht t) code null)) + + (or + ;; In the table? + (for/or ([b (in-list vals)]) + (define bv (weak-box-value b)) + (and (equal? bv v) bv)) + ;; Not in the table: + (let* ([pruned-t (if (= (table-count t) (table-prune-at t)) + (prune-table t) + t)]) + (define ht (table-ht pruned-t)) + (define new-t + (table (hash-set ht code (cons (make-weak-box v) + (hash-ref ht code null))) + (add1 (table-count pruned-t)) + (table-prune-at pruned-t))) + ;; Try to install the updated table, and return `v` if it + ;; is successfully installed + (or (and (box-cas! b t new-t) + v) + ;; Transaction failed, so try again + (weak-intern! tt v))))) + +;; Remove empty weak boxes from a table. Count the number +;; of remaining entries, and remember to prune again when +;; the number of entries doubles (up to at least reaches 128) +(define (prune-table t) + (define new-ht + (for*/hash ([(k vals) (in-hash (table-ht t))] + [new-vals (in-value + (for/list ([b (in-list vals)] + #:when (weak-box-value b)) + b))] + #:when (pair? new-vals)) + (values k new-vals))) + (define count (for/sum ([(k vals) (in-hash new-ht)]) + (length vals))) + (table new-ht + count + (max 128 (* 2 count)))) + +;; ---------------------------------------- + +(module+ test + (define show-status? #f) + + (define N 10) ; number of threads + (define M 1000) ; number of values to intern and remember + (define P 100) ; number of values to intern and discard + + (struct val (key other) + #:transparent + #:property prop:equal+hash (list + (lambda (v1 v2 eql?) (eql? (val-key v1) (val-key v2))) + (lambda (v1 code) (code (val-key v1))) + (lambda (v1 code) (code (val-key v1))))) + + (define tt (make-weak-intern-table)) + + (define results (make-vector N #f)) + + (define threads + (for/list ([i (in-range N)]) + (thread + (lambda () + (vector-set! + results + i + (for/list ([j (in-range M)]) + (for/list ([k (in-range P)]) + (weak-intern! + tt + (val (format "~a + ~a" j k) i))) + (weak-intern! tt (val (number->string j) i)))))))) + + (define done? #f) + (define measure-thread + (thread + (lambda () + (when show-status? + (let loop () + (define t (unbox (weak-intern-table-box tt))) + (printf "~s [~s]\n" + (table-count t) + (hash-count (table-ht t))) + (unless done? + (sleep 1) + (loop))))))) + + (for-each sync threads) + + (collect-garbage) + (collect-garbage) + (set! done? #t) + + (void (sync measure-thread)) + + (let ([t (prune-table (unbox (weak-intern-table-box tt)))]) + (printf "Final pruning: ~s [~s]\n" + (table-count t) + (hash-count (table-ht t))) + (unless ((table-count t) . < . (* 3 M)) + (error "too many items are still in the table; not weak enough?"))) + + (for ([i (in-range N)]) + (unless (equal? (vector-ref results i) (vector-ref results 0)) + (error "mismatch" i))) + + ;; Make sure the results come from different threads: + (define representatives + (for/fold ([ht (hasheqv)]) ([v (in-list (vector-ref results 0))]) + (hash-update ht (val-other v) add1 0))) + (unless ((hash-count representatives) . > . (* 0.25 N)) + (error "poor representation among threads;\n something is wrong, or the test is not balanced enough"))) diff --git a/racket/src/expander/common/list-ish.rkt b/racket/src/expander/common/list-ish.rkt new file mode 100644 index 0000000000..0c3ea6ccbd --- /dev/null +++ b/racket/src/expander/common/list-ish.rkt @@ -0,0 +1,42 @@ +#lang racket/base +(require (for-syntax racket/base)) + +;; A `list-ish` is like a `list`, but it can be an "improper list" that +;; doesn't end in null. Using `cons-ish` on an element and `null` returns +;; just the element. A `list-ish` makes sense when lists of length 1 +;; would otherwise be common, but only when elements are never lists. + +(provide cons-ish + in-list-ish) + +(define (cons-ish a b) + (if (null? b) + a + (cons a b))) + +(define-sequence-syntax in-list-ish + (lambda (stx) (raise-syntax-error #f "only allowed in a `for` form" stx)) + (lambda (stx) + (syntax-case stx () + [[(id) (_ lst-expr)] + (for-clause-syntax-protect + #'[(id) + (:do-in + ;;outer bindings + ([(lst) lst-expr]) + ;; outer check + (void) + ;; loop bindings + ([lst lst]) + ;; pos check + (not (null? lst)) + ;; inner bindings + ([(id) (if (pair? lst) (car lst) lst)] + [(rest) (if (pair? lst) (cdr lst) null)]) + ;; pre guard + #t + ;; post guard + #t + ;; loop args + (rest))])] + [_ #f]))) diff --git a/racket/src/expander/common/make-match.rkt b/racket/src/expander/common/make-match.rkt new file mode 100644 index 0000000000..bc8c142d32 --- /dev/null +++ b/racket/src/expander/common/make-match.rkt @@ -0,0 +1,229 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide define-define-match) + +;; Yet another pattern matcher along the lines of `syntax-rules`, but +;; intended for relatively simple and small patterns. +;; +;; The `define-match` form generated here has the following syntax to +;; match the result of against : +;; +;; (define-match ') +;; +;; = | #:when | #:unless +;; = | #:try +;; +;; = ; matches anything +;; | id: ; matches only identifiers +;; | ( ...) ; zero or more +;; | ( ...+) ; one or more +;; | ( . ) +;; +;; Note that the ' before doesn't produce a symbol or list; +;; it's just a literal to textually highlight the pattern. +;; +;; The bound by `define-match` is used as either +;; +;; () +;; +;; to check whether the match suceeded (which makes sense only if a +;; guard or `#:try` is included) or +;; +;; ( ') +;; +;; to access the value for a match. Again, the ' here does not produce +;; a symbol, but serves only as visual highlighting. +;; +;; Unlike `syntax-rules`/`syntax-case`/`syntax-parse`, there's no +;; template system and no help in making sure your uses of variables +;; before `...` expect the right shape. For example, with +;; +;; (define-match m s '(a ...)) +;; +;; then `(m 'a)` will always produce a list of matches of `a`. +;; +;; If a pattern doesn't match and there's no `#:try`, then a syntax +;; error is reported. +;; +;; The `define-define-match` form is a macro-generating macro so that +;; it can be used with different underlying notions of syntax, as +;; specific by the `rt-syntax?`, etc., macro arguments. + +(define-syntax-rule (define-define-match define-match + rt-syntax? rt-syntax-e rt-raise-syntax-error) + (... + (begin + (define-for-syntax (extract-pattern-ids pattern) + (cond + [(identifier? pattern) + (if (or (eq? '... (syntax-e pattern)) + (eq? '...+ (syntax-e pattern))) + null + (list pattern))] + [(symbol? pattern) + (if (or (eq? '... pattern) + (eq? '...+ pattern)) + null + (list pattern))] + [(syntax? pattern) (extract-pattern-ids (syntax-e pattern))] + [(pair? pattern) + (append (extract-pattern-ids (car pattern)) + (extract-pattern-ids (cdr pattern)))] + [else null])) + + ;; This pattern compiler has bad time complexity for complex + ;; patterns, because it keeps recomputing the set of pattern + ;; variables, but we're only going to use it on simple patterns + + (define-for-syntax (identifier-pattern? pattern) + (regexp-match? #rx"^id(:|$)" (symbol->string pattern))) + + (define-for-syntax (compile-pattern pattern already-checked?) + (cond + [(symbol? pattern) + (if (identifier-pattern? pattern) + (if already-checked? + #'s + #`(if (or (and (rt-syntax? s) + (symbol? (rt-syntax-e s))) + (symbol? s)) + s + (rt-raise-syntax-error #f "not an identifier" orig-s s))) + #'s)] + [else + #`(let ([s (if (rt-syntax? s) (rt-syntax-e s) s)]) + #,(cond + [(and (list? pattern) + (= (length pattern) 2) + (or (eq? '... (cadr pattern)) + (eq? '...+ (cadr pattern)))) + (with-syntax ([(pattern-id ...) (extract-pattern-ids (car pattern))]) + #`(let ([flat-s (to-syntax-list s)]) + (cond + [#,(if already-checked? #'#f #'(not flat-s)) + (rt-raise-syntax-error #f "bad syntax" orig-s)] + [#,(if (and (eq? '...+ (cadr pattern)) (not already-checked?)) #'(null? flat-s) #'#f) + (rt-raise-syntax-error #f "bad syntax" orig-s)] + [else + #,(if (and (symbol? (car pattern)) + (or (not (identifier-pattern? (car pattern))) + already-checked?)) + #`flat-s + #`(for/lists (pattern-id ...) ([s (in-list flat-s)]) + #,(compile-pattern (car pattern) already-checked?)))])))] + [(pair? pattern) + (with-syntax ([(a-pattern-id ...) (generate-temporaries (extract-pattern-ids (car pattern)))] + [(d-pattern-id ...) (generate-temporaries (extract-pattern-ids (cdr pattern)))]) + #`(if #,(if already-checked? #'#t #'(pair? s)) + (let-values ([(a-pattern-id ...) (let ([s (car s)]) #,(compile-pattern (car pattern) + already-checked?))] + [(d-pattern-id ...) (let ([s (cdr s)]) #,(compile-pattern (cdr pattern) + already-checked?))]) + (values a-pattern-id ... d-pattern-id ...)) + (rt-raise-syntax-error #f "bad syntax" orig-s)))] + [(null? pattern) + (if already-checked? + #'(values) + #'(if (null? s) + (values) + (rt-raise-syntax-error #f "bad syntax" orig-s)))] + [(or (keyword? pattern) + (boolean? pattern)) + (if already-checked? + #'(values) + #`(if (eq? '#,pattern s) + (values) + (rt-raise-syntax-error #f "bad syntax" orig-s)))] + [else + (raise-syntax-error 'define-match "bad pattern" pattern)]))])) + + (define-for-syntax (compile-pattern-check pattern) + (cond + [(symbol? pattern) + (if (identifier-pattern? pattern) + #`(or (and (rt-syntax? s) + (symbol? (rt-syntax-e s))) + (symbol? s)) + #'#t)] + [else + #`(let ([s (if (rt-syntax? s) (rt-syntax-e s) s)]) + #,(cond + [(and (list? pattern) + (= (length pattern) 2) + (or (eq? '... (cadr pattern)) + (eq? '...+ (cadr pattern)))) + (with-syntax ([(pattern-id ...) (extract-pattern-ids (car pattern))]) + #`(let ([flat-s (to-syntax-list s)]) + (cond + [(not flat-s) #f] + [#,(if (eq? '...+ (cadr pattern)) #'(null? flat-s) #'#f) #f] + [else #,(if (and (symbol? (car pattern)) + (not (identifier-pattern? (car pattern)))) + #`#t + #`(for/and ([s (in-list flat-s)]) + #,(compile-pattern-check (car pattern))))])))] + [(pair? pattern) + (with-syntax ([(a-pattern-id ...) (extract-pattern-ids (car pattern))] + [(d-pattern-id ...) (extract-pattern-ids (cdr pattern))]) + #`(and (pair? s) + (let ([s (car s)]) #,(compile-pattern-check (car pattern))) + (let ([s (cdr s)]) #,(compile-pattern-check (cdr pattern)))))] + [(null? pattern) + #'(null? s)] + [(or (keyword? pattern) + (boolean? pattern)) + #`(eq? '#,pattern s)] + [else + (raise-syntax-error 'define-match "bad pattern" pattern)]))])) + + (define (to-syntax-list s) + (cond + [(list? s) s] + [(pair? s) + (define r (to-syntax-list (cdr s))) + (and r (cons (car s) r))] + [(rt-syntax? s) (to-syntax-list (rt-syntax-e s))] + [else #f])) + + (define-syntax (define-match stx) + (syntax-case stx (quote) + [(_ id expr 'pattern) + #'(do-define-match id expr 'pattern #:when #t #:try? #f)] + [(_ id expr #:try 'pattern) + #'(do-define-match id expr 'pattern #:when #t #:try? #t)] + [(_ id expr #:when guard-expr 'pattern) + #'(do-define-match id expr 'pattern #:when guard-expr #:try? #f)] + [(_ id expr #:when guard-expr #:try 'pattern) + #'(do-define-match id expr 'pattern #:when guard-expr #:try? #t)] + [(_ id expr #:unless guard-expr 'pattern) + #'(do-define-match id expr 'pattern #:when (not guard-expr) #:try? #f)] + [(_ id expr #:unless guard-expr #:try 'pattern) + #'(do-define-match id expr 'pattern #:when (not guard-expr) #:try? #t)])) + + (define-syntax (do-define-match stx) + (syntax-case stx (quote) + [(_ id expr 'pattern #:when guard-expr #:try? try?) + (let ([pattern-ids (extract-pattern-ids #'pattern)] + [try? (syntax-e #'try?)]) + (with-syntax ([(pattern-id ...) pattern-ids] + [(pattern-result-id ...) (generate-temporaries pattern-ids)] + [(false-result ...) (map (lambda (x) #'#f) pattern-ids)] + [matcher (compile-pattern (syntax->datum #'pattern) try?)]) + #`(begin + (define-values (ok? pattern-result-id ...) + (let ([s expr]) + (if (and guard-expr + #,(if try? + (compile-pattern-check (syntax->datum #'pattern)) + #'#t)) + (let ([orig-s s]) + (let-values ([(pattern-result-id ...) matcher]) + (values #t pattern-result-id ...))) + (values #f false-result ...)))) + (define-syntax id + (syntax-rules (quote pattern-id ...) + [(m) ok?] + [(m (quote pattern-id)) + pattern-result-id] + ...)))))]))))) diff --git a/racket/src/expander/common/memo.rkt b/racket/src/expander/common/memo.rkt new file mode 100644 index 0000000000..07fd171c95 --- /dev/null +++ b/racket/src/expander/common/memo.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide define-memo-lite) + +;; Lightweight memorization by storing only the most recent result +(define-syntax (define-memo-lite stx) + (syntax-case stx () + [(_ (id arg ...) body0 body ...) + (with-syntax ([(prev-val ...) (generate-temporaries #'(arg ...))]) + #'(begin + (define prev-val #f) ... + (define prev-result #f) + (define (id arg ...) + (cond + [(and (eq? prev-val arg) ...) + prev-result] + [else + (define r (let () + body0 + body ...)) + (set! prev-val arg) ... + (set! prev-result r) + r]))))])) diff --git a/racket/src/expander/common/module-path-intern.rkt b/racket/src/expander/common/module-path-intern.rkt new file mode 100644 index 0000000000..d8e3cedb02 --- /dev/null +++ b/racket/src/expander/common/module-path-intern.rkt @@ -0,0 +1,38 @@ +#lang racket/base +(require "module-path.rkt" + (submod "module-path.rkt" for-intern)) + +(provide make-module-path-index-intern-table + intern-module-path-index!) + +(struct mpi-intern-table (normal ; name[not #f] -[`equal?`-based]-> base -[`eq?`-based]-> module path index + fast)) ; superset, but `eq?`-keyed for fast already-interned checks + +(define (make-module-path-index-intern-table) + (mpi-intern-table (make-hash) (make-hasheq))) + +(define (intern-module-path-index! t mpi) + (or (hash-ref (mpi-intern-table-fast t) mpi #f) + (let-values ([(name base) (module-path-index-split mpi)]) + (cond + [(not name) + (hash-set! (mpi-intern-table-fast t) mpi mpi) + mpi] + [else + (define interned-base (and base + (intern-module-path-index! t base))) + (define at-name + (or (hash-ref (mpi-intern-table-normal t) name #f) + (let ([at-name (make-hasheq)]) + (hash-set! (mpi-intern-table-normal t) name at-name) + at-name))) + (define i-mpi + (or (hash-ref at-name interned-base #f) + (let ([mpi (if (eq? base interned-base) + mpi + (struct-copy module-path-index mpi + [base interned-base]))]) + (hash-set! at-name interned-base mpi) + mpi))) + (hash-set! (mpi-intern-table-fast t) mpi i-mpi) + i-mpi])))) diff --git a/racket/src/expander/common/module-path.rkt b/racket/src/expander/common/module-path.rkt new file mode 100644 index 0000000000..eca500d50d --- /dev/null +++ b/racket/src/expander/common/module-path.rkt @@ -0,0 +1,470 @@ +#lang racket/base +(require "../compile/serialize-property.rkt" + "contract.rkt" + "parse-module-path.rkt" + "intern.rkt") + +(provide module-path? + + resolved-module-path? + make-resolved-module-path + resolved-module-path-name + resolved-module-path-root-name + resolved-module-path->module-path + + module-path-index? + module-path-index-resolve + module-path-index-unresolve + module-path-index-join + module-path-index-split + module-path-index-submodule + make-self-module-path-index + make-generic-self-module-path-index + imitate-generic-module-path-index! + module-path-index-shift + module-path-index-resolved ; returns #f if not yet resolved + + top-level-module-path-index + top-level-module-path-index? + + resolve-module-path + current-module-name-resolver + build-module-name + + current-module-declare-name + current-module-declare-source + substitute-module-declare-name + + deserialize-module-path-index) + +(module+ for-intern + (provide (struct-out module-path-index))) + +;; ---------------------------------------- + +(struct resolved-module-path (name) + #:authentic + #:property prop:equal+hash + ;; Although equal resolved module paths are `eq?` externally, + ;; we need this equality predicate to hash them for the + ;; interning table + (list (lambda (a b eql?) + (eql? (resolved-module-path-name a) + (resolved-module-path-name b))) + (lambda (a hash-code) + (hash-code (resolved-module-path-name a))) + (lambda (a hash-code) + (hash-code (resolved-module-path-name a)))) + #:property prop:custom-write + (lambda (r port mode) + (when mode + (write-string "#" port))) + #:property prop:serialize + (lambda (r ser-push! state) + (ser-push! 'tag '#:resolved-module-path) + (ser-push! (resolved-module-path-name r)))) + +(define (deserialize-resolved-module-path n) + (make-resolved-module-path n)) + +(define (format-resolved-module-path-name p) + (cond + [(path? p) (string-append "\"" (path->string p) "\"")] + [(symbol? p) (format-symbol p)] + [else (format-submod (format-resolved-module-path-name (car p)) + (cdr p))])) + +(define (format-symbol p) + (format "'~s~a" p (if (symbol-interned? p) + "" + (format "[~a]" (eq-hash-code p))))) + +(define (format-submod base syms) + (format "(submod ~a~a)" + base + (apply string-append (for/list ([i (in-list syms)]) + (format " ~s" i))))) + +(define (resolved-module-path-root-name r) + (define name (resolved-module-path-name r)) + (if (pair? name) + (car name) + name)) + +(define resolved-module-paths (make-weak-intern-table)) + +(define (make-resolved-module-path p) + (unless (or (symbol? p) + (and (path? p) (complete-path? p)) + (and (pair? p) + (pair? (cdr p)) + (list? p) + (or (symbol? (car p)) + (and (path? (car p)) (complete-path? (car p)))) + (for/and ([s (in-list (cdr p))]) + (symbol? s)))) + (raise-argument-error 'make-resolved-module-path + (string-append + "(or/c symbol?\n" + " (and/c path? complete-path?)\n" + " (cons/c (or/c symbol?\n" + " (and/c path? complete-path?))\n" + " (non-empty-listof symbol?)))") + p)) + (weak-intern! resolved-module-paths (resolved-module-path p))) + +(define (resolved-module-path->module-path r) + (define name (resolved-module-path-name r)) + (define root-name (if (pair? name) (car name) name)) + (define root-mod-path (if (path? root-name) + root-name + `(quote ,root-name))) + (if (pair? name) + `(submod ,root-mod-path ,@(cdr name)) + root-mod-path)) + +;; ---------------------------------------- + +(struct module-path-index (path base [resolved #:mutable] [shift-cache #:mutable]) + #:authentic + #:property prop:equal+hash + (list (lambda (a b eql?) + (and (eql? (module-path-index-path a) + (module-path-index-path b)) + (eql? (module-path-index-base a) + (module-path-index-base b)))) + (lambda (a hash-code) + (and (+ (hash-code (module-path-index-path a)) + (hash-code (module-path-index-base a))))) + (lambda (a hash-code) + (and (+ (hash-code (module-path-index-path a)) + (hash-code (module-path-index-base a)))))) + #:property prop:custom-write + (lambda (r port mode) + (write-string "#" port))) + +;; Serialization of a module path index is handled specially, because they +;; must be shared across phases of a module +(define deserialize-module-path-index + (case-lambda + [(path base) (module-path-index-join path base)] + [(name) (make-self-module-path-index (make-resolved-module-path name))] + [() top-level-module-path-index])) + +(define (module-path-index-resolve mpi [load? #f]) + (check 'module-path-index-resolve module-path-index? mpi) + (or (module-path-index-resolved mpi) + (let ([mod-name ((current-module-name-resolver) + (module-path-index-path mpi) + (module-path-index-resolve/maybe + (module-path-index-base mpi) + load?) + #f + load?)]) + (unless (resolved-module-path? mod-name) + (raise-arguments-error 'module-path-index-resolve + "current module name resolver's result is not a resolved module path" + "result" mod-name)) + (set-module-path-index-resolved! mpi mod-name) + mod-name))) + +(define (module-path-index-unresolve mpi) + (cond + [(module-path-index-resolved mpi) + (define-values (path base) (module-path-index-split mpi)) + (module-path-index-join path base)] + [else mpi])) + +(define (module-path-index-join mod-path base [submod #f]) + (unless (or (not mod-path) + (module-path? mod-path)) + (raise-argument-error 'module-path-index-join "(or/c #f module-path?)" mod-path)) + (unless (or (not base) + (resolved-module-path? base) + (module-path-index? base)) + (raise-argument-error 'module-path-index-join "(or/c #f resolved-module-path? module-path-index?)" base)) + (unless (or (not submod) + (and (pair? submod) + (list? submod) + (andmap symbol? submod))) + (raise-argument-error 'module-path-index-join "(or/c #f (non-empty-listof symbol?))" submod)) + (when (and (not mod-path) + base) + (raise-arguments-error 'module-path-index-join + "cannot combine #f path with non-#f base" + "given base" base)) + (when (and submod mod-path) + (raise-arguments-error 'module-path-index-join + "cannot combine #f submodule list with non-#f module path" + "given module path" mod-path + "given submodule list" submod)) + (cond + [submod + (make-self-module-path-index (make-resolved-module-path + (cons generic-module-name submod)))] + [else + (define keep-base + (let loop ([mod-path mod-path]) + (cond + [(path? mod-path) #f] + [(and (pair? mod-path) (eq? 'quote (car mod-path))) #f] + [(symbol? mod-path) #f] + [(and (pair? mod-path) (eq? 'submod (car mod-path))) + (loop (cadr mod-path))] + [else base]))) + (module-path-index mod-path keep-base #f #f)])) + +(define (module-path-index-resolve/maybe base load?) + (if (module-path-index? base) + (module-path-index-resolve base load?) + base)) + +(define (module-path-index-split mpi) + (check 'module-path-index-split module-path-index? mpi) + (values (module-path-index-path mpi) + (module-path-index-base mpi))) + +(define (module-path-index-submodule mpi) + (check 'module-path-index-submodule module-path-index? mpi) + (and (not (module-path-index-path mpi)) + (let ([r (module-path-index-resolved mpi)]) + (and r + (let ([p (resolved-module-path-name r)]) + (and (pair? p) + (cdr p))))))) + +(define make-self-module-path-index + (case-lambda + [(name) (module-path-index #f #f name #f)] + [(name enclosing) + (make-self-module-path-index (build-module-name name + (and enclosing + (module-path-index-resolve enclosing))))])) + +;; A "generic" module path index is used by the exansion of `module`; every +;; expanded module (at the same submodule nesting and name) uses the same +;; generic module path, so that compilation can recognize references within +;; the module to itself, and so on +(define generic-self-mpis (make-weak-hash)) +(define generic-module-name '|expanded module|) + +;; Return a module path index that is the same for a given +;; submodule path in the given self module path index +(define (make-generic-self-module-path-index self) + (define r (resolved-module-path-to-generic-resolved-module-path + (module-path-index-resolved self))) + (or (let ([e (hash-ref generic-self-mpis r #f)]) + (and e (ephemeron-value e))) + (let ([mpi (module-path-index #f #f r #f)]) + (hash-set! generic-self-mpis r (make-ephemeron r mpi)) + mpi))) + +(define (resolved-module-path-to-generic-resolved-module-path r) + (define name (resolved-module-path-name r)) + (make-resolved-module-path + (if (symbol? name) + generic-module-name + (cons generic-module-name (cdr name))))) + +;; Mutate the resolved path in `mpi` to use the root module name of a +;; generic module path index, which means that future +;; `free-identifier=?` comparisons with the generic module path index +;; will succeed +(define (imitate-generic-module-path-index! mpi) + (define r (module-path-index-resolved mpi)) + (when r + (set-module-path-index-resolved! mpi + (resolved-module-path-to-generic-resolved-module-path r)))) + +(define (module-path-index-shift mpi from-mpi to-mpi) + (cond + [(eq? mpi from-mpi) to-mpi] + [else + (define base (module-path-index-base mpi)) + (cond + [(not base) mpi] + [else + (define shifted-base (module-path-index-shift base from-mpi to-mpi)) + (cond + [(eq? shifted-base base) mpi] + [(shift-cache-ref (module-path-index-shift-cache shifted-base) mpi)] + [else + (define shifted-mpi + (module-path-index (module-path-index-path mpi) shifted-base #f #f)) + (shift-cache-set! (module-path-index-shift-cache! shifted-base) mpi shifted-mpi) + shifted-mpi])])])) + +(define (module-path-index-shift-cache! mpi) + (or (let ([cache (module-path-index-shift-cache mpi)]) + (and cache + (weak-box-value cache) + cache)) + (let ([cache (make-weak-box (box #hasheq()))]) + (set-module-path-index-shift-cache! mpi cache) + cache))) + +(define (shift-cache-ref cache v) + (and cache + (let ([b (weak-box-value cache)]) + (and b (hash-ref (unbox b) v #f))))) + +(define (shift-cache-set! cache v r) + (define b (weak-box-value cache)) + (when b + (set-box! b (hash-set (unbox b) v r)))) + +;; A constant module path index to represent the top level +(define top-level-module-path-index + (make-self-module-path-index + (make-resolved-module-path 'top-level))) + +(define (top-level-module-path-index? mpi) + (eq? top-level-module-path-index mpi)) + +;; ---------------------------------------- + +(define (resolve-module-path mod-path base) + ((current-module-name-resolver) mod-path base #f #t)) + +;; The resolver in "../boot/handler.rkt" replaces this one +;; as the value of `current-module-name-resolver` +(define core-module-name-resolver + (case-lambda + [(name from-namespace) + ;; No need to register + (void)] + [(p enclosing source-stx-stx load?) + (unless (module-path? p) + (raise-argument-error 'core-module-name-resolver "module-path?" p)) + (unless (or (not enclosing) + (resolved-module-path? enclosing)) + (raise-argument-error 'core-module-name-resolver "resolved-module-path?" enclosing)) + (cond + [(and (list? p) + (= (length p) 2) + (eq? 'quote (car p)) + (symbol? (cadr p))) + (make-resolved-module-path (cadr p))] + [(and (list? p) + (eq? 'submod (car p)) + (equal? ".." (cadr p))) + (for/fold ([enclosing enclosing]) ([s (in-list (cdr p))]) + (build-module-name s enclosing #:original p))] + [(and (list? p) + (eq? 'submod (car p)) + (equal? "." (cadr p))) + (for/fold ([enclosing enclosing]) ([s (in-list (cddr p))]) + (build-module-name s enclosing #:original p))] + [(and (list? p) + (eq? 'submod (car p))) + (let ([base ((current-module-name-resolver) (cadr p) enclosing #f #f)]) + (for/fold ([enclosing base]) ([s (in-list (cddr p))]) + (build-module-name s enclosing #:original p)))] + [else + (error 'core-module-name-resolver + "not a supported module path: ~v" p)])])) + +;; Build a submodule name given an enclosing module name, if cany +(define (build-module-name name ; a symbol + enclosing ; #f => no enclosing module + #:original [orig-name name]) ; for error reporting + (define enclosing-module-name (and enclosing + (resolved-module-path-name enclosing))) + (make-resolved-module-path + (cond + [(not enclosing-module-name) name] + [(symbol? enclosing-module-name) (list enclosing-module-name name)] + [(equal? name "..") + (cond + [(symbol? enclosing-module-name) + (error "too many \"..\"s:" orig-name)] + [(= 2 (length enclosing-module-name)) (car enclosing-module-name)] + [else (reverse (cdr (reverse enclosing-module-name)))])] + [else (append enclosing-module-name (list name))]))) + +;; Parameter that can be set externally: +(define current-module-name-resolver + (make-parameter + core-module-name-resolver + (lambda (v) + (unless (and (procedure? v) + (procedure-arity-includes? v 2) + (procedure-arity-includes? v 4)) + (raise-argument-error 'current-module-name-resolver + "(and/c (procedure-arity-includes/c 2) (procedure-arity-includes/c 4))" + v)) + v))) + +;; ---------------------------------------- + +(define current-module-declare-name + (make-parameter #f + (lambda (r) + (unless (or (not r) + (resolved-module-path? r)) + (raise-argument-error 'current-module-declare-name + "(or/c #f resolved-module-path?)" + r)) + r))) + +(define current-module-declare-source + (make-parameter #f + (lambda (s) + (unless (or (not s) + (symbol? s) + (and (path? s) (complete-path? s))) + (raise-argument-error 'current-module-declare-source + "(or/c #f symbol? (and/c path? complete-path?))" + s)) + s))) + +(define (substitute-module-declare-name default-name) + (define current-name (current-module-declare-name)) + (define root-name (if current-name + (resolved-module-path-root-name current-name) + (if (pair? default-name) + (car default-name) + default-name))) + (make-resolved-module-path + (if (pair? default-name) + (cons root-name (cdr default-name)) + root-name))) diff --git a/racket/src/expander/common/parse-module-path.rkt b/racket/src/expander/common/parse-module-path.rkt new file mode 100644 index 0000000000..fe9851071e --- /dev/null +++ b/racket/src/expander/common/parse-module-path.rkt @@ -0,0 +1,445 @@ +#lang racket/base + +(provide module-path?) + +;; This parser for module paths is written in a relatively primitive +;; style, becaue it's applied often and we want it to be fast. + +(define (module-path? v) + (or (and (pair? v) + (eq? (car v) 'submod) + (submodule-module-path? v)) + (root-module-path? v))) + +(define (root-module-path? v) + (or (path? v) + (and (string? v) + (string-module-path? v)) + (and (symbol? v) + (symbol-module-path? v)) + (and (pair? v) + (case (car v) + [(quote) (and (pair? (cdr v)) + (symbol? (cadr v)) + (null? (cddr v)))] + [(lib) (lib-module-path? v)] + [(file) (and (pair? (cdr v)) + (string? (cadr v)) + (path-string? (cadr v)) + (null? (cddr v)))] + [(planet) (planet-module-path? v)] + [else #f])))) + +(define (submodule-module-path? v) + (and (pair? (cdr v)) + (list? v) + (or (equal? (cadr v) "..") + (equal? (cadr v) ".") + (root-module-path? (cadr v))) + (for/and ([e (in-list (cddr v))]) + (or (equal? e "..") + (symbol? e))))) + +(define (string-module-path? v) + (module-path-string? v #:dots-dir-ok? #t #:just-file-ok? #t #:file-end-ok? #t)) + +(define (symbol-module-path? v) + (module-path-string? (symbol->string v))) + +(define (lib-module-path? v) + (and (list? v) + (pair? (cdr v)) + (let loop ([v (cdr v)] [first? #t]) + (or (null? v) + (and (string? (car v)) + (module-path-string? (car v) + #:just-file-ok? first? + #:file-end-ok? first?) + (loop (cdr v) #f)))))) + +(define (planet-module-path? v) + (and (list? v) + (case (length v) + [(1) #f] + [(2) + (define e (cadr v)) + (cond + [(string? e) + (module-path-string? e + #:for-planet? #t + #:file-end-ok? #t)] + [(symbol? e) + (module-path-string? (symbol->string e) + #:for-planet? #t)] + [else #f])] + [else + (define file (cadr v)) + (define pkg (caddr v)) + (define subs (cdddr v)) + (and file + (module-path-string? file + #:just-file-ok? #t + #:file-end-ok? #t) + (and (list? pkg) + (<= 2 (length pkg) 4) + (planet-user/pkg-string? (car pkg)) + (planet-user/pkg-string? (cadr pkg)) + (or (null? (cddr pkg)) + (planet-version-number? (caddr pkg)) + (and (or (null? (cddr pkg)) + (planet-version-minor-spec? (cadddr pkg)))))) + (for/and ([sub (in-list subs)]) + (module-path-string? sub)))]))) + +(define (planet-version-number? v) + (exact-nonnegative-integer? v)) + +(define (planet-version-minor-spec? v) + (or (planet-version-number? v) + (and (pair? v) + (list? v) + (= 2 (length v)) + (case (car v) + [(= + -) + (planet-version-number? (cadr v))] + [else + (and (planet-version-number? (car v)) + (planet-version-number? (cadr v)))])))) + +;; ---------------------------------------- + +(define (module-path-string? v + #:for-planet? [for-planet? #f] + #:dots-dir-ok? [dots-dir-ok? #f] + #:just-file-ok? [just-file-ok? #f] + #:file-end-ok? [file-end-ok? #f]) + (define len (string-length v)) + (and (positive? len) + (not (char=? #\/ (string-ref v 0))) + (not (char=? #\/ (string-ref v (sub1 len)))) + (let-values ([(start-package-version-pos end-package-version-pos) + (if for-planet? + (check-planet-part v len) + (values 0 0))]) + (and + start-package-version-pos + (let loop ([i (sub1 len)] + [prev-was-slash? #f] + [saw-slash? (not file-end-ok?)] + [saw-dot? #f]) + (cond + [(not (zero? i)) + ;; check next character + (define c (string-ref v i)) + (cond + [(char=? c #\/) + (and (not prev-was-slash?) + (loop (sub1 i) #t #t saw-dot?))] + [(char=? c #\.) + (if (and ((add1 i) . < . len) + (not (char=? (string-ref v (add1 i)) #\/)) + (not (char=? (string-ref v (add1 i)) #\.))) + (and (not saw-slash?) ; can't have suffix on a directory + (loop (sub1 i) #f saw-slash? #t)) + (loop (sub1 i) #f saw-slash? saw-dot?))] + [(or (plain-char? c) + (and (char=? c #\%) + ((+ i 2) . < . len) + (hex-sequence? v (add1 i)))) + (loop (sub1 i) #f saw-slash? saw-dot?)] + [(and (i . >= . start-package-version-pos) (i . < . end-package-version-pos)) + ;; We've already checked characters in the package-version range + (loop (sub1 i) #f saw-slash? saw-dot?)] + [else #f])] + [else + ;; checked all characters + (and + ;; can't have a file name with no directory + (not (and (not just-file-ok?) + saw-dot? + (not saw-slash?))) + + (or dots-dir-ok? + ;; double-check for delimited "." or ".." + (let loop ([i 0]) + (cond + [(= i len) #t] + [(char=? (string-ref v i) #\.) + (and + ;; not "." + (not (or (= len (add1 i)) + (char=? (string-ref v (add1 i)) #\/))) + ;; not ".." + (not (and (char=? (string-ref v (add1 i)) #\.) + (or (= len (+ i 2)) + (char=? (string-ref v (+ i 2)) #\/)))) + ;; Skip over "."s: + (loop (let loop ([i i]) + (if (char=? #\. (string-ref v i)) + (loop (add1 i)) + i))))] + [else (loop (add1 i))]))))])))))) + +(define (planet-user/pkg-string? v) + (and (string? v) + (let ([len (string-length v)]) + (and (positive? len) + (for/and ([c (in-string v)] + [i (in-naturals)]) + (or (plain-char? c) + (char=? #\. c) + (and (char=? #\% c) + (i . < . (- len 2)) + (hex-sequence? v (add1 i))))))))) + +(define (plain-char? c) + (or (char<=? #\a c #\z) + (char<=? #\A c #\Z) + (char<=? #\0 c #\9) + (char=? #\- c) + (char=? #\_ c) + (char=? #\+ c))) + +(define (hex-sequence? s i) + (define c1 (string-ref s i)) + (define c2 (string-ref s (add1 i))) + (and (hex-char? c1) + (hex-char? c2) + (let ([c (integer->char (+ (* (hex-char->integer c1) 16) + (hex-char->integer c2)))]) + (not (plain-char? c))))) + +(define (hex-char? c) + (or (char<=? #\a c #\f) + (char<=? #\0 c #\9))) + +(define (hex-char->integer c) + (cond + [(char<=? #\a c #\f) + (- (char->integer c) (+ 10 (char->integer #\a)))] + [(char<=? #\A c #\F) + (- (char->integer c) (+ 10 (char->integer #\A)))] + [else + (- (char->integer c) (char->integer #\0))])) + +;; ---------------------------------------- + +(define (check-planet-part v len) + ;; Must have at least two slashes, and a version spec is allowed between them + (define-values (start-package-version-pos end-package-version-pos colon1-pos colon2-pos) + (let loop ([j 0] + [start-package-version-pos #f] [end-package-version-pos #f] + [colon1-pos #f] [colon2-pos #f]) + (cond + [(= j len) (values start-package-version-pos (or end-package-version-pos j) + colon1-pos colon2-pos)] + [else + (case (string-ref v j) + [(#\/) + (loop (add1 j) + (or start-package-version-pos (add1 j)) + (and start-package-version-pos + (or end-package-version-pos j)) + colon1-pos colon2-pos)] + [(#\:) + (cond + [colon2-pos (values #f #f #f #f)] + [colon1-pos + (loop (add1 j) + start-package-version-pos end-package-version-pos + colon1-pos j)] + [else + (loop (add1 j) + start-package-version-pos end-package-version-pos + j #f)])] + [else + (loop (add1 j) + start-package-version-pos end-package-version-pos + colon1-pos colon2-pos)])]))) + + (cond + [(and start-package-version-pos + (end-package-version-pos . > . start-package-version-pos) + (or (not colon2-pos) ((add1 colon2-pos) . < . end-package-version-pos))) + (cond + [colon1-pos + ;; Check that the version spec is well-formed + (define colon1-end (or colon2-pos end-package-version-pos)) + (cond + [(and (integer-sequence? v (add1 colon1-pos) colon1-end) + (or (not colon2-pos) + (case (string-ref v (add1 colon2-pos)) + [(#\=) + (integer-sequence? v (+ 2 colon2-pos) end-package-version-pos)] + [(#\> #\<) + (cond + [(and ((+ 2 colon2-pos) . < . end-package-version-pos) + (char=? #\= (string-ref v (+ colon2-pos 2)))) + (integer-sequence? v (+ 3 colon2-pos) end-package-version-pos)] + [else + (integer-sequence? v (+ 2 colon2-pos) end-package-version-pos)])] + [else + (integer-range-sequence? v (add1 colon2-pos) end-package-version-pos)]))) + ;; Version spec => need to skip a range + (values colon1-pos end-package-version-pos)] + [else + ;; Bad version spec + (values #f #f)])] + [else + ;; No version spec => nothing to skip later + (values 0 0)])] + [else + ;; Bad 'planet path + (values #f #f)])) + +(define (integer-sequence? s start end) + (and (start . < . end) + (for/and ([i (in-range start end)]) + (char<=? #\0 (string-ref s i) #\9)))) + +(define (integer-range-sequence? s start end) + (and (start . < . end) + (for/and ([i (in-range start end)]) + (define c (string-ref s i)) + (or (char=? c #\-) + (char<=? #\0 c #\9))) + (1 . >= . (for/sum ([i (in-range start end)]) + (if (char=? (string-ref s i) #\-) + 1 + 0))))) + +;; ---------------------------------------- + +(module+ test + (define (test ok? v) + (unless (equal? ok? (module-path? v)) + (error 'module-path?-test "failed ~s; expected ~a" v ok?))) + + (test #t "hello") + (test #t "hello.rkt") + (test #f "hello*ss") + (test #t "hello%2ess") + (test #t "hello%00ss") + (test #f "hello%2Ess") + (test #f "hello%41ss") + (test #f "hello%4") + (test #f "hello%") + (test #f "hello%q0") + (test #f "hello%0q") + (test #f "foo.rkt/hello") + (test #f "foo/") + (test #f "a/foo/") + (test #f "/foo.rkt") + (test #f "/a/foo.rkt") + (test #f "a/foo.rkt/b") + (test #t "a/foo%2ess/b") + (test #t "a/_/b") + (test #t "a/0123456789+-_/b.---") + (test #t "a/0123456789+-_/b.-%2e") + (test #t "../foo.rkt") + (test #t "x/../foo.rkt") + (test #t "x/./foo.rkt") + (test #t "x/.") + (test #t "x/..") + + (test #t (collection-file-path "module.rktl" "tests" "racket")) + (test #t (string->path "x")) + + (test #t 'hello) + (test #f 'hello/) + (test #f 'hello.rkt) + (test #t 'hello%2ess) + (test #f 'hello%2Ess) + (test #f 'hello/a.rkt) + (test #f '/hello/a.rkt) + (test #f '/hello) + (test #f '/a/hello) + (test #f 'a//hello) + (test #f '../hello) + (test #f './hello) + (test #f 'a/../hello) + (test #f 'b/./hello) + (test #f 'b/*/hello) + + (test #t '(lib "hello")) + (test #f '(lib "hello/")) + (test #f '(lib "hello/../b")) + (test #t '(lib "hello/a")) + (test #t '(lib "hello/a.rkt")) + (test #f '(lib "hello.bb/a.rkt")) + (test #f '(lib "/hello/a.rkt")) + (test #t '(lib "hello/a.rkt" "ack")) + (test #t '(lib "hello/a.rkt" "ack" "bar")) + (test #t '(lib "hello/a.rkt" "ack/bar")) + (test #f '(lib "hello/a.rkt" "ack/")) + (test #f '(lib "hello/a.rkt" "ack" "/bar")) + (test #f '(lib "hello/a.rkt" "ack" "..")) + (test #f '(lib "hello/a.rkt" "ack" bar)) + (test #f '(lib "hello/a.rkt" . bar)) + (test #f '(lib . "hello/a.rkt")) + (test #f '(lib)) + + (test #f '(planet)) + (test #f '(planet robby)) + (test #t '(planet robby/redex)) + (test #t '(planet robby%2e/%2eredex)) + (test #f '(planet robby%2/redex)) + (test #f '(planet robby/redex%2)) + (test #f '(planet robby/redex/)) + (test #f '(planet robby/redex/foo/)) + (test #f '(planet /robby/redex/foo)) + (test #f '(planet robby/redex.plt/foo)) + (test #f '(planet robby/redex/foo.rkt)) + (test #f '(planet robby/redex/foo.rkt/bar)) + (test #f '(planet robby/../foo)) + (test #t '(planet robby/redex/foo)) + (test #t '(planet robby/redex/foo/bar)) + (test #t '(planet robby/redex:7/foo)) + (test #t '(planet robby/redex:7)) + (test #t '(planet robby/redex:7:8/foo)) + (test #t '(planet robby/redex:7:<=8/foo)) + (test #t '(planet robby/redex:7:>=8/foo)) + (test #t '(planet robby/redex:7:8-9/foo)) + (test #t '(planet robby/redex:7:8-9)) + (test #t '(planet robby/redex:700:800-00900/foo)) + (test #t '(planet robby/redex:700:800-00900/foo%2e)) + (test #f '(planet robby/redex:=7/foo)) + (test #f '(planet robby/redex::8/foo)) + (test #f '(planet robby/redex:7:/foo)) + (test #f '(planet robby/redex.plt:7:8/foo)) + (test #f '(planet robby/redex:a/foo)) + (test #f '(planet robby/redex:7:a/foo)) + (test #f '(planet robby/redex:7:a-10/foo)) + (test #f '(planet robby/redex:7:10-a/foo)) + + (test #f '(planet "foo.rkt")) + (test #t '(planet "foo.rkt" ("robby" "redex.plt"))) + (test #f '(planet "../foo.rkt" ("robby" "redex.plt"))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt" 7 (7 8)))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt" 7 8))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt" 7 (= 8)))) + (test #t '(planet "foo.rkt" ("robby" "redex.plt") "sub" "deeper")) + (test #t '(planet "foo%2e.rkt" ("robby%2e" "redex%2e.plt") "sub%2e" "%2edeeper")) + + (test #t '(submod ".")) + (test #t '(submod "." x)) + (test #t '(submod "." x y)) + (test #t '(submod "." x ".." y)) + (test #t '(submod "." x ".." y ".." ".." "..")) + (test #f '(submod "." "x" y)) + (test #f '(submod "." x "y")) + (test #t '(submod "..")) + (test #t '(submod ".." x)) + (test #t '(submod ".." x y)) + (test #f '(submod ".." "x" y)) + (test #f '(submod ".." x "y")) + (test #t '(submod ".." "..")) + (test #f '(submod ".." ".")) + + (test #t '(submod x a b)) + (test #f '(submod x "a" b)) + + (test #t '(submod 'x a)) + (test #t '(submod 'x)) + + (printf "Passed all tests\n")) diff --git a/racket/src/expander/common/performance.rkt b/racket/src/expander/common/performance.rkt new file mode 100644 index 0000000000..947bbd091e --- /dev/null +++ b/racket/src/expander/common/performance.rkt @@ -0,0 +1,197 @@ +#lang racket/base + +(provide performance-region) + +;; To enable measurement, see the end of this file. + +;; The expression form +;; +;; (performance-region [key-expr ...] body ....) +;; +;; records the time of `body ...` and associated it with +;; the path `(list key-expr ...)`. Times for a path +;; are included in the times for the path's prefixes, but +;; not for any other path. When regions that are nested +;; dynamically, time accumlates only for the most nested +;; region. +;; +;; For example, +;; +;; (performance-region +;; ['compile 'module] +;; (do-expand-module)) +;; +;; counts the time for `(do-expand-module)` to '(compile) and +;; to '(compile module), and not to any other path, even if +;; the compilation occurs while expanding another module. +;; +;; The key '_ as a path element is special: it is replaced +;; by the correspondig element of the enclosing region's +;; path (if any). +;; +;; Beware that `body ...` is not in tail position when +;; performance measurement is enabled. + +;; ------------------------------------------------------------ +;; Re-export this submodule to enable performance measurements + +(module measure-mode racket/base + (provide performance-region) + + (define-syntax-rule (performance-region [tag0-expr tag-expr ...] body ...) + (begin + (start-performance-region tag0-expr tag-expr ...) + (begin0 + (let () body ...) + (end-performance-region)))) + + (define region-stack #f) + (define accums (make-hasheq)) + + (struct region (path + [start #:mutable] ; start time + [start-memory #:mutable] ; memory allocated before start time + [as-nested #:mutable] ; time accumulated for nested regions + [as-nested-memory #:mutable])) ; ditto, for memory + (struct stat ([msecs #:mutable] [memory #:mutable] [count #:mutable])) + + (define stat-key (gensym)) + + (define-logger performance) + + (define (start-performance-region . path) + (set! region-stack (cons (region (if region-stack + ;; Replace '_ elements: + (let loop ([path path] + [enclosing-path (region-path (car region-stack))]) + (if (null? path) + null + (cons (if (and (eq? '_ (car path)) + (pair? enclosing-path)) + (car enclosing-path) + (car path)) + (loop (cdr path) + (if (pair? enclosing-path) + (cdr enclosing-path) + null))))) + path) + (current-inexact-milliseconds) + (current-memory-use 'cumulative) + 0.0 + 0) + region-stack))) + + (define (end-performance-region) + (define now (current-inexact-milliseconds)) + (define now-memory (current-memory-use 'cumulative)) + (define r (car region-stack)) + (set! region-stack (cdr region-stack)) + + (define full-delta (- now (region-start r))) + (define delta (- full-delta (region-as-nested r))) + + (define full-delta-memory (- now-memory (region-start-memory r))) + (define delta-memory (- full-delta-memory (region-as-nested-memory r))) + + (let loop ([accums accums] [path (region-path r)]) + (define key (car path)) + (let ([accum (or (hash-ref accums key #f) + (let ([accum (make-hasheq)]) + (hash-set! accums key accum) + accum))]) + (define s (or (hash-ref accum stat-key #f) + (let ([s (stat 0.0 0 0)]) + (hash-set! accum stat-key s) + s))) + (set-stat-msecs! s (+ delta (stat-msecs s))) + (set-stat-memory! s (+ delta-memory (stat-memory s))) + (when (null? (cdr path)) + (set-stat-count! s (add1 (stat-count s)))) + (unless (null? (cdr path)) + (loop accum (cdr path))))) + + (when region-stack + (set-region-as-nested! (car region-stack) + (+ (region-as-nested (car region-stack)) + full-delta)) + (set-region-as-nested-memory! (car region-stack) + (+ (region-as-nested-memory (car region-stack)) + full-delta-memory)))) + + (void (plumber-add-flush! (current-plumber) + (lambda (h) + (define (whole-len s) + (caar (or (regexp-match-positions #rx"[.]" s) '(0)))) + (define (kb b) + (define s (number->string (quotient b 1024))) + (list->string + (for/fold ([l null]) ([c (in-list (reverse (string->list s)))] + [i (in-naturals)]) + (cond + [(and (positive? i) (zero? (modulo i 3))) + (list* c #\, l)] + [else (cons c l)])))) + (define-values (label-max-len value-max-len memory-max-len count-max-len) + (let loop ([accums accums] [label-len 6] [value-len 5] [memory-len 4] [count-len 5] [indent 2]) + (for/fold ([label-len label-len] + [value-len value-len] + [memory-len memory-len] + [count-len count-len]) + ([(k v) (in-hash accums)]) + (cond + [(eq? k stat-key) + (values label-len + (max value-len (whole-len (format "~a" (stat-msecs v)))) + (max memory-len (string-length (format "~a" (kb (stat-memory v))))) + (max count-len (string-length (format "~a" (stat-count v)))))] + [else (loop v + (max label-len (+ indent (string-length (format "~a" k)))) + value-len + memory-len + count-len + (+ 2 indent))])))) + (log-performance-info "REGION ~aMSECS ~aMEMK ~aCOUNT" + (make-string (- (+ label-max-len value-max-len) 11) + #\space) + (make-string (- memory-max-len 4) + #\space) + (make-string (- count-max-len 5) + #\space)) + (let loop ([name #f] [accums accums] [indent ""] [newline? #t]) + (when name + (define v (hash-ref accums stat-key)) + (log-performance-info "~a~a ~a~a ~a~a ~a~a" + indent + name + (make-string (+ (- label-max-len (string-length (format "~a" name)) (string-length indent)) + (- value-max-len (whole-len (format "~a" (stat-msecs v))))) + #\space) + (regexp-replace #rx"[.](..).*" (format "~a00" (stat-msecs v)) ".\\1") + (make-string (- memory-max-len (string-length (format "~a" (kb (stat-memory v))))) + #\space) + (kb (stat-memory v)) + (make-string (- count-max-len (string-length (format "~a" (stat-count v)))) + #\space) + (stat-count v))) + (define keys (sort (for/list ([k (in-hash-keys accums)] #:when (not (eq? k stat-key))) k) + > + #:key (lambda (key) (stat-msecs (hash-ref (hash-ref accums key) stat-key))))) + (for ([k (in-list keys)] + [i (in-naturals)]) + (when (and newline? (positive? i)) (log-performance-info "")) + (loop k (hash-ref accums k) (string-append indent " ") #f))))))) + +;; ------------------------------------------------------------ +;; Re-export this submodule to disable measurements + +(module no-measure-mode racket/base + (provide performance-region) + + (define-syntax-rule (performance-region [tag0-expr tag-expr ...] body ...) + (let () body ...))) + + +;; ------------------------------------------------------------ +;; Select whether to measure (has overhead) or not: + +(require (submod "." no-measure-mode)) diff --git a/racket/src/expander/common/phase.rkt b/racket/src/expander/common/phase.rkt new file mode 100644 index 0000000000..8d9095167d --- /dev/null +++ b/racket/src/expander/common/phase.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(provide phase? + phase+ + phase- + phaselist + list->set + list->seteq + for/set + for/seteq + for/seteqv + for*/set + for*/seteq + in-set) + +(define the-empty-hash #hash()) +(define the-empty-hasheq #hasheq()) +(define the-empty-hasheqv #hasheqv()) + +(define set + (case-lambda + [() the-empty-hash] + [l (for/fold ([s the-empty-hash]) ([e (in-list l)]) + (hash-set s e #t))])) +(define seteq + (case-lambda + [() the-empty-hasheq] + [l (for/fold ([s the-empty-hasheq]) ([e (in-list l)]) + (hash-set s e #t))])) +(define (seteqv) the-empty-hasheqv) + +(define (set? s) (hash? s)) + +(define (set-empty? s) (zero? (hash-count s))) +(define (set-member? s e) (hash-ref s e #f)) +(define (set-count s) (hash-count s)) + +(define (set-add s e) (hash-set s e #t)) +(define (set-remove s e) (hash-remove s e)) +(define (set-first s) (hash-iterate-key s (hash-iterate-first s))) + +(define-syntax in-set (make-rename-transformer #'in-immutable-hash-keys)) + +(define (subset? s1 s2) + (hash-keys-subset? s1 s2)) + +(define (set=? s1 s2) + (or (eq? s1 s2) + (and (= (hash-count s1) (hash-count s2)) + (hash-keys-subset? s1 s2)))) + +(define (set-subtract s1 s2) + (for/fold ([s1 s1]) ([k (in-set s2)]) + (hash-remove s1 k))) + +(define (set-union s1 s2) + (if ((set-count s1) . < . (set-count s2)) + (set-union s2 s1) + (for/fold ([s1 s1]) ([k (in-set s2)]) + (hash-set s1 k #t)))) + +(define (set-intersect s1 s2) + (if ((set-count s1) . < . (set-count s2)) + (set-intersect s2 s1) + (for/fold ([s s2]) ([k (in-set s2)]) + (if (hash-ref s1 k #f) + s + (hash-remove s k))))) + +(define (set-partition s pred empty-y-set empty-n-set) + (for/fold ([y empty-y-set] [n empty-n-set]) ([v (in-set s)]) + (if (pred v) + (values (set-add y v) n) + (values y (set-add n v))))) + +(define (set->list s) + (for/list ([k (in-set s)]) + k)) + +(define (list->set l) + (for/set ([k (in-list l)]) + k)) + +(define (list->seteq l) + (for/seteq ([k (in-list l)]) + k)) + +(define-syntax-rule (for/set bindings body ...) + (for/hash bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for/seteq bindings body ...) + (for/hasheq bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for/seteqv bindings body ...) + (for/hasheqv bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for*/set bindings body ...) + (for*/hash bindings (values + (let () + body ...) + #t))) + +(define-syntax-rule (for*/seteq bindings body ...) + (for*/hasheq bindings (values + (let () + body ...) + #t))) diff --git a/racket/src/expander/common/small-hash.rkt b/racket/src/expander/common/small-hash.rkt new file mode 100644 index 0000000000..15cf99567d --- /dev/null +++ b/racket/src/expander/common/small-hash.rkt @@ -0,0 +1,25 @@ +#lang racket/base + +;; For a hash table that's likely to be small, then a boxed immutable +;; hash table can be more efficient + +(provide make-small-hasheq + make-small-hasheqv + small-hash-ref + small-hash-set! + small-hash-keys) + +(define (make-small-hasheq) + (box #hasheq())) + +(define (make-small-hasheqv) + (box #hasheqv())) + +(define (small-hash-ref small-ht key default) + (hash-ref (unbox small-ht) key default)) + +(define (small-hash-set! small-ht key val) + (set-box! small-ht (hash-set (unbox small-ht) key val))) + +(define (small-hash-keys small-ht) + (hash-keys (unbox small-ht))) diff --git a/racket/src/expander/common/struct-star.rkt b/racket/src/expander/common/struct-star.rkt new file mode 100644 index 0000000000..dc412e6a71 --- /dev/null +++ b/racket/src/expander/common/struct-star.rkt @@ -0,0 +1,267 @@ +#lang racket/base +(require (for-syntax racket/base + racket/provide-transform)) + +(provide struct* + struct*-copy + struct*-out) + +;; The `struct*` form is like `struct`, but a field can be have a `*` +;; before it or not: the fields without `*` are moved into a nested +;; structure (and cannot be mutable), and the ones with `*` are kept +;; immediate. This distinction is useful is `struct*-copy` is used +;; often to asjust some fields and not others in a relatively larger +;; struct. + +;; Example: +#; +(struct* fish (* weight + color + name)) +;; Makes a `fish` struct where `struct*-copy` is used +;; frequently to change `weight`, but not `color` or +;; `name` --- so `color` and `name` will be represented +;; together in an inner structure that is referenced +;; though one field in the outer structure. + +;; Currently doesn't support: +;; * Subtypes deeper than one + +(begin-for-syntax + (struct struct*-shape (constructor + parent + outer-name inner-name outer-name-inner + all-fields ; including parent fields + outer-fields inner-fields mutators) + #:property prop:procedure (lambda (shape stx) + (with-syntax ([make-id (struct*-shape-constructor shape)]) + (syntax-case stx () + [(id arg ...) + (syntax/loc stx (make-id arg ...))] + [else + (syntax/loc stx make-id)]))))) + +(define-syntax (struct* stx) + (let-values ([(name parent-name fields options) + (syntax-case stx () + [(_ name parent-name (field ...) options ...) + (values #'name #'parent-name #'(field ...) #'(options ...))] + [(_ name (field ...) options ...) + (values #'name #f #'(field ...) #'(options ...))])]) + (define parent-shape (and parent-name + (syntax-local-value parent-name (lambda () #f)))) + (when parent-name + (check-struct* parent-shape stx parent-name)) + (with-syntax ([((outer-field ...) (inner-field ...)) (split-star-fields fields)] + [outer-name (make-id name '/outer)] + [inner-name (make-id name '/inner)] + [(option ...) options]) + (with-syntax ([(outer-field-name ...) (map field-id (syntax->list #'(outer-field ...)))] + [(inner-field-name ...) (map field-id (syntax->list #'(inner-field ...)))] + [(outer-parent-name ...) + (if parent-name + (list (struct*-shape-outer-name parent-shape)) + null)] + [(inner-parent-name ...) + (if parent-name + (list (struct*-shape-inner-name parent-shape)) + null)] + [(chain-field ...) (if parent-name + '() + (list (datum->syntax name 'inner)))] + [(every-field ...) (append (if parent-shape + (struct*-shape-all-fields parent-shape) + null) + (extract-all-fields fields))] + [(parent-outer-field ...) (if parent-shape + (struct*-shape-outer-fields parent-shape) + null)] + [(parent-inner-field ...) (if parent-shape + (struct*-shape-inner-fields parent-shape) + null)] + [(name-outer-field ...) (make-accessor-ids name #'(outer-field ...))] + [(set-name-outer-field! ...) (make-mutator-ids name #'(outer-field ...))] + [(name-inner-field ...) (make-accessor-ids name #'(inner-field ...))] + [(outer-name-outer-field ...) (make-accessor-ids #'outer-name #'(outer-field ...))] + [(set-outer-name-outer-field! ...) (make-mutator-ids #'outer-name #'(outer-field ...))] + [(inner-name-inner-field ...) (make-accessor-ids #'inner-name #'(inner-field ...))] + [outer-name-inner (if parent-shape + (struct*-shape-outer-name-inner parent-shape) + (make-id #'outer-name '-inner))] + [parent-name parent-name] + [name name] + [make-name (make-id name '/make)] + [name? (make-id name '?)] + [outer-name? (make-id #'outer-name '?)] + [quote-parent-syntax (if parent-shape + #'quote-syntax + #'quote)]) + #`(begin + (struct outer-name outer-parent-name ... (chain-field ... outer-field ...) + option ... + #:reflection-name 'name + #:authentic) + (struct inner-name inner-parent-name ... (inner-field ...) + #:authentic) + (define-syntax name (struct*-shape + (quote-syntax make-name) + (quote-parent-syntax parent-name) + (quote-syntax outer-name) + (quote-syntax inner-name) + (quote-syntax outer-name-inner) + '(every-field ...) + '(outer-field-name ...) + '(inner-field-name ...) + '(set-name-outer-field! ...))) + (define (name? v) (outer-name? v)) + (define (make-name every-field ...) + (outer-name (inner-name parent-inner-field ... inner-field-name ...) + parent-outer-field ... outer-field-name ...)) + (define (name-outer-field v) (outer-name-outer-field v)) ... + (define (set-name-outer-field! v f) (set-outer-name-outer-field! v f)) ... + (define (name-inner-field v) (inner-name-inner-field (outer-name-inner v))) ...))))) + +;; ---------------------------------------- + +(define-syntax (struct*-copy stx) + (syntax-case stx () + [(_ name expr binding ...) + (identifier? #'name) + (let ([shape (syntax-local-value #'name (lambda () #f))]) + (check-struct* shape stx #'name) + (with-syntax ([outer-name (struct*-shape-outer-name shape)] + [inner-name (struct*-shape-inner-name shape)] + [((outer-binding ...) (inner-binding ...)) + (split-star-bindings #'(binding ...) + shape + stx)] + [(inner-place ...) (if (struct*-shape-parent shape) + `(#:parent ,(struct*-shape-outer-name + (syntax-local-value + (struct*-shape-parent shape)))) + '())] + [outer-name-inner (struct*-shape-outer-name-inner shape)] + [inner (datum->syntax (struct*-shape-outer-name-inner shape) 'inner)]) + #`(let ([v expr]) + (struct-copy outer-name v + outer-binding ... + [inner inner-place ... + (struct-copy/maybe inner-name (outer-name-inner v) + inner-binding ...)]))))])) + +(define-syntax struct-copy/maybe + (syntax-rules () + [(struct-copy/maybe struct val) val] + [(struct-copy/maybe struct val binding ...) + (struct-copy struct val binding ...)])) + +;; ---------------------------------------- + +(define-syntax struct*-out + (make-provide-pre-transformer + (lambda (stx modes) + (syntax-case stx () + [(_ name) + (begin + (syntax-local-lift-module-end-declaration #'(provide-struct* name)) + #'(combine-out))])))) + +(define-syntax (provide-struct* stx) + (syntax-case stx () + [(_ name) + (let () + (define shape (syntax-local-value #'name (lambda () #f))) + (check-struct* shape stx #'name) + (with-syntax ([name? (make-id #'name '?)] + [(name-field ...) + (for/list ([field (in-list (append + (struct*-shape-outer-fields shape) + (struct*-shape-inner-fields shape)))]) + (make-id #'name (string->symbol (format "-~a" field))))] + [(mutator ...) + (for/list ([mutator (in-list (struct*-shape-mutators shape))]) + (datum->syntax #'name mutator))]) + #'(provide name name? name-field ... mutator ...)))])) + +;; ---------------------------------------- + +(define-for-syntax (check-struct* shape stx id) + (unless (struct*-shape? shape) + (raise-syntax-error #f "not a struct* binding" stx id))) + +(define-for-syntax (make-id base sym) + (datum->syntax base (string->symbol (format "~a~a" (syntax-e base) sym)) base)) + +(define-for-syntax (make-accessor-ids name fields) + (for/list ([f (in-list (syntax->list fields))]) + (define id (field-id f)) + (datum->syntax id (string->symbol (format "~a-~a" (syntax-e name) (syntax-e id)))))) + +(define-for-syntax (make-mutator-ids name fields) + (for/list ([f (in-list (syntax->list fields))] + #:when (syntax-case f () + [(_ #:mutable) #t] + [_ #f])) + (define id (field-id f)) + (datum->syntax id (string->symbol (format "set-~a-~a!" (syntax-e name) (syntax-e id)))))) + +(define-for-syntax (field-id f) + (syntax-case f () + [(id . _) #'id] + [id #'id])) + +(define-for-syntax (extract-all-fields fields) + (let loop ([fields (syntax->list fields)]) + (cond + [(null? fields) null] + [(eq? '* (syntax-e (car fields))) + (cons (field-id (cadr fields)) (loop (cddr fields)))] + [else + (cons (field-id (car fields)) (loop (cdr fields)))]))) + +(define-for-syntax (split-star-fields fields) + (let loop ([fields (syntax->list fields)] [accum-outer null] [accum-inner null]) + (cond + [(null? fields) (list (reverse accum-outer) (reverse accum-inner))] + [(eq? '* (syntax-e (car fields))) + (loop (cddr fields) (cons (cadr fields) accum-outer) accum-inner)] + [else + (loop (cdr fields) accum-outer (cons (car fields) accum-inner))]))) + +(define-for-syntax (split-star-bindings bindings shape stx) + (let loop ([bindings (syntax->list bindings)] [accum-outer null] [accum-inner null]) + (cond + [(null? bindings) (list (reverse accum-outer) (reverse accum-inner))] + [else + (define binding (car bindings)) + (define (outer-in-shape? shape id) + (memq (syntax-e id) (struct*-shape-outer-fields shape))) + (define-values (new-binding outer?) + (syntax-case binding () + [[id val] + (begin + (define outer? (outer-in-shape? shape #'id)) + (with-syntax ([id (datum->syntax (if outer? + (struct*-shape-outer-name shape) + (struct*-shape-outer-name shape)) + (syntax-e #'id))]) + (values (syntax/loc stx [id val]) outer?)))] + [[id #:parent parent val] + (begin + (unless (and (struct*-shape-parent shape) + (free-identifier=? #'parent + (struct*-shape-parent shape))) + (raise-syntax-error #f "bad parent name" + stx #'parent)) + (define parent-shape (syntax-local-value #'parent #f)) + (define outer? (outer-in-shape? parent-shape #'id)) + (define parent-name (if outer? + (struct*-shape-outer-name parent-shape) + (struct*-shape-inner-name parent-shape))) + (with-syntax ([parent-name parent-name] + [id (datum->syntax parent-name (syntax-e #'id))]) + (values (syntax/loc binding [id #:parent parent-name val]) + outer?)))])) + (if outer? + (loop (cdr bindings) (cons new-binding accum-outer) accum-inner) + (loop (cdr bindings) accum-outer (cons new-binding accum-inner)))]))) diff --git a/racket/src/expander/compile/built-in-symbol.rkt b/racket/src/expander/compile/built-in-symbol.rkt new file mode 100644 index 0000000000..6821d2d35e --- /dev/null +++ b/racket/src/expander/compile/built-in-symbol.rkt @@ -0,0 +1,65 @@ +#lang racket/base + +;; A built-in symbol is one that the compiler must avoid using for a +;; binding. Built-in symbols include the names of run-time primitives +;; and identifiers reserved by the compiler itself (see +;; "reserved-symbol.rkt") + +(provide register-built-in-symbol! + built-in-symbol? + make-built-in-symbol!) + +(define built-in-symbols (make-hasheq)) + +(define (register-built-in-symbol! s) + (hash-set! built-in-symbols s #t)) + +(define (built-in-symbol? s) + (hash-ref built-in-symbols s #f)) + +(define (make-built-in-symbol! s) + ;; Make a symbol that is a little more obscure than just `s` + (define built-in-s (string->symbol (format ".~s" s))) + (register-built-in-symbol! built-in-s) + built-in-s) + +;; ---------------------------------------- + +(void + (begin + ;; Primitive expression forms + (for-each register-built-in-symbol! + '(lambda case-lambda + if begin begin0 + let-values letrec-values + set! quote + with-continuation-mark + #%variable-reference)) + + ;; Source-mode linklet glue + (for-each register-built-in-symbol! + '(check-not-undefined + instance-variable-box + variable-reference + variable-reference? + variable-reference->instance + variable-reference-constant? + variable-reference-from-unsafe?)) + + ;; Linklet compilation on Chez Scheme + (for-each register-built-in-symbol! + '(let + letrec* + define + or + and + pariah + variable-set! + variable-ref + variable-ref/no-check + make-instance-variable-reference + annotation? + annotation-expression + #%app + #%call-with-values + make-pthread-parameter)))) diff --git a/racket/src/expander/compile/compiled-in-memory.rkt b/racket/src/expander/compile/compiled-in-memory.rkt new file mode 100644 index 0000000000..831aed6c08 --- /dev/null +++ b/racket/src/expander/compile/compiled-in-memory.rkt @@ -0,0 +1,39 @@ +#lang racket/base + +;; A `compiled-in-memory` structure holds the result of compilation. +;; It's produced by `compile-top` or `compile-module` and consumed by +;; `eval-compiled-in-memory`. The marshaled form is just the linklet +;; directory, which has the same essential information, but loses sharing +;; with anything else currently in memory. The marshaled form also loses +;; extra inspectors. +(provide (struct-out compiled-in-memory)) + +(struct compiled-in-memory (linklet-directory ;; includes content of `{pre,post}-compiled-tops`; may be just a bundle + ;; Shortcuts, instead of using the metadata linklet: + original-self + requires + provides + phase-to-link-module-uses + ;; Maybe provide more capability than the module's declaration inspector: + compile-time-inspector + ;; For each phase (that has a linklet), optionally report + ;; a list of lists; the outer list matches the order of imports + ;; into the linklet, and each inner list matches the order of + ;; variables from that imported linklet; each member of the + ;; inner list is #f or an extra inspector that has been carried + ;; over from the originally compiled reference + phase-to-link-extra-inspectorsss ; phase -> list of hash tables to "extra inspectors" + ;; For using existing values directly, instead of unmarshaling: + mpis + syntax-literals + ;; Shortcuts for associated code (submodules or sequence of top levels) + pre-compiled-in-memorys + post-compiled-in-memorys + ;; Namespace scopes from top-level compilation, so syntax objects + ;; can be adjusted for a target namespace: + namespace-scopes + ;; To track whether a form in a top-level sequence can be discarded: + purely-functional?) + #:property prop:custom-write + (lambda (cim port mode) + (write (compiled-in-memory-linklet-directory cim) port))) diff --git a/racket/src/expander/compile/context.rkt b/racket/src/expander/compile/context.rkt new file mode 100644 index 0000000000..132957bf7f --- /dev/null +++ b/racket/src/expander/compile/context.rkt @@ -0,0 +1,30 @@ +#lang racket/base +(require "../namespace/namespace.rkt") + +(provide (struct-out compile-context) + make-compile-context) + +(struct compile-context (namespace ; compile-time namespace + phase ; phase (top level) or phase level (within a module) + self ; if non-#f module path index, compiling the body of a module + module-self ; if non-#f, same as `self` and compiling the body of a module + full-module-name ; set to a symbol or symbol list if `self` is non-#f + lazy-syntax-literals? ; #t (for modules) => deserialize and shift syntax on demand + header) ; accumulates initialization and other parts shared among expressions + #:authentic) + +(define (make-compile-context #:namespace [namespace (current-namespace)] + #:phase [phase (namespace-phase namespace)] + #:self [self (namespace-mpi namespace)] + #:module-self [module-self #f] + #:full-module-name [full-module-name #f] + #:lazy-syntax-literals? [lazy-syntax-literals? (and module-self #t)]) + (when (and module-self (not full-module-name)) + (error "internal error: module-self provided without full name")) + (compile-context namespace + phase + self + module-self + full-module-name + lazy-syntax-literals? + #f)) diff --git a/racket/src/expander/compile/correlate.rkt b/racket/src/expander/compile/correlate.rkt new file mode 100644 index 0000000000..8e146a6d1c --- /dev/null +++ b/racket/src/expander/compile/correlate.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/datum-map.rkt" + "../host/correlate.rkt" + (only-in "../host/syntax-to-reader-syntax.rkt" srcloc->vector)) + +;; The `correlate*` function takes the source location of an expander +;; syntax object and applies it to a host-system syntax object (i.e., +;; a "correlated") + +(provide correlate* + correlate~ + correlate/app + ->correlated) + +(define (correlate* stx s-exp) + (if (syntax-srcloc stx) + (datum->correlated s-exp (srcloc->vector (syntax-srcloc stx))) + s-exp)) + +;; For terms where we know the compiler currently doesn't +;; pay attention to source locations, so there's no reason +;; to keep them: +(define (correlate~ stx s-exp) + s-exp) + +(define (correlate/app stx s-exp) + (if (eq? (system-type 'vm) 'chez-scheme) + (correlate* stx s-exp) + (correlate~ stx s-exp))) + +(define (->correlated s) + (datum->correlated s #f)) diff --git a/racket/src/expander/compile/eager-instance.rkt b/racket/src/expander/compile/eager-instance.rkt new file mode 100644 index 0000000000..8e4e7974d3 --- /dev/null +++ b/racket/src/expander/compile/eager-instance.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require "reserved-symbol.rkt" + "../host/linklet.rkt" + "namespace-scope.rkt") + +;; Compilation of top-level forms generates a link that has an +;; `eager-instance` argument to receive deserialization information: a +;; namspace, its phase, etc. + +(provide eager-instance-imports + make-eager-instance-instance + empty-eager-instance-instance) + +(define eager-instance-imports + `(,ns-id + ,dest-phase-id + ,self-id + ,bulk-binding-registry-id + ,inspector-id + swap-top-level-scopes)) + +(define (make-eager-instance-instance #:namespace ns + #:dest-phase dest-phase + #:self self + #:bulk-binding-registry bulk-binding-registry + #:inspector inspector) + (make-instance 'instance #f 'constant + ns-id ns + dest-phase-id dest-phase + self-id self + bulk-binding-registry-id bulk-binding-registry + inspector-id inspector + 'swap-top-level-scopes swap-top-level-scopes)) + +(define empty-eager-instance-instance + (make-eager-instance-instance #:namespace #f + #:dest-phase #f + #:self #f + #:bulk-binding-registry #f + #:inspector #f)) diff --git a/racket/src/expander/compile/expr.rkt b/racket/src/expander/compile/expr.rkt new file mode 100644 index 0000000000..8461d50e46 --- /dev/null +++ b/racket/src/expander/compile/expr.rkt @@ -0,0 +1,236 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/performance.rkt" + "../syntax/syntax.rkt" + "../syntax/to-list.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/property.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../syntax/binding.rkt" + "../syntax/match.rkt" + "../common/module-path.rkt" + "../expand/parsed.rkt" + "built-in-symbol.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "self-quoting.rkt" + "../host/correlate.rkt" + "correlate.rkt") + +(provide compile + compile-quote-syntax) + +;; Convert an expanded syntax object to an expression that is +;; represented by a plain S-expression plus source location info (so, +;; still represented as a syntax object). The expression is compiled +;; for a particular phase, but if the expression is in a module, its +;; phase can be shifted at run time by the amount bound to +;; `phase-shift-id`. Module bindings are accessed through a namespace +;; that is bound to `ns-id` at run time. +;; The `result-used?` hint lets us drop `quote-syntax` forms that will +;; not be used in the result, so we can avoid serializing them; a value +;; of `#f` for `result-used?` means that the expression can be replaced +;; by a boolean-equivalent value if it has no side effect. +(define (compile p cctx [name #f] [result-used? #t]) + (let ([compile (lambda (p name result-used?) (compile p cctx name result-used?))]) + (define s (parsed-s p)) + (cond + [(parsed-id? p) + (compile-identifier p cctx)] + [(parsed-lambda? p) + (cond + [result-used? + (add-lambda-properties + (correlate* s `(lambda ,@(compile-lambda (parsed-lambda-keys p) (parsed-lambda-body p) cctx))) + name + s)] + [else (correlate~ s `(quote unused-lambda))])] + [(parsed-case-lambda? p) + (cond + [result-used? + (add-lambda-properties + (correlate* s `(case-lambda ,@(for/list ([clause (in-list (parsed-case-lambda-clauses p))]) + (compile-lambda (car clause) (cadr clause) cctx)))) + name + s)] + [else (correlate~ s `(quote unused-case-lambda))])] + [(parsed-app? p) + (define rands (parsed-app-rands p)) + (correlate/app s (cons + (compile (parsed-app-rator p) #f #t) + (for/list ([r (in-list rands)]) + (compile r #f #t))))] + [(parsed-if? p) + (define tst-e (compile (parsed-if-tst p) #f #f)) + ;; Ad hoc optimization of `(if #t ... ...)` or `(if #f ... ...)` + ;; happens to help avoid syntax literals in pattern matching. + (cond + [(eq? (correlated-e tst-e) #t) (compile (parsed-if-thn p) name result-used?)] + [(eq? (correlated-e tst-e) #f) (compile (parsed-if-els p) name result-used?)] + [else + (correlate~ s `(if + ,tst-e + ,(compile (parsed-if-thn p) name result-used?) + ,(compile (parsed-if-els p) name result-used?)))])] + [(parsed-with-continuation-mark? p) + (correlate~ s `(with-continuation-mark + ,(compile (parsed-with-continuation-mark-key p) #f #t) + ,(compile (parsed-with-continuation-mark-val p) #f #t) + ,(compile (parsed-with-continuation-mark-body p) name result-used?)))] + [(parsed-begin0? p) + (correlate~ s `(begin0 + ,(compile (car (parsed-begin0-body p)) name result-used?) + ,@(for/list ([e (in-list (cdr (parsed-begin0-body p)))]) + (compile e #f #f))))] + [(parsed-begin? p) + (correlate~ s (compile-begin (parsed-begin-body p) cctx name result-used?))] + [(parsed-set!? p) + (correlate~ s `(,@(compile-identifier (parsed-set!-id p) cctx + #:set-to? #t + #:set-to (compile (parsed-set!-rhs p) (parsed-s (parsed-set!-id p)) #t))))] + [(parsed-let-values? p) + (compile-let p cctx name #:rec? #f result-used?)] + [(parsed-letrec-values? p) + (compile-let p cctx name #:rec? #t result-used?)] + [(parsed-quote? p) + (define datum (parsed-quote-datum p)) + (cond + [(self-quoting-in-linklet? datum) + (correlate~ s datum)] + [else + (correlate~ s `(quote ,datum))])] + [(parsed-quote-syntax? p) + (if result-used? + (compile-quote-syntax (parsed-quote-syntax-datum p) cctx) + (correlate~ s `(quote ,(syntax->datum s))))] + [(parsed-#%variable-reference? p) + (define id (parsed-#%variable-reference-id p)) + (correlate~ s + (if id + `(#%variable-reference ,(compile-identifier id cctx)) + `(#%variable-reference)))] + [else + (error "unrecognized parsed form:" p)]))) + +(define (compile-lambda formals bodys cctx) + `(,formals ,(compile-sequence bodys cctx #f #t))) + +(define (compile-sequence bodys cctx name result-used?) + (if (null? (cdr bodys)) + (compile (car bodys) cctx name result-used?) + (compile-begin bodys cctx name result-used?))) + +(define (compile-begin es cctx name result-used?) + (define used-pos (sub1 (length es))) + `(begin ,@(for/list ([e (in-list es)] + [i (in-naturals)]) + (define used? (= i used-pos)) + (compile e cctx (and used? name) (and used? result-used?))))) + +(define (add-lambda-properties s inferred-name orig-s) + ;; Allow pairs formed by origin tracking to provide the + ;; same name multiple times: + (define (simplify-name v) + (cond + [(pair? v) + (define n1 (simplify-name (car v))) + (define n2 (simplify-name (cdr v))) + (if (eq? n1 n2) n1 v)] + [else v])) + ;; Get either a declared 'inferred-name or one accumulated by the compiler + (define name (or (let ([v (simplify-name (syntax-property orig-s 'inferred-name))]) + (and (or (symbol? v) (syntax? v) (void? v)) + v)) + inferred-name)) + (define named-s (if name + (correlated-property (->correlated s) + 'inferred-name + (if (syntax? name) (syntax-e name) name)) + s)) + (define as-method (syntax-property orig-s 'method-arity-error)) + (if as-method + (correlated-property (->correlated named-s) 'method-arity-error as-method) + named-s)) + +(define (compile-let p cctx name #:rec? rec? result-used?) + (define body (parsed-let_-values-body p)) + (correlate~ (parsed-s p) + `(,(if rec? 'letrec-values 'let-values) + ,(for/list ([clause (in-list (parsed-let_-values-clauses p))] + [ids (in-list (parsed-let_-values-idss p))]) + `[,(if rec? + (for/list ([sym (in-list (car clause))] + [id (in-list ids)]) + (add-undefined-error-name-property sym id)) + (car clause)) + ,(compile (cadr clause) + cctx + (and (= 1 (length ids)) (car ids)))]) + ,(compile-sequence body cctx name result-used?)))) + +(define (add-undefined-error-name-property sym orig-id) + (define id (correlate~ orig-id sym)) + (correlated-property (->correlated id) 'undefined-error-name + (or (syntax-property orig-id 'undefined-error-name) + (syntax-e orig-id)))) + +(define (compile-identifier p cctx #:set-to? [set-to? #f] #:set-to [rhs #f]) + (define normal-b (parsed-id-binding p)) + ;; If `normal-b`, then `(parsed-s p)` might be #f + (define b + (or normal-b + ;; Assume a variable reference + (make-module-binding (compile-context-self cctx) + (compile-context-phase cctx) + (syntax-e (parsed-s p))))) + (define sym + (cond + [(local-binding? b) + (local-binding-key b)] + [(module-binding? b) + (define mpi (if (parsed-top-id? p) + (compile-context-self cctx) + (module-binding-module b))) + (cond + [(parsed-primitive-id? p) + ;; Direct reference to a runtime primitive: + (unless (zero? (module-binding-phase b)) + (error "internal error: non-zero phase for a primitive")) + (when set-to? + (error "internal error: cannot assign to a primitive:" (module-binding-sym b))) + ;; Expect each primitive to be bound: + (module-binding-sym b)] + [(eq? mpi (compile-context-module-self cctx)) + ;; Direct reference to a variable defined in the same module: + (define header (compile-context-header cctx)) + (hash-ref (header-binding-sym-to-define-sym header) + (module-binding-sym b))] + [else + ;; Reference to a variable defined in another module or in an + ;; environment (such as the top level) other than a module + ;; context; register as a linklet import + (register-required-variable-use! (compile-context-header cctx) + mpi + (module-binding-phase b) + (module-binding-sym b) + (or (module-binding-extra-inspector b) + (parsed-id-inspector p) + (and (parsed-s p) + (syntax-inspector (parsed-s p)))))])] + [else + (error "not a reference to a module or local binding:" b (parsed-s p))])) + (correlate~ (parsed-s p) (if set-to? + `(set! ,sym ,rhs) + sym))) + +(define (compile-quote-syntax q cctx) + (define pos (add-syntax-literal! (compile-context-header cctx) q)) + (cond + [(compile-context-lazy-syntax-literals? cctx) + (generate-lazy-syntax-literal-lookup pos)] + [else + (generate-eager-syntax-literal-lookup pos)])) diff --git a/racket/src/expander/compile/extra-inspector.rkt b/racket/src/expander/compile/extra-inspector.rkt new file mode 100644 index 0000000000..ac5fff3ce9 --- /dev/null +++ b/racket/src/expander/compile/extra-inspector.rkt @@ -0,0 +1,142 @@ +#lang racket/base +(require "../common/set.rkt" + "module-use.rkt" + "../host/linklet.rkt") + +(provide extra-inspectors-allow? + + module-uses-add-extra-inspectorsss + module-uses-strip-extra-inspectorsss + module-uses-extract-extra-inspectorsss + module-use*-declaration-inspector! + + module-use+extra-inspectors + module-use-merge-extra-inspectorss!) + +;; Compilation leaves a linklet with some "or" inspectors that apply +;; to the whole linklet plus (potentially) some "and" inspectors for +;; each invdidual binding. Cross-module optimization can move this +;; or+and combination to the "and" part of a different module, so we +;; use functions in general + +(define (extra-inspectors-allow? extra-inspectors guard-insp) + (cond + [(not extra-inspectors) #f] + [(set? extra-inspectors) + (for/and ([extra-insp (in-set extra-inspectors)]) + (inspector-superior? extra-insp guard-insp))] + [(procedure? extra-inspectors) + (extra-inspectors guard-insp)] + [else + (error 'extra-inspectors-allow? + "unknown representation of extra inspectors: ~e" + extra-inspectors)])) + +(define (extra-inspectors-merge extra-inspectors-1 extra-inspectors-2) + (cond + [(or (not extra-inspectors-1) + (not extra-inspectors-2)) + #f] + [(and (set? extra-inspectors-1) + (set? extra-inspectors-2)) + (set-union extra-inspectors-1 extra-inspectors-2)] + [else + (lambda (guard-insp) + (and (extra-inspectors-allow? extra-inspectors-1 guard-insp) + (extra-inspectors-allow? extra-inspectors-2 guard-insp)))])) + +;; ---------------------------------------- + +;; While compiling a linklet, we start out with parallel lists of +;; module uses and extra inspectors, but it's more convenient to +;; manage inlining if we put those together. We may need to merge +;; extra-inspector sets while preserving `eq?` identity of the +;; `module-use*`, so that field is mutable. +(struct module-use* module-use ([extra-inspectorss #:mutable] + [self-inspector #:mutable])) + +;; Parallel lists into one list +(define (module-uses-add-extra-inspectorsss mus extra-inspectorsss) + (cond + [extra-inspectorsss + (for/list ([mu (in-list mus)] + [extra-inspectorss (in-list extra-inspectorsss)]) + (module-use* (module-use-module mu) + (module-use-phase mu) + extra-inspectorss + #f))] + [else + (for/list ([mu (in-list mus)]) + (module-use* (module-use-module mu) + (module-use-phase mu) + #f + #f))])) + +;; Split the list back into one of the parallel lists +(define (module-uses-strip-extra-inspectorsss mu*s) + (for/list ([mu* (in-list mu*s)]) + (module-use (module-use-module mu*) + (module-use-phase mu*)))) + +;; Split the list back into the other parallel list --- but also check +;; for inlining-introduced references that must have formerly been +;; module-internal references (i.e., referenecs that are not already +;; recorded as imports) +(define (module-uses-extract-extra-inspectorsss mu*s linklet check-inlined-reference? skip-n) + (cond + [(not check-inlined-reference?) + (for/list ([mu* (in-list mu*s)]) + (module-use*-extra-inspectorss mu*))] + [else + (for/list ([mu* (in-list mu*s)] + [imports (in-list (list-tail (linklet-import-variables linklet) skip-n))]) + (define extra-inspectorss (module-use*-extra-inspectorss mu*)) + (for/fold ([extra-inspectorss extra-inspectorss]) ([import (in-list imports)]) + (cond + [(eq? (hash-ref extra-inspectorss import '#:not-recorded) '#:not-recorded) + (hash-set extra-inspectorss import (set (module-use*-self-inspector mu*)))] + [else extra-inspectorss])))])) + +(define (module-use*-declaration-inspector! mu* insp) + (set-module-use*-self-inspector! mu* insp)) + +;; ---------------------------------------- + +(define (module-use+extra-inspectors mpi phase imports inspector extra-inspector extra-inspectorss) + ;; If `inspector` or `extra-inspector` is not subsumed by the + ;; current inspector, then propagate it by adding to each imported + ;; variable's set of "or" inspectors + (define now-inspector (current-code-inspector)) + (define add-insp? (and inspector (inspector-superior? inspector now-inspector))) + (define add-extra-insp? (and extra-inspector (inspector-superior? extra-inspector now-inspector))) + (define new-extra-inspectorss + (cond + [(or add-insp? add-extra-insp?) + (for/hash ([import (in-list imports)]) + (values import + (let ([extra-inspectors (and extra-inspectorss + (hash-ref extra-inspectorss import #f))]) + (lambda (guard-insp) + (or (and add-insp? (inspector-superior? inspector guard-insp)) + (and add-extra-insp? (inspector-superior? extra-inspector guard-insp)) + (extra-inspectors-allow? extra-inspectors guard-insp))))))] + [else + ;; Make sure every import is mapped, because w may need to distinguish + ;; between "not accessed" and "accessed without extra inspectors" + (for/fold ([extra-inspectorss (or extra-inspectorss (seteq))]) ([import (in-list imports)]) + (if (hash-ref extra-inspectorss import #f) + extra-inspectorss + (hash-set extra-inspectorss import #f)))])) + (module-use* mpi phase new-extra-inspectorss #f)) + +;; Merge inspectors from potentially different paths through imported linklets +(define (module-use-merge-extra-inspectorss! existing-mu* mu*) + (define extra-inspectorss (module-use*-extra-inspectorss mu*)) + (define existing-extra-inspectorss (module-use*-extra-inspectorss existing-mu*)) + (define new-extra-inspectorss + (for/fold ([new-extra-inspectorss existing-extra-inspectorss]) ([(sym extra-inspectors) (in-hash extra-inspectorss)]) + (hash-set new-extra-inspectorss + sym + (extra-inspectors-merge extra-inspectors + (hash-ref new-extra-inspectorss sym (seteq)))))) + (set-module-use*-extra-inspectorss! existing-mu* new-extra-inspectorss)) diff --git a/racket/src/expander/compile/form.rkt b/racket/src/expander/compile/form.rkt new file mode 100644 index 0000000000..e4de3363ab --- /dev/null +++ b/racket/src/expander/compile/form.rkt @@ -0,0 +1,463 @@ +#lang racket/base +(require "../common/performance.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/property.rkt" + "../syntax/match.rkt" + "../common/phase.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../expand/root-expand-context.rkt" + "../expand/parsed.rkt" + "../common/module-path.rkt" + "module-use.rkt" + "serialize.rkt" + "built-in-symbol.rkt" + "../host/linklet.rkt" + "../host/correlate.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "instance.rkt" + "namespace-scope.rkt" + "expr.rkt" + "extra-inspector.rkt" + "correlate.rkt") + +(provide compile-forms + + compile-namespace-scopes) + +(struct link-info (link-module-uses imports extra-inspectorsss def-decls)) + +;; Compiles a module body or sequence of top-level forms, returning a +;; linklet directory to cover all phases covered by the forms +(define (compile-forms bodys cctx mpis + #:body-imports body-imports + #:body-import-instances body-import-instances + #:body-suffix-forms [body-suffix-forms null] + #:force-phases [force-phases null] + #:encoded-root-expand-ctx-box [encoded-root-expand-ctx-box #f] ; encoded root context, if any + #:root-ctx-only-if-syntax? [root-ctx-only-if-syntax? #f] + #:compiled-expression-callback [compiled-expression-callback void] + #:definition-callback [definition-callback void] + #:other-form-callback [other-form-callback void] + #:get-module-linklet-info [get-module-linklet-info (lambda (mod-name p) #f)] ; to support submodules + #:to-source? [to-source? #f] + #:serializable? [serializable? #t] + #:cross-linklet-inlining? [cross-linklet-inlining? #t]) + (define phase (compile-context-phase cctx)) + (define self (compile-context-self cctx)) + + ;; Accumulate syntax objects across all phases: + (define syntax-literals (make-syntax-literals)) + + ;; For each phase, keep track of all compiled expressions for the + ;; phase + (define phase-to-body (make-hasheqv)) ; phase -> list of S-expression + (define (add-body! phase body) + (hash-update! phase-to-body phase (lambda (l) (cons body l)) null)) + + ;; For each phase, accumulate a header for referenced imports and + ;; syntax literals + (define phase-to-header (make-hasheqv)) ; phase -> header + (define (find-or-create-header! phase) + (or (hash-ref phase-to-header phase #f) + (let ([header (make-header mpis syntax-literals)]) + (hash-set! phase-to-header phase header) + header))) + + ;; Ensure that some requested phases are realized: + (for ([phase (in-list force-phases)]) + (find-or-create-header! phase) + (add-body! phase '(void))) + + ;; Keep track of whether any `define-syntaxes` appeared at any phase + (define saw-define-syntaxes? #f) + + (when (compile-context-module-self cctx) + ;; In a module, select non-conflicting symbols for definitions, + ;; first, in the hope that we can just the names as-is; and we'll + ;; rename locals as needed to avoid these names + (let loop! ([bodys bodys] [phase phase] [header (find-or-create-header! phase)]) + (for ([body (in-list bodys)]) + (cond + [(parsed-define-values? body) + (for ([sym (in-list (parsed-define-values-syms body))]) + (define def-sym (select-fresh sym header)) + (hash-set! (header-binding-sym-to-define-sym header) + sym + def-sym) + (set-header-binding-syms-in-order! header + (cons sym + (header-binding-syms-in-order header))) + (register-as-defined! header def-sym))] + [(parsed-begin-for-syntax? body) + (loop! (parsed-begin-for-syntax-body body) (add1 phase) (find-or-create-header! (add1 phase)))])))) + + ;; Provided for callbacks to detect required references: + (define ((as-required? header) sym) + (registered-as-required? header sym)) + + ;; Compile each form in `bodys`, recording results in `phase-to-body` + (define last-i (sub1 (length bodys))) + (let loop! ([bodys bodys] [phase phase] [header (find-or-create-header! phase)]) + (for ([body (in-list bodys)] + [i (in-naturals)]) + (cond + [(parsed-define-values? body) + (define ids (parsed-define-values-ids body)) + (define binding-syms (parsed-define-values-syms body)) + (define def-syms + (cond + [(compile-context-module-self cctx) + ;; In a module, look up name for local definition: + (for/list ([binding-sym (in-list binding-syms)]) + (hash-ref (header-binding-sym-to-define-sym header) + binding-sym))] + [else + ;; Outside of a module, look up name to `set!` + (for/list ([binding-sym (in-list binding-syms)]) + (register-required-variable-use! header + (compile-context-self cctx) + phase + binding-sym + #f + #:defined? #t))])) + (define rhs (compile (parsed-define-values-rhs body) + (struct-copy compile-context cctx + [phase phase] + [header header]) + (and (= (length ids) 1) (car ids)))) + (definition-callback) + (compiled-expression-callback rhs (length def-syms) phase (as-required? header)) + ;; Generate a definition: + (add-body! phase (propagate-inline-property + (correlate* (parsed-s body) `(define-values ,def-syms ,rhs)) + (parsed-s body))) + (unless (or (compile-context-module-self cctx) + (null? ids)) + ;; Not in a module; ensure that the defined names are + ;; treated as mutable + (add-body! phase + `(if #f + (begin + ,@(for/list ([def-sym (in-list def-syms)]) + `(set! ,def-sym #f))) + (void))) + ;; Also, install a binding at run time + (add-body! phase (compile-top-level-bind + ids binding-syms + (struct-copy compile-context cctx + [phase phase] + [header header]) + #f)))] + [(parsed-define-syntaxes? body) + (define ids (parsed-define-syntaxes-ids body)) + (define binding-syms (parsed-define-syntaxes-syms body)) + (define next-header (find-or-create-header! (add1 phase))) + (define gen-syms (for/list ([binding-sym (in-list binding-syms)]) + (define gen-sym (select-fresh binding-sym next-header)) + (register-as-defined! next-header gen-sym) + gen-sym)) + (define rhs (compile (parsed-define-syntaxes-rhs body) + (struct-copy compile-context cctx + [phase (add1 phase)] + [header next-header]))) + (definition-callback) + (compiled-expression-callback rhs (length gen-syms) (add1 phase) (as-required? header)) + (define transformer-set!s (for/list ([binding-sym (in-list binding-syms)] + [gen-sym (in-list gen-syms)]) + `(,set-transformer!-id ',binding-sym ,gen-sym))) + (cond + [(compile-context-module-self cctx) + (add-body! (add1 phase) `(let-values ([,gen-syms ,rhs]) + (begin + ,@transformer-set!s + (void))))] + [else + (add-body! (add1 phase) + (generate-top-level-define-syntaxes + gen-syms rhs transformer-set!s + (compile-top-level-bind + ids binding-syms + (struct-copy compile-context cctx + [phase phase] + [header header]) + gen-syms)))]) + (set! saw-define-syntaxes? #t)] + [(parsed-begin-for-syntax? body) + (loop! (parsed-begin-for-syntax-body body) (add1 phase) (find-or-create-header! (add1 phase)))] + [(or (parsed-#%declare? body) (parsed-module? body) (parsed-require? body)) + ;; Must be handled separately, if allowed at all + (define e (other-form-callback body (struct-copy compile-context cctx + [phase phase] + [header header]))) + (when e + (compiled-expression-callback e #f phase (as-required? header)) + (add-body! phase e))] + [else + (define e (compile body + (struct-copy compile-context cctx + [phase phase] + [header header]) + #f + (= i last-i))) + (compiled-expression-callback e #f phase (as-required? header)) + (add-body! phase e)]))) + + ;; Register root-expand-context, if any, encoded as a syntax object; + ;; see also "../eval/root-context.rkt" + (define encoded-root-expand-pos + (and encoded-root-expand-ctx-box + (unbox encoded-root-expand-ctx-box) ; box => can be cleared by a callback + (not (and root-ctx-only-if-syntax? + (not saw-define-syntaxes?) + (syntax-literals-empty? syntax-literals))) + (add-syntax-literal! syntax-literals (unbox encoded-root-expand-ctx-box)))) + + ;; Collect resulting phases + (define phases-in-order (sort (hash-keys phase-to-body) <)) + (define min-phase (if (pair? phases-in-order) + (car phases-in-order) + phase)) + (define max-phase (if (pair? phases-in-order) + (car (reverse phases-in-order)) + phase)) + + ;; Compute linking info for each phase + (define phase-to-link-info + (for/hash ([phase (in-list phases-in-order)]) + (define header (hash-ref phase-to-header phase #f)) + (define-values (link-module-uses imports extra-inspectorsss def-decls) + (generate-links+imports header phase cctx cross-linklet-inlining?)) + (values phase (link-info link-module-uses imports extra-inspectorsss def-decls)))) + + ;; Generate the phase-specific linking units + (define body-linklets+module-use*s + (for/hasheq ([phase (in-list phases-in-order)]) + (define bodys (hash-ref phase-to-body phase)) + (define li (hash-ref phase-to-link-info phase)) + (define binding-sym-to-define-sym + (header-binding-sym-to-define-sym (hash-ref phase-to-header phase))) + (define module-use*s + (module-uses-add-extra-inspectorsss (link-info-link-module-uses li) + (link-info-extra-inspectorsss li))) + ;; Compile the linklet with support for cross-module inlining, which + ;; means that the set of imports can change: + (define-values (linklet new-module-use*s) + (performance-region + ['compile '_ 'linklet] + ((if to-source? + (lambda (l name keys getter) (values l keys)) + (lambda (l name keys getter) + (compile-linklet l name keys getter serializable?))) + `(linklet + ;; imports + (,@body-imports + ,@(link-info-imports li)) + ;; exports + (,@(link-info-def-decls li) + ,@(for/list ([binding-sym (in-list (header-binding-syms-in-order + (hash-ref phase-to-header phase)))]) + (define def-sym (hash-ref binding-sym-to-define-sym binding-sym)) + (if (eq? def-sym binding-sym) + def-sym + `[,def-sym ,binding-sym]))) + ;; body + ,@(reverse bodys) + ,@body-suffix-forms) + 'module + ;; Support for cross-module optimization starts with a vector + ;; of keys for the linklet imports; we use `module-use` values + ;; as keys, plus #f or an instance (=> cannot be pruned) for + ;; each boilerplate linklet + (list->vector (append body-import-instances + module-use*s)) + ;; To complete cross-module support, map a key (which is a `module-use`) + ;; to a linklet and an optional vector of keys for that linklet's + ;; imports: + (make-module-use-to-linklet cross-linklet-inlining? + (compile-context-namespace cctx) + get-module-linklet-info + module-use*s)))) + (values phase (cons linklet (list-tail (vector->list new-module-use*s) + (length body-imports)))))) + + (define body-linklets + (for/hasheq ([(phase l+mu*s) (in-hash body-linklets+module-use*s)]) + (values phase (car l+mu*s)))) + + (define phase-to-link-module-uses + (for/hasheq ([(phase l+mu*s) (in-hash body-linklets+module-use*s)]) + (values phase (module-uses-strip-extra-inspectorsss (cdr l+mu*s))))) + + (define phase-to-link-module-uses-expr + (serialize-phase-to-link-module-uses phase-to-link-module-uses mpis)) + + (define phase-to-link-extra-inspectorsss + (for*/hash ([(phase l+mu*s) (in-hash body-linklets+module-use*s)] + [(extra-inspectorsss) (in-value (module-uses-extract-extra-inspectorsss + (cdr l+mu*s) + (car l+mu*s) + cross-linklet-inlining? + (length body-imports)))] + #:when extra-inspectorsss) + (values phase extra-inspectorsss))) + + (values body-linklets ; main compilation result + min-phase + max-phase + phase-to-link-module-uses + phase-to-link-module-uses-expr + phase-to-link-extra-inspectorsss + syntax-literals + encoded-root-expand-pos)) + +;; ---------------------------------------- + +;; Evaluating a top-level definition has a secondary effect: it +;; adjusts the binding of defined identifiers. This mingling of +;; evaluation and expansion is the main weirdness of the top +;; level. +(define (compile-top-level-bind ids binding-syms cctx trans-exprs) + (define phase (compile-context-phase cctx)) + (define self (compile-context-self cctx)) + (define header (compile-context-header cctx)) + (define mpis (header-module-path-indexes header)) + ;; The binding that we install at run time should not include + ;; the temporary binding scope that the expander added: + (define top-level-bind-scope (root-expand-context-top-level-bind-scope + (namespace-get-root-expand-ctx + (compile-context-namespace cctx)))) + ;; For installing a binding: + (define self-expr (add-module-path-index! mpis self)) + ;; Generate calls to `top-level-bind!`: + `(begin + ,@(for/list ([id (in-list ids)] + [binding-sym (in-list binding-syms)] + [trans-expr (in-list (or trans-exprs + (for/list ([id (in-list ids)]) + `'#f)))]) + (define id-stx + (compile-quote-syntax (remove-scope id top-level-bind-scope) + cctx)) + `(,top-level-bind!-id ,id-stx ,self-expr ,phase ,phase-shift-id ,ns-id ',binding-sym + ,(and trans-exprs #t) ,trans-expr)))) + +;; To support namespace-relative binding, bundle scope information for +;; the current namespace into a syntax object +(define (compile-namespace-scopes cctx) + (define v (encode-namespace-scopes (compile-context-namespace cctx))) + (compile-quote-syntax v cctx)) + +;; ---------------------------------------- + +;; Handle the `define-syntaxes`-with-zero-results hack for the top level; +;; beware that we make two copies of `finish` +(define (generate-top-level-define-syntaxes gen-syms rhs transformer-set!s finish) + `(call-with-values + (lambda () ,rhs) + (case-lambda + [,gen-syms + (begin + ,@transformer-set!s + ,finish + (void))] + [() + (let-values ([,gen-syms (values ,@(for/list ([s (in-list gen-syms)]) `'#f))]) + (begin + ,finish + (void)))] + [args + ;; Provoke the wrong-number-of-arguments error: + (let-values ([,gen-syms (apply values args)]) + (void))]))) + +;; ---------------------------------------- + +(define (propagate-inline-property e orig-s) + (define v (syntax-property orig-s 'compiler-hint:cross-module-inline)) + (if v + (correlated-property e 'compiler-hint:cross-module-inline v) + e)) + +;; ---------------------------------------- + +(define (make-module-use-to-linklet cross-linklet-inlining? ns get-module-linklet-info init-mu*s) + ;; Inlining might reach the same module though different indirections; + ;; use a consistent `module-use` value so that the compiler knows to + ;; collapse them to a single import + (define mu*-intern-table (make-hash)) + (define (intern-module-use* mu*) + (define mod-name (module-path-index-resolve (module-use-module mu*))) + (define existing-mu* (hash-ref mu*-intern-table (cons mod-name (module-use-phase mu*)) #f)) + (cond + [existing-mu* + (module-use-merge-extra-inspectorss! existing-mu* mu*) + existing-mu*] + [else + (hash-set! mu*-intern-table (cons mod-name (module-use-phase mu*)) mu*) + mu*])) + (for ([mu* (in-list init-mu*s)]) + (intern-module-use* mu*)) + ;; The callback function supplied to `compile-linklet`: + (lambda (mu*-or-instance) + (cond + [(instance? mu*-or-instance) + ;; An instance represents a boilerplate linklet. An instance + ;; doesn't enable inlining (and we don't want inlining, since + ;; that would change the overall protocol for module or + ;; top-level linklets), but it can describe shapes. + (values mu*-or-instance #f)] + [(not cross-linklet-inlining?) + ;; Although we let instances through, because that's cheap, + ;; don't track down linklets and allow inlining of functions + (values #f #f)] + [mu*-or-instance + (define mu* mu*-or-instance) + (define mod-name (module-path-index-resolve (module-use-module mu*))) + (define mli (or (get-module-linklet-info mod-name (module-use-phase mu*)) + (namespace->module-linklet-info ns + mod-name + (module-use-phase mu*)))) + (when mli + ;; Record the module's declaration-time inspector, for use + ;; later recording extra inspectors for inlined referenced + (module-use*-declaration-inspector! mu* (module-linklet-info-inspector mli))) + (if mli + ;; Found info for inlining: + (values (module-linklet-info-linklet-or-instance mli) + (and (module-linklet-info-module-uses mli) ; => linklet + (list->vector + (append + '(#f #f) ; boilerplate imports common to all modules + (let ([mus (module-linklet-info-module-uses mli)] + [extra-inspectorsss (module-linklet-info-extra-inspectorsss mli)]) + (for/list ([sub-mu (in-list mus)] + [imports (in-list + (linklet-import-variables + (module-linklet-info-linklet-or-instance mli)))] + [extra-inspectorss (in-list (or extra-inspectorsss + ;; a list of the right length: + mus))]) + (intern-module-use* + (module-use+extra-inspectors (module-path-index-shift + (module-use-module sub-mu) + (module-linklet-info-self mli) + (module-use-module mu*)) + (module-use-phase sub-mu) + ;; The remaining arguments are used to + ;; make an `module-use*` instead of a + ;; plain `module-use` + imports + (module-linklet-info-inspector mli) + (module-linklet-info-extra-inspector mli) + (and extra-inspectorsss + extra-inspectorss))))))))) + ;; Didn't find info, for some reason: + (values #f #f))] + [else + ;; Boilerplate linklet with no compile-time information + (values #f #f)]))) diff --git a/racket/src/expander/compile/header.rkt b/racket/src/expander/compile/header.rkt new file mode 100644 index 0000000000..bc43a9738f --- /dev/null +++ b/racket/src/expander/compile/header.rkt @@ -0,0 +1,329 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/scope.rkt" + "module-use.rkt" + "../common/module-path.rkt" + "context.rkt" + "built-in-symbol.rkt" + "reserved-symbol.rkt" + "namespace-scope.rkt" + "serialize.rkt" + "vector-ref.rkt") + +(provide (struct-out header) + make-header + + make-syntax-literals + syntax-literals-empty? + syntax-literals-count + add-syntax-literal! + add-syntax-literals! + generate-eager-syntax-literals! + generate-eager-syntax-literal-lookup + generate-lazy-syntax-literals! + generate-lazy-syntax-literals-data! + generate-lazy-syntax-literal-lookup + syntax-literals-as-vector + + header-empty-syntax-literals? + + local-key->symbol + select-fresh + + register-required-variable-use! + register-as-defined! + registered-as-required? + generate-links+imports) + +;; A compilation header accumulates information about syntax literals +;; and about referenced required and defined variables. This +;; information is accumulated while compiling expressions, and then +;; header information is extracted into deserialization code that +;; reconstructs syntax literals, module path indexes, and so on. The +;; header also keeps track of which variable references correspond to +;; which linklet imports, and it keeps track of compile-time +;; inspectors that may grant access to some of those imports. + +(struct syntax-literals ([stxes #:mutable] + [count #:mutable])) + +(struct header (module-path-indexes ; module-path-index -> linklet import position + binding-sym-to-define-sym ; sym -> sym; avoid conflicts with primitives + [binding-syms-in-order #:mutable] ; list of sym + require-var-to-import-sym ; variable-use -> sym + import-sym-to-extra-inspectors ; sym -> set of inspectors + [require-vars-in-order #:mutable] ; list of variable-use + define-and-import-syms ; hash of sym -> 'defined/'imported, to select distinct symbols + syntax-literals)) ; syntax-literals + +(struct variable-use (module-use sym) + #:transparent) ; for hashing + +(define (make-syntax-literals) + (syntax-literals null 0)) + +(define (make-header mpis syntax-literals) + (header mpis + (make-hasheq) ; binding-sym-to-define-sym + null ; binding-syms-in-order + (make-variable-uses) ; require-var-to-import-sym + (make-hasheq) ; import-sym-to-extra-inspectors + null ; require-vars-in-order + (make-hasheq) ; define-and-import-syms + syntax-literals)) + +(define (make-variable-uses) + (make-hash)) + +(define (add-syntax-literal! header-or-literals q) + (define sl (if (header? header-or-literals) + (header-syntax-literals header-or-literals) + header-or-literals)) + (define pos (syntax-literals-count sl)) + (set-syntax-literals-count! sl (add1 pos)) + (set-syntax-literals-stxes! sl (cons q (syntax-literals-stxes sl))) + pos) + +;; Return a position in a larger vector where the given vector will +;; start; for convenience, pair that position with the size of the +;; vector +(define (add-syntax-literals! sl vec) + (define pos (syntax-literals-count sl)) + (for ([e (in-vector vec)]) + (add-syntax-literal! sl e)) + (cons pos (vector-length vec))) + +(define (syntax-literals-empty? sl) + (null? (syntax-literals-stxes sl))) + +;; Generate on-demand shifting (not shared among module instances) +;; using `deserialize-syntax-literal-data` (shared among module +;; instances); the result defines `syntax-literals-id` and +;; `get-syntax-literal!-id` +(define (generate-lazy-syntax-literals! sl mpis self + #:skip-deserialize? [skip-deserialize? #f]) + `((define-values (,syntax-literals-id) + (make-vector ,(syntax-literals-count sl) #f)) + (define-values (,get-syntax-literal!-id) + (lambda (pos) + (let-values ([(ready-stx) (,unsafe-vector-ref-id ,syntax-literals-id pos)]) + (if ready-stx + ready-stx + (begin + ,@(if skip-deserialize? + null + `((if (,unsafe-vector-ref-id ,deserialized-syntax-vector-id 0) + (void) + (,deserialize-syntax-id ,bulk-binding-registry-id)))) + (let-values ([(stx) + (syntax-module-path-index-shift + (syntax-shift-phase-level + (,unsafe-vector-ref-id ,deserialized-syntax-vector-id pos) + ,phase-shift-id) + ,(add-module-path-index! mpis self) + ,self-id + ,inspector-id)]) + (begin + (vector-cas! ,syntax-literals-id pos #f stx) + (,unsafe-vector-ref-id ,syntax-literals-id pos)))))))))) + +;; Generate on-demand deserialization (shared across instances); the +;; result defines `deserialize-syntax-id` +(define (generate-lazy-syntax-literals-data! sl mpis) + (cond + [(syntax-literals-empty? sl) + `((define-values (,deserialize-syntax-id) #f))] + [else + `((define-values (,deserialize-syntax-id) + ;; Put deserialization under a `lambda` so that it's loaded + ;; from bytecode on demand, and in a function that can be + ;; discarded via `set!` after deserialization. Since this + ;; deserialized form is shared via the module cache across + ;; module instances and even module declarations, it must not + ;; depend on anything namespace-, declaration-, or + ;; instance-specific. As an exception, however, a bulk-binding + ;; registry can be namespace- or declaration-specific + ;; declaration on the grounds that all declarations should + ;; provide the same information for bulk bindings. + (lambda (,bulk-binding-registry-id) + (begin + (vector-copy! + ,deserialized-syntax-vector-id + '0 + (let-values ([(,inspector-id) #f]) + ,(generate-deserialize (vector->immutable-vector + (list->vector + (reverse (syntax-literals-stxes sl)))) + mpis))) + (set! ,deserialize-syntax-id #f)))))])) + +(define (generate-lazy-syntax-literal-lookup pos) + `(,get-syntax-literal!-id ,pos)) + +;; Generate immediate deserialization and shifting of a set of syntax +;; objects across multiple phases; the result is an expression for a +;; vector (indexed by syntax-literal position). +(define (generate-eager-syntax-literals! sl mpis base-phase self ns) + (cond + [(syntax-literals-empty? sl) + ;; Avoid serializing unneeded namespace scope: + #f] + [else + `(let-values ([(ns+stxss) ,(generate-deserialize (cons + ;; Prefix with namespace scope: + (encode-namespace-scopes ns) + (reverse + (syntax-literals-stxes sl))) + mpis)]) + (let-values ([(ns-scope-s) (car ns+stxss)]) + (list->vector + (map (lambda (stx) + (swap-top-level-scopes + (syntax-module-path-index-shift + (syntax-shift-phase-level + stx + (- ,base-phase ,dest-phase-id)) + ,(add-module-path-index! mpis self) + ,self-id) + ns-scope-s ,ns-id)) + (cdr ns+stxss)))))])) + +(define (generate-eager-syntax-literal-lookup pos) + `(,unsafe-vector-ref-id ,syntax-literals-id ,pos)) + +;; Genereate a vector for a set of syntax objects; the result is a +;; vector like the one generated in expression from by +;; `generate-eager-syntax-literals!`, where no shifts are needed +(define (syntax-literals-as-vector sl) + (list->vector + (reverse (syntax-literals-stxes sl)))) + +(define (header-empty-syntax-literals? h) + (syntax-literals-empty? (header-syntax-literals h))) + +;; ---------------------------------------- + +;; Pick a symbol to represent a local binding, given the binding's key +(define (local-key->symbol key) + ;; A local-binding key is already an distinct uninterned symbol + ;; (with a deterministic label) + key) + +;; Select a symbol not yet used in the header or as a built-in name +(define (select-fresh sym header) + (if (symbol-conflicts? sym header) + (let loop ([pos 1]) + (define new-sym (string->symbol (format "~a/~a" pos sym))) + (if (symbol-conflicts? new-sym header) + (loop (add1 pos)) + new-sym)) + sym)) + +(define (symbol-conflicts? sym header) + (or (built-in-symbol? sym) + (hash-ref (header-define-and-import-syms header) sym #f))) + +;; ---------------------------------------- + +(define (register-required-variable-use! header mpi phase sym extra-inspector + #:defined? [defined? #f]) + (define key (variable-use (module-use mpi phase) sym)) + (define variable-uses (header-require-var-to-import-sym header)) + (define prev-var-sym (hash-ref variable-uses key #f)) + (define var-sym + (or prev-var-sym + (let ([sym (select-fresh (variable-use-sym key) header)]) + (hash-set! variable-uses key sym) + (set-header-require-vars-in-order! header + (cons key + (header-require-vars-in-order header))) + (hash-set! (header-define-and-import-syms header) sym (if defined? 'defined 'required)) + sym))) + (when (and extra-inspector + ;; Only track extra inspectors if all references have an inspector; + ;; otherwise, the one without an extra inspector has the least access + (not prev-var-sym)) + (define extra-inspectors (header-import-sym-to-extra-inspectors header)) + (hash-update! extra-inspectors var-sym (lambda (s) (set-add s extra-inspector)) #hasheq())) + var-sym) + +(define (register-as-defined! header def-sym) + (hash-set! (header-define-and-import-syms header) def-sym 'defined)) + +(define (registered-as-required? header var-sym) + (eq? 'required (hash-ref (header-define-and-import-syms header) var-sym #f))) + +;; Returns: +;; link-names : a list of sym +;; link-requires : a list of module path indexes +;; imports : a list of S-expressions for imports; refers to `link-names` +;; extra-inspectorsss : a list of hash of symbol to (or/c #f (set/c inspector?)) +;; def-decls : a list of S-expressions for forward-reference declarations +(define (generate-links+imports header phase cctx cross-linklet-inlining?) + ;; Find each distinct module+phase: + (define mod-use-ht + (for/fold ([ht #hash()]) ([(vu) (in-list (header-require-vars-in-order header))]) + (define mu (variable-use-module-use vu)) + (if (or (hash-ref ht mu #f) + (eq? (module-use-module mu) + (compile-context-self cctx)) + (top-level-module-path-index? (module-use-module mu))) + ht + (hash-set ht mu #t)))) + ;; List of distinct module+phases: + (define link-mod-uses (hash-keys mod-use-ht)) + + (values + ;; Module-uses list: + link-mod-uses + ;; Imports, using the same order as module-uses list: + (for/list ([mu (in-list link-mod-uses)]) + (for/list ([vu (in-list (header-require-vars-in-order header))] + #:when (equal? mu (variable-use-module-use vu))) + (define var-sym (hash-ref (header-require-var-to-import-sym header) vu)) + (define ex-sym (variable-use-sym vu)) + (if (eq? var-sym ex-sym) + var-sym + `[,ex-sym ,var-sym]))) + ;; Extra inspectorsss, in parallel to imports + (for/list ([mu (in-list link-mod-uses)]) + (define extra-inspectorss + (for*/hash ([vu (in-list (header-require-vars-in-order header))] + #:when (equal? mu (variable-use-module-use vu)) + [var-sym (in-value (hash-ref (header-require-var-to-import-sym header) vu))] + [extra-inspectors (in-value (hash-ref (header-import-sym-to-extra-inspectors header) var-sym #f))] + #:when (or extra-inspectors + ;; For inlining purposes, keep track of all referenced, + ;; since formerly unreferenced will mean inlined + cross-linklet-inlining?)) + (values var-sym extra-inspectors))) + (and (hash-count extra-inspectorss) + extra-inspectorss)) + ;; Declarations (for non-module contexts) + (for/list ([vu (in-list (header-require-vars-in-order header))] + #:when (let ([mod (module-use-module (variable-use-module-use vu))]) + (or (eq? mod (compile-context-self cctx)) + (top-level-module-path-index? mod)))) + (define var-sym (hash-ref (header-require-var-to-import-sym header) vu)) + (define ex-sym (variable-use-sym vu)) + (if (eq? var-sym ex-sym) + var-sym + `(,var-sym ,ex-sym))))) + +;; Get a reasonably nice name from a module-path-index +(define (extract-name mpi) + (define-values (p base) (module-path-index-split mpi)) + (cond + [(symbol? p) p] + [(path? p) (let-values ([(base name dir?) (split-path p)]) + (path-replace-extension name #""))] + [(string? p) (path-replace-extension p #"")] + [(and (pair? p) (eq? (car p) 'quote)) + (cadr p)] + [(and (pair? p) (eq? (car p) 'file)) + (let-values ([(base name dir?) (split-path (cadr p))]) + (path-replace-extension name #""))] + [(and (pair? p) (eq? (car p) 'lib)) + (path-replace-extension (cadr p) #"")] + [else 'module])) + diff --git a/racket/src/expander/compile/instance.rkt b/racket/src/expander/compile/instance.rkt new file mode 100644 index 0000000000..3a25447ed2 --- /dev/null +++ b/racket/src/expander/compile/instance.rkt @@ -0,0 +1,67 @@ +#lang racket/base +(require "reserved-symbol.rkt" + "../host/linklet.rkt") + +;; Compilation generates a linklet that has an `instance` argument to +;; receive instantiation information: a namspace, its phase, etc. + +(provide instance-imports + make-instance-instance + make-module-body-instance-instance + empty-syntax-literals-instance + empty-module-body-instance + empty-syntax-literals-data-instance + empty-top-syntax-literal-instance + empty-instance-instance) + +(define instance-imports + `(,ns-id + ,phase-shift-id + ,self-id + ,inspector-id ; declaration-time inspector to grant to syntax objects + ,bulk-binding-registry-id ; declaration-time registry to connect to bulk bindings + ,set-transformer!-id)) + +(define (make-instance-instance #:namespace ns + #:phase-shift phase-shift + #:self self + #:inspector inspector + #:bulk-binding-registry bulk-binding-registry + #:set-transformer! set-transformer!) + (make-instance 'instance #f 'constant + ns-id ns + phase-shift-id phase-shift + self-id self + inspector-id inspector + bulk-binding-registry-id bulk-binding-registry + set-transformer!-id set-transformer!)) + +(define (make-module-body-instance-instance #:set-transformer! set-transformer!) + (make-instance 'body-instance #f 'constant + set-transformer!-id set-transformer!)) + +(define empty-syntax-literals-instance + (make-instance 'empty-stx #f 'constant + get-syntax-literal!-id (lambda (pos) #f) + 'get-encoded-root-expand-ctx #f)) + +(define empty-module-body-instance + (make-module-body-instance-instance #:set-transformer! (lambda (name val) (void)))) + +(define empty-top-syntax-literal-instance + (make-instance 'top-syntax-literal #f 'constant + mpi-vector-id #f + syntax-literals-id #f)) + +(define empty-syntax-literals-data-instance + (make-instance 'empty-stx-data #f 'constant + deserialized-syntax-vector-id (vector) + deserialize-syntax-id void)) + +(define empty-instance-instance + (make-instance-instance #:namespace #f + #:phase-shift #f + #:self #f + #:inspector #f + #:bulk-binding-registry #f + #:set-transformer! #f)) diff --git a/racket/src/expander/compile/known.rkt b/racket/src/expander/compile/known.rkt new file mode 100644 index 0000000000..cadbf85364 --- /dev/null +++ b/racket/src/expander/compile/known.rkt @@ -0,0 +1,55 @@ +#lang racket/base + +(provide (struct-out known-defined) + (struct-out known-defined/delay) + (struct-out known-property) + (struct-out known-function) + (struct-out known-function-of-satisfying) + (struct-out known-predicate) + (struct-out known-satisfies) + (struct-out known-struct-op) + lookup-defn) + +;; Known locals and defined variables map to one of he following: + +(struct known-defined () #:prefab) +;; all we know is that it's defined and can be referenced now + +(struct known-defined/delay (thunk) #:prefab) +;; force the thunk and try again + +(struct known-property () #:prefab) +;; defined as a struct property with no guard + +(struct known-function (arity pure?) #:prefab) +;; function of known arity and maybe known pure, where +;; pure must return 1 value + +(struct known-function-of-satisfying (arg-predicate-keys) #:prefab) +;; function that is known to be pure as long as its arguments +;; are known to satisfy certain predicates + +(struct known-predicate (key) #:prefab) +;; a predicate that is pure and categorizes an argument + +(struct known-satisfies (predicate-key) #:prefab) +;; a value that is known to satisfy a specific predicate + +(struct known-struct-op (type field-count) #:prefab) +;; struct operation for a type with n fields +;; where type is one of: 'struct-type, 'constructor +;; 'predicate, 'accessor, 'mutator +;; 'general-accessor, +;; or 'general-mutator (needs field index) +;; and the 'constructor mode can be used for things that +;; construct built-in datatypes; for 'general-accessor or +;; 'general-mutator, the field count doesn't include inherited + +;; Supports `known-defined/delay`: +(define (lookup-defn defns sym) + (define d (hash-ref defns sym #f)) + (cond + [(known-defined/delay? d) + ((known-defined/delay-thunk d)) + (lookup-defn defns sym)] + [else d])) diff --git a/racket/src/expander/compile/main.rkt b/racket/src/expander/compile/main.rkt new file mode 100644 index 0000000000..970541095e --- /dev/null +++ b/racket/src/expander/compile/main.rkt @@ -0,0 +1,72 @@ +#lang racket/base +(require "context.rkt" + "top.rkt" + "multi-top.rkt" + "module.rkt" + "recompile.rkt") + +;; Compilation of expanded code produces an S-expression (but enriched +;; with source locations and properties) where run-time primitive are +;; accessed directly, and all linklet imports and local variables are +;; renamed to avoid collisions with the primitive names and to avoid +;; all shadowing (but the same variable might be used in +;; non-overlapping local contexts). A `compile-linklet` function +;; (currently provided by the runtime system) then compiles the +;; enriched S-expression to bytecode. + +;; Compilation to linklets uses one of two protocols, which differ in +;; the shapes of linklets that they generate: +;; +;; * Top-level forms or stand-alone expressions (such as the +;; right-hand side of a `define-syntaxes` form within a module, +;; which must be compiled to continue expanding the module) are +;; compiled using one protocol. +;; +;; In the case of top-level forms, a sequence of forms that affect +;; binding or transformers must be compiled separately --- normally +;; via `per-top-level` in "../eval/main.rkt". The separarately +;; compiled forms can them be combined into a single compilation +;; record. +;; +;; The generated linklets for a single form include one linklet for +;; potentially serialized module path indices and syntax objects, +;; plus one linklet per relevant phase. +;; +;; Multi-form combinations group the linklet sets for individual +;; compilations in nested linklet directories. In addition, a +;; linklet implements deserialization of all the data across +;; top-level forms that are compiled together, so that they share. +;; (In that case, the deserialization linklet with each inidvidual +;; form turns out not to be used.) +;; +;; * Modules are compiled to a slightly different protocol. Like the +;; top-level protocol, the resulting set of linklets includes on +;; linklet per phase plus three linklets for housing potentially +;; serialized data. An additional linklet reports metadata about the +;; modules, such as its requires and provides. An individual module +;; is represented by a linklet bundle, and a module is compiled with +;; submodules through nested linklet directories. +;; +;; Besides the extra metadata module, the handling of syntax-object +;; deserialization is a little different for modules than top-level +;; forms, because syntax-literal unmarshaling is lazy for modules. +;; +;; Whichever protocol is used, the result is wrapped in a +;; `compiled-in-memory` structure, which retains original module path +;; indices and syntax objects. If the compiled code is evaluated +;; directly, then the retained values are used instead of running +;; unmarshaling code in generated linklets. That's both faster an +;; preserves some expected sharing. When a `compile-in-memory` +;; structure is written, it writes the same as a linklet directory +;; (i.e., it loses the shortcut information, as well as some +;; inspector information). + +(provide make-compile-context + + compile-single + compile-top + compiled-tops->compiled-top + + compile-module + + compiled-expression-recompile) diff --git a/racket/src/expander/compile/module-use.rkt b/racket/src/expander/compile/module-use.rkt new file mode 100644 index 0000000000..ea8e2ed213 --- /dev/null +++ b/racket/src/expander/compile/module-use.rkt @@ -0,0 +1,11 @@ +#lang racket/base + +;; A `module-use` record is just a part of module path index plus +;; phase, since that combination is commonly needed + +(provide (struct-out module-use)) + +(struct module-use (module phase) + ;; transparent for hashing; note that module path indices will + ;; be hashed as `equal?`, which makes sense within a module + #:transparent) diff --git a/racket/src/expander/compile/module.rkt b/racket/src/expander/compile/module.rkt new file mode 100644 index 0000000000..d3770b84e7 --- /dev/null +++ b/racket/src/expander/compile/module.rkt @@ -0,0 +1,420 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../common/phase.rkt" + "../namespace/core.rkt" + "../namespace/module.rkt" + "../common/module-path.rkt" + "../common/performance.rkt" + "../expand/parsed.rkt" + "module-use.rkt" + "serialize.rkt" + "side-effect.rkt" + "built-in-symbol.rkt" + "../host/linklet.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "instance.rkt" + "form.rkt" + "compiled-in-memory.rkt" + "../eval/reflect.rkt" + "../eval/reflect-name.rkt") + +(provide compile-module) + +;; Compiles module to a set of linklets that is returned as a +;; `compiled-in-memory` --- or a hash table containing S-expression +;; linklets if `to-source?` is true. +(define (compile-module p cctx + #:force-linklet-directory? [force-linklet-directory? #f] + #:serializable? [serializable? #f] + #:to-source? [to-source? #f] + #:modules-being-compiled [modules-being-compiled (make-hasheq)] + #:need-compiled-submodule-rename? [need-compiled-submodule-rename? #t]) + + (define full-module-name (let ([parent-full-name (compile-context-full-module-name cctx)] + [name (syntax-e (parsed-module-name-id p))]) + (if parent-full-name + (append (if (list? parent-full-name) + parent-full-name + (list parent-full-name)) + (list name)) + name))) + + ;; Extract submodules; each list is (cons linklet-directory-key compiled-in-memory) + (define compiled-submodules (parsed-module-compiled-submodules p)) + (define (get-submodules star?) + (for/list ([(name star?+compiled) (in-hash compiled-submodules)] + #:when (eq? star? (car star?+compiled))) + (cons name (if (and need-compiled-submodule-rename? + (not (parsed-module-compiled-module p))) + (update-submodule-names (cdr star?+compiled) name full-module-name) + (cdr star?+compiled))))) + (define pre-submodules (get-submodules #f)) + (define post-submodules (get-submodules #t)) + + (cond + [(parsed-module-compiled-module p) + => (lambda (c) + ;; We've already compiled the module body during expansion. + ;; Update the name in the compiled form and add in submodules. + (define-values (name prefix) (if (symbol? full-module-name) + (values full-module-name null) + (let ([r (reverse full-module-name)]) + (values (car r) (reverse (cdr r)))))) + (define m (change-module-name c name prefix)) + (module-compiled-submodules (module-compiled-submodules m #t (map cdr pre-submodules)) + #f + (map cdr post-submodules)))] + [else + (compile-module-from-parsed p cctx + #:full-module-name full-module-name + #:force-linklet-directory? force-linklet-directory? + #:serializable? serializable? + #:to-source? to-source? + #:modules-being-compiled modules-being-compiled + #:pre-submodules pre-submodules + #:post-submodules post-submodules + #:need-compiled-submodule-rename? need-compiled-submodule-rename?)])) + +;; ------------------------------------------------------------ + +(define (compile-module-from-parsed p cctx + #:full-module-name full-module-name + #:force-linklet-directory? force-linklet-directory? + #:serializable? serializable? + #:to-source? to-source? + #:modules-being-compiled modules-being-compiled + #:pre-submodules pre-submodules + #:post-submodules post-submodules + #:need-compiled-submodule-rename? need-compiled-submodule-rename?) + (performance-region + ['compile 'module] + + (define enclosing-self (compile-context-module-self cctx)) + (define self (parsed-module-self p)) + (define requires (parsed-module-requires p)) + (define provides (parsed-module-provides p)) + (define encoded-root-expand-ctx-box (box (parsed-module-encoded-root-ctx p))) ; for `module->namespace` + (define body-context-simple? (parsed-module-root-ctx-simple? p)) + (define language-info (filter-language-info (syntax-property (parsed-s p) 'module-language))) + (define bodys (parsed-module-body p)) + + (define empty-result-for-module->namespace? #f) + + (define mpis (make-module-path-index-table)) + + (define body-cctx (struct-copy compile-context cctx + [phase 0] + [self self] + [module-self self] + [full-module-name full-module-name] + [lazy-syntax-literals? #t])) + + (define cross-phase-persistent? #f) + + ;; Callback to track phases that have side effects + (define side-effects (make-hasheqv)) + (define (check-side-effects! e ; compiled expression + expected-results ; number of expected results, or #f if any number is ok + phase + required-reference?) + (unless (hash-ref side-effects phase #f) + (when (any-side-effects? e expected-results #:ready-variable? required-reference?) + (hash-set! side-effects phase #t)))) + + (when (and need-compiled-submodule-rename? + modules-being-compiled) + ;; Re-register submodules, since they're so far registered under + ;; the expand-time module path. + (unless (null? post-submodules) + (error "internal error: have post submodules, but not already compiled")) + (register-compiled-submodules modules-being-compiled pre-submodules self)) + + ;; Compile the sequence of body forms: + (define-values (body-linklets + min-phase + max-phase + phase-to-link-module-uses + phase-to-link-module-uses-expr + phase-to-link-extra-inspectorsss + syntax-literals + root-ctx-pos) + (compile-forms bodys body-cctx mpis + #:body-imports `([,get-syntax-literal!-id] + [,set-transformer!-id]) + #:body-import-instances (list empty-syntax-literals-instance + empty-module-body-instance) + #:body-suffix-forms '((void)) ; otherwise, compiler always preserves last form + #:force-phases '(0) ; minor hack for more consistent compilation + #:encoded-root-expand-ctx-box encoded-root-expand-ctx-box + #:root-ctx-only-if-syntax? body-context-simple? + #:compiled-expression-callback check-side-effects! + #:other-form-callback (lambda (body cctx) + (cond + [(parsed-#%declare? body) + (define-match m (parsed-s body) '(_ kw ...)) + (for ([kw (in-list (m 'kw))]) + (when (eq? (syntax-e kw) '#:cross-phase-persistent) + (set! cross-phase-persistent? #t)) + (when (eq? (syntax-e kw) '#:empty-namespace) + (set! empty-result-for-module->namespace? #t) + (set-box! encoded-root-expand-ctx-box #f))) + #f] + [else #f])) + #:get-module-linklet-info (lambda (mod-name phase) + (define ht (and modules-being-compiled + (hash-ref modules-being-compiled mod-name #f))) + (and ht (hash-ref ht phase #f))) + #:to-source? to-source? + #:serializable? serializable?)) + + (when modules-being-compiled + ;; Record this module's linklets for cross-module inlining among (sub)modules + ;; that are compiled together + (hash-set! modules-being-compiled + (module-path-index-resolve self) + (for/hasheq ([(phase linklet) (in-hash body-linklets)]) + (values phase + (module-linklet-info linklet + (hash-ref phase-to-link-module-uses phase #f) + self + #f ; inspector is the same as other modules + #f ; no extra inspector, so far + (and phase-to-link-extra-inspectorsss + (hash-ref phase-to-link-extra-inspectorsss phase #f))))))) + + ;; Assemble the declaration linking unit, which includes linking + ;; information for each phase, is instanted once for a module + ;; declaration, and is shared among instances + (define declaration-linklet + (and serializable? + ((if to-source? values (lambda (s) (performance-region + ['compile 'module 'linklet] + (compile-linklet s 'decl)))) + `(linklet + ;; imports + (,deserialize-imports + [,mpi-vector-id]) + ;; exports + (self-mpi + requires + provides + phase-to-link-modules) + ;; body + (define-values (self-mpi) ,(add-module-path-index! mpis self)) + (define-values (requires) ,(generate-deserialize requires mpis #:syntax-support? #f)) + (define-values (provides) ,(generate-deserialize provides mpis #:syntax-support? #f)) + (define-values (phase-to-link-modules) ,phase-to-link-module-uses-expr))))) + + ;; Assemble a linklet that shifts syntax objects on demand. + ;; Include an encoding of the root expand context, if any, so that + ;; `module->namespace` can have the same scopes as literal syntax + ;; objects in the module. + (define syntax-literals-linklet + (and (not (syntax-literals-empty? syntax-literals)) + ((if to-source? values (lambda (s) + (performance-region + ['compile 'module 'linklet] + (define-values (linklet new-keys) + (compile-linklet s 'syntax-literals + (vector deserialize-instance + empty-top-syntax-literal-instance + empty-syntax-literals-data-instance + empty-instance-instance) + (lambda (inst) (values inst #f)) + serializable?)) + linklet))) + `(linklet + ;; imports + (,deserialize-imports + [,mpi-vector-id] + [,deserialized-syntax-vector-id + ,@(if serializable? + `(,deserialize-syntax-id) + '())] + ,instance-imports) + ;; exports + (,get-syntax-literal!-id + get-encoded-root-expand-ctx) + ;; body + ,@(generate-lazy-syntax-literals! syntax-literals mpis self + #:skip-deserialize? (not serializable?)) + (define-values (get-encoded-root-expand-ctx) + ,(cond + [root-ctx-pos + `(lambda () + ,(generate-lazy-syntax-literal-lookup root-ctx-pos))] + [empty-result-for-module->namespace? + ;; We also attach this information directly to the bundle, + ;; in case this linklet is not included (due to an empty + ;; set of syntax literals) + `'empty] + [else + `'#f])))))) + + ;; Assemble a linklet that deserializes unshifted syntax objects on + ;; demand. An instance of this linklet is shared for all + ;; instantiations of the module, like the data linklet. It's + ;; separate from the data linklet so that the data linklet can be + ;; instantiated for information that just depends on module path + ;; indexes, such as required modules. + (define syntax-literals-data-linklet + (and serializable? + (not (syntax-literals-empty? syntax-literals)) + ((if to-source? values (lambda (s) (performance-region + ['compile 'module 'linklet] + (compile-linklet s 'syntax-literals-data)))) + `(linklet + ;; imports + (,deserialize-imports + [,mpi-vector-id]) + ;; exports + (,deserialized-syntax-vector-id + ,deserialize-syntax-id) + ;; body + (define-values (,deserialized-syntax-vector-id) + (make-vector ,(syntax-literals-count syntax-literals) #f)) + ,@(performance-region + ['compile 'module 'serialize] + (generate-lazy-syntax-literals-data! syntax-literals mpis)))))) + + ;; The data linklet houses deserialized data for use by the + ;; declaration and module-body linklets. Its instance is shared + ;; across module instances. + (define data-linklet + (and serializable? + ((if to-source? values (lambda (s) (performance-region + ['compile 'module 'linklet] + (compile-linklet s 'data)))) + `(linklet + ;; imports + (,deserialize-imports) + ;; exports + (,mpi-vector-id) + ;; body + (define-values (,inspector-id) (current-code-inspector)) + (define-values (,mpi-vector-id) + ,(generate-module-path-index-deserialize mpis)))))) + + ;; Combine linklets with other metadata as the bundle: + (define bundle + (let* ([bundle (hash-set body-linklets 'name full-module-name)] + [bundle (hash-set bundle 'decl (or declaration-linklet + ;; Need a 'decl mapping to indicate + ;; that bundle is a module: + 'in-memory))] + [bundle (if data-linklet + (hash-set bundle 'data data-linklet) + bundle)] + [bundle (if syntax-literals-linklet + (hash-set bundle 'stx syntax-literals-linklet) + bundle)] + [bundle (if syntax-literals-data-linklet + (hash-set bundle 'stx-data syntax-literals-data-linklet) + bundle)] + [bundle (if (null? pre-submodules) + bundle + (hash-set bundle 'pre (map car pre-submodules)))] + [bundle (if (null? post-submodules) + bundle + (hash-set bundle 'post (map car post-submodules)))] + [bundle (if cross-phase-persistent? + (hash-set bundle 'cross-phase-persistent? #t) + bundle)] + [bundle (if language-info + (hash-set bundle 'language-info language-info) + bundle)] + [bundle (if (zero? min-phase) + bundle + (hash-set bundle 'min-phase min-phase))] + [bundle (if (zero? max-phase) + bundle + (hash-set bundle 'max-phase max-phase))] + [bundle (if (hash-count side-effects) + (hash-set bundle 'side-effects (sort (hash-keys side-effects) <)) + bundle)] + [bundle (if empty-result-for-module->namespace? + (hash-set bundle 'module->namespace 'empty) + bundle)]) + (hash->linklet-bundle bundle))) + + ;; Combine with submodules in a linklet directory + (define ld + (cond + [(and (null? pre-submodules) + (null? post-submodules) + (not force-linklet-directory?)) + ;; Just use the bundle representation directly: + bundle] + [else + ((if to-source? values hash->linklet-directory) + (for/fold ([ht (hasheq #f bundle)]) ([sm (in-list (append pre-submodules post-submodules))]) + (hash-set ht + (car sm) + ((if to-source? values compiled-in-memory-linklet-directory) + (cdr sm)))))])) + + (cond + [to-source? ld] + [else + ;; Save mpis and syntax for direct evaluation, instead of unmarshaling: + (compiled-in-memory ld + self + requires + provides + phase-to-link-module-uses + (current-code-inspector) + phase-to-link-extra-inspectorsss + (mpis-as-vector mpis) + (syntax-literals-as-vector syntax-literals) + (map cdr pre-submodules) + (map cdr post-submodules) + #f ; no namespace scopes + #f)]))) ; not purely functional, since it declares a module + +;; ---------------------------------------- + +;; When a submodule is compiled while expanding a module, then it has a base +;; module name that is an uninterned symbol. +(define (update-submodule-names cim name full-module-name) + (change-module-name cim name (if (symbol? full-module-name) + (list full-module-name) + (reverse (cdr (reverse full-module-name)))))) + +(define (register-compiled-submodules modules-being-compiled pre-submodules self) + (for ([s (in-list pre-submodules)]) + (define name (car s)) + (define cim (cdr s)) + (define phase-to-link-module-uses (compiled-in-memory-phase-to-link-module-uses cim)) + (define ld (compiled-in-memory-linklet-directory cim)) + (define sm-self (module-path-index-join `(submod "." ,name) self)) + (define phase-to-extra-inspectorsss (compiled-in-memory-phase-to-link-extra-inspectorsss cim)) + (hash-set! modules-being-compiled + (module-path-index-resolve sm-self) + (for/hasheq ([(phase linklet) (in-hash (linklet-bundle->hash + (if (linklet-directory? ld) + (hash-ref (linklet-directory->hash ld) #f) + ld)))] + #:when (number? phase)) + (values phase + (module-linklet-info linklet + (hash-ref phase-to-link-module-uses phase #f) + self + #f ; inspector is the same as the module being compiled + (compiled-in-memory-compile-time-inspector cim) + (and phase-to-extra-inspectorsss + (hash-ref phase-to-extra-inspectorsss phase #f)))))))) + +;; ---------------------------------------- + +(define (filter-language-info li) + (and (vector? li) + (= 3 (vector-length li)) + (module-path? (vector-ref li 0)) + (symbol? (vector-ref li 1)) + li)) diff --git a/racket/src/expander/compile/multi-top-data.rkt b/racket/src/expander/compile/multi-top-data.rkt new file mode 100644 index 0000000000..506ddf522d --- /dev/null +++ b/racket/src/expander/compile/multi-top-data.rkt @@ -0,0 +1,94 @@ +#lang racket/base +(require "compiled-in-memory.rkt" + "serialize.rkt" + "header.rkt" + "eager-instance.rkt" + "reserved-symbol.rkt" + "../host/linklet.rkt") + +(provide build-shared-data-linklet) + +;; When multiple top-level forms are compiled separately (e.g., for a +;; `begin` sequence), then each has its own serialization of syntax +;; objects and module path indxes, but we want that information to be +;; shared acrosss forms that are compiled together. So, re-serialize +;; the data here in a way that can be shared across the forms. +;; +;; When a multi-form top-level sequence is evaluated, the shared +;; deserialization is propagated to each individual form by +;; reconstructing a `compiled-in-memory` structure and using the same +;; protocol as when top-level forms are evaluated immediately after +;; compilation. See "../eval/multi-top.rkt" for that part, which is +;; the run-time complement to the encoding here. + +(define (build-shared-data-linklet cims ns) + ;; Gather all mpis: + (define mpis (make-module-path-index-table)) + (define mpi-trees + (map-cim-tree cims + (lambda (cim) + (for/vector ([mpi (in-vector (compiled-in-memory-mpis cim))]) + (add-module-path-index!/pos mpis mpi))))) + + ;; Gather all syntax literals: + (define syntax-literals (make-syntax-literals)) + (define syntax-literals-trees + (map-cim-tree cims + (lambda (cim) + (add-syntax-literals! + syntax-literals + (compiled-in-memory-syntax-literals cim))))) + + ;; Gather all phase-to-module-uses tables: + (define module-uses-tables null) + (define module-uses-tables-count 0) + (define phase-to-link-module-uses-trees + (map-cim-tree cims + (lambda (cim) + (define pos module-uses-tables-count) + (set! module-uses-tables (cons (compiled-in-memory-phase-to-link-module-uses cim) + module-uses-tables)) + (set! module-uses-tables-count (add1 pos)) + pos))) + + (define syntax-literals-expr + (generate-eager-syntax-literals! + syntax-literals + mpis + 0 + #f ; self + ns)) + + (define phase-to-link-module-uses-expr + `(vector + ,@(for/list ([phase-to-link-module-uses (in-list (reverse module-uses-tables))]) + (serialize-phase-to-link-module-uses phase-to-link-module-uses mpis)))) + + (compile-linklet + `(linklet + ;; imports + (,deserialize-imports + ,eager-instance-imports) + ;; exports + (,mpi-vector-id + mpi-vector-trees + phase-to-link-modules-vector + phase-to-link-modules-trees + syntax-literals + syntax-literals-trees) + (define-values (,mpi-vector-id) + ,(generate-module-path-index-deserialize mpis)) + (define-values (mpi-vector-trees) ',mpi-trees) + (define-values (phase-to-link-modules-vector) ,phase-to-link-module-uses-expr) + (define-values (phase-to-link-modules-trees) ',phase-to-link-module-uses-trees) + (define-values (syntax-literals) ,syntax-literals-expr) + (define-values (syntax-literals-trees) ',syntax-literals-trees)))) + +;; ---------------------------------------- + +(define (map-cim-tree cims proc) + (let loop ([cims cims]) + (for/list ([cim (in-list cims)]) + (vector (proc cim) + (loop (compiled-in-memory-pre-compiled-in-memorys cim)) + (loop (compiled-in-memory-post-compiled-in-memorys cim)))))) diff --git a/racket/src/expander/compile/multi-top.rkt b/racket/src/expander/compile/multi-top.rkt new file mode 100644 index 0000000000..23c7d5b911 --- /dev/null +++ b/racket/src/expander/compile/multi-top.rkt @@ -0,0 +1,82 @@ +#lang racket/base +(require "compiled-in-memory.rkt" + "multi-top-data.rkt" + "../host/linklet.rkt") + +(provide compiled-tops->compiled-top + compiled-top->compiled-tops) + +;; Encode a sequence of compiled top-level forms by creating a linklet +;; directory using labels |0|, |1|, etc., to map to the given linklet +;; directories. Keep all the existing compile-in-memory records as +;; "pre" records, too. +;; +;; If `merge-serialization?` is true, then merge all serialized data +;; and generate a new serialization to be used across all top-level +;; forms in the sequence, so that sharing across the top-level forms +;; is preserved. (By doing that only on request for the very +;; top of a tree, we repeat work only twice and avoid non-linear +;; behavior.) +(define (compiled-tops->compiled-top all-cims + #:to-source? [to-source? #f] + #:merge-serialization? [merge-serialization? #f] + #:namespace [ns #f]) ; need for `merge-serialization?` + (define cims (remove-nontail-purely-functional all-cims)) + (cond + [(= 1 (length cims)) + (car cims)] + [else + (define sequence-ht + (for/hasheq ([cim (in-list cims)] + [i (in-naturals)]) + (values (string->symbol (number->string i)) + ((if to-source? values compiled-in-memory-linklet-directory) + cim)))) + (define ht (if merge-serialization? + (hash-set sequence-ht + 'data + (hash->linklet-directory + (hasheq #f + (hash->linklet-bundle + (hasheq + 0 + (build-shared-data-linklet cims ns)))))) + sequence-ht)) + (cond + [to-source? ht] + [else + (compiled-in-memory (hash->linklet-directory ht) + #f ; self + #f ; requires + #f ; provides + #hasheqv() + #f + #hasheqv() + #() ; mpis + #() ; syntax-literals + cims + null + #f + #f)])])) + +;; Decode a sequence of compiled top-level forms by unpacking the +;; linklet directory into a list of linklet directories +(define (compiled-top->compiled-tops ld) + (define ht (linklet-directory->hash ld)) + (for*/list ([i (in-range (hash-count ht))] + [top (in-value (hash-ref ht (string->symbol (number->string i)) #f))] + #:when top) + top)) + +;; ---------------------------------------- + +(define (remove-nontail-purely-functional cims) + (let loop ([cims cims]) + (cond + [(null? cims) null] + [(null? (cdr cims)) cims] + [(and (compiled-in-memory? (car cims)) + (compiled-in-memory-purely-functional? (car cims))) + (loop (cdr cims))] + [else + (cons (car cims) (cdr cims))]))) diff --git a/racket/src/expander/compile/namespace-scope.rkt b/racket/src/expander/compile/namespace-scope.rkt new file mode 100644 index 0000000000..9e3b1a3fb3 --- /dev/null +++ b/racket/src/expander/compile/namespace-scope.rkt @@ -0,0 +1,67 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../common/phase.rkt" + "../namespace/namespace.rkt" + "../expand/root-expand-context.rkt") + +(provide swap-top-level-scopes + extract-namespace-scopes + encode-namespace-scopes + namespace-scopes=?) + +;; In case a syntax object in compiled top-level code is from a +;; different namespace or deserialized, swap the current namespace's +;; scope for the original namespace's scope. +;; +;; To swap a namespace scopes, we partition the namespace scopes into +;; two groups: the scope that's added after every expansion (and +;; therefore appears on every binding form), and the other scopes that +;; indicate being original to the namespace. We swap those groups +;; separately. + +(struct namespace-scopes (post other) #:prefab) + +;; Swapping function, used at run time: +(define (swap-top-level-scopes s original-scopes-s new-ns) + (define-values (old-scs-post old-scs-other) + (if (namespace-scopes? original-scopes-s) + (values (namespace-scopes-post original-scopes-s) + (namespace-scopes-other original-scopes-s)) + (decode-namespace-scopes original-scopes-s))) + (define-values (new-scs-post new-scs-other) (extract-namespace-scopes/values new-ns)) + (syntax-swap-scopes (syntax-swap-scopes s old-scs-post new-scs-post) + old-scs-other new-scs-other)) + +(define (extract-namespace-scopes/values ns) + (define root-ctx (namespace-get-root-expand-ctx ns)) + (define post-expansion-sc (root-expand-context-post-expansion-scope root-ctx)) + (values (seteq post-expansion-sc) + (set-remove (list->seteq (root-expand-context-module-scopes root-ctx)) + post-expansion-sc))) + +(define (extract-namespace-scopes ns) + (define-values (scs-post scs-other) (extract-namespace-scopes/values ns)) + (namespace-scopes scs-post scs-other)) + +;; Extract namespace scopes to a syntax object, used at compile time: +(define (encode-namespace-scopes ns) + (define-values (post-expansion-scs other-scs) (extract-namespace-scopes/values ns)) + (define post-expansion-s (add-scopes (datum->syntax #f 'post) + (set->list post-expansion-scs))) + (define other-s (add-scopes (datum->syntax #f 'other) + (set->list other-scs))) + (datum->syntax #f (vector post-expansion-s other-s))) + +;; Decoding, used at run time: +(define (decode-namespace-scopes stx) + (define vec (syntax-e stx)) + (values (syntax-scope-set (vector-ref vec 0) 0) + (syntax-scope-set (vector-ref vec 1) 0))) + +(define (namespace-scopes=? nss1 nss2) + (and (set=? (namespace-scopes-post nss1) + (namespace-scopes-post nss2)) + (set=? (namespace-scopes-other nss1) + (namespace-scopes-other nss2)))) diff --git a/racket/src/expander/compile/recompile.rkt b/racket/src/expander/compile/recompile.rkt new file mode 100644 index 0000000000..e52d0df53d --- /dev/null +++ b/racket/src/expander/compile/recompile.rkt @@ -0,0 +1,25 @@ +#lang racket/base +(require "../host/linklet.rkt" + "../eval/reflect.rkt") + +(provide compiled-expression-recompile) + +(define (compiled-expression-recompile c) + (unless (compiled-expression? c) + (raise-argument-error 'compiled-expression-recompile "compiled-expression?" c)) + (cond + [(linklet-bundle? c) + (hash->linklet-bundle + (for/hasheq ([(k v) (in-hash (linklet-bundle->hash c))]) + (cond + [(linklet? v) (values k (recompile-linklet v))] + [else (values k v)])))] + [(linklet-directory? c) + (hash->linklet-directory + (for/hasheq ([(k v) (in-hash (linklet-directory->hash c))]) + (cond + [(compiled-expression? v) + (values k (compiled-expression-recompile v))] + [else + (values k v)])))] + [else c])) diff --git a/racket/src/expander/compile/reserved-symbol.rkt b/racket/src/expander/compile/reserved-symbol.rkt new file mode 100644 index 0000000000..c4a69d8fa4 --- /dev/null +++ b/racket/src/expander/compile/reserved-symbol.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require "built-in-symbol.rkt") + +;; Identifers used in the compiler's output; we make distinct names +;; for them once to avoid shadowing of other collisions +(provide phase-shift-id + dest-phase-id + ns-id + self-id + syntax-literals-id + get-syntax-literal!-id + bulk-binding-registry-id + inspector-id + deserialize-syntax-id + deserialized-syntax-vector-id + set-transformer!-id + top-level-bind!-id + top-level-require!-id + mpi-vector-id) + +(define phase-shift-id (make-built-in-symbol! 'phase)) +(define dest-phase-id (make-built-in-symbol! 'dest-phase)) +(define ns-id (make-built-in-symbol! 'namespace)) +(define self-id (make-built-in-symbol! 'self)) +(define syntax-literals-id (make-built-in-symbol! 'syntax-literals)) +(define get-syntax-literal!-id (make-built-in-symbol! 'get-syntax-literal!)) +(define bulk-binding-registry-id (make-built-in-symbol! 'bulk-binding-registry)) +(define inspector-id (make-built-in-symbol! 'inspector)) +(define deserialize-syntax-id (make-built-in-symbol! 'deserialize-syntax)) +(define deserialized-syntax-vector-id (make-built-in-symbol! 'deserialized-syntax-vector)) +(define set-transformer!-id (make-built-in-symbol! 'set-transformer!)) +(define top-level-bind!-id (make-built-in-symbol! 'top-level-bind!)) +(define top-level-require!-id (make-built-in-symbol! 'top-level-require!)) +(define mpi-vector-id (make-built-in-symbol! 'mpi-vector)) diff --git a/racket/src/expander/compile/self-quoting.rkt b/racket/src/expander/compile/self-quoting.rkt new file mode 100644 index 0000000000..0b3be60e9a --- /dev/null +++ b/racket/src/expander/compile/self-quoting.rkt @@ -0,0 +1,6 @@ +#lang racket/base + +(provide self-quoting-in-linklet?) + +(define (self-quoting-in-linklet? datum) + (or (number? datum) (boolean? datum) (string? datum) (bytes? datum))) diff --git a/racket/src/expander/compile/serialize-property.rkt b/racket/src/expander/compile/serialize-property.rkt new file mode 100644 index 0000000000..ccf66631f7 --- /dev/null +++ b/racket/src/expander/compile/serialize-property.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +;; Structures that support serialization (e.g., syntax objects) +;; implement the `prop:serialize` property, and so on. + +(provide prop:serialize + serialize? + serialize-ref + + prop:serialize-fill! + serialize-fill!? + serialize-fill!-ref + + prop:reach-scopes + reach-scopes? + reach-scopes-ref + + prop:scope-with-bindings + scope-with-bindings? + scope-with-bindings-ref + + prop:binding-reach-scopes + binding-reach-scopes? + binding-reach-scopes-ref) + +(define-values (prop:serialize serialize? serialize-ref) + (make-struct-type-property 'serialize)) + +;; For values with mutable fields, so that cycles can be reconstructed +(define-values (prop:serialize-fill! serialize-fill!? serialize-fill!-ref) + (make-struct-type-property 'serialize-fill!)) + +;; A property for a value that contains references to scopes, so that +;; all reachable scopes can be found +(define-values (prop:reach-scopes reach-scopes? reach-scopes-ref) + (make-struct-type-property 'reach-scopes)) + +;; A property for scopes, used when detecting reachable scopes; +;; a scope has bindings that conditionally reach additional scopes +(define-values (prop:scope-with-bindings scope-with-bindings? scope-with-bindings-ref) + (make-struct-type-property 'scope-with-bindings)) + +;; Like `prop:reach-scopes`, but return a single value; used for bindings: +(define-values (prop:binding-reach-scopes binding-reach-scopes? binding-reach-scopes-ref) + (make-struct-type-property 'binding-reach-scopes)) diff --git a/racket/src/expander/compile/serialize-state.rkt b/racket/src/expander/compile/serialize-state.rkt new file mode 100644 index 0000000000..13b5fda418 --- /dev/null +++ b/racket/src/expander/compile/serialize-state.rkt @@ -0,0 +1,113 @@ +#lang racket/base + +(provide (struct-out serialize-state) + make-serialize-state + + intern-scopes + intern-shifted-multi-scopes + intern-mpi-shifts + intern-context-triple + intern-properties + + push-syntax-context! + get-syntax-context + pop-syntax-context!) + +;; A `serialize-state` record is threaded through the construction of +;; a deserialization expression + +(struct serialize-state (reachable-scopes ; the set of all reachable scopes + bindings-intern ; to record pruned binding tables + bulk-bindings-intern ; to record pruned bulk-binding lists + scopes ; interned scope sets + shifted-multi-scopes ; interned shifted multi-scope lists + mpi-shifts ; interned module path index shifts + context-triples ; combinations of the previous three + props ; map full props to previously calculated + interned-props ; intern filtered props + syntax-context ; used to collapse encoding of syntax literals + sharing-syntaxes)) ; record which syntax objects are `datum->syntax` form + +(define (make-serialize-state reachable-scopes) + (serialize-state reachable-scopes + (make-hasheq) ; bindings-intern + (make-hasheq) ; bulk-bindings-intern + (make-hash) ; scopes + (make-hash) ; shifted-multi-scopes + (make-hasheq) ; mpi-shifts + (make-hasheq) ; context-triples + (make-hasheq) ; props + (make-hash) ; interned-props + (box null) ; syntax-context + (make-hasheq))) ; sharing-syntaxes + +(define (intern-scopes scs state) + (or (hash-ref (serialize-state-scopes state) scs #f) + (begin + (hash-set! (serialize-state-scopes state) scs scs) + scs))) + +(define (intern-shifted-multi-scopes sms state) + (or (hash-ref (serialize-state-shifted-multi-scopes state) sms #f) + (begin + (hash-set! (serialize-state-shifted-multi-scopes state) sms sms) + sms))) + +(define (intern-mpi-shifts mpi-shifts state) + (cond + [(null? mpi-shifts) null] + [else + (define tail (intern-mpi-shifts (cdr mpi-shifts) state)) + (define tail-table (or (hash-ref (serialize-state-mpi-shifts state) tail #f) + (let ([ht (make-hasheq)]) + (hash-set! (serialize-state-mpi-shifts state) tail ht) + ht))) + (or (hash-ref tail-table (car mpi-shifts) #f) + (let ([v (cons (car mpi-shifts) tail)]) + (hash-set! tail-table (car mpi-shifts) v) + v))])) + +(define (intern-context-triple scs sms mpi-shifts state) + (define scs-ht (or (hash-ref (serialize-state-context-triples state) scs #f) + (let ([ht (make-hasheq)]) + (hash-set! (serialize-state-context-triples state) scs ht) + ht))) + (define sms-ht (or (hash-ref scs-ht sms #f) + (let ([ht (make-hasheq)]) + (hash-set! scs-ht sms ht) + ht))) + (or (hash-ref sms-ht mpi-shifts #f) + (let ([vec (vector-immutable scs sms mpi-shifts)]) + (hash-set! sms-ht mpi-shifts vec) + vec))) + +(define (intern-properties all-props get-preserved-props state) + (define v (hash-ref (serialize-state-props state) all-props 'no)) + (cond + [(eq? v 'no) + (define preserved-props (get-preserved-props)) + (define p + (cond + [(zero? (hash-count preserved-props)) #f] + [(hash-ref (serialize-state-interned-props state) preserved-props #f) + => (lambda (p) p)] + [else + (hash-set! (serialize-state-interned-props state) preserved-props preserved-props) + preserved-props])) + (hash-set! (serialize-state-props state) all-props p) + p] + [else v])) + +(define (push-syntax-context! state v) + (define b (serialize-state-syntax-context state)) + (set-box! b (cons v (unbox b)))) + +(define (get-syntax-context state) + (define b (serialize-state-syntax-context state)) + (if (null? (unbox b)) + #f + (car (unbox b)))) + +(define (pop-syntax-context! state) + (define b (serialize-state-syntax-context state)) + (set-box! b (cdr (unbox b)))) diff --git a/racket/src/expander/compile/serialize.rkt b/racket/src/expander/compile/serialize.rkt new file mode 100644 index 0000000000..0ca1002ac7 --- /dev/null +++ b/racket/src/expander/compile/serialize.rkt @@ -0,0 +1,893 @@ +#lang racket/base +(require (for-syntax racket/base) + "serialize-property.rkt" + "serialize-state.rkt" + "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/binding-table.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/module-binding.rkt" + "../syntax/local-binding.rkt" + "../syntax/bulk-binding.rkt" + "../namespace/provided.rkt" + "../common/module-path.rkt" + "../common/module-path-intern.rkt" + "module-use.rkt" + "../host/linklet.rkt" + "built-in-symbol.rkt" + "reserved-symbol.rkt" + "vector-ref.rkt") + +;; Serializaiton is mostly for syntax object and module path indexes. +;; +;; Serialization is implemented by a combination of direct handling +;; for some primitive datatypes, `prop:serialize` handlers attached +;; to some structure types, and deserialization functions provided +;; by the same modules as the serialization handlers. +;; +;; Module path indexes are serialized to code that runs to reconstruct +;; the module path indexes. Syntax objects and other data is +;; serialized to somewhat expression-shaped data and interpreted for +;; deserialization, where that interpretation can refer to an array of +;; already-deserialized module path indexes. +;; +;; To support sharing and cycles, serialized data is represented by: +;; +;; - a vector of "shell" descriptions to allocate mutatable objects, +;; such as mutable vectors and hash tables; +;; +;; - a vector of initializations for shared, immutable values (which +;; can refer to mutable values) +;; +;; - a vector of "fill" descriptions to complete the construction of +;; mutable values (whcih can refer to mutable and shared values); +;; and +;; +;; - a final value construction (which can refer to shared and +;; mutable values). +;; +;; In general, a deserialized object is represented as a pair of a +;; symbol tag and data, including a `quote` tag to represent arbitrary +;; quoted data (that's non-cyclic and with no internal sharing). A few +;; special cases enable a more compact representation: +;; +;; - numbers, booleans, and symbols are represented as themselves +;; (i.e., self-quoting, in a sense); +;; +;; - #& is a reference to a mutable or shared value at +;; position in a deserialization array; +;; +;; - #( ...) is a `srcloc` +;; +;; - #:inspector and #:bulk-binding-registry refer to +;; instantiation-time values supplied as imported to the +;; deserializing linklet +;; +;; In addition to all the complexities of detecting sharing and cycles +;; and breaking cycles on mutable boundaries, the serialization +;; process also prunes unreachable scopes and interns some values that +;; formerly were not shared. + +(provide make-module-path-index-table + add-module-path-index! + add-module-path-index!/pos + generate-module-path-index-deserialize + mpis-as-vector + + generate-deserialize + + deserialize-instance + deserialize-imports + + serialize-module-uses + serialize-phase-to-link-module-uses) + +;; ---------------------------------------- +;; Module path index serialization + +(struct module-path-index-table (positions intern)) + +(define (make-module-path-index-table) + (module-path-index-table (make-hasheq) ; module-path-index -> pos + (make-module-path-index-intern-table))) + +(define (add-module-path-index! mpis mpi) + (define pos + (add-module-path-index!/pos mpis mpi)) + (and pos + `(,unsafe-vector-ref-id ,mpi-vector-id ,pos))) + +(define (add-module-path-index!/pos mpis mpi) + (cond + [(not mpi) #f] + [mpi + (let ([mpi (intern-module-path-index! (module-path-index-table-intern mpis) mpi)] + [positions (module-path-index-table-positions mpis)]) + (or (hash-ref positions mpi #f) + (let ([pos (hash-count positions)]) + (hash-set! positions mpi pos) + pos)))])) + +(define (generate-module-path-index-deserialize mpis) + (define positions (module-path-index-table-positions mpis)) + (define gen-order (make-hasheqv)) + (define rev-positions + (for/hasheqv ([(k v) (in-hash positions)]) + (values v k))) + ;; Create mpis used earlier first: + (for ([i (in-range (hash-count rev-positions))]) + (define mpi (hash-ref rev-positions i)) + (let loop ([mpi mpi]) + (unless (hash-ref gen-order mpi #f) + (define-values (name base) (module-path-index-split mpi)) + (when base + (loop base)) + (hash-set! gen-order mpi (hash-count gen-order))))) + (define rev-gen-order + (for/hasheqv ([(k v) (in-hash gen-order)]) + (values v k))) + (define gens + (for/vector #:length (hash-count gen-order) ([i (in-range (hash-count gen-order))]) + (define mpi (hash-ref rev-gen-order i)) + (define-values (path base) (module-path-index-split mpi)) + (cond + [(top-level-module-path-index? mpi) + 'top] + [(not path) + (box (or (resolved-module-path-name + (module-path-index-resolved mpi)) + 'self))] + [(not base) + (vector path)] + [base + (vector path (hash-ref gen-order base))]))) + `(deserialize-module-path-indexes + ;; Vector of deserialization instructions, where earlier + ;; must be constructed first: + ',gens + ;; Vector of reordering to match reference order: + ',(for/vector ([i (in-range (hash-count rev-positions))]) + (hash-ref gen-order (hash-ref rev-positions i))))) + +(define (deserialize-module-path-indexes gen-vec order-vec) + (define gen (make-vector (vector-length gen-vec) #f)) + (for ([d (in-vector gen-vec)] + [i (in-naturals)]) + (vector-set! + gen + i + (cond + [(eq? d 'top) (deserialize-module-path-index)] + [(box? d) (deserialize-module-path-index (unbox d))] + [else + (deserialize-module-path-index (vector*-ref d 0) + (and ((vector*-length d) . > . 1) + (vector*-ref gen (vector*-ref d 1))))]))) + (for/vector #:length (vector-length order-vec) ([p (in-vector order-vec)]) + (vector*-ref gen p))) + +(define (mpis-as-vector mpis) + (define positions (module-path-index-table-positions mpis)) + (define vec (make-vector (hash-count positions) #f)) + (for ([(mpi pos) (in-hash positions)]) + (vector-set! vec pos mpi)) + vec) + +;; Convert `let*` into chunks of `let` as much as possible +(define (make-let* bindings body) + (let loop ([vars #hasheq()] [group null] [bindings bindings]) + (cond + [(null? bindings) `(let-values ,(reverse group) ,body)] + [(has-symbol? (cadar bindings) vars) + `(let-values ,(reverse group) ,(loop #hasheq() null bindings))] + [else + (loop (hash-set vars (caaar bindings) #t) + (cons (car bindings) group) + (cdr bindings))]))) + +(define (has-symbol? d vars) + (or (and (symbol? d) (hash-ref vars d #f)) + (and (pair? d) + (or (has-symbol? (car d) vars) + (has-symbol? (cdr d) vars))))) + +;; ---------------------------------------- +;; Module-use serialization --- as an expression, like module path +;; indexes, and unlike everything else + +(define (serialize-module-uses mus mpis) + (for/list ([mu (in-list mus)]) + `(module-use + ,(add-module-path-index! mpis (module-use-module mu)) + ,(module-use-phase mu)))) + +(define (interned-literal? v) + (or (null? v) + (boolean? v) + (and (fixnum? v) + (v . < . (sub1 (expt 2 30))) + (v . > . (- (expt 2 30)))) + (symbol? v) + (char? v) + (keyword? v))) + +(define (serialize-phase-to-link-module-uses phase-to-link-module-uses mpis) + (define phases-in-order (sort (hash-keys phase-to-link-module-uses) <)) + `(hasheqv ,@(apply + append + (for/list ([phase (in-list phases-in-order)]) + (list phase `(list ,@(serialize-module-uses (hash-ref phase-to-link-module-uses phase) + mpis))))))) + +;; ---------------------------------------- +;; Serialization for everything else + +(define (generate-deserialize v mpis #:syntax-support? [syntax-support? #t]) + (define reachable-scopes (find-reachable-scopes v)) + + (define state (make-serialize-state reachable-scopes)) + + (define mutables (make-hasheq)) ; v -> pos + (define objs (make-hasheq)) ; v -> step + (define shares (make-hasheq)) ; v -> #t + (define obj-step 0) + + ;; Build table of sharing and mutable values + (define frontier null) + (define add-frontier! + (case-lambda + [(v) (set! frontier (cons v frontier))] + [(kind v) (add-frontier! v)])) + (let frontier-loop ([v v]) + (let loop ([v v]) + (cond + [(or (interned-literal? v) + (module-path-index? v)) + ;; no need to find sharing + (void)] + [(hash-ref objs v #f) + (unless (hash-ref mutables v #f) + (hash-set! shares v #t))] + [else + (cond + [(serialize-fill!? v) + ;; Assume no sharing in non-mutable part + (hash-set! mutables v (hash-count mutables)) + ((serialize-fill!-ref v) v add-frontier! state)] + [(serialize? v) + ((serialize-ref v) v + (case-lambda + [(sub-v) (loop sub-v)] + [(kind sub-v) (loop sub-v)]) + state)] + [(pair? v) + (loop (car v)) + (loop (cdr v))] + [(vector? v) + (if (or (immutable? v) + (zero? (vector-length v))) + (for ([e (in-vector v)]) + (loop e)) + (begin + (hash-set! mutables v (hash-count mutables)) + (for ([e (in-vector v)]) + (add-frontier! e))))] + [(box? v) + (if (immutable? v) + (loop (unbox v)) + (begin + (hash-set! mutables v (hash-count mutables)) + (add-frontier! (unbox v))))] + [(hash? v) + (if (immutable? v) + (for ([k (in-list (sorted-hash-keys v))]) + (loop k) + (loop (hash-ref v k))) + (begin + (hash-set! mutables v (hash-count mutables)) + (for ([k (in-list (sorted-hash-keys v))]) + (add-frontier! k) + (add-frontier! (hash-ref v k)))))] + [(prefab-struct-key v) + (for ([e (in-vector (struct->vector v) 1)]) + (loop e))] + [(srcloc? v) + (for ([e (in-vector (struct->vector v) 1)]) + (loop e))] + [else + (void)]) + ;; `v` may already be in `objs`, but to get the order right + ;; for unmarshaling, we need to map it to ka new step number + (hash-set! objs v obj-step) + (set! obj-step (add1 obj-step))])) + (unless (null? frontier) + (define l frontier) + (set! frontier null) + (for ([v (in-list l)]) + (frontier-loop v)))) + + ;; Maybe object steps to positions in a vector after mutables + (define num-mutables (hash-count mutables)) + (define share-step-positions + (let ([share-steps (for/list ([obj (in-hash-keys shares)]) + (hash-ref objs obj))]) + (for/hasheqv ([step (in-list (sort share-steps <))] + [pos (in-naturals num-mutables)]) + (values step pos)))) + + ;; Accumulate the serialized stream: + (define stream null) + (define stream-size 0) + + (define (next-push-position) stream-size) + + (define (quoted? pos) + (define v (list-ref stream (- stream-size (add1 pos)))) + (or (not (keyword? v)) + (eq? '#:quote v))) + + (define (ser-reset! pos) + (set! stream (list-tail stream (- stream-size pos))) + (set! stream-size pos)) + + (define (reap-stream!) + (begin0 + (list->vector (reverse stream)) + (set! stream null) + (set! stream-size 0))) + + ;; Handle a reference to an object that may be shared + ;; or mutable + (define ser-push! + (case-lambda + [(v) + (cond + [(hash-ref shares v #f) + (define n (hash-ref share-step-positions (hash-ref objs v))) + (ser-push! 'tag '#:ref) + (ser-push! 'exact n)] + [(hash-ref mutables v #f) + => (lambda (n) + (ser-push! 'tag '#:ref) + (ser-push! 'exact n))] + [else (ser-push-encoded! v)])] + [(kind v) + (case kind + [(exact) + (set! stream (cons v stream)) + (set! stream-size (add1 stream-size))] + [(tag) + (ser-push! 'exact v)] + [(reference) + (cond + [(hash-ref shares v #f) + (define n (hash-ref share-step-positions (hash-ref objs v))) + (ser-push! 'exact n)] + [(hash-ref mutables v #f) + => (lambda (n) + (ser-push! 'exact n))] + [else + (ser-push! v)])] + [else (ser-push! v)])])) + + ;; Handle an immutable, not-shared (or on RHS of binding) value + (define (ser-push-encoded! v) + (cond + [(keyword? v) + (ser-push! 'tag '#:quote) + (ser-push! 'exact v)] + [(module-path-index? v) + (ser-push! 'tag '#:mpi) + (ser-push! 'exact (add-module-path-index!/pos mpis v))] + [(serialize? v) + ((serialize-ref v) v ser-push! state)] + [(and (list? v) + (pair? v) + (pair? (cdr v))) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:list) + (ser-push! 'exact (length v)) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([i (in-list v)]) + (define i-pos (next-push-position)) + (ser-push! i) + (and all-quoted? + (quoted? i-pos)))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(pair? v) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:cons) + (define a-pos (next-push-position)) + (ser-push! (car v)) + (define d-pos (next-push-position)) + (ser-push! (cdr v)) + (when (and (quoted? a-pos) (quoted? d-pos)) + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(box? v) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:box) + (define v-pos (next-push-position)) + (ser-push! (unbox v)) + (when (quoted? v-pos) + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(vector? v) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:vector) + (ser-push! 'exact (vector-length v)) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([i (in-vector v)]) + (define i-pos (next-push-position)) + (ser-push! i) + (and all-quoted? + (quoted? i-pos)))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(hash? v) + (define start-pos (next-push-position)) + (define as-set? (for/and ([val (in-hash-values v)]) + (eq? val #t))) + (ser-push! 'tag (if as-set? + (cond + [(hash-eq? v) '#:seteq] + [(hash-eqv? v) '#:seteqv] + [else '#:set]) + (cond + [(hash-eq? v) '#:hasheq] + [(hash-eqv? v) '#:hasheqv] + [else '#:hash]))) + (ser-push! 'exact (hash-count v)) + (define ks (sorted-hash-keys v)) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([k (in-list ks)]) + (define k-pos (next-push-position)) + (ser-push! k) + (define v-pos (next-push-position)) + (unless as-set? + (ser-push! (hash-ref v k))) + (and all-quoted? + (quoted? k-pos) + (or as-set? (quoted? v-pos))))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v))] + [(prefab-struct-key v) + => (lambda (k) + (define vec (struct->vector v)) + (define start-pos (next-push-position)) + (ser-push! 'tag '#:prefab) + (ser-push! 'exact k) + (ser-push! 'exact (sub1 (vector-length vec))) + (define all-quoted? + (for/fold ([all-quoted? #t]) ([i (in-vector vec 1)]) + (define i-pos (next-push-position)) + (ser-push! i) + (and all-quoted? + (quoted? i-pos)))) + (when all-quoted? + (ser-reset! start-pos) + (ser-push-optional-quote!) + (ser-push! 'exact v)))] + [(srcloc? v) + (ser-push! 'tag '#:srcloc) + (ser-push! (srcloc-source v)) + (ser-push! (srcloc-line v)) + (ser-push! (srcloc-column v)) + (ser-push! (srcloc-position v)) + (ser-push! (srcloc-span v))] + [else + (ser-push-optional-quote!) + (ser-push! 'exact v)])) + + ;; A no-op, but can be made to push '#:quote as a debugging aid + (define (ser-push-optional-quote!) + ;; (ser-push! 'tag '#:quote) + (void)) + + ;; Generate the shell of a mutable value --- uses a different + ;; encoding then the one for most other purposes + (define (ser-shell! v) + (cond + [(serialize-fill!? v) ((serialize-ref v) v ser-push! state)] + [(box? v) (ser-push! 'tag '#:box)] + [(vector? v) + (ser-push! 'tag '#:vector) + (ser-push! 'exact (vector-length v))] + [(hash? v) (ser-push! 'tag (cond + [(hash-eq? v) '#:hasheq] + [(hash-eqv? v) '#:hasheqv] + [else '#:hash]))] + [else + (error 'ser-shell "unknown mutable: ~e" v)])) + + ;; Fill in the content of a mutable shell --- also a different + ;; encoding + (define (ser-shell-fill! v) + (cond + [(serialize-fill!? v) ((serialize-fill!-ref v) v ser-push! state)] + [(box? v) + (ser-push! 'tag '#:set-box!) + (ser-push! (unbox v))] + [(vector? v) + (ser-push! 'tag '#:set-vector!) + (ser-push! 'exact (vector-length v)) + (for ([v (in-vector v)]) + (ser-push! v))] + [(hash? v) + (ser-push! 'tag '#:set-hash!) + (ser-push! 'exact (hash-count v)) + (define ks (sorted-hash-keys v)) + (for ([k (in-list ks)]) + (ser-push! k) + (ser-push! (hash-ref v k)))] + [else + (error 'ser-shell-fill "unknown mutable: ~e" v)])) + + ;; Prepare mutable shells, first: + (define rev-mutables (for/hasheqv ([(k v) (in-hash mutables)]) + (values v k))) + (define mutable-shell-bindings + (begin + (for ([i (in-range (hash-count mutables))]) + (ser-shell! (hash-ref rev-mutables i))) + (reap-stream!))) + + ;; Prepare shared values: + (define rev-shares (for/hasheqv ([obj (in-hash-keys shares)]) + (values (hash-ref share-step-positions (hash-ref objs obj)) + obj))) + (define shared-bindings + (begin + (for ([i (in-range num-mutables (+ num-mutables (hash-count shares)))]) + (ser-push-encoded! (hash-ref rev-shares i))) + (reap-stream!))) + + ;; Fill in mutable values + (define mutable-fills + (begin + (for ([i (in-range (hash-count mutables))]) + (ser-shell-fill! (hash-ref rev-mutables i))) + (reap-stream!))) + + ;; Put it all together: + `(deserialize + ,mpi-vector-id + ,(if syntax-support? inspector-id #f) + ,(if syntax-support? bulk-binding-registry-id #f) + ',(hash-count mutables) + ',mutable-shell-bindings + ',(hash-count shares) + ',shared-bindings + ',mutable-fills + ',(begin + (ser-push! v) + (reap-stream!)))) + +(define (sorted-hash-keys ht) + (define ks (hash-keys ht)) + (cond + [(null? ks) ks] + [(null? (cdr ks)) ks] + [(andmap symbol? ks) + (sort ks symbolsyntax) + (decodes + (content [#:ref context] [#:ref srcloc]) + (deserialize-datum->syntax content + context + srcloc + inspector))] + [(#:syntax+props) + (decodes + (content [#:ref context] [#:ref srcloc] props tamper) + (deserialize-syntax content + context + srcloc + props + tamper + inspector))] + [(#:srcloc) + (decode* (srcloc source line column position span))] + [(#:quote) + (values (vector*-ref vec (add1 pos)) (+ pos 2))] + [(#:mpi) + (values (vector*-ref mpis (vector*-ref vec (add1 pos))) + (+ pos 2))] + [(#:box) + (decode* (box-immutable v))] + [(#:cons) + (decode* (cons a d))] + [(#:list #:vector) + (define len (vector*-ref vec (add1 pos))) + (define r (make-vector len)) + (define next-pos + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (v next-pos) (decodes #:pos pos (v) v)) + (vector-set! r i v) + next-pos)) + (values (if (eq? (vector*-ref vec pos) '#:list) + (vector->list r) + (vector->immutable-vector r)) + next-pos)] + [(#:hash #:hasheq #:hasheqv) + (define ht (case (vector*-ref vec pos) + [(#:hash) (hash)] + [(#:hasheq) (hasheq)] + [(#:hasheqv) (hasheqv)])) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([ht ht] [pos (+ pos 2)]) ([i (in-range len)]) + (decodes #:pos pos (k v) (hash-set ht k v)))] + [(#:set #:seteq #:seteqv) + (define s (case (vector*-ref vec pos) + [(#:set) (set)] + [(#:seteq) (seteq)] + [(#:seteqv) (seteqv)])) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([s s] [pos (+ pos 2)]) ([i (in-range len)]) + (decodes #:pos pos (k) (set-add s k)))] + [(#:prefab) + (define-values (key next-pos) (decodes #:pos (add1 pos) (k) k)) + (define len (vector*-ref vec next-pos)) + (define-values (r done-pos) + (for/fold ([r null] [pos (add1 next-pos)]) ([i (in-range len)]) + (decodes #:pos pos (v) (cons v r)))) + (values (apply make-prefab-struct key (reverse r)) + done-pos)] + [(#:scope) + (decode* (deserialize-scope))] + [(#:scope+kind) + (decode* (deserialize-scope kind))] + [(#:multi-scope) + (decode* (deserialize-multi-scope name scopes))] + [(#:shifted-multi-scope) + (decode* (deserialize-shifted-multi-scope phase multi-scope))] + [(#:table-with-bulk-bindings) + (decode* (deserialize-table-with-bulk-bindings syms bulk-bindings))] + [(#:bulk-binding-at) + (decode* (deserialize-bulk-binding-at scopes bulk))] + [(#:representative-scope) + (decode* (deserialize-representative-scope kind phase))] + [(#:module-binding) + (decode* (deserialize-full-module-binding + module sym phase + nominal-module + nominal-phase + nominal-sym + nominal-require-phase + free=id + extra-inspector + extra-nominal-bindings))] + [(#:simple-module-binding) + (decode* (deserialize-simple-module-binding module sym phase nominal-module))] + [(#:local-binding) + (decode* (deserialize-full-local-binding key free=id))] + [(#:bulk-binding) + (decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))] + [(#:provided) + (decode* (deserialize-provided binding protected? syntax?))] + [else + (values (vector*-ref vec pos) (add1 pos))])) + +;; Decode the filling of mutable values, which has its own encoding +;; variant +(define (decode-fill! v vec pos mpis inspector bulk-binding-registry shared) + (case (vector*-ref vec pos) + [(#f) (add1 pos)] + [(#:set-box!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (set-box! v c) + next-pos] + [(#:set-vector!) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (c next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (vector-set! v i c) + next-pos)] + [(#:set-hash!) + (define len (vector*-ref vec (add1 pos))) + (for/fold ([pos (+ pos 2)]) ([i (in-range len)]) + (define-values (key next-pos) + (decode vec pos mpis inspector bulk-binding-registry shared)) + (define-values (val done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (hash-set! v key val) + done-pos)] + [(#:scope-fill!) + (define-values (c next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (deserialize-scope-fill! v c) + next-pos] + [(#:representative-scope-fill!) + (define-values (a next-pos) + (decode vec (add1 pos) mpis inspector bulk-binding-registry shared)) + (define-values (d done-pos) + (decode vec next-pos mpis inspector bulk-binding-registry shared)) + (deserialize-representative-scope-fill! v a d) + done-pos] + [else + (error 'deserialize "bad fill encoding: ~v" (vector*-ref vec pos))])) + +;; ---------------------------------------- +;; For pruning unreachable scopes in serialization + +(define (find-reachable-scopes v) + (define seen (make-hasheq)) + (define reachable-scopes (seteq)) + (define scope-triggers (make-hasheq)) + + (let loop ([v v]) + (cond + [(interned-literal? v) (void)] + [(hash-ref seen v #f) (void)] + [else + (hash-set! seen v #t) + (cond + [(scope-with-bindings? v) + (set! reachable-scopes (set-add reachable-scopes v)) + + ((reach-scopes-ref v) v loop) + + (define l (hash-ref scope-triggers v null)) + (for ([v (in-list l)]) + (loop v)) + + ;; A binding may have a `free-id=?` equivalence; + ;; that equivalence is reachable if all the scopes in the + ;; binding set are reachable; for a so-far unreachable scope, + ;; record a trigger in case the scope bcomes reachable later + ((scope-with-bindings-ref v) + v + reachable-scopes + loop + (lambda (sc-unreachable b) + (hash-update! scope-triggers + sc-unreachable + (lambda (l) (cons b l)) + null)))] + [(reach-scopes? v) + ((reach-scopes-ref v) v loop)] + [(pair? v) + (loop (car v)) + (loop (cdr v))] + [(vector? v) + (for ([e (in-vector v)]) + (loop e))] + [(box? v) + (loop (unbox v))] + [(hash? v) + (for ([(k v) (in-hash v)]) + (loop k) + (loop v))] + [(prefab-struct-key v) + (for ([e (in-vector (struct->vector v) 1)]) + (loop e))] + [(srcloc? v) + (loop (srcloc-source v))] + [else + (void)])])) + + reachable-scopes) + +;; ---------------------------------------- +;; Set up the instance to import into deserializing linklets + +(define deserialize-imports + '(deserialize-module-path-indexes + syntax-module-path-index-shift + syntax-shift-phase-level + module-use + deserialize)) + +;; To avoid a higher-order use of a keyword-accepting function: +(define syntax-module-path-index-shift/no-keywords + (let ([syntax-module-path-index-shift + (lambda (s from-mpi to-mpi [inspector #f]) + (syntax-module-path-index-shift s from-mpi to-mpi inspector))]) + syntax-module-path-index-shift)) + +(define deserialize-instance + (make-instance 'deserialize #f 'constant + 'deserialize-module-path-indexes deserialize-module-path-indexes + 'syntax-module-path-index-shift syntax-module-path-index-shift/no-keywords + 'syntax-shift-phase-level syntax-shift-phase-level + 'module-use module-use + 'deserialize deserialize)) diff --git a/racket/src/expander/compile/side-effect.rkt b/racket/src/expander/compile/side-effect.rkt new file mode 100644 index 0000000000..3671d9ad4d --- /dev/null +++ b/racket/src/expander/compile/side-effect.rkt @@ -0,0 +1,456 @@ +#lang racket/base +(require "../common/set.rkt" + "built-in-symbol.rkt" + "self-quoting.rkt" + "known.rkt" + "../host/correlate.rkt") + +;; To support extraction of a bootstrapped version of the expander, we +;; need to be able to prune unused module content. Pruning is usefully +;; improved by a simple analysis of whether a module body has any +;; side-effects. + +;; See "known.rkt" for classifications of definitions and locals + +(provide any-side-effects?) + +(define (any-side-effects? e ; compiled expression + expected-results ; number of expected results, or #f if any number is ok + #:known-locals [locals #hasheq()] ; known local-variable bindings + #:known-defns [defns #hasheq()] ; other variables to known-value information + #:ready-variable? [ready-variable? (lambda (id) #f)]) ; other variables known to be ready + (define (effects? e expected-results locals) + (any-side-effects? e expected-results + #:known-locals locals + #:known-defns defns + #:ready-variable? ready-variable?)) + (define actual-results + (let loop ([e e] [locals locals]) + (case (and (pair? (correlated-e e)) + (correlated-e (car (correlated-e e)))) + [(quote lambda case-lambda #%variable-reference) 1] + [(letrec-values let-values) + (define-correlated-match m e '(_ ([ids rhs] ...) body)) + (and (not (for/or ([ids (in-list (m 'ids))] + [rhs (in-list (m 'rhs))]) + (effects? rhs (correlated-length ids) locals))) + (loop (m 'body) (add-binding-info locals (m 'ids) (m 'rhs))))] + [(values) + (define-correlated-match m e '(_ e ...)) + (and (for/and ([e (in-list (m 'e))]) + (not (effects? e 1 locals))) + (length (m 'e)))] + [(void) + (define-correlated-match m e '(_ e ...)) + (and (for/and ([e (in-list (m 'e))]) + (not (effects? e 1 locals))) + 1)] + [(begin) + (define-correlated-match m e '(_ e ...)) + (let bloop ([es (m 'e)]) + (cond + [(null? es) #f] + [(null? (cdr es)) (loop (car es) locals)] + [else (and (not (effects? (car es) #f locals)) + (bloop (cdr es)))]))] + [(begin0) + (define-correlated-match m e '(_ e0 e ...)) + (and (for/and ([e (in-list (m 'e))]) + (not (effects? e #f locals))) + (loop (m 'e0) locals))] + [(make-struct-type) + (and (ok-make-struct-type? e ready-variable? defns) + 5)] + [(make-struct-field-accessor) + (and (ok-make-struct-field-accessor/mutator? e locals 'general-accessor defns) + 1)] + [(make-struct-field-mutator) + (and (ok-make-struct-field-accessor/mutator? e locals 'general-mutator defns) + 1)] + [(make-struct-type-property) + (and (ok-make-struct-type-property? e defns) + 3)] + [(if) + (define-correlated-match m e #:try '(_ (id:rator id:arg) thn els)) + (cond + [(m) + (cond + [(or (hash-ref locals (m 'id:rator) #f) + (lookup-defn defns (m 'id:rator))) + => (lambda (d) + (and (known-predicate? d) + (not (effects? (m 'thn) + expected-results + (hash-set locals (m 'id:arg) + (known-satisfies (known-predicate-key d))))) + (loop (m 'els) locals)))] + [else #f])] + [else + (define-correlated-match m e #:try '(_ tst thn els)) + (and (m) + (not (effects? (m 'tst) 1 locals)) + (not (effects? (m 'thn) expected-results locals)) + (loop (m 'els) locals))])] + [else + (define v (correlated-e e)) + (cond + [(or (string? v) (number? v) (boolean? v) (char? v)) + 1] ;; unquoted vals + [(and (pair? v) + (let ([rator (correlated-e (car v))]) + (or (hash-ref locals rator #f) + (lookup-defn defns rator)))) + => + (lambda (d) + (define-correlated-match m e '(_ e ...)) + (define n-args (length (m 'e))) + (and (or (and (or (and (known-struct-op? d) + (eq? 'constructor (known-struct-op-type d)) + (= (known-struct-op-field-count d) n-args)) + (and (known-function? d) + (known-function-pure? d) + (arity-includes? (known-function-arity d) n-args))) + (for/and ([e (in-list (m 'e))]) + (not (effects? e 1 locals)))) + (and (known-function-of-satisfying? d) + (= n-args (length (known-function-of-satisfying-arg-predicate-keys d))) + (for/and ([e (in-list (m 'e))] + [key (in-list (known-function-of-satisfying-arg-predicate-keys d))]) + (and (not (effects? e 1 locals)) + (satisfies? e key defns locals))))) + 1))] + [else + (and + (or (self-quoting-in-linklet? v) + (and (symbol? v) + (or (hash-ref locals v #f) + (lookup-defn defns v) + (built-in-symbol? v) + (ready-variable? v)))) + 1)])]))) + (not (and actual-results + (or (not expected-results) + (= actual-results expected-results))))) + +(define (satisfies? e key defns locals) + (define d (or (hash-ref locals e #f) + (lookup-defn defns e))) + (and d + (known-satisfies? d) + (eq? key (known-satisfies-predicate-key d)))) + +;; ---------------------------------------- + +(define (add-binding-info locals idss rhss) + (for/fold ([locals locals]) ([ids (in-list idss)] + [rhs (in-list rhss)]) + (let loop ([rhs rhs]) + (case (and (pair? (correlated-e rhs)) + (correlated-e (car (correlated-e rhs)))) + [(make-struct-type) + ;; Record result "types" + (define field-count (extract-struct-field-count-lower-bound rhs)) + (for/fold ([locals locals]) ([id (in-list (correlated->list ids))] + [type (in-list '(struct-type + constructor + predicate + general-accessor + general-mutator))]) + (hash-set locals (correlated-e id) (known-struct-op type field-count)))] + [(let-values) + (if (null? (correlated-e (correlated-cadr rhs))) + (loop (caddr (correlated->list rhs))) + (loop #f))] + [else + (for/fold ([locals locals]) ([id (in-list (correlated->list ids))]) + (hash-set locals (correlated-e id) #t))])))) + +;; ---------------------------------------- + +(define (ok-make-struct-type-property? e defns) + (define l (correlated->list e)) + (and (<= 2 (length l) 5) + (for/and ([arg (in-list (cdr l))] + [pred (in-list + (list + (lambda (v) (quoted? symbol? v)) + (lambda (v) (is-lambda? v 2 defns)) + (lambda (v) (ok-make-struct-type-property-super? v defns)) + (lambda (v) (any-side-effects? v 1 #:known-defns defns))))]) + (pred arg)))) + +(define (ok-make-struct-type-property-super? v defns) + (or (quoted? null? v) + (eq? 'null (correlated-e v)) + (and (pair? (correlated-e v)) + (eq? (correlated-e (car (correlated-e v))) 'list) + (for/and ([prop+val (in-list (cdr (correlated->list v)))]) + (and (= (correlated-length prop+val) 3) + (let ([prop+val (correlated->list prop+val)]) + (and (eq? 'cons (correlated-e (car prop+val))) + (or (memq (correlated-e (list-ref prop+val 1)) + '(prop:procedure prop:equal+hash prop:custom-write)) + (known-property? (lookup-defn defns (correlated-e (list-ref prop+val 1))))) + (not (any-side-effects? (list-ref prop+val 2) 1 #:known-defns defns)))))) + ;; All properties must be distinct + (= (sub1 (correlated-length v)) + (set-count (for/set ([prop+val (in-list (cdr (correlated->list v)))]) + (correlated-e (list-ref (correlated->list prop+val) 1)))))))) + +;; ---------------------------------------- + +(define (ok-make-struct-type? e ready-variable? defns) + (define l (correlated->list e)) + (define init-field-count-expr (and ((length l) . > . 3) + (list-ref l 3))) + (define auto-field-count-expr (and ((length l) . > . 4) + (list-ref l 4))) + (define num-fields + (maybe+ (field-count-expr-to-field-count init-field-count-expr) + (field-count-expr-to-field-count auto-field-count-expr))) + (define immutables-expr (or (and ((length l) . > . 9) + (list-ref l 9)) + 'null)) + (define super-expr (and ((length l) . > . 2) + (list-ref l 2))) + + (and ((length l) . >= . 5) + ((length l) . <= . 12) + (for/and ([arg (in-list (cdr l))] + [pred (in-list (list + (lambda (v) (quoted? symbol? v)) + (lambda (v) (super-ok? v defns)) + (lambda (v) (field-count-expr-to-field-count v)) + (lambda (v) (field-count-expr-to-field-count v)) + (lambda (v) (not (any-side-effects? v 1 #:ready-variable? ready-variable? #:known-defns defns))) + (lambda (v) (known-good-struct-properties? v immutables-expr super-expr defns)) + (lambda (v) (inspector-or-false? v)) + (lambda (v) (procedure-spec? v num-fields)) + (lambda (v) (immutables-ok? v init-field-count-expr))))]) + (pred arg)))) + +(define (super-ok? e defns) + (or (quoted? false? e) + (let ([o (lookup-defn defns (correlated-e e))]) + (and o + (known-struct-op? o) + (eq? 'struct-type (known-struct-op-type o)))))) + +(define (extract-struct-field-count-lower-bound e) + ;; e is already checked by `ok-make-struct-type?` + (define l (correlated->list e)) + (+ (field-count-expr-to-field-count (list-ref l 3)) + (field-count-expr-to-field-count (list-ref l 4)))) + +(define (quoted? val? v) + (or (and (pair? (correlated-e v)) + (eq? (correlated-e (car (correlated-e v))) 'quote) + (val? (correlated-e (correlated-cadr v)))) + (val? (correlated-e v)))) + +(define (quoted-value v) + (if (pair? (correlated-e v)) + (correlated-e (correlated-cadr v)) + (correlated-e v))) + +(define (false? v) + (eq? (correlated-e v) #f)) + +(define (field-count-expr-to-field-count v) + (and (quoted? exact-nonnegative-integer? v) + (quoted-value v))) + +(define (inspector-or-false? v) + (or (quoted? false? v) + (and (quoted? symbol? v) + (eq? 'prefab (quoted-value v))) + (and (= 1 (correlated-length v)) + (eq? 'current-inspector (correlated-e (car (correlated-e v))))))) + +(define (known-good-struct-properties? v immutables-expr super-expr defns) + (or (quoted? null? v) + (eq? 'null (correlated-e v)) + (and (pair? (correlated-e v)) + (eq? (correlated-e (car (correlated-e v))) 'list) + (for/and ([prop+val (in-list (cdr (correlated->list v)))]) + (and (= (correlated-length prop+val) 3) + (let ([prop+val (correlated->list prop+val)]) + (and (eq? 'cons (correlated-e (car prop+val))) + (known-good-struct-property+value? (list-ref prop+val 1) + (list-ref prop+val 2) + immutables-expr + super-expr + defns))))) + ;; All properties must be distinct + (= (sub1 (correlated-length v)) + (set-count (for/set ([prop+val (in-list (cdr (correlated->list v)))]) + (correlated-e (list-ref (correlated->list prop+val) 1)))))))) + +(define (known-good-struct-property+value? prop-expr val-expr immutables-expr super-expr defns) + (define prop-name (correlated-e prop-expr)) + (case prop-name + [(prop:evt) (or (is-lambda? val-expr 1 defns) + (immutable-field? val-expr immutables-expr))] + [(prop:procedure) (or (is-lambda? val-expr 1 defns) + (immutable-field? val-expr immutables-expr))] + [(prop:custom-write) (is-lambda? val-expr 3 defns)] + [(prop:equal+hash) + (define l (correlated->list val-expr)) + (and (eq? 'list (car l)) + (is-lambda? (list-ref l 1) 3 defns) + (is-lambda? (list-ref l 2) 2 defns) + (is-lambda? (list-ref l 3) 2 defns))] + [(prop:method-arity-error prop:incomplete-arity) + (not (any-side-effects? val-expr 1 #:known-defns defns))] + [(prop:impersonator-of) + (is-lambda? val-expr 1 defns)] + [(prop:arity-string) (is-lambda? val-expr 1 defns)] + [(prop:checked-procedure) + (and (quoted? false? super-expr) + ;; checking that we have at least 2 fields + (immutable-field? 1 immutables-expr))] + [else + (define o (lookup-defn defns prop-name)) + (and o + (known-property? o) + (not (any-side-effects? val-expr 1 #:known-defns defns)))])) + +;; is expr a procedure of specified arity? (arity irrelevant if #f) +(define (is-lambda? expr arity defns) + (define lookup (lookup-defn defns expr)) + (or (and lookup (known-function? lookup) ;; is it a known procedure? + (or (not arity) ;; arity doesn't matter + (arity-includes? (known-function-arity lookup) arity))) ;; arity compatible + (and (pair? (correlated-e expr)) + (eq? 'case-lambda (car (correlated-e expr))) + (not arity)) + (and (pair? (correlated-e expr)) + (eq? 'lambda (car (correlated-e expr))) + (or (not arity) + (let loop ([args (cadr (correlated->list expr))] + [arity arity]) + (cond + [(correlated? args) (loop (correlated-e args) arity)] + [(null? args) (zero? arity)] + [(pair? args) (loop (cdr args) (sub1 arity))] + [else (not (negative? arity))])))))) + +(define (arity-includes? a n) + (or (equal? a n) + (and (list? a) + (for/or ([a (in-list a)]) + (equal? a n))))) + +(define (immutable-field? val-expr immutables-expr) + (and (quoted? exact-nonnegative-integer? val-expr) + (memv (quoted-value val-expr) + (immutables-expr-to-immutables immutables-expr null)))) + +(define (immutables-expr-to-immutables e fail-v) + (case (and (pair? (correlated-e e)) + (correlated-e (car (correlated-e e)))) + [(quote) + (define v (correlated-cadr e)) + (or (and (correlated-length v) + (let ([l (map correlated-e (correlated->list v))]) + (and (andmap exact-nonnegative-integer? l) + (= (length l) (set-count (list->set l))) + l))) + fail-v)] + [else fail-v])) + +(define (procedure-spec? e field-count) + (or (quoted? false? e) + (and (quoted? exact-nonnegative-integer? e) + field-count + (< (quoted-value e) field-count)) + (is-lambda? e #f #hasheq()))) + +(define (immutables-ok? e init-field-count-expr) + (define l (immutables-expr-to-immutables e #f)) + (define c (field-count-expr-to-field-count init-field-count-expr)) + (and l + (for/and ([n (in-list l)]) + (n . < . c)))) + +;; ---------------------------------------- + +(define (ok-make-struct-field-accessor/mutator? e locals type defns) + (define l (correlated->list e)) + (define a (and (or (= (length l) 3) (= (length l) 4)) + (or (hash-ref locals (correlated-e (list-ref l 1)) #f) + (lookup-defn defns (correlated-e (list-ref l 1)))))) + (and (known-struct-op? a) + (eq? (known-struct-op-type a) type) + ((field-count-expr-to-field-count (list-ref l 2)) . < . (known-struct-op-field-count a)) + (or (= (length l) 3) (quoted? symbol? (list-ref l 3))))) + +;; ---------------------------------------- + +(define (maybe+ x y) + (and x y (+ x y))) + +;; ---------------------------------------- + +(module+ test + (define-syntax-rule (check expr result) + (unless (equal? expr result) + (error 'failed "~s" #'expr))) + + (define (any-side-effects?* e n) + (define v1 (any-side-effects? e n)) + (define v2 (any-side-effects? (datum->correlated e) n)) + (unless (equal? v1 v2) + (error "problem with correlated:" e)) + v1) + + (check (any-side-effects?* ''1 1) + #f) + + (check (any-side-effects?* ''1 #f) + #f) + + (check (any-side-effects?* '(lambda (x) x) 1) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + (list (cons prop:evt '0)) + (current-inspector) + '#f + '(0)) + 5) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + '() + (current-inspector) + '#f + '(0)) + 5) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + '() + (current-inspector) + '0 + '(0)) + 5) + #f) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + (list + (cons prop:evt '0) + (cons prop:evt '0)) ; duplicate + (current-inspector) + '#f + '(0)) + 5) + #t) + + (check (any-side-effects?* '(make-struct-type 'evt '#f '1 '0 '#f + (list (cons prop:evt '0)) + (current-inspector) + '#f + '(1)) ; <- too big + 5) + #t)) diff --git a/racket/src/expander/compile/top.rkt b/racket/src/expander/compile/top.rkt new file mode 100644 index 0000000000..98d59d1381 --- /dev/null +++ b/racket/src/expander/compile/top.rkt @@ -0,0 +1,170 @@ +#lang racket/base +(require "serialize.rkt" + "../host/linklet.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../namespace/namespace.rkt" + "../expand/root-expand-context.rkt" + "../expand/parsed.rkt" + "../compile/reserved-symbol.rkt" + "../common/performance.rkt" + "../eval/top-level-instance.rkt" + "compiled-in-memory.rkt" + "context.rkt" + "header.rkt" + "reserved-symbol.rkt" + "instance.rkt" + "eager-instance.rkt" + "expr.rkt" + "form.rkt" + "multi-top.rkt" + "namespace-scope.rkt" + "side-effect.rkt") + +(provide compile-single + compile-top) + +;; Compile a stand-alone expression, such as the right-hand side of a +;; `define-syntaxes` in a module +(define (compile-single p cctx) + (compile-top p cctx + #:serializable? #f + #:single-expression? #t)) + +;; Compile a single form, which can be a `define-values` form, a +;; `define-syntaxes` form, or an expression (where `begin` is treated +;; as an expression form). If `serializable?` is false, don't bother +;; generating the linklet for serialized data, because it won't be +;; used. If `to-source?` is true, the result is a hash table containing +;; S-expression linkets, instead of a `compiled-in-memory` containing +;; compiled linklets. +(define (compile-top p cctx + #:serializable? [serializable? #t] + #:single-expression? [single-expression? #f] + #:to-source? [to-source? #f]) + (performance-region + ['compile (if single-expression? 'transformer 'top)] + + (define phase (compile-context-phase cctx)) + + (define mpis (make-module-path-index-table)) + (define purely-functional? #t) + + ;; Compile the body forms, similar to compiling the body of a module + (define-values (body-linklets + min-phase + max-phase + phase-to-link-module-uses + phase-to-link-module-uses-expr + phase-to-link-extra-inspectorss + syntax-literals + no-root-context-pos) + (compile-forms (list p) cctx mpis + #:body-imports (if single-expression? + `([] + [,syntax-literals-id] + []) + `([,top-level-bind!-id + ,top-level-require!-id] + [,mpi-vector-id + ,syntax-literals-id] + ,instance-imports)) + #:body-import-instances (list top-level-instance + empty-top-syntax-literal-instance + empty-instance-instance) + #:to-source? to-source? + #:serializable? serializable? + #:definition-callback (lambda () (set! purely-functional? #f)) + #:compiled-expression-callback + (lambda (e expected-results phase required-reference?) + (when (and purely-functional? + (any-side-effects? e expected-results #:ready-variable? required-reference?)) + (set! purely-functional? #f))) + #:other-form-callback (lambda (s cctx) + (set! purely-functional? #f) + (compile-top-level-require s cctx)) + #:cross-linklet-inlining? (not single-expression?))) + + (define (add-metadata ht) + (let* ([ht (hash-set ht 'original-phase phase)] + [ht (hash-set ht 'max-phase max-phase)]) + ht)) + + (define bundle + ((if to-source? values hash->linklet-bundle) + (add-metadata + (cond + [serializable? + ;; To support seialization, construct a linklet that will + ;; deserialize module path indexes, syntax objects, etc. + (define syntax-literals-expr + (performance-region + ['compile 'top 'serialize] + (generate-eager-syntax-literals! + syntax-literals + mpis + phase + (compile-context-self cctx) + (compile-context-namespace cctx)))) + + (define link-linklet + ((if to-source? values (lambda (s) + (performance-region + ['compile 'top 'linklet] + (define-values (linklet new-keys) + (compile-linklet s + #f + (vector deserialize-instance + empty-eager-instance-instance) + (lambda (inst) (values inst #f)))) + linklet))) + `(linklet + ;; imports + (,deserialize-imports + ,eager-instance-imports) + ;; exports + (,mpi-vector-id + ,deserialized-syntax-vector-id + phase-to-link-modules + ,syntax-literals-id) + (define-values (,mpi-vector-id) + ,(generate-module-path-index-deserialize mpis)) + (define-values (,deserialized-syntax-vector-id) + (make-vector ,(add1 phase) #f)) + (define-values (phase-to-link-modules) ,phase-to-link-module-uses-expr) + (define-values (,syntax-literals-id) ,syntax-literals-expr)))) + + (hash-set body-linklets 'link link-linklet)] + [else + ;; Will combine the linking unit with non-serialized link info + body-linklets])))) + + (cond + [to-source? + (hasheq #f bundle)] + [else + ;; If the compiled code is executed directly, it must be in its + ;; original phase, and we'll share the original values + (compiled-in-memory (hash->linklet-directory (hasheq #f bundle)) + #f ; self + #f ; requires + #f ; provides + phase-to-link-module-uses + (current-code-inspector) + phase-to-link-extra-inspectorss + (mpis-as-vector mpis) + (syntax-literals-as-vector syntax-literals) + null + null + (extract-namespace-scopes (compile-context-namespace cctx)) + purely-functional?)]))) + +;; Callback for compiling a sequence of expressions: handle `require` +;; (which is handled separately for modules) +(define (compile-top-level-require p cctx) + (define phase (compile-context-phase cctx)) + (cond + [(parsed-require? p) + (define form-stx (compile-quote-syntax (syntax-disarm (parsed-s p)) cctx)) + `(,top-level-require!-id ,form-stx ,ns-id)] + [else #f])) diff --git a/racket/src/expander/compile/vector-ref.rkt b/racket/src/expander/compile/vector-ref.rkt new file mode 100644 index 0000000000..ba946030a0 --- /dev/null +++ b/racket/src/expander/compile/vector-ref.rkt @@ -0,0 +1,14 @@ +#lang racket/base + +(provide unsafe-vector-ref-id) + +(define unsafe-vector-ref-id + (cond + [(eq? (system-type 'vm) 'chez-scheme) + ;; Using `unsafe-vector*-ref` is worthwhile, + ;; because it saves significant compiler effort + 'unsafe-vector*-ref] + [else + ;; Using an unsafe operation doesn't work with + ;; bytecode loading in no-unsafe-operation mode + 'vector*-ref])) diff --git a/racket/src/expander/demo.rkt b/racket/src/expander/demo.rkt new file mode 100644 index 0000000000..32dba90c0b --- /dev/null +++ b/racket/src/expander/demo.rkt @@ -0,0 +1,1411 @@ +#lang racket/base +(require "main.rkt" + "common/set.rkt") + +;; ---------------------------------------- + +(define demo-ns (make-namespace)) +(namespace-attach-module (current-namespace) ''#%kernel demo-ns) + +(namespace-require ''#%kernel demo-ns) +(namespace-require '(for-syntax '#%kernel) demo-ns) + +(define check-reexpand? #f) +(define check-serialize? #f) + +(define (expand-expression e #:namespace [ns demo-ns]) + (expand (namespace-syntax-introduce (datum->syntax #f e) ns) + ns)) + +(define (compile+eval-expression e #:namespace [ns demo-ns]) + (define exp-e (expand-expression e #:namespace ns)) + (define c (compile (if check-reexpand? exp-e e) ns check-serialize?)) + (define ready-c (if check-serialize? + (let ([o (open-output-bytes)]) + (display c o) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes (get-output-bytes o))))) + c)) + (values exp-e + (eval ready-c ns))) + +(define (eval-expression e #:check [check-val 'no-value-to-check] + #:namespace [ns demo-ns]) + (define-values (c v) (compile+eval-expression e #:namespace ns)) + (unless (eq? check-val 'no-value-to-check) + (unless (equal? v check-val) + (error "check failed:" v "vs." check-val))) + v) + +(define (eval-expression/interleaved e #:check [check-val 'no-value-to-check] + #:namespace [ns demo-ns]) + (define v (eval e ns)) + (unless (eq? check-val 'no-value-to-check) + (check-value v check-val)) + v) + +(define (check-value v check-val) + (unless (equal? v check-val) + (error "check failed:" v "vs." check-val))) + +(define-syntax-rule (check-print expr out ...) + (check-thunk-print (lambda () expr) out ...)) + +(define (check-thunk-print t . outs) + (define o (open-output-bytes)) + (parameterize ([current-output-port o]) + (t)) + (write-bytes (get-output-bytes o)) + (define o-expected (open-output-bytes)) + (for ([out (in-list outs)]) (println out o-expected)) + (unless (equal? (get-output-bytes o) + (get-output-bytes o-expected)) + (error "output check failed:" + (get-output-bytes o) + "vs." (get-output-bytes o-expected)))) + +(define-syntax-rule (check-error expr rx) + (check-thunk-error (lambda () expr) rx)) + +(define (check-thunk-error t rx) + (void) + (with-handlers ([exn:fail? (lambda (exn) + (unless (regexp-match? rx (exn-message exn)) + (error "wrong error" (exn-message exn))) + `(ok ,(exn-message exn)))]) + (t) + (error "shouldn't get here"))) + +;; ---------------------------------------- + +(compile+eval-expression + '(+ 1 1)) + +(compile+eval-expression + '(case-lambda + [(x) (set! x 5)] + [(x y) (begin0 y x)] + [() (with-continuation-mark 1 2 3)])) + +(compile+eval-expression + '(lambda (x) (define-values (y) x) y)) + +(compile+eval-expression + '(lambda (x) + (define-syntaxes (y) (lambda (stx) (quote-syntax 7))) + y)) + +;; Expands to `let-values`: +(compile+eval-expression + '(lambda (x) + (define-values (z) 1) + (define-values (y) z) + y)) + +;; Expands to two separate `letrec-values`: +(compile+eval-expression + '(lambda (x) + (define-values (z) (lambda () y)) + (define-values (y) 1) + (define-values (q) (lambda () q)) + z)) + +;; Same as previous: +(compile+eval-expression + '(lambda (x) + (letrec-syntaxes+values + () + ([(z) (lambda () y)] + [(y) 1] + [(q) (lambda () q)]) + z))) + +(compile+eval-expression + '(let-values ([(z) 9]) + (letrec-syntaxes+values + ([(m) (lambda (stx) (car (cdr (syntax-e stx))))]) + ([(x) 5] [(y) (lambda (z) z)]) + (let-values ([(z) 10]) + (begin z (if (m 10) 1 2)))))) + +"expansion not captured" +(eval-expression + #:check 'x-1 + '(let-values ([(x) 'x-1]) + (letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax x))]) + () + (let-values ([(x) 'x-3]) + (m))))) + +"non-capturing expansion" +(eval-expression + #:check 'x-3 + '(let-values ([(x) 'x-1]) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax + #f + (list (quote-syntax let-values) + (list (list (list (quote-syntax x)) + (quote-syntax 'x-2))) + (car (cdr (syntax-e stx))))))]) + () + (let-values ([(x) 'x-3]) + (m x))))) + +"distinct generated variables" +(eval-expression + #:check '(2 1) + '(letrec-syntaxes+values + ([(gen) (lambda (stx) + (let-values ([(vals) (syntax-e (car (cdr (syntax-e stx))))] + [(binds) (syntax-e (car (cdr (cdr (syntax-e stx)))))] + [(refs) (syntax-e (car (cdr (cdr (cdr (syntax-e stx))))))]) + (datum->syntax + #f + (if (null? vals) + (list (quote-syntax bind) binds refs) + (list (quote-syntax gen) + (cdr vals) + (cons (list (list (quote-syntax x)) + (car vals)) + binds) + (cons (quote-syntax x) + refs))))))] + [(bind) (lambda (stx) + (let-values ([(binds) (car (cdr (syntax-e stx)))] + [(refs) (car (cdr (cdr (syntax-e stx))))]) + (datum->syntax + (quote-syntax here) + (list (quote-syntax let-values) + binds + (cons (quote-syntax list) + refs)))))]) + () + (gen (1 2) () ()))) + +"use-site scopes (so not ambiguous)" +(eval-expression + #:check 'ok + '((let-values () + (define-syntaxes (identity) + (lambda (stx) + (let-values ([(misc-id) (car (cdr (syntax-e stx)))]) + (datum->syntax + (quote-syntax here) + (list 'lambda '(x) + (list 'let-values (list + (list (list misc-id) ''other)) + 'x)))))) + (identity x)) + 'ok)) + +"use-site scope remove from binding position" +(eval-expression + #:check 'still-ok + '(let-values () + (define-syntaxes (define-identity) + (lambda (stx) + (let-values ([(id) (car (cdr (syntax-e stx)))]) + (datum->syntax + (quote-syntax here) + (list 'define-values (list id) '(lambda (x) x)))))) + (define-identity f) + (f 'still-ok))) + +"compile-time scopes pruned by `quote-syntax`" +(namespace-require '(for-meta 2 '#%kernel) demo-ns) +(eval-expression + #:check 'bound + '(letrec-syntaxes+values + ([(m) + (lambda (stx) + (let-values ([(id1) (let-values ([(x) 1]) + (define-syntaxes (wrap) ; to provoke a use-site scope + (lambda (stx) (car (cdr (syntax-e stx))))) + (wrap (quote-syntax x)))] + [(id2) (let-values ([(x) 1]) + (define-syntaxes (wrap) + (lambda (stx) (car (cdr (syntax-e stx))))) + (wrap (quote-syntax x)))]) + (datum->syntax + (quote-syntax here) + (list 'let-values (list (list (list id1) ''bound)) + id2))))]) + () + (m))) + +"`(quote-syntax .... #:local)` doesn't prune" +(eval-expression + #:check 'bound-2 + '(letrec-syntaxes+values + ([(m) + (lambda (stx) + (let-values ([(id1) (let-values ([(x) 1]) + (quote-syntax x #:local))] + [(id2) (let-values ([(x) 1]) + (define-syntaxes (wrap) + (lambda (stx) (car (cdr (syntax-e stx))))) + (quote-syntax x #:local))]) + (datum->syntax + (quote-syntax here) + (list 'let-values (list (list (list id1) ''bound-1) + (list (list id2) ''bound-2)) + id2))))]) + () + (m))) + +"non-transformer binding misuse" +(check-error + (expand-expression '(letrec-syntaxes+values + ([(v) 1]) + () + v)) + #rx"illegal use of syntax") + +"free-identifier=? and bound-identifier=?" +(eval-expression + #:check '(a (#t #f #t) + b (#f #f #t) + c (#t #f #t) + d (#t #f #f) + e (#f #f #t) (#f #f #f) + f ((#t #f) (#f #f))) + '(let-values ([(x) 0]) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (list + (free-identifier=? (quote-syntax x) (car (cdr (syntax-e stx)))) + (bound-identifier=? (quote-syntax x) (car (cdr (syntax-e stx)))) + (bound-identifier=? (car (cdr (syntax-e stx))) + (car (cdr (cdr (syntax-e stx)))))))))]) + () + (list + 'a + (m x x) + 'b + (let-values ([(x) 1]) + (m x x)) + 'c + (letrec-syntaxes+values + ([(n) (lambda (stx) + (quote-syntax (m x x)))]) + () + (n)) + 'd + (letrec-syntaxes+values + ([(o) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax m) + (car (cdr (syntax-e stx))) + (quote-syntax x))))]) + () + (o x)) + 'e + (m not-x not-x) + (m not-x also-not-x) + 'f + (letrec-syntaxes+values + ([(p) (lambda (stx) + (letrec-syntaxes+values + ([(q) (lambda (nested-stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + ;; These `free-identifier=?` test should be at phase 1: + (list + (free-identifier=? (quote-syntax stx) (car (cdr (syntax-e nested-stx)))) + (free-identifier=? (quote-syntax stx) (car (cdr (cdr (syntax-e nested-stx)))))))))]) + () + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (list (q stx not-stx) + (let-values ([(stx) 0]) + (q stx stx)))))))]) + () + (p)))))) + +"syntax-local-value" +(eval-expression + '(let-values ([(x) 1]) + (letrec-syntaxes+values + ([(x-id) (quote-syntax x)]) + () + (letrec-syntaxes+values + ([(m) (lambda (stx) (syntax-local-value (quote-syntax x-id)))]) + () + (let-values ([(x) 2]) + (m))))) + #:check 1) + +"local-expand" +(eval-expression + '(let-values ([(x) 10]) + (letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax (something x)))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) (car + (cdr + (syntax-e + (local-expand (car (cdr (syntax-e stx))) + 'expression + (list (quote-syntax #%app)))))))]) + () + (let-values ([(x) 20]) + (n (m)))))) + #:check 10) + +"local-expand-expression" +(eval-expression + '(letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax 5))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) + (let-values ([(expr already) + (syntax-local-expand-expression (car (cdr (syntax-e stx))))]) + (datum->syntax + (quote-syntax here) + (list (quote-syntax +) + (quote-syntax 1) + already))))]) + () + (n (m)))) + #:check 6) + +(check-error + (eval-expression + '(letrec-syntaxes+values + ([(m) (lambda (stx) (quote-syntax 5))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) + (let-values ([(expr already) + (syntax-local-expand-expression (car (cdr (syntax-e stx))))]) + (datum->syntax + #f + (list + (quote-syntax let-values) + (list (list (list (quote-syntax x)) (quote-syntax 1))) + already))))]) + () + (n (m))))) + #rx"expanded syntax not in its original lexical context") + +"internal definition context" +(eval-expression + '(let-values ([(x) 10]) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (let-values ([(id) (car (cdr (syntax-e stx)))] + [(id2) (car (cdr (cdr (syntax-e stx))))] + [(intdef) (syntax-local-make-definition-context)]) + (syntax-local-bind-syntaxes (list id) + (quote-syntax (lambda (stx) (quote-syntax 5))) + intdef) + (syntax-local-bind-syntaxes (list id2) + #f + intdef) + (datum->syntax + (quote-syntax here) + (list (quote-syntax let-values) + (list (list (list + (let-values ([(id2-by-expand) + (car + (cdr + (syntax-e (local-expand (datum->syntax + #f + (list (quote-syntax quote) + id2)) + (list 'intdef) + (list (quote-syntax quote)) + intdef))))] + [(id2-by-intro) + (internal-definition-context-introduce + intdef + id2)] + [(flip) (make-syntax-introducer)]) + (if (bound-identifier=? id2-by-expand id2-by-intro) + (let-values ([(delta) + (make-syntax-delta-introducer + (flip (quote-syntax here)) + (quote-syntax here))]) + (syntax-local-identifier-as-binding + (delta (flip id2-by-intro) 'remove))) + (error "should have been the same")))) + 7)) + (local-expand (datum->syntax + (quote-syntax here) + (list (quote-syntax +) + (list id) + id2)) + (list 'intdef) + (list) + intdef)))))]) + + () + (m x y))) + #:check 12) + +"set! transformer" +(eval-expression + '(let-values ([(real-one) 1] + [(check-one) (lambda (v) + (if (equal? v 1) + 'ok + 'oops))]) + (letrec-syntaxes+values + ([(one) + (make-set!-transformer + (lambda (stx) + (if (pair? (syntax-e stx)) + (if (free-identifier=? (car (syntax-e stx)) + (quote-syntax set!)) + (datum->syntax + (quote-syntax here) + (list (quote-syntax check-one) + (car (cdr (cdr (syntax-e stx)))))) + (datum->syntax + stx + (cons + (quote-syntax list) + (cons + (quote-syntax real-one) + (cdr (syntax-e stx)))))) + (quote-syntax real-one))))]) + () + (list one + (set! one 5) + (set! one 1) + (one 8)))) + #:check (list 1 'oops 'ok '(1 8))) + +"rename transformer" +(eval-expression + '(let-values ([(f) (lambda (v) (+ v 1))]) + (letrec-syntaxes+values + ([(g) (make-rename-transformer (quote-syntax f))]) + () + (list (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax (quote-syntax here) + (free-identifier=? (quote-syntax f) + (quote-syntax g))))]) + () + (m)) + (let-values ([(h) g]) (h 0)) + (g 1) + (begin + (set! g 3) + f) + (letrec-syntaxes+values + ([(f-id) (quote-syntax f)]) + () + (letrec-syntaxes+values + ([(g-id) (make-rename-transformer (quote-syntax f-id))]) + () + (letrec-syntaxes+values + ([(m) (lambda (stx) (syntax-local-value (quote-syntax g-id)))]) + () + (+ 1 (m)))))))) + #:check (list #t 1 2 3 4)) + +"lifts in transformer; same number twice" +(eval-expression '(letrec-syntaxes+values + ([(n) (lambda (stx) + (letrec-syntaxes+values + ([(m) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list + (quote-syntax begin) + (list (quote-syntax print) + (syntax-local-lift-expression + (quote-syntax (random)))) + (list (quote-syntax newline)))))]) + () + (datum->syntax (quote-syntax here) + (m))))]) + () + (list (n) (n)))) + +"local-expand/capture-lifts" +(eval-expression '(letrec-syntaxes+values + ([(m) (lambda (stx) + (syntax-local-lift-expression (quote-syntax 1)))]) + () + (letrec-syntaxes+values + ([(n) (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (local-expand/capture-lifts + (quote-syntax (m)) + 'expression + '()))))]) + () + (let-values ([(x) (n)]) + (list (car x) + (car (car (cdr x))) + (car (cdr (cdr (car (cdr x))))))))) + #:check '(begin define-values 1)) + +"get shadower" +(eval-expression + '(let-values ([(x) 1]) + (letrec-syntaxes+values + ([(m) + (lambda (stx) + (datum->syntax + #f + (list (quote-syntax let-values) + (list + (list + (list (syntax-local-introduce + (syntax-local-get-shadower (quote-syntax x)))) + (quote-syntax 2))) + (car (cdr (syntax-e stx))))))]) + () + (let-values ([(x) 3]) + (m x)))) + #:check 2) + +"top-level definitions" +(eval-expression '(define-values (top-x) 'x-at-top)) +(eval-expression 'top-x #:check 'x-at-top) +(check-error (eval-expression 'top-y) #rx"undefined") +(eval-expression '(define-values (top-f) (lambda () top-y))) +(check-error (eval-expression '(top-f)) #rx"undefined") +(eval-expression '(define-values (top-y) 'y-at-top)) +(eval-expression '(top-f) #:check 'y-at-top) +(eval-expression '(define-values (top-y) 'changed-y-at-top)) +(eval-expression '(top-f) #:check 'changed-y-at-top) +(eval-expression '(define-syntaxes (top-m) (lambda (stx) + (datum->syntax + #f + (list (quote-syntax quote) + (car (cdr (syntax-e stx)))))))) +(eval-expression '(top-m 8) #:check 8) +(eval-expression '(define-syntaxes (top-def-top-x) + (lambda (stx) + (quote-syntax + (begin + (define-values (top-x) 'macro-introduced-top-x) + top-x))))) +(eval-expression/interleaved '(top-def-top-x) #:check 'macro-introduced-top-x) +(eval-expression 'top-x #:check 'x-at-top) +(eval-expression '(begin ; check compilation of multiple top-level forms + (define-values (top-z) 'z-at-top) + top-z) + #:check 'z-at-top) + +;; ---------------------------------------- + +(define (eval-module-declaration mod #:namespace [ns demo-ns]) + (parameterize ([current-namespace ns]) + (eval-expression mod #:namespace ns))) + +(eval-module-declaration '(module m0 '#%kernel + (define-values (x) 0) + (print x) (newline))) + +(check-print + (eval-expression '(#%require 'm0)) + 0) + +(eval-module-declaration '(module m1 '#%kernel + (#%require (for-syntax '#%kernel)) + (begin-for-syntax + (define-values (ten) (quote-syntax 10))) + (define-syntaxes (m) (lambda (stx) ten)) + (define-values (x) 1) + (print x) (newline) + (define-values (posn make-posn struct:posn posn? + posn-x posn-y + set-posn-x! set-posn-y!) + (values 1 2 3 4 5 6 7 8)) + (#%provide (prefix-all-defined def:) + (struct posn (x y))) + (print (m)) (newline) + (m))) + +(eval-module-declaration '(module m2 '#%kernel + (#%require 'm1) + (print def:x) (newline))) + +(check-print + (eval-expression '(#%require 'm2)) + 1 + 10 + 1) + +(eval-module-declaration '(module with-use-site-scope '#%kernel + (#%require (for-syntax '#%kernel)) + + (define-syntaxes (identity) + (lambda (stx) + (let-values ([(misc-id) (car (cdr (syntax-e stx)))]) + (datum->syntax + (quote-syntax here) + (list 'lambda '(x) + (list 'let-values (list + (list (list misc-id) ''other)) + 'x)))))) + (identity x) + + (define-syntaxes (define-identity) + (lambda (stx) + (datum->syntax + #f + (list (quote-syntax define-values) + (list (car (cdr (syntax-e stx)))) + (quote-syntax (lambda (x) x)))))) + (define-identity f) + (print (f 5)) (newline) + + (define-syntaxes (define-x) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax begin-for-syntax) + (list (quote-syntax define-values) + (list (car (cdr (syntax-e stx)))) + (quote-syntax 'ct-5)))))) + (define-x ct-5) + (define-syntaxes (ct-five) + (lambda (stx) + (datum->syntax (quote-syntax here) + (list (quote-syntax quote) + ct-5)))) + (print (ct-five)) (newline))) + +(check-print + (namespace-require ''with-use-site-scope demo-ns) + 5 + 'ct-5) + +(eval-module-declaration '(module definition-shadows-initial-require '#%kernel + (#%require (rename '#%kernel orig:list list)) + (#%provide list) + (define-values (list) + (lambda (a b) + (print a) (newline) + (orig:list a b))))) + +(eval-module-declaration '(module definition-shadows-plain-require '#%kernel + (#%require '#%kernel) + (#%provide map) + (define-values (map) + (lambda (f l) + (if (null? l) + '() + (cons (car l) ; don't use `f` + (map f (cdr l)))))))) + +(eval-module-declaration '(module require-shadows-initial-require '#%kernel + (#%require 'definition-shadows-initial-require + 'definition-shadows-plain-require) + (print (map pair? (list 'a 'b))) (newline))) + +(check-print + (namespace-require ''require-shadows-initial-require demo-ns) + 'a + '(a b)) + +(check-error + (eval-module-declaration '(module m '#%kernel + (#%require '#%kernel + 'definition-shadows-initial-require))) + #rx"already required") + +(check-error + (eval-module-declaration '(module m '#%kernel + (define-values (list) 5) + (#%require '#%kernel))) + #rx"already defined") + +;; ---------------------------------------- + +(check-print + (eval-module-declaration '(module forward-reference-in-begin-for-syntax '#%kernel + (#%require (for-syntax '#%kernel)) + (begin-for-syntax + (define-values (even) (lambda () odd))) + (begin-for-syntax + (define-values (odd) (lambda () even))) + (begin-for-syntax + (define-values (assign-later!) (lambda () (set! later also-later)))) + (begin-for-syntax + (define-values (later) 5) + (define-values (also-later) 6) + (assign-later!) + (print later) (newline)))) + 6 + 6) ; re-expansion + +;; ---------------------------------------- + +(eval-module-declaration '(module random-n '#%kernel + (define-values (n) (random)) + (#%provide n))) + +(eval-module-declaration '(module use-random-n '#%kernel + (#%require 'random-n + (for-syntax '#%kernel + 'random-n)) + (define-syntaxes (m) + (lambda (stx) (datum->syntax (quote-syntax here) + n))) + (print (m)) (newline) + (print (m)) (newline) + (print n) (newline) + (print n) (newline))) + +"print same number twice, then different number twice" +(namespace-require ''use-random-n demo-ns) + +;; ---------------------------------------- + +;; Fresh compile-time, same run-time: +(eval-module-declaration '(module use-random-n-again '#%kernel + (#%require 'random-n + (for-syntax '#%kernel + 'random-n)) + (define-syntaxes (m) + (lambda (stx) (datum->syntax (quote-syntax here) + n))) + (print (m)) (newline) + (print n) (newline))) + +"first number is fresh, second number is same" +(namespace-require ''use-random-n-again demo-ns) + +;; ---------------------------------------- + +;; Check phase shifting of syntax objects: +(eval-module-declaration '(module two-xes '#%kernel + (#%require (for-syntax '#%kernel)) + (define-values (x) 0) + (begin-for-syntax + (define-values (x) 1)) + (#%provide x + (for-syntax x)))) + +(eval-module-declaration '(module use-two-xes '#%kernel + (#%require (for-template 'two-xes) + (for-syntax '#%kernel)) + (define-values (rt-x-ref) (quote-syntax x)) + (begin-for-syntax + (define-values (ct-x-ref) (quote-syntax x))) + (#%provide rt-x-ref + (for-syntax ct-x-ref)))) + +(eval-module-declaration '(module use-x-ref '#%kernel + (#%require 'use-two-xes + (for-syntax '#%kernel + 'use-two-xes)) + (define-syntaxes (ct-m) (lambda (stx) ct-x-ref)) + (define-syntaxes (rt-m) (lambda (stx) rt-x-ref)) + (print (ct-m)) (newline) + (print (rt-m)) (newline))) + +(check-print + (namespace-require ''use-x-ref demo-ns) + 1 + 0) + +;; ---------------------------------------- +;; Custom `#%module-begin' + +(eval-module-declaration '(module printing-mb '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide (all-from-except '#%kernel #%module-begin) + (rename module-begin #%module-begin)) + (define-syntaxes (module-begin) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (cons + (quote-syntax #%module-begin) + (map (lambda (b) + (datum->syntax + (quote-syntax here) + (list (quote-syntax begin) + (list (quote-syntax print) b) + (list (quote-syntax newline))))) + (cdr (syntax-e stx))))))))) + +(eval-module-declaration '(module printed 'printing-mb + (+ 1 2) + (+ 3 4))) + +(check-print + (namespace-require ''printed demo-ns) + 3 + 7) + +(eval-module-declaration '(module intro-printed-submodule '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide m) + (define-syntaxes (m) + (lambda (stx) + (quote-syntax + (module sub 'printing-mb + (+ 5 6) + (+ 7 8))))))) + +(eval-module-declaration '(module printed-submodule '#%kernel + (#%require 'intro-printed-submodule) + (m))) + +(check-print + (namespace-require '(submod 'printed-submodule sub) demo-ns) + 11 + 15) + +;; ---------------------------------------- +;; local-expanding `#%module-begin' + +(eval-module-declaration '(module local-expanding-mb '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide (all-from-except '#%kernel #%module-begin) + (rename module-begin #%module-begin)) + (define-syntaxes (module-begin) + (lambda (stx) + (local-expand (datum->syntax + #f + (cons + (quote-syntax #%module-begin) + (cdr (syntax-e stx)))) + 'module-begin + null))))) + +(eval-module-declaration '(module local-expanded-mb 'local-expanding-mb + (define-values (x) 'x) + (print x) (newline))) + +(check-print + (namespace-require ''local-expanded-mb demo-ns) + 'x) + +;; ---------------------------------------- +;; Submodule + +(eval-module-declaration '(module with-pre-submodule '#%kernel + (module a '#%kernel + (#%provide a) + (define-values (a) 'a)) + (#%require (submod "." a)) + (print a) (newline))) + +(check-print + (namespace-require ''with-pre-submodule demo-ns) + 'a) + +(eval-module-declaration '(module with-post-submodule '#%kernel + (#%provide b) + (define-values (b) 'b) + (module* b '#%kernel + (#%require (submod "..")) + (print b) (newline)))) + +(check-print + (namespace-require '(submod 'with-post-submodule b) demo-ns) + 'b) + +(eval-module-declaration '(module with-#f-submodule '#%kernel + (#%require (for-syntax '#%kernel)) + (define-values (c) 'c) + (define-syntaxes (c2) (lambda (stx) (quote-syntax c))) + (module* c #f + (print c) (newline) + (print c2) (newline)))) + +(check-print + (namespace-require '(submod 'with-#f-submodule c) demo-ns) + 'c + 'c) + +(eval-module-declaration '(module used-by-shifted-submodule '#%kernel + (define-values (x) 'x) + (#%provide x))) + +(eval-module-declaration '(module with-shifted-pre-submodule '#%kernel + (#%require (for-syntax '#%kernel)) + (begin-for-syntax + (module xa '#%kernel + (#%require 'used-by-shifted-submodule) + (#%provide xa) + (define-values (xa) x))) + (#%require (submod "." xa)) + (print xa) (newline))) + +(check-print + (namespace-require ''with-shifted-pre-submodule demo-ns) + 'x) + +(eval-module-declaration '(module with-shifted-#f-submodule '#%kernel + (#%require (for-syntax '#%kernel + 'used-by-shifted-submodule)) + (define-values (d) 'd) + (begin-for-syntax + (define-values (d-stx) (quote-syntax d)) + (module* d #f + (#%provide get-d-stx) + x + (define-values (get-d-stx) (lambda () d-stx)))))) + +(eval-module-declaration '(module use-shifted-#f-submodule '#%kernel + (#%require (for-syntax '#%kernel + (submod 'with-shifted-#f-submodule d))) + (define-syntaxes (m) (lambda (stx) (get-d-stx))) + (print (m)) (newline))) + +(check-print + (namespace-require ''use-shifted-#f-submodule demo-ns) + 'd) + +(eval-module-declaration '(module with-#f-submodule-provide '#%kernel + (define-values (e) 'e) + (module* e #f + (#%provide e)))) + +(eval-module-declaration '(module use-submodule-provide '#%kernel + (#%require (submod 'with-#f-submodule-provide e)) + (print e) (newline))) + +(check-print + (namespace-require ''use-submodule-provide demo-ns) + 'e) + +;; ---------------------------------------- +;; rename-transformer provide redirection + +(eval-module-declaration '(module provides-original-binding '#%kernel + (#%provide x) + (define-values (x) 'x))) + +(eval-module-declaration '(module provides-rename-transformer '#%kernel + (#%require (for-syntax '#%kernel) + 'provides-original-binding) + (#%provide y) + (define-syntaxes (y) (make-rename-transformer + (quote-syntax x))))) + +(eval-module-declaration '(module checks-free=id '#%kernel + (#%require (for-syntax '#%kernel) + 'provides-original-binding + 'provides-rename-transformer) + (print (if (free-identifier=? (quote-syntax x) + (quote-syntax y)) + 'free=id + 'not-free=id)) + (newline))) + +(check-print + (namespace-require ''checks-free=id demo-ns) + 'free=id) + +;; ---------------------------------------- +;; syntax-local-value of module binding + +(eval-module-declaration '(module define-non-transformer '#%kernel + (#%require (for-syntax '#%kernel)) + (#%provide car-id) + (define-syntaxes (car-id) (quote-syntax car)))) + +(eval-module-declaration '(module use-non-transformer '#%kernel + (#%require (for-syntax '#%kernel) + 'define-non-transformer) + (define-syntaxes (m) + (lambda (stx) (syntax-local-value (quote-syntax car-id)))) + (print ((m) '(1 2))) + (newline))) + +(check-print + (namespace-require ''use-non-transformer demo-ns) + 1) + +;; ---------------------------------------- +;; syntax-local-lift-{expression,module}, etc. + +(eval-module-declaration '(module lifts '#%kernel + (#%require (for-syntax '#%kernel)) + (module pre '#%kernel + (#%provide pre) + (define-values (pre) 'pre)) + (define-syntaxes (m) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list + (quote-syntax begin) + (list (quote-syntax print) + (syntax-local-lift-expression + (quote-syntax (+ 1 2)))) + (list (quote-syntax newline)))))) + (m) + (list (m)) + (define-values (dummy) (m)) + (define-syntaxes (n) + (lambda (stx) + (syntax-local-lift-module + (quote-syntax (module sub '#%kernel + (#%provide sub) + (define-values (sub) 'sub)))) + (syntax-local-lift-module + (quote-syntax (module* main #f + (print x) (newline)))) + (syntax-local-lift-module-end-declaration + (quote-syntax (define-values (done) 'done))) + (syntax-local-lift-provide + (quote-syntax done)) + (let-values ([(pre-id) (syntax-local-lift-require + (quote-syntax (submod "." pre)) + (quote-syntax pre))]) + (datum->syntax + (quote-syntax here) + (list + (quote-syntax begin) + (list (quote-syntax print) pre-id) + (quote-syntax (newline)) + (quote-syntax (#%require (submod "." sub))) + (quote-syntax (print sub)) + (quote-syntax (newline))))))) + (n) + (define-values (x) '*) + (define-syntaxes (as-expr) + (lambda (stx) + ;; (syntax-local-lift-module-end-declaration + ;; (quote-syntax (define-values (fail) 'this-wont-work))) + (syntax-local-lift-module-end-declaration + (quote-syntax (begin (print 'end) (newline)))) + (quote-syntax (void)))) + (list (as-expr)))) + +(check-print + (namespace-require '(submod 'lifts main) demo-ns) + 3 + 3 + 3 + 'pre + 'sub + 'end + '*) + +(eval-module-declaration '(module use-lifted-provide '#%kernel + (#%require 'lifts) + (print done) (newline))) + +(check-print + (namespace-require ''use-lifted-provide demo-ns) + 'done) + +;; ---------------------------------------- +;; `local-transformer-expand` + +(eval-module-declaration '(module local-transformer-expand '#%kernel + (#%require (for-syntax '#%kernel)) + (define-syntaxes (m) + (lambda (stx) + (datum->syntax + #f + (list + (quote-syntax letrec-syntaxes+values) + (list + (list (list (car (cdr (syntax-e stx)))) + (local-transformer-expand + (car (cdr (cdr (syntax-e stx)))) + 'expression + '()))) + (list) + (car (cdr (cdr (cdr (syntax-e stx))))))))) + (begin-for-syntax + (#%require (for-syntax '#%kernel)) + (define-syntaxes (tm) + (lambda (stx) + (quote-syntax (quote-syntax 'local-trans))))) + (print (m p (lambda (stx) (tm)) (p))) (newline))) + +(check-print + (namespace-require ''local-transformer-expand demo-ns) + 'local-trans) + +;; ---------------------------------------- +;; `expand` in `#%provide` + +(eval-module-declaration '(module expand-provide '#%kernel + (#%require (for-syntax '#%kernel)) + (module sub '#%kernel + (#%provide a-sub b-sub) + (define-values (a-sub) 'a-sub) + (define-values (b-sub) 'b-sub)) + (#%require (submod "." sub)) + (define-values (a-here) 'a-here) + (define-values (b-here) 'b-here) + (define-syntaxes (all-a) + (lambda (stx) + (let-values ([(here) (syntax-local-module-defined-identifiers)] + [(there) (syntax-local-module-required-identifiers + '(submod "." sub) + 0)] + [(keep-a) (lambda (id) + (regexp-match? #rx"^a" + (symbol->string + (syntax-e id))))]) + (define-values (filter) + (lambda (f l) + (if (null? l) + null + (if (f (car l)) + (cons (car l) (filter f (cdr l))) + (filter f (cdr l)))))) + (datum->syntax + #f + (cons + (quote-syntax begin) + (append + (filter keep-a (hash-ref here 0)) + (filter keep-a (cdr (assv 0 there))))))))) + (#%provide (expand (all-a))))) + +(eval-module-declaration '(module use-expand-provide '#%kernel + (#%require 'expand-provide) + (print (list a-sub a-here)) (newline))) + +(check-print + (namespace-require ''use-expand-provide demo-ns) + (list 'a-sub 'a-here)) + +;; ---------------------------------------- +;; cross-phase persistent declaration + +(eval-module-declaration '(module cross-phase-persistent '#%kernel + (#%declare #:cross-phase-persistent) + (#%require '#%kernel) + (#%provide gen) + (define-values (gen) (gensym "g")) + (module ignored '#%kernel) + (module* also-ignored '#%kernel) + (begin + (define-values (y) (lambda () (error "anything"))) + (define-values (x) (case-lambda + [() (error "anything")] + [(x) (set! x x)]))) + (define-values (z) (list + #t + (cons 1 2) + "string" + #"bytes" + 'symbol + (gensym) + (string->uninterned-symbol "u"))))) + +(eval-module-declaration '(module use-cross-phase-persistent '#%kernel + (#%require (for-syntax '#%kernel + 'cross-phase-persistent) + (for-meta 2 '#%kernel + 'cross-phase-persistent)) + (begin-for-syntax + (define-syntaxes (ctct-gen) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + gen))))) + (define-syntaxes (ct-gen) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + gen)))) + (define-syntaxes (use-ctct-gen) + (lambda (stx) + (datum->syntax + (quote-syntax here) + (list (quote-syntax quote) + (ctct-gen))))) + + (print (equal? (ct-gen) (use-ctct-gen))) (newline))) + +(check-print + (namespace-require ''use-cross-phase-persistent demo-ns) + #t) + +;; ---------------------------------------- +;; for-label imports + +(eval-module-declaration '(module provides-title '#%kernel + (#%provide title) + (define-values (title) "Of Mice and Men"))) + +(eval-module-declaration '(module imports-title-for-label '#%kernel + (#%require (for-label 'provides-title)) + (print (identifier-binding (quote-syntax title))) (newline) + (print (cadr (identifier-label-binding (quote-syntax title)))) (newline))) + +(check-print + (namespace-require ''imports-title-for-label demo-ns) + #f + 'title) + +;; ---------------------------------------- +;; namespace-attach + +(eval-module-declaration '(module provides-random-r '#%kernel + (define-values (r) (random)) + (#%provide r))) + + +(define random-r (parameterize ([current-namespace demo-ns]) + (dynamic-require ''provides-random-r 'r))) +(unless (equal? random-r (parameterize ([current-namespace demo-ns]) + (dynamic-require ''provides-random-r 'r))) + (error "not the same random number")) +'ok-dynamic + +(define other-ns (make-namespace)) +(namespace-attach-module demo-ns ''provides-random-r other-ns) + +(unless (equal? random-r (parameterize ([current-namespace other-ns]) + (dynamic-require ''provides-random-r 'r))) + (error "not the same random number after attach")) +'ok-instance + +(namespace-attach-module demo-ns ''provides-random-r other-ns) ; re-attach ok +'ok-reattach + +(define third-ns (make-namespace)) +(namespace-attach-module-declaration demo-ns ''provides-random-r third-ns) + +(when (equal? random-r (parameterize ([current-namespace third-ns]) + (dynamic-require ''provides-random-r 'r))) + (error "the same random number after declaration attach")) +'ok-declaration + +(namespace-attach-module-declaration demo-ns ''provides-random-r third-ns) ; re-attach ok +(check-error + (namespace-attach-module demo-ns ''provides-random-r third-ns) + #rx"different instance") + +(define has-already-ns (make-namespace)) +(namespace-attach-module (current-namespace) ''#%kernel has-already-ns) +(namespace-require ''#%kernel has-already-ns) +(eval-module-declaration '(module provides-random-r '#%kernel + (define-values (r) 5) + (#%provide r)) + #:namespace has-already-ns) +(parameterize ([current-namespace has-already-ns]) + (dynamic-require ''provides-random-r 'r)) +(check-error + (namespace-attach-module-declaration demo-ns ''provides-random-r has-already-ns) + #rx"different declaration") + +;; ---------------------------------------- +;; module redeclaration + +(eval-module-declaration '(module to-be-redeclared '#%kernel + (define-values (tbr-x) 'x) + (print tbr-x) (newline))) +(check-print + (eval-expression '(#%require 'to-be-redeclared)) + 'x) + +(check-print + (eval-module-declaration '(module to-be-redeclared '#%kernel + (define-values (tbr-y) 'y) + (print tbr-y) (newline))) + 'y) + +;; ---------------------------------------- +;; module exports + +(define one-of-each-provide-at-each-phase-expr + '(module one-of-each-provide-at-each-phase '#%kernel + (#%require (for-syntax '#%kernel) + (for-meta 2 '#%kernel)) + (define-values (one) 1) + (define-values (also-one) 1) + (define-syntaxes (one-s) (quote-syntax 1)) + (begin-for-syntax + (define-values (two) 2) + (define-values (also-two) 2) + (define-syntaxes (two-s) (quote-syntax 2))) + (#%provide one one-s + (for-syntax two two-s)))) + +(eval-module-declaration one-of-each-provide-at-each-phase-expr) + +(parameterize ([current-namespace demo-ns]) + (eval-expression '(call-with-values + (lambda () (module->exports ''one-of-each-provide-at-each-phase)) + list) + #:check '(((0 (one ())) (1 (two ()))) + ((0 (one-s ())) (1 (two-s ())))))) + +(parameterize ([current-namespace demo-ns]) + (eval-expression '(module->indirect-exports ''one-of-each-provide-at-each-phase) + #:check '((0 also-one) (1 also-two)))) + +(check-value (call-with-values + (lambda () (module-compiled-exports + (compile one-of-each-provide-at-each-phase-expr demo-ns))) + list) + '(((0 (one ())) (1 (two ()))) + ((0 (one-s ())) (1 (two-s ()))))) + +(check-value (module-compiled-indirect-exports + (compile one-of-each-provide-at-each-phase-expr demo-ns)) + '((0 also-one) (1 also-two))) + +;; ---------------------------------------- +;; top-level fallbacks + +(define s-only-in-demo (namespace-syntax-introduce (datum->syntax #f 'car) demo-ns)) + +(define alt-ns (make-namespace)) +(namespace-attach-module demo-ns ''#%kernel alt-ns) + +(define s-also-in-alt (namespace-syntax-introduce s-only-in-demo alt-ns)) +(define s-only-in-alt (namespace-syntax-introduce (datum->syntax #f 'car) alt-ns)) + +(check-value (hash-ref (syntax-debug-info s-only-in-demo) 'fallbacks #f) + #f) +(check-value (hash-ref (syntax-debug-info s-only-in-alt) 'fallbacks #f) + #f) +(check-value (length (hash-ref (syntax-debug-info s-also-in-alt) 'fallbacks null)) + 1) +(check-value (list->set (hash-ref (syntax-debug-info s-also-in-alt) 'context #f)) + (set-union (list->set (hash-ref (syntax-debug-info s-only-in-demo) 'context #f)) + (list->set (hash-ref (syntax-debug-info s-only-in-alt) 'context #f)))) + +(check-value (cadr (identifier-binding s-only-in-demo)) + 'car) +(check-value (identifier-binding s-only-in-alt) + #f) +(check-value (cadr (identifier-binding s-also-in-alt)) + 'car) + +(namespace-require ''#%kernel alt-ns) +(check-value (cadr (identifier-binding s-only-in-alt)) + 'car) + +(eval-module-declaration '(module kar '#%kernel + (#%provide (rename kar car)) + (define-values (kar) 5)) + #:namespace alt-ns) +(eval-expression '(#%require 'kar) #:namespace alt-ns) +(eval-expression 'car #:namespace alt-ns + #:check 5) + +(check-value (cadr (identifier-binding s-only-in-alt)) + 'kar) +(check-value (cadr (identifier-binding s-also-in-alt)) + 'car) ; because using combined scopes is ambiguous diff --git a/racket/src/expander/eval/api.rkt b/racket/src/expander/eval/api.rkt new file mode 100644 index 0000000000..09674844e6 --- /dev/null +++ b/racket/src/expander/eval/api.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require (prefix-in direct: "main.rkt") + (prefix-in direct: "../namespace/api.rkt") + "../syntax/api.rkt" + "../namespace/namespace.rkt" + "../common/contract.rkt" + "parameter.rkt") + +;; These wrappers implement the protocol for whether to use +;; `namespace-synatx-introduce` on the argument to `eval`, etc. + +(provide eval + eval-syntax + + compile + compile-syntax + + expand + expand-syntax + + expand-to-top-form + expand-syntax-to-top-form + + expand-once + expand-syntax-once) + +(define eval + (case-lambda + [(s) ((current-eval) (intro s))] + [(s ns) + (check 'eval namespace? ns) + (parameterize ([current-namespace ns]) + ((current-eval) (intro s ns)))])) + +(define eval-syntax + (case-lambda + [(s) + (check 'eval-syntax syntax? s) + ((current-eval) s)] + [(s ns) + (check 'eval-syntax syntax? s) + (check 'eval-syntax namespace? ns) + (parameterize ([current-namespace ns]) + ((current-eval) s))])) + +(define (compile s) + ((current-compile) (intro s) #f)) + +(define (compile-syntax s) + (check 'compile-syntax syntax? s) + ((current-compile) s #f)) + +(define (expand s) + (direct:expand (intro s) (current-namespace) #t)) + +(define (expand-syntax s) + (check 'expand-syntax syntax? s) + (direct:expand s (current-namespace) #t)) + +(define (expand-once s) + (direct:expand-once (intro s))) + +(define (expand-syntax-once s) + (check 'expand-syntax-once syntax? s) + (direct:expand-once s)) + +(define (expand-to-top-form s) + (direct:expand-to-top-form (intro s))) + +(define (expand-syntax-to-top-form s) + (check 'expand-syntax-to-top-form syntax? s) + (direct:expand-to-top-form s)) + + +(define (intro given-s [ns (current-namespace)]) + (define s (if (syntax? given-s) given-s (datum->syntax #f given-s))) + (direct:namespace-syntax-introduce s ns)) diff --git a/racket/src/expander/eval/collection.rkt b/racket/src/expander/eval/collection.rkt new file mode 100644 index 0000000000..0454916dfd --- /dev/null +++ b/racket/src/expander/eval/collection.rkt @@ -0,0 +1,484 @@ +#lang racket/base +(require racket/private/check + racket/private/config + "parameter.rkt" + ;; Avoid keyword-argument variant: + (only-in '#%kernel directory-list)) + +(provide collection-path + collection-file-path + find-library-collection-paths + find-library-collection-links + + find-col-file) + +(define (relative-path-string? s) + (and (path-string? s) (relative-path? s))) + +(define (check-collection who s l) + (check who relative-path-string? + #:contract "(and/c path-string? relative-path?)" + s) + (check who (lambda (l) + (and (list? l) + (andmap relative-path-string? l))) + #:contract "(listof (and/c path-string? relative-path?))" + l)) + +(define (check-fail who fail) + (check who (procedure-arity-includes/c 1) fail)) + +;; Non-keyword variant is wrapped by a kerword variant in `racket/base` +(define/who (collection-path fail collection collection-path) + (check-collection who collection collection-path) + (check-fail who fail) + (find-col-file fail + collection collection-path + #f + #f)) + +;; Non-keyword variant is wrapped by a kerword variant in `racket/base` +(define/who (collection-file-path fail check-compiled? file-name collection collection-path) + (check who relative-path-string? + #:contract "(and/c path-string? relative-path?)" + file-name) + (check-collection who collection collection-path) + (check-fail who fail) + (find-col-file fail + collection collection-path + file-name + check-compiled?)) + +(define (get-config-table d) + (define p (and d (build-path d "config.rktd"))) + (or (and p + (file-exists? p) + (with-input-from-file p + (lambda () + (let ([v (call-with-default-reading-parameterization read)]) + (and (hash? v) + v))))) + #hash())) + +(define (get-installation-name config-table) + (hash-ref config-table + 'installation-name + (version))) + +(define (coerce-to-path p) + (cond + [(string? p) (collects-relative-path->complete-path (string->path p))] + [(bytes? p) (collects-relative-path->complete-path (bytes->path p))] + [(path? p) (collects-relative-path->complete-path p)] + [else p])) + +(define (collects-relative-path->complete-path p) + (cond + [(complete-path? p) p] + [else + (path->complete-path p (or (find-main-collects) + ;; If we get here, then something is configured wrong, + ;; and making up paths relative to the current directory + ;; is not great --- but we have to come up with some + ;; path at this point. + (current-directory)))])) + +(define (add-config-search ht key orig-l) + (define l (hash-ref ht key #f)) + (if l + (let loop ([l l]) + (cond + [(null? l) null] + [(not (car l)) (append orig-l (loop (cdr l)))] + [else (cons (coerce-to-path (car l)) (loop (cdr l)))])) + orig-l)) + +(define (find-library-collection-links) + (define ht (get-config-table (find-main-config))) + (define lf (coerce-to-path + (or (hash-ref ht 'links-file #f) + (build-path (or (hash-ref ht 'share-dir #f) + (build-path 'up "share")) + "links.rktd")))) + (append + ;; `#f' means `current-library-collection-paths': + (list #f) + ;; user-specific + (if (and (use-user-specific-search-paths) + (use-collection-link-paths)) + (list (build-path (find-system-path 'addon-dir) + (get-installation-name ht) + "links.rktd")) + null) + ;; installation-wide: + (if (use-collection-link-paths) + (add-config-search + ht + 'links-search-files + (list lf)) + null))) + +;; map from link-file names to cached information: +(define links-cache (make-weak-hash)) + +;; used for low-level exception abort below: +(define stamp-prompt-tag (make-continuation-prompt-tag 'stamp)) + +(define (file->stamp path old-stamp) + ;; Using just the file's modification date almost works as a stamp, + ;; but 1-second granularity isn't fine enough. A stamp is therefore + ;; the file content paired with a filesystem-change event (where + ;; supported), and the event lets us recycle the old stamp almost + ;; always. + (cond + [(and old-stamp + (cdr old-stamp) + (not (sync/timeout 0 (cdr old-stamp)))) + old-stamp] + [else + (call-with-continuation-prompt + (lambda () + (call-with-exception-handler + (lambda (exn) + (abort-current-continuation + stamp-prompt-tag + (if (exn:fail:filesystem? exn) + (lambda () #f) + (lambda () (raise exn))))) + (lambda () + (define dir-evt + (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? + (let loop ([path path]) + (let-values ([(base name dir?) (split-path path)]) + (and (path? base) + (if (directory-exists? base) + (filesystem-change-evt base (lambda () #f)) + (loop base))))))) + (cond + [(not (file-exists? path)) + (cons #f dir-evt)] + [else + (define evt (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? + (filesystem-change-evt path (lambda () #f)))) + (when dir-evt (filesystem-change-evt-cancel dir-evt)) + (cons (file->bytes path) + evt)])))) + stamp-prompt-tag)])) + +(define (file->bytes path) + (call-with-input-file* + path + (lambda (p) + (let ([bstr (read-bytes 8192 p)]) + (if (and (bytes? bstr) + ((bytes-length bstr) . >= . 8192)) + (apply + bytes-append + (cons + bstr + (let loop () + (let ([bstr (read-bytes 8192 p)]) + (if (eof-object? bstr) + null + (cons bstr (loop))))))) + bstr))))) + +(define (no-file-stamp? a) + (or (not a) + (not (car a)))) + +(define (get-linked-collections links-path) + ;; Use/save information in `links-cache', relying on filesystem-change events + ;; or a copy of the file to detect when the cache is stale. + (let/ec esc + (define (make-handler ts) + (lambda (exn) + (if (exn:fail? exn) + (let ([l (current-logger)]) + (when (log-level? l 'error) + (log-message l 'error + (format + "error reading collection links file ~s: ~a" + links-path + (exn-message exn)) + (current-continuation-marks)))) + (void)) + (when ts + (hash-set! links-cache links-path (cons ts #hasheq()))) + (if (exn:fail? exn) + (esc (make-hasheq)) + ;; re-raise the exception (which is probably a break) + exn))) + (call-with-exception-handler + (make-handler #f) + (lambda () + (define links-stamp+cache (hash-ref links-cache links-path '(#f . #hasheq()))) + (define a-links-stamp (car links-stamp+cache)) + (define ts (file->stamp links-path a-links-stamp)) + (cond + [(equal? ts a-links-stamp) + (cdr links-stamp+cache)] + [else + (call-with-exception-handler + (make-handler ts) + (lambda () + (call-with-default-reading-parameterization + (lambda () + (define v (if (no-file-stamp? ts) + null + (call-with-input-file* + links-path + (lambda (p) + (begin0 + (read p) + (unless (eof-object? (read p)) + (error "expected a single S-expression"))))))) + (unless (and (list? v) + (andmap (lambda (p) + (and (list? p) + (or (= 2 (length p)) + (= 3 (length p))) + (or (string? (car p)) + (eq? 'root (car p)) + (eq? 'static-root (car p))) + (path-string? (cadr p)) + (or (null? (cddr p)) + (regexp? (caddr p))))) + v)) + (error "ill-formed content")) + (define ht (make-hasheq)) + (define dir (let-values ([(base name dir?) (split-path links-path)]) + base)) + (for-each (lambda (p) + (when (or (null? (cddr p)) + (regexp-match? (caddr p) (version))) + (let ([dir (simplify-path + (path->complete-path (cadr p) dir))]) + (cond + [(eq? (car p) 'static-root) + ;; multi-collection, constant content: + (for-each + (lambda (sub) + (when (directory-exists? (build-path dir sub)) + (let ([k (string->symbol (path->string sub))]) + (hash-set! ht k (cons dir (hash-ref ht k null)))))) + (directory-list dir))] + [(eq? (car p) 'root) + ;; multi-collection, dynamic content: + ;; Add directory to the #f mapping, and also + ;; add to every existing table element (to keep + ;; the choices in order) + (unless (hash-ref ht #f #f) + (hash-set! ht #f null)) + (hash-for-each + ht + (lambda (k v) + (hash-set! ht k (cons dir v))))] + [else + ;; single collection: + (let ([s (string->symbol (car p))]) + (hash-set! ht s (cons (box dir) + (hash-ref ht s null))))])))) + v) + ;; reverse all lists: + (hash-for-each + ht + (lambda (k v) (hash-set! ht k (reverse v)))) + ;; save table & file content: + (hash-set! links-cache links-path (cons ts ht)) + ht))))]))))) + +(define (normalize-collection-reference collection collection-path) + ;; make sure that `collection' is a top-level collection name + (cond + [(string? collection) + (let ([m (regexp-match-positions #rx"/+" collection)]) + (if m + (cond + [(= (caar m) (sub1 (string-length collection))) + (values (substring collection 0 (caar m)) collection-path)] + [else + (values (substring collection 0 (caar m)) + (cons (substring collection (cdar m)) + collection-path))]) + (values collection collection-path)))] + [else + (define-values (base name dir?) (split-path collection)) + (if (eq? base 'relative) + (values name collection-path) + (normalize-collection-reference base (cons name collection-path)))])) + +(define (find-col-file fail collection-in collection-path-in file-name check-compiled?) + (define-values (collection collection-path) + (normalize-collection-reference collection-in collection-path-in)) + (define all-paths (let ([sym (string->symbol + (if (path? collection) + (path->string collection) + collection))]) + (let loop ([l (current-library-collection-links)]) + (cond + [(null? l) null] + [(not (car l)) + ;; #f is the point where we try the old parameter: + (append + (current-library-collection-paths) + (loop (cdr l)))] + [(hash? (car l)) + ;; A hash table maps a collection-name symbol + ;; to a list of paths. We need to wrap each path + ;; in a box, because that's how the code below + ;; knows that it's a single collection's directory. + ;; A hash table can also map #f to a list of paths + ;; for directories that hold collections. + (append + (map box (hash-ref (car l) sym null)) + (hash-ref (car l) #f null) + (loop (cdr l)))] + [else + (let ([ht (get-linked-collections (car l))]) + (append + ;; Table values are lists of paths and (box path)s, + ;; where a (box path) is a collection directory + ;; (instead of a directory containing collections). + (hash-ref ht sym null) + (hash-ref ht #f null) + (loop (cdr l))))])))) + (define (done p) + (if file-name (build-path p file-name) p)) + (define (*build-path-rep p c) + (if (path? p) + (build-path p c) + ;; box => from links table for c + (unbox p))) + (define (*directory-exists? orig p) + (if (path? orig) + (directory-exists? p) + ;; orig is box => from links table + #t)) + (define (to-string p) (if (path? p) (path->string p) p)) + + (let cloop ([paths all-paths] [found-col #f]) + (if (null? paths) + (if found-col + (done found-col) + (let ([rest-coll + (if (null? collection-path) + "" + (apply + string-append + (let loop ([cp collection-path]) + (if (null? (cdr cp)) + (list (to-string (car cp))) + (list* (to-string (car cp)) "/" (loop (cdr cp)))))))]) + (define-values (filter) + (lambda (f l) + (if (null? l) + null + (if (f (car l)) + (cons (car l) (filter f (cdr l))) + (filter f (cdr l)))))) + (fail + (format "collection not found\n collection: ~s\n in collection directories:~a~a" + (if (null? collection-path) + (to-string collection) + (string-append (to-string collection) "/" rest-coll)) + (apply + string-append + (map (lambda (p) + (format "\n ~a ~a" " " p)) + (let ([len (length all-paths)] + [clen (length (current-library-collection-paths))]) + (if ((- len clen) . < . 5) + all-paths + (append (current-library-collection-paths) + (list (format "... [~a additional linked and package directories]" + (- len clen)))))))) + (if (ormap box? all-paths) + (format "\n sub-collection: ~s\n in parent directories:~a" + rest-coll + (apply + string-append + (map (lambda (p) + (format "\n ~a" (unbox p))) + (filter box? all-paths)))) + ""))))) + (let ([dir (*build-path-rep (car paths) collection)]) + (if (*directory-exists? (car paths) dir) + (let ([cpath (apply build-path dir collection-path)]) + (if (if (null? collection-path) + #t + (directory-exists? cpath)) + (if file-name + (if (or (file-exists?/maybe-compiled cpath file-name + check-compiled?) + (let ([alt-file-name + (let* ([file-name (if (path? file-name) + (path->string file-name) + file-name)] + [len (string-length file-name)]) + (and (len . >= . 4) + (string=? ".rkt" (substring file-name (- len 4))) + (string-append (substring file-name 0 (- len 4)) ".ss")))]) + (and alt-file-name + (file-exists?/maybe-compiled cpath alt-file-name + check-compiled?)))) + (done cpath) + ;; Look further for specific file, but remember + ;; first found directory + (cloop (cdr paths) (or found-col cpath))) + ;; Just looking for dir; found it: + (done cpath)) + ;; sub-collection not here; try next instance + ;; of the top-level collection + (cloop (cdr paths) found-col))) + (cloop (cdr paths) found-col)))))) + +(define (file-exists?/maybe-compiled dir path check-compiled?) + (or (file-exists? (build-path dir path)) + (and check-compiled? + (let ([try-path (path-add-extension path #".zo")] + [modes (use-compiled-file-paths)] + [roots (current-compiled-file-roots)]) + (ormap (lambda (d) + (ormap (lambda (mode) + (file-exists? + (let ([p (build-path dir mode try-path)]) + (cond + [(eq? d 'same) p] + [(relative-path? d) (build-path p d)] + [else (reroot-path p d)])))) + modes)) + roots))))) + +(define (find-library-collection-paths [extra-collects-dirs null] [post-collects-dirs null]) + (let ([user-too? (use-user-specific-search-paths)] + [cons-if (lambda (f r) (if f (cons f r) r))] + [config-table (get-config-table (find-main-config))]) + (path-list-string->path-list + (if user-too? + (let ([c (environment-variables-ref (current-environment-variables) + #"PLTCOLLECTS")]) + (if c + (bytes->string/locale c #\?) + "")) + "") + (add-config-search + config-table + 'collects-search-dirs + (cons-if + (and user-too? + (build-path (find-system-path 'addon-dir) + (get-installation-name config-table) + "collects")) + (let loop ([l (append + extra-collects-dirs + (list (find-system-path 'collects-dir)) + post-collects-dirs)]) + (if (null? l) + null + (let* ([collects-path (car l)] + [v (exe-relative-path->complete-path collects-path)]) + (if v + (cons (simplify-path (path->complete-path v (current-directory))) + (loop (cdr l))) + (loop (cdr l))))))))))) diff --git a/racket/src/expander/eval/direct.rkt b/racket/src/expander/eval/direct.rkt new file mode 100644 index 0000000000..f4fa4c0f51 --- /dev/null +++ b/racket/src/expander/eval/direct.rkt @@ -0,0 +1,76 @@ +#lang racket/base +(require "../common/phase.rkt" + "../common/module-path.rkt" + "../syntax/scope.rkt" + "../syntax/module-binding.rkt" + "../expand/parsed.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../host/linklet.rkt" + "protect.rkt") + +;; Instead of going through all the work to compile, optimize, and +;; evaluate a compile-time expression, it might be easier and faster +;; to evaluate the expression directly. + +(provide can-direct-eval? + direct-eval) + +(define not-available (gensym 'not-available)) +(define (get-not-available) not-available) + +(define (can-direct-eval? p ns) + (cond + [(parsed-app? p) + (and (can-direct-eval? (parsed-app-rator p) ns) + (for/and ([r (in-list (parsed-app-rands p))]) + (can-direct-eval? r ns)))] + [(parsed-id? p) (not (eq? (get-id-value p ns) not-available))] + [(parsed-quote? p) #t] + [(parsed-quote-syntax? p) #t] + [else #f])) + +(define (direct-eval p ns) + (cond + [(parsed-app? p) + (apply (direct-eval (parsed-app-rator p) ns) + (for/list ([r (in-list (parsed-app-rands p))]) + (direct-eval r ns)))] + [(parsed-id? p) (get-id-value p ns)] + [(parsed-quote? p) (parsed-quote-datum p)] + [(parsed-quote-syntax? p) (parsed-quote-syntax-datum p)] + [else #f])) + +;; Return `not-available` if the value is not readily available. +(define (get-id-value p ns) + (define b (parsed-id-binding p)) + (cond + [(parsed-primitive-id? p) + (hash-ref (primitive-table '#%kernel) + (module-binding-sym b) + get-not-available)] + [(or (parsed-top-id? p) + (not b) + (eq? (namespace-mpi ns) + (module-binding-module b))) + (namespace-get-variable + ns + (if b (module-binding-phase b) (namespace-phase ns)) + (if b (module-binding-sym b) (syntax-e (parsed-s p))) + get-not-available)] + [else + (define mi + (namespace->module-instance ns + (module-path-index-resolve (module-binding-module b)) + (phase- (namespace-phase ns) (module-binding-phase b)))) + (cond + [(not mi) not-available] + [(check-single-require-access mi + (module-binding-phase b) + (module-binding-sym b) + (module-binding-extra-inspector b)) + (namespace-get-variable (module-instance-namespace mi) + (module-binding-phase b) + (module-binding-sym b) + get-not-available)] + [else not-available])])) diff --git a/racket/src/expander/eval/dynamic-require.rkt b/racket/src/expander/eval/dynamic-require.rkt new file mode 100644 index 0000000000..e6cae27382 --- /dev/null +++ b/racket/src/expander/eval/dynamic-require.rkt @@ -0,0 +1,129 @@ +#lang racket/base +(require "../common/phase.rkt" + "../syntax/module-binding.rkt" + "../syntax/api.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/provided.rkt" + "../common/module-path.rkt" + "../namespace/api.rkt" + "main.rkt") + +(provide dynamic-require + dynamic-require-for-syntax + default-dynamic-require-fail-thunk) + +(define (do-dynamic-require who mod-path sym [fail-k default-dynamic-require-fail-thunk]) + (unless (or (module-path? mod-path) + (module-path-index? mod-path) + (resolved-module-path? mod-path)) + (raise-argument-error who + "(or/c module-path? module-path-index? resolved-module-path?)" + mod-path)) + (unless (or (symbol? sym) + (not sym) + (equal? sym 0) + (void? sym)) + (raise-argument-error who "(or/c symbol? #f 0 void?)" sym)) + (unless (and (procedure? fail-k) (procedure-arity-includes? fail-k 0)) + (raise-argument-error who "(-> any)" fail-k)) + (define ns (current-namespace)) + (define mpi + (cond + [(module-path? mod-path) (module-path-index-join mod-path #f)] + [(module-path-index? mod-path) mod-path] + [else (module-path-index-join (resolved-module-path->module-path mod-path) #f)])) + (define mod-name (module-path-index-resolve mpi #t)) + (define phase (namespace-phase ns)) + ;; Dispatch to the variant of `dynamic-require` that is determined + ;; by the second argument: + (cond + [(not sym) + ;; Run phase 0; don't visit or make available + (namespace-module-instantiate! ns mpi phase #:run-phase phase + #:otherwise-available? #f)] + [(equal? sym 0) + ;; Run phase 0, also make available + (namespace-module-instantiate! ns mpi phase #:run-phase phase)] + [(void? sym) + ;; Just visit + (namespace-module-visit! ns mpi phase #:visit-phase phase)] + [else + ;; Extract a particular value via phase 0.... + (define m (namespace->module ns mod-name)) + (unless m (raise-unknown-module-error 'dynamic-require mod-name)) + (define binding/p (hash-ref (hash-ref (module-provides m) 0 #hasheq()) + sym + #f)) + (cond + [(not binding/p) + (if (eq? fail-k default-dynamic-require-fail-thunk) + (raise-arguments-error 'dynamic-require + "name is not provided" + "name" sym + "module" mod-name) + (fail-k))] + [else + ;; The provided binding may correspond to an immediate provide, + ;; or it may by re-provided from a different module + (define binding (provided-as-binding binding/p)) + (define ex-sym (module-binding-sym binding)) + (define ex-phase (module-binding-phase binding)) + (namespace-module-instantiate! ns mpi phase #:run-phase phase) + (define ex-mod-name (module-path-index-resolve + (module-path-index-shift + (module-binding-module binding) + (module-self m) + mpi))) + (define m-ns (namespace->module-namespace ns ex-mod-name (phase- phase ex-phase) + #:complain-on-failure? #t)) + ;; Before continuing, make sure that we're allowed to access the binding + (define ex-m (namespace->module ns ex-mod-name)) + (define access (or (module-access ex-m) (module-compute-access! ex-m))) + (when (and (not (eq? 'provided (hash-ref (hash-ref access ex-phase #hasheq()) ex-sym #f))) + (and (not (inspector-superior? (current-code-inspector) (namespace-inspector m-ns))) + (not (and (module-binding-extra-inspector binding) + (inspector-superior? (module-binding-extra-inspector binding) + (namespace-inspector m-ns)))))) + (raise-arguments-error 'dynamic-require + "name is protected" + "name" sym + "module" mod-name)) + (define (fail) + (if (eq? fail-k default-dynamic-require-fail-thunk) + (raise-arguments-error 'dynamic-require + "name's binding is missing" + "name" sym + "module" mod-name) + (fail-k))) + (cond + [(not (provided-as-transformer? binding/p)) + (namespace-get-variable m-ns ex-phase ex-sym fail)] + [else + (define missing (gensym 'missing)) + (namespace-module-visit! ns mpi phase #:visit-phase phase) + (define t (namespace-get-transformer m-ns ex-phase ex-sym missing)) + (cond + [(eq? t missing) + (fail)] + [else + ;; Found transformer; expand in a fresh namespace + (define tmp-ns (new-namespace ns)) + (define mod-path (resolved-module-path->module-path mod-name)) + (namespace-require mod-path tmp-ns) + (parameterize ([current-namespace tmp-ns]) + (eval sym tmp-ns))])])])])) + +;; The `dynamic-require` function cheats by recognizing this failure +;; thunk and substituting a more specific error: +(define (default-dynamic-require-fail-thunk) + (error "failed")) + +(define (dynamic-require mod-path sym [fail-k default-dynamic-require-fail-thunk]) + (do-dynamic-require 'dynamic-require mod-path sym fail-k)) + +(define (dynamic-require-for-syntax mod-path sym [fail-k default-dynamic-require-fail-thunk]) + (parameterize ([current-namespace + (let ([ns (current-namespace)]) + (namespace->namespace-at-phase ns (add1 (namespace-phase ns))))]) + (do-dynamic-require 'dynamic-require-for-syntax mod-path sym fail-k))) diff --git a/racket/src/expander/eval/load.rkt b/racket/src/expander/eval/load.rkt new file mode 100644 index 0000000000..c2233ee259 --- /dev/null +++ b/racket/src/expander/eval/load.rkt @@ -0,0 +1,62 @@ +#lang racket/base +(require racket/private/check + racket/private/executable-path + "module.rkt" + "parameter.rkt") + +(provide load + load-extension + load/use-compiled + embedded-load) + +(define/who (load s) + (check who path-string? s) + (call-with-current-load-relative-directory + s + (lambda () + ((current-load) s #f)))) + +(define/who (load-extension s) + (check who path-string? s) + (call-with-current-load-relative-directory + s + (lambda () + ((current-load-extension) s #f)))) + +(define (call-with-current-load-relative-directory p thunk) + (define-values (base name dir?) (split-path p)) + (parameterize ([current-load-relative-directory + (if (eq? base 'relative) + (current-directory) + (path->complete-path base))]) + (thunk))) + +;; ---------------------------------------- + +(define/who (load/use-compiled f) + (check who path-string? f) + ((current-load/use-compiled) f #f)) + +;; used for the -k command-line argument: +(define (embedded-load start end str as-predefined?) + (let* ([s (if str + str + (let* ([sp (find-system-path 'exec-file)] + [exe (find-executable-path sp #f)] + [start (or (string->number start) 0)] + [end (or (string->number end) 0)]) + (with-input-from-file exe + (lambda () + (file-position (current-input-port) start) + (read-bytes (max 0 (- end start)))))))] + [p (open-input-bytes s)]) + (let loop () + (let ([e (parameterize ([read-accept-compiled #t] + [read-accept-reader #t] + [read-accept-lang #t] + [read-on-demand-source #t]) + (read p))]) + (unless (eof-object? e) + (parameterize ([current-module-declare-as-predefined as-predefined?]) + ((current-eval) e)) + (loop)))))) diff --git a/racket/src/expander/eval/main.rkt b/racket/src/expander/eval/main.rkt new file mode 100644 index 0000000000..029e736e8c --- /dev/null +++ b/racket/src/expander/eval/main.rkt @@ -0,0 +1,398 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../syntax/module-binding.rkt" + "../syntax/api.rkt" + (only-in "../syntax/taint.rkt" + [syntax-disarm raw:syntax-disarm] + [syntax-rearm raw:syntax-rearm]) + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/core.rkt" + "../common/phase.rkt" + "../syntax/match.rkt" + "../expand/context.rkt" + (rename-in "../expand/main.rkt" [expand expand-in-context]) + "../compile/main.rkt" + "../compile/compiled-in-memory.rkt" + "top.rkt" + "module.rkt" + "../common/module-path.rkt" + "../host/linklet.rkt" + "../syntax/bulk-binding.rkt" + "../common/contract.rkt" + "../namespace/api.rkt" + "../expand/lift-context.rkt" + "../expand/require.rkt" + "../expand/require+provide.rkt" + "reflect.rkt" + "../expand/log.rkt" + "../expand/parsed.rkt" + "../common/performance.rkt") + +(provide eval + compile + expand + expand-once + expand-to-top-form + + compile-to-linklets) + +;; This `eval` is suitable as an eval handler that will be called by +;; the `eval` and `eval-syntax` of '#%kernel. +;; [Don't use keyword arguments here, because the function is +;; exported for use by an embedding runtime system.] +(define (eval s [ns (current-namespace)] [compile (lambda (s ns) + (compile s ns #f))]) + (cond + [(or (compiled-in-memory? s) + (linklet-directory? s) + (linklet-bundle? s)) + (eval-compiled s ns)] + [(and (syntax? s) + (or (compiled-in-memory? (syntax-e s)) + (linklet-directory? (syntax-e s)) + (linklet-bundle? (syntax-e s)))) + (eval-compiled (syntax->datum s) ns)] + [else + (per-top-level s ns + #:single (lambda (s ns tail?) + (eval-compiled (compile s ns) ns tail?)) + #:observable? #f)])) + +(define (eval-compiled c ns [as-tail? #t]) + (cond + [(compiled-module-expression? c) + (eval-module c #:namespace ns)] + [else + (eval-top c ns eval-compiled as-tail?)])) + +;; This `compile` is suitable as a compile handler that will be called +;; by the `compile` and `compile-syntax` of '#%kernel +;; [Don't use keyword arguments here, because the function is +;; exported for use by an embedding runtime system.] +(define (compile s [ns (current-namespace)] [serializable? #t] [expand expand] [to-source? #f]) + ;; The given `s` might be an already-compiled expression because it + ;; went through some strange path, such as a `load` on a bytecode + ;; file, which would wrap `#%top-interaction` around the compiled + ;; expression where the expansion just discards the wrapper + (define cs + (cond + [(compiled-expression? s) (list s)] + [(and (syntax? s) + (compiled-expression? (syntax-e s))) + (list (syntax-e s))] + [else + (per-top-level s ns + #:single (lambda (s ns as-tail?) + (list (compile-single s ns expand + serializable? + to-source?))) + #:combine append + #:observable? #f)])) + (if (and (= 1 (length cs)) + (not (compiled-multiple-top? (car cs)))) + (car cs) + (compiled-tops->compiled-top cs + #:to-source? to-source? + #:merge-serialization? serializable? + #:namespace ns))) + +;; Result is a hash table containing S-expressons that may have +;; "correlated" parts in the sense of "host/correlate.rkt"; use +;; `datum->correlated` plus `correlated->datum` to get a plain +;; S-expression +(define (compile-to-linklets s [ns (current-namespace)]) + (compile s ns #t expand #t)) + +;; To communicate lifts from `expand-single` to `compile-single`: +(struct lifted-parsed-begin (seq last)) + +(define (compile-single s ns expand serializable? to-source?) + (define exp-s (expand s ns #f #t serializable?)) + (let loop ([exp-s exp-s]) + (cond + [(parsed-module? exp-s) + (compile-module exp-s (make-compile-context #:namespace ns) + #:serializable? serializable? + #:to-source? to-source?)] + [(lifted-parsed-begin? exp-s) + ;; expansion must have captured lifts + (compiled-tops->compiled-top + (for/list ([e (in-list (append (lifted-parsed-begin-seq exp-s) + (list (lifted-parsed-begin-last exp-s))))]) + (loop e)) + #:to-source? to-source?)] + [else + (compile-top exp-s (make-compile-context #:namespace ns) + #:serializable? serializable? + #:to-source? to-source?)]))) + +;; This `expand` is suitable as an expand handler (if such a thing +;; existed) to be called by `expand` and `expand-syntax`. +;; [Don't use keyword arguments here, because the function is +;; exported for use by an embedding runtime system.] +(define (expand s [ns (current-namespace)] [observable? #f] [to-parsed? #f] [serializable? #f]) + (when observable? (log-expand-start)) + (per-top-level s ns + #:single (lambda (s ns as-tail?) (expand-single s ns observable? to-parsed? serializable?)) + #:combine cons + #:wrap re-pair + #:observable? observable?)) + +(define (expand-single s ns observable? to-parsed? serializable?) + (define rebuild-s (keep-properties-only s)) + (define ctx (make-expand-context ns + #:to-parsed? to-parsed? + #:for-serializable? serializable? + #:observable? observable?)) + (define-values (require-lifts lifts exp-s) (expand-capturing-lifts s ctx)) + (cond + [(and (null? require-lifts) (null? lifts)) exp-s] + [to-parsed? + (wrap-lifts-as-lifted-parsed-begin require-lifts + lifts + exp-s rebuild-s + #:adjust-form (lambda (form) + (expand-single form ns observable? to-parsed? serializable?)))] + [else + (log-top-lift-begin-before ctx require-lifts lifts exp-s ns) + (define new-s + (wrap-lifts-as-begin (append require-lifts lifts) + #:adjust-form (lambda (form) + (log-expand ctx 'next) + (expand-single form ns observable? to-parsed? serializable?)) + #:adjust-body (lambda (form) + (cond + [to-parsed? form] + [else + (log-expand ctx 'next) + ;; This re-expansion should be unnecessary, but we do it + ;; for a kind of consistentcy with `expand/capture-lifts` + ;; and for expansion observers + (expand-single form ns observable? to-parsed? serializable?)])) + exp-s + (namespace-phase ns))) + (log-top-begin-after ctx new-s) + new-s])) + +(define (expand-once s [ns (current-namespace)]) + (per-top-level s ns + #:single (lambda (s ns as-tail?) (expand-single-once s ns)) + #:combine cons + #:wrap re-pair + #:just-once? #t + #:observable? #t)) + +(define (expand-single-once s ns) + (define-values (require-lifts lifts exp-s) + (expand-capturing-lifts s (struct*-copy expand-context (make-expand-context ns #:observable? #t) + [just-once? #t]))) + (cond + [(and (null? require-lifts) (null? lifts)) exp-s] + [else + (wrap-lifts-as-begin (append require-lifts lifts) + exp-s + (namespace-phase ns))])) + +(define (expand-to-top-form s [ns (current-namespace)]) + ;; Use `per-top-level` for immediate expansion and lift handling, + ;; but `#:single #f` makes it return immediately + (log-expand-start) + (per-top-level s ns + #:single #f + #:quick-immediate? #f + #:observable? #t)) + +;; ---------------------------------------- + +;; Top-level compilation and evaluation, which involves partial +;; expansion to detect `begin` and `begin-for-syntax` to interleave +;; expansions +(define (per-top-level given-s ns + #:single single ; handle discovered form; #f => stop after immediate + #:combine [combine #f] ; how to cons a recur result, or not + #:wrap [wrap #f] ; how to wrap a list of recur results, or not + #:just-once? [just-once? #f] ; single expansion step + #:quick-immediate? [quick-immediate? #t] + #:serializable? [serializable? #f] ; for module+submodule expansion + #:observable? observable?) + (define s (maybe-intro given-s ns)) + (define ctx (make-expand-context ns #:observable? observable?)) + (define phase (namespace-phase ns)) + (let loop ([s s] [phase phase] [ns ns] [as-tail? #t]) + (define tl-ctx (struct*-copy expand-context ctx + [phase phase] + [namespace ns] + [just-once? just-once?] + [for-serializable? serializable?])) + (define wb-s (and just-once? s)) + (define-values (require-lifts lifts exp-s) + (if (and quick-immediate? + ;; To avoid annoying the macro stepper, bail out quietly + ;; if the input is obviously a core form + (core-form-sym s phase)) + (values null null s) + (expand-capturing-lifts s (struct*-copy expand-context tl-ctx + [only-immediate? #t] + [def-ctx-scopes (box null)] ; discarding is ok + [phase phase] + [namespace ns])))) + (define disarmed-exp-s (raw:syntax-disarm exp-s)) + (cond + [(or (pair? require-lifts) (pair? lifts)) + ;; Fold in lifted definitions and try again + (define new-s (wrap-lifts-as-begin (append require-lifts lifts) + exp-s + phase)) + (log-expand tl-ctx 'lift-loop new-s) + (if just-once? + new-s + (loop new-s phase ns as-tail?))] + [(not single) exp-s] + [(and just-once? (not (eq? exp-s wb-s))) exp-s] + [else + (case (core-form-sym disarmed-exp-s phase) + [(begin) + (log-top-begin-before ctx exp-s) + (define-match m disarmed-exp-s '(begin e ...)) + ;; Map `loop` over the `e`s, but in the case of `eval`, + ;; tail-call for last one: + (define (begin-loop es) + (cond + [(null? es) (if combine null (void))] + [(and (not combine) (null? (cdr es))) + (loop (car es) phase ns as-tail?)] + [else + (log-expand tl-ctx 'next) + (define a (if combine + (loop (car es) phase ns #f) + (begin + ;; Allow any number of results: + (loop (car es) phase ns #f) + (void)))) + (if combine + (combine a (begin-loop (cdr es))) + (begin-loop (cdr es)))])) + (cond + [wrap + (define new-s (wrap (m 'begin) exp-s (begin-loop (m 'e)))) + (log-top-begin-after tl-ctx new-s) + new-s] + [else (begin-loop (m 'e))])] + [(begin-for-syntax) + (define-match m disarmed-exp-s '(begin-for-syntax e ...)) + (define next-phase (add1 phase)) + (define next-ns (namespace->namespace-at-phase ns next-phase)) + (when quick-immediate? + ;; In case `expand-capturing-lifts` didn't already: + (namespace-visit-available-modules! ns)) + (namespace-visit-available-modules! next-ns) ; to match old behavior for empty body + (define l + (for/list ([s (in-list (m 'e))]) + (loop s next-phase next-ns #f))) + (cond + [wrap (wrap (m 'begin-for-syntax) exp-s l)] + [combine l] + [else (void)])] + [else + (single exp-s ns as-tail?)])]))) + +;; Add scopes to `s` if it's not syntax: +(define (maybe-intro s ns) + (if (syntax? s) + s + (namespace-syntax-introduce (datum->syntax #f s) ns))) + +(define (re-pair form-id s r) + (raw:syntax-rearm + (datum->syntax (raw:syntax-disarm s) + (cons form-id r) + s + s) + s)) + +;; ---------------------------------------- + +(define (expand-capturing-lifts s ctx) + (performance-region + ['expand 'top] + + (define ns (expand-context-namespace ctx)) + (namespace-visit-available-modules! ns) + + (define lift-ctx (make-lift-context (make-top-level-lift ctx))) + (define require-lift-ctx (make-require-lift-context + (namespace-phase ns) + (make-parse-top-lifted-require ns))) + (define exp-s + (expand-in-context s (struct*-copy expand-context ctx + [lifts lift-ctx] + [module-lifts lift-ctx] + [require-lifts require-lift-ctx]))) + (values (get-and-clear-require-lifts! require-lift-ctx) + (get-and-clear-lifts! lift-ctx) + exp-s))) + +(define (make-parse-top-lifted-require ns) + (lambda (s phase) + ;; We don't "hide" this require in the same way as + ;; a top-level `#%require`, because it's already + ;; hidden in the sense of having an extra scope + (define-match m (raw:syntax-disarm s) '(#%require req)) + (parse-and-perform-requires! (list (m 'req)) s + ns phase #:run-phase phase + (make-requires+provides #f) + #:who 'require))) + +(define (wrap-lifts-as-lifted-parsed-begin require-lifts + lifts + exp-s rebuild-s + #:adjust-form adjust-form) + (lifted-parsed-begin (append + (for/list ([req (in-list require-lifts)]) + (parsed-require req)) + (for/list ([ids+syms+rhs (in-list (get-lifts-as-lists lifts))]) + (define exp-rhs (adjust-form (caddr ids+syms+rhs))) + (define just-rhs (if (lifted-parsed-begin? exp-rhs) + (lifted-parsed-begin-last exp-rhs) + exp-rhs)) + (define dv + (parsed-define-values rebuild-s + (car ids+syms+rhs) + (cadr ids+syms+rhs) + just-rhs)) + (if (lifted-parsed-begin? exp-rhs) + (struct-copy lifted-parsed-begin exp-rhs + [last dv]) + dv))) + exp-s)) + +(define (log-top-lift-begin-before ctx require-lifts lifts exp-s ns) + (log-expand... + ctx + (lambda (obs) + (define new-s (wrap-lifts-as-begin (append require-lifts lifts) + exp-s + (namespace-phase ns))) + (...log-expand obs ['lift-loop new-s]) + (log-top-begin-before ctx new-s)))) + +(define (log-top-begin-before ctx new-s) + (log-expand... + ctx + (lambda (obs) + (define-match m new-s '(begin e ...)) + (...log-expand obs + ['visit new-s] ['resolve (m 'begin)] + ['enter-prim new-s] ['prim-begin] + ['enter-list (datum->syntax #f (m 'e) new-s)])))) + +(define (log-top-begin-after ctx new-s) + (log-expand... + ctx + (lambda (obs) + (define-match m new-s '(begin e ...)) + (log-expand* ctx + ['exit-list (datum->syntax #f (m 'e) new-s)] + ['exit-prim new-s] + ['return new-s])))) diff --git a/racket/src/expander/eval/module-cache.rkt b/racket/src/expander/eval/module-cache.rkt new file mode 100644 index 0000000000..89c4c7a19b --- /dev/null +++ b/racket/src/expander/eval/module-cache.rkt @@ -0,0 +1,30 @@ +#lang racket/base + +;; The module cache lets us avoid reloading ".zo" files when +;; we have the relevant data handy in memory. The "eval/module.rkt" +;; module installs entries, and the default load handler in +;; "boot/load-handler.rkt" consults the cache. + +(provide make-module-cache-key + module-cache-set! + module-cache-ref) + +(define module-cache (make-weak-hash)) + +(define (make-module-cache-key hash-code) + ;; The result is preserved to retain the cache entry, and + ;; found in `module-cache-ref` by `equal?` comparsion. + ;; The current load-relative directory is part of the + ;; key because the bytecode form can have bulk bindings + ;; in syntax objects that refer to `require`s that are + ;; relative to the enclosing module, and that part of + ;; the syntax object is unmarshaled once and used for + ;; all instances of the module. + (and hash-code (list hash-code (current-load-relative-directory)))) + +(define (module-cache-set! key proc) + (hash-set! module-cache key (make-ephemeron key proc))) + +(define (module-cache-ref key) + (define e (hash-ref module-cache key #f)) + (and e (ephemeron-value e))) diff --git a/racket/src/expander/eval/module-read.rkt b/racket/src/expander/eval/module-read.rkt new file mode 100644 index 0000000000..f8c9db3105 --- /dev/null +++ b/racket/src/expander/eval/module-read.rkt @@ -0,0 +1,67 @@ +#lang racket/base +(require "../syntax/api.rkt" + "main.rkt" + "reflect.rkt" + "../namespace/api.rkt" + "../read/primitive-parameter.rkt") + +(provide with-module-reading-parameterization + raise-wrong-module-name + check-module-form) + +(define (with-module-reading-parameterization thunk) + (parameterize ([read-accept-reader #t] + [read-accept-lang #t] + [read-accept-compiled #t] + ;; Would be set by `call-with-default-reading-parameterization`, + ;; but we need to set them in our own reader, not the host's: + [read-case-sensitive #t] + [read-square-bracket-as-paren #t] + [read-curly-brace-as-paren #t] + [read-square-bracket-with-tag #f] + [read-curly-brace-with-tag #f] + [read-accept-box #t] + [read-accept-bar-quote #t] + [read-accept-graph #t] + [read-decimal-as-inexact #t] + [read-cdot #f] + [read-accept-dot #t] + [read-accept-infix-dot #t] + [read-accept-quasiquote #t] + [current-readtable #f]) + (thunk))) + +(define (raise-wrong-module-name filename expected-name name) + (error 'load-handler + "expected a `module' declaration for `~a' in ~s, found: ~a" + expected-name filename name)) + +(define (check-module-form exp filename) + (cond [(or (eof-object? exp) (eof-object? (syntax-e exp))) + (and filename + (error 'load-handler + (string-append "expected a `module' declaration, but found end-of-file\n" + " file: ~a") + filename))] + [(compiled-module-expression? (syntax-e exp)) + ;; It's fine: + exp] + [(and (syntax? exp) + (pair? (syntax-e exp)) + (eq? 'module (syntax-e (car (syntax-e exp)))) + (let* ([r (cdr (syntax-e exp))] + [r (if (syntax? r) (syntax-e r) r)]) + (and (pair? r) + (identifier? (car r))))) + ;; It's ok; need to install a specific `module' binding: + (datum->syntax exp + (cons (namespace-module-identifier) + (cdr (syntax-e exp))) + exp + exp)] + [else + (and filename + (error 'default-load-handler + (string-append "expected a `module' declaration, but found something else\n" + " file: ~a") + filename))])) diff --git a/racket/src/expander/eval/module.rkt b/racket/src/expander/eval/module.rkt new file mode 100644 index 0000000000..f2108e3e91 --- /dev/null +++ b/racket/src/expander/eval/module.rkt @@ -0,0 +1,397 @@ +#lang racket/base +(require racket/promise + "../common/performance.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/inspector.rkt" + "../common/phase.rkt" + "../compile/module-use.rkt" + "../compile/reserved-symbol.rkt" + "../common/module-path.rkt" + "../compile/serialize.rkt" + "../host/linklet.rkt" + "../compile/instance.rkt" + "../compile/compiled-in-memory.rkt" + "../expand/context.rkt" + "../expand/root-expand-context.rkt" + "root-context.rkt" + "protect.rkt" + "module-cache.rkt") + +;; Run a representation of top-level code as produced by `compile-module`; +;; see "compile/main.rkt" and "compile/module.rkt" + +(provide eval-module + compiled-module->declaration-instance + compiled-module->h+declaration-instance + compiled-module->h + current-module-declare-as-predefined) + +;; Modules that are defined via `embedded-load` can be "predefined", +;; because they can be defined in every place as the embedded load +;; is replayed in each place +(define current-module-declare-as-predefined (make-parameter #f)) + +(define (eval-module c + #:namespace [ns (current-namespace)] + #:with-submodules? [with-submodules? #t] + #:supermodule-name [supermodule-name #f]) ; for submodules declared with module + (performance-region + ['eval 'module] + + (define-values (dh h data-instance declaration-instance) + (compiled-module->dh+h+data-instance+declaration-instance c)) + + (define syntax-literals-data-instance + (if (compiled-in-memory? c) + (make-syntax-literal-data-instance-from-compiled-in-memory c) + (let ([l (hash-ref h 'stx-data #f)]) + (cond + [l (instantiate-linklet (eval-linklet l) + (list deserialize-instance + data-instance))] + [(eq? (hash-ref h 'module->namespace #f) 'empty) + empty-syntax-literals-instance/empty-namespace] + [else + empty-syntax-literals-data-instance])))) + + (define (decl key) + (instance-variable-value declaration-instance key)) + + (define pre-submodule-names (hash-ref h 'pre null)) + (define post-submodule-names (hash-ref h 'post null)) + (define default-name (hash-ref h 'name 'module)) + + (define cache-key (make-module-cache-key + (and + ;; We expect a hash code only for a module + ;; loaded independently from its submodules: + (null? pre-submodule-names) + (null? post-submodule-names) + (hash-ref h 'hash-code #f)))) + + (define cross-phase-persistent? (hash-ref h 'cross-phase-persistent? #f)) + (define min-phase (hash-ref h 'min-phase 0)) + (define max-phase (hash-ref h 'max-phase 0)) + (define language-info (hash-ref h 'language-info #f)) + + ;; Evaluate linklets, so that they're JITted just once (on demand). + ;; Also, filter the bundle hash to just the phase-specific linklets, so that + ;; we don't retain other info --- especially the syntax-literals linklet. + (define phases-h (for*/hash ([phase-level (in-range min-phase (add1 max-phase))] + [v (in-value (hash-ref h phase-level #f))] + #:when v) + (values phase-level (eval-linklet v)))) + (define syntax-literals-linklet (let ([l (hash-ref h 'stx #f)]) + (and l (eval-linklet l)))) + + (define extra-inspector (and (compiled-in-memory? c) + (compiled-in-memory-compile-time-inspector c))) + (define phase-to-link-extra-inspectorsss + (if (compiled-in-memory? c) + (compiled-in-memory-phase-to-link-extra-inspectorsss c) + #hasheqv())) + + (define requires (decl 'requires)) + (define provides (decl 'provides)) + (define original-self (decl 'self-mpi)) + (define phase-to-link-modules (decl 'phase-to-link-modules)) + + (define create-root-expand-context-from-module ; might be used to create root-expand-context + (make-create-root-expand-context-from-module requires phases-h)) + + (define declare-submodules + ;; If there's no `dh`, then it's important not to retain a reference to + ;; `c`, which could cause the serialized form of syntax objects to + ;; be retained after deserialization and reachable from the module cache; + ;; if it's there's a `dh`, though, then we won't be in the module cache + (if dh + ;; Callback to declare submodules: + (lambda (ns names declare-name pre?) + (if (compiled-in-memory? c) + (for ([c (in-list (if pre? + (compiled-in-memory-pre-compiled-in-memorys c) + (compiled-in-memory-post-compiled-in-memorys c)))]) + (eval-module c #:namespace ns #:supermodule-name declare-name)) + (for ([name (in-list names)]) + (define sm-cd (hash-ref dh name #f)) + (unless sm-cd (error "missing submodule declaration:" name)) + (eval-module sm-cd #:namespace ns #:supermodule-name declare-name)))) + ;; Dummy callback to avoid retaining anything: + void)) + + ;; At this point, we've prepared everything anout the module that we + ;; can while staying independent of a specific declaration or + ;; specific instance. If we have a hash key for this module, we can + ;; stash `declare-this-module` for potential reuse later. + (define declare-this-module + (lambda (ns) ; namespace for declaration + (define m (make-module #:source-name (current-module-declare-source) + #:self original-self + #:requires requires + #:provides provides + #:language-info language-info + #:min-phase-level min-phase + #:max-phase-level max-phase + #:cross-phase-persistent? cross-phase-persistent? + #:predefined? (current-module-declare-as-predefined) + #:submodule-names (append pre-submodule-names post-submodule-names) + #:supermodule-name supermodule-name + #:get-all-variables (lambda () (get-all-variables phases-h)) + #:phase-level-linklet-info-callback + (lambda (phase-level ns insp) + (module-linklet-info (hash-ref phases-h phase-level #f) + (hash-ref phase-to-link-modules phase-level #f) + original-self + insp + extra-inspector + (hash-ref phase-to-link-extra-inspectorsss phase-level #f))) + #:force-bulk-binding-callback + (lambda (bulk-binding-registry) + ;; Avoids a leak of some namespace's bulk-binding registry into the + ;; deserialized syntax of the module, but module caching can still allow + ;; a namespace's bulk-binding registry to get saved by the module's + ;; deserialized syntax. + (force-syntax-deserialize syntax-literals-data-instance bulk-binding-registry)) + #:prepare-instance-callback + (lambda (data-box ns phase-shift self bulk-binding-registry insp) + (unless (unbox data-box) + (init-instance-data! data-box cache-key ns + syntax-literals-linklet data-instance syntax-literals-data-instance + phase-shift original-self self bulk-binding-registry insp + create-root-expand-context-from-module))) + #:instantiate-phase-callback + (lambda (data-box ns phase-shift phase-level self bulk-binding-registry insp) + (performance-region + ['eval 'instantiate] + (define syntax-literals-instance (instance-data-syntax-literals-instance + (unbox data-box))) + (define phase-linklet (hash-ref phases-h phase-level #f)) + + (when phase-linklet + (define module-uses (hash-ref phase-to-link-modules phase-level)) + (define-values (import-module-instances import-instances) + (for/lists (mis is) ([mu (in-list module-uses)]) + (namespace-module-use->module+linklet-instances + ns mu + #:shift-from original-self + #:shift-to self + #:phase-shift + (phase+ (phase- phase-level (module-use-phase mu)) + phase-shift)))) + + (check-require-access phase-linklet #:skip-imports 2 + module-uses import-module-instances insp + extra-inspector + (hash-ref phase-to-link-extra-inspectorsss phase-level #f)) + + (define module-body-instance-instance + (make-module-body-instance-instance + #:set-transformer! (lambda (name val) + (namespace-set-transformer! ns (sub1 phase-level) name val)))) + + (define (instantiate-body) + (instantiate-linklet phase-linklet + (list* syntax-literals-instance + module-body-instance-instance + import-instances) + (namespace->instance ns phase-level))) + + (cond + [(zero-phase? phase-level) + (cond + [(zero-phase? phase-shift) + (instantiate-body)] + [else + ;; Need to set the current namespace so that it has the + ;; right phase + (parameterize ([current-namespace ns]) + (instantiate-body))])] + [else + ;; For phase level 1 and up, set the expansion context + ;; to point back to the module's info: + (define ns-1 (namespace->namespace-at-phase ns (phase+ phase-shift (sub1 phase-level)))) + (parameterize ([current-expand-context (delay (make-expand-context ns-1))] + [current-namespace ns] + [current-module-code-inspector insp]) + (instantiate-body))])))))) + + (define declare-name (substitute-module-declare-name default-name)) + + (when with-submodules? + (declare-submodules ns pre-submodule-names declare-name #t)) + + (declare-module! ns + m + declare-name + #:with-submodules? with-submodules?) + + (when with-submodules? + (declare-submodules ns post-submodule-names declare-name #f)))) + + ;; ---------------------------------------- + + ;; If we have a hash code, save the prepare module in the cache + ;; so it can be found by that hash code: + (when cache-key + (module-cache-set! cache-key declare-this-module)) + + (declare-this-module ns))) + +;; ---------------------------------------- + +;; Value in a declaration's `data-box`: +(struct instance-data (syntax-literals-instance cache-key)) + +(define (init-instance-data! data-box cache-key ns + syntax-literals-linklet data-instance syntax-literals-data-instance + phase-shift original-self self bulk-binding-registry insp + create-root-expand-context-from-module) + (when (and (not (load-on-demand-enabled)) + (not (eq? syntax-literals-data-instance empty-syntax-literals-data-instance)) + (not (eq? syntax-literals-data-instance empty-syntax-literals-instance/empty-namespace))) + (force-syntax-deserialize syntax-literals-data-instance bulk-binding-registry)) + + (define inst + (make-instance-instance + #:namespace ns + #:phase-shift phase-shift + #:self self + #:inspector insp + #:bulk-binding-registry bulk-binding-registry + #:set-transformer! (lambda (name val) (error "shouldn't get here for the root-ctx linklet")))) + + (define syntax-literals-instance + (if syntax-literals-linklet + (instantiate-linklet syntax-literals-linklet + (list deserialize-instance + data-instance + syntax-literals-data-instance + inst)) + empty-syntax-literals-instance)) + + (set-box! data-box (instance-data syntax-literals-instance cache-key)) + + (define get-encoded-root-expand-ctx + (instance-variable-value syntax-literals-instance 'get-encoded-root-expand-ctx)) + + (cond + [(eq? get-encoded-root-expand-ctx 'empty) + ;; A `#:empty-namespace` declaration requested a namespace with no initial bindings + (namespace-set-root-expand-ctx! ns (delay (make-root-expand-context)))] + [(procedure? get-encoded-root-expand-ctx) + ;; Root expand context has been preserved; deserialize it on demand + (namespace-set-root-expand-ctx! ns (delay (root-expand-context-decode-for-module + (get-encoded-root-expand-ctx))))] + [else + ;; Root expand context has not been preserved, because it can be reconstructed + ;; from module metadata; do that on demand + (namespace-set-root-expand-ctx! ns (delay (create-root-expand-context-from-module + ns phase-shift original-self self)))])) + +;; ---------------------------------------- + +(define (force-syntax-deserialize syntax-literals-data-instance bulk-binding-registry) + ;; Since on-demand loading is disabled, force deserialization + (let ([deserialize-syntax (instance-variable-value syntax-literals-data-instance deserialize-syntax-id)]) + ;; We need to make sure there's something to deserialize; if it's already done + ;; `deserialize-syntax` has been set to #f + (when deserialize-syntax + (deserialize-syntax bulk-binding-registry)))) + +;; ---------------------------------------- + +;; Returns: +;; +;; dh - hash from linklet directory to access submodules, or #f if +;; no submodules +;; +;; h - hash from the module's linklet bundle +;; +(define (compiled-module->dh+h c) + (define ld/h (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + (define dh (cond + [(linklet-directory? ld/h) + ;; has submodules + (linklet-directory->hash ld/h)] + [else + ;; no submodules + #f])) + (define h (linklet-bundle->hash (if dh + (hash-ref dh #f) + ld/h))) + + (values dh h)) + +(define (compiled-module->h c) + (define-values (dh h) + (compiled-module->dh+h c)) + h) + +;; Additionally returns: +;; +;; data-instance - provides data, either extracted from +;; compiled-in-memory or instantiated from the bundle +;; +;; declaration-instance - provides metadata, extracted from the +;; bundle and linked with `data-instance` +(define (compiled-module->dh+h+data-instance+declaration-instance c) + (define-values (dh h) (compiled-module->dh+h c)) + + (define data-instance + (if (compiled-in-memory? c) + (make-data-instance-from-compiled-in-memory c) + (instantiate-linklet (eval-linklet (hash-ref h 'data)) + (list deserialize-instance)))) + + (define declaration-instance + (if (and (compiled-in-memory? c) + (compiled-in-memory-original-self c)) + (make-declaration-instance-from-compiled-in-memory c) + (instantiate-linklet (eval-linklet (hash-ref h 'decl)) + (list deserialize-instance + data-instance)))) + + (values dh h data-instance declaration-instance)) + +(define (compiled-module->declaration-instance c) + (define-values (dh h data-instance declaration-instance) + (compiled-module->dh+h+data-instance+declaration-instance c)) + declaration-instance) + +(define (compiled-module->h+declaration-instance c) + (define-values (dh h data-instance declaration-instance) + (compiled-module->dh+h+data-instance+declaration-instance c)) + (values h declaration-instance)) + +;; ---------------------------------------- + +(define (make-data-instance-from-compiled-in-memory cim) + (make-instance 'data #f 'constant + mpi-vector-id (compiled-in-memory-mpis cim))) + +(define (make-declaration-instance-from-compiled-in-memory cim) + (make-instance 'decl #f 'constant + 'self-mpi (compiled-in-memory-original-self cim) + 'requires (compiled-in-memory-requires cim) + 'provides (compiled-in-memory-provides cim) + 'phase-to-link-modules (compiled-in-memory-phase-to-link-module-uses cim))) + +(define (make-syntax-literal-data-instance-from-compiled-in-memory cim) + (make-instance 'syntax-literal-data #f #f + deserialize-syntax-id void + deserialized-syntax-vector-id (compiled-in-memory-syntax-literals cim))) + +(define empty-syntax-literals-instance/empty-namespace + (make-instance 'empty-stx/empty-ns #f 'constant + get-syntax-literal!-id (lambda (pos) #f) + 'get-encoded-root-expand-ctx 'empty)) + +;; ---------------------------------------- + +(define (get-all-variables phases-h) + (for/hash ([(phase linklet) (in-hash phases-h)]) + (values phase + (linklet-export-variables linklet)))) diff --git a/racket/src/expander/eval/multi-top.rkt b/racket/src/expander/eval/multi-top.rkt new file mode 100644 index 0000000000..37909dc561 --- /dev/null +++ b/racket/src/expander/eval/multi-top.rkt @@ -0,0 +1,96 @@ +#lang racket/base +(require "../namespace/namespace.rkt" + "../compile/compiled-in-memory.rkt" + "../compile/serialize.rkt" + "../compile/eager-instance.rkt" + "../compile/reserved-symbol.rkt" + "../compile/namespace-scope.rkt" + "../compile/multi-top.rkt" + "../host/linklet.rkt") + +(provide create-compiled-in-memorys-using-shared-data) + +(define (create-compiled-in-memorys-using-shared-data tops data-linklet ns) + (define data-instance + (instantiate-linklet data-linklet + (list deserialize-instance + (make-eager-instance-instance + #:namespace ns + #:dest-phase (namespace-phase ns) + #:self (namespace-mpi ns) + #:bulk-binding-registry (namespace-bulk-binding-registry ns) + #:inspector (current-code-inspector))))) + + (define (data key) (instance-variable-value data-instance key)) + + (define mpi-vector (data mpi-vector-id)) + (define mpi-vector-trees (data 'mpi-vector-trees)) + (define phase-to-link-modules-vector (data 'phase-to-link-modules-vector)) + (define phase-to-link-modules-trees (data 'phase-to-link-modules-trees)) + (define syntax-literals (data 'syntax-literals)) + (define syntax-literals-trees (data 'syntax-literals-trees)) + + (define namespace-scopes (extract-namespace-scopes ns)) + + (define (construct-compiled-in-memory ld + mpi-vector-tree + phase-to-link-modules-tree + syntax-literals-tree) + (define is-module? (or (linklet-bundle? ld) + (let ([b (hash-ref (linklet-directory->hash ld) #f #f)]) + (and b (hash-ref (linklet-bundle->hash b) 'decl #f))))) + (define mpi-pos-vec (vector-ref mpi-vector-tree 0)) + (define syntax-literals-spec (vector-ref syntax-literals-tree 0)) + (define pres (if is-module? + (extract-submodules ld 'pre) + (compiled-top->compiled-tops ld))) + (define posts (if is-module? + (extract-submodules ld 'post) + null)) + (define (map-construct-compiled-in-memory l vec-pos) + (for/list ([sub-ld (in-list l)] + [mpi-vector-tree (in-list (vector-ref mpi-vector-tree vec-pos))] + [phase-to-link-modules-tree (in-list (vector-ref phase-to-link-modules-tree vec-pos))] + [syntax-literals-tree (in-list (vector-ref syntax-literals-tree vec-pos))]) + (construct-compiled-in-memory sub-ld + mpi-vector-tree + phase-to-link-modules-tree + syntax-literals-tree))) + (compiled-in-memory ld + #f ; self + #f ; requires + #f ; provides + (vector-ref phase-to-link-modules-vector (vector-ref phase-to-link-modules-tree 0)) + #f ; compile-time-inspector + #hasheqv() ; phase-to-link-extra-inspectorsss + (for/vector #:length (vector-length mpi-pos-vec) ([pos (in-vector mpi-pos-vec)]) + (vector-ref mpi-vector pos)) + (for/vector #:length (cdr syntax-literals-spec) ([i (in-range (cdr syntax-literals-spec))]) + (and syntax-literals + (vector-ref syntax-literals (+ (car syntax-literals-spec) i)))) + (map-construct-compiled-in-memory pres 1) + (map-construct-compiled-in-memory posts 2) + namespace-scopes + #f)) + + (map construct-compiled-in-memory + tops + mpi-vector-trees + phase-to-link-modules-trees + syntax-literals-trees)) + +;; ---------------------------------------- + +(define (extract-submodules ld names-key) + (cond + [(linklet-bundle? ld) + ;; no submodules + null] + [else + (define h (linklet-directory->hash ld)) + (define mod (hash-ref h #f #f)) + (unless mod (error "missing main module")) + (define mh (linklet-bundle->hash mod)) + (define names (hash-ref mh names-key null)) + (for/list ([name (in-list names)]) + (hash-ref h name (lambda () (error "missing submodule declaration:" name))))])) diff --git a/racket/src/expander/eval/parameter.rkt b/racket/src/expander/eval/parameter.rkt new file mode 100644 index 0000000000..2669ec7f67 --- /dev/null +++ b/racket/src/expander/eval/parameter.rkt @@ -0,0 +1,133 @@ +#lang racket/base +(require racket/private/check + "../common/module-path.rkt") + +(provide current-eval + current-compile + current-load + current-load/use-compiled + + current-library-collection-paths + current-library-collection-links + + use-compiled-file-paths + current-compiled-file-roots + use-compiled-file-check + use-collection-link-paths + use-user-specific-search-paths) + +(define (replace-me who) + (lambda args + (error who "this stub must be replaced"))) + +(define/who current-eval + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define/who current-compile + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-load + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-load/use-compiled + (make-parameter (replace-me who) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-library-collection-paths + (make-parameter null + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap complete-path-string? l))) + #:contract "(listof (and/c path-string? complete-path?))" + l) + (map to-path l)))) + +(define/who current-library-collection-links + (make-parameter null + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap (lambda (p) + (or (not p) + (complete-path-string? p) + (and (hash? p) + (for/and ([(k v) (in-hash p)]) + (and (or (not k) + (and (symbol? k) (module-path? k))) + (list? v) + (andmap complete-path-string? v)))))) + l))) + + #:contract (string-append + "(listof (or/c #f\n" + " (and/c path-string? complete-path?)\n" + " (hash/c (or/c (and/c symbol? module-path?) #f)\n" + " (listof (and/c path-string? complete-path?)))))") + l) + (map (lambda (p) + (cond + [(not p) #f] + [(path? p) p] + [(string? p) (string->path p)] + [else + (for/hash ([(k v) (in-hash p)]) + (values k (to-path v)))])) + l)))) + +(define/who use-compiled-file-paths + (make-parameter (list (string->path "compiled")) + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap relative-path-string? l))) + #:contract "(listof (and/c path-string? relative-path?))" + l) + (map to-path l)))) + +(define/who current-compiled-file-roots + (make-parameter '(same) + (lambda (l) + (check who (lambda (l) + (and (list? l) + (andmap (lambda (p) + (or (path-string? p) + (eq? p 'same))) + l))) + #:contract "(listof (or/c path-string? 'same))" + l) + (map to-path l)))) + +(define/who use-compiled-file-check + (make-parameter 'modify-seconds + (lambda (v) + (check who (lambda (v) (or (eq? v 'modify-seconds) (eq? v 'exists))) + #:contract "(or/c 'modify-seconds 'exists)" + v) + v))) + +(define use-collection-link-paths + (make-parameter #t (lambda (v) (and v #t)))) + +(define use-user-specific-search-paths + (make-parameter #t (lambda (v) (and v #t)))) + +(define (complete-path-string? p) + (and (path-string? p) (complete-path? p))) + +(define (relative-path-string? p) + (and (path-string? p) (relative-path? p))) + +(define (to-path p) + (if (string? p) (string->path p) p)) diff --git a/racket/src/expander/eval/protect.rkt b/racket/src/expander/eval/protect.rkt new file mode 100644 index 0000000000..039ff679a7 --- /dev/null +++ b/racket/src/expander/eval/protect.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(require "../common/set.rkt" + "../host/linklet.rkt" + "../compile/module-use.rkt" + "../common/module-path.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../compile/extra-inspector.rkt") + +;; Inspectors guarded access to protected values at expansion time. We +;; run code that references portentially protected values, we have to +;; check again, in case the compiled form was synthesized or compiled +;; in a namespace with different protections. + +;; When programs are compiled and run in memory (i.e., without going +;; through serialization), we can trust the protections checked by the +;; expander --- and the access enabled by compiling from source may be +;; greater than enabled by serialized bytecode, because inspectors can +;; be tracked as values and changed at a finer granularity. In that +;; case, a `compiled-in-memory` record holds extra-inspector +;; information that is propagated to here. + +(provide check-require-access + check-single-require-access) + +(define (check-require-access linklet #:skip-imports skip-num-imports + import-module-uses import-module-instances insp + extra-inspector ; from declaration time + extra-inspectorsss) ; per imported variable; from compilation + (for ([import-syms (in-list (list-tail (linklet-import-variables linklet) skip-num-imports))] + [mu (in-list import-module-uses)] + [mi (in-list import-module-instances)] + [extra-inspectorss (in-list (or extra-inspectorsss + ;; Use `import-module-uses` just to have the right shape + import-module-uses))]) + (define m (module-instance-module mi)) + (unless (module-no-protected? m) + (define access (or (module-access m) (module-compute-access! m))) + (for ([import-sym (in-list import-syms)]) + (define a (hash-ref (hash-ref access (module-use-phase mu) #hasheq()) + import-sym + 'unexported)) + (when (or (eq? a 'unexported) ; not provided => implicitly protected + (eq? a 'protected)) + (define guard-insp (namespace-inspector (module-instance-namespace mi))) + (unless (or + ;; Allowed at declaration time? + (inspector-superior? insp guard-insp) + ;; Allowed back at compile time? + (and extra-inspector (inspector-superior? extra-inspector guard-insp)) + ;; Allowed by inspectors attached to each referencing syntax object? + (and extra-inspectorsss + extra-inspectorss + (extra-inspectors-allow? (hash-ref extra-inspectorss import-sym #f) + guard-insp))) + (error 'link + (string-append "access disallowed by code inspector to ~a variable\n" + " variable: ~s\n" + " from module: ~a") + a + import-sym + (module-path-index-resolve (namespace-mpi (module-instance-namespace mi)))))))))) + +(define (check-single-require-access mi phase sym insp) + (define m (module-instance-module mi)) + (cond + [(module-no-protected? m) #t] + [else + (define access (or (module-access m) (module-compute-access! m))) + (define a + (hash-ref (hash-ref access phase #hasheq()) + sym + 'unexported)) + (cond + [(or (eq? a 'unexported) ; not provided => implicitly protected + (eq? a 'protected)) + (define guard-insp (namespace-inspector (module-instance-namespace mi))) + (or (and insp + (inspector-superior? insp guard-insp)) + (inspector-superior? (current-code-inspector) guard-insp))] + [else #t])])) diff --git a/racket/src/expander/eval/reflect-name.rkt b/racket/src/expander/eval/reflect-name.rkt new file mode 100644 index 0000000000..a299f8dcbb --- /dev/null +++ b/racket/src/expander/eval/reflect-name.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require "../compile/compiled-in-memory.rkt" + "../host/linklet.rkt") + +(provide module-compiled-current-name + change-module-name + module-compiled-immediate-name + rebuild-linklet-directory + compiled->linklet-directory-or-bundle) + +(define (compiled->linklet-directory-or-bundle c) + (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + +(define (module-compiled-current-name c) + (define ld (compiled->linklet-directory-or-bundle c)) + (define b (if (linklet-bundle? ld) + ld + (hash-ref (linklet-directory->hash ld) #f))) + (hash-ref (linklet-bundle->hash b) 'name)) + +(define (module-compiled-immediate-name c) + (define n (module-compiled-current-name c)) + (if (pair? n) + (car (reverse n)) + n)) + +(define (change-module-name c name prefix) + (define full-name (if (null? prefix) name (append prefix (list name)))) + (define next-prefix (if (null? prefix) (list name) full-name)) + (define (recur sub-c name) + (if (equal? (module-compiled-current-name sub-c) (append next-prefix (list name))) + sub-c + (change-module-name sub-c name next-prefix))) + (cond + [(compiled-in-memory? c) + (define (change-submodule-name sub-c) + (recur sub-c (module-compiled-immediate-name sub-c))) + (define pre-compiled-in-memorys (map change-submodule-name + (compiled-in-memory-pre-compiled-in-memorys c))) + (define post-compiled-in-memorys (map change-submodule-name + (compiled-in-memory-post-compiled-in-memorys c))) + (struct-copy compiled-in-memory c + [pre-compiled-in-memorys pre-compiled-in-memorys] + [post-compiled-in-memorys post-compiled-in-memorys] + [linklet-directory (rebuild-linklet-directory + (update-one-name + (let ([ld (compiled->linklet-directory-or-bundle c)]) + (if (linklet-bundle? ld) + ld + (hash-ref (linklet-directory->hash ld) #f))) + full-name) + #:bundle-ok? (symbol? full-name) + (append pre-compiled-in-memorys + post-compiled-in-memorys))])] + [(linklet-directory? c) + (hash->linklet-directory + (for/hasheq ([(key val) (in-hash (linklet-directory->hash c))]) + (values key + (if (not key) + (update-one-name val full-name) + (recur val key)))))] + [else + ;; linklet bundle + (update-one-name c full-name)])) + +(define (update-one-name lb name) + (hash->linklet-bundle (hash-set (linklet-bundle->hash lb) 'name name))) + +(define (rebuild-linklet-directory main submods #:bundle-ok? [bundle-ok? #f]) + (if (and (null? submods) bundle-ok?) + main + (hash->linklet-directory + (hash-set (for/fold ([ht #hasheq()]) ([submod (in-list submods)]) + (define name (module-compiled-immediate-name submod)) + (cond + [(hash-ref ht name #f) + (raise-arguments-error 'module-compiled-submodules + "change would result in duplicate submodule name" + "name" name)] + [else + (hash-set ht name (compiled->linklet-directory-or-bundle submod))])) + #f + main)))) diff --git a/racket/src/expander/eval/reflect.rkt b/racket/src/expander/eval/reflect.rkt new file mode 100644 index 0000000000..cb6b69a463 --- /dev/null +++ b/racket/src/expander/eval/reflect.rkt @@ -0,0 +1,200 @@ +#lang racket/base +(require "../compile/compiled-in-memory.rkt" + "../host/linklet.rkt" + "../common/contract.rkt" + "module.rkt" + "../namespace/provided.rkt" + "../namespace/provide-for-api.rkt" + "reflect-name.rkt") + +(provide compiled-expression? + + compiled-module-expression? + module-compiled-name + module-compiled-submodules + module-compiled-language-info + module-compiled-imports + module-compiled-exports + module-compiled-indirect-exports + module-compiled-cross-phase-persistent?) + +;; The representation of a module with its submodules is designed to +;; make reading an individual submodule (with its submodule path +;; intact) fast and convenient --- but it makes adjusting the name +;; inconvenient, because each linklet bundle for a module encodes its +;; full submodule path. The extra layer of `compiled-in-memory` +;; support for sharing and fast compile-then-eval cycles is another +;; layer of inconvenience. + +(define (compiled-expression? c) + (or (compiled-in-memory? c) + (linklet-directory? c) + (linklet-bundle? c))) + +(define (compiled-module-expression? c) + (define ld (compiled->linklet-directory-or-bundle c)) + (or (and (linklet-directory? ld) + (let ([b (hash-ref (linklet-directory->hash ld) #f #f)]) + (and b (hash-ref (linklet-bundle->hash b) 'decl #f))) + #t) + (and (linklet-bundle? ld) + (hash-ref (linklet-bundle->hash ld) 'decl #f) + #t))) + +(define module-compiled-name + (case-lambda + [(c) + (check 'module-compiled-name compiled-module-expression? c) + (module-compiled-current-name c)] + [(c name) + (check 'module-compiled-name compiled-module-expression? c) + (unless (or (symbol? name) + (and (pair? name) + (list? name) + (andmap symbol? name))) + (raise-argument-error 'module-compiled-name + "(or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))" + name)) + (define-values (i-name prefix) + (if (symbol? name) + (values name null) + (let ([r (reverse name)]) + (values (car r) (reverse (cdr r)))))) + (change-module-name c i-name prefix)])) + +(define module-compiled-submodules + (case-lambda + [(c non-star?) + (check 'module-compiled-submodules compiled-module-expression? c) + (cond + [(compiled-in-memory? c) + ;; We have a convenient `compiled-in-memory` structure + (if non-star? + (compiled-in-memory-pre-compiled-in-memorys c) + (compiled-in-memory-post-compiled-in-memorys c))] + [else + ;; We have a raw linklet directory or bundle, which is designed + ;; more for loading code than easy manipulation... + (cond + [(linklet-directory? c) + (define ht (linklet-directory->hash c)) + (define bh (linklet-bundle->hash (hash-ref ht #f))) + (define names (hash-ref bh (if non-star? 'pre 'post) null)) + (for/list ([name (in-list names)]) + (hash-ref ht name))] + [else + ;; a linklet bundle represents a module with no submodules + null])])] + [(c non-star? submods) + (check 'module-compiled-submodules compiled-module-expression? c) + (unless (and (list? submods) + (andmap compiled-module-expression? submods)) + (raise-argument-error 'module-compiled-submodules "(listof compiled-module-expression?)" submods)) + (cond + [(and (null? submods) + (or (linklet-bundle? (compiled->linklet-directory-or-bundle c)) + (and (compiled-in-memory? c) + (null? (if non-star? + (compiled-in-memory-pre-compiled-in-memorys c) + (compiled-in-memory-post-compiled-in-memorys c)))))) + ;; No change to a module without submodules + c] + [(and (compiled-in-memory? c) + (andmap compiled-in-memory? submods)) + ;; All compiled-in-memory structures, so preserve them + (define pre-compiled-in-memorys (if non-star? + submods + (compiled-in-memory-pre-compiled-in-memorys c))) + (define post-compiled-in-memorys (if non-star? + (compiled-in-memory-post-compiled-in-memorys c) + submods)) + (define n-c (normalize-to-linklet-directory c)) + (fixup-submodule-names + (struct-copy compiled-in-memory n-c + [pre-compiled-in-memorys pre-compiled-in-memorys] + [post-compiled-in-memorys post-compiled-in-memorys] + [linklet-directory (rebuild-linklet-directory + (reset-submodule-names + (hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f) + non-star? + submods) + #:bundle-ok? (symbol? (module-compiled-current-name c)) + (append pre-compiled-in-memorys + post-compiled-in-memorys))]))] + [else + ;; Not all compiled-in-memory structures, so forget whatever ones we have + (define n-c (normalize-to-linklet-directory c)) + (fixup-submodule-names + (rebuild-linklet-directory + (reset-submodule-names + (hash-ref (linklet-directory->hash (compiled->linklet-directory-or-bundle n-c)) #f) + non-star? + submods) + (map compiled->linklet-directory-or-bundle + (append (if non-star? submods (module-compiled-submodules c #t)) + (if non-star? (module-compiled-submodules c #f) submods)))))])])) + +(define (module-compiled-language-info c) + (check 'module-compiled-language-info compiled-module-expression? c) + (define h (compiled-module->h c)) + (hash-ref h 'language-info #f)) + +(define (module-compiled-imports c) + (check 'module-compiled-imports compiled-module-expression? c) + (define inst (compiled-module->declaration-instance c)) + (instance-variable-value inst 'requires)) + +(define (module-compiled-exports c) + (check 'module-compiled-imports compiled-module-expression? c) + (define inst (compiled-module->declaration-instance c)) + (provides->api-provides (instance-variable-value inst 'provides) + (instance-variable-value inst 'self-mpi))) + +(define (module-compiled-indirect-exports c) + (check 'module-compiled-indirect-imports compiled-module-expression? c) + (define-values (h inst) (compiled-module->h+declaration-instance c)) + (define min-phase (hash-ref h 'min-phase 0)) + (define max-phase (hash-ref h 'max-phase 0)) + (variables->api-nonprovides (instance-variable-value inst 'provides) + (for/hash ([phase-level (in-range min-phase (add1 max-phase))]) + (define linklet (hash-ref h phase-level #f)) + (values phase-level + (if linklet + (linklet-export-variables linklet) + null))))) + +(define (module-compiled-cross-phase-persistent? c) + (check 'module-compiled-cross-phase-persistent? compiled-module-expression? c) + (define h (compiled-module->h c)) + (hash-ref h 'cross-phase-persistent? #f)) + +;; ---------------------------------------- + +;; Normalize a compiled module that may have no submodules and is +;; represented directy by a linklet bundle to a representation that +;; uses a linklet directory +(define (normalize-to-linklet-directory c) + (cond + [(linklet-directory? (compiled->linklet-directory-or-bundle c)) + ;; already in linklet-directory form: + c] + [(linklet-bundle? c) + (hash->linklet-directory (hasheq #f c))] + [else + (struct-copy compiled-in-memory c + [linklet-directory (normalize-to-linklet-directory + (compiled-in-memory-linklet-directory c))])])) + +;; ---------------------------------------- + +(define (fixup-submodule-names c) + ;; Although this looks like a no-op, it forces a reset on submodule + ;; names, except where the names already match (short-circuited in + ;; `change-module-name`). + (module-compiled-name c (module-compiled-name c))) + +(define (reset-submodule-names b pre? submods) + (hash->linklet-bundle + (hash-set (linklet-bundle->hash b) + (if pre? 'pre 'post) + (map module-compiled-immediate-name submods)))) diff --git a/racket/src/expander/eval/root-context.rkt b/racket/src/expander/eval/root-context.rkt new file mode 100644 index 0000000000..b4e75e4575 --- /dev/null +++ b/racket/src/expander/eval/root-context.rkt @@ -0,0 +1,51 @@ +#lang racket/base +(require "../expand/root-expand-context.rkt" + "../expand/require.rkt" + "../expand/def-id.rkt" + "../expand/env.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/module-binding.rkt" + "../common/module-path.rkt" + "../common/phase.rkt" + "../host/linklet.rkt") + +(provide make-create-root-expand-context-from-module) + +;; Reconstructs a `root-expand-context` for a module based on its +;; metadata, specifically its requires and the exports of its +;; linklets. Reconstructing that way works as long as there are no +;; transformer definitions, since transformer definitions are not +;; visible outside a linklet. Typically, also, we can only do this +;; when the module contained no syntax literals, which would likely +;; contain information that is inconsistent with this reconstruction. +(define (make-create-root-expand-context-from-module requires evaled-ld-h) + (lambda (ns phase-shift original-self self) + (define root-ctx (make-root-expand-context)) + (define s (add-scopes empty-syntax (root-expand-context-module-scopes root-ctx))) + + ;; Add bindings for `require`s + (for ([(phase+reqs) (in-list requires)]) + (define phase (car phase+reqs)) + (for ([req (in-list (cdr phase+reqs))]) + (define mpi (module-path-index-shift req original-self self)) + (perform-require! mpi s self + s ns + #:phase-shift (phase+ phase phase-shift) + #:run-phase phase-shift + #:who 'module))) + + ;; Add bindings for `define`s, including registering symbols used + ;; by those definitions (some of which might be macro-introduced) + (define defined-syms (root-expand-context-defined-syms root-ctx)) + (for ([(phase linklet) (in-hash evaled-ld-h)]) + (for ([sym (in-list (linklet-export-variables linklet))]) + ;; Note that sym might be an unreadable symbol, in which case + ;; the binding should be unreachable, but we need to reserve + ;; the symbol to avoid conflicts + (define id (datum->syntax s sym)) + (add-binding! id (make-module-binding self phase sym) phase) + (add-defined-sym! defined-syms phase sym id))) + + root-ctx)) diff --git a/racket/src/expander/eval/top-level-instance.rkt b/racket/src/expander/eval/top-level-instance.rkt new file mode 100644 index 0000000000..c1705adae1 --- /dev/null +++ b/racket/src/expander/eval/top-level-instance.rkt @@ -0,0 +1,49 @@ +#lang racket/base +(require "../syntax/to-list.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../common/phase.rkt" + "../namespace/namespace.rkt" + "../expand/root-expand-context.rkt" + "../compile/reserved-symbol.rkt" + "../syntax/module-binding.rkt" + "../host/linklet.rkt" + "../expand/env.rkt" + "../expand/require.rkt" + "../expand/require+provide.rkt") + +;; Run-time support for evaluating top-level forms +(provide top-level-instance) + +(define top-level-instance + (make-instance + 'top-level #f 'constant + + top-level-bind!-id + (lambda (id mpi orig-phase phase-shift ns sym trans? trans-val) + (define phase (phase+ orig-phase phase-shift)) + (define b (make-module-binding mpi phase sym + #:frame-id (root-expand-context-frame-id + (namespace-get-root-expand-ctx ns)))) + (add-binding! id b phase) + (cond + [trans? + (when trans-val + (maybe-install-free=id! trans-val id phase))] + [else + (namespace-unset-transformer! ns phase sym)])) + + top-level-require!-id + (lambda (stx ns) + (define reqs (cdr (syntax->list stx))) + (parse-and-perform-requires! #:run? #t + #:visit? #f + reqs + #f ; no syntax errors should happen + ns + (namespace-phase ns) + (make-requires+provides #f) + #:who 'require + ;; We don't need to check for conflicts + ;; or adjust the requires+provides: + #:initial-require? #t)))) diff --git a/racket/src/expander/eval/top.rkt b/racket/src/expander/eval/top.rkt new file mode 100644 index 0000000000..bbcdbe3448 --- /dev/null +++ b/racket/src/expander/eval/top.rkt @@ -0,0 +1,198 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/phase.rkt" + "../common/performance.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../compile/module-use.rkt" + "../compile/reserved-symbol.rkt" + "../host/linklet.rkt" + "../compile/serialize.rkt" + "../compile/instance.rkt" + "../compile/eager-instance.rkt" + "../compile/compiled-in-memory.rkt" + "../compile/multi-top.rkt" + "../compile/namespace-scope.rkt" + "../expand/context.rkt" + "top-level-instance.rkt" + "multi-top.rkt" + "protect.rkt") + +;; Run a representation of top-level code as produced by `compile-top`; +;; see "compile/main.rkt", "compile/top.rkt", and "compile/multi-top.rkt" + +(provide eval-top + eval-single-top + + compiled-multiple-top?) + +(define (eval-single-top c ns) + (eval-one-top c ns #:single-expression? #t)) + +(define (compiled-multiple-top? c) + (define ld (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + (and (linklet-directory? ld) + (not (hash-ref (linklet-directory->hash ld) #f #f)))) + +(define (eval-top c ns [eval-compiled eval-top] [as-tail? #t]) + (if (compiled-multiple-top? c) + (eval-multiple-tops c ns eval-compiled as-tail?) + (eval-one-top c ns as-tail?))) + +(define (eval-multiple-tops c ns eval-compiled as-tail?) + (define (eval-compiled-parts l) + (let loop ([l l]) + (cond + [(null? l) void] + [(null? (cdr l)) + ;; Tail call: + (eval-compiled (car l) ns as-tail?)] + [else + (eval-compiled (car l) ns #f) + (loop (cdr l))]))) + + (cond + [(compiled-in-memory? c) + (eval-compiled-parts (compiled-in-memory-pre-compiled-in-memorys c))] + [(hash-ref (linklet-directory->hash c) 'data #f) + => (lambda (data-ld) + (eval-compiled-parts + (create-compiled-in-memorys-using-shared-data + (compiled-top->compiled-tops c) + ;; extract data linklet: + (hash-ref (linklet-bundle->hash (hash-ref (linklet-directory->hash data-ld) #f)) 0) + ns)))] + [else + ;; No shared data? Strage, but we can carry on, anyway: + (eval-compiled-parts (compiled-top->compiled-tops c))])) + +(define (eval-one-top c ns [as-tail? #t] + #:single-expression? [single-expression? #f]) + (performance-region + ['eval (if single-expression? 'transformer 'top)] + + (define ld (if (compiled-in-memory? c) + (compiled-in-memory-linklet-directory c) + c)) + (define h (linklet-bundle->hash (hash-ref (linklet-directory->hash ld) #f))) + (define link-instance + (if (compiled-in-memory? c) + (link-instance-from-compiled-in-memory c (and (not single-expression?) ns)) + (instantiate-linklet (hash-ref h 'link) + (list deserialize-instance + (make-eager-instance-instance + #:namespace ns + #:dest-phase (namespace-phase ns) + #:self (namespace-mpi ns) + #:bulk-binding-registry (namespace-bulk-binding-registry ns) + #:inspector (current-code-inspector)))))) + + (define orig-phase (hash-ref h 'original-phase)) + (define max-phase (hash-ref h 'max-phase)) + (define phase-shift (phase- (namespace-phase ns) orig-phase)) + + (define extra-inspector (and (compiled-in-memory? c) + (compiled-in-memory-compile-time-inspector c))) + (define phase-to-link-extra-inspectorsss + (if (compiled-in-memory? c) + (compiled-in-memory-phase-to-link-extra-inspectorsss c) + #hasheqv())) + + (define phase-to-link-modules + (if (compiled-in-memory? c) + (compiled-in-memory-phase-to-link-module-uses c) + (instance-variable-value link-instance 'phase-to-link-modules))) + + ;; Get last thunk to call in tail position: + (define thunk + (for/fold ([prev-thunk void]) ([phase (in-range max-phase (sub1 orig-phase) -1)]) + (prev-thunk #f) ;; call a not-last thunk before proceeding with the next phase + + (define module-uses (hash-ref phase-to-link-modules phase null)) + (define-values (import-module-instances import-instances) + (for/lists (mis is) ([mu (in-list module-uses)]) + (namespace-module-use->module+linklet-instances + ns mu #:phase-shift (phase- (phase+ phase phase-shift) + (module-use-phase mu))))) + + (define phase-ns (namespace->namespace-at-phase ns (phase+ phase phase-shift))) + + (define inst (if single-expression? + ;; Instance is ignored, so anything will do: + link-instance + ;; Instance is used: + (make-instance-instance + #:namespace phase-ns + #:phase-shift phase-shift + #:self (namespace-mpi ns) + #:inspector (namespace-inspector ns) + #:bulk-binding-registry (namespace-bulk-binding-registry ns) + #:set-transformer! (lambda (name val) + (namespace-set-transformer! ns + (phase+ (sub1 phase) phase-shift) + name + val))))) + + (define linklet (hash-ref h phase #f)) + + (cond + [linklet + (check-require-access linklet #:skip-imports 3 + module-uses import-module-instances (current-code-inspector) + extra-inspector + (hash-ref phase-to-link-extra-inspectorsss phase #f)) + (define (instantiate tail?) + ;; Providing a target instance to `instantiate-linklet` means that we get + ;; the body's results instead of the instance as a result + (instantiate-linklet linklet + (list* top-level-instance + link-instance + inst + import-instances) + ;; Instantiation merges with the namespace's current instance: + (namespace->instance ns (phase- (phase+ phase phase-shift) + (namespace-0-phase ns))) + ;; No prompt in tail position: + (not tail?))) + ;; Return `instantiate` as the next thunk + (cond + [(zero-phase? phase) + instantiate] + [single-expression? + (lambda (tail?) + (parameterize ([current-namespace phase-ns]) + (instantiate tail?)))] + [else + (define ns-1 (namespace->namespace-at-phase phase-ns (sub1 phase))) + (lambda (tail?) + (parameterize ([current-expand-context (make-expand-context ns-1)] + [current-namespace phase-ns]) + (instantiate tail?)))])] + [else void]))) + + ;; Call last thunk tail position --- maybe, since using a prompt if not `as-tail?` + (thunk as-tail?))) + +(define (link-instance-from-compiled-in-memory cim to-ns) + ;; If the compilation namespace doesn't match the evaluation + ;; namespace, then we need to adjust syntax object literals to work + ;; in the new namespace --- the same shifting that happens otherwise + ;; through deserialization + (define orig-syntax-literals (compiled-in-memory-syntax-literals cim)) + (define syntax-literals + (cond + [(not to-ns) orig-syntax-literals] + [(namespace-scopes=? (compiled-in-memory-namespace-scopes cim) + (extract-namespace-scopes to-ns)) + orig-syntax-literals] + [else + (for/vector #:length (vector-length orig-syntax-literals) ([s (in-vector orig-syntax-literals)]) + (swap-top-level-scopes s + (compiled-in-memory-namespace-scopes cim) + to-ns))])) + ;; Create the instance: + (make-instance 'link #f 'constant + mpi-vector-id (compiled-in-memory-mpis cim) + syntax-literals-id syntax-literals)) diff --git a/racket/src/expander/expand/allowed-context.rkt b/racket/src/expander/expand/allowed-context.rkt new file mode 100644 index 0000000000..03f54f3bb2 --- /dev/null +++ b/racket/src/expander/expand/allowed-context.rkt @@ -0,0 +1,55 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/binding.rkt" + "../syntax/scope.rkt" + "../namespace/core.rkt" + "context.rkt" + "../syntax/error.rkt") + +(provide prop:expansion-contexts + + not-in-this-expand-context? + avoid-current-expand-context) + +(define-values (prop:expansion-contexts expansion-contexts? expansion-contexts-ref) + (make-struct-type-property 'expansion-contexts + (lambda (v info) + (unless (and (list? v) + (for/and ([s (in-list v)]) + (memq s '(expression top-level module module-begin definition-context)))) + (raise-argument-error 'guard-for-prop:expansion-contexts + "(listof (or/c 'expression 'top-level 'module 'module-begin 'definition-context))" + v)) + v))) + + + +(define (not-in-this-expand-context? t ctx) + (and (expansion-contexts? t) + (not (memq (context->symbol (expand-context-context ctx)) + (expansion-contexts-ref t))))) + +(define (context->symbol context) + (if (symbol? context) + context + 'definition-context)) + +(define (avoid-current-expand-context s t ctx) + (define (wrap sym) + (datum->syntax #f (list (syntax-shift-phase-level + (datum->syntax core-stx sym) + (expand-context-phase ctx)) + s))) + (define (fail) + (raise-syntax-error + #f + (format "not allowed in context\n expansion context: ~a" + (context->symbol (expand-context-context ctx))) + s)) + (case (context->symbol (expand-context-context ctx)) + [(module-begin) (wrap 'begin)] + [(module top-level definition-context) + (if (memq 'expression (expansion-contexts-ref t)) + (wrap '#%expression) + (fail))] + [else (fail)])) diff --git a/racket/src/expander/expand/already-expanded.rkt b/racket/src/expander/expand/already-expanded.rkt new file mode 100644 index 0000000000..06eb02b2c9 --- /dev/null +++ b/racket/src/expander/expand/already-expanded.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +;; Defines a struct type for an expression that has been +;; expanded already by `local-expand-expression` + +(provide (struct-out already-expanded)) + +(struct already-expanded (s binding-layer) + #:reflection-name 'expanded-syntax) diff --git a/racket/src/expander/expand/append.rkt b/racket/src/expander/expand/append.rkt new file mode 100644 index 0000000000..df3551d01b --- /dev/null +++ b/racket/src/expander/expand/append.rkt @@ -0,0 +1,10 @@ +#lang racket/base + +(provide append/tail-on-null) + +(define-syntax-rule (append/tail-on-null e0 ... e) + (let ([finish (lambda () e)]) + (define l (append e0 ...)) + (if (null? l) + (finish) + (append l (finish))))) diff --git a/racket/src/expander/expand/bind-top.rkt b/racket/src/expander/expand/bind-top.rkt new file mode 100644 index 0000000000..9bc0435ef9 --- /dev/null +++ b/racket/src/expander/expand/bind-top.rkt @@ -0,0 +1,33 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "root-expand-context.rkt" + "context.rkt" + "def-id.rkt" + "dup-check.rkt" + "use-site.rkt") + +;; When compiling `(define-values (x) ...)` at the top level, we'd +;; like to bind `x` so that a reference in the "..." will point back +;; to the definition, as opposed to being whatever `x` was before. +;; (The top level is hopeless, but this bit of early binding helps.) +;; We don't want that binding to take effect outside of evaluation, +;; however; the permanent binding should happen when the +;; `define-values` for is evaluated. So, we use a distinct scope that +;; effectively hides the binding from tasks other than expansion. +;; +;; See also "expand-def-id.rkt". + +(provide as-expand-time-top-level-bindings) + +(define (as-expand-time-top-level-bindings ids s ctx) + (define top-level-bind-scope (root-expand-context-top-level-bind-scope ctx)) + (define tl-ids + (for/list ([id (in-list ids)]) + (remove-use-site-scopes id ctx))) + (check-no-duplicate-ids tl-ids (expand-context-phase ctx) s) + (define tmp-bind-ids + (for/list ([id (in-list tl-ids)]) + (add-scope id top-level-bind-scope))) + (values tl-ids + (select-defined-syms-and-bind!/ctx tmp-bind-ids ctx))) diff --git a/racket/src/expander/expand/binding-for-transformer.rkt b/racket/src/expander/expand/binding-for-transformer.rkt new file mode 100644 index 0000000000..8e69431530 --- /dev/null +++ b/racket/src/expander/expand/binding-for-transformer.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require "env.rkt" + "../common/module-path.rkt" + "../syntax/module-binding.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/provided.rkt") + +(provide binding-for-transformer?) + +;; Determine whether `b`, which is the binding of `id` at `at-phase`, +;; refers to a variable or transformer binding; also, check taints +;; (for bindings other than for-label) +(define (binding-for-transformer? b id at-phase ns) + (cond + [(not at-phase) + ;; The binding must be imported; determine whether it's syntax by + ;; consulting the exporting module + (define m (namespace->module ns (module-path-index-resolve + (module-binding-nominal-module b)))) + (define b/p (hash-ref (hash-ref (module-provides m) (module-binding-nominal-phase b) #hasheq()) + (module-binding-nominal-sym b) + #f)) + (provided-as-transformer? b/p)] + [else + ;; Use `binding-lookup` to both check for taints and determine whether the + ;; binding is a transformer or variable binding + (define-values (val primitive? insp) (binding-lookup b empty-env null ns at-phase id)) + (not (variable? val))])) diff --git a/racket/src/expander/expand/binding-to-module.rkt b/racket/src/expander/expand/binding-to-module.rkt new file mode 100644 index 0000000000..d2a42241be --- /dev/null +++ b/racket/src/expander/expand/binding-to-module.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require "../syntax/module-binding.rkt" + "../syntax/error.rkt" + "../common/phase.rkt" + "../common/module-path.rkt" + "../namespace/module.rkt") + +(provide binding->module-instance) + +;; Locate a module instance for a binding +(define (binding->module-instance b ns phase id) + (define at-phase (phase- phase (module-binding-phase b))) + (define mi + (namespace->module-instance ns + (module-path-index-resolve (module-binding-module b)) + at-phase + #:check-available-at-phase-level (module-binding-phase b) + #:unavailable-callback (lambda (mi) 'unavailable))) + (when (eq? mi 'unavailable) + (raise-syntax-error + #f + (format (string-append "module mismatch;\n" + " attempted to use a module that is not available\n" + " possible cause:\n" + " using (dynamic-require .... #f)\n" + " but need (dynamic-require .... 0)\n" + " module: ~s\n" + " phase: ~s") + (module-binding-module b) + (phase+ at-phase (module-binding-phase b))) + id)) + (unless mi + (error 'expand + (string-append "namespace mismatch; cannot locate module instance\n" + " module: ~s\n" + " use phase: ~a\n" + " definition phase: ~a\n" + " for identifier: ~s") + (module-binding-module b) + phase + (module-binding-phase b) + id)) + mi) diff --git a/racket/src/expander/expand/body.rkt b/racket/src/expander/expand/body.rkt new file mode 100644 index 0000000000..5ca8bd6e84 --- /dev/null +++ b/racket/src/expander/expand/body.rkt @@ -0,0 +1,451 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../namespace/module.rkt" + "../syntax/binding.rkt" + "env.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "../expand/parsed.rkt" + "dup-check.rkt" + "use-site.rkt" + "../namespace/core.rkt" + "../boot/runtime-primitive.rkt" + "context.rkt" + "liberal-def-ctx.rkt" + "reference-record.rkt" + "prepare.rkt" + "log.rkt" + "main.rkt") + +(provide expand-body + expand-and-split-bindings-by-reference) + +;; Expand a sequence of body forms in a definition context; returns a +;; list of body forms +(define (expand-body bodys ctx + #:source s + #:stratified? [stratified? #f]) + (log-expand ctx 'enter-block (datum->syntax #f bodys)) + ;; In principle, we have an outside-edge scope that identifies the + ;; original content of the definition context --- but a body always + ;; exists inside some binding form, so that form's scope will do; + ;; the inside-edge scope identifies any form that appears (perhaps + ;; through macro expansion) in the definition context + (define inside-sc (new-scope 'intdef)) + (define init-bodys + (for/list ([body (in-list bodys)]) + (add-scope body inside-sc))) + (log-expand ctx 'block-renames (datum->syntax #f init-bodys) (datum->syntax #f bodys)) + (define phase (expand-context-phase ctx)) + (define frame-id (make-reference-record)) ; accumulates info on referenced variables + (define def-ctx-scopes (box null)) + ;; Create an expansion context for expanding only immediate macros; + ;; this partial-expansion phase uncovers macro- and variable + ;; definitions in the definition context + (define body-ctx (struct*-copy expand-context ctx + [context (list (make-liberal-define-context))] + [name #f] + [only-immediate? #t] + [def-ctx-scopes def-ctx-scopes] + [post-expansion-scope #:parent root-expand-context inside-sc] + [post-expansion-scope-action add-scope] + [scopes (cons inside-sc + (expand-context-scopes ctx))] + [use-site-scopes #:parent root-expand-context (box null)] + [frame-id #:parent root-expand-context frame-id] + [reference-records (cons frame-id + (expand-context-reference-records ctx))])) + ;; Increment the binding layer relative to `ctx` when we encounter a binding + (define (maybe-increment-binding-layer ids body-ctx) + (if (eq? (expand-context-binding-layer body-ctx) + (expand-context-binding-layer ctx)) + (increment-binding-layer ids body-ctx inside-sc) + (expand-context-binding-layer body-ctx))) + ;; Save the name for the last form + (define name (expand-context-name ctx)) + ;; Loop through the body forms for partial expansion + (let loop ([body-ctx body-ctx] + [bodys init-bodys] + [done-bodys null] ; accumulated expressions + [val-idss null] ; accumulated binding identifiers + [val-keyss null] ; accumulated binding keys + [val-rhss null] ; accumulated binding right-hand sides + [track-stxs null] ; accumulated syntax for tracking + [trans-idss null] ; accumulated `define-syntaxes` identifiers that have disappeared + [stx-clauses null] ; accumulated syntax-binding clauses, used when observing + [dups (make-check-no-duplicate-table)]) + (cond + [(null? bodys) + ;; Partial expansion is complete, so finish by rewriting to + ;; `letrec-values` + (finish-expanding-body body-ctx frame-id def-ctx-scopes + (reverse val-idss) (reverse val-keyss) (reverse val-rhss) (reverse track-stxs) + (reverse stx-clauses) (reverse done-bodys) + #:source s + #:stratified? stratified? + #:name name + #:disappeared-transformer-bindings (reverse trans-idss))] + [else + (define rest-bodys (cdr bodys)) + (log-expand body-ctx 'next) + (define exp-body (expand (car bodys) (if (and name (null? (cdr bodys))) + (struct*-copy expand-context body-ctx + [name name]) + body-ctx))) + (define disarmed-exp-body (syntax-disarm exp-body)) + (case (core-form-sym disarmed-exp-body phase) + [(begin) + ;; Splice a `begin` form + (log-expand body-ctx 'prim-begin) + (define-match m disarmed-exp-body '(begin e ...)) + (define (track e) (syntax-track-origin e exp-body)) + (define splice-bodys (append (map track (m 'e)) rest-bodys)) + (log-expand body-ctx 'splice splice-bodys) + (loop body-ctx + splice-bodys + done-bodys + val-idss + val-keyss + val-rhss + track-stxs + trans-idss + stx-clauses + dups)] + [(define-values) + ;; Found a variable definition; add bindings, extend the + ;; environment, and continue + (log-expand body-ctx 'prim-define-values) + (define-match m disarmed-exp-body '(define-values (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) body-ctx)) + (log-expand body-ctx 'rename-one (datum->syntax #f (list ids (m 'rhs)))) + (define new-dups (check-no-duplicate-ids ids phase exp-body dups)) + (define counter (root-expand-context-counter ctx)) + (define keys (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in exp-body))) + (define extended-env (for/fold ([env (expand-context-env body-ctx)]) ([key (in-list keys)] + [id (in-list ids)]) + (env-extend env key (local-variable id)))) + (loop (struct*-copy expand-context body-ctx + [env extended-env] + [binding-layer (maybe-increment-binding-layer ids body-ctx)]) + rest-bodys + null + ;; If we had accumulated some expressions, we + ;; need to turn each into the equivalent of + ;; (defined-values () (begin (values))) + ;; form so it can be kept with definitions to + ;; preserve order + (cons ids (append + (for/list ([done-body (in-list done-bodys)]) + null) + val-idss)) + (cons keys (append + (for/list ([done-body (in-list done-bodys)]) + null) + val-keyss)) + (cons (m 'rhs) (append + (for/list ([done-body (in-list done-bodys)]) + (no-binds done-body s phase)) + val-rhss)) + (cons exp-body (append + (for/list ([done-body (in-list done-bodys)]) + #f) + track-stxs)) + trans-idss + stx-clauses + new-dups)] + [(define-syntaxes) + ;; Found a macro definition; add bindings, evaluate the + ;; compile-time right-hand side, install the compile-time + ;; values in the environment, and continue + (log-expand body-ctx 'prim-define-syntaxes) + (define-match m disarmed-exp-body '(define-syntaxes (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) body-ctx)) + (log-expand body-ctx 'rename-one (datum->syntax #f (list ids (m 'rhs)))) + (define new-dups (check-no-duplicate-ids ids phase exp-body dups)) + (define counter (root-expand-context-counter ctx)) + (define keys (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in exp-body))) + (log-expand body-ctx 'prepare-env) + (prepare-next-phase-namespace ctx) + (log-expand body-ctx 'enter-bind) + (define vals (eval-for-syntaxes-binding (m 'rhs) ids body-ctx)) + (define extended-env (for/fold ([env (expand-context-env body-ctx)]) ([key (in-list keys)] + [val (in-list vals)] + [id (in-list ids)]) + (maybe-install-free=id-in-context! val id phase body-ctx) + (env-extend env key val))) + (log-expand body-ctx 'exit-bind) + (loop (struct*-copy expand-context body-ctx + [env extended-env] + [binding-layer (maybe-increment-binding-layer ids body-ctx)]) + rest-bodys + done-bodys + val-idss + val-keyss + val-rhss + track-stxs + (cons ids trans-idss) + (cons (datum->syntax #f (list ids (m 'rhs)) (m 'rhs)) stx-clauses) + new-dups)] + [else + (cond + [stratified? + ;; Found an expression, so no more definitions are allowed + (unless (null? done-bodys) (error "internal error: accumulated expressions not empty")) + (loop body-ctx + null + (if (and (null? val-idss) (null? trans-idss)) + (reverse (cons exp-body rest-bodys)) + (list (datum->syntax #f (cons (core-id '#%stratified-body phase) + (cons exp-body rest-bodys))))) + val-idss + val-keyss + val-rhss + track-stxs + trans-idss + stx-clauses + dups)] + [else + ;; Found an expression; accumulate it and continue + (loop body-ctx + rest-bodys + (cons exp-body done-bodys) + val-idss + val-keyss + val-rhss + track-stxs + trans-idss + stx-clauses + dups)])])]))) + +;; Partial expansion is complete, so assumble the result as a +;; `letrec-values` form and continue expanding +(define (finish-expanding-body body-ctx frame-id def-ctx-scopes + val-idss val-keyss val-rhss track-stxs + stx-clauses done-bodys + #:source s + #:stratified? stratified? + #:name name + #:disappeared-transformer-bindings disappeared-transformer-bindings) + (when (null? done-bodys) + (raise-syntax-error #f "no expression after a sequence of internal definitions" s)) + ;; As we finish expanding, we're no longer in a definition context + (define finish-ctx (struct*-copy expand-context (accumulate-def-ctx-scopes body-ctx def-ctx-scopes) + [context 'expression] + [use-site-scopes #:parent root-expand-context (box null)] + [scopes (append + (unbox (root-expand-context-use-site-scopes body-ctx)) + (expand-context-scopes body-ctx))] + [only-immediate? #f] + [def-ctx-scopes #f] + [post-expansion-scope #:parent root-expand-context #f])) + ;; Helper to expand and wrap the ending expressions in `begin`, if needed: + (define (finish-bodys) + (define block->list? (null? val-idss)) + (unless block->list? (log-expand body-ctx 'next-group)) ; to go with 'block->letrec + (define last-i (sub1 (length done-bodys))) + (log-expand body-ctx 'enter-list (datum->syntax #f done-bodys)) + (define exp-bodys + (for/list ([done-body (in-list done-bodys)] + [i (in-naturals)]) + (log-expand body-ctx 'next) + (expand done-body (if (and name (= i last-i)) + (struct*-copy expand-context finish-ctx + [name name]) + finish-ctx)))) + (log-expand body-ctx 'exit-list (datum->syntax #f exp-bodys)) + (reference-record-clear! frame-id) + exp-bodys) + (cond + [(and (null? val-idss) + (null? disappeared-transformer-bindings)) + ;; No definitions, so just return the body list + (log-expand finish-ctx 'block->list (datum->syntax s done-bodys)) + (finish-bodys)] + [else + (log-expand... finish-ctx (lambda (obs) + ;; Simulate old expansion steps + (log-letrec-values obs finish-ctx s val-idss val-rhss track-stxs + stx-clauses done-bodys))) + ;; Roughly, finish expanding the right-hand sides, finish the body + ;; expression, then add a `letrec-values` wrapper: + (define exp-s (expand-and-split-bindings-by-reference + val-idss val-keyss val-rhss track-stxs + #:split? (not stratified?) + #:frame-id frame-id #:ctx finish-ctx + #:source s #:had-stxes? (pair? stx-clauses) + #:get-body finish-bodys #:track? #f)) + (log-expand* body-ctx ['exit-prim exp-s] ['return exp-s]) + (if (expand-context-to-parsed? body-ctx) + (list exp-s) + (list (attach-disappeared-transformer-bindings + exp-s + disappeared-transformer-bindings)))])) + +;; Roughly, create a `letrec-values` for for the given ids, right-hand sides, and +;; body. While expanding right-hand sides, though, keep track of whether any +;; forward references appear, and if not, generate a `let-values` form, instead, +;; at each binding clause. Similar, end a `letrec-values` form and start a new +;; one if there were forward references up to the clause but not beyond. +;; Returns a single form. +(define (expand-and-split-bindings-by-reference idss keyss rhss track-stxs + #:split? split? + #:frame-id frame-id #:ctx ctx + #:source s #:had-stxes? had-stxes? + #:get-body get-body #:track? track?) + (define phase (expand-context-phase ctx)) + (let loop ([idss idss] [keyss keyss] [rhss rhss] [track-stxs track-stxs] + [accum-idss null] [accum-keyss null] [accum-rhss null] [accum-track-stxs null] + [track? track?] [get-list? #f] [can-log? #t]) + (cond + [(null? idss) + (cond + [(and (null? accum-idss) + get-list?) + (get-body)] + [else + (define exp-body (get-body)) + (define result-s + (if (expand-context-to-parsed? ctx) + (if (null? accum-idss) + (parsed-let-values (keep-properties-only s) null null exp-body) + (parsed-letrec-values (keep-properties-only s) + (reverse accum-idss) + (reverse (map list accum-keyss accum-rhss)) + exp-body)) + (rebuild + #:track? track? + s + `(,(if (null? accum-idss) + (core-id 'let-values phase) + (core-id 'letrec-values phase)) + ,(build-clauses accum-idss accum-rhss accum-track-stxs) + ,@exp-body)))) + (log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s]) + (if get-list? (list result-s) result-s)])] + [else + (log-expand ctx 'next) + (define ids (car idss)) + (define expanded-rhs (expand (car rhss) (as-named-context ctx ids))) + (define track-stx (car track-stxs)) + + (define local-or-forward-references? (reference-record-forward-references? frame-id)) + (reference-record-bound! frame-id (car keyss)) + (define forward-references? (reference-record-forward-references? frame-id)) + + (cond + [(and (not local-or-forward-references?) + split?) + (unless (null? accum-idss) (error "internal error: accumulated ids not empty")) + (define exp-rest (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs) + null null null null + #f #t #f)) + (define result-s + (if (expand-context-to-parsed? ctx) + (parsed-let-values (keep-properties-only s) + (list ids) + (list (list (car keyss) expanded-rhs)) + exp-rest) + (rebuild + #:track? track? + s + `(,(core-id 'let-values phase) + (,(build-clause ids expanded-rhs track-stx)) + ,@exp-rest)))) + (log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s]) + (if get-list? (list result-s) result-s)] + [(and (not forward-references?) + (or split? (null? (cdr idss)))) + (define exp-rest (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs) + null null null null + #f #t #f)) + (define result-s + (if (expand-context-to-parsed? ctx) + (parsed-letrec-values (keep-properties-only s) + (reverse (cons ids accum-idss)) + (reverse + (cons (list (car keyss) expanded-rhs) + (map list accum-keyss accum-rhss))) + exp-rest) + (rebuild + #:track? track? + s + `(,(core-id 'letrec-values phase) + ,(build-clauses (cons ids accum-idss) + (cons expanded-rhs accum-rhss) + (cons track-stx accum-track-stxs)) + ,@exp-rest)))) + (log-expand* ctx #:when (and can-log? (log-tag? had-stxes? ctx)) ['tag result-s]) + (if get-list? (list result-s) result-s)] + [else + (loop (cdr idss) (cdr keyss) (cdr rhss) (cdr track-stxs) + (cons ids accum-idss) (cons (car keyss) accum-keyss) + (cons expanded-rhs accum-rhss) (cons track-stx accum-track-stxs) + track? get-list? can-log?)])]))) + +(define (build-clauses accum-idss accum-rhss accum-track-stxs) + (map build-clause + (reverse accum-idss) + (reverse accum-rhss) + (reverse accum-track-stxs))) + +(define (build-clause ids rhs track-stx) + (define clause (datum->syntax #f `[,ids ,rhs])) + (if track-stx + (syntax-track-origin clause track-stx) + clause)) + +;; Helper to turn an expression into a binding clause with zero +;; bindings +(define (no-binds expr s phase) + (define s-runtime-stx (syntax-shift-phase-level runtime-stx phase)) + (datum->syntax (core-id '#%app phase) ; for `values` application + `(,(core-id 'begin phase) + ,expr + (,(datum->syntax s-runtime-stx 'values))) + s)) + +(define (log-tag? had-stxes? ctx) + (and had-stxes? + (not (expand-context-only-immediate? ctx)))) + +;; Generate observer actions that simulate the old expander +;; going back through `letrec-values`: +(define (log-letrec-values obs ctx s val-idss val-rhss track-stxs + stx-clauses done-bodys) + (define phase (expand-context-phase ctx)) + (define clauses (for/list ([val-ids (in-list val-idss)] + [val-rhs (in-list val-rhss)] + [track-stx (in-list track-stxs)]) + (datum->syntax #f `[,val-ids ,val-rhs] track-stx))) + (define had-stxes? (not (null? stx-clauses))) + (define lv-id (core-id (if had-stxes? 'letrec-syntaxes+values 'letrec-values) phase)) + (define lv-s (datum->syntax #f (if had-stxes? + `(,lv-id ,stx-clauses ,clauses ,@done-bodys) + `(,lv-id ,clauses ,@done-bodys)) + s)) + (...log-expand obs + ['block->letrec (list lv-s)] + ['visit lv-s] + ['resolve lv-id] + ['enter-prim lv-s]) + (cond + [had-stxes? + (...log-expand obs + ['prim-letrec-syntaxes+values #f] + ['letrec-syntaxes-renames stx-clauses clauses (datum->syntax #f done-bodys s)] + ['prepare-env] + ['next-group]) + (unless (null? val-idss) + (...log-expand obs + ['prim-letrec-values] + ['let-renames clauses (datum->syntax #f done-bodys s)]))] + [else + (...log-expand obs + ['prim-letrec-values #f] + ['let-renames clauses (datum->syntax #f done-bodys s)])])) diff --git a/racket/src/expander/expand/context.rkt b/racket/src/expander/expand/context.rkt new file mode 100644 index 0000000000..d6a93a90bd --- /dev/null +++ b/racket/src/expander/expand/context.rkt @@ -0,0 +1,198 @@ +#lang racket/base +(require racket/promise + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "env.rkt" + "free-id-set.rkt" + "../namespace/namespace.rkt" + "root-expand-context.rkt" + "lift-key.rkt") + +(provide (struct*-out expand-context) + (all-from-out "root-expand-context.rkt") + make-expand-context + copy-root-expand-context + current-expand-context + get-current-expand-context + + current-expand-observe + + as-expression-context + as-begin-expression-context + as-tail-context + as-named-context + as-to-parsed-context) + +;; An `expand-context` controls the process and result of expansion. +;; +;; If `to-parsed?` is true, the result is a `parsed` record instead of +;; an expanded syntax objects. That mode is effectively a fusion of +;; expansion and parsing, which is useful in the common case that +;; expanded code is being sent directly the the compiler. +;; +;; If only-immediate?` is set, then only immediate macro uses are +;; expanded. That mode overrides `to-parsed?`, since it's common to +;; partially expand forms on the way to a parsed result. + +(struct* expand-context root-expand-context + (to-parsed? ; #t => "expand" to a parsed form; #f => normal expand + * context ; 'expression, 'module, or 'top-level + phase ; current expansion phase; must match phase of `namespace` + namespace ; namespace for modules and evaluation + * env ; environment for local bindings + * post-expansion-scope-action ; function to apply with `post-expansion-scope` + * scopes ; list of scopes that should be pruned by `quote-syntax` + * def-ctx-scopes ; #f or box of list of scopes; transformer-created def-ctxes + * binding-layer ; changed when a binding is nested; to check already-expanded + * reference-records ; list of reference records for enclosing + * only-immediate? ; #t => stop at core forms; #t => `def-ctx-scopes` is a box + just-once? ; #t => stop (a given subform) after any expansion + module-begin-k ; expander for `#%module-begin` in a 'module-begin context + * need-eventually-defined ; phase(>=1) -> variables expanded before binding + allow-unbound? ; allow reference to unbound identifiers as variables + in-local-expand? ; #t via `local-expand` + stops ; free-id-set; non-empty => `def-ctx-scopes` is a box + * current-introduction-scopes ; scopes for current macro expansion + declared-submodule-names ; mutable hash table: symbol -> 'module or 'module* + lifts ; #f or lift-context, which contains a list of lifteds + lift-envs ; list of box of env for lifts to locals + module-lifts ; lifted `module`s + require-lifts ; lifted `require`s + to-module-lifts ; lifted `provide` and end declarations + requires+provides ; enclosing module's requires+provides during `provide` + * name ; #f or identifier to name the expression + observer ; logging observer (for the macro debugger) + for-serializable? ; accumulate submodules as serializable? + should-not-encounter-macros?)) ; #t when "expanding" to parse + +(define (make-expand-context ns + #:to-parsed? [to-parsed? #f] + #:for-serializable? [for-serializable? #f] + #:observable? [observable? #f]) + (define root-ctx (namespace-get-root-expand-ctx ns)) + (expand-context (root-expand-context-module-scopes root-ctx) + (root-expand-context-post-expansion-scope root-ctx) + (root-expand-context-top-level-bind-scope root-ctx) + (root-expand-context-all-scopes-stx root-ctx) + (root-expand-context-use-site-scopes root-ctx) + (root-expand-context-defined-syms root-ctx) + (root-expand-context-frame-id root-ctx) + (root-expand-context-counter root-ctx) + (root-expand-context-lift-key root-ctx) + to-parsed? + 'top-level + (namespace-phase ns) + ns + empty-env + push-scope ; post-expansion-scope-action + null ; scopes + #f ; def-ctx-scopes + (root-expand-context-frame-id root-ctx) ; binding-layer + null ; reference-records + #f ; only-immediate? + #f ; just-once? + #f ; module-begin-k + #f ; need-eventually-defined + #t ; allow-unbound? + #f ; in-local-expand? + empty-free-id-set ; stops + null ; current-introduction-scopes + #hasheq() ; declared-submodule-names + #f ; lifts + '() ; lift-envs + #f ; module-lifts + #f ; require-lifts + #f ; to-module-lifts + #f ; requires+provides + #f ; name + (and observable? (current-expand-observe)) + for-serializable? + #f)) + +(define (copy-root-expand-context ctx root-ctx) + (struct*-copy expand-context ctx + [module-scopes #:parent root-expand-context (root-expand-context-module-scopes root-ctx)] + [post-expansion-scope #:parent root-expand-context (root-expand-context-post-expansion-scope root-ctx)] + [top-level-bind-scope #:parent root-expand-context (root-expand-context-top-level-bind-scope root-ctx)] + [all-scopes-stx #:parent root-expand-context (root-expand-context-all-scopes-stx root-ctx)] + [use-site-scopes #:parent root-expand-context (root-expand-context-use-site-scopes root-ctx)] + [defined-syms #:parent root-expand-context (root-expand-context-defined-syms root-ctx)] + [frame-id #:parent root-expand-context (root-expand-context-frame-id root-ctx)] + [counter #:parent root-expand-context (root-expand-context-counter root-ctx)] + [lift-key #:parent root-expand-context (root-expand-context-lift-key root-ctx)] + [binding-layer (root-expand-context-frame-id root-ctx)])) + +;; An expand-context or a delayed expand context (so use `force`): +(define current-expand-context (make-parameter #f)) + +(define (get-current-expand-context [who 'unexpected] + #:fail-ok? [fail-ok? #f]) + (or (force (current-expand-context)) + (if fail-ok? + #f + (raise-arguments-error who "not currently expanding")))) + +;; ---------------------------------------- + +;; For macro debugging; see "log.rkt" + +(define current-expand-observe (make-parameter #f + (lambda (v) + (unless (or (not v) + (and (procedure? v) + (procedure-arity-includes? v 2))) + (raise-argument-error 'current-expand-observe + "(or/c (procedure-arity-includes/c 2) #f)" + v)) + v))) + +;; ---------------------------------------- + +;; Adjusts `ctx` to make it suitable for a subexpression of the +;; current context +(define (as-expression-context ctx) + (cond + [(and (eq? 'expression (expand-context-context ctx)) + (not (expand-context-name ctx))) + ctx] + [else (struct*-copy expand-context ctx + [context 'expression] + [name #f] + [post-expansion-scope #:parent root-expand-context #f])])) + +;; Adjusts `ctx` to make it suitable for a non-tail position +;; in an `begin` form, possibly in a 'top-level or 'module context +;; (so don't force it to 'expression mode) +(define (as-begin-expression-context ctx) + (cond + [(not (expand-context-name ctx)) + ctx] + [else (struct*-copy expand-context ctx + [name #f])])) + +;; Adjusts `ctx` (which should be an expression context) to make it +;; suitable for a subexpression in tail position +(define (as-tail-context ctx #:wrt wrt-ctx) + (cond + [(expand-context-name wrt-ctx) + (struct*-copy expand-context ctx + [name (expand-context-name wrt-ctx)])] + [else ctx])) + +;; Adjust `ctx` to make it suitable for a context in the right-hand +;; side of a definition of `ids` +(define (as-named-context ctx ids) + (cond + [(and (pair? ids) (null? (cdr ids))) + (struct*-copy expand-context ctx + [name (car ids)])] + [else ctx])) + +;; Adjust `ctx` to to generate a parsed result +(define (as-to-parsed-context ctx) + (struct*-copy expand-context ctx + [to-parsed? #t] + [observer #f] + [should-not-encounter-macros? #t])) diff --git a/racket/src/expander/expand/cross-phase.rkt b/racket/src/expander/expand/cross-phase.rkt new file mode 100644 index 0000000000..9fca3b16e4 --- /dev/null +++ b/racket/src/expander/expand/cross-phase.rkt @@ -0,0 +1,94 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/match.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "../namespace/core.rkt" + "../common/module-path.rkt" + "../boot/runtime-primitive.rkt" + "parsed.rkt" + "expanded+parsed.rkt") + +;; Check whether a module fits the restricted grammar of a cross-phase +;; persistent module + +(provide check-cross-phase-persistent-form) + +(define (check-cross-phase-persistent-form bodys) + (check-body bodys)) + +(define (check-body bodys) + (for ([body (in-list bodys)]) + (define p (if (expanded+parsed? body) + (expanded+parsed-parsed body) + body)) + (cond + [(parsed-define-values? p) + (check-expr (parsed-define-values-rhs p) (length (parsed-define-values-syms p)) p)] + [(or (parsed-#%declare? p) + (parsed-module? p) + (syntax? p)) ;; remaining unparsed forms, such as `#%require` and `#%provide`, are ok + (void)] + [else + (disallow p)]))) + +(define (check-expr e num-results enclosing) + (cond + [(or (parsed-lambda? e) + (parsed-case-lambda? e)) + (check-count 1 num-results enclosing)] + [(parsed-quote? e) + (check-datum (parsed-quote-datum e) e) + (check-count 1 num-results enclosing)] + [(parsed-app? e) + (define rands (parsed-app-rands e)) + (for ([rand (in-list rands)]) + (check-expr rand 1 e)) + (case (cross-phase-primitive-name (parsed-app-rator e)) + [(cons list) + (check-count 1 num-results enclosing)] + [(make-struct-type) + (check-count 5 num-results enclosing)] + [(make-struct-type-property) + (check-count 3 num-results enclosing)] + [(gensym) + (unless (or (= 0 (length rands)) + (and (= 1 (length rands)) + (quoted-string? (car rands)))) + (disallow e))] + [(string->uninterned-symbol) + (unless (and (= 1 (length rands)) + (quoted-string? (car rands))) + (disallow e))] + [else (disallow e)])])) + +(define (check-count is-num expected-num enclosing) + (unless (= is-num expected-num) + (disallow enclosing))) + +(define (check-datum d e) + (cond + [(or (number? d) (boolean? d) (symbol? d) (string? d) (bytes? d)) + (void)] + [else (disallow e)])) + +(define (quoted-string? e) + (and (parsed-quote? e) + (string? (parsed-quote-datum e)))) + +(define (cross-phase-primitive-name id) + (cond + [(parsed-id? id) + (define b (parsed-id-binding id)) + (and (module-binding? b) + (eq? runtime-module-name (module-path-index-resolve (module-binding-module b))) + (module-binding-sym b))] + [else #f])) + +(define (disallow body) + (raise-syntax-error 'module + "not allowed in a cross-phase persistent module" + (if (parsed? body) + (datum->syntax #f body (parsed-s body)) + body))) diff --git a/racket/src/expander/expand/def-id.rkt b/racket/src/expander/expand/def-id.rkt new file mode 100644 index 0000000000..190051d5dd --- /dev/null +++ b/racket/src/expander/expand/def-id.rkt @@ -0,0 +1,101 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/module-binding.rkt" + "require+provide.rkt" + "../namespace/namespace.rkt" + "context.rkt" + "root-expand-context.rkt" + "env.rkt") + +(provide select-defined-syms-and-bind! + select-defined-syms-and-bind!/ctx + add-defined-sym!) + +;; For each identifier that is defined in a module or at the top +;; level, we need to map the identifier to a symbol for a variable in +;; a linklet instance. (Since multiple definitions have identifiers +;; that wrap the same symbol in different scopes, we invent new +;; symbols as unreadable symbols.) A `module-binding` refers to this +;; linklet-level symbol. + +;; As a concession to top-level evaluation, reserve plain symbols for +;; identifers that have only the module's scopes. That way, if a +;; reference to an identifier is encountered before a definition, the +;; reference can still work in normal cases. + +;; One further twist is that top-level expansion uses a "top level +;; bind scope", which is used to create bindings while expanding so +;; that definitions and uses expanded to together work in the expected +;; way, but no binding is actually created until a definition is +;; evaluated. For the purposes of selecting a symbol, we need to treat +;; as equivalent identifiers with and without the top level bind +;; scope. + +(define (select-defined-syms-and-bind! ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:top-level-bind-scope [top-level-bind-scope #f] + #:requires+provides [requires+provides #f] + #:in [orig-s #f] + #:as-transformer? [as-transformer? #f]) + (define defined-syms-at-phase + (or (hash-ref defined-syms phase #f) (let ([ht (make-hasheq)]) + (hash-set! defined-syms phase ht) + ht))) + (for/list ([id (in-list ids)]) + (define sym (syntax-e id)) + (define defined-sym + (if (and (not (defined-as-other? (hash-ref defined-syms-at-phase sym #f) id phase top-level-bind-scope)) + ;; Only use `sym` directly if there are no + ;; extra scopes on the binding form + (no-extra-scopes? id all-scopes-stx top-level-bind-scope phase)) + sym + (let loop ([pos 1]) + (define s (string->unreadable-symbol (format "~a.~a" sym pos))) + (if (defined-as-other? (hash-ref defined-syms-at-phase s #f) id phase top-level-bind-scope) + (loop (add1 pos)) + s)))) + (hash-set! defined-syms-at-phase defined-sym id) + (define b (make-module-binding self phase defined-sym #:frame-id frame-id + #:nominal-sym sym)) + (when requires+provides + (remove-required-id! requires+provides id phase #:unless-matches b)) + (add-binding! id b phase #:in orig-s) + (when requires+provides + (add-defined-or-required-id! requires+provides id phase b #:as-transformer? as-transformer?)) + defined-sym)) + +(define (no-extra-scopes? id all-scopes-stx top-level-bind-scope phase) + (define m-id (datum->syntax all-scopes-stx (syntax-e id))) + (or (bound-identifier=? id m-id phase) + (and top-level-bind-scope + (bound-identifier=? id (add-scope m-id top-level-bind-scope) phase)))) + +(define (defined-as-other? prev-id id phase top-level-bind-scope) + (and prev-id + (not (bound-identifier=? prev-id id phase)) + (or (not top-level-bind-scope) + (not (bound-identifier=? (remove-scope prev-id top-level-bind-scope) + (remove-scope id top-level-bind-scope) + phase))))) + +;; ------------------------------ + +(define (select-defined-syms-and-bind!/ctx tl-ids ctx) + (select-defined-syms-and-bind! tl-ids (root-expand-context-defined-syms ctx) + (namespace-mpi (expand-context-namespace ctx)) + (expand-context-phase ctx) + (root-expand-context-all-scopes-stx ctx) + #:frame-id (root-expand-context-frame-id ctx) + #:top-level-bind-scope (root-expand-context-top-level-bind-scope ctx))) + +;; ---------------------------------------- + +(define (add-defined-sym! defined-syms phase sym id) + (define defined-syms-at-phase + (or (hash-ref defined-syms phase #f) (let ([ht (make-hasheq)]) + (hash-set! defined-syms phase ht) + ht))) + (hash-set! defined-syms-at-phase sym id)) diff --git a/racket/src/expander/expand/definition-context.rkt b/racket/src/expander/expand/definition-context.rkt new file mode 100644 index 0000000000..feb874eeed --- /dev/null +++ b/racket/src/expander/expand/definition-context.rkt @@ -0,0 +1,268 @@ +#lang racket/base +(require (for-syntax racket/base) + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "env.rkt" + "use-site.rkt" + "context.rkt" + "main.rkt" + "log.rkt" + "free-id-set.rkt" + "stop-ids.rkt") + +(provide add-intdef-scopes + add-intdef-bindings + internal-definition-context-frame-id + + internal-definition-context? + syntax-local-make-definition-context + syntax-local-bind-syntaxes + internal-definition-context-binding-identifiers + internal-definition-context-introduce + internal-definition-context-seal + identifier-remove-from-definition-context + + make-local-expand-context + flip-introduction-scopes) + +(struct internal-definition-context (frame-id ; identifies the frame for use-site scopes + scope ; scope that represents the context + add-scope? ; whether the scope is auto-added for expansion + env-mixins)) ; bindings for this context: box of list of mix-binding + +(struct env-mixin (id + sym + value + cache)) ; caches addition of binding to an existing environment + +;; syntax-local-make-definition-context +(define (syntax-local-make-definition-context [parent-ctx #f] [add-scope? #t]) + (unless (or (not parent-ctx) + (internal-definition-context? parent-ctx)) + (raise-argument-error 'syntax-local-make-definition-context "(or/c #f internal-definition-context?)" parent-ctx)) + (define ctx (get-current-expand-context 'syntax-local-make-definition-context)) + (define frame-id (or (root-expand-context-frame-id ctx) + (and parent-ctx (internal-definition-context-frame-id parent-ctx)) + (gensym))) + (define sc (new-scope 'intdef)) + (define def-ctx-scopes (expand-context-def-ctx-scopes ctx)) + (unless def-ctx-scopes (error "internal error: no box to accumulate definition-context scopes")) + (set-box! def-ctx-scopes (cons sc (unbox def-ctx-scopes))) + (internal-definition-context frame-id sc add-scope? (box null))) + +;; syntax-local-bind-syntaxes +(define (syntax-local-bind-syntaxes ids s intdef) + (unless (and (list? ids) + (andmap identifier? ids)) + (raise-argument-error 'syntax-local-bind-syntaxes "(listof identifier?)" ids)) + (unless (or (not s) (syntax? s)) + (raise-argument-error 'syntax-local-bind-syntaxes "(or/c syntax? #f)" s)) + (unless (internal-definition-context? intdef) + (raise-argument-error 'syntax-local-bind-syntaxes "internal-definition-context?" intdef)) + (define ctx (get-current-expand-context 'local-expand)) + (log-expand ctx 'local-bind ids) + (define phase (expand-context-phase ctx)) + (define intdef-env (add-intdef-bindings (expand-context-env ctx) + intdef)) + (define intdef-ids (for/list ([id (in-list ids)]) + (define pre-id (remove-use-site-scopes (flip-introduction-scopes id ctx) + ctx)) + (add-intdef-scopes pre-id intdef #:always? #t))) + (log-expand ctx 'rename-list intdef-ids) + (define syms (for/list ([intdef-id (in-list intdef-ids)]) + (add-local-binding! intdef-id phase (root-expand-context-counter ctx) + #:frame-id (internal-definition-context-frame-id intdef)))) + (define vals + (cond + [s + (define input-s (flip-introduction-scopes (add-intdef-scopes s intdef #:always? #t) + ctx)) + (define tmp-env (for/fold ([env intdef-env]) ([sym (in-list syms)]) + (hash-set env sym variable))) + (log-expand ctx 'enter-bind) + (define vals + (eval-for-syntaxes-binding input-s ids + (make-local-expand-context (struct*-copy expand-context ctx + [env tmp-env]) + #:context 'expression + #:intdefs intdef))) + (log-expand ctx 'exit-bind) + vals] + [else + (for/list ([id (in-list ids)]) variable)])) + (define env-mixins (internal-definition-context-env-mixins intdef)) + (set-box! env-mixins (append (for/list ([intdef-id (in-list intdef-ids)] + [sym (in-list syms)] + [val (in-list vals)]) + (maybe-install-free=id-in-context! val intdef-id phase ctx) + (env-mixin intdef-id sym val (make-weak-hasheq))) + (unbox env-mixins))) + (log-expand ctx 'exit-local-bind)) + +;; internal-definition-context-binding-identifiers +(define (internal-definition-context-binding-identifiers intdef) + (unless (internal-definition-context? intdef) + (raise-argument-error 'internal-definition-context-binding-identifiers "internal-definition-context?" intdef)) + (for/list ([env-mixin (in-list (unbox (internal-definition-context-env-mixins intdef)))]) + (env-mixin-id env-mixin))) + +;; internal-definition-context-introduce +(define (internal-definition-context-introduce intdef s [mode 'flip]) + (unless (internal-definition-context? intdef) + (raise-argument-error 'internal-definition-context-introduce "internal-definition-context?" intdef)) + (unless (syntax? s) + (raise-argument-error 'internal-definition-context-introduce "syntax?" s)) + (add-intdef-scopes s intdef + #:action (case mode + [(add) add-scope] + [(remove) remove-scope] + [(flip) flip-scope] + [else (raise-argument-error + internal-definition-context-introduce + "(or/c 'add 'remove 'flip)" + mode)]))) + +;; internal-definition-context-seal +(define (internal-definition-context-seal intdef) + (unless (internal-definition-context? intdef) + (raise-argument-error 'internal-definition-context-seal "internal-definition-context?" intdef)) + (void)) + +;; identifier-remove-from-definition-context +(define (identifier-remove-from-definition-context id intdef) + (unless (identifier? id) + (raise-argument-error 'identifier-remove-from-definition-context "identifier?" id)) + (unless (or (internal-definition-context? intdef) + (and (list? intdef) + (andmap internal-definition-context? intdef))) + (raise-argument-error 'identifier-remove-from-definition-context + "(or/c internal-definition-context? (listof internal-definition-context?))" + intdef)) + (for/fold ([id id]) ([intdef (in-intdefs intdef)]) + (internal-definition-context-introduce intdef id 'remove))) + +;; Sequence for intdefs provided to `local-expand` +(define-sequence-syntax in-intdefs + (lambda (stx) (raise-syntax-error #f "only allowed in a `for` form" stx)) + (lambda (stx) + (syntax-case stx () + [[(d) (_ arg)] + #'[(d) + (:do-in + ([(x) (let ([a arg]) + (cond + [(list? a) (reverse a)] + [(not a) null] + [else (list a)]))]) + #t + ([a x]) + (pair? a) + ([(d) (car a)]) + #t + #t + ((cdr a)))]]))) + +(define (add-intdef-bindings env intdefs) + (for/fold ([env env]) ([intdef (in-intdefs intdefs)]) + (define env-mixins (unbox (internal-definition-context-env-mixins intdef))) + (let loop ([env env] [env-mixins env-mixins]) + (cond + [(null? env-mixins) env] + [else + (define env-mixin (car env-mixins)) + (or (hash-ref (env-mixin-cache env-mixin) env #f) + (let ([new-env (env-extend (loop env (cdr env-mixins)) + (env-mixin-sym env-mixin) + (env-mixin-value env-mixin))]) + (hash-set! (env-mixin-cache env-mixin) env new-env) + new-env))])))) + +(define (add-intdef-scopes s intdefs + #:always? [always? #f] + #:action [action add-scope]) + (for/fold ([s s]) ([intdef (in-intdefs intdefs)] + #:when (or always? + (internal-definition-context-add-scope? intdef))) + (action s (internal-definition-context-scope intdef)))) + +;; ---------------------------------------- + +(define (make-local-expand-context ctx + #:context context + #:phase [phase (expand-context-phase ctx)] + #:intdefs intdefs + #:stop-ids [stop-ids #f] + #:to-parsed-ok? [to-parsed-ok? #f] + #:track-to-be-defined? [track-to-be-defined? #f]) + (define same-kind? (or (eq? context + (expand-context-context ctx)) + (and (list? context) + (list? (expand-context-context ctx))))) + (define all-stop-ids (and stop-ids (stop-ids->all-stop-ids stop-ids phase))) + (define def-ctx-scopes (if (expand-context-def-ctx-scopes ctx) + (unbox (expand-context-def-ctx-scopes ctx)) + null)) + (struct*-copy expand-context ctx + [context context] + [env (add-intdef-bindings (expand-context-env ctx) + intdefs)] + [use-site-scopes + #:parent root-expand-context + (and (or (eq? context 'module) + (eq? context 'module-begin) + (list? context)) + (or (root-expand-context-use-site-scopes ctx) + (box null)))] + [frame-id #:parent root-expand-context + ;; If there are multiple definition contexts in `intdefs` + ;; and if they have different frame IDs, then we conservatively + ;; turn on use-site scopes for all frame IDs + (for/fold ([frame-id (root-expand-context-frame-id ctx)]) ([intdef (in-intdefs intdefs)]) + (define i-frame-id (internal-definition-context-frame-id intdef)) + (cond + [(and frame-id i-frame-id (not (eq? frame-id i-frame-id))) + ;; Special ID 'all means "use-site scopes for all expansions" + 'all] + [else (or frame-id i-frame-id)]))] + [post-expansion-scope + #:parent root-expand-context + (if intdefs + (new-scope 'macro) ; placeholder; action uses `indefs` + (and same-kind? + (memq context '(module module-begin top-level)) + (root-expand-context-post-expansion-scope ctx)))] + [post-expansion-scope-action + (if intdefs + (lambda (s placeholder-sc) + (add-intdef-scopes s intdefs)) + (expand-context-post-expansion-scope-action ctx))] + [scopes + (append def-ctx-scopes + (expand-context-scopes ctx))] + [only-immediate? (not stop-ids)] ; def-ctx-scopes is set for the enclosing transformer call + [to-parsed? (if to-parsed-ok? + (expand-context-to-parsed? ctx) + #f)] + [just-once? #f] + [in-local-expand? #t] + [stops (free-id-set phase (or all-stop-ids null))] + [current-introduction-scopes null] + [need-eventually-defined (let ([ht (expand-context-need-eventually-defined ctx)]) + (cond + [track-to-be-defined? + ;; maintain status quo and propagate tracking + ht] + [ht + ;; keep allowing unbound references, but don't track them + (make-hasheqv)] + [else + ;; keep disallowing unbound references + #f]))])) + +;; ---------------------------------------- + +(define (flip-introduction-scopes s ctx) + (flip-scopes s (expand-context-current-introduction-scopes ctx))) diff --git a/racket/src/expander/expand/dup-check.rkt b/racket/src/expander/expand/dup-check.rkt new file mode 100644 index 0000000000..333fd5ed49 --- /dev/null +++ b/racket/src/expander/expand/dup-check.rkt @@ -0,0 +1,28 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/error.rkt") + +(provide make-check-no-duplicate-table + check-no-duplicate-ids) + +(define (make-check-no-duplicate-table) #hasheq()) + +;; Check for duplicates, returning a table on success that can be +;; used for further checking. +;; The `ids` argument can be a single identifier, a list, a list of +;; lists, etc. +(define (check-no-duplicate-ids ids phase s [ht (make-check-no-duplicate-table)] + #:what [what "binding name"]) + (let loop ([v ids] [ht ht]) + (cond + [(identifier? v) + (define l (hash-ref ht (syntax-e v) null)) + (for ([id (in-list l)]) + (when (bound-identifier=? id v phase) + (raise-syntax-error #f (string-append "duplicate " what) s v))) + (hash-set ht (syntax-e v) (cons v l))] + [(pair? v) + (loop (cdr v) (loop (car v) ht))] + [else + ht]))) diff --git a/racket/src/expander/expand/env.rkt b/racket/src/expander/expand/env.rkt new file mode 100644 index 0000000000..1c50a37f46 --- /dev/null +++ b/racket/src/expander/expand/env.rkt @@ -0,0 +1,154 @@ +#lang racket/base +(require "../common/memo.rkt" + "../syntax/syntax.rkt" + "../syntax/error.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../common/phase.rkt" + "../syntax/binding.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "protect.rkt" + "binding-to-module.rkt" + "set-bang-trans.rkt" + "rename-trans.rkt" + "../common/module-path.rkt") + +(provide empty-env + env-extend + + variable + (struct-out core-form) + + transformer? transformer->procedure + variable? + + (struct-out local-variable) + substitute-variable + + add-binding! + add-bulk-binding! + add-local-binding! + + binding-lookup) + +;; ---------------------------------------- + +;; An expansion environment maps keys to either `variable` or a +;; compile-time value: +(define empty-env #hasheq()) +(define (env-extend env key val) + (hash-set env key val)) + +;; `variable` is a token to represent a binding to a run-time variable +(define variable (gensym 'variable)) +(define (variable? t) (or (eq? t variable) + (local-variable? t))) + +;; A `local-variable` records a binding identifier, so that a +;; reference can be replaced with the binding identifier +(struct local-variable (id) #:authentic) + +;; If a variable binding corresponds to a local binding, substitute +;; the binding identifier in place of the original reference +(define (substitute-variable id t #:no-stops? no-stops?) + (if (and no-stops? (local-variable? t)) + (let ([bind-id (local-variable-id t)]) + ;; Keep source locations and properties of original reference: + (syntax-rearm (datum->syntax (syntax-disarm bind-id) (syntax-e bind-id) id id) + id)) + id)) + +;; `missing` is a token to represent the absence of a binding; a +;; distinct token is needed so that it's distinct from all compile-time +;; values +(define missing (gensym 'missing)) +(define (missing? t) (eq? t missing)) + +;; A subset of compile-time values are macro transformers +(define (transformer? t) (or (procedure? t) + (set!-transformer? t) + (rename-transformer? t))) +(define (transformer->procedure t) + (cond + [(set!-transformer? t) (set!-transformer-procedure t)] + [(rename-transformer? t) (lambda (s) s)] ; "expansion" handled via #:alternate-id + [else t])) + +;; A subset of compile-time values are primitive forms +(struct core-form (expander name) #:transparent #:authentic) + +;; ---------------------------------------- + +(define (add-binding! id binding phase #:in [in-s #f] #:just-for-nominal? [just-for-nominal? #f]) + (check-id-taint id in-s) + (add-binding-in-scopes! (syntax-scope-set id phase) (syntax-e id) binding + #:just-for-nominal? just-for-nominal?)) + +(define (add-bulk-binding! s binding phase #:in [in-s #f]) + (when (syntax-tainted? s) + (raise-syntax-error #f "cannot bind from tainted syntax" in-s s)) + (add-bulk-binding-in-scopes! (syntax-scope-set s phase) binding)) + +;; Helper for registering a local binding in a set of scopes: +(define (add-local-binding! id phase counter #:frame-id [frame-id #f] #:in [in-s #f]) + (check-id-taint id in-s) + (set-box! counter (add1 (unbox counter))) + (define key (string->uninterned-symbol (format "~a_~a" (syntax-e id) (unbox counter)))) + (add-binding-in-scopes! (syntax-scope-set id phase) (syntax-e id) (make-local-binding key #:frame-id frame-id)) + key) + +(define (check-id-taint id in-s) + (when (syntax-tainted? id) + (raise-syntax-error #f "cannot bind tainted identifier" in-s id))) + +;; ---------------------------------------- + +;; Returns: `variable` or a compile-time value +;; #f or #t indicating whether the binding is to a primitive +;; #f or (for a transformer) an inspector for the defining module +;; A binding provided to `binding-lookup` should be obtained either by +;; passing `#:immediate? #t` to `resolve+shift` or by using `resolve+shift/extra-inspector`, +;; where the latter checks protected access for `free-identifier=?` equivalence +;; chains to provide an inspector associated with the endpoint identifier; using +;; just `resolve+shift` may leave the access with a too-weak inspector. +(define (binding-lookup b env lift-envs ns phase id + #:in [in-s #f] + #:out-of-context-as-variable? [out-of-context-as-variable? #f]) + (cond + [(module-binding? b) + (define top-level? (top-level-module-path-index? (module-binding-module b))) + (define mi (and (not top-level?) (binding->module-instance b ns phase id))) + (define m (and mi (module-instance-module mi))) + (define primitive? (and m (module-primitive? m))) + (define m-ns (if top-level? ns (and mi (module-instance-namespace mi)))) + (check-taint id) + (define t (namespace-get-transformer m-ns (module-binding-phase b) (module-binding-sym b) + variable)) + (when mi (check-access b mi id in-s (if (variable? t) "variable" "transformer"))) + (define insp (and mi (module-instance-module mi) (module-inspector (module-instance-module mi)))) + (values t primitive? insp)] + [(local-binding? b) + (define t (hash-ref env (local-binding-key b) missing)) + (cond + [(eq? t missing) + (values (or + ;; check in lift envs, if any + (for/or ([lift-env (in-list lift-envs)]) + (hash-ref (unbox lift-env) (local-binding-key b) #f)) + (if out-of-context-as-variable? + variable + (error "identifier used out of context:" id))) + #f + #f)] + [else + (check-taint id) + (values t #f #f)])] + [else (error "internal error: unknown binding for lookup:" b)])) + +;; Check for taints on a variable reference +(define (check-taint id) + (when (syntax-tainted? id) + (raise-syntax-error #f + "cannot use identifier tainted by macro transformation" + id))) diff --git a/racket/src/expander/expand/expanded+parsed.rkt b/racket/src/expander/expand/expanded+parsed.rkt new file mode 100644 index 0000000000..a1e0686e45 --- /dev/null +++ b/racket/src/expander/expand/expanded+parsed.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "parsed.rkt" + "rebuild.rkt") + +(provide (struct-out expanded+parsed) + (struct-out semi-parsed-define-values) + (struct-out semi-parsed-begin-for-syntax) + extract-syntax + parsed-only + syntax-only) + +;; When expanding a module, we may need to compile and instantiate it, +;; too (as or for submodules), so keep both expanded and compiled +;; variants of a form together: +(struct expanded+parsed (s parsed) #:authentic) + +;; A `define-values` or `begin-for-syntax-form` is in limbo though +;; some passes. +(struct semi-parsed-define-values (s syms ids rhs) #:authentic) +(struct semi-parsed-begin-for-syntax (s body) #:authentic) + +(define (extract-syntax s) + (if (expanded+parsed? s) + (expanded+parsed-s s) + s)) + +(define (parsed-only l) + (for/list ([i (in-list l)] + #:when (or (parsed? i) + (expanded+parsed? i) + (semi-parsed-begin-for-syntax? i))) + (cond + [(expanded+parsed? i) + (expanded+parsed-parsed i)] + [(semi-parsed-begin-for-syntax? i) + (parsed-begin-for-syntax (semi-parsed-begin-for-syntax-s i) + (parsed-only (semi-parsed-begin-for-syntax-body i)))] + [else i]))) + +(define (syntax-only l) + (for/list ([i (in-list l)] + #:when (or (syntax? i) + (expanded+parsed? i) + (semi-parsed-begin-for-syntax? i))) + (cond + [(expanded+parsed? i) (expanded+parsed-s i)] + [(semi-parsed-begin-for-syntax? i) + ;; If `l` is after skipping `module*` expansion, then we may + ;; still have semi-parsed `begin-for-syntax` + (define s (semi-parsed-begin-for-syntax-s i)) + (define nested-bodys (semi-parsed-begin-for-syntax-body i)) + (let ([disarmed-s (syntax-disarm s)]) + (define-match m disarmed-s '(begin-for-syntax _ ...)) + (rebuild s `(,(m 'begin-for-syntax) ,@(syntax-only nested-bodys))))] + [else i]))) diff --git a/racket/src/expander/expand/expr.rkt b/racket/src/expander/expand/expr.rkt new file mode 100644 index 0000000000..3fdf98494d --- /dev/null +++ b/racket/src/expander/expand/expr.rkt @@ -0,0 +1,756 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../namespace/namespace.rkt" + "../common/module-path.rkt" + "../syntax/binding.rkt" + "env.rkt" + "free-id-set.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "syntax-id-error.rkt" + "dup-check.rkt" + "../namespace/core.rkt" + "context.rkt" + "allowed-context.rkt" + "main.rkt" + "body.rkt" + "set-bang-trans.rkt" + "rename-trans.rkt" + "reference-record.rkt" + "prepare.rkt" + "log.rkt" + "parsed.rkt") + +;; ---------------------------------------- + +;; Common expansion for `lambda` and `case-lambda` +(define (lambda-clause-expander s disarmed-s formals bodys ctx log-renames-tag) + (define sc (new-scope 'local)) + (define phase (expand-context-phase ctx)) + ;; Parse and check formal arguments: + (define ids (parse-and-flatten-formals formals sc disarmed-s)) + (check-no-duplicate-ids ids phase s #:what "argument name") + ;; Bind each argument and generate a corresponding key for the + ;; expand-time environment: + (define counter (root-expand-context-counter ctx)) + (define keys (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:in s))) + (define body-env (for/fold ([env (expand-context-env ctx)]) ([key (in-list keys)] + [id (in-list ids)]) + (env-extend env key (local-variable id)))) + (define sc-formals (add-scope formals sc)) + (define sc-bodys (for/list ([body (in-list bodys)]) (add-scope body sc))) + (log-expand ctx log-renames-tag sc-formals (datum->syntax #f sc-bodys)) + ;; Expand the function body: + (define body-ctx (struct*-copy expand-context ctx + [env body-env] + [scopes (cons sc (expand-context-scopes ctx))] + [binding-layer (increment-binding-layer ids ctx sc)] + [frame-id #:parent root-expand-context #f])) + (define exp-body (expand-body sc-bodys body-ctx #:source (keep-as-needed ctx s #:keep-for-error? #t))) + ;; Return formals (with new scope) and expanded body: + (values (if (expand-context-to-parsed? ctx) + (unflatten-like-formals keys formals) + sc-formals) + exp-body)) + +(define (make-expand-lambda get-lambda) + (lambda (s ctx) + (log-expand ctx 'prim-lambda) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(lambda formals body ...+)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t)) + (define-values (formals body) + (lambda-clause-expander s disarmed-s (m 'formals) (m 'body) ctx 'lambda-renames)) + (if (expand-context-to-parsed? ctx) + (parsed-lambda rebuild-s formals body) + (rebuild + rebuild-s + `(,(get-lambda ctx (m 'lambda)) ,formals ,@body))))) + +(add-core-form! + 'lambda + (make-expand-lambda (lambda (ctx lam-id) lam-id))) + +(add-core-form! + 'λ + (make-expand-lambda + (lambda (ctx lam-id) + (datum->syntax (syntax-shift-phase-level core-stx (expand-context-phase ctx)) + 'lambda + lam-id + lam-id)))) + +(add-core-form! + 'case-lambda + (lambda (s ctx) + (log-expand ctx 'prim-case-lambda) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(case-lambda [formals body ...+] ...)) + (define-match cm disarmed-s '(case-lambda clause ...)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t)) + (define clauses + (for/list ([formals (in-list (m 'formals))] + [body (in-list (m 'body))] + [clause (in-list (cm 'clause))]) + (log-expand ctx 'next) + (define rebuild-clause (keep-as-needed ctx clause)) + (define-values (exp-formals exp-body) + (lambda-clause-expander s disarmed-s formals body ctx 'case-lambda-renames)) + (if (expand-context-to-parsed? ctx) + (list exp-formals exp-body) + (rebuild rebuild-clause `[,exp-formals ,@exp-body])))) + (if (expand-context-to-parsed? ctx) + (parsed-case-lambda rebuild-s clauses) + (rebuild + rebuild-s + `(,(m 'case-lambda) ,@clauses))))) + +(define (parse-and-flatten-formals all-formals sc s) + (let loop ([formals all-formals]) + (cond + [(identifier? formals) (list (add-scope formals sc))] + [(syntax? formals) + (define p (syntax-e formals)) + (cond + [(pair? p) (loop p)] + [(null? p) null] + [else (raise-syntax-error #f "not an identifier" s p)])] + [(pair? formals) + (unless (identifier? (car formals)) + (raise-syntax-error #f "not an identifier" s (car formals))) + (cons (add-scope (car formals) sc) + (loop (cdr formals)))] + [(null? formals) + null] + [else + (raise-syntax-error "bad argument sequence" s all-formals)]))) + +(define (unflatten-like-formals keys formals) + (let loop ([keys keys] [formals formals]) + (cond + [(null? formals) null] + [(pair? formals) (cons (car keys) (loop (cdr keys) (cdr formals)))] + [(syntax? formals) (loop keys (syntax-e formals))] + [else (car keys)]))) + +;; ---------------------------------------- + +;; Common expansion for `let[rec]-[syntaxes+]values` +(define (make-let-values-form #:log-tag log-tag + #:syntaxes? [syntaxes? #f] + #:rec? [rec? #f] + #:split-by-reference? [split-by-reference? #f] + #:renames-log-tag [renames-log-tag 'let-renames]) + (lambda (s ctx) + (log-expand ctx log-tag) + (define disarmed-s (syntax-disarm s)) + (define-match stx-m disarmed-s #:when syntaxes? + '(letrec-syntaxes+values + ([(id:trans ...) trans-rhs] ...) + ([(id:val ...) val-rhs] ...) + body ...+)) + (define-match val-m disarmed-s #:unless syntaxes? + '(let-values ([(id:val ...) val-rhs] ...) + body ...+)) + (define sc (new-scope 'local)) + (define phase (expand-context-phase ctx)) + (define frame-id (and syntaxes? + (make-reference-record))) ; accumulates info on referenced variables + ;; Add the new scope to each binding identifier: + (define trans-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:trans) null))]) + (for/list ([id (in-list ids)]) + (add-scope id sc)))) + (define val-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:val) (val-m 'id:val)))]) + (for/list ([id (in-list ids)]) + (add-scope id sc)))) + (define val-rhss (if rec? + (for/list ([rhs (in-list (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs)))]) + (add-scope rhs sc)) + (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs)))) + (check-no-duplicate-ids (list trans-idss val-idss) phase s) + ;; Bind each left-hand identifier and generate a corresponding key + ;; fo the expand-time environment: + (define counter (root-expand-context-counter ctx)) + (define trans-keyss (for/list ([ids (in-list trans-idss)]) + (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in s)))) + (define val-keyss (for/list ([ids (in-list val-idss)]) + (for/list ([id (in-list ids)]) + (add-local-binding! id phase counter #:frame-id frame-id #:in s)))) + ;; Add new scope to body: + (define bodys (for/list ([body (in-list (if syntaxes? (stx-m 'body) (val-m 'body)))]) + (add-scope body sc))) + (log-expand... ctx (lambda (obs) + (log-let-renames obs renames-log-tag val-idss val-rhss bodys + trans-idss (and syntaxes? (stx-m 'trans-rhs)) sc))) + ;; Evaluate compile-time expressions (if any): + (when syntaxes? + (log-expand ctx 'prepare-env) + (prepare-next-phase-namespace ctx)) + (define trans-valss (for/list ([rhs (in-list (if syntaxes? (stx-m 'trans-rhs) '()))] + [ids (in-list trans-idss)]) + (log-expand* ctx ['next] ['enter-bind]) + (define trans-val (eval-for-syntaxes-binding (add-scope rhs sc) ids ctx)) + (log-expand ctx 'exit-bind) + trans-val)) + ;; Fill expansion-time environment: + (define rec-val-env + (for/fold ([env (expand-context-env ctx)]) ([keys (in-list val-keyss)] + [ids (in-list val-idss)] + #:when #t + [key (in-list keys)] + [id (in-list ids)]) + (env-extend env key (local-variable id)))) + (define rec-env (for/fold ([env rec-val-env]) ([keys (in-list trans-keyss)] + [vals (in-list trans-valss)] + [ids (in-list trans-idss)]) + (for/fold ([env env]) ([key (in-list keys)] + [val (in-list vals)] + [id (in-list ids)]) + (maybe-install-free=id-in-context! val id phase ctx) + (env-extend env key val)))) + ;; Expand right-hand sides and body + (define expr-ctx (as-expression-context ctx)) + (define orig-rrs (expand-context-reference-records expr-ctx)) + (define rec-ctx (struct*-copy expand-context expr-ctx + [env rec-env] + [scopes (cons sc (expand-context-scopes ctx))] + [reference-records (if split-by-reference? + (cons frame-id orig-rrs) + orig-rrs)] + [binding-layer (increment-binding-layer + (cons trans-idss val-idss) + ctx + sc)])) + (define letrec-values-id + (and (not (expand-context-to-parsed? ctx)) + (if syntaxes? + (core-id 'letrec-values phase) + (val-m 'let-values)))) + + (define rebuild-s (keep-as-needed ctx s #:keep-for-error? #t)) + (define val-name-idss (if (expand-context-to-parsed? ctx) + (for/list ([val-ids (in-list val-idss)]) + (for/list ([val-id (in-list val-ids)]) + (datum->syntax #f (syntax-e val-id) val-id val-id))) + val-idss)) + + (when syntaxes? + (log-expand... ctx (lambda (obs) (log-letrec-values obs val-idss val-rhss bodys)))) + + (define (get-body) + (log-expand* ctx #:unless (and syntaxes? (null? val-idss)) ['next-group]) + (define body-ctx (struct*-copy expand-context rec-ctx + [reference-records orig-rrs])) + (expand-body bodys (as-tail-context body-ctx #:wrt ctx) #:source rebuild-s)) + + (define result-s + (cond + [(not split-by-reference?) + (define clauses + (for/list ([ids (in-list val-name-idss)] + [keys (in-list val-keyss)] + [rhs (in-list val-rhss)]) + (log-expand ctx 'next) + (define exp-rhs (expand rhs (if rec? + (as-named-context rec-ctx ids) + (as-named-context expr-ctx ids)))) + (if (expand-context-to-parsed? ctx) + (list keys exp-rhs) + `[,ids ,exp-rhs]))) + (define exp-body (get-body)) + (when frame-id + (reference-record-clear! frame-id)) + (if (expand-context-to-parsed? ctx) + (if rec? + (parsed-letrec-values rebuild-s val-name-idss clauses exp-body) + (parsed-let-values rebuild-s val-name-idss clauses exp-body)) + (rebuild + rebuild-s + `(,letrec-values-id ,clauses ,@exp-body)))] + [else + (expand-and-split-bindings-by-reference + val-idss val-keyss val-rhss (for/list ([rhs (in-list val-idss)]) + #f) + #:split? #t + #:frame-id frame-id #:ctx rec-ctx + #:source rebuild-s #:had-stxes? syntaxes? + #:get-body get-body #:track? #t)])) + + (if (expand-context-to-parsed? ctx) + result-s + (attach-disappeared-transformer-bindings result-s trans-idss)))) + +(define (log-let-renames obs renames-log-tag val-idss val-rhss bodys + trans-idss trans-rhss sc) + (define vals+body (cons (for/list ([val-ids (in-list val-idss)] + [val-rhs (in-list val-rhss)]) + (datum->syntax #f `[,val-ids ,val-rhs])) + (datum->syntax #f bodys))) + (...log-expand obs [renames-log-tag (if (not trans-rhss) + vals+body + (cons + (for/list ([trans-ids (in-list trans-idss)] + [trans-rhs (in-list trans-rhss)]) + (datum->syntax #f `[,trans-ids ,(add-scope trans-rhs sc)])) + vals+body))])) + +(define (log-letrec-values obs val-idss val-rhss bodys) + (...log-expand obs ['next-group]) + (unless (null? val-idss) + (...log-expand obs ['prim-letrec-values]) + (log-let-renames obs 'let-renames val-idss val-rhss bodys + #f #f #f))) + +(add-core-form! + 'let-values + (make-let-values-form #:log-tag 'prim-let-values)) + +(add-core-form! + 'letrec-values + (make-let-values-form #:rec? #t #:log-tag 'prim-letrec-values)) + +(add-core-form! + 'letrec-syntaxes+values + (make-let-values-form #:syntaxes? #t #:rec? #t #:split-by-reference? #t + #:log-tag 'prim-letrec-syntaxes+values + #:renames-log-tag 'letrec-syntaxes-renames)) + +;; ---------------------------------------- + +(add-core-form! + '#%stratified-body + (lambda (s ctx) + (log-expand ctx 'prim-#%stratified) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%stratified-body body ...+)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-error? #t)) + (define exp-body (expand-body (m 'body) ctx #:stratified? #t #:source rebuild-s)) + (if (expand-context-to-parsed? ctx) + (parsed-begin rebuild-s exp-body) + (rebuild + rebuild-s + (if (null? (cdr exp-body)) + (car exp-body) + `(,(core-id 'begin (expand-context-phase ctx)) + ,@exp-body)))))) + +;; ---------------------------------------- + +(add-core-form! + '#%datum + (lambda (s ctx) + (log-expand ctx 'prim-#%datum) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%datum . datum)) + (define datum (m 'datum)) + (when (and (syntax? datum) + (keyword? (syntax-e datum))) + (raise-syntax-error '#%datum "keyword misused as an expression" #f datum)) + (define phase (expand-context-phase ctx)) + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (parsed-quote (keep-properties-only~ s) (syntax->datum datum)) + (rebuild + s + (list (core-id 'quote phase) + datum))))) + +;; '#%kernel `#%app` treats an empty combination as a literal null +(add-core-form! + '#%app + (lambda (s ctx) + (log-expand ctx 'prim-#%app) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%app e ...)) + (define es (m 'e)) + (cond + [(null? es) + (define phase (expand-context-phase ctx)) + (if (expand-context-to-parsed? ctx) + (parsed-quote (keep-properties-only~ s) null) + (rebuild + s + (list (core-id 'quote phase) + null)))] + [else + (define keep-for-parsed? (eq? (system-type 'vm) 'chez-scheme)) + (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? keep-for-parsed?)) + (define prefixless (cdr (syntax-e disarmed-s))) + (define rebuild-prefixless (and (syntax? prefixless) + (keep-as-needed ctx prefixless #:keep-for-parsed? keep-for-parsed?))) + (define expr-ctx (as-expression-context ctx)) + (log-expand* expr-ctx ['enter-list (datum->syntax #f es s)] ['next]) + (define rest-es (cdr es)) + (define exp-rator (expand (car es) expr-ctx)) + (define exp-es (for/list ([e (in-list rest-es)]) + (log-expand expr-ctx 'next) + (expand e expr-ctx))) + (cond + [(expand-context-to-parsed? ctx) + (parsed-app (or rebuild-prefixless rebuild-s) exp-rator exp-es)] + [else + (define es (let ([exp-es (cons exp-rator exp-es)]) + (if rebuild-prefixless + (rebuild rebuild-prefixless exp-es) + exp-es))) + (log-expand expr-ctx 'exit-list (datum->syntax #f es rebuild-s)) + (rebuild rebuild-s (cons (m '#%app) es))])]))) + + +(add-core-form! + 'quote + (lambda (s ctx) + (log-expand ctx 'prim-quote) + (define-match m (syntax-disarm s) '(quote datum)) + (if (expand-context-to-parsed? ctx) + (parsed-quote (keep-properties-only~ s) (syntax->datum (m 'datum))) + s))) + +(add-core-form! + 'quote-syntax + (lambda (s ctx) + (log-expand ctx 'prim-quote-syntax) + (define disarmed-s (syntax-disarm s)) + (define-match m-local disarmed-s #:try '(quote-syntax datum #:local)) + (define-match m disarmed-s #:unless (m-local) '(quote-syntax datum)) + (cond + [(m-local) + ;; #:local means don't prune, and it counts as a reference to + ;; all variables for letrec splitting + (reference-records-all-used! (expand-context-reference-records ctx)) + (define-match m-kw disarmed-s '(_ _ kw)) + (if (expand-context-to-parsed? ctx) + (parsed-quote-syntax (keep-properties-only~ s) (m-local 'datum)) + (rebuild + s + `(,(m-local 'quote-syntax) ,(m-local 'datum) ,(m-kw 'kw))))] + [else + ;; otherwise, prune scopes up to transformer boundary: + (define datum-s (remove-scopes (m 'datum) (expand-context-scopes ctx))) + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (parsed-quote-syntax (keep-properties-only~ s) datum-s) + (rebuild + s + `(,(m 'quote-syntax) + ,datum-s)))]))) + +(add-core-form! + 'if + (lambda (s ctx) + (log-expand ctx 'prim-if) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(if tst thn els)) + (define expr-ctx (as-expression-context ctx)) + (define tail-ctx (as-tail-context expr-ctx #:wrt ctx)) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-tst (expand (m 'tst) expr-ctx)) + (log-expand ctx 'next) + (define exp-thn (expand (m 'thn) tail-ctx)) + (log-expand ctx 'next) + (define exp-els (expand (m 'els) tail-ctx)) + (if (expand-context-to-parsed? ctx) + (parsed-if rebuild-s exp-tst exp-thn exp-els) + (rebuild + rebuild-s + (list (m 'if) exp-tst exp-thn exp-els))))) + +(add-core-form! + 'with-continuation-mark + (lambda (s ctx) + (log-expand ctx 'prim-with-continuation-mark) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(with-continuation-mark key val body)) + (define expr-ctx (as-expression-context ctx)) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-key (expand (m 'key) expr-ctx)) + (log-expand ctx 'next) + (define exp-val (expand (m 'val) expr-ctx)) + (log-expand ctx 'next) + (define exp-body (expand (m 'body) (as-tail-context expr-ctx #:wrt ctx))) + (if (expand-context-to-parsed? ctx) + (parsed-with-continuation-mark rebuild-s exp-key exp-val exp-body) + (rebuild + rebuild-s + (list (m 'with-continuation-mark) exp-key exp-val exp-body))))) + +(define (make-begin log-tag parsed-begin + #:list-start-index list-start-index + #:last-is-tail? last-is-tail?) + (lambda (s ctx) + (log-expand ctx log-tag) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(begin e ...+)) + (define expr-ctx (if last-is-tail? + (as-begin-expression-context ctx) + (as-expression-context ctx))) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-es + (let loop ([es (m 'e)] [index list-start-index]) + (when (zero? index) + (log-expand... ctx + (lambda (obs) + (unless (zero? list-start-index) + (...log-expand obs ['next])) + (...log-expand obs ['enter-list (datum->syntax #f es rebuild-s)])))) + (cond + [(null? es) null] + [else + (define rest-es (cdr es)) + (log-expand ctx 'next) + (cons (expand (car es) (if (and last-is-tail? (null? rest-es)) + (as-tail-context expr-ctx #:wrt ctx) + expr-ctx)) + (loop rest-es (sub1 index)))]))) + (log-expand ctx 'exit-list (datum->syntax #f (list-tail exp-es list-start-index) rebuild-s)) + (if (expand-context-to-parsed? ctx) + (parsed-begin rebuild-s exp-es) + (rebuild + rebuild-s + (cons (m 'begin) exp-es))))) + +(add-core-form! + 'begin + (let ([nonempty-begin (make-begin 'prim-begin parsed-begin #:list-start-index 0 #:last-is-tail? #t)]) + (lambda (s ctx) + ;; Empty `begin` allowed in 'top-level and 'module contexts, + ;; which might get here via `local-expand`: + (define context (expand-context-context ctx)) + (cond + [(or (eq? context 'top-level) (eq? context 'module)) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s #:try '(begin)) + (if (m) + s + (nonempty-begin s ctx))] + [else + (nonempty-begin s ctx)])))) + +(add-core-form! + 'begin0 + (make-begin 'prim-begin0 parsed-begin0 #:list-start-index 1 #:last-is-tail? #f)) + +(define (register-eventual-variable!? id ctx) + (cond + [(and (expand-context-need-eventually-defined ctx) + ((expand-context-phase ctx) . >= . 1)) + ;; In top level or `begin-for-syntax`, encountered a reference to a + ;; variable that might be defined later; record it for later checking + (hash-update! (expand-context-need-eventually-defined ctx) + (expand-context-phase ctx) + (lambda (l) (cons id l)) + null) + #t] + [else #f])) + +(add-core-form! + '#%top + (lambda (s ctx [implicit-omitted? #f]) + (log-expand ctx 'prim-#%top) + (define disarmed-s (syntax-disarm s)) + (define id (cond + [implicit-omitted? + ;; As a special favor to `local-expand`, the expander + ;; has avoided making `#%top` explicit + s] + [else + (define-match m disarmed-s '(#%top . id)) + (m 'id)])) + (define b (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous)) + (cond + [(eq? b 'ambiguous) + (raise-ambiguous-error id ctx)] + [(and b + (module-binding? b) + (eq? (module-binding-module b) (namespace-mpi (expand-context-namespace ctx)))) + ;; Allow `#%top` in a module or top-level where it refers to the same + ;; thing that the identifier by itself would refer to; in that case + ;; `#%top` can be stripped within a module + (if (expand-context-to-parsed? ctx) + (parsed-id id b #f) + (cond + [(top-level-module-path-index? (module-binding-module b)) s] + [else id]))] + [(register-eventual-variable!? id ctx) + ;; Must be in a module, and we'll check the binding later, so strip `#%top`: + (if (expand-context-to-parsed? ctx) + (parsed-id id b #f) + id)] + [else + (cond + [(not (expand-context-allow-unbound? ctx)) + ;; In a module, unbound or out of context: + (raise-unbound-syntax-error #f "unbound identifier" id #f null + (syntax-debug-info-string id ctx))] + [else + ;; At the top level: + (define tl-id (add-scope id (root-expand-context-top-level-bind-scope ctx))) + (define tl-b (resolve tl-id (expand-context-phase ctx))) + (cond + [tl-b + ;; Expand to a reference to a top-level variable, instead of + ;; a local or required variable; don't include the temporary + ;; binding scope in an expansion, though, in the same way that + ;; `define-values` expands without it + (if (expand-context-to-parsed? ctx) + (parsed-top-id tl-id tl-b #f) + (cond + [implicit-omitted? id] + [else + (define-match m disarmed-s '(#%top . id)) + (rebuild s (cons (m '#%top) id))]))] + [else (if (expand-context-to-parsed? ctx) + (parsed-top-id id b #f) + s)])])]))) + +(add-core-form! + 'set! + (lambda (s ctx) + (log-expand ctx 'prim-set!) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(set! id rhs)) + (define id (m 'id)) + (let rename-loop ([id id] [from-rename? #f]) + (define binding (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (when (eq? binding 'ambiguous) + (raise-ambiguous-error id ctx)) + (define-values (t primitive? insp) (if binding + (lookup binding ctx s) + (values #f #f #f))) + (log-expand ctx 'resolve id) + (cond + [(or (variable? t) + (and (not binding) + (or (register-eventual-variable!? id ctx) + (expand-context-allow-unbound? ctx)))) + (when (and (module-binding? binding) + (not (eq? (module-binding-module binding) + (namespace-mpi (expand-context-namespace ctx))))) + (raise-syntax-error #f "cannot mutate module-required identifier" s id)) + (log-expand ctx 'next) + (register-variable-referenced-if-local! binding) + (define rebuild-s (keep-as-needed ctx s)) + (define exp-rhs (expand (m 'rhs) (as-expression-context ctx))) + (if (expand-context-to-parsed? ctx) + (parsed-set! rebuild-s (parsed-id id binding #f) exp-rhs) + (rebuild + rebuild-s + (list (m 'set!) + (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx))) + exp-rhs)))] + [(not binding) + (raise-unbound-syntax-error #f "unbound identifier" s id null + (syntax-debug-info-string id ctx))] + [(set!-transformer? t) + (cond + [(not-in-this-expand-context? t ctx) + (expand (avoid-current-expand-context (substitute-set!-rename s disarmed-s (m 'set!) (m 'rhs) id from-rename? ctx) t ctx) + ctx)] + [else + (define-values (exp-s re-ctx) + (apply-transformer t insp s id ctx binding)) + (cond + [(expand-context-just-once? ctx) exp-s] + [else (expand exp-s re-ctx)])])] + [(rename-transformer? t) + (cond + [(not-in-this-expand-context? t ctx) + (expand (avoid-current-expand-context (substitute-set!-rename s disarmed-s (m 'set!) (m 'rhs) id from-rename? ctx t) t ctx) + ctx)] + [else (rename-loop (rename-transformer-target-in-context t ctx) #t)])] + [else + (raise-syntax-error #f "cannot mutate syntax identifier" s id)])))) + +(define (substitute-set!-rename s disarmed-s set!-id id rhs-s from-rename? ctx [t #f]) + (cond + [(or t from-rename?) + (define new-id (if t + (rename-transformer-target-in-context t ctx) + id)) + (syntax-rearm (datum->syntax disarmed-s (list set!-id new-id rhs-s) disarmed-s disarmed-s) + s)] + [else s])) + +(add-core-form! + '#%variable-reference + (lambda (s ctx) + (log-expand ctx 'prim-#%variable-reference) + (define disarmed-s (syntax-disarm s)) + (define-match id-m disarmed-s #:try '(#%variable-reference id)) + (define-match top-m disarmed-s #:unless (id-m) #:try '(#%variable-reference (#%top . id))) + (define-match empty-m disarmed-s #:unless (or (id-m) (top-m)) '(#%variable-reference)) + (cond + [(or (id-m) (top-m)) + (define var-id (if (id-m) (id-m 'id) (top-m 'id))) + (define binding (resolve+shift var-id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous)) + (when (eq? binding 'ambiguous) + (raise-ambiguous-error var-id ctx)) + (unless (or binding + (expand-context-allow-unbound? ctx)) + (raise-unbound-syntax-error #f "unbound identifier" s var-id null + (syntax-debug-info-string var-id ctx))) + (define-values (t primitive? insp-of-t) + (if binding + (lookup binding ctx var-id + #:in s + #:out-of-context-as-variable? (expand-context-in-local-expand? ctx)) + (values #f #f #f))) + (when (and t (not (variable? t))) + (raise-syntax-error #f "identifier does not refer to a variable" var-id s)) + (if (expand-context-to-parsed? ctx) + (parsed-#%variable-reference (keep-properties-only~ s) + ;; Intentionally not using `parsed-primitive-id`; + ;; see also `variable-reference->namespace` + (cond + [(top-m) (parsed-top-id var-id binding #f)] + [else (parsed-id var-id binding #f)])) + s)] + [else + (if (expand-context-to-parsed? ctx) + (parsed-#%variable-reference (keep-properties-only~ s) #f) + s)]))) + +(add-core-form! + '#%expression + (lambda (s ctx) + (log-expand ctx 'prim-#%expression) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%expression e)) + (define rebuild-s (keep-as-needed ctx s #:for-track? #t)) + (define exp-e (expand (m 'e) (as-tail-context (as-expression-context ctx) + #:wrt ctx))) + (if (expand-context-to-parsed? ctx) + exp-e + (case (and (not (expand-context-in-local-expand? ctx)) + (expand-context-context ctx)) + [(expression) + (define result-s (syntax-track-origin exp-e rebuild-s)) + (log-expand ctx 'tag result-s) + result-s] + [else (rebuild + rebuild-s + `(,(m '#%expression) ,exp-e))])))) + +;; ---------------------------------------- + +;; Historically in '#%kernel, should be moved out +(add-core-form! + 'unquote + (lambda (s ctx) + (raise-syntax-error #f "not in quasiquote" s))) +(add-core-form! + 'unquote-splicing + (lambda (s ctx) + (raise-syntax-error #f "not in quasiquote" s))) diff --git a/racket/src/expander/expand/free-id-set.rkt b/racket/src/expander/expand/free-id-set.rkt new file mode 100644 index 0000000000..6be6eb3627 --- /dev/null +++ b/racket/src/expander/expand/free-id-set.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require "../common/list-ish.rkt" + "../syntax/syntax.rkt" + "../syntax/binding.rkt") + +(provide free-id-set + empty-free-id-set + free-id-set-empty? + free-id-set-member? + free-id-set-empty-or-just-module*?) + +;; A free-id-set is a hash: sym -> list of id + +(define (free-id-set phase ids) + (for/fold ([ht #hasheq()]) ([id (in-list ids)]) + (define sym (identifier-binding-symbol id phase)) + (hash-set ht sym (cons-ish id (hash-ref ht sym null))))) + +(define empty-free-id-set (free-id-set 0 null)) + +(define (free-id-set-empty? fs) + (eq? fs empty-free-id-set)) + +(define (free-id-set-member? fs phase given-id) + (if (zero? (hash-count fs)) + #f + (for/or ([id (in-list-ish (hash-ref fs + (identifier-binding-symbol given-id phase) + null))]) + (free-identifier=? id given-id phase phase)))) + +(define (free-id-set-empty-or-just-module*? fs) + (define c (hash-count fs)) + ;; If any identifier other than `module*` is present, then many + ;; identifiers are present + (c . <= . 1)) diff --git a/racket/src/expander/expand/liberal-def-ctx.rkt b/racket/src/expander/expand/liberal-def-ctx.rkt new file mode 100644 index 0000000000..7d59e90837 --- /dev/null +++ b/racket/src/expander/expand/liberal-def-ctx.rkt @@ -0,0 +1,16 @@ +#lang racket/base + +(provide prop:liberal-define-context + (rename-out [has-liberal-define-context-property? liberal-define-context?]) + make-liberal-define-context) + +(define-values (prop:liberal-define-context has-liberal-define-context-property? liberal-define-context-value) + (make-struct-type-property 'liberal-define-context)) + +(struct liberal-define-context () + #:transparent + #:property prop:liberal-define-context #t + #:constructor-name make-liberal-define-context) + + + diff --git a/racket/src/expander/expand/lift-context.rkt b/racket/src/expander/expand/lift-context.rkt new file mode 100644 index 0000000000..fa5b325d1f --- /dev/null +++ b/racket/src/expander/expand/lift-context.rkt @@ -0,0 +1,222 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "env.rkt" + "../namespace/core.rkt" + "../namespace/namespace.rkt" + "root-expand-context.rkt" + "context.rkt" + "def-id.rkt") + +;; Helpers to implement the consumer side of `syntax-local-lift-expression`, +;; `syntax-local-lift-module`, etc. These structures are used by `syntax-local-...` +;; functions as communicated through the current expand context. + +(provide make-lift-context + add-lifted! + get-and-clear-lifts! + + make-local-lift + make-top-level-lift + wrap-lifts-as-let + wrap-lifts-as-begin + get-lifts-as-lists + + make-module-lift-context + get-and-clear-module-lifts! + add-lifted-module! + module-lift-context-wrt-phase + + make-require-lift-context + add-lifted-require! + get-and-clear-require-lifts! + require-lift-context-wrt-phase + + make-to-module-lift-context + make-shared-module-ends + to-module-lift-context-end-as-expressions? + get-and-clear-end-lifts! + get-and-clear-provide-lifts! + add-lifted-to-module-provide! + add-lifted-to-module-end! + to-module-lift-context-wrt-phase) + +;; ---------------------------------------- + +(define (box-cons! b v) + (set-box! b (cons v (unbox b)))) + +(define (box-clear! b) + (begin0 + (reverse (unbox b)) + (set-box! b null))) + +;; ---------------------------------------- + +(struct lift-context (convert ; takes a list of ids and rhs to produce a lifted-bind + lifts ; box of list of lifted-binds and maybe other forms + module*-ok?)) ; if used to capture module lifts, allow `module*`? +(struct lifted-bind (ids keys rhs)) + +(define (make-lift-context convert #:module*-ok? [module*-ok? #f]) + (lift-context convert (box null) module*-ok?)) + +(define (add-lifted! lifts ids rhs phase) + (define-values (lifted-ids lifted) ((lift-context-convert lifts) ids rhs phase)) + (box-cons! (lift-context-lifts lifts) lifted) + lifted-ids) + +(define (get-and-clear-lifts! lifts) + (box-clear! (lift-context-lifts lifts))) + +(define (make-local-lift lift-env counter) + (lambda (ids rhs phase) + (define keys + (for/list ([id (in-list ids)]) + (define key (add-local-binding! id phase counter)) + (set-box! lift-env (hash-set (unbox lift-env) key variable)) + key)) + (values ids (lifted-bind ids keys rhs)))) + +(define (make-top-level-lift ctx) + (lambda (ids rhs phase) + ;; Add the namespace's post-expansion scope (i.e., the inside-edge + ;; scope) so that the binding has a specific phase: + (define post-scope + (root-expand-context-post-expansion-scope + (namespace-get-root-expand-ctx + (expand-context-namespace ctx)))) + (define tl-ids (for/list ([id (in-list ids)]) + (add-scope id post-scope))) + ;; Bind the identifier: + (define syms (select-defined-syms-and-bind!/ctx tl-ids ctx)) + (values tl-ids (lifted-bind tl-ids syms rhs)))) + +(define (wrap-lifts-as-let lifts body phase) + (datum->syntax + #f + (for/fold ([body body]) ([lift (in-list (reverse lifts))]) + (unless (lifted-bind? lift) + (error "non-bindings in `lift-context`")) + (list (datum->syntax + (syntax-shift-phase-level core-stx phase) + 'let-values) + (list (list (lifted-bind-ids lift) + (lifted-bind-rhs lift))) + body)))) + +(define (wrap-lifts-as-begin lifts body phase + #:adjust-form [adjust-form values] + #:adjust-body [adjust-body values]) + (datum->syntax + #f + (cons (datum->syntax + (syntax-shift-phase-level core-stx phase) + 'begin) + (append + (for/list ([lift (in-list lifts)]) + (adjust-form + (cond + [(lifted-bind? lift) + (datum->syntax + #f + (list (datum->syntax + (syntax-shift-phase-level core-stx phase) + 'define-values) + (lifted-bind-ids lift) + (lifted-bind-rhs lift)))] + [else lift]))) + (list (adjust-body body)))))) + +(define (get-lifts-as-lists lifts) + (for/list ([lift (in-list lifts)]) + (list (lifted-bind-ids lift) + (lifted-bind-keys lift) + (lifted-bind-rhs lift)))) + +;; ---------------------------------------- + +(struct module-lift-context (wrt-phase ; phase of target for lifts + lifts ; box of list of lifted + module*-ok?)) ; whether `module*` is allowed + +(define (make-module-lift-context phase module*-ok?) + (module-lift-context phase (box null) module*-ok?)) + +(define (get-and-clear-module-lifts! module-lifts) + (box-clear! (module-lift-context-lifts module-lifts))) + +(define (add-lifted-module! module-lifts s phase) + (unless (or (and (module-lift-context? module-lifts) + (module-lift-context-module*-ok? module-lifts)) + (and (lift-context? module-lifts) + (lift-context-module*-ok? module-lifts))) + (case (core-form-sym s phase) + [(module) (void)] + [(module*) + (raise-arguments-error 'syntax-local-lift-module + "cannot lift `module*' to a top-level context" + "syntax" s)] + [else + (raise-arguments-error 'syntax-local-lift-module + "not a `module' declaration" + "syntax" s)])) + (cond + [(module-lift-context? module-lifts) + (box-cons! (module-lift-context-lifts module-lifts) s)] + [(lift-context? module-lifts) + ;; Top-level expansion uses a `lift-context` for both, which keeps + ;; modules and other lifts in order + (box-cons! (lift-context-lifts module-lifts) s)] + [else + (error "internal error: unrecognized lift-context type for module lift")])) + +;; ---------------------------------------- + +(struct require-lift-context (do-require ; callback to process a lifted require + wrt-phase ; phase of target for lifts + requires)) ; records lifted requires + +(define (make-require-lift-context wrt-phase do-require) + (require-lift-context do-require wrt-phase (box null))) + +(define (get-and-clear-require-lifts! require-lifts) + (box-clear! (require-lift-context-requires require-lifts))) + +(define (add-lifted-require! require-lifts s phase) + ((require-lift-context-do-require require-lifts) s phase) + (box-cons! (require-lift-context-requires require-lifts) + s)) + +;; ---------------------------------------- + +(struct to-module-lift-context (wrt-phase ; phase of target for lifts + provides + end-as-expressions? + ends)) + +(define (make-to-module-lift-context phase + #:shared-module-ends ends + #:end-as-expressions? end-as-expressions?) + (to-module-lift-context phase + (box null) + end-as-expressions? + ends)) + +(define (make-shared-module-ends) + (box null)) + +(define (get-and-clear-end-lifts! to-module-lifts) + (box-clear! (to-module-lift-context-ends to-module-lifts))) + +(define (get-and-clear-provide-lifts! to-module-lifts) + (box-clear! (to-module-lift-context-provides to-module-lifts))) + +(define (add-lifted-to-module-provide! to-module-lifts s phase) + (box-cons! (to-module-lift-context-provides to-module-lifts) + s)) + +(define (add-lifted-to-module-end! to-module-lifts s phase) + (box-cons! (to-module-lift-context-ends to-module-lifts) + s)) diff --git a/racket/src/expander/expand/lift-key.rkt b/racket/src/expander/expand/lift-key.rkt new file mode 100644 index 0000000000..89b70f0b95 --- /dev/null +++ b/racket/src/expander/expand/lift-key.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +;; A lift key represents a target for lifting, such as a particular +;; module body, a particular namespace, or a particular capture point + +(provide generate-lift-key) + +(define (generate-lift-key) + (gensym 'lift)) diff --git a/racket/src/expander/expand/local-expand.rkt b/racket/src/expander/expand/local-expand.rkt new file mode 100644 index 0000000000..7f48a0bed7 --- /dev/null +++ b/racket/src/expander/expand/local-expand.rkt @@ -0,0 +1,153 @@ +#lang racket/base +(require "../common/performance.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../namespace/core.rkt" + "../namespace/module.rkt" + "context.rkt" + "main.rkt" + "syntax-local.rkt" + "definition-context.rkt" + "already-expanded.rkt" + "lift-key.rkt" + "log.rkt" + "parsed.rkt") + +(provide local-expand + local-expand/capture-lifts + local-transformer-expand + local-transformer-expand/capture-lifts + syntax-local-expand-expression) + +(define (local-expand s context stop-ids [intdefs #f]) + (do-local-expand 'local-expand s context stop-ids intdefs)) + +(define (local-expand/capture-lifts s context stop-ids [intdefs #f] [lift-key (generate-lift-key)]) + (do-local-expand 'local-expand s context stop-ids intdefs + #:capture-lifts? #t + #:lift-key lift-key)) + +(define (local-transformer-expand s context stop-ids [intdefs #f]) + (do-local-expand 'local-expand s context stop-ids intdefs + #:as-transformer? #t)) + +(define (local-transformer-expand/capture-lifts s context stop-ids [intdefs #f] [lift-key (generate-lift-key)]) + (do-local-expand 'local-expand s context stop-ids intdefs + #:as-transformer? #t + #:capture-lifts? #t + #:lift-key lift-key)) + +(define (syntax-local-expand-expression s [opaque-only? #f]) + (define exp-s (do-local-expand 'syntax-local-expand-expression s 'expression null #f + #:to-parsed-ok? opaque-only? + #:skip-log-exit? #t + #:track-to-be-defined? #t)) + (define ctx (get-current-expand-context)) + ;; Move introduction scope from the already-expanded syntax object to + ;; its wrapper. The expander will later check that the wrapper ends up + ;; with an empty set of scopes, and then the already-expanded inside has + ;; the scopes suitably flipped + (define ae (flip-introduction-scopes + (datum->syntax #f (already-expanded + (if (parsed? exp-s) + exp-s + (flip-introduction-scopes exp-s ctx)) + (expand-context-binding-layer ctx))) + ctx)) + (log-expand ctx 'opaque-expr ae) + (log-expand ctx 'exit-local exp-s) + (values (and (not opaque-only?) exp-s) ae)) + +;; ---------------------------------------- + +(define (do-local-expand who s-or-s-exp context stop-ids [intdefs #f] + #:capture-lifts? [capture-lifts? #f] + #:as-transformer? [as-transformer? #f] + #:to-parsed-ok? [to-parsed-ok? #f] + #:lift-key [lift-key (and (or capture-lifts? + as-transformer?) + (generate-lift-key))] + #:track-to-be-defined? [track-to-be-defined? #f] + #:skip-log-exit? [skip-log-exit? #f]) + (performance-region + ['expand 'local-expand] + + (define s (datum->syntax #f s-or-s-exp)) + (unless (or (list? context) + (memq context (if as-transformer? + '(expression top-level) + '(expression top-level module module-begin)))) + (raise-argument-error who + (if as-transformer? + "(or/c 'expression 'top-level list?)" + "(or/c 'expression 'top-level 'module 'module-begin list?)") + context)) + (unless (or (not stop-ids) + (and (list? stop-ids) + (andmap identifier? stop-ids))) + (raise-argument-error who "(or/c (listof identifier?) #f)" stop-ids)) + (unless (or (not intdefs) + (internal-definition-context? intdefs) + (and (list? intdefs) (andmap internal-definition-context? intdefs))) + (raise-argument-error who + "(or/c #f internal-definitionc-context? (listof internal-definitionc-context?))" + intdefs)) + + (define ctx (get-current-expand-context who)) + (define phase (if as-transformer? + (add1 (expand-context-phase ctx)) + (expand-context-phase ctx))) + (define local-ctx (make-local-expand-context ctx + #:context context + #:phase phase + #:intdefs intdefs + #:stop-ids stop-ids + #:to-parsed-ok? to-parsed-ok? + #:track-to-be-defined? track-to-be-defined?)) + + (namespace-visit-available-modules! (expand-context-namespace ctx) phase) + + (log-expand local-ctx 'enter-local s) + (define input-s (add-intdef-scopes (flip-introduction-scopes s ctx) intdefs)) + + (when as-transformer? (log-expand local-ctx 'phase-up)) + (log-expand local-ctx 'local-pre input-s) + (when stop-ids (log-expand local-ctx 'start-expand)) + + (define output-s (cond + [(and as-transformer? capture-lifts?) + (expand-transformer input-s local-ctx + #:context context + #:expand-lifts? #f + #:begin-form? #t + #:lift-key lift-key + #:always-wrap? #t + #:keep-stops? #t)] + [as-transformer? + (expand-transformer input-s local-ctx + #:context context + #:expand-lifts? #f + #:begin-form? (eq? 'top-level context) + #:lift-key lift-key + #:keep-stops? #t)] + [capture-lifts? + (expand/capture-lifts input-s local-ctx + #:begin-form? #t + #:lift-key lift-key + #:always-wrap? #t)] + [else + (expand input-s local-ctx)])) + + (log-expand local-ctx 'local-post output-s) + + (define result-s (if (parsed? output-s) + output-s + (flip-introduction-scopes output-s ctx))) + + (unless skip-log-exit? + (log-expand local-ctx 'exit-local result-s)) + + result-s)) diff --git a/racket/src/expander/expand/log.rkt b/racket/src/expander/expand/log.rkt new file mode 100644 index 0000000000..7530ae16fc --- /dev/null +++ b/racket/src/expander/expand/log.rkt @@ -0,0 +1,154 @@ +#lang racket/base +(require "context.rkt") + +(provide log-expand + log-expand* + log-expand... + ...log-expand + log-expand-start) + +(define-syntax log-expand... + (syntax-rules (lambda) + [(_ ctx (lambda (obs) body ...)) + (let ([obs (expand-context-observer ctx)]) + (when obs + body ...))])) + +(define-syntax-rule (...log-expand obs [key arg ...] ...) + (begin + (call-expand-observe obs key arg ...) + ...)) + +(define-syntax log-expand* + (syntax-rules () + [(_ ctx #:when guard [key arg ...] ...) + (log-expand... ctx + (lambda (obs) + (when guard + (...log-expand obs [key arg ...] ...))))] + [(_ ctx #:unless guard [key arg ...] ...) + (log-expand* ctx #:when (not guard) [key arg ...] ...)] + [(_ ctx [key arg ...] ...) + (log-expand* ctx #:when #t [key arg ...] ...)])) + +(define-syntax-rule (log-expand ctx key arg ...) + (log-expand* ctx #:when #t [key arg ...])) + +(define (call-expand-observe obs key . args) + (obs (hash-ref key->number key) (cond + [(null? args) #f] + [else (apply list* args)]))) + +(define (log-expand-start) + (define obs (current-expand-observe)) + (when obs + (call-expand-observe obs 'start-expand))) + +;; For historical reasons, an expander observer currently expects +;; numbers +(define key->number + #hash((visit . 0) + (resolve . 1) + (return . 2) + (next . 3) + (enter-list . 4) + (exit-list . 5) + (enter-prim . 6) + (exit-prim . 7) + (enter-macro . 8) + (exit-macro . 9) + (enter-block . 10) + (splice . 11) + (block->list . 12) + (next-group . 13) + (block->letrec . 14) + (let-renames . 16) + (lambda-renames . 17) + (case-lambda-renames . 18) + (letrec-syntaxes-renames . 19) + (phase-up . 20) + + (macro-pre-x . 21) + (macro-post-x . 22) + + (module-body . 23) + (block-renames . 24) + + (prim-stop . 100) + (prim-module . 101) + (prim-module-begin . 102) + (prim-define-syntaxes . 103) + (prim-define-values . 104) + (prim-if . 105) + (prim-with-continuation-mark . 106) + (prim-begin . 107) + (prim-begin0 . 108) + (prim-#%app . 109) + (prim-lambda . 110) + (prim-case-lambda . 111) + (prim-let-values . 112) + (prim-letrec-values . 113) + (prim-letrec-syntaxes+values . 114) + (prim-#%datum . 115) + (prim-#%top . 116) + (prim-quote . 117) + (prim-quote-syntax . 118) + (prim-require . 119) + (prim-provide . 122) + + (prim-set! . 123) + (prim-#%expression . 138) + (prim-#%variable-reference . 149) + + (prim-#%stratified . 155) + + (prim-begin-for-syntax . 156) + + (prim-submodule . 158) + (prim-submodule* . 159) + + (variable . 125) + + (enter-check . 126) + (exit-check . 127) + + (lift-loop . 128) + (letlift-loop . 136) + (module-lift-loop . 137) + (module-lift-end-loop . 135) + + (local-lift . 129) + (lift-statement . 134) + (lift-require . 150) + (lift-provide . 151) + + (enter-local . 130) + (exit-local . 131) + (local-pre . 132) + (local-post . 133) + + (enter-local-expr . 139) + (exit-local-expr . 140) + + (start-expand . 141) + + (tag . 142) + + (local-bind . 143) + (exit-local-bind . 160) + (enter-bind . 144) + (exit-bind . 145) + + (opaque-expr . 146) + + (rename-list . 147) + + (rename-one . 148) + + (track-origin . 152) + + (local-value . 153) + + (local-value-result . 154) + + (prepare-env . 157))) diff --git a/racket/src/expander/expand/main.rkt b/racket/src/expander/expand/main.rkt new file mode 100644 index 0000000000..54eca8096c --- /dev/null +++ b/racket/src/expander/expand/main.rkt @@ -0,0 +1,744 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/taint-dispatch.rkt" + "../syntax/match.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../namespace/inspector.rkt" + "../syntax/binding.rkt" + "env.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "syntax-id-error.rkt" + "syntax-implicit-error.rkt" + "free-id-set.rkt" + "dup-check.rkt" + "use-site.rkt" + "../compile/main.rkt" + "../eval/top.rkt" + "../eval/direct.rkt" + "../namespace/core.rkt" + "../boot/runtime-primitive.rkt" + "context.rkt" + "lift-context.rkt" + "already-expanded.rkt" + "liberal-def-ctx.rkt" + "rename-trans.rkt" + "allowed-context.rkt" + "lift-key.rkt" + "../syntax/debug.rkt" + "reference-record.rkt" + "log.rkt" + "../common/performance.rkt" + "rebuild.rkt" + "parsed.rkt" + "expanded+parsed.rkt") + +(provide expand + lookup + apply-transformer + + register-variable-referenced-if-local! + + expand/capture-lifts + expand-transformer + expand+eval-for-syntaxes-binding + eval-for-syntaxes-binding + eval-for-bindings + + keep-properties-only + keep-properties-only~ + keep-as-needed + rebuild + attach-disappeared-transformer-bindings + increment-binding-layer + accumulate-def-ctx-scopes + rename-transformer-target-in-context + maybe-install-free=id-in-context!) + +;; ---------------------------------------- + +;; Main expander dispatch +(define (expand s ctx + ;; Aplying a rename transformer substitutes + ;; an id without changing `s` + #:alternate-id [alternate-id #f] + #:skip-log? [skip-log? #f]) + (log-expand* ctx #:unless skip-log? [(if (expand-context-only-immediate? ctx) 'enter-check 'visit) s]) + (cond + [(identifier? s) + (expand-identifier s ctx alternate-id)] + [(and (pair? (syntax-content s)) + (identifier? (car (syntax-content s)))) + (expand-id-application-form s ctx alternate-id)] + [(or (pair? (syntax-content s)) + (null? (syntax-content s))) + ;; An "application" form that doesn't start with an identifier, so + ;; use implicit `#%app` + (expand-implicit '#%app s ctx #f)] + [(already-expanded? (syntax-content s)) + (expand-already-expanded s ctx)] + [else + ;; Anything other than an identifier or parens triggers the + ;; implicit `#%datum` form + (expand-implicit '#%datum s ctx #f)])) + +;; An identifier by itself (i.e., not after an open parenthesis) +(define (expand-identifier s ctx alternate-id) + (define id (or alternate-id s)) + (guard-stop + id ctx s + (define binding (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (log-expand* ctx #:unless (expand-context-only-immediate? ctx) ['resolve id]) + (cond + [(eq? binding 'ambiguous) + (raise-ambiguous-error id ctx)] + [(not binding) + ;; The implicit `#%top` form handles unbound identifiers + (expand-implicit '#%top (substitute-alternate-id s alternate-id) ctx s)] + [else + ;; Variable or form as identifier macro + (define-values (t primitive? insp-of-t) (lookup binding ctx id + #:in (and alternate-id s) + #:out-of-context-as-variable? (expand-context-in-local-expand? ctx))) + (dispatch t insp-of-t s id ctx binding primitive?)]))) + +;; An "application" form that starts with an identifier +(define (expand-id-application-form s ctx alternate-id) + (define id (or alternate-id (car (syntax-e/no-taint s)))) + (guard-stop + id ctx s + (define binding (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (log-expand* ctx #:unless (expand-context-only-immediate? ctx) ['resolve id]) + (cond + [(eq? binding 'ambiguous) + (raise-ambiguous-error id ctx)] + [(not binding) + ;; The `#%app` binding might do something with unbound ids + (expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)] + [else + ;; Find out whether it's bound as a variable, syntax, or core form + (define-values (t primitive? insp-of-t) (lookup binding ctx id + #:in (and alternate-id (car (syntax-e/no-taint s))) + #:out-of-context-as-variable? (expand-context-in-local-expand? ctx))) + (cond + [(variable? t) + ;; Not as syntax or core form, so use implicit `#%app` + (expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)] + [else + ;; Syntax or core form as "application" + (dispatch t insp-of-t s id ctx binding primitive?)])]))) + +;; Handle an implicit: `#%app`, `#%top`, or `#%datum`; this is similar +;; to handling an id-application form, but there are several little +;; differences: the binding must be a core form or transformer, +;; an implicit `#%top` is handled specially, and so on +(define (expand-implicit sym s ctx trigger-id) + (cond + [(expand-context-only-immediate? ctx) + (log-expand* ctx ['exit-check s]) + s] + [else + (define disarmed-s (syntax-disarm s)) + (define id (datum->syntax disarmed-s sym)) + (guard-stop + id ctx s + (log-expand* ctx ['resolve id]) + (define b (resolve+shift id (expand-context-phase ctx) + #:ambiguous-value 'ambiguous + #:immediate? #t)) + (cond + [(eq? b 'ambiguous) + (raise-ambiguous-error id ctx)] + [else + (define-values (t primitive? insp-of-t) (if b (lookup b ctx id) (values #f #f #f))) + (cond + [(transformer? t) + (dispatch-transformer t insp-of-t (make-explicit ctx sym s disarmed-s) id ctx b)] + [(core-form? t) + (cond + [(and (eq? sym '#%top) + (eq? (core-form-name t) '#%top) + (expand-context-in-local-expand? ctx)) + (dispatch-implicit-#%top-core-form t s ctx)] + [else + (dispatch-core-form t (make-explicit ctx sym s disarmed-s) ctx)])] + [else + (define tl-id + (and (eq? sym '#%top) + (root-expand-context-top-level-bind-scope ctx) + (add-scope s (root-expand-context-top-level-bind-scope ctx)))) + (define tl-b (and tl-id (resolve tl-id (expand-context-phase ctx)))) + (cond + [tl-b + ;; Special case: the identifier is not bound and its scopes don't + ;; have a binding for `#%top`, but it's bound temporaily for compilation; + ;; treat the identifier as a variable reference + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (parsed-id tl-id tl-b #f) + tl-id)] + [else + (raise-syntax-implicit-error s sym trigger-id ctx)])])]))])) + +;; An expression that is already fully expanded via `local-expand-expression` +(define (expand-already-expanded s ctx) + (define ae (syntax-e s)) + (define exp-s (already-expanded-s ae)) + (when (or (syntax-any-macro-scopes? s) + (not (eq? (expand-context-binding-layer ctx) + (already-expanded-binding-layer ae))) + (and (parsed? exp-s) + (not (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx)))))) + (raise-syntax-error #f + (string-append "expanded syntax not in its original lexical context;\n" + " extra bindings or scopes in the current context") + (and (not (parsed? exp-s)) exp-s))) + (cond + [(parsed? exp-s) exp-s] + [else + (define result-s (syntax-track-origin exp-s s)) + (log-expand ctx 'opaque-expr result-s) + (if (and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (expand result-s ctx) ; fully expanded to compiled + result-s)])) + +(define (make-explicit ctx sym s disarmed-s) + (define new-s (syntax-rearm (datum->syntax disarmed-s (cons sym disarmed-s) s s) s)) + (log-expand ctx 'tag new-s) + new-s) + +;; ---------------------------------------- + +;; Expand `s` given that the value `t` of the relevant binding, +;; where `t` is either a core form, a macro transformer, some +;; other compile-time value (which is an error), or a token +;; indicating that the binding is a run-time variable; note that +;; `s` is not disarmed +(define (dispatch t insp-of-t s id ctx binding primitive?) + (cond + [(core-form? t) + (dispatch-core-form t s ctx)] + [(transformer? t) + (dispatch-transformer t insp-of-t s id ctx binding)] + [(variable? t) + (dispatch-variable t s id ctx binding primitive?)] + [else + ;; Some other compile-time value: + (raise-syntax-error #f "illegal use of syntax" s)])) + +;; Call a core-form expander (e.g., `lambda`) +(define (dispatch-core-form t s ctx) + (cond + [(expand-context-only-immediate? ctx) + (log-expand* ctx ['exit-check s]) + s] + [(expand-context-observer ctx) + (log-expand ctx 'enter-prim s) + (define result-s ((core-form-expander t) s ctx)) + (log-expand* ctx ['exit-prim (extract-syntax result-s)] ['return (extract-syntax result-s)]) + result-s] + [else + ;; As previous case, but as a tail call: + ((core-form-expander t) s ctx)])) + +;; Special favor to `local-expand` from `expand-implicit`: call +;; `#%top` form without making `#%top` explicit in the form +(define (dispatch-implicit-#%top-core-form t s ctx) + (log-expand ctx 'enter-prim s) + (define result-s ((core-form-expander t) s ctx #t)) + (log-expand* ctx ['exit-prim result-s] ['return result-s]) + result-s) + +;; Call a macro expander, taking into account whether it works +;; in the current context, whether to expand just once, etc. +(define (dispatch-transformer t insp-of-t s id ctx binding) + (cond + [(not-in-this-expand-context? t ctx) + (log-expand ctx 'enter-macro s) + (define adj-s (avoid-current-expand-context (substitute-alternate-id s id) t ctx)) + (log-expand ctx 'exit-macro s) + (expand adj-s ctx)] + [(expand-context-should-not-encounter-macros? ctx) + (raise-syntax-error #f + "encountered a macro binding in form that should be fully expanded" + s)] + [else + (log-expand* ctx #:when (and (expand-context-only-immediate? ctx) + (not (rename-transformer? t))) + ;; The old expander would emit 'resolve for a rename transformer + ;; as long as it's not the first one encountered in immediate mode + ['visit s] ['resolve id]) + ;; Apply transformer and expand again + (define-values (exp-s re-ctx) + (if (rename-transformer? t) + (values s ctx) + (apply-transformer t insp-of-t s id ctx binding))) + (log-expand* ctx #:when (and (expand-context-only-immediate? ctx) + (not (rename-transformer? t))) + ['return exp-s]) + (cond + [(expand-context-just-once? ctx) exp-s] + [else (expand exp-s re-ctx + #:alternate-id (and (rename-transformer? t) + (syntax-track-origin (rename-transformer-target-in-context t ctx) + id + id)) + #:skip-log? (or (expand-context-only-immediate? ctx) + (rename-transformer? t)))])])) + +;; Handle the expansion of a variable to itself +(define (dispatch-variable t s id ctx binding primitive?) + (cond + [(expand-context-only-immediate? ctx) + (log-expand* ctx ['exit-check s]) + id] + [else + (log-expand ctx 'variable s id) + ;; A reference to a variable expands to itself + (register-variable-referenced-if-local! binding) + ;; If the variable is locally bound, replace the use's scopes with the binding's scopes + (define result-s (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx)))) + (cond + [(and (expand-context-to-parsed? ctx) + (free-id-set-empty? (expand-context-stops ctx))) + (define prop-s (keep-properties-only~ result-s)) + (define insp (syntax-inspector result-s)) + (if primitive? + (parsed-primitive-id prop-s binding insp) + (parsed-id prop-s binding insp))] + [else + (log-expand ctx 'return result-s) + result-s])])) + +;; ---------------------------------------- + +;; Given a macro transformer `t`, apply it --- adding appropriate +;; scopes to represent the expansion step; the `insp-of-t` inspector +;; is the inspector of the module that defines `t`, which gives it +;; priviledge for `syntax-arm` and similar +(define (apply-transformer t insp-of-t s id ctx binding) + (performance-region + ['expand '_ 'macro] + + (log-expand ctx 'enter-macro s) + (define disarmed-s (syntax-disarm s)) + (define intro-scope (new-scope 'macro)) + (define intro-s (flip-scope disarmed-s intro-scope)) + ;; In a definition context, we need use-site scopes + (define-values (use-s use-scopes) (maybe-add-use-site-scope intro-s ctx binding)) + ;; Avoid accidental transfer of taint-controlling properties: + (define cleaned-s (syntax-remove-taint-dispatch-properties use-s)) + ;; Prepare to accumulate definition contexts created by the transformer + (define def-ctx-scopes (box null)) + + ;; Call the transformer; the current expansion context may be needed + ;; for `syntax-local-....` functions, and we may accumulate scopes from + ;; definition contexts created by the transformer + (define transformed-s + (apply-transformer-in-context t cleaned-s ctx insp-of-t + intro-scope use-scopes def-ctx-scopes + id)) + + ;; Flip the introduction scope + (define result-s (flip-scope transformed-s intro-scope)) + ;; In a definition context, we need to add the inside-edge scope to + ;; any expansion result + (define post-s (maybe-add-post-expansion-scope result-s ctx)) + ;; Track expansion: + (define tracked-s (syntax-track-origin post-s cleaned-s id)) + (define rearmed-s (taint-dispatch tracked-s (lambda (t-s) (syntax-rearm t-s s)) (expand-context-phase ctx))) + (log-expand ctx 'exit-macro rearmed-s) + (values rearmed-s + (accumulate-def-ctx-scopes ctx def-ctx-scopes)))) + +;; With all the pre-call scope work done and post-call scope work in +;; the continuation, actually call the transformer function in the +;; appropriate context +(define (apply-transformer-in-context t cleaned-s ctx insp-of-t + intro-scope use-scopes def-ctx-scopes + id) + (log-expand ctx 'macro-pre-x cleaned-s) + (define confine-def-ctx-scopes? + (not (or (expand-context-only-immediate? ctx) + (not (free-id-set-empty-or-just-module*? (expand-context-stops ctx)))))) + (define accum-ctx + (if (and confine-def-ctx-scopes? + (expand-context-def-ctx-scopes ctx) + (not (null? (unbox (expand-context-def-ctx-scopes ctx))))) + (accumulate-def-ctx-scopes ctx (expand-context-def-ctx-scopes ctx)) + ctx)) + (define m-ctx (struct*-copy expand-context accum-ctx + [current-introduction-scopes (cons intro-scope + use-scopes)] + [def-ctx-scopes + (if confine-def-ctx-scopes? + ;; Can confine tracking to this call + def-ctx-scopes + ;; Keep old def-ctx-scopes box, so that we don't + ;; lose them at the point where expansion stops + (expand-context-def-ctx-scopes ctx))])) + (define transformed-s + (parameterize ([current-expand-context m-ctx] + [current-namespace (namespace->namespace-at-phase + (expand-context-namespace ctx) + (add1 (expand-context-phase ctx)))] + [current-module-code-inspector (or insp-of-t (current-module-code-inspector))]) + (call-with-continuation-barrier + (lambda () + ;; Call the transformer! + ((transformer->procedure t) cleaned-s))))) + (log-expand ctx 'macro-post-x transformed-s cleaned-s) + (unless (syntax? transformed-s) + (raise-arguments-error (syntax-e id) + "received value from syntax expander was not syntax" + "received" transformed-s)) + transformed-s) + +(define (maybe-add-use-site-scope s ctx binding) + (cond + [(and (root-expand-context-use-site-scopes ctx) + (matching-frame? (root-expand-context-frame-id ctx) + (binding-frame-id binding))) + ;; We're in a recursive definition context where use-site scopes + ;; are needed, so create one, record it, and add to the given + ;; syntax + (define sc (new-scope 'use-site)) + (define b (root-expand-context-use-site-scopes ctx)) + (set-box! b (cons sc (unbox b))) + (values (add-scope s sc) (list sc))] + [else (values s null)])) + +(define (matching-frame? current-frame-id bind-frame-id) + (and current-frame-id + (or (eq? current-frame-id bind-frame-id) + (eq? current-frame-id 'all)))) + +(define (maybe-add-post-expansion-scope s ctx) + (cond + [(root-expand-context-post-expansion-scope ctx) + ;; We're in a definition context where, say, an inside-edge scope + ;; needs to be added to any immediate macro expansion; that way, + ;; if the macro expands to a definition form, the binding will be + ;; in the definition context's scope. The sepcific action depends + ;; on the expansion context. + ((expand-context-post-expansion-scope-action ctx) + s + (root-expand-context-post-expansion-scope ctx))] + [else s])) + +(define (accumulate-def-ctx-scopes ctx def-ctx-scopes) + ;; Move any accumulated definition-context scopes to the `scopes` + ;; list for further expansion: + (if (null? (unbox def-ctx-scopes)) + ctx + (struct*-copy expand-context ctx + [scopes (append (unbox def-ctx-scopes) + (expand-context-scopes ctx))]))) + +;; ---------------------------------------- + +;; Helper to lookup a binding in an expansion context +(define (lookup b ctx id + #:in [in-s #f] + #:out-of-context-as-variable? [out-of-context-as-variable? #f]) + (binding-lookup b + (expand-context-env ctx) + (expand-context-lift-envs ctx) + (expand-context-namespace ctx) + (expand-context-phase ctx) + id + #:in in-s + #:out-of-context-as-variable? out-of-context-as-variable?)) + +(define-syntax-rule (guard-stop id ctx s otherwise ...) + (cond + [(free-id-set-member? (expand-context-stops ctx) + (expand-context-phase ctx) + id) + (log-expand* ctx #:unless (expand-context-only-immediate? ctx) + ['resolve id] ['enter-prim s] ['prim-stop] ['exit-prim s] ['return s]) + s] + [else + otherwise ...])) + +(define (substitute-alternate-id s alternate-id) + (cond + [(not alternate-id) s] + [(identifier? s) (syntax-rearm (syntax-track-origin alternate-id s) s)] + [else + (define disarmed-s (syntax-disarm s)) + (syntax-rearm (syntax-track-origin (datum->syntax + disarmed-s + (cons alternate-id + (cdr (syntax-e disarmed-s))) + s) + s) + s)])) + +(define (register-variable-referenced-if-local! binding) + ;; If the binding's frame has a reference record, then register + ;; the use for the purposes of `letrec` splitting + (when (and (local-binding? binding) + (reference-record? (binding-frame-id binding))) + (reference-record-used! (binding-frame-id binding) (local-binding-key binding)))) + +;; ---------------------------------------- + +;; Expand `s` as a compile-time expression relative to the current +;; expansion context +(define (expand/capture-lifts s ctx + #:expand-lifts? [expand-lifts? #f] + #:begin-form? [begin-form? #f] + #:lift-key [lift-key (generate-lift-key)] + #:always-wrap? [always-wrap? #f]) + (define context (expand-context-context ctx)) + (define phase (expand-context-phase ctx)) + (define local? (not begin-form?)) ;; see "[*]" below + ;; Expand `s`, but loop to handle lifted expressions + (let loop ([s s] [always-wrap? always-wrap?] [ctx ctx]) + (define lift-env (and local? (box empty-env))) + (define lift-ctx (make-lift-context + (if local? + (make-local-lift lift-env (root-expand-context-counter ctx)) + (make-top-level-lift ctx)) + #:module*-ok? (and (not local?) (eq? context 'module)))) + (define capture-ctx (struct*-copy expand-context ctx + [lift-key #:parent root-expand-context lift-key] + [lifts lift-ctx] + [lift-envs (if local? + (cons lift-env + (expand-context-lift-envs ctx)) + (expand-context-lift-envs ctx))] + [module-lifts (if (or local? + (not (memq context '(top-level module)))) + (expand-context-module-lifts ctx) + lift-ctx)])) + (define rebuild-s (keep-properties-only s)) + (define exp-s (expand s capture-ctx)) + (define lifts (get-and-clear-lifts! (expand-context-lifts capture-ctx))) + (define with-lifts-s + (cond + [(or (pair? lifts) always-wrap?) + (cond + [(expand-context-to-parsed? ctx) + (unless expand-lifts? (error "internal error: to-parsed mode without expanding lifts")) + (wrap-lifts-as-parsed-let lifts exp-s rebuild-s ctx (lambda (rhs rhs-ctx) (loop rhs #f rhs-ctx)))] + [else + (if begin-form? + (wrap-lifts-as-begin lifts exp-s phase) + (wrap-lifts-as-let lifts exp-s phase))])] + [else exp-s])) + (cond + [(or (not expand-lifts?) (null? lifts) (expand-context-to-parsed? ctx)) + ;; Expansion is done + with-lifts-s] + [else + ;; Expand again... + (log-expand ctx 'letlift-loop with-lifts-s) + (loop with-lifts-s #f ctx)]))) + +;; [*] Although `(memq context '(top-level module))` makes more sense +;; than `(not begin-form?)`, the latter was used historically; the +;; implementation of `typed/require` currently depends on that +;; choice, because it expands in 'expression mode to obtain forms +;; that are splcied into a module context --- leading to an +;; out-of-context definition error if the historical choice is not +;; preserved. + +;; Expand `s` as a compile-time expression relative to the current +;; expansion context +(define (expand-transformer s ctx + #:context [context 'expression] + #:begin-form? [begin-form? #f] + #:expand-lifts? [expand-lifts? #t] + #:lift-key [lift-key (generate-lift-key)] + #:always-wrap? [always-wrap? #f] + #:keep-stops? [keep-stops? #f]) + (performance-region + ['expand 'transformer] + + (define trans-ctx (context->transformer-context ctx context + #:keep-stops? keep-stops?)) + (expand/capture-lifts s trans-ctx + #:expand-lifts? expand-lifts? + #:begin-form? begin-form? + #:lift-key lift-key + #:always-wrap? always-wrap?))) + +(define (context->transformer-context ctx [context 'expression] + #:keep-stops? [keep-stops? #f]) + (define phase (add1 (expand-context-phase ctx))) + (define ns (namespace->namespace-at-phase (expand-context-namespace ctx) + phase)) + (namespace-visit-available-modules! ns phase) ; redundant? + (struct*-copy expand-context ctx + [context context] + [scopes null] + [phase phase] + [namespace ns] + [env empty-env] + [only-immediate? (and keep-stops? (expand-context-only-immediate? ctx))] + [stops (if keep-stops? + (expand-context-stops ctx) + empty-free-id-set)] + [def-ctx-scopes #f] + [post-expansion-scope #:parent root-expand-context #f])) + +;; Expand and evaluate `s` as a compile-time expression, ensuring that +;; the number of returned values matches the number of target +;; identifiers; return the expanded form as well as its values +(define (expand+eval-for-syntaxes-binding rhs ids ctx + #:log-next? [log-next? #t]) + (define exp-rhs (expand-transformer rhs (as-named-context ctx ids))) + (define phase (add1 (expand-context-phase ctx))) + (define parsed-rhs (if (expand-context-to-parsed? ctx) + exp-rhs + (expand exp-rhs (context->transformer-context + (as-to-parsed-context ctx))))) + (when log-next? (log-expand ctx 'next)) + (values exp-rhs + parsed-rhs + (eval-for-bindings ids + parsed-rhs + phase + (namespace->namespace-at-phase + (expand-context-namespace ctx) + phase) + ctx))) + +;; Expand and evaluate `s` as a compile-time expression, returning +;; only the compile-time values +(define (eval-for-syntaxes-binding rhs ids ctx) + (define-values (exp-rhs parsed-rhs vals) + (expand+eval-for-syntaxes-binding rhs ids ctx)) + vals) + +;; Expand and evaluate `s` as an expression in the given phase; +;; ensuring that the number of returned values matches the number of +;; target identifiers; return the values +(define (eval-for-bindings ids p phase ns ctx) + (define compiled (if (can-direct-eval? p ns) + #f + (compile-single p (make-compile-context + #:namespace ns + #:phase phase)))) + (define vals + (call-with-values (lambda () + (parameterize ([current-expand-context ctx] + [current-namespace ns] + [eval-jit-enabled #f]) + (if compiled + (eval-single-top compiled ns) + (direct-eval p ns)))) + list)) + (unless (= (length vals) (length ids)) + (error "wrong number of results (" (length vals) "vs." (length ids) ")" + "from" p)) + vals) + +;; ---------------------------------------- + +(define (keep-properties-only s) + (datum->syntax #f 'props s s)) + +;; For cases where we don't actually keep properties, because +;; the compiler doesn't currently use them: +(define (keep-properties-only~ s) + #f) + +;; Drop the `syntax-e` part of `s`, and also drop its scopes when +;; producing a parsed result, producing a result suitable for use with +;; `rebuild`, including in a `parsed` record, or to provide a form +;; name for error reporting. In fact, when producing a parsed value +;; and `keep-for-parsed?` and `keep-for-error?` are both false, then +;; keep nothing (because the compiler isn't going to use it). +;; Dropping references in this way helps the +;; GC not retain too much of an original syntax object in the process +;; of expanding it, which can matter for deeply nested expansions. +(define (keep-as-needed ctx s + #:for-track? [for-track? #f] + #:keep-for-parsed? [keep-for-parsed? #f] + #:keep-for-error? [keep-for-error? #f]) + (define d (syntax-e s)) + (define keep-e (cond + [(symbol? d) d] + [(and (pair? d) (identifier? (car d))) (syntax-e (car d))] + [else #f])) + (cond + [(expand-context-to-parsed? ctx) + (and (or keep-for-parsed? keep-for-error?) (datum->syntax #f keep-e s s))] + [else + (syntax-rearm (datum->syntax (syntax-disarm s) keep-e s s) + s)])) + +(define (attach-disappeared-transformer-bindings s trans-idss) + (cond + [(null? trans-idss) s] + [else + (syntax-property s + 'disappeared-binding + (append (apply append trans-idss) + (or (syntax-property s 'disappeared-binding) + null)))])) + +;; Generate a fresh binding-layer identity if `ids` contains any +;; identifiers +(define (increment-binding-layer ids ctx layer-val) + (if (let loop ([ids ids]) + (or (identifier? ids) + (and (pair? ids) + (or (loop (car ids)) (loop (cdr ids)))))) + layer-val + (expand-context-binding-layer ctx))) + +;; Wrap lifted forms in a `let` for a mode where we're generating a +;; parsed result. The body has already been parsed, and the left-hand +;; sides already have bindings. We need to parse the right-hand sides +;; as a series of nested `lets`. +(define (wrap-lifts-as-parsed-let lifts exp-s rebuild-s ctx parse-rhs) + (define idss+keyss+rhss (get-lifts-as-lists lifts)) + (let lets-loop ([idss+keyss+rhss idss+keyss+rhss] [rhs-ctx ctx]) + (cond + [(null? idss+keyss+rhss) exp-s] + [else + (define ids (caar idss+keyss+rhss)) + (define keys (cadar idss+keyss+rhss)) + (define rhs (caddar idss+keyss+rhss)) + (define exp-rhs (parse-rhs rhs rhs-ctx)) + (parsed-let-values + rebuild-s + (list ids) + (list (list keys exp-rhs)) + (list + (lets-loop (cdr idss+keyss+rhss) + (struct*-copy expand-context rhs-ctx + [env (for/fold ([env (expand-context-env rhs-ctx)]) ([id (in-list ids)] + [key (in-list keys)]) + (env-extend env key (local-variable id)))]))))]))) + +;; A rename transformer can have a `prop:rename-transformer` property +;; as a function, and that fnuction might want to use +;; `syntax-local-value`, etc. +(define (rename-transformer-target-in-context t ctx) + (parameterize ([current-expand-context ctx]) + (rename-transformer-target t))) + +;; In case the rename-transformer has a callback, ensure that the +;; current expansion context is available while installing a +;; `free-identifier=?` equivalence +(define (maybe-install-free=id-in-context! val id phase ctx) + (when (rename-transformer? val) + (parameterize ([current-expand-context ctx]) + (maybe-install-free=id! val id phase)))) diff --git a/racket/src/expander/expand/missing-module.rkt b/racket/src/expander/expand/missing-module.rkt new file mode 100644 index 0000000000..68dc7bc0a3 --- /dev/null +++ b/racket/src/expander/expand/missing-module.rkt @@ -0,0 +1,82 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/error.rkt" + "../common/module-path.rkt") + +(provide current-module-path-for-load + maybe-raise-missing-module + + prop:missing-module + exn:missing-module? + exn:missing-module-accessor + + (struct-out exn:fail:filesystem:missing-module) + make-exn:fail:filesystem:missing-module + (struct-out exn:fail:syntax:missing-module) + make-exn:fail:syntax:missing-module) + +(define-values (prop:missing-module exn:missing-module? exn:missing-module-accessor) + (make-struct-type-property 'missing-module + (lambda (v info) + (unless (and (procedure? v) + (procedure-arity-includes? v 1)) + (raise-argument-error 'guard-for-prop:missing-module + "(procedure-arity-includes/c 1)" + v)) + v))) + +(struct exn:fail:filesystem:missing-module exn:fail:filesystem (path) + #:extra-constructor-name make-exn:fail:filesystem:missing-module + #:transparent + #:property prop:missing-module (lambda (e) (exn:fail:filesystem:missing-module-path e))) +(struct exn:fail:syntax:missing-module exn:fail:syntax (path) + #:extra-constructor-name make-exn:fail:syntax:missing-module + #:transparent + #:property prop:missing-module (lambda (e) (exn:fail:syntax:missing-module-path e))) + +(define current-module-path-for-load + (make-parameter #f + (lambda (v) + (unless (or (not v) + (module-path? v) + (and (syntax? v) + (module-path? (syntax->datum v)))) + (raise-argument-error + 'current-module-path-for-load + (string-append "(or/c module-path?" + " (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))" + " #f)") + v)) + v))) + +(define (maybe-raise-missing-module name filename pre rel post errstr) + (define path (current-module-path-for-load)) + (when path + (when (syntax? path) + (raise + (exn:fail:syntax:missing-module + (format (string-append "~a: cannot open module file\n" + " module path: ~a\n" + " path: ~a~a~a~a\n" + " system error: ~a") + (if (syntax-srcloc path) + (srcloc->string (syntax-srcloc path)) + name) + (syntax->datum path) + filename pre rel post + errstr) + (current-continuation-marks) + (list path) + (syntax->datum path)))) + (raise + (exn:fail:filesystem:missing-module + (format (string-append "~a: cannot open module file\n" + " module path: ~a\n" + " path: ~a~a~a~a\n" + " system error: ~a") + name + path + filename pre rel post + errstr) + (current-continuation-marks) + path)))) diff --git a/racket/src/expander/expand/module-path.rkt b/racket/src/expander/expand/module-path.rkt new file mode 100644 index 0000000000..8cb6a39904 --- /dev/null +++ b/racket/src/expander/expand/module-path.rkt @@ -0,0 +1,33 @@ +#lang racket/base +(require "../common/module-path.rkt" + "../namespace/namespace.rkt" + "context.rkt") + +(provide module-path->mpi + module-path->mpi/context) + +(define (module-path->mpi mod-path self + #:declared-submodule-names [declared-submodule-names #hasheq()]) + (cond + [(and (list? mod-path) + (= 2 (length mod-path)) + (eq? 'quote (car mod-path)) + (symbol? (cadr mod-path)) + (hash-ref declared-submodule-names (cadr mod-path) #f)) + (module-path-index-join `(submod "." ,(cadr mod-path)) self)] + [(and (list? mod-path) + (eq? 'submod (car mod-path)) + (let ([mod-path (cadr mod-path)]) + (and (list? mod-path) + (= 2 (length mod-path)) + (eq? 'quote (car mod-path)) + (symbol? (cadr mod-path)) + (hash-ref declared-submodule-names (cadr mod-path) #f)))) + (module-path-index-join `(submod "." ,(cadr (cadr mod-path)) ,@(cddr mod-path)) self)] + [else + (module-path-index-join mod-path self)])) + +(define (module-path->mpi/context mod-path ctx) + (module-path->mpi mod-path + (namespace-mpi (expand-context-namespace ctx)) + #:declared-submodule-names (expand-context-declared-submodule-names ctx))) diff --git a/racket/src/expander/expand/module.rkt b/racket/src/expander/expand/module.rkt new file mode 100644 index 0000000000..f94604d217 --- /dev/null +++ b/racket/src/expander/expand/module.rkt @@ -0,0 +1,1459 @@ +#lang racket/base +(require racket/promise + "../common/struct-star.rkt" + "../common/performance.rkt" + "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../syntax/match.rkt" + "../syntax/track.rkt" + "../common/phase.rkt" + "../syntax/track.rkt" + "../syntax/error.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../syntax/binding.rkt" + "dup-check.rkt" + "free-id-set.rkt" + "stop-ids.rkt" + "require+provide.rkt" + "../common/module-path.rkt" + "lift-context.rkt" + "../namespace/core.rkt" + "context.rkt" + "use-site.rkt" + "main.rkt" + "require.rkt" + "provide.rkt" + "def-id.rkt" + "prepare.rkt" + "log.rkt" + "syntax-id-error.rkt" + "../compile/main.rkt" + "../eval/top.rkt" + "../eval/module.rkt" + "cross-phase.rkt" + "parsed.rkt" + "expanded+parsed.rkt" + "append.rkt" + "save-and-restore.rkt") + +(add-core-form! + 'module + (lambda (s ctx) + (unless (eq? (expand-context-context ctx) 'top-level) + (log-expand ctx 'prim-module) + (raise-syntax-error #f "allowed only at the top level" s)) + (performance-region + ['expand 'module] + (expand-module s ctx #f)))) + +(add-core-form! + 'module* + (lambda (s ctx) + (log-expand ctx 'prim-module) + (raise-syntax-error #f "illegal use (not in a module top-level)" s))) + +(add-core-form! + '#%module-begin + (lambda (s ctx) + (log-expand ctx 'prim-module-begin) + (unless (eq? (expand-context-context ctx) 'module-begin) + (raise-syntax-error #f "not in a module-definition context" s)) + (unless (expand-context-module-begin-k ctx) + (raise-syntax-error #f "not currently transforming a module" s)) + ;; This `#%module-begin` must be in a `module`; the + ;; `module-begin-k` function continues that module's + ;; expansion + ((expand-context-module-begin-k ctx) + s + (struct*-copy expand-context ctx + [module-begin-k #f])))) + +(add-core-form! + '#%declare + (lambda (s ctx) + (log-expand ctx 'prim-declare) + ;; The `#%module-begin` expander handles `#%declare` + (raise-syntax-error #f "not allowed outside of a module body" s))) + +;; ---------------------------------------- + +(define (expand-module s init-ctx enclosing-self + #:always-produce-compiled? [always-produce-compiled? #f] + #:keep-enclosing-scope-at-phase [keep-enclosing-scope-at-phase #f] + #:enclosing-all-scopes-stx [enclosing-all-scopes-stx #f] + #:enclosing-is-cross-phase-persistent? [enclosing-is-cross-phase-persistent? #f] + #:enclosing-requires+provides [enclosing-r+p #f] + #:mpis-for-enclosing-reset [mpis-for-enclosing-reset #f] + ;; For cross-linklet inlining among submodules compiled together: + #:modules-being-compiled [modules-being-compiled (make-hasheq)]) + (log-expand init-ctx 'prim-module) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(module id:module-name initial-require body ...)) + + (define rebuild-s (keep-as-needed init-ctx s #:keep-for-parsed? #t #:keep-for-error? #t)) + + (define initial-require (syntax->datum (m 'initial-require))) + (unless (or keep-enclosing-scope-at-phase + (module-path? initial-require)) + (raise-syntax-error #f "not a module path" s (m 'initial-require))) + + ;; All module bodies start at phase 0 + (define phase 0) + + (define module-name-sym (syntax-e (m 'id:module-name))) + + (define outside-scope (new-scope 'module)) + (define inside-scope (new-multi-scope module-name-sym)) + + (define self (make-self-module-path-index (if enclosing-self + module-name-sym + (string->uninterned-symbol + (symbol->string module-name-sym))) + enclosing-self)) + + (define enclosing-mod (and enclosing-self + (module-path-index-join '(submod "..") self))) + (when (and enclosing-mod mpis-for-enclosing-reset) + (set-box! mpis-for-enclosing-reset + (cons enclosing-mod (unbox mpis-for-enclosing-reset)))) + + (define apply-module-scopes + (make-apply-module-scopes outside-scope inside-scope + init-ctx keep-enclosing-scope-at-phase + self enclosing-self enclosing-mod)) + + ;; Initial require name provides the module's base scopes + (define initial-require-s (apply-module-scopes (m 'initial-require))) + (define all-scopes-s (if enclosing-all-scopes-stx + (apply-module-scopes + (syntax-shift-phase-level enclosing-all-scopes-stx + keep-enclosing-scope-at-phase)) + initial-require-s)) + + (define root-ctx (make-root-expand-context + #:initial-scopes (if keep-enclosing-scope-at-phase + (root-expand-context-module-scopes init-ctx) + null) + #:outside-scope outside-scope + #:post-expansion-scope inside-scope + #:all-scopes-stx all-scopes-s)) + + ;; Extract combined scopes + (define new-module-scopes (root-expand-context-module-scopes root-ctx)) + + ;; A frame-id is used to determine when use-site scopes are needed + (define frame-id (root-expand-context-frame-id root-ctx)) + + ;; Make a namespace for module expansion + (define (make-m-ns ns #:for-submodule? [for-submodule? (and enclosing-self #t)]) + (make-module-namespace ns + #:mpi self + #:root-expand-context root-ctx + #:for-submodule? for-submodule?)) + (define m-ns (make-m-ns (expand-context-namespace init-ctx))) + + ;; Initial context for all body expansions: + (define ctx (struct*-copy expand-context (copy-root-expand-context init-ctx root-ctx) + [allow-unbound? #f] + [namespace m-ns] + [post-expansion-scope-action add-scope] + [phase phase] + [just-once? #f])) + + ;; Add the module's scope to the body forms; use `disarmed-s` and + ;; re-match to extract the body forms, because that improves sharing + (define bodys (let ([scoped-s (apply-module-scopes disarmed-s)]) + (define-match m scoped-s '(_ _ _ body ...)) + (m 'body))) + + ;; To keep track of all requires and provides + (define requires+provides (make-requires+provides self)) + + ;; Table of symbols picked for each binding in this module: + (define defined-syms (root-expand-context-defined-syms root-ctx)) ; phase -> sym -> id + + ;; So that compilations of submodules can be preserved for + ;; inclusion in an overall compiled module: + (define compiled-submodules (make-hasheq)) + + ;; If we compile the module for use by `module*` submodules, keep that + ;; compiled form to possibly avoid compiling again. + (define compiled-module-box (box #f)) + + ;; Accumulate module path indexes used by submodules to refer to this module + (define mpis-to-reset (box null)) + + ;; Initial require + (define (initial-require! #:bind? bind?) + (cond + [(not keep-enclosing-scope-at-phase) + ;; Install the initial require + (perform-initial-require! initial-require self + all-scopes-s + m-ns + requires+provides + #:bind? bind? + #:who 'module)] + [else + ;; For `(module* name #f ....)`, just register the enclosing module + ;; as an import and visit it + (add-required-module! requires+provides + enclosing-mod + keep-enclosing-scope-at-phase + enclosing-is-cross-phase-persistent?) + (add-enclosing-module-defined-and-required! requires+provides + #:enclosing-requires+provides enclosing-r+p + enclosing-mod + keep-enclosing-scope-at-phase) + (namespace-module-visit! m-ns enclosing-mod + keep-enclosing-scope-at-phase)])) + (log-expand init-ctx 'prepare-env) + (initial-require! #:bind? #t) + + ;; To detect whether the body is expanded multiple times: + (define again? #f) + + ;; The primitive `#%module-body` form calls this function to expand the + ;; current module's body + (define (module-begin-k mb-s mb-init-ctx) + ;; In case the module body is expanded multiple times, we clear + ;; the requires, provides and definitions information each time. + ;; Don't discard accumulated requires, though, since those may be + ;; needed by pieces from a previous expansion. Also, be careful + ;; not to change the current bindings when re-establishing the + ;; requires. + (when again? + (requires+provides-reset! requires+provides) + (initial-require! #:bind? #f) + (hash-clear! compiled-submodules) + (set-box! compiled-module-box #f)) + (set! again? #t) + + ;; In case a nested `#%module-begin` expansion is forced, save + ;; and restore the module-expansion state: + (define ctx (struct*-copy expand-context mb-init-ctx + [module-begin-k + (lambda (s ctx) + (define new-requires+provides + ;; Copy old `require` dependencies, which allows a + ;; synthesized nested `#%module-begin` to use pieces + ;; that depend on bindings introduced outside the + ;; synthesized part --- a questionable practice, + ;; but support for backward compatibility, at least. + (make-requires+provides self + #:copy-requires requires+provides)) + (with-save-and-restore ([requires+provides new-requires+provides] + [compiled-submodules (make-hasheq)] + [compiled-module-box (box #f)]) + (module-begin-k s ctx)))])) + + ;; In case `#%module-begin` expansion is forced on syntax that + ;; that wasn't already introduced into the mdoule's inside scope, + ;; add it to all the given body forms + (define added-s (add-scope mb-s inside-scope)) + (log-expand ctx 'rename-one added-s) + + (define disarmed-mb-s (syntax-disarm added-s)) + (define-match mb-m disarmed-mb-s '(#%module-begin body ...)) + (define bodys (mb-m 'body)) + + (define rebuild-mb-s (keep-as-needed ctx mb-s)) + + ;; For variable repeferences before corresponding binding (phase >= 1) + (define need-eventually-defined (make-hasheqv)) ; phase -> list of id + + ;; For `syntax-local-lift-module-end-declaration`, which is accumulated + ;; across phases: + (define module-ends (make-shared-module-ends)) + + ;; Accumulate `#%declare` content + (define declared-keywords (make-hasheq)) + + ;; Accumulated declared submodule names for `syntax-local-submodules` + (define declared-submodule-names (make-hasheq)) + + ;; Module expansion always parses the module body along the way, + ;; even if `to-parsed?` in `ctx` is not true. The body is parsed + ;; so that the module can be declared for reference by + ;; submodules. So, if expansion is supposed to a syntax object + ;; instead of `module-parsed`, then we'll need to accumulate both + ;; parsed and expanded results; see "expanded+parsed.rkt". + + ;; The expansion of the module body happens in 4 passes: + ;; Pass 1: Partial expansion to determine imports and definitions + ;; Pass 2: Complete expansion of remaining expressions + ;; Pass 3: Parsing of provide forms + ;; Pass 4: Parsing of `module*` submodules + + ;; Passes 1 and 2 are nested via `begin-for-syntax`: + (define expression-expanded-bodys + (let pass-1-and-2-loop ([bodys bodys] [phase phase]) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 1: partially expand to discover all bindings and install all + ;; defined macro transformers + + ;; Need to accumulate definition contexts created during + ;; partial expansion: + (define def-ctx-scopes (box null)) + (define to-parsed? (expand-context-to-parsed? ctx)) + + (define partial-body-ctx (struct*-copy expand-context ctx + [context 'module] + [phase phase] + [namespace (namespace->namespace-at-phase m-ns phase)] + [stops (free-id-set phase (module-expand-stop-ids phase))] + [def-ctx-scopes def-ctx-scopes] + [need-eventually-defined need-eventually-defined] ; used only at phase 1 and up + [declared-submodule-names declared-submodule-names] + [lifts (make-lift-context + (make-wrap-as-definition self frame-id + inside-scope all-scopes-s + defined-syms requires+provides))] + [module-lifts (make-module-lift-context phase #t)] + [require-lifts (make-require-lift-context + phase + (make-parse-lifted-require m-ns self requires+provides + #:declared-submodule-names declared-submodule-names))] + [to-module-lifts (make-to-module-lift-context + phase + #:shared-module-ends module-ends + #:end-as-expressions? #f)])) + + ;; Result is mostly a list of S-expressions, but can also + ;; contain `compile-form` or `expanded+parsed` structures: + (define partially-expanded-bodys + (partially-expand-bodys bodys + #:phase phase + #:ctx partial-body-ctx + #:namespace m-ns + #:self self + #:frame-id frame-id + #:requires-and-provides requires+provides + #:need-eventually-defined need-eventually-defined + #:all-scopes-stx all-scopes-s + #:defined-syms defined-syms + #:declared-keywords declared-keywords + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset + #:loop pass-1-and-2-loop)) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 2: finish expanding expressions + + (log-expand partial-body-ctx 'next-group) + + (define body-ctx (struct*-copy expand-context (accumulate-def-ctx-scopes partial-body-ctx def-ctx-scopes) + [stops empty-free-id-set] + [def-ctx-scopes #f] + [post-expansion-scope #:parent root-expand-context #f] + [to-module-lifts (make-to-module-lift-context phase + #:shared-module-ends module-ends + #:end-as-expressions? #t)])) + + (finish-expanding-body-expressons partially-expanded-bodys + #:phase phase + #:ctx body-ctx + #:self self + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset))) + + ;; Check that any tentatively allowed reference at phase >= 1 is ok + (check-defined-by-now need-eventually-defined self ctx) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 3: resolve provides at all phases + + (log-expand ctx 'next-group) + + (define fully-expanded-bodys-except-post-submodules + (resolve-provides expression-expanded-bodys + #:requires-and-provides requires+provides + #:declared-submodule-names declared-submodule-names + #:namespace m-ns + #:phase phase + #:self self + #:ctx ctx)) + + ;; Validate any cross-phase persistence request + (define is-cross-phase-persistent? (hash-ref declared-keywords '#:cross-phase-persistent #f)) + (when is-cross-phase-persistent? + (unless (requires+provides-can-cross-phase-persistent? requires+provides) + (raise-syntax-error #f "cannot be cross-phase persistent due to required modules" + rebuild-s + (hash-ref declared-keywords '#:cross-phase-persistent))) + (check-cross-phase-persistent-form fully-expanded-bodys-except-post-submodules)) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Pass 4: expand `module*` submodules + + (log-expand ctx 'next) + + ;; Create a new namespace to avoid retaining the instance that + ;; was needed to expand this module body: + (define submod-m-ns (make-m-ns m-ns #:for-submodule? #t)) + + (define submod-ctx (struct*-copy expand-context ctx + [frame-id #:parent root-expand-context #f] + [post-expansion-scope #:parent root-expand-context #f] + [namespace submod-m-ns])) + + (define declare-enclosing-module + ;; Ensure this module on demand for `module*` submodules that might use it + (delay (declare-module-for-expansion fully-expanded-bodys-except-post-submodules + #:module-name-id (m 'id:module-name) + #:rebuild-s rebuild-s + #:requires-and-provides requires+provides + #:namespace submod-m-ns + #:self self + #:enclosing enclosing-self + #:root-ctx root-ctx + #:ctx submod-ctx + #:modules-being-compiled modules-being-compiled + #:fill compiled-module-box))) + + (define fully-expanded-bodys + (cond + [(stop-at-module*? submod-ctx) + fully-expanded-bodys-except-post-submodules] + [else + (expand-post-submodules fully-expanded-bodys-except-post-submodules + #:declare-enclosing declare-enclosing-module + #:phase phase + #:self self + #:requires-and-provides requires+provides + #:enclosing-is-cross-phase-persistent? is-cross-phase-persistent? + #:all-scopes-s all-scopes-s + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:ctx submod-ctx)])) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Finish + + ;; Assemble the `#%module-begin` result: + (cond + [(expand-context-to-parsed? submod-ctx) + (parsed-#%module-begin rebuild-mb-s (parsed-only fully-expanded-bodys))] + [else + (define mb-result-s + (rebuild + rebuild-mb-s + `(,(mb-m '#%module-begin) ,@(syntax-only fully-expanded-bodys)))) + (cond + [(not (expand-context-in-local-expand? submod-ctx)) + (expanded+parsed mb-result-s + (parsed-#%module-begin rebuild-mb-s (parsed-only fully-expanded-bodys)))] + [else mb-result-s])])) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Actually expand the `#%module-body` form + + ;; The preceding function performs the expansion; here's where we + ;; trigger it + + (define mb-ctx + (struct*-copy expand-context ctx + [context 'module-begin] + [module-begin-k module-begin-k] + [in-local-expand? #f])) + + (define mb-scopes-s + (if keep-enclosing-scope-at-phase + ;; for `(module* name #f)`, use the `(module* ...)` form + disarmed-s + ;; otherwise, use the initial require + all-scopes-s)) + + ;; Need to accumulate definition contexts created during + ;; expansion to `#%module-begin`: + (define mb-def-ctx-scopes (box null)) + + ;; Add `#%module-begin` around the body if it's not already present; + ;; also logs 'rename-one + (define mb + (ensure-module-begin bodys + #:module-name-sym module-name-sym + #:scopes-s mb-scopes-s + #:m-ns m-ns + #:ctx mb-ctx + #:def-ctx-scopes mb-def-ctx-scopes + #:phase phase + #:s s)) + + ;; Expand the body + (define expanded-mb (performance-region + ['expand 'module-begin] + (expand mb (accumulate-def-ctx-scopes mb-ctx mb-def-ctx-scopes)))) + + ;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ;; Assemble the `module` result + + (define-values (requires provides) (extract-requires-and-provides requires+provides self self)) + + (define result-form + (and (or (expand-context-to-parsed? init-ctx) + always-produce-compiled?) + (parsed-module rebuild-s + #f + (m 'id:module-name) + self + requires + provides + (requires+provides-all-bindings-simple? requires+provides) + (root-expand-context-encode-for-module root-ctx self self) + (parsed-#%module-begin-body + (if (expanded+parsed? expanded-mb) + (expanded+parsed-parsed expanded-mb) + expanded-mb)) + (unbox compiled-module-box) + compiled-submodules))) + + (define result-s + (cond + [(not (expand-context-to-parsed? init-ctx)) + ;; Shift the "self" reference that we have been using for expansion + ;; to a generic and constant (for a particualr submodule path) + ;; "self", so that we can reocognize it for compilation or to shift + ;; back on any future re-expansion: + (define generic-self (make-generic-self-module-path-index self)) + + ;; Make `self` like `generic-self`; this hacky update plays the + ;; role of applying a shift to identifiers that are in syntax + ;; properties, such as the 'origin property + (imitate-generic-module-path-index! self) + (for ([mpi (in-list (unbox mpis-to-reset))]) + (imitate-generic-module-path-index! mpi)) + + (let* ([result-s + (rebuild + rebuild-s + `(,(m 'module) ,(m 'id:module-name) ,initial-require-s ,(expanded+parsed-s expanded-mb)))] + [result-s + (syntax-module-path-index-shift result-s self generic-self)] + [result-s (attach-root-expand-context-properties result-s root-ctx self generic-self)] + [result-s (if (requires+provides-all-bindings-simple? requires+provides) + (syntax-property result-s 'module-body-context-simple? #t) + result-s)]) + (log-expand init-ctx 'rename-one result-s) + result-s)])) + + (cond + [(expand-context-to-parsed? init-ctx) result-form] + [always-produce-compiled? + (expanded+parsed result-s result-form)] + [else result-s])) + +;; ---------------------------------------- + +;; Add `#%module-begin` to `bodys`, if needed, and otherwise +;; expand to a core `#%module-begin` form +(define (ensure-module-begin bodys + #:module-name-sym module-name-sym + #:scopes-s scopes-s + #:m-ns m-ns + #:ctx ctx + #:def-ctx-scopes def-ctx-scopes + #:phase phase + #:s s) + (define (make-mb-ctx) + (struct*-copy expand-context ctx + [context 'module-begin] + [only-immediate? #t] + [def-ctx-scopes def-ctx-scopes])) + (define mb + (cond + [(= 1 (length bodys)) + ;; Maybe it's already a `#%module-begin` form, or maybe it + ;; will expand to one + (log-expand ctx 'rename-one (car bodys)) + (cond + [(eq? '#%module-begin (core-form-sym (syntax-disarm (car bodys)) phase)) + ;; Done + (car bodys)] + [else + ;; A single body form might be a macro that expands to + ;; the primitive `#%module-begin` form: + (define partly-expanded-body + (performance-region + ['expand 'module-begin] + (expand (add-enclosing-name-property (car bodys) module-name-sym) + (make-mb-ctx)))) + (cond + [(eq? '#%module-begin (core-form-sym (syntax-disarm partly-expanded-body) phase)) + ;; Yes, it expanded to `#%module-begin` + partly-expanded-body] + [else + ;; No, it didn't expand to `#%module-begin` + (add-module-begin (list partly-expanded-body) s scopes-s phase module-name-sym + (make-mb-ctx) + #:log-rename-one? #f)])])] + [else + ;; Multiple body forms definitely need a `#%module-begin` wrapper + (add-module-begin bodys s scopes-s phase module-name-sym + (make-mb-ctx))])) + (add-enclosing-name-property mb module-name-sym)) + +;; Add `#%module-begin`, because it's needed +(define (add-module-begin bodys s scopes-s phase module-name-sym mb-ctx + #:log-rename-one? [log-rename-one? #t]) + (define disarmed-scopes-s (syntax-disarm scopes-s)) + (define mb-id (datum->syntax disarmed-scopes-s '#%module-begin)) + ;; If `mb-id` is not bound, we'd like to give a clear error message + (unless (resolve mb-id phase) + (raise-syntax-error #f "no #%module-begin binding in the module's language" s)) + (define mb (datum->syntax disarmed-scopes-s `(,mb-id ,@bodys) s)) + (log-expand mb-ctx 'tag mb) + (when log-rename-one? + (log-expand mb-ctx 'rename-one mb)) + (define partly-expanded-mb (performance-region + ['expand 'module-begin] + (expand (add-enclosing-name-property mb module-name-sym) + mb-ctx))) + (unless (eq? '#%module-begin (core-form-sym (syntax-disarm partly-expanded-mb) phase)) + (raise-syntax-error #f "expansion of #%module-begin is not a #%plain-module-begin form" s + partly-expanded-mb)) + partly-expanded-mb) + +(define (add-enclosing-name-property stx module-name-sym) + (syntax-property stx 'enclosing-module-name module-name-sym)) + +;; ---------------------------------------- + +;; Make function to adjust syntax that appears in the original module body +(define (make-apply-module-scopes inside-scope outside-scope + init-ctx keep-enclosing-scope-at-phase + self enclosing-self enclosing-mod) + (lambda (s) + (performance-region + ['expand 'module 'scopes] + (define s-without-enclosing + (if keep-enclosing-scope-at-phase + ;; Keep enclosing module scopes for `(module* _ #f ....)` + s + ;; Remove the scopes of the top level or a module outside of + ;; this module, as well as any relevant use-site scopes + (remove-use-site-scopes + (remove-scopes s (root-expand-context-module-scopes init-ctx)) + init-ctx))) + ;; Add outside- and inside-edge scopes + (define s-with-edges + (add-scope (add-scope s-without-enclosing + outside-scope) + inside-scope)) + (define s-with-suitable-enclosing + (cond + [keep-enclosing-scope-at-phase + ;; Shift any references to the enclosing module to be relative to the + ;; submodule + (syntax-module-path-index-shift + s-with-edges + enclosing-self + enclosing-mod)] + [else s-with-edges])) + ;; In case we're expanding syntax that was previously expanded, + ;; shift the generic "self" to the "self" for the current expansion: + (syntax-module-path-index-shift + s-with-suitable-enclosing + (make-generic-self-module-path-index self) + self + ;; Also preserve the expansion-time code inspector + (current-code-inspector))))) + +;; ---------------------------------------- + +;; Pass 1 of `module` expansion, which uncovers definitions, +;; requires, and `module` submodules +(define (partially-expand-bodys bodys + #:phase phase + #:ctx partial-body-ctx + #:namespace m-ns + #:self self + #:frame-id frame-id + #:requires-and-provides requires+provides + #:need-eventually-defined need-eventually-defined + #:all-scopes-stx all-scopes-stx + #:defined-syms defined-syms + #:declared-keywords declared-keywords + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset + #:loop pass-1-and-2-loop) + (namespace-visit-available-modules! m-ns phase) + (let loop ([tail? #t] [bodys bodys]) + (cond + [(null? bodys) + (cond + [(and tail? (not (zero? phase))) + (log-expand partial-body-ctx 'module-lift-end-loop '()) + null] + [tail? + ;; Were at the very end of the module; if there are any lifted-to-end + ;; declarations, keep going + (define bodys + (append + (get-and-clear-end-lifts! (expand-context-to-module-lifts partial-body-ctx)) + (get-and-clear-provide-lifts! (expand-context-to-module-lifts partial-body-ctx)))) + (log-expand partial-body-ctx 'module-lift-end-loop bodys) + (cond + [(null? bodys) null] + [else (loop #t (add-post-expansion-scope bodys partial-body-ctx))])] + [else null])] + [else + (define rest-bodys (cdr bodys)) + (log-expand partial-body-ctx 'next) + (define exp-body (performance-region + ['expand 'form-in-module/1] + (expand (car bodys) partial-body-ctx))) + (define disarmed-exp-body (syntax-disarm exp-body)) + (define lifted-defns (get-and-clear-lifts! (expand-context-lifts partial-body-ctx))) + (when (pair? lifted-defns) + (log-lifted-defns partial-body-ctx lifted-defns exp-body rest-bodys)) + (log-expand partial-body-ctx 'rename-one exp-body) + (append/tail-on-null + ;; Save any requires lifted during partial expansion + (get-and-clear-require-lifts! (expand-context-require-lifts partial-body-ctx)) + ;; Ditto for expressions + lifted-defns + ;; Ditto for modules, which need to be processed + (loop #f (add-post-expansion-scope + (get-and-clear-module-lifts! (expand-context-module-lifts partial-body-ctx)) + partial-body-ctx)) + ;; Dispatch on form revealed by partial expansion + (case (core-form-sym disarmed-exp-body phase) + [(begin) + (define-match m disarmed-exp-body '(begin e ...)) + (define (track e) (syntax-track-origin e exp-body)) + (define spliced-bodys (append (map track (m 'e)) rest-bodys)) + (log-expand partial-body-ctx 'splice spliced-bodys) + (loop tail? spliced-bodys)] + [(begin-for-syntax) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-begin-for-syntax] ['prepare-env]) + (define ct-m-ns (namespace->namespace-at-phase m-ns (add1 phase))) + (prepare-next-phase-namespace partial-body-ctx) + (log-expand partial-body-ctx 'phase-up) + (define-match m disarmed-exp-body '(begin-for-syntax e ...)) + (define nested-bodys (pass-1-and-2-loop (m 'e) (add1 phase))) + (log-expand partial-body-ctx 'next-group) + (namespace-run-available-modules! m-ns (add1 phase)) ; to support running `begin-for-syntax` + (eval-nested-bodys nested-bodys (add1 phase) ct-m-ns self partial-body-ctx) + (namespace-visit-available-modules! m-ns phase) ; since we're shifting back a phase + (log-expand partial-body-ctx 'exit-prim + (let ([s-nested-bodys (for/list ([nested-body (in-list nested-bodys)]) + (extract-syntax nested-body))]) + (datum->syntax #f (cons (m 'begin-for-syntax) s-nested-bodys) exp-body))) + (cons + (semi-parsed-begin-for-syntax exp-body nested-bodys) + (loop tail? rest-bodys))] + [(define-values) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-define-values]) + (define-match m disarmed-exp-body '(define-values (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) partial-body-ctx)) + (check-no-duplicate-ids ids phase exp-body) + (check-ids-unbound ids phase requires+provides #:in exp-body) + (define syms (select-defined-syms-and-bind! ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:requires+provides requires+provides + #:in exp-body)) + (add-defined-syms! requires+provides syms phase) + (log-expand partial-body-ctx 'exit-prim + (datum->syntax #f `(,(m 'define-values) ,ids ,(m 'rhs)) exp-body)) + (cons + (semi-parsed-define-values exp-body syms ids (m 'rhs)) + (loop tail? rest-bodys))] + [(define-syntaxes) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-define-syntaxes] ['prepare-env]) + (prepare-next-phase-namespace partial-body-ctx) + (log-expand partial-body-ctx 'phase-up) + (define-match m disarmed-exp-body '(define-syntaxes (id ...) rhs)) + (define ids (remove-use-site-scopes (m 'id) partial-body-ctx)) + (check-no-duplicate-ids ids phase exp-body) + (check-ids-unbound ids phase requires+provides #:in exp-body) + (define syms (select-defined-syms-and-bind! ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:requires+provides requires+provides + #:in exp-body + #:as-transformer? #t)) + (add-defined-syms! requires+provides syms phase) + ;; Expand and evaluate RHS: + (define-values (exp-rhs parsed-rhs vals) + (expand+eval-for-syntaxes-binding (m 'rhs) ids + (struct*-copy expand-context partial-body-ctx + [lifts #f] + ;; require lifts ok, others disallowed + [module-lifts #f] + [to-module-lifts #f] + [need-eventually-defined need-eventually-defined]) + #:log-next? #f)) + ;; Install transformers in the namespace for expansion: + (for ([sym (in-list syms)] + [val (in-list vals)] + [id (in-list ids)]) + (maybe-install-free=id-in-context! val id phase partial-body-ctx) + (namespace-set-transformer! m-ns phase sym val)) + (log-expand partial-body-ctx 'exit-prim (datum->syntax #f `(,(m 'define-syntaxes) ,ids ,exp-rhs))) + (define parsed-body (parsed-define-syntaxes (keep-properties-only exp-body) ids syms parsed-rhs)) + (cons (if (expand-context-to-parsed? partial-body-ctx) + parsed-body + (expanded+parsed + (rebuild + exp-body + `(,(m 'define-syntaxes) ,ids ,exp-rhs)) + parsed-body)) + (loop tail? rest-bodys))] + [(#%require) + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-require]) + (define ready-body (remove-use-site-scopes disarmed-exp-body partial-body-ctx)) + (define-match m ready-body '(#%require req ...)) + (parse-and-perform-requires! (m 'req) exp-body #:self self + m-ns phase #:run-phase phase + requires+provides + #:declared-submodule-names declared-submodule-names + #:who 'module) + (log-expand partial-body-ctx 'exit-prim ready-body) + (cons exp-body + (loop tail? rest-bodys))] + [(#%provide) + ;; save for last pass + (cons exp-body + (loop tail? rest-bodys))] + [(module) + ;; Submodule to parse immediately + (define ready-body (remove-use-site-scopes exp-body partial-body-ctx)) + (define submod + (expand-submodule ready-body self partial-body-ctx + #:is-star? #f + #:declared-submodule-names declared-submodule-names + #:mpis-to-reset mpis-to-reset + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)) + (cons submod + (loop tail? rest-bodys))] + [(module*) + ;; Submodule to save for after this module + (log-expand* partial-body-ctx ['enter-prim exp-body] ['prim-submodule*] + ['exit-prim exp-body]) + (cons exp-body + (loop tail? rest-bodys))] + [(#%declare) + (define-match m disarmed-exp-body '(#%declare kw ...)) + (for ([kw (in-list (m 'kw))]) + (unless (keyword? (syntax-e kw)) + (raise-syntax-error #f "expected a keyword" exp-body kw)) + (unless (memq (syntax-e kw) '(#:cross-phase-persistent #:empty-namespace)) + (raise-syntax-error #f "not an allowed declaration keyword" exp-body kw)) + (when (hash-ref declared-keywords (syntax-e kw) #f) + (raise-syntax-error #f "keyword declared multiple times" exp-body kw)) + (hash-set! declared-keywords (syntax-e kw) kw)) + (define parsed-body (parsed-#%declare exp-body)) + (cons (if (expand-context-to-parsed? partial-body-ctx) + parsed-body + (expanded+parsed exp-body parsed-body)) + (loop tail? rest-bodys))] + [else + ;; save expression for next pass + (cons exp-body + (loop tail? rest-bodys))]))]))) + +;; Convert lifted identifiers plus expression to a `define-values` form: +(define (make-wrap-as-definition self frame-id + inside-scope all-scopes-stx + defined-syms requires+provides) + (lambda (ids rhs phase) + (define scoped-ids (for/list ([id (in-list ids)]) + (add-scope id inside-scope))) + (define syms + (select-defined-syms-and-bind! scoped-ids defined-syms + self phase all-scopes-stx + #:frame-id frame-id + #:requires+provides requires+provides)) + (define s (add-scope (datum->syntax + #f + (list (datum->syntax (syntax-shift-phase-level core-stx phase) + 'define-values) + scoped-ids + rhs)) + inside-scope)) + (values scoped-ids + (semi-parsed-define-values s syms scoped-ids rhs)))) + +(define (add-post-expansion-scope bodys ctx) + (define sc (root-expand-context-post-expansion-scope ctx)) + (if sc + (for/list ([body (in-list bodys)]) + (add-scope body sc)) + bodys)) + +;; ---------------------------------------- + +;; Pass 2 of `module` expansion, which expands all expressions +(define (finish-expanding-body-expressons partially-expanded-bodys + #:phase phase + #:ctx body-ctx + #:self self + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:mpis-to-reset mpis-to-reset) + (let loop ([tail? #t] [bodys partially-expanded-bodys]) + (cond + [(null? bodys) + (cond + [(and tail? (not (zero? phase))) + (log-expand body-ctx 'module-lift-end-loop '()) + null] + [tail? + ;; We're at the very end of the module, again, so check for lifted-to-end + ;; declarations + (define bodys + (append + (get-and-clear-end-lifts! (expand-context-to-module-lifts body-ctx)) + (get-and-clear-provide-lifts! (expand-context-to-module-lifts body-ctx)))) + (cond + [(null? bodys) + (log-expand body-ctx 'module-lift-end-loop '()) + null] + [else + (loop #t (add-post-expansion-scope bodys body-ctx))])] + [else null])] + [else + (log-expand body-ctx 'next) + (define body (car bodys)) + (define rest-bodys (cdr bodys)) + (define exp-body + (cond + [(or (parsed? body) + (expanded+parsed? body) + (semi-parsed-begin-for-syntax? body)) + ;; An already-parsed (enough for now) form + body] + [(semi-parsed-define-values? body) + (define ids (semi-parsed-define-values-ids body)) + (define rhs-ctx (as-named-context (as-expression-context body-ctx) ids)) + (define syms (semi-parsed-define-values-syms body)) + (define s (semi-parsed-define-values-s body)) + (define-match m (syntax-disarm s) #:unless (expand-context-to-parsed? rhs-ctx) + '(define-values _ _)) + (define rebuild-s (keep-as-needed rhs-ctx s #:keep-for-parsed? #t)) + (log-defn-enter body-ctx body) + (define exp-rhs (performance-region + ['expand 'form-in-module/2] + (expand (semi-parsed-define-values-rhs body) rhs-ctx))) + (log-defn-exit body-ctx body exp-rhs) + (define comp-form + (parsed-define-values rebuild-s ids syms + (if (expand-context-to-parsed? rhs-ctx) + ;; Have (and need only) parsed form + exp-rhs + ;; Expand rhs again to parse it + (expand exp-rhs (as-to-parsed-context rhs-ctx))))) + (if (expand-context-to-parsed? rhs-ctx) + comp-form + (expanded+parsed + (rebuild + rebuild-s + `(,(m 'define-values) ,ids ,exp-rhs)) + comp-form))] + [else + (define disarmed-body (syntax-disarm body)) + (case (core-form-sym disarmed-body phase) + [(#%require #%provide module*) + ;; handle earlier or later + body] + [else + (performance-region + ['expand 'form-in-module/2] + (define exp-body (expand body (as-expression-context body-ctx))) + (if (expand-context-to-parsed? body-ctx) + ;; Have (and need only) parsed form + exp-body + ;; Expand again to parse it + (expanded+parsed + exp-body + (expand exp-body (as-to-parsed-context body-ctx)))))])])) + (define lifted-defns (get-and-clear-lifts! (expand-context-lifts body-ctx))) + (define lifted-requires + ;; Get any requires and provides, keeping them as-is + (get-and-clear-require-lifts! (expand-context-require-lifts body-ctx))) + (define lifted-modules (get-and-clear-module-lifts! (expand-context-module-lifts body-ctx))) + (define no-lifts? (and (null? lifted-defns) (null? lifted-modules) (null? lifted-requires))) + (unless no-lifts? + (log-expand body-ctx 'module-lift-loop (append lifted-requires + (lifted-defns-extract-syntax lifted-defns) + (add-post-expansion-scope lifted-modules body-ctx)))) + (define exp-lifted-modules + ;; If there were any module lifts, the `module` forms need to + ;; be expanded + (expand-non-module*-submodules lifted-modules + phase + self + body-ctx + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)) + (define exp-lifted-defns + ;; If there were any lifts, the right-hand sides need to be expanded + (loop #f lifted-defns)) + (unless no-lifts? (log-expand body-ctx 'next)) + (append + lifted-requires + exp-lifted-defns + exp-lifted-modules + (cons exp-body + (loop tail? rest-bodys)))]))) + +(define (check-defined-by-now need-eventually-defined self ctx) + ;; If `need-eventually-defined` is not empty, report an error + (for ([(phase l) (in-hash need-eventually-defined)]) + (for ([id (in-list l)]) + (define b (resolve+shift id phase)) + ;; FIXME: check that the binding is for a variable + (unless (and b + (module-binding? b) + (eq? (module-binding-sym b) (syntax-e id)) + (eq? (module-binding-module b) self)) + (raise-syntax-error #f "reference to an unbound identifier" + id #f null + (syntax-debug-info-string id ctx)))))) + +;; ---------------------------------------- + +;; Pass 3 of `module` expansion, which parses `provide` forms and +;; matches them up with defintiions and requires +(define (resolve-provides expression-expanded-bodys + #:requires-and-provides requires+provides + #:declared-submodule-names declared-submodule-names + #:namespace m-ns + #:phase phase + #:self self + #:ctx ctx) + (performance-region + ['expand 'provide] + (let loop ([bodys expression-expanded-bodys] [phase phase]) + (cond + [(null? bodys) null] + [(or (parsed? (car bodys)) + (expanded+parsed? (car bodys))) + (cons (car bodys) + (loop (cdr bodys) phase))] + [(semi-parsed-begin-for-syntax? (car bodys)) + (define nested-bodys (loop (semi-parsed-begin-for-syntax-body (car bodys)) (add1 phase))) + ;; Stil semi-parsed; finished in pass 4 + (cons (struct-copy semi-parsed-begin-for-syntax (car bodys) + [body nested-bodys]) + (loop (cdr bodys) phase))] + [else + (define disarmed-body (syntax-disarm (car bodys))) + (case (core-form-sym disarmed-body phase) + [(#%provide) + (log-expand* ctx ['enter-prim (car bodys)] ['prim-provide]) + (define-match m disarmed-body '(#%provide spec ...)) + (define-values (track-stxes specs) + (parse-and-expand-provides! (m 'spec) (car bodys) + requires+provides self + phase (struct*-copy expand-context ctx + [context 'top-level] + [phase phase] + [namespace (namespace->namespace-at-phase m-ns phase)] + [requires+provides requires+provides] + [declared-submodule-names declared-submodule-names]))) + (log-expand ctx 'exit-prim) + (cond + [(expand-context-to-parsed? ctx) + (loop (cdr bodys) phase)] + [else + (cons (syntax-track-origin* + track-stxes + (rebuild + (car bodys) + `(,(m '#%provide) ,@specs))) + (loop (cdr bodys) phase))])] + [else + (cons (car bodys) + (loop (cdr bodys) phase))])])))) + +;; ---------------------------------------- + +;; In support of pass 4, declare a module (in a temporary namespace) +;; before any `module*` submodule is expanded +(define (declare-module-for-expansion fully-expanded-bodys-except-post-submodules + #:module-name-id module-name-id + #:rebuild-s rebuild-s + #:requires-and-provides requires+provides + #:namespace m-ns + #:self self + #:enclosing enclosing-self + #:root-ctx root-ctx + #:ctx ctx + #:modules-being-compiled modules-being-compiled + #:fill compiled-module-box) + + (define-values (requires provides) (extract-requires-and-provides requires+provides self self)) + + (define parsed-mod + (parsed-module rebuild-s + #f + module-name-id + self + requires + provides + (requires+provides-all-bindings-simple? requires+provides) + (root-expand-context-encode-for-module root-ctx self self) + (parsed-only fully-expanded-bodys-except-post-submodules) + #f + (hasheq))) + + (define module-name (module-path-index-resolve (or enclosing-self self))) + (define compiled-module + (compile-module parsed-mod + (make-compile-context #:namespace m-ns + #:module-self enclosing-self + #:full-module-name (and enclosing-self + (resolved-module-path-name module-name))) + #:serializable? (expand-context-for-serializable? ctx) + #:modules-being-compiled modules-being-compiled + #:need-compiled-submodule-rename? #f)) + (set-box! compiled-module-box compiled-module) + + (define root-module-name (resolved-module-path-root-name module-name)) + (parameterize ([current-namespace m-ns] + [current-module-declare-name (make-resolved-module-path root-module-name)]) + (eval-module compiled-module + #:with-submodules? #f))) + +(define (attach-root-expand-context-properties s root-ctx orig-self new-self) + ;; Original API: + (let* ([s (syntax-property s 'module-body-context (root-expand-context-all-scopes-stx root-ctx))] + [s (syntax-property s + 'module-body-inside-context + (add-scope empty-syntax + (root-expand-context-post-expansion-scope root-ctx)))]) + s)) + +;; ---------------------------------------- + +;; Pass 4 of `module` expansion, which expands `module*` forms; +;; this pass muct happen after everything else for the module, since a +;; `module*` submodule can require from its enclosing module; in +;; addition to expanding `module*`, generate expanded `begin-for-syntax` +;; as needed and ensure that parsed `begin-for-syntax` has only parsed +;; forms +(define (expand-post-submodules fully-expanded-bodys-except-post-submodules + #:declare-enclosing declare-enclosing-module + #:phase phase + #:self self + #:requires-and-provides requires+provides + #:enclosing-is-cross-phase-persistent? enclosing-is-cross-phase-persistent? + #:all-scopes-s all-scopes-s + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled + #:ctx submod-ctx) + (let loop ([bodys fully-expanded-bodys-except-post-submodules] [phase phase]) + (cond + [(null? bodys) null] + [else + (define body (car bodys)) + (define rest-bodys (cdr bodys)) + (cond + [(semi-parsed-begin-for-syntax? body) + (define body-s (semi-parsed-begin-for-syntax-s body)) + (define-match m (syntax-disarm body-s) '(begin-for-syntax _ ...)) + (define rebuild-body-s (keep-as-needed submod-ctx body-s)) + (define nested-bodys (loop (semi-parsed-begin-for-syntax-body body) (add1 phase))) + (define parsed-bfs (parsed-begin-for-syntax rebuild-body-s (parsed-only nested-bodys))) + (cons + (if (expand-context-to-parsed? submod-ctx) + parsed-bfs + (expanded+parsed + (rebuild rebuild-body-s `(,(m 'begin-for-syntax) ,@(syntax-only nested-bodys))) + parsed-bfs)) + (loop rest-bodys phase))] + [(or (parsed? body) + (expanded+parsed? body)) + ;; We can skip any other parsed form + (cons body + (loop rest-bodys phase))] + [else + (define disarmed-body (syntax-disarm body)) + (case (core-form-sym disarmed-body phase) + [(module*) + ;; Ensure that the enclosing module is declared: + (force declare-enclosing-module) + (define ready-body (remove-use-site-scopes body submod-ctx)) + (define-match f-m disarmed-body #:try '(module* name #f . _)) + (define submod + (cond + [(f-m) + ;; Need to shift the submodule relative to the enclosing module: + (define neg-phase (phase- 0 phase)) + (define shifted-s (syntax-shift-phase-level ready-body neg-phase)) + (define submod + (expand-submodule shifted-s self submod-ctx + #:is-star? #t + #:keep-enclosing-scope-at-phase neg-phase + #:enclosing-all-scopes-stx all-scopes-s + #:enclosing-requires+provides requires+provides + #:enclosing-is-cross-phase-persistent? enclosing-is-cross-phase-persistent? + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)) + (cond + [(parsed? submod) submod] + [(expanded+parsed? submod) + (struct-copy expanded+parsed submod + [s (syntax-shift-phase-level (expanded+parsed-s submod) phase)])] + [else (syntax-shift-phase-level submod phase)])] + [else + (expand-submodule ready-body self submod-ctx + #:is-star? #t + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)])) + (cons submod + (loop rest-bodys phase))] + [else + ;; We can skip any other unparsed form + (cons body + (loop rest-bodys phase))])])]))) + +(define (stop-at-module*? ctx) + (free-id-set-member? (expand-context-stops ctx) + (expand-context-phase ctx) + (syntax-shift-phase-level (datum->syntax core-stx 'module*) + (expand-context-phase ctx)))) + +;; ---------------------------------------- + +(define (check-ids-unbound ids phase requires+provides #:in s) + (for ([id (in-list ids)]) + (check-not-defined requires+provides id phase #:in s #:who 'module))) + +;; ---------------------------------------- + +(define (eval-nested-bodys bodys phase m-ns self ctx) + ;; The definitions and expression `bodys` are fully expanded and + ;; parsed; evaluate them + (for ([body (in-list bodys)]) + (define p (if (expanded+parsed? body) + (expanded+parsed-parsed body) + body)) + (cond + [(parsed-define-values? p) + (define ids (parsed-define-values-ids p)) + (define vals (eval-for-bindings ids (parsed-define-values-rhs p) phase m-ns ctx)) + (for ([id (in-list ids)] + [sym (in-list (parsed-define-values-syms p))] + [val (in-list vals)]) + (namespace-set-variable! m-ns phase sym val))] + [(or (parsed-define-syntaxes? p) + (semi-parsed-begin-for-syntax? p)) + ;; already evaluated during expansion + (void)] + [(or (parsed-#%declare? p) + (syntax? p)) + ;; handled earlier or later + (void)] + [else + ;; an expression + (parameterize ([current-expand-context ctx] + [current-namespace m-ns]) + (eval-single-top + (compile-single p (make-compile-context + #:namespace m-ns + #:phase phase)) + m-ns))]))) + +;; ---------------------------------------- + +(define (expand-submodule s self ctx + #:is-star? is-star? + #:keep-enclosing-scope-at-phase [keep-enclosing-scope-at-phase #f] + #:enclosing-requires+provides [enclosing-r+p #f] + #:enclosing-is-cross-phase-persistent? [enclosing-is-cross-phase-persistent? #f] + #:enclosing-all-scopes-stx [enclosing-all-scopes-stx #f] + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled) + (unless is-star? + (log-expand* ctx ['enter-prim s] [(if is-star? 'prim-submodule* 'prim-submodule)])) + + ;; Register name and check for duplicates + (define-match m s '(module name . _)) + (define name (syntax-e (m 'name))) + (when (hash-ref declared-submodule-names name #f) + (raise-syntax-error #f "submodule already declared with the same name" s name)) + (hash-set! declared-submodule-names name (syntax-e (m 'module))) + + (log-expand* ctx ['enter-prim s]) + + (define submod + (expand-module s + (struct*-copy expand-context ctx + [context 'module] + [stops empty-free-id-set] + [post-expansion-scope #:parent root-expand-context #f]) + self + #:always-produce-compiled? #t + #:keep-enclosing-scope-at-phase keep-enclosing-scope-at-phase + #:enclosing-all-scopes-stx enclosing-all-scopes-stx + #:enclosing-requires+provides enclosing-r+p + #:enclosing-is-cross-phase-persistent? enclosing-is-cross-phase-persistent? + #:mpis-for-enclosing-reset mpis-to-reset + #:modules-being-compiled modules-being-compiled)) + + (log-expand* ctx ['exit-prim (extract-syntax submod)]) + + ;; Compile and declare the submodule for use by later forms + ;; in the enclosing module: + (define ns (expand-context-namespace ctx)) + (define module-name (module-path-index-resolve self)) + (define root-module-name (resolved-module-path-root-name module-name)) + (define compiled-submodule + (compile-module (if (expanded+parsed? submod) + (expanded+parsed-parsed submod) + submod) + (make-compile-context #:namespace ns + #:module-self self + #:full-module-name (resolved-module-path-name module-name)) + #:force-linklet-directory? #t + #:serializable? (expand-context-for-serializable? ctx) + #:modules-being-compiled modules-being-compiled + #:need-compiled-submodule-rename? #f)) + (hash-set! compiled-submodules name (cons is-star? compiled-submodule)) + (parameterize ([current-namespace ns] + [current-module-declare-name (make-resolved-module-path root-module-name)]) + (eval-module compiled-submodule + #:with-submodules? #f)) + + (unless is-star? + (log-expand ctx 'exit-prim (extract-syntax submod))) + + ;; Return the expanded submodule + (cond + [(not is-star?) + submod] + [(expanded+parsed? submod) + (struct-copy expanded+parsed submod + [parsed (struct-copy parsed-module (expanded+parsed-parsed submod) + [star? #t])])] + [else + (struct-copy parsed-module submod + [star? #t])])) + +;; Expand `module` forms, leave `module*` forms alone: +(define (expand-non-module*-submodules bodys phase self ctx + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled) + (for/list ([body (in-list bodys)]) + (case (core-form-sym (syntax-disarm body) phase) + [(module) + (expand-submodule body self ctx + #:is-star? #f + #:mpis-to-reset mpis-to-reset + #:declared-submodule-names declared-submodule-names + #:compiled-submodules compiled-submodules + #:modules-being-compiled modules-being-compiled)] + [else body]))) + +;; ---------------------------------------- + +(define (make-parse-lifted-require m-ns self requires+provides + #:declared-submodule-names declared-submodule-names) + (lambda (s phase) + (define-match m (syntax-disarm s) '(#%require req)) + (parse-and-perform-requires! (list (m 'req)) s #:self self + m-ns phase #:run-phase phase + requires+provides + #:declared-submodule-names declared-submodule-names + #:who 'require))) + +;; ---------------------------------------- + +(define (defn-extract-syntax defn) + (datum->syntax #f `(define-values ,(semi-parsed-define-values-ids defn) + ,(semi-parsed-define-values-rhs defn)) + (semi-parsed-define-values-s defn))) + +(define (lifted-defns-extract-syntax lifted-defns) + (for/list ([lifted-defn (in-list lifted-defns)]) + (defn-extract-syntax lifted-defn))) + +(define (log-lifted-defns partial-body-ctx lifted-defns exp-body rest-bodys) + (log-expand... + partial-body-ctx + (lambda (obs) + (define s-lifted-defns (lifted-defns-extract-syntax lifted-defns)) + (...log-expand obs ['rename-list (cons exp-body rest-bodys)] ['module-lift-loop s-lifted-defns]) + ;; The old expander retried expanding the lifted definitions. + ;; We know that they immediately stop, so we don't do that here, + ;; but we simulate the observer events. + (for ([s-lifted-defn (in-list s-lifted-defns)]) + (define-match m s-lifted-defn '(define-values _ ...)) + (...log-expand obs + ['next] + ['visit s-lifted-defn] + ['resolve (m 'define-values)] + ['enter-prim s-lifted-defn] + ['prim-stop] + ['exit-prim s-lifted-defn] + ['return s-lifted-defn] + ['rename-one s-lifted-defn] + ['enter-prim s-lifted-defn] + ['prim-define-values] + ['exit-prim s-lifted-defn])) + ;; A 'next, etc., to simulate retrying the expression that + ;; generated the lifts --- which we know must be a stop form, + ;; but we need to simulate the trip back around the loop: + (define-match m exp-body '(form-id . _)) + (...log-expand obs + ['next] + ['visit exp-body] + ['resolve (m 'form-id)] + ['enter-prim exp-body] + ['prim-stop] + ['exit-prim exp-body] + ['return exp-body])))) + +(define (log-defn-enter ctx defn) + (log-expand... + ctx + (lambda (obs) + (define s-defn (defn-extract-syntax defn)) + (define-match m s-defn '(define-values _ ...)) + (...log-expand obs + ['visit s-defn] + ['resolve (m 'define-values)] + ['enter-prim s-defn] + ['prim-define-values])))) + +(define (log-defn-exit ctx defn exp-rhs) + (log-expand... + ctx + (lambda (obs) + (define s-defn + (datum->syntax #f `(define-values ,(semi-parsed-define-values-ids defn) + ,exp-rhs) + (semi-parsed-define-values-s defn))) + (...log-expand obs + ['exit-prim s-defn] + ['return s-defn])))) diff --git a/racket/src/expander/expand/parsed.rkt b/racket/src/expander/expand/parsed.rkt new file mode 100644 index 0000000000..a7fa7b9e95 --- /dev/null +++ b/racket/src/expander/expand/parsed.rkt @@ -0,0 +1,51 @@ +#lang racket/base + +(provide (all-defined-out)) + +;; A fully expanded form can be parsed into an AST. In principle, +;; parsing could be a pass separate from the expander. As an important +;; shortcut, however, we fuse the expander and parser; the +;; `to-parsed?` field in an `expand-context` indicates whether the +;; expander should produce a syntax object or a `parsed` structure. + +(struct parsed (s) #:authentic #:transparent) + +(struct parsed-id parsed (binding inspector) #:authentic) +(struct parsed-primitive-id parsed-id () #:authentic) +(struct parsed-top-id parsed-id () #:authentic) + +(struct parsed-lambda parsed (keys body) #:authentic) +(struct parsed-case-lambda parsed (clauses) #:authentic) +(struct parsed-app parsed (rator rands) #:authentic) +(struct parsed-if parsed (tst thn els) #:authentic) +(struct parsed-set! parsed (id rhs) #:authentic) +(struct parsed-with-continuation-mark parsed (key val body) #:authentic) +(struct parsed-#%variable-reference parsed (id) #:authentic) +(struct parsed-begin parsed (body) #:authentic) +(struct parsed-begin0 parsed (body) #:authentic) +(struct parsed-quote parsed (datum) #:authentic) +(struct parsed-quote-syntax parsed (datum) #:authentic) + +(struct parsed-let_-values parsed (idss clauses body) #:authentic) +(struct parsed-let-values parsed-let_-values () #:authentic) +(struct parsed-letrec-values parsed-let_-values () #:authentic) + +(struct parsed-define-values parsed (ids syms rhs) #:authentic) +(struct parsed-define-syntaxes parsed (ids syms rhs) #:authentic) +(struct parsed-begin-for-syntax parsed (body) #:authentic) + +(struct parsed-#%declare parsed () #:authentic) +(struct parsed-require parsed () #:authentic) + +(struct parsed-#%module-begin parsed (body) #:authentic) +(struct parsed-module parsed (star? + name-id + self + requires + provides + root-ctx-simple? + encoded-root-ctx + body + compiled-module ; #f or already-compiled module + compiled-submodules) ; already-compiled submodules + #:authentic) diff --git a/racket/src/expander/expand/prepare.rkt b/racket/src/expander/expand/prepare.rkt new file mode 100644 index 0000000000..c52cda7f1b --- /dev/null +++ b/racket/src/expander/expand/prepare.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require "../namespace/namespace.rkt" + "../namespace/module.rkt" + "context.rkt") + +(provide prepare-next-phase-namespace) + +(define (prepare-next-phase-namespace ctx) + (define phase (add1 (expand-context-phase ctx))) + (define ns (namespace->namespace-at-phase (expand-context-namespace ctx) + phase)) + (namespace-visit-available-modules! ns phase)) diff --git a/racket/src/expander/expand/protect.rkt b/racket/src/expander/expand/protect.rkt new file mode 100644 index 0000000000..e098983fcd --- /dev/null +++ b/racket/src/expander/expand/protect.rkt @@ -0,0 +1,70 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../common/module-path.rkt" + "binding-to-module.rkt") + +(provide resolve+shift/extra-inspector + check-access) + +;; Check inspector-based access to a module's definitions; a suitable inspector +;; might be provided by `id`, or the binding might carry an extra inspector +;; (put there via a provide of a rename transformer, where the extra inspector +;; was attached to the identifier in the rename transformer) +(define (check-access b mi id in-s what) + (define m (module-instance-module mi)) + (when (and m (not (module-no-protected? m))) + (define access (or (module-access m) (module-compute-access! m))) + (define a (hash-ref (hash-ref access (module-binding-phase b) #hasheq()) + (module-binding-sym b) + 'unexported)) + (when (or (eq? a 'unexported) ; not provided => implicitly protected + (eq? a 'protected)) + (unless (or (inspector-superior? (or (syntax-inspector id) (current-code-inspector)) + (namespace-inspector (module-instance-namespace mi))) + (and (module-binding-extra-inspector b) + (inspector-superior? (module-binding-extra-inspector b) + (namespace-inspector (module-instance-namespace mi))))) + ;; In the error message, use the original expression `in-s` or + ;; the symbol protected or defined in the target module --- + ;; but only if that name is different from `id`, which we'll + ;; certainly include in the error + (define complain-id (let ([c-id (or in-s (module-binding-sym b))]) + (and (not (eq? (if (syntax? c-id) (syntax-content c-id) c-id) + (syntax-content id))) + c-id))) + (raise-syntax-error #f + (format "access disallowed by code inspector to ~a ~a\n from module: ~a" + a + what + (module-path-index-resolve (namespace-mpi (module-instance-namespace mi)))) + complain-id id null))))) + +;; Like `resolve+shift`, but follow `free-identifier=?` chains to +;; attach an inspector at the last step in the chain to the +;; resulting binding. Also, check protected access along the way, +;; so that we don't expose an inspector that the reference is not +;; allowed to reach. +(define (resolve+shift/extra-inspector id phase ns) + (let loop ([id id] [in-s #f]) + (define b (resolve+shift id phase #:immediate? #t)) + (cond + [(binding-free=id b) + => (lambda (next-id) + (when (and (module-binding? b) + (not (top-level-module-path-index? (module-binding-module b)))) + (define mi (binding->module-instance b ns phase id)) + (check-access b mi id in-s "provided binding")) + (define next-b (loop next-id (or in-s id))) + (cond + [(not next-b) b] + [(and (module-binding? next-b) + (not (module-binding-extra-inspector next-b)) + (syntax-inspector id)) + (module-binding-update next-b + #:extra-inspector (syntax-inspector id))] + [else next-b]))] + [else b]))) diff --git a/racket/src/expander/expand/provide.rkt b/racket/src/expander/expand/provide.rkt new file mode 100644 index 0000000000..dd7b193fc1 --- /dev/null +++ b/racket/src/expander/expand/provide.rkt @@ -0,0 +1,276 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/taint.rkt" + "../syntax/track.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/match.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "require+provide.rkt" + "context.rkt" + "protect.rkt" + "module-path.rkt" + "binding-for-transformer.rkt" + "../namespace/core.rkt" + "../common/module-path.rkt" + "free-id-set.rkt" + "main.rkt") + +(provide parse-and-expand-provides!) + +(define layers '(raw phaseless id)) + +(define provide-form-name 'provide) ; complain as `provide` instead of `#%provide` + +(define (parse-and-expand-provides! specs orig-s + rp self + phase ctx) + ;; returns a list of expanded specs while registering provides in `rp` + (define ns (expand-context-namespace ctx)) + (let loop ([specs specs] + [at-phase phase] + [protected? #f] + [layer 'raw]) + (define-values (track-stxess exp-specss) + (for/lists (track-stxes exp-specs) ([spec (in-list specs)]) + (define disarmed-spec (syntax-disarm spec)) + (define fm (and (pair? (syntax-e disarmed-spec)) + (identifier? (car (syntax-e disarmed-spec))) + (syntax-e (car (syntax-e disarmed-spec))))) + (define (check-nested want-layer) + (unless (member want-layer (member layer layers)) + (raise-syntax-error provide-form-name (format "nested `~a' not allowed" fm) orig-s spec))) + (case fm + [(for-meta) + (check-nested 'raw) + (define-match m disarmed-spec '(for-meta phase-level spec ...)) + (define p (syntax-e (m 'phase-level))) + (unless (phase? p) + (raise-syntax-error provide-form-name "bad `for-meta' phase" orig-s spec)) + (define-values (track-stxes exp-specs) + (loop (m 'spec) + (phase+ p at-phase) + protected? + 'phaseless)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'for-meta) ,(m 'phase-level) ,@exp-specs)))))] + [(for-syntax) + (check-nested 'raw) + (define-match m disarmed-spec '(for-syntax spec ...)) + (define-values (track-stxes exp-specs) + (loop (m 'spec) + (phase+ 1 at-phase) + protected? + 'phaseless)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'for-syntax) ,@exp-specs)))))] + [(for-label) + (check-nested 'raw) + (define-match m disarmed-spec '(for-label spec ...)) + (define-values (track-stxes exp-specs) + (loop (m 'spec) + #f + protected? + 'phaseless)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'for-label) ,@exp-specs)))))] + [(protect) + (check-nested 'phaseless) + (when protected? + (raise-syntax-error provide-form-name "nested `protect' not allowed" orig-s spec)) + (define-match m disarmed-spec '(protect p-spec ...)) + (define-values (track-stxes exp-specs) + (loop (m 'p-spec) + at-phase + #t + layer)) + (values null + (list + (syntax-track-origin* + track-stxes + (rebuild + spec + `(,(m 'protect) ,@exp-specs)))))] + [(rename) + (check-nested 'phaseless) + (define-match m disarmed-spec '(rename id:from id:to)) + (parse-identifier! (m 'id:from) orig-s (syntax-e (m 'id:to)) at-phase ns rp protected?) + (values null (list spec))] + [(struct) + (check-nested 'phaseless) + (define-match m disarmed-spec '(struct id:struct (id:field ...))) + (parse-struct! (m 'id:struct) orig-s (m 'id:field) at-phase ns rp protected?) + (values null (list spec))] + [(all-from) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-from mod-path)) + (parse-all-from (m 'mod-path) orig-s self null at-phase ns rp protected? ctx) + (values null (list spec))] + [(all-from-except) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-from-except mod-path id ...)) + (parse-all-from (m 'mod-path) orig-s self (m 'id) at-phase ns rp protected? ctx) + (values null (list spec))] + [(all-defined) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-defined)) + (parse-all-from-module self spec orig-s null #f at-phase ns rp protected?) + (values null (list spec))] + [(all-defined-except) + (check-nested 'phaseless) + (define-match m disarmed-spec '(all-defined-except id ...)) + (parse-all-from-module self spec orig-s (m 'id) #f at-phase ns rp protected?) + (values null (list spec))] + [(prefix-all-defined) + (check-nested 'phaseless) + (define-match m disarmed-spec '(prefix-all-defined id:prefix)) + (parse-all-from-module self spec orig-s null (syntax-e (m 'id:prefix)) at-phase ns rp protected?) + (values null (list spec))] + [(prefix-all-defined-except) + (check-nested 'phaseless) + (define-match m disarmed-spec '(prefix-all-defined-except id:prefix id ...)) + (parse-all-from-module self spec orig-s (m 'id) (syntax-e (m 'id:prefix)) at-phase ns rp protected?) + (values null (list spec))] + [(expand) + (define-match ex-m disarmed-spec '(expand (id . datum))) ; just check syntax + (define-match m disarmed-spec '(expand form)) ; get form to expand + (define exp-spec (expand (m 'form) (struct*-copy expand-context ctx + [stops (free-id-set at-phase (list (core-id 'begin at-phase)))] + ;; Discarding definition-context scopes is ok, + ;; because the scopes won't be captured by + ;; any `quote-syntax`: + [def-ctx-scopes (box null)]))) + (unless (and (pair? (syntax-e exp-spec)) + (identifier? (car (syntax-e exp-spec))) + (eq? 'begin (core-form-sym exp-spec at-phase))) + (raise-syntax-error provide-form-name "expansion was not a `begin' sequence" orig-s spec)) + (define-match e-m exp-spec '(begin spec ...)) + (define-values (track-stxes exp-specs) + (loop (e-m 'spec) + at-phase + protected? + layer)) + (values (list* spec exp-spec track-stxes) + exp-specs)] + [else + (cond + [(identifier? spec) + (parse-identifier! spec orig-s (syntax-e spec) at-phase ns rp protected?) + (values null (list spec))] + [else + (raise-syntax-error provide-form-name "bad syntax" orig-s spec)])]))) + (values (apply append track-stxess) + (apply append exp-specss)))) + +;; ---------------------------------------- + +(define (parse-identifier! spec orig-s sym at-phase ns rp protected?) + (define b (resolve+shift/extra-inspector spec at-phase ns)) + (unless b + (raise-syntax-error provide-form-name "provided identifier is not defined or required" orig-s spec)) + (define as-transformer? (binding-for-transformer? b spec at-phase ns)) + (define immed-b (resolve+shift spec at-phase #:immediate? #t)) + (add-provide! rp sym at-phase b immed-b spec orig-s + #:as-protected? protected? + #:as-transformer? as-transformer?)) + +(define (parse-struct! id:struct orig-s fields at-phase ns rp protected?) + (define (mk fmt) + (define sym (string->symbol (format fmt (syntax-e id:struct)))) + (datum->syntax id:struct sym id:struct)) + (define (mk2 fmt field-id) + (define sym (string->symbol (format fmt + (syntax-e id:struct) + (syntax-e field-id)))) + (datum->syntax id:struct sym id:struct)) + (for ([fmt (in-list (list "~a" + "make-~a" + "struct:~a" + "~a?"))]) + (define id (mk fmt)) + (parse-identifier! id orig-s (syntax-e id) at-phase ns rp protected?)) + (for ([field (in-list fields)]) + (define get-id (mk2 "~a-~a" field)) + (define set-id (mk2 "set-~a-~a!" field)) + (parse-identifier! get-id orig-s (syntax-e get-id) at-phase ns rp protected?) + (parse-identifier! set-id orig-s (syntax-e set-id) at-phase ns rp protected?))) + +(define (parse-all-from mod-path-stx orig-s self except-ids at-phase ns rp protected? ctx) + (define mod-path (syntax->datum mod-path-stx)) + (unless (module-path? mod-path) + (raise-syntax-error provide-form-name "not a module path" orig-s mod-path-stx)) + (define mpi (module-path->mpi/context mod-path ctx)) + (parse-all-from-module mpi #f orig-s except-ids #f at-phase ns rp protected?)) + +(define (parse-all-from-module mpi matching-stx orig-s except-ids prefix-sym at-phase ns rp protected?) + (define requireds (extract-module-requires rp mpi at-phase)) + + (define (phase-desc) (cond + [(zero-phase? at-phase) ""] + [(label-phase? at-phase) " for-label"] + [else (format " for phase ~a" at-phase)])) + (unless requireds + (raise-syntax-error provide-form-name + (format "cannot provide from a module without a matching require~a" + (phase-desc)) + orig-s matching-stx)) + + (define (add-prefix sym) + (if prefix-sym + (string->symbol (format "~a~a" prefix-sym sym)) + sym)) + + (define found (make-hasheq)) + + ;; Register all except excluded bindings: + (for ([i (in-list requireds)]) + (define id (required-id i)) + (define phase (required-phase i)) + (unless (or (and matching-stx + ;; For `(all-defined-out)`, phase and binding context must match: + (not (and (eqv? phase at-phase) + (free-identifier=? id + (datum->syntax matching-stx (syntax-e id)) + phase + phase)))) + (for/or ([except-id (in-list except-ids)]) + (and (free-identifier=? id except-id phase phase) + (hash-set! found except-id #t)))) + (define b (resolve+shift/extra-inspector id phase ns)) + (define immed-b (resolve+shift id phase #:immediate? #t)) + (add-provide! rp (add-prefix (syntax-e id)) phase b immed-b id orig-s + #:as-protected? protected? + #:as-transformer? (required-as-transformer? i)))) + + ;; Check that all exclusions matched something to exclude: + (unless (= (hash-count found) (length except-ids)) + (for ([except-id (in-list except-ids)]) + (unless (or (hash-ref found except-id #f) + (for/or ([i (in-list requireds)]) + (define id (required-id i)) + (define phase (required-phase i)) + (free-identifier=? id except-id phase phase))) + (raise-syntax-error provide-form-name + (format (if matching-stx + "excluded identifier was not defined or required in the module~a" + "excluded identifier was not required from the specified module~a") + (phase-desc)) + orig-s + except-id))))) diff --git a/racket/src/expander/expand/rebuild.rkt b/racket/src/expander/expand/rebuild.rkt new file mode 100644 index 0000000000..13622e2775 --- /dev/null +++ b/racket/src/expander/expand/rebuild.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/taint.rkt") + +(provide rebuild) + +;; A helper for forms to reconstruct syntax while preserving source +;; locations, properties, and arming; if `track?` is #f, then don't keep +;; properties, because we've kept them in a surrounding form +(define (rebuild orig-s new + #:track? [track? #t]) + (syntax-rearm (datum->syntax (syntax-disarm orig-s) new orig-s (and track? orig-s)) + orig-s)) + diff --git a/racket/src/expander/expand/reference-record.rkt b/racket/src/expander/expand/reference-record.rkt new file mode 100644 index 0000000000..4f0ee216b3 --- /dev/null +++ b/racket/src/expander/expand/reference-record.rkt @@ -0,0 +1,55 @@ +#lang racket/base +(require "../common/set.rkt") + +;; A reference record keeps tarck of which bindings in a frame are +;; being referenced and which have been already bound so that a +;; reference doesn't count as a forward reference. This information +;; is needed for expanding internal definitions to break them into +;; suitable `let` and `letrec` sets. + +(provide make-reference-record + reference-record? + reference-record-used! + reference-records-all-used! + reference-record-bound! + reference-record-forward-references? + reference-record-clear!) + +(struct reference-record ([already-bound #:mutable] + [reference-before-bound #:mutable] + [all-referenced? #:mutable]) + #:transparent) + +(define (make-reference-record) + (reference-record (seteq) (seteq) #f)) + +(define (reference-record-used! rr key) + (unless (set-member? (reference-record-already-bound rr) key) + (set-reference-record-reference-before-bound! + rr + (set-add (reference-record-reference-before-bound rr) key)))) + +(define (reference-records-all-used! rrs) + (for ([rr (in-list rrs)] + ;; If a reference record is already marked as all referenced, + ;; then later records must be already marked, too + #:break (reference-record-all-referenced? rr)) + (set-reference-record-all-referenced?! rr #t))) + +(define (reference-record-bound! rr keys) + (set-reference-record-already-bound! + rr + (for/fold ([ab (reference-record-already-bound rr)]) ([key (in-list keys)]) + (set-add ab key ))) + (set-reference-record-reference-before-bound! + rr + (for/fold ([rbb (reference-record-reference-before-bound rr)]) ([key (in-list keys)]) + (set-remove rbb key)))) + +(define (reference-record-forward-references? rr) + (or (reference-record-all-referenced? rr) + (positive? (set-count (reference-record-reference-before-bound rr))))) + +(define (reference-record-clear! rr) + (set-reference-record-already-bound! rr #f) + (set-reference-record-reference-before-bound! rr #f)) diff --git a/racket/src/expander/expand/rename-trans.rkt b/racket/src/expander/expand/rename-trans.rkt new file mode 100644 index 0000000000..f1da731470 --- /dev/null +++ b/racket/src/expander/expand/rename-trans.rkt @@ -0,0 +1,61 @@ +#lang racket/base +(require "../syntax/syntax.rkt") + +(provide rename-transformer? + prop:rename-transformer + make-rename-transformer + rename-transformer-target) + +(define-values (prop:rename-transformer rename-transformer? rename-transformer-value) + (make-struct-type-property 'rename-transformer + (lambda (v info) + (unless (or (exact-nonnegative-integer? v) + (identifier? v) + (and (procedure? v) + (procedure-arity-includes? v 1))) + (raise-argument-error + 'guard-for-prop:rename-transformer + (string-append "(or/c exact-nonnegative-integer?\n" + " identifier?\n" + " (procedure-arity-includes? proc 1))") + v)) + (when (exact-nonnegative-integer? v) + (unless (v . <= . (list-ref info 1)) + (raise-arguments-error 'guard-for-prop:rename-transformer + "field index >= initialized-field count for structure type" + "field index" v + "initialized-field count" (list-ref info 1))) + (unless (member v (list-ref info 5)) + (raise-arguments-error 'guard-for-prop:rename-transformer + "field index not declared immutable" + "field index" v))) + (define ref (list-ref info 3)) + (cond + [(identifier? v) (lambda (t) v)] + [(integer? v) + (lambda (t) + (define val (ref t v)) + (if (identifier? val) + val + (datum->syntax #f '?)))] + [else (lambda (t) + (define id (call-with-continuation-prompt + (lambda () + (v t)))) + (unless (identifier? id) + (raise-arguments-error 'prop:rename-transformer + "contract violation for given value; expected an identifier" + "given" id)) + id)])))) + +(struct id-rename-transformer (id) + #:property prop:rename-transformer 0 + #:reflection-name 'rename-transformer) + +(define (make-rename-transformer id) + (unless (identifier? id) + (raise-argument-error 'make-rename-transformer "identifier?" id)) + (id-rename-transformer id)) + +(define (rename-transformer-target t) + ((rename-transformer-value t) t)) diff --git a/racket/src/expander/expand/require+provide.rkt b/racket/src/expander/expand/require+provide.rkt new file mode 100644 index 0000000000..b398752ef7 --- /dev/null +++ b/racket/src/expander/expand/require+provide.rkt @@ -0,0 +1,487 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/list-ish.rkt" + "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/error.rkt" + "../syntax/bulk-binding.rkt" + "../syntax/mapped-name.rkt" + "../namespace/namespace.rkt" + "../namespace/provided.rkt" + "../common/module-path.rkt" + "../common/module-path-intern.rkt" + "env.rkt") + +(provide make-requires+provides + requires+provides-self + requires+provides-can-cross-phase-persistent? + + requires+provides-all-bindings-simple? + set-requires+provides-all-bindings-simple?! + + (struct-out required) + add-required-module! + add-defined-or-required-id! + add-bulk-required-ids! + add-enclosing-module-defined-and-required! + remove-required-id! + check-not-defined + add-defined-syms! + extract-module-requires + extract-module-definitions + extract-all-module-requires + + requires+provides-reset! + add-provide! + + extract-requires-and-provides + + shift-provides-module-path-index) + +;; ---------------------------------------- + +(struct requires+provides (self ; module-path-index to recognize definitions among requires + require-mpis ; intern table + require-mpis-in-order ; require-phase -> list of module-path-index + requires ; mpi [interned] -> require-phase -> sym -> list-ish of [bulk-]required + provides ; phase -> sym -> binding or protected + phase-to-defined-syms ; phase -> sym -> boolean + [can-cross-phase-persistent? #:mutable] + [all-bindings-simple? #:mutable]) ; tracks whether bindings are easily reconstructed + #:authentic) + +;; A `required` represents an identifier required into a module +(struct required (id phase can-be-shadowed? as-transformer?)) + +;; A `nominal` supports a reverse mapping of bindings to nominal info +(struct nominal (module provide-phase require-phase sym) #:transparent #:authentic) + +;; A `bulk-required` can be converted into a `required` given the +;; module path, phase, and symbol that are mapped to it +(struct bulk-required (provides ; extract binding info based on the sym + prefix-len ; length of a prefix to remove + s ; combine with the sym to create an identifier + provide-phase-level ; phase of `provide` in immediately providing module + can-be-shadowed?) ; shadowed because, e.g., an initial import + #:authentic) + +(define (make-requires+provides self + #:copy-requires [copy-r+p #f]) + (requires+provides self + ;; require-mpis: + (if copy-r+p + (requires+provides-require-mpis copy-r+p) + (make-module-path-index-intern-table)) + ;; require-mpis-in-order: + (if copy-r+p + (hash-copy (requires+provides-require-mpis-in-order copy-r+p)) + (make-hasheqv)) + (make-hasheq) ; requires + (make-hasheqv) ; provides + (make-hasheqv) ; phase-to-defined-syms + #t + #t)) + +(define (requires+provides-reset! r+p) + ;; Don't clear `require-mpis-in-order`, since we want to accumulate + ;; all previously required modules + (hash-clear! (requires+provides-requires r+p)) + (hash-clear! (requires+provides-provides r+p)) + (hash-clear! (requires+provides-phase-to-defined-syms r+p))) + +;; ---------------------------------------- + +(define (intern-mpi r+p mpi) + (intern-module-path-index! (requires+provides-require-mpis r+p) mpi)) + +;; ---------------------------------------- + +;; Register that a module is required at a given phase shift, and return a +;; locally interned module path index +(define (add-required-module! r+p mod-name phase-shift is-cross-phase-persistent?) + (define mpi (intern-mpi r+p mod-name)) + (unless (hash-ref (hash-ref (requires+provides-requires r+p) mpi #hasheqv()) phase-shift #f) + ;; Add to list of requires that are kept in order, so that order + ;; is preserved on instantiation + (hash-update! (requires+provides-require-mpis-in-order r+p) + phase-shift + (lambda (l) (cons mpi l)) + null) + ;; Init list of required identifiers: + (hash-set! (hash-ref! (requires+provides-requires r+p) mpi make-hasheqv) + phase-shift + (make-hasheq))) + (unless is-cross-phase-persistent? + (set-requires+provides-can-cross-phase-persistent?! r+p #f)) + mpi) + +;; Register a specific identifier that is required +(define (add-defined-or-required-id! r+p id phase binding + #:can-be-shadowed? [can-be-shadowed? #f] + #:as-transformer? as-transformer?) + ;; Register specific required identifier + (unless (equal? phase (phase+ (module-binding-nominal-phase binding) + (module-binding-nominal-require-phase binding))) + (error "internal error: binding phase does not match nominal info")) + (add-defined-or-required-id-at-nominal! r+p id phase + #:nominal-module (module-binding-nominal-module binding) + #:nominal-require-phase (module-binding-nominal-require-phase binding) + #:can-be-shadowed? can-be-shadowed? + #:as-transformer? as-transformer?)) + + +;; The internals of `add-defined-or-required-id!` that consumes just +;; the needed part of the binding +(define (add-defined-or-required-id-at-nominal! r+p id phase + #:nominal-module nominal-module + #:nominal-require-phase nominal-require-phase + #:can-be-shadowed? can-be-shadowed? + #:as-transformer? as-transformer?) + (define at-mod (hash-ref! (requires+provides-requires r+p) + (intern-mpi r+p nominal-module) + make-hasheqv)) + (define sym-to-reqds (hash-ref! at-mod nominal-require-phase make-hasheq)) + (define sym (syntax-e id)) + ;; Record that the identifier is required + (hash-set! sym-to-reqds sym (cons-ish (required id phase can-be-shadowed? as-transformer?) + (hash-ref sym-to-reqds sym null)))) + +;; Like `add-defined-or-required-id!`, but faster for bindings that +;; all have the same scope, etc. +(define (add-bulk-required-ids! r+p s self nominal-module phase-shift provides provide-phase-level + #:prefix bulk-prefix + #:excepts bulk-excepts + #:symbols-accum symbols-accum + #:in orig-s + #:can-be-shadowed? can-be-shadowed? + #:check-and-remove? check-and-remove? + #:accum-update-nominals accum-update-nominals + #:who who) + (define phase (phase+ provide-phase-level phase-shift)) + (define shortcut-table (and check-and-remove? + ((hash-count provides) . > . 64) + (syntax-mapped-names s phase))) + (define mpi (intern-mpi r+p nominal-module)) + (define at-mod (hash-ref! (requires+provides-requires r+p) mpi make-hasheqv)) + (define sym-to-reqds (hash-ref! at-mod phase-shift make-hasheq)) + (define prefix-len (if bulk-prefix (string-length (symbol->string bulk-prefix)) 0)) + (define br (bulk-required provides prefix-len s provide-phase-level can-be-shadowed?)) + (for ([(out-sym binding/p) (in-hash provides)]) + (when symbols-accum (hash-set! symbols-accum out-sym #t)) + (unless (hash-ref bulk-excepts out-sym #f) + (define sym (cond + [(not bulk-prefix) out-sym] + [else (string->symbol (format "~a~a" bulk-prefix out-sym))])) + (when (and check-and-remove? + (or (not shortcut-table) + (hash-ref shortcut-table sym #f))) + (check-not-defined #:check-not-required? #t + r+p (datum->syntax s sym s) phase #:in orig-s + #:unless-matches + (lambda () + (provide-binding-to-require-binding binding/p + sym + #:self self + #:mpi mpi + #:provide-phase-level provide-phase-level + #:phase-shift phase-shift)) + #:remove-shadowed!? #t + #:accum-update-nominals accum-update-nominals + #:who who)) + (hash-set! sym-to-reqds sym (cons-ish br (hash-ref sym-to-reqds sym null)))))) + +;; Convert a combination of a symbol and `bulk-required` to a +;; `required` on demand +(define (bulk-required->required br nominal-module phase sym) + (define prefix-len (bulk-required-prefix-len br)) + (define out-sym (if (zero? prefix-len) + sym + (string->symbol (substring (symbol->string sym) prefix-len)))) + (define binding/p (hash-ref (bulk-required-provides br) out-sym)) + (required (datum->syntax (bulk-required-s br) sym) + (phase+ phase (bulk-required-provide-phase-level br)) + (bulk-required-can-be-shadowed? br) + (provided-as-transformer? binding/p))) + +(define (normalize-required r mod-name phase sym) + (if (bulk-required? r) + (bulk-required->required r mod-name phase sym) + r)) + +;; Add bindings of an enclosing module +(define (add-enclosing-module-defined-and-required! r+p + #:enclosing-requires+provides enclosing-r+p + enclosing-mod + phase-shift) + (set-requires+provides-all-bindings-simple?! r+p #f) + (for ([(mod-name at-mod) (in-hash (requires+provides-requires enclosing-r+p))]) + (for* ([(phase at-phase) (in-hash at-mod)] + [(sym reqds) (in-hash at-phase)] + [reqd/maybe-bulk (in-list-ish reqds)]) + (define reqd (normalize-required reqd/maybe-bulk mod-name phase sym)) + (add-defined-or-required-id-at-nominal! r+p + (syntax-shift-phase-level + (syntax-module-path-index-shift + (required-id reqd) + (requires+provides-self enclosing-r+p) + enclosing-mod) + phase-shift) + (phase+ (required-phase reqd) phase-shift) + #:nominal-module enclosing-mod + #:nominal-require-phase phase-shift + #:can-be-shadowed? #t + #:as-transformer? (required-as-transformer? reqd))))) + +;; Removes a required identifier, in anticipation of it being defined. +;; The `check-not-defined` function below is similar, and it also includes +;; an option to remove shadowed bindings. +(define (remove-required-id! r+p id phase #:unless-matches binding) + (define b (resolve+shift id phase #:exactly? #t)) + (when b + (define mpi (intern-mpi r+p (module-binding-nominal-module b))) + (define at-mod (hash-ref (requires+provides-requires r+p) mpi #f)) + (when at-mod + (define nominal-phase (module-binding-nominal-require-phase b)) + (define sym-to-reqds (hash-ref at-mod + nominal-phase + #f)) + (when sym-to-reqds + (define sym (syntax-e id)) + (define l (hash-ref sym-to-reqds sym null)) + (unless (null? l) + (unless (same-binding? b binding) + (hash-set! sym-to-reqds sym (remove-non-matching-requireds l id phase mpi nominal-phase sym)))))))) + +;; Prune a list of `required`s t remove any with a different binding +(define (remove-non-matching-requireds reqds id phase mpi nominal-phase sym) + ;; Ok to produce a list-ish instead of a list, but we don't have `for*/list-ish`: + (for*/list ([r (in-list-ish reqds)] + [r (in-value (normalize-required r mpi nominal-phase sym))] + #:unless (and (eqv? phase (required-phase r)) + (free-identifier=? (required-id r) id phase phase))) + r)) + +;; Check whether an identifier has a binding that is from a non-shadowable +;; require; if something is found but it will be replaced, then record that +;; bindings are not simple. +(define (check-not-defined #:check-not-required? [check-not-required? #f] + r+p id phase #:in orig-s + #:unless-matches [ok-binding/delayed #f] ; binding or (-> binding) + #:remove-shadowed!? [remove-shadowed!? #f] + #:accum-update-nominals [accum-update-nominals #f] + #:who who) + (define b (resolve+shift id phase #:exactly? #t)) + (cond + [(not b) (void)] + [(not (module-binding? b)) + (raise-syntax-error #f "identifier out of context" id)] + [else + (define defined? (and b (eq? (requires+provides-self r+p) + (module-binding-module b)))) + (cond + [(and (not defined?) (not check-not-required?)) + ;; Not defined, and we're shadowing all requires -- so, it's ok, + ;; but binding is non-simple + (set-requires+provides-all-bindings-simple?! r+p #f)] + [(and defined? + ;; In case `#%module-begin` is expanded multiple times, check + ;; that the definition has been seen this particular expansion + (not (hash-ref (hash-ref (requires+provides-phase-to-defined-syms r+p) + phase + #hasheq()) + (module-binding-sym b) + #f))) + ;; Doesn't count as previously defined + (void)] + [else + (define mpi (intern-mpi r+p (module-binding-nominal-module b))) + (define at-mod (hash-ref (requires+provides-requires r+p) mpi #f)) + (define ok-binding (if (procedure? ok-binding/delayed) + (ok-binding/delayed) + ok-binding/delayed)) + (cond + [(not at-mod) + ;; Binding is from an enclosing context; if it's from an + ;; enclosing module, then we've already marked bindings + ;; a non-simple --- otherwise, we don't care + (void)] + [(and ok-binding (same-binding? b ok-binding)) + ;; It's the same binding already, so overall binding hasn't + ;; become non-simple + (unless (same-binding-nominals? b ok-binding) + ;; Need to accumulate nominals + (define (update!) + (add-binding! + #:just-for-nominal? #t + id + (module-binding-update b + #:extra-nominal-bindings + (cons ok-binding + (module-binding-extra-nominal-bindings b))) + phase)) + (cond + [accum-update-nominals + ;; We can't reset now, because the caller is preparing for + ;; a bulk bind. Record that we need to merge nominals. + (set-box! accum-update-nominals (cons update! (unbox accum-update-nominals)))] + [else (update!)]))] + [else + (define nominal-phase (module-binding-nominal-require-phase b)) + (define sym-to-reqds (hash-ref at-mod nominal-phase #hasheq())) + (define reqds (hash-ref sym-to-reqds (syntax-e id) null)) + (for ([r (in-list-ish reqds)]) + (cond + [(if (bulk-required? r) + (bulk-required-can-be-shadowed? r) + (required-can-be-shadowed? r)) + ;; Shadowing --- ok, but non-simple + (set-requires+provides-all-bindings-simple?! r+p #f)] + [else + (raise-syntax-error who + (string-append "identifier already " + (if defined? "defined" "required") + (cond + [(zero-phase? phase) ""] + [(label-phase? phase) " for label"] + [(= 1 phase) " for syntax"] + [else (format " for phase ~a" phase)])) + orig-s + id)])) + (when (and remove-shadowed!? (not (null? reqds))) + ;; Same work as in `remove-required-id!` + (hash-set! sym-to-reqds (syntax-e id) + (remove-non-matching-requireds reqds id phase mpi nominal-phase (syntax-e id))))])])])) + +(define (add-defined-syms! r+p syms phase) + (define phase-to-defined-syms (requires+provides-phase-to-defined-syms r+p)) + (define defined-syms (hash-ref phase-to-defined-syms phase #hasheq())) + (define new-defined-syms + (for/fold ([defined-syms defined-syms]) ([sym (in-list syms)]) + (hash-set defined-syms sym #t))) + (hash-set! phase-to-defined-syms phase new-defined-syms)) + +;; Get all the bindings imported from a given module +(define (extract-module-requires r+p mod-name phase) + (define mpi (intern-mpi r+p mod-name)) + (define at-mod (hash-ref (requires+provides-requires r+p) mpi #f)) + (and at-mod + (for*/list ([(sym reqds) (in-hash (hash-ref at-mod phase #hasheq()))] + [reqd (in-list-ish reqds)]) + (normalize-required reqd mpi phase sym)))) + +;; Get all the definitions +(define (extract-module-definitions r+p) + (or (extract-module-requires r+p (requires+provides-self r+p) 0) + null)) + +;; Like `extract-module-requires`, but merging modules and phases +(define (extract-all-module-requires r+p + mod-name ; or #f for "all" + phase) ; or 'all for "all" + (define self (requires+provides-self r+p)) + (define requires (requires+provides-requires r+p)) + (let/ec esc + (for*/list ([mod-name (in-list (if mod-name + (list (intern-mpi r+p mod-name)) + (hash-keys requires)))] + #:unless (eq? mod-name self) + [phase-to-requireds (in-value (hash-ref requires mod-name #hasheqv()))] + [phase (in-list (if (eq? phase 'all) + (hash-keys phase-to-requireds) + (list phase)))] + [(sym reqds) (in-hash + (hash-ref phase-to-requireds phase + ;; failure => not required at that phase + (lambda () (esc #f))))] + [reqd (in-list-ish reqds)]) + (normalize-required reqd mod-name phase sym)))) + +;; ---------------------------------------- + +;; Register that a binding is provided as a given symbol; report an +;; error if the provide is inconsistent with an earlier one +(define (add-provide! r+p sym phase binding immed-binding id orig-s + #:as-protected? as-protected? + #:as-transformer? as-transformer?) + (when (and as-protected? + (not (eq? (module-binding-module immed-binding) (requires+provides-self r+p)))) + (raise-syntax-error #f "cannot protect required identifier in re-provide" sym)) + (hash-update! (requires+provides-provides r+p) + phase + (lambda (at-phase) + (define b/p (hash-ref at-phase sym #f)) + (define b (provided-as-binding b/p)) + (cond + [(not b) + ;; Record this binding, but first strip away any `free-identifier=?` + ;; identifier that remains, which means that it doesn't have a binding. + ;; The serializer and deserializer won't be able to handle that, and + ;; it's not relevant to further comparisons. + (define plain-binding (if (binding-free=id binding) + (module-binding-update binding #:free=id #f) + binding)) + (hash-set at-phase sym (if (or as-protected? as-transformer?) + (provided plain-binding as-protected? as-transformer?) + plain-binding))] + [(same-binding? b binding) + at-phase] + [else + (raise-syntax-error #f + "identifier already provided (as a different binding)" + orig-s id)])) + #hasheq())) + +;; ---------------------------------------- + +(define (extract-requires-and-provides r+p old-self new-self) + (define (extract-requires) + ;; Extract from the in-order record, so that instantiation can use the original order + (define phase-to-mpis-in-order (requires+provides-require-mpis-in-order r+p)) + (define phases-in-order (sort (hash-keys phase-to-mpis-in-order) phasesym-set (m 'id))) + #f #f 'path)] + [(prefix) + (check-nested 'phaseless) + (define-match m req '(prefix id:prefix spec)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-prefix (syntax-e (m 'id:prefix))) + #f #f 'path)] + [(all-except) + (check-nested 'phaseless) + (define-match m req '(all-except spec id ...)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-all-except '|| (ids->sym-set (m 'id))) + #f #f 'path)] + [(prefix-all-except) + (check-nested 'phaseless) + (define-match m req '(prefix-all-except id:prefix spec id ...)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-all-except (syntax-e (m 'id:prefix)) (ids->sym-set (m 'id))) + #f #f 'path)] + [(rename) + (check-nested 'phaseless) + (define-match m req '(rename spec id:to id:from)) + (loop (list (m 'spec)) + (or top-req req) + phase-shift + just-meta + (adjust-rename (m 'id:to) (syntax-e (m 'id:from))) + #f #f 'path)] + [else + (define maybe-mp (syntax->datum req)) + (unless (or (module-path? maybe-mp) + (resolved-module-path? maybe-mp)) + (raise-syntax-error #f "bad require spec" orig-s req)) + (when (or adjust (not (eq? just-meta 'all))) + (set-requires+provides-all-bindings-simple?! requires+provides #f)) + (define mp (if (resolved-module-path? maybe-mp) + (resolved-module-path->module-path maybe-mp) + maybe-mp)) + (define mpi (module-path->mpi mp self + #:declared-submodule-names declared-submodule-names)) + (perform-require! mpi req self + (or req top-req) m-ns + #:phase-shift phase-shift + #:run-phase run-phase + #:just-meta just-meta + #:adjust adjust + #:requires+provides requires+provides + #:run? run? + #:visit? visit? + #:copy-variable-phase-level copy-variable-phase-level + #:copy-variable-as-constant? copy-variable-as-constant? + #:skip-variable-phase-level skip-variable-phase-level + #:initial-require? initial-require? + #:who who) + (set! initial-require? #f)])))) + +(define (ids->sym-set ids) + (for/set ([id (in-list ids)]) + (syntax-e id))) + +;; ---------------------------------------- + +(define (perform-initial-require! mod-path self + in-stx m-ns + requires+provides + #:bind? bind? + #:who who) + (perform-require! (module-path->mpi mod-path self) #f self + in-stx m-ns + #:phase-shift 0 + #:run-phase 0 + #:requires+provides requires+provides + #:can-be-shadowed? #t + #:initial-require? #t + #:bind? bind? + #:who who)) + +;; ---------------------------------------- + +(define (perform-require! mpi orig-s self + in-stx m-ns + #:phase-shift phase-shift + #:run-phase run-phase + #:just-meta [just-meta 'all] + #:adjust [adjust #f] + #:requires+provides [requires+provides #f] + #:visit? [visit? #t] + #:run? [run? #f] + #:can-be-shadowed? [can-be-shadowed? #f] + #:initial-require? [initial-require? #f] + ;; For `namespace-require/copy` and `namespace-require/constant`: + #:copy-variable-phase-level [copy-variable-phase-level #f] + #:copy-variable-as-constant? [copy-variable-as-constant? #f] + #:skip-variable-phase-level [skip-variable-phase-level #f] + #:bind? [bind? #t] + #:who who) + (performance-region + ['expand 'require] + (define module-name (module-path-index-resolve mpi #t)) + (define bind-in-stx (if (adjust-rename? adjust) + (adjust-rename-to-id adjust) + in-stx)) + (define done-syms (and adjust (make-hash))) + (define m (namespace->module m-ns module-name)) + (unless m (raise-unknown-module-error 'require module-name)) + (define interned-mpi + (if requires+provides + (add-required-module! requires+provides mpi phase-shift + (module-cross-phase-persistent? m)) + mpi)) + (when visit? + (namespace-module-visit! m-ns interned-mpi phase-shift #:visit-phase run-phase)) + (when run? + (namespace-module-instantiate! m-ns interned-mpi phase-shift #:run-phase run-phase)) + (when (not (or visit? run?)) + ;; make the module available: + (namespace-module-make-available! m-ns interned-mpi phase-shift #:visit-phase run-phase)) + (define can-bulk-bind? (and (or (not adjust) + (adjust-prefix? adjust) + (adjust-all-except? adjust)) + (not skip-variable-phase-level))) + (define bulk-prefix (cond + [(adjust-prefix? adjust) (adjust-prefix-sym adjust)] + [(adjust-all-except? adjust) (adjust-all-except-prefix-sym adjust)] + [else #f])) + (define bulk-excepts (cond + [(adjust-all-except? adjust) (adjust-all-except-syms adjust)] + [else #hasheq()])) + (define update-nominals-box (and can-bulk-bind? (box null))) + (bind-all-provides! + m + bind-in-stx phase-shift m-ns interned-mpi module-name + #:in orig-s + #:only (cond + [(adjust-only? adjust) (set->list (adjust-only-syms adjust))] + [(adjust-rename? adjust) (list (adjust-rename-from-sym adjust))] + [else #f]) + #:just-meta just-meta + #:bind? bind? + #:can-bulk? can-bulk-bind? + #:bulk-prefix bulk-prefix + #:bulk-excepts bulk-excepts + #:bulk-callback (and + requires+provides + can-bulk-bind? + (lambda (provides provide-phase-level) + (add-bulk-required-ids! requires+provides + bind-in-stx + (module-self m) mpi phase-shift + provides + provide-phase-level + #:prefix bulk-prefix + #:excepts bulk-excepts + #:symbols-accum (and (positive? (hash-count bulk-excepts)) + done-syms) + #:can-be-shadowed? can-be-shadowed? + #:check-and-remove? (not initial-require?) + #:in orig-s + #:accum-update-nominals update-nominals-box + #:who who))) + #:filter (and + (or (not can-bulk-bind?) + copy-variable-phase-level) + (lambda (binding as-transformer?) + (define sym (module-binding-nominal-sym binding)) + (define provide-phase (module-binding-nominal-phase binding)) + (define adjusted-sym + (cond + [(and skip-variable-phase-level + (not as-transformer?) + (equal? provide-phase skip-variable-phase-level)) + #f] + [(not adjust) sym] + [(adjust-only? adjust) + (and (set-member? (adjust-only-syms adjust) sym) + (hash-set! done-syms sym #t) + sym)] + [(adjust-prefix? adjust) + (string->symbol + (format "~a~a" (adjust-prefix-sym adjust) sym))] + [(adjust-all-except? adjust) + (and (not (and (set-member? (adjust-all-except-syms adjust) sym) + (hash-set! done-syms sym #t))) + (string->symbol + (format "~a~a" (adjust-all-except-prefix-sym adjust) sym)))] + [(adjust-rename? adjust) + (and (eq? sym (adjust-rename-from-sym adjust)) + (hash-set! done-syms sym #t) + (adjust-rename-to-id adjust))])) + (when (and adjusted-sym requires+provides) + (define s (datum->syntax bind-in-stx adjusted-sym)) + (define bind-phase (phase+ phase-shift provide-phase)) + (unless initial-require? + (check-not-defined #:check-not-required? #t + requires+provides + s bind-phase + #:unless-matches binding + #:in orig-s + #:remove-shadowed!? #t + #:who who)) + (add-defined-or-required-id! requires+provides + s bind-phase binding + #:can-be-shadowed? can-be-shadowed? + #:as-transformer? as-transformer?)) + (when (and adjusted-sym + copy-variable-phase-level + (not as-transformer?) + (equal? provide-phase copy-variable-phase-level)) + (copy-namespace-value m-ns adjusted-sym binding copy-variable-phase-level phase-shift + copy-variable-as-constant?)) + adjusted-sym))) + ;; Now that a bulk binding is in place, update to merge nominals: + (when update-nominals-box + (for ([update! (in-list (unbox update-nominals-box))]) + (update!))) + ;; check that we covered all expected ids: + (define need-syms (cond + [(adjust-only? adjust) + (adjust-only-syms adjust)] + [(adjust-all-except? adjust) + (adjust-all-except-syms adjust)] + [(adjust-rename? adjust) + (set (adjust-rename-from-sym adjust))] + [else #f])) + (when (and need-syms + (not (= (set-count need-syms) (hash-count done-syms)))) + (for ([sym (in-set need-syms)]) + (unless (hash-ref done-syms sym #f) + (raise-syntax-error who "not in nested spec" orig-s sym)))))) + +;; ---------------------------------------- + +(define (bind-all-provides! m in-stx phase-shift ns mpi module-name + #:in orig-s + #:only only-syms + #:just-meta just-meta + #:bind? bind? + #:can-bulk? can-bulk? + #:bulk-prefix bulk-prefix + #:bulk-excepts bulk-excepts + #:filter filter + #:bulk-callback bulk-callback) + (define self (module-self m)) + (for ([(provide-phase-level provides) (in-hash (module-provides m))] + #:when (or (eq? just-meta 'all) + (eqv? just-meta provide-phase-level))) + (define phase (phase+ phase-shift provide-phase-level)) + (when bulk-callback + (bulk-callback provides provide-phase-level)) + (when bind? + (when filter + (for ([sym (in-list (or only-syms (hash-keys provides)))]) + (define binding/p (hash-ref provides sym #f)) + (when binding/p + (define b (provide-binding-to-require-binding binding/p sym + #:self self + #:mpi mpi + #:provide-phase-level provide-phase-level + #:phase-shift phase-shift)) + (let-values ([(sym) (filter b (provided-as-transformer? binding/p))]) + (when (and sym + (not can-bulk?)) ;; bulk binding added later + ;; Add a non-bulk binding, since `filter` has checked/adjusted it + (add-binding! (datum->syntax in-stx sym) b phase)))))) + ;; Add bulk binding after all filtering + (when can-bulk? + (define bulk-binding-registry (namespace-bulk-binding-registry ns)) + (add-bulk-binding! in-stx + (bulk-binding (or (and (not bulk-prefix) + (zero? (hash-count bulk-excepts)) + provides) + ;; During expansion, the submodules aren't be registered in + ;; the bulk-binding registry for use by other submodules, + ;; so do the work to compute bulk provides now if the module + ;; isn't registered + (and (not (registered-bulk-provide? bulk-binding-registry + module-name)) + (bulk-provides-add-prefix-remove-exceptions + provides bulk-prefix bulk-excepts))) + bulk-prefix bulk-excepts + self mpi provide-phase-level phase-shift + bulk-binding-registry) + phase + #:in orig-s))))) + +;; ---------------------------------------- + +;; In certain lifting cases, we'd like to just throw a `for-syntax` +;; around a `require` specification, but that's not supported by our +;; `#%require` grammar. Instead, we have to adjust whatever phase +;; shift is present. +(define (require-spec-shift-for-syntax req) + (define (rebuild-req req new-req) + (datum->syntax req new-req req req)) + (define ((loop shifted?) req) + (define fm (and (pair? (syntax-e req)) + (identifier? (car (syntax-e req))) + (syntax-e (car (syntax-e req))))) + (case fm + [(for-meta) + (define-match m req '(for-meta phase-level spec ...)) + (define p (syntax-e (m 'phase-level))) + (unless (phase? p) + (raise-syntax-error #f "bad phase" req)) + (rebuild-req req `(,(m 'for-meta) ,(phase+ p 1) ,@(map (loop #t) (m 'spec))))] + [(for-syntax) + (define-match m req '(for-syntax spec ...)) + (rebuild-req req `(for-meta 2 ,@(map (loop #t) (m 'spec))))] + [(for-template) + (define-match m req '(for-template spec ...)) + (rebuild-req req `(for-meta 0 ,@(map (loop #t) (m 'spec))))] + [(for-label) + (define-match m req '(for-label spec ...)) + (rebuild-req req `(,(m 'for-label) ,@(map (loop #t) (m 'spec))))] + [(just-meta) + (define-match m req '(just-meta phase-level spec ...)) + (rebuild-req req `(,(m 'just-meta) ,(m 'phase-level) ,@(map (loop #f) (m 'spec))))] + [else + (if shifted? + req + (datum->syntax #f `(for-syntax ,req)))])) + ((loop #f) req)) + +;; ---------------------------------------- + +(define (copy-namespace-value m-ns adjusted-sym binding phase-level phase-shift as-constant?) + (define i-ns (namespace->module-namespace m-ns + (module-path-index-resolve (module-binding-module binding)) + (phase- (module-binding-phase binding) phase-level) + #:complain-on-failure? #t)) + (define val (namespace-get-variable i-ns (module-binding-phase binding) (module-binding-sym binding) + (lambda () (error 'namespace-require/copy + (format + (string-append "namespace mismatch;\n" + " variable not found\n" + " module: ~a\n" + " variable name: ~s\n" + " phase level: ~s") + (module-binding-module binding) + (module-binding-sym binding) + (module-binding-phase binding)))))) + (namespace-set-variable! m-ns (phase+ phase-shift phase-level) adjusted-sym val as-constant?)) diff --git a/racket/src/expander/expand/root-expand-context.rkt b/racket/src/expander/expand/root-expand-context.rkt new file mode 100644 index 0000000000..8d5dc948f2 --- /dev/null +++ b/racket/src/expander/expand/root-expand-context.rkt @@ -0,0 +1,115 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../common/phase.rkt" + "lift-key.rkt") + +(provide (struct*-out root-expand-context) + make-root-expand-context + + root-expand-context-encode-for-module + root-expand-context-decode-for-module) + +;; A `root-expand-context` is a subset of `expand-context` that is +;; preserved from a module's expansion for later use in a namespace +;; generated by `module->namespace` --- or preserved across different +;; expansions at the top level +(struct* root-expand-context + (module-scopes ; list of scopes for enclosing module or top level; includes next two fields + * post-expansion-scope ; #f or scope to add to every expansion; often module's inside edge + top-level-bind-scope ; #f or a scope to constrain expansion bindings; see "expand-bind-top.rkt" + all-scopes-stx ; scopes like the initial import, which correspond to original forms + * use-site-scopes ; #f or boxed list: scopes that should be pruned from binders + defined-syms ; phase -> sym -> id; symbols picked for bindings + * frame-id ; #f or a gensym to identify a binding frame; 'all matches any for use-site scopes + counter ; box of an integer; used for generating names deterministically + lift-key ; identifies (via `syntax-local-lift-context`) a target for lifts + )) ; after adding a field, update `copy-module-context` in "context.rkt" + +(define (make-root-expand-context #:initial-scopes [initial-scopes null] + #:outside-scope [outside-scope top-level-common-scope] + #:post-expansion-scope [post-expansion-scope (new-multi-scope 'top-level)] + #:all-scopes-stx [all-scopes-stx #f]) + (define module-scopes (list* post-expansion-scope + outside-scope + initial-scopes)) + (root-expand-context module-scopes + post-expansion-scope + (new-scope 'module) ; top-level-bind-scope + (or all-scopes-stx + (add-scopes empty-syntax module-scopes)) + (box null) ; use-site-scopes + (make-hasheqv) ; defined-syms + (string->uninterned-symbol "root-frame") ; frame-id + (box 0) ; counter + (generate-lift-key))) + +;; ---------------------------------------- + +;; Encode information in a syntax object that can be serialized and deserialized +(define (root-expand-context-encode-for-module ctx orig-self new-self) + (datum->syntax + #f + (vector (add-scopes empty-syntax (root-expand-context-module-scopes ctx)) + (add-scope empty-syntax (root-expand-context-post-expansion-scope ctx)) + (syntax-module-path-index-shift (root-expand-context-all-scopes-stx ctx) orig-self new-self) + (add-scopes empty-syntax (unbox (root-expand-context-use-site-scopes ctx))) + (for/hasheqv ([(phase ht) (in-hash (root-expand-context-defined-syms ctx))]) ; make immutable + (values phase ht)) + (root-expand-context-frame-id ctx) + (unbox (root-expand-context-counter ctx))))) + +;; Encode information in a syntax object that can be serialized and deserialized +(define (root-expand-context-decode-for-module vec-s) + (define vec (and (syntax? vec-s) (syntax-e vec-s))) + (unless (and (vector? vec) + (= (vector-length vec) 7) + (syntax? (vector-ref vec 0)) + (syntax-with-one-scope? (vector-ref vec 1)) + (syntax? (vector-ref vec 2)) + (syntax? (vector-ref vec 3)) + (defined-syms-hash? (syntax-e (vector-ref vec 4))) + (symbol? (syntax-e (vector-ref vec 5))) + (exact-nonnegative-integer? (syntax-e (vector-ref vec 6)))) + (error 'root-expand-context-decode-for-module + "bad encoding: ~s" + vec-s)) + (root-expand-context (extract-scope-list (vector-ref vec 0)) ; module-scopes + (extract-scope (vector-ref vec 1)) ; post-expansion-scope + (new-scope 'module) ; top-level-bind-scope + (vector-ref vec 2) ; all-scopes-stx + (box (extract-scope-list (vector-ref vec 3))) ; use-site-scopes + (unpack-defined-syms (vector-ref vec 4)) ; defined-syms + (syntax-e (vector-ref vec 5)) ; frame-id + (box (syntax-e (vector-ref vec 6))) ; counter + (generate-lift-key))) + +(define (defined-syms-hash? v) + (and (for/and ([(phase ht-s) (in-hash v)]) + (and (phase? phase) + (hash? (syntax-e ht-s)) + (for/and ([(sym id) (in-hash (syntax-e ht-s))]) + (and (symbol? sym) + (identifier? id))))))) + +(define (extract-scope-list stx) + (map generalize-scope (set->list (syntax-scope-set stx 0)))) + +(define (syntax-with-one-scope? stx) + (and (syntax? stx) + (= 1 (set-count (syntax-scope-set stx 0))))) + +(define (extract-scope stx) + (define s (syntax-scope-set stx 0)) + (generalize-scope (set-first s))) + +(define (unpack-defined-syms v) + (hash-copy ; make mutable + (for/hasheqv ([(phase ht-s) (in-hash (syntax-e v))]) + (values phase + (hash-copy ; make mutable + (for/hash ([(sym id) (in-hash (syntax-e ht-s))]) + (values sym id))))))) diff --git a/racket/src/expander/expand/save-and-restore.rkt b/racket/src/expander/expand/save-and-restore.rkt new file mode 100644 index 0000000000..7fba67e7cd --- /dev/null +++ b/racket/src/expander/expand/save-and-restore.rkt @@ -0,0 +1,18 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide with-save-and-restore) + +(define-syntax (with-save-and-restore stx) + (syntax-case stx () + [(_ ([id init-val] ...) body0 body ...) + (with-syntax ([(old-id ...) (generate-temporaries #'(id ...))] + [(new-id ...) (generate-temporaries #'(id ...))]) + #'(let ([old-id id] ... + [new-id init-val] ...) + (dynamic-wind + (lambda () (set! id new-id) ...) + (lambda () body0 body ...) + (lambda () (set! id old-id) ...))))])) + + diff --git a/racket/src/expander/expand/set-bang-trans.rkt b/racket/src/expander/expand/set-bang-trans.rkt new file mode 100644 index 0000000000..e4a73238b7 --- /dev/null +++ b/racket/src/expander/expand/set-bang-trans.rkt @@ -0,0 +1,57 @@ +#lang racket/base + +(provide set!-transformer? + prop:set!-transformer + make-set!-transformer + set!-transformer-procedure) + +(define-values (prop:set!-transformer set!-transformer? set!-transformer-value) + (make-struct-type-property 'set!-transformer + (lambda (v info) + (unless (or (and (procedure? v) + (or (procedure-arity-includes? v 1) + (procedure-arity-includes? v 2))) + (exact-nonnegative-integer? v)) + (raise-argument-error + 'guard-for-prop:set!-transformer + (string-append "(or/c (procedure-arity-includes? proc 1)\n" + " (procedure-arity-includes? proc 2)\n" + " exact-nonnegative-integer?)") + v)) + (when (exact-nonnegative-integer? v) + (unless (v . <= . (list-ref info 1)) + (raise-arguments-error 'guard-for-prop:set!-transformer + "field index >= initialized-field count for structure type" + "field index" v + "initialized-field count" (list-ref info 1))) + (unless (member v (list-ref info 5)) + (raise-arguments-error 'guard-for-prop:set!-transformer + "field index not declared immutable" + "field index" v))) + (define ref (list-ref info 3)) + (cond + [(integer? v) (lambda (t) + (define p (ref t v)) + (if (and (procedure? p) + (procedure-arity-includes? p 1)) + p + (lambda (s) (error "bad syntax:" s))))] + [else (lambda (t) v)])))) + +(define make-set!-transformer + (let () + (struct set!-transformer (proc) + #:property prop:set!-transformer 0) + (lambda (proc) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 1)) + (raise-argument-error 'make-set!-transformer + "(procedure-arity-includes/c 1)" + proc)) + (set!-transformer proc)))) + +(define (set!-transformer-procedure t) + (define v ((set!-transformer-value t) t)) + (if (procedure-arity-includes? v 1) + v + (lambda (s) (v t s)))) diff --git a/racket/src/expander/expand/stop-ids.rkt b/racket/src/expander/expand/stop-ids.rkt new file mode 100644 index 0000000000..8bd154c071 --- /dev/null +++ b/racket/src/expander/expand/stop-ids.rkt @@ -0,0 +1,42 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../namespace/core.rkt") + +(provide stop-ids->all-stop-ids + module-expand-stop-ids) + +;; ---------------------------------------- + +(define (stop-ids->all-stop-ids stop-ids phase) + (cond + [(null? stop-ids) stop-ids] + [else + (define p-core-stx (syntax-shift-phase-level core-stx phase)) + (cond + [(and (= 1 (length stop-ids)) + (free-identifier=? (car stop-ids) + (datum->syntax p-core-stx 'module*) + phase + phase)) + stop-ids] + [else (append stop-ids + (for/list ([sym (in-list auto-stop-syms)]) + (datum->syntax p-core-stx sym)))])])) + +(define auto-stop-syms '(begin quote set! lambda case-lambda let-values letrec-values + if begin0 with-continuation-mark letrec-syntaxes+values + #%app #%expression #%top #%variable-reference)) + +;; ---------------------------------------- + +(define (module-expand-stop-ids phase) + (define p-core-stx (syntax-shift-phase-level core-stx phase)) + (for/list ([sym (in-list module-stop-syms)]) + (datum->syntax p-core-stx sym))) + +(define module-stop-syms (append auto-stop-syms + '(define-values define-syntaxes begin-for-syntax + #%require #%provide module module* #%declare + #%stratified-body))) diff --git a/racket/src/expander/expand/syntax-id-error.rkt b/racket/src/expander/expand/syntax-id-error.rkt new file mode 100644 index 0000000000..5317ce87c3 --- /dev/null +++ b/racket/src/expander/expand/syntax-id-error.rkt @@ -0,0 +1,107 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/error.rkt" + "context.rkt" + "../syntax/debug.rkt") + +(provide raise-ambiguous-error + syntax-debug-info-string) + +(define (raise-ambiguous-error id ctx) + (raise-syntax-error #f + "identifier's binding is ambiguous" + id #f null + (syntax-debug-info-string id ctx))) + +;; ---------------------------------------- + +(define (syntax-debug-info-string s ctx) + (define info (syntax-debug-info s (expand-context-phase ctx) #t)) + (cond + [(not (or (pair? (hash-ref info 'bindings null)) + (for*/or ([fb-info (in-list (hash-ref info 'fallbacks null))]) + (pair? (hash-ref fb-info 'bindings null))))) + ;; Don't show context if there's no binding to compare it to + ""] + [else + (define relevant-scope-sets + (let loop ([info info] [layer 0]) + (apply + append + (cons (hash-ref info 'context) + (for/list ([b (in-list (hash-ref info 'bindings null))]) + (hash-ref b 'context))) + (let ([fallbacks (hash-ref info 'fallbacks null)]) + (for/list ([fallback (in-list fallbacks)] + [layer (in-naturals (add1 layer))]) + (loop fallback layer)))))) + (define common-scopes + (if (null? relevant-scope-sets) + (set) + (for/fold ([s (list->set (car relevant-scope-sets))]) ([l (in-list relevant-scope-sets)]) + (set-intersect s (list->set l))))) + (string-append + (let loop ([info info] [layer 0]) + (string-append + "\n context" (layer->string layer) "...:" + (describe-context (hash-ref info 'context) common-scopes) + (apply string-append + (for/list ([b (in-list (sort (hash-ref info 'bindings null) + ;; Order matches before non-matches: + (lambda (a b) + (and (hash-ref a 'match? #f) + (not (hash-ref b 'match? #f))))))]) + (string-append + "\n " (if (hash-ref b 'match? #f) "matching" "other") " binding" (layer->string layer) "...:" + "\n " (if (hash-ref b 'local #f) + "local" + (format "~a" (hash-ref b 'module #f))) + (describe-context (hash-ref b 'context) common-scopes)))) + (let ([fallbacks (hash-ref info 'fallbacks null)]) + (apply + string-append + (for/list ([fallback (in-list fallbacks)] + [layer (in-naturals (add1 layer))]) + (loop fallback layer)))))) + (if (set-empty? common-scopes) + "" + (string-append + "\n common scopes...:" + ;; Get scopes from the original context to keep them in the right order + (describe-context (for/list ([s (in-list (hash-ref info 'context))] + #:when (set-member? common-scopes s)) + s) + (set)))))])) + +(define (describe-context scopes common-scopes) + (define strs + (let loop ([strs null] [scopes (if (set-empty? common-scopes) + scopes + (append + (for/list ([s (in-list scopes)] + #:when (not (set-member? common-scopes s))) + s) + (list "[common scopes]")))]) + (cond + [(null? scopes) (reverse strs)] + [else + (define str (format " ~a" (car scopes))) + (if (and (pair? strs) + ((+ (string-length str) (string-length (car strs))) . < . 72)) + (loop (cons (string-append (car strs) str) + (cdr strs)) + (cdr scopes)) + (loop (cons str strs) + (cdr scopes)))]))) + (cond + [(null? strs) "\n [empty]"] + [else + (apply string-append (for/list ([str (in-list strs)]) + (string-append "\n " str)))])) + +(define (layer->string layer) + (if (zero? layer) + "" + (format " at layer ~a" layer))) diff --git a/racket/src/expander/expand/syntax-implicit-error.rkt b/racket/src/expander/expand/syntax-implicit-error.rkt new file mode 100644 index 0000000000..62fe7676f0 --- /dev/null +++ b/racket/src/expander/expand/syntax-implicit-error.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require "../syntax/error.rkt" + "../syntax/scope.rkt" + "context.rkt" + "syntax-id-error.rkt") + +(provide raise-syntax-implicit-error) + +(define (raise-syntax-implicit-error s sym trigger-id ctx) + (define phase (expand-context-phase ctx)) + (define what + (case sym + [(#%app) "function application"] + [(#%datum) "literal data"] + [(#%top) + (if (expand-context-allow-unbound? ctx) + "reference to a top-level identifier" + "reference to an unbound identifier")])) + (define unbound? (and trigger-id (not (resolve trigger-id phase)))) + (raise-syntax-error #f + (format (if unbound? + "unbound identifier;\n also, no ~a transformer is bound~a" + (string-append what " is not allowed;\n no ~a syntax transformer is bound~a")) + sym + (case phase + [(0) ""] + [(1) " in the transformer phase"] + [else (format " at phase ~a" phase)])) + (and unbound? trigger-id) + (and unbound? + (not (eq? (syntax-e s) (syntax-e trigger-id))) + s) + null + (if unbound? (syntax-debug-info-string trigger-id ctx) ""))) diff --git a/racket/src/expander/expand/syntax-local.rkt b/racket/src/expander/expand/syntax-local.rkt new file mode 100644 index 0000000000..9e8e1b5442 --- /dev/null +++ b/racket/src/expander/expand/syntax-local.rkt @@ -0,0 +1,436 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/struct-star.rkt" + "../syntax/syntax.rkt" + "../common/phase.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../syntax/taint.rkt" + "env.rkt" + "context.rkt" + "main.rkt" + "../namespace/core.rkt" + "use-site.rkt" + "rename-trans.rkt" + "lift-context.rkt" + "require.rkt" + "require+provide.rkt" + "protect.rkt" + "log.rkt" + "module-path.rkt" + "definition-context.rkt" + "../common/module-path.rkt" + "../namespace/namespace.rkt" + "../namespace/module.rkt" + "../common/contract.rkt") + +(provide syntax-transforming? + syntax-transforming-with-lifts? + syntax-transforming-module-expression? + syntax-local-transforming-module-provides? + + syntax-local-context + syntax-local-introduce + syntax-local-identifier-as-binding + syntax-local-phase-level + syntax-local-name + + make-syntax-introducer + make-syntax-delta-introducer + + syntax-local-value + syntax-local-value/immediate + + syntax-local-lift-expression + syntax-local-lift-values-expression + syntax-local-lift-context + + syntax-local-lift-module + + syntax-local-lift-require + syntax-local-lift-provide + syntax-local-lift-module-end-declaration + + syntax-local-module-defined-identifiers + syntax-local-module-required-identifiers + syntax-local-module-exports + syntax-local-submodules + + syntax-local-get-shadower) + +;; ---------------------------------------- + +(define (syntax-transforming?) + (and (get-current-expand-context #:fail-ok? #t) #t)) + +(define (syntax-transforming-with-lifts?) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (and ctx + (expand-context-lifts ctx) + #t)) + +(define (syntax-transforming-module-expression?) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (and ctx + (expand-context-to-module-lifts ctx) + #t)) + +(define (syntax-local-transforming-module-provides?) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (and ctx + (expand-context-requires+provides ctx) + #t)) + +;; ---------------------------------------- + +(define (syntax-local-context) + (define ctx (get-current-expand-context 'syntax-local-context)) + (expand-context-context ctx)) + +(define (syntax-local-introduce s) + (check 'syntax-local-introduce syntax? s) + (define ctx (get-current-expand-context 'syntax-local-introduce)) + (flip-introduction-scopes s ctx)) + +(define (syntax-local-identifier-as-binding id) + (check syntax-local-identifier-as-binding identifier? id) + (define ctx (get-current-expand-context 'syntax-local-identifier-as-binding)) + (remove-use-site-scopes id ctx)) + +(define (syntax-local-phase-level) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (if ctx + (expand-context-phase ctx) + 0)) + +(define (syntax-local-name) + (define ctx (get-current-expand-context 'syntax-local-name)) + (define id (expand-context-name ctx)) + (and id + ;; Strip lexical context, but keep source-location information + (datum->syntax #f (syntax-e id) id))) + +;; ---------------------------------------- + +(define (make-syntax-introducer [as-use-site? #f]) + (define sc (new-scope (if as-use-site? 'use-site 'macro))) + (lambda (s [mode 'flip]) + (check 'syntax-introducer syntax? s) + (case mode + [(add) (add-scope s sc)] + [(remove) (remove-scope s sc)] + [(flip) (flip-scope s sc)] + [else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)]))) + +(define (make-syntax-delta-introducer ext-s base-s [phase (syntax-local-phase-level)]) + (check 'make-syntax-delta-introducer syntax? ext-s) + (unless (or (syntax? base-s) (not base-s)) + (raise-argument-error 'make-syntax-delta-introducer "(or/c syntax? #f)" base-s)) + (unless (phase? phase) + (raise-argument-error 'make-syntax-delta-introducer phase?-string phase)) + (define ext-scs (syntax-scope-set ext-s phase)) + (define base-scs (syntax-scope-set (or base-s empty-syntax) phase)) + (define use-base-scs (if (subset? base-scs ext-scs) + base-scs + (or (and (identifier? base-s) + (resolve base-s phase #:get-scopes? #t)) + (seteq)))) + (define delta-scs (set->list (set-subtract ext-scs use-base-scs))) + (define maybe-taint (if (syntax-clean? ext-s) values syntax-taint)) + (lambda (s [mode 'add]) + (maybe-taint + (case mode + [(add) (add-scopes s delta-scs)] + [(remove) (remove-scopes s delta-scs)] + [(flip) (flip-scopes s delta-scs)] + [else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)])))) + +;; ---------------------------------------- + +(define (do-syntax-local-value who id intdef failure-thunk + #:immediate? immediate?) + (check who identifier? id) + (unless (or (not failure-thunk) + (and (procedure? failure-thunk) + (procedure-arity-includes? failure-thunk 0))) + (raise-argument-error who + "(or #f (procedure-arity-includes/c 0))" + failure-thunk)) + (unless (or (not intdef) + (internal-definition-context? intdef)) + (raise-argument-error who + "(or #f internal-definition-context?)" + failure-thunk)) + (define current-ctx (get-current-expand-context who)) + (define ctx (if intdef + (struct*-copy expand-context current-ctx + [env (add-intdef-bindings (expand-context-env current-ctx) + intdef)]) + current-ctx)) + (log-expand ctx 'local-value id) + (define phase (expand-context-phase ctx)) + (let loop ([id (flip-introduction-scopes id ctx)]) + (define b (if immediate? + (resolve+shift id phase #:immediate? #t) + (resolve+shift/extra-inspector id phase (expand-context-namespace ctx)))) + (log-expand ctx 'resolve id) + (cond + [(not b) + (log-expand ctx 'local-value-result #f) + (if failure-thunk + (failure-thunk) + (error 'syntax-local-value "unbound identifier: ~v" id))] + [else + (define-values (v primitive? insp) (lookup b ctx id #:out-of-context-as-variable? #t)) + (cond + [(or (variable? v) (core-form? v)) + (log-expand ctx 'local-value-result #f) + (if failure-thunk + (failure-thunk) + (error 'syntax-local-value "identifier is not bound to syntax: ~v" id))] + [else + (log-expand* ctx #:unless (and (rename-transformer? v) (not immediate?)) + ['local-value-result #t]) + (cond + [(rename-transformer? v) + (if immediate? + (values v (rename-transformer-target v)) + (loop (rename-transformer-target v)))] + [immediate? (values v #f)] + [else v])])]))) + +(define (syntax-local-value id [failure-thunk #f] [intdef #f]) + (do-syntax-local-value 'syntax-local-value #:immediate? #f id intdef failure-thunk)) + +(define (syntax-local-value/immediate id [failure-thunk #f] [intdef #f]) + (do-syntax-local-value 'syntax-local-value/immediate #:immediate? #t id intdef failure-thunk)) + +;; ---------------------------------------- + +(define (do-lift-values-expression who n s) + (check who syntax? s) + (check who exact-nonnegative-integer? n) + (define ctx (get-current-expand-context who)) + (define lifts (expand-context-lifts ctx)) + (unless lifts (raise-arguments-error who "no lift target")) + (define counter (root-expand-context-counter ctx)) + (define ids (for/list ([i (in-range n)]) + (set-box! counter (add1 (unbox counter))) + (define name (string->unreadable-symbol (format "lifted/~a" (unbox counter)))) + (add-scope (datum->syntax #f name) (new-scope 'macro)))) + (log-expand ctx 'local-lift ids s) + (map (lambda (id) (flip-introduction-scopes id ctx)) + ;; returns converted ids: + (add-lifted! lifts + ids + (flip-introduction-scopes s ctx) + (expand-context-phase ctx)))) + +(define (syntax-local-lift-expression s) + (car (do-lift-values-expression 'syntax-local-lift-expression 1 s))) + +(define (syntax-local-lift-values-expression n s) + (do-lift-values-expression 'syntax-local-lift-values-expression n s)) + +(define (syntax-local-lift-context) + (define ctx (get-current-expand-context 'syntax-local-lift-context)) + (root-expand-context-lift-key ctx)) + +;; ---------------------------------------- + +(define (syntax-local-lift-module s) + (check 'syntax-local-lift-module syntax? s) + (define ctx (get-current-expand-context 'syntax-local-lift-module)) + (define phase (expand-context-phase ctx)) + (case (core-form-sym s phase) + [(module module*) + (define lifts (expand-context-module-lifts ctx)) + (unless lifts + (raise-arguments-error 'syntax-local-lift-module + "not currently transforming within a module declaration or top level" + "form to lift" s)) + (add-lifted-module! lifts (flip-introduction-scopes s ctx) phase)] + [else + (raise-arguments-error 'syntax-local-lift-module "not a module form" + "given form" s)]) + (log-expand ctx 'lift-statement s)) + +;; ---------------------------------------- + +(define (do-local-lift-to-module who s + #:no-target-msg no-target-msg + #:intro? [intro? #t] + #:more-checks [more-checks void] + #:get-lift-ctx get-lift-ctx + #:add-lifted! add-lifted! + #:get-wrt-phase get-wrt-phase + #:pre-wrap [pre-wrap (lambda (s phase lift-ctx) s)] + #:shift-wrap [shift-wrap (lambda (s phase lift-ctx) s)] + #:post-wrap [post-wrap (lambda (s phase lift-ctx) s)]) + (check who syntax? s) + (more-checks) + (define ctx (get-current-expand-context who)) + (define lift-ctx (get-lift-ctx ctx)) + (unless lift-ctx (raise-arguments-error who no-target-msg + "form to lift" s)) + (define phase (expand-context-phase ctx)) ; we're currently at this phase + (define wrt-phase (get-wrt-phase lift-ctx)) ; lift context is at this phase + (define added-s (if intro? (flip-introduction-scopes s ctx) s)) + (define pre-s (pre-wrap added-s phase lift-ctx)) ; add pre-wrap at current phase + (define shift-s (for/fold ([s pre-s]) ([phase (in-range phase wrt-phase -1)]) ; shift from lift-context phase + (shift-wrap s (sub1 phase) lift-ctx))) + (define post-s (post-wrap shift-s wrt-phase lift-ctx)) ; post-wrap at lift-context phase + (add-lifted! lift-ctx post-s wrt-phase) ; record lift for the target phase + (values ctx post-s)) + +(define (syntax-local-lift-require s use-s) + (define sc (new-scope 'macro)) + (define-values (ctx added-s) + (do-local-lift-to-module 'syntax-local-lift-require + (datum->syntax #f s) + #:no-target-msg "could not find target context" + #:intro? #f + #:more-checks + (lambda () + (check 'syntax-local-lift-require + syntax? + use-s)) + #:get-lift-ctx expand-context-require-lifts + #:get-wrt-phase require-lift-context-wrt-phase + #:add-lifted! add-lifted-require! + #:shift-wrap + (lambda (s phase require-lift-ctx) + (require-spec-shift-for-syntax s)) + #:post-wrap + (lambda (s phase require-lift-ctx) + (wrap-form '#%require (add-scope s sc) phase)))) + (namespace-visit-available-modules! (expand-context-namespace ctx) + (expand-context-phase ctx)) + (define result-s (add-scope use-s sc)) + (log-expand ctx 'lift-require added-s use-s result-s) + result-s) + +(define (syntax-local-lift-provide s) + (define-values (ctx result-s) + (do-local-lift-to-module 'syntax-local-lift-provide + s + #:no-target-msg "not expanding in a module run-time body" + #:get-lift-ctx expand-context-to-module-lifts + #:get-wrt-phase to-module-lift-context-wrt-phase + #:add-lifted! add-lifted-to-module-provide! + #:shift-wrap + (lambda (s phase to-module-lift-ctx) + (wrap-form 'for-syntax s #f)) + #:post-wrap + (lambda (s phase to-module-lift-ctx) + (wrap-form '#%provide s phase)))) + (log-expand ctx 'lift-provide result-s)) + +(define (syntax-local-lift-module-end-declaration s) + (define-values (ctx also-s) + (do-local-lift-to-module 'syntax-local-lift-module-end-declaration + s + #:no-target-msg "not currently transforming an expression within a module declaration" + #:get-lift-ctx expand-context-to-module-lifts + #:get-wrt-phase (lambda (lift-ctx) 0) ; always relative to 0 + #:add-lifted! add-lifted-to-module-end! + #:pre-wrap + (lambda (orig-s phase to-module-lift-ctx) + (if (to-module-lift-context-end-as-expressions? to-module-lift-ctx) + (wrap-form '#%expression orig-s phase) + orig-s)) + #:shift-wrap + (lambda (s phase to-module-lift-ctx) + (wrap-form 'begin-for-syntax s phase)))) + (log-expand ctx 'lift-statement s)) + +(define (wrap-form sym s phase) + (datum->syntax + #f + (list (datum->syntax + (if phase + (syntax-shift-phase-level core-stx phase) + #f) + sym) + s))) + +;; ---------------------------------------- + +(define (syntax-local-module-defined-identifiers) + (unless (syntax-local-transforming-module-provides?) + (raise-arguments-error 'syntax-local-module-defined-identifiers "not currently transforming module provides")) + (define ctx (get-current-expand-context 'syntax-local-module-defined-identifiers)) + (requireds->phase-ht (extract-module-definitions (expand-context-requires+provides ctx)))) + + +(define (syntax-local-module-required-identifiers mod-path phase-level) + (unless (or (not mod-path) (module-path? mod-path)) + (raise-argument-error 'syntax-local-module-required-identifiers "(or/c module-path? #f)" mod-path)) + (unless (or (eq? phase-level #t) (phase? phase-level)) + (raise-argument-error 'syntax-local-module-required-identifiers (format "(or/c ~a #t)" phase?-string) phase-level)) + (unless (syntax-local-transforming-module-provides?) + (raise-arguments-error 'syntax-local-module-required-identifiers "not currently transforming module provides")) + (define ctx (get-current-expand-context 'syntax-local-module-required-identifiers)) + (define requires+provides (expand-context-requires+provides ctx)) + (define mpi (and mod-path + (module-path->mpi/context mod-path ctx))) + (define requireds + (extract-all-module-requires requires+provides + mpi + (if (eq? phase-level #t) 'all phase-level))) + (and requireds + (for/list ([(phase ids) (in-hash (requireds->phase-ht requireds))]) + (cons phase ids)))) + +(define (requireds->phase-ht requireds) + (for/fold ([ht (hasheqv)]) ([r (in-list requireds)]) + (hash-update ht + (required-phase r) + (lambda (l) (cons (required-id r) l)) + null))) + +;; ---------------------------------------- + +(define (syntax-local-module-exports mod-path) + (unless (or (module-path? mod-path) + (and (syntax? mod-path) + (module-path? (syntax->datum mod-path)))) + (raise-argument-error 'syntax-local-module-exports + (string-append + "(or/c module-path?\n" + " (and/c syntax?\n" + " (lambda (stx)\n" + " (module-path? (syntax->datum stx)))))") + mod-path)) + (define ctx (get-current-expand-context 'syntax-local-module-exports)) + (define ns (expand-context-namespace ctx)) + (define mod-name (module-path-index-resolve + (module-path->mpi/context (if (syntax? mod-path) + (syntax->datum mod-path) + mod-path) + ctx) + #t)) + (define m (namespace->module ns mod-name)) + (unless m (raise-unknown-module-error 'syntax-local-module-exports mod-name)) + (for/list ([(phase syms) (in-hash (module-provides m))]) + (cons phase + (for/list ([sym (in-hash-keys syms)]) + sym)))) + +(define (syntax-local-submodules) + (define ctx (get-current-expand-context 'syntax-local-submodules)) + (define submods (expand-context-declared-submodule-names ctx)) + (for/list ([(name kind) (in-hash submods)] + #:when (eq? kind 'module)) + name)) + +;; ---------------------------------------- + +;; Works well enough for some backward compatibility: +(define (syntax-local-get-shadower id [only-generated? #f]) + (check 'syntax-local-get-shadower identifier? id) + (define ctx (get-current-expand-context 'syntax-local-get-shadower)) + (define new-id (add-scopes id (expand-context-scopes ctx))) + (if (syntax-clean? id) + new-id + (syntax-taint new-id))) diff --git a/racket/src/expander/expand/top.rkt b/racket/src/expander/expand/top.rkt new file mode 100644 index 0000000000..3f451696d3 --- /dev/null +++ b/racket/src/expander/expand/top.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require "../syntax/scope.rkt" + "../syntax/taint.rkt" + "../namespace/core.rkt" + "../syntax/match.rkt" + "../syntax/error.rkt" + "../syntax/module-binding.rkt" + "../namespace/namespace.rkt" + "require+provide.rkt" + "main.rkt" + "parsed.rkt" + "context.rkt" + "require.rkt" + "def-id.rkt" + "bind-top.rkt" + "log.rkt") + +(add-core-form! + 'define-values + (lambda (s ctx) + (log-expand ctx 'prim-define-values) + (unless (eq? (expand-context-context ctx) 'top-level) + (raise-syntax-error #f "not allowed in an expression position" s)) + (define disarmed-s (syntax-disarm s)) + (define-match m s '(define-values (id ...) rhs)) + (define-values (ids syms) (as-expand-time-top-level-bindings (m 'id) s ctx)) + (define exp-rhs (expand (m 'rhs) (as-named-context ctx ids))) + (if (expand-context-to-parsed? ctx) + (parsed-define-values s ids syms exp-rhs) + (rebuild + s + `(,(m 'define-values) ,ids ,exp-rhs))))) + +(add-core-form! + 'define-syntaxes + (lambda (s ctx) + (log-expand ctx 'prim-define-syntaxes) + (log-expand ctx 'prepare-env) + (unless (eq? (expand-context-context ctx) 'top-level) + (raise-syntax-error #f "not allowed in an expression position" s)) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(define-syntaxes (id ...) rhs)) + (define-values (ids syms) (as-expand-time-top-level-bindings (m 'id) s ctx)) + (define exp-rhs (expand-transformer (m 'rhs) (as-named-context ctx ids))) + (if (expand-context-to-parsed? ctx) + (parsed-define-syntaxes s ids syms exp-rhs) + (rebuild + s + `(,(m 'define-syntaxes) ,ids ,exp-rhs))))) + +(add-core-form! + 'begin-for-syntax + (lambda (s ctx) + (raise-syntax-error #f "not allowed in an expression position" s))) + +(add-core-form! + '#%require + (lambda (s ctx) + (log-expand ctx 'prim-require) + (unless (eq? (expand-context-context ctx) 'top-level) + (raise-syntax-error #f "allowed only in a module or the top level" s)) + (define disarmed-s (syntax-disarm s)) + (define-match m disarmed-s '(#%require req ...)) + (define sc (new-scope 'macro)) ; to hide bindings + ;; Check the `#%require` form syntax and trigger compile-time + ;; instanations + (parse-and-perform-requires! (for/list ([req (in-list (m 'req))]) + (add-scope req sc)) + s + #:visit? #f + (expand-context-namespace ctx) + (expand-context-phase ctx) + (make-requires+provides #f) + #:who 'require + ;; We don't need to check for conflicts: + #:initial-require? #t) + ;; Nothing to expand + (if (expand-context-to-parsed? ctx) + (parsed-require s) + s))) + +(add-core-form! + '#%provide + (lambda (s ctx) + (log-expand ctx 'prim-provide) + (raise-syntax-error #f "not allowed outside of a module body" s))) diff --git a/racket/src/expander/expand/use-site.rkt b/racket/src/expander/expand/use-site.rkt new file mode 100644 index 0000000000..9dc4200318 --- /dev/null +++ b/racket/src/expander/expand/use-site.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "root-expand-context.rkt") + +(provide remove-use-site-scopes) + +;; Helper to remove any created use-site scopes from the left-hand +;; side of a definition that was revealed by partial expansion in a +;; definition context; the `s` argument can be syntax of a list +;; of syntax +(define (remove-use-site-scopes s ctx) + (define use-sites (root-expand-context-use-site-scopes ctx)) + (if (and use-sites + (pair? (unbox use-sites))) + (if (syntax? s) + (remove-scopes s (unbox use-sites)) + (for/list ([id (in-list s)]) + (remove-scopes id (unbox use-sites)))) + s)) diff --git a/racket/src/expander/extract/c-encode.rkt b/racket/src/expander/extract/c-encode.rkt new file mode 100644 index 0000000000..befcdb2ea8 --- /dev/null +++ b/racket/src/expander/extract/c-encode.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +(provide encode-to-c) + +;; Take a stream that has a single S-expression and converts it to C +;; code for a string that contains the S-expression + +(define (encode-to-c in out) + (fprintf out "#define EVAL_STARTUP EVAL_ONE_STR(startup_source)\n") + (fprintf out "static const char *startup_source =\n") + (for ([l (in-lines in)]) + (let* ([l (regexp-replace* #rx"\\\\" l "\\\\\\\\")] + [l (regexp-replace* #rx"\"" l "\\\\\"")] + [l (regexp-replace* #rx"\t" l " ")] + [l (if (regexp-match? #rx"\"" l) + ;; Has a string - can't safely delete more spaces + l + (let ([l (regexp-replace* #rx" +" l " ")]) + (regexp-replace* #rx" \\(" l "(")))]) + (fprintf out "\"~a\"\n" l))) + (fprintf out ";\n")) diff --git a/racket/src/expander/extract/check-and-report.rkt b/racket/src/expander/extract/check-and-report.rkt new file mode 100644 index 0000000000..e04c70d8ea --- /dev/null +++ b/racket/src/expander/extract/check-and-report.rkt @@ -0,0 +1,69 @@ +#lang racket/base +(require "../run/status.rkt" + "../boot/runtime-primitive.rkt" + "link.rkt" + "linklet-info.rkt" + "linklet.rkt") + +(provide check-and-report!) + +;; Check for bootstrap obstacles and report the results +(define (check-and-report! #:compiled-modules compiled-modules + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:instance-knot-ties instance-knot-ties) + + (log-status "Traversed ~s modules" (hash-count compiled-modules)) + (log-status "Got ~s relevant linklets" (hash-count linklets)) + (log-status "Need ~s of those linklets" (hash-count needed)) + + (define code-bytes + (let ([o (open-output-bytes)]) + (for ([li (in-list (unbox linklets-in-order))]) + (write (linklet-info-linklet (hash-ref linklets li)) o)) + (get-output-bytes o))) + + (define source-mode? (linklets-are-source-mode? linklets)) + + (log-status "Code is ~s bytes~a" + (bytes-length code-bytes) + (if source-mode? " as source" "")) + (unless source-mode? + (log-status "Reading all code...") + (time (let ([i (open-input-bytes code-bytes)]) + (parameterize ([read-accept-compiled #t]) + (let loop () + (unless (eof-object? (read i)) + (loop))))))) + + ;; Check whether any needed linklet needs an instance of a + ;; pre-defined instance that is not part of the runtime system: + (define complained? #f) + (for ([lnk (in-list (unbox linklets-in-order))]) + (define needed-reason (hash-ref needed lnk #f)) + (when needed-reason + (define li (hash-ref linklets lnk)) + (define complained-this? #f) + (for ([in-lnk (in-list (linklet-info-imports li))] + [in-vars (in-list (linklet-info-in-variables li))]) + (define p (link-name in-lnk)) + (when (and (symbol? p) + (not (member p runtime-instances)) + (not (eq? p '#%linklet)) + (not (hash-ref instance-knot-ties p #f)) + (hash-ref needed in-lnk #t)) + (unless complained? + (log-status "~a\n~a" + "Unfortunately, some linklets depend on pre-defined host instances" + "that are not part of the runtime system:") + (set! complained? #t)) + (unless complained-this? + (log-status " - ~a at ~s" (link-name lnk) (link-phase lnk)) + (set! complained-this? #t)) + (log-status "~a" (lines (format " needs ~s:" p) in-vars)))) + (when complained-this? + (log-status " needed by ~s" needed-reason)))) + + (when complained? + (exit 1))) diff --git a/racket/src/expander/extract/decompile.rkt b/racket/src/expander/extract/decompile.rkt new file mode 100644 index 0000000000..8b81953ee0 --- /dev/null +++ b/racket/src/expander/extract/decompile.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require '#%linklet + racket/pretty + "../run/status.rkt") + +(provide compile-and-decompile) + +(define (compile-and-decompile linklet-expr print-extracted-to) + (unless compile-linklet + (error "Host Racket does not support linklet compilation")) + + (log-status "Compiling and decompiling linklet to ~a" print-extracted-to) + + (define linklet (compile-linklet linklet-expr)) + + (define o (open-output-bytes)) + (write (hash->linklet-bundle (hasheq 0 linklet)) o) + + (define i (open-input-bytes (get-output-bytes o))) + + ;; Dynamically load decompiler, so that it's not otherwise a + ;; dependency for running the expander-flattener + (define zo ((dynamic-require 'compiler/zo-parse 'zo-parse) i)) + (define decompiled-expr ((dynamic-require 'compiler/decompile 'decompile) zo)) + + (call-with-output-file* + print-extracted-to + #:exists 'truncate/replace + (lambda (o) + (pretty-write decompiled-expr o)))) + +(define compile-linklet + (hash-ref (primitive-table '#%linklet) 'compile-linklet #f)) + +(define hash->linklet-bundle + (hash-ref (primitive-table '#%linklet) 'hash->linklet-bundle #f)) diff --git a/racket/src/expander/extract/defn-known.rkt b/racket/src/expander/extract/defn-known.rkt new file mode 100644 index 0000000000..7fa4ad7d97 --- /dev/null +++ b/racket/src/expander/extract/defn-known.rkt @@ -0,0 +1,140 @@ +#lang racket/base +(require racket/match + "../run/status.rkt" + "../compile/side-effect.rkt" + "../compile/known.rkt") +(provide add-defn-known!) + +(struct struct-shape (num-fields num-parent-fields op-types)) + +(define (add-defn-known! seen-defns syms rhs) + (for ([s (in-list syms)]) + (unless (hash-ref seen-defns s #f) + (hash-set! seen-defns s (known-defined)))) + (cond + ;; Recognize known-arity `lambda` and `case-lambda` + [(and (= 1 (length syms)) (lambda-arity rhs)) + => + (lambda (arity) + (hash-set! seen-defns + (car syms) + (known-function arity + (pure-lambda? (car syms) + rhs + seen-defns))))] + ;; Recognize structure declarations + [(expr-struct-shape rhs seen-defns) + => + (lambda (shape) + (when (= (length syms) (length (struct-shape-op-types shape))) + (for ([sym (in-list syms)] + [op-type (in-list (struct-shape-op-types shape))]) + (hash-set! seen-defns sym + (known-struct-op op-type + (case op-type + [(general-accessor general-mutator) + (- (struct-shape-num-fields shape) + (struct-shape-num-parent-fields shape))] + [else (struct-shape-num-fields shape)]))))))] + ;; Recognize structure-property declaration + [(and (= 3 (length syms)) (simple-property? rhs)) + (hash-set! seen-defns (list-ref syms 0) (known-property)) + (hash-set! seen-defns (list-ref syms 1) (known-function 1 #t)) + (hash-set! seen-defns (list-ref syms 2) (known-function 1 #t))])) + +(define (lambda-arity e) + (match e + [`(lambda (,args ...) ,_) (length args)] + [`(case-lambda [(,argss ...) ,_] ...) (map length argss)] + [_ #f])) + +(define (pure-lambda? self-id e seen-defns) + (match e + [`(lambda (,args ...) ,body) + (pure-body? self-id null args body seen-defns)] + [`(case-lambda [(,argss ...) ,bodys] ...) + (define arity (map length argss)) + (for/and ([args (in-list argss)] + [body (in-list bodys)]) + (pure-body? self-id arity args body seen-defns))] + [_ #f])) + +(define (pure-body? self-id self-arity args orig-body seen-defns) + (define locals + (for/hash ([arg (in-list args)]) + (values arg (known-defined)))) + (define body + ;; Strip away a `begin` that's there to record a function name: + (match orig-body + [`(begin (quote ,_) ,e) e] + [else orig-body])) + (cond + [(and (pair? body) + (eq? (car body) self-id) + ((sub1 (length body)) . > . (length args))) + ;; Allow a self-call as pure, as long as the number of arguments + ;; grows. We'll only conclude that the function is pure overall if + ;; that assumption now as justified, but we require the number of + ;; arguments to grow to disallow an infinite loop as pure. + (define num-args (length args)) + (not (any-side-effects? body 1 + #:known-defns seen-defns + #:known-locals (hash-set locals + self-id + (known-function + (for/list ([a (in-list self-arity)] + #:when (a . > . num-args)) + a) + #t))))] + [else + (not (any-side-effects? body 1 + #:known-defns seen-defns + #:known-locals locals))])) + +(define struct-general-op-types + '(struct-type constructor predicate general-accessor general-mutator)) + +(define (expr-struct-shape e defns) + (let loop ([e e]) + (match e + [`(let-values () ,e) (loop e)] + [`(make-struct-type ,_ #f ,n 0 #f . ,_) + (and (exact-nonnegative-integer? n) + (struct-shape n 0 struct-general-op-types))] + [`(make-struct-type ,_ ,s ,n 0 #f . ,_) + (define h (hash-ref defns s #f)) + (and (known-struct-op? h) + (exact-nonnegative-integer? n) + (eq? (known-struct-op-type h) 'struct-type) + (struct-shape (+ n (known-struct-op-field-count h)) + (known-struct-op-field-count h) + struct-general-op-types))] + [`(let-values (((,ty ,mk ,pred ,ref ,mut) ,mst)) + (values ,ty ,mk ,pred + (,make-struct-field-xs ,refs ,is ,_) ...)) + (define shape (expr-struct-shape mst defns)) + (and shape + (equal? (struct-shape-op-types shape) struct-general-op-types) + (let ([num-immediate-fields (- (struct-shape-num-fields shape) + (struct-shape-num-parent-fields shape))]) + (for/and ([make-struct-field-x (in-list make-struct-field-xs)] + [r (in-list refs)] + [i (in-list is)]) + (and (< i num-immediate-fields) + (if (eq? make-struct-field-x 'make-struct-field-accessor) + (eq? r ref) + (eq? r mut))))) + (struct-shape (struct-shape-num-fields shape) + (struct-shape-num-parent-fields shape) + (append '(struct-type constructor predicate) + (for/list ([make-struct-field-x (in-list make-struct-field-xs)]) + (if (eq? make-struct-field-x 'make-struct-field-accessor) + 'accessor + 'mutator)))))] + [_ #f]))) + +;; checks for properties without guards +(define (simple-property? e) + (match e + [`(make-struct-type-property ,_) #t] + [_ #f])) diff --git a/racket/src/expander/extract/defn.rkt b/racket/src/expander/extract/defn.rkt new file mode 100644 index 0000000000..735d823988 --- /dev/null +++ b/racket/src/expander/extract/defn.rkt @@ -0,0 +1,12 @@ +#lang racket/base + +(provide defn? + defn-syms + defn-rhs) + +(define (defn? e) + (and (pair? e) + (eq? (car e) 'define-values))) +(define defn-syms cadr) +(define defn-rhs caddr) + diff --git a/racket/src/expander/extract/export.rkt b/racket/src/expander/extract/export.rkt new file mode 100644 index 0000000000..6c4babfc4c --- /dev/null +++ b/racket/src/expander/extract/export.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require "module.rkt" + "../host/linklet.rkt" + "../common/module-path.rkt" + "../syntax/module-binding.rkt" + "../namespace/provided.rkt" + "link.rkt" + "variable.rkt") + +(provide get-module-export-variables) + +(define (get-module-export-variables lnk + #:compiled-modules compiled-modules + #:cache cache) + (define name (link-name lnk)) + (define phase (link-phase lnk)) + (define root-name (if (pair? name) (car name) name)) ; strip away submodule path + (define comp-mod + (get-compiled-module name root-name + #:compiled-modules compiled-modules + #:cache cache)) + + (define provs (instance-variable-value (compiled-module-declaration comp-mod) 'provides)) + + (for/hash ([(sym binding/p) (in-hash (hash-ref provs 0 #hasheq()))]) + (define binding (provided-as-binding binding/p)) + (values sym (variable (link (module-path-index->module-name (module-binding-module binding) name) + (module-binding-phase binding)) + (module-binding-sym binding))))) diff --git a/racket/src/expander/extract/flatten.rkt b/racket/src/expander/extract/flatten.rkt new file mode 100644 index 0000000000..bcdc70d21f --- /dev/null +++ b/racket/src/expander/extract/flatten.rkt @@ -0,0 +1,186 @@ +#lang racket/base +(require "../common/set.rkt" + "../run/status.rkt" + "link.rkt" + "linklet-info.rkt" + "linklet.rkt" + "variable.rkt" + "symbol.rkt" + "primitive-table.rkt" + (prefix-in bootstrap: "../run/linklet.rkt")) + +(provide flatten!) + +(define (flatten! start-link + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:exports exports + #:instance-knot-ties instance-knot-ties + #:primitive-table-directs primitive-table-directs) + (log-status "Flattening to a single linklet...") + (define needed-linklets-in-order + (for/list ([lnk (in-list (unbox linklets-in-order))] + #:when (hash-ref needed lnk #f)) + lnk)) + + (define variable-names (pick-variable-names + #:linklets linklets + #:needed-linklets-in-order needed-linklets-in-order + #:instance-knot-ties instance-knot-ties)) + + (for ([var (in-hash-keys variable-names)] + #:when (symbol? (link-name (variable-link var)))) + (error 'flatten "found a dependency on a non-primitive: ~s from ~s" + (variable-name var) + (link-name (variable-link var)))) + + `(linklet + ;; imports + () + ;; exports + ,(for/list ([ex-sym (in-list (sort (hash-keys exports) symbol set-of-symbol + (define all-variables null) ; domain of `variable-locals` in an order + (define otherwise-used-symbols (seteq)) + + (for ([lnk (in-list needed-linklets-in-order)]) + (define li (hash-ref linklets lnk)) + (define linklet (linklet-info-linklet li)) + (define importss+localss + (skip-abi-imports (bootstrap:s-expr-linklet-importss+localss linklet))) + (define exports+locals + (bootstrap:s-expr-linklet-exports+locals linklet)) + (define all-mentioned-symbols + (all-used-symbols (bootstrap:s-expr-linklet-body linklet))) + + (define (record! lnk external+local knot-ties) + (cond + [(find-knot-tying-alternate knot-ties lnk (car external+local) linklets) + => (lambda (alt-lnk) + (unless (eq? alt-lnk 'ignore) + (record! alt-lnk external+local knot-ties)))] + [else + (define var (variable lnk (car external+local))) + (unless (hash-ref variable-locals var #f) + (set! all-variables (cons var all-variables))) + (hash-update! variable-locals + var + (lambda (s) (set-add s (cdr external+local))) + (seteq))])) + + (for ([imports+locals (in-list importss+localss)] + [i-lnk (in-list (linklet-info-imports li))]) + (for ([import+local (in-list imports+locals)]) + (record! i-lnk import+local instance-knot-ties))) + + (for ([export+local (in-list exports+locals)]) + (record! lnk export+local #hasheq())) + + (define all-import-export-locals + (list->set + (apply append + (map cdr exports+locals) + (for/list ([imports+locals (in-list importss+localss)]) + (map cdr imports+locals))))) + (set! otherwise-used-symbols + (set-union otherwise-used-symbols + (set-subtract all-mentioned-symbols + all-import-export-locals)))) + + ;; For each variable name, use the obvious symbol if it won't + ;; collide, otherwise pick a symbol that's not mentioned anywhere. + ;; (If a variable was given an alternative name for all imports or + ;; exports, probably using the obvious symbol would cause a + ;; collision.) + (for/hash ([var (in-list (reverse all-variables))]) + (define current-syms (hash-ref variable-locals var)) + (define sym + (cond + [(and (= 1 (set-count current-syms)) + (not (set-member? otherwise-used-symbols (set-first current-syms)))) + (set-first current-syms)] + [(and (set-member? current-syms (variable-name var)) + (not (set-member? otherwise-used-symbols (variable-name var)))) + (variable-name var)] + [else (distinct-symbol (variable-name var) otherwise-used-symbols)])) + (set! otherwise-used-symbols (set-add otherwise-used-symbols sym)) + (values var sym))) + +(define (body-with-substituted-variable-names lnk li variable-names + #:linklets linklets + #:instance-knot-ties instance-knot-ties) + (define linklet (linklet-info-linklet li)) + (define importss+localss + (skip-abi-imports (bootstrap:s-expr-linklet-importss+localss linklet))) + (define exports+locals + (bootstrap:s-expr-linklet-exports+locals linklet)) + + (define substs (make-hasheq)) + + (define (add-subst! lnk external+local knot-ties) + (cond + [(find-knot-tying-alternate knot-ties lnk (car external+local) linklets) + => (lambda (alt-lnk) + (unless (eq? alt-lnk 'ignore) + (add-subst! alt-lnk external+local knot-ties)))] + [else + (hash-set! substs + (cdr external+local) + (hash-ref variable-names (variable lnk (car external+local))))])) + + (for ([imports+locals (in-list importss+localss)] + [i-lnk (in-list (linklet-info-imports li))]) + (for ([import+local (in-list imports+locals)]) + (add-subst! i-lnk import+local instance-knot-ties))) + + (for ([export+local (in-list exports+locals)]) + (add-subst! lnk export+local #hasheq())) + + (define orig-s (bootstrap:s-expr-linklet-body (linklet-info-linklet li))) + + (substitute-symbols orig-s substs)) + + +(define (find-knot-tying-alternate knot-ties lnk external linklets) + (cond + [(hash-ref knot-ties (link-name lnk) #f) + => (lambda (alt-paths) + (or (for/or ([alt-path (in-list alt-paths)]) + (cond + [(eq? alt-path 'ignore) + 'ignore] + [else + (define alt-lnk (link alt-path 0)) + (define li (hash-ref linklets alt-lnk)) + (define exports+locals (bootstrap:s-expr-linklet-exports+locals (linklet-info-linklet li))) + (for/or ([export+local (in-list exports+locals)]) + (and (eq? external (car export+local)) + alt-lnk))])) + (error 'flatten "could not find alternative export: ~s from ~s" + external + lnk)))] + [else #f])) diff --git a/racket/src/expander/extract/gc-defn.rkt b/racket/src/expander/extract/gc-defn.rkt new file mode 100644 index 0000000000..3b8f60950b --- /dev/null +++ b/racket/src/expander/extract/gc-defn.rkt @@ -0,0 +1,115 @@ +#lang racket/base +(require racket/list + "../host/correlate.rkt" + "../common/set.rkt" + "../compile/side-effect.rkt" + "../compile/known.rkt" + "../run/status.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "symbol.rkt" + "defn.rkt" + "defn-known.rkt" + "known-primitive.rkt") + +(provide garbage-collect-definitions) + +(define (garbage-collect-definitions linklet-expr) + (log-status "Removing unused definitions...") + + (define body (bootstrap:s-expr-linklet-body linklet-expr)) + + (define used-syms (make-hasheq)) + + ;; See "../compile/known.rkt" for the meaning of + ;; values in `seen-defns` + (define seen-defns (make-hasheq)) + (register-known-primitives! seen-defns) + + ;; Map symbols to definition right-hand sides + (define sym-to-rhs (make-hasheq)) + (for ([e (in-list body)]) + (cond + [(defn? e) + (for ([sym (in-list (defn-syms e))]) + (hash-set! sym-to-rhs sym (defn-rhs e)))])) + + ;; A "mark"-like traversal of an expression: + (define (set-all-used! e) + (for ([sym (in-set (all-used-symbols e))]) + (unless (hash-ref used-syms sym #f) + (hash-set! used-syms sym #t) + (set-all-used! (hash-ref sym-to-rhs sym #f))))) + + ;; Helper to check for side-effects at a definition + (define (defn-side-effects? e) + (any-side-effects? (defn-rhs e) + (length (defn-syms e)) + #:known-defns seen-defns)) + + ;; Mark each body form, delaying the righthand side of definitions + ;; if the definition has no side-effect + (let loop ([body body]) + (cond + [(null? body) (void)] + [(defn? (car body)) + (define defn (car body)) + (cond + [(defn-side-effects? defn) + ;; Right-hand side has an effect, so keep the + ;; definition and mark everything as used: + (for ([sym (in-list (defn-syms defn))]) + (unless (hash-ref used-syms sym #f) + (hash-set! used-syms sym #t))) + (set-all-used! (defn-rhs defn)) + ;; Afterward, these identifiers are defined. + ;; (It's ok if delayed types refer to these, + ;; because they're apparently used later if they're + ;; still delayed.) + (for ([sym (in-list (defn-syms defn))]) + (hash-set! seen-defns sym (known-defined)))] + [else + ;; The definition itself doesn't have a side effect, so dont + ;; mark it as used right away, and delay analysis to make it + ;; independent of order within a group without side effects + (define thunk + (known-defined/delay + (lambda () + (for ([sym (in-list (defn-syms defn))]) + (hash-set! seen-defns sym (known-defined))) + (add-defn-known! seen-defns + (defn-syms defn) + (defn-rhs defn))))) + (for ([sym (in-list (defn-syms defn))]) + (hash-set! seen-defns sym thunk))]) + (loop (cdr body))] + [else + (set-all-used! (car body)) + (loop (cdr body))])) + + ;; Mark each export: + (for ([ex+sym (in-list (bootstrap:s-expr-linklet-exports+locals linklet-expr))]) + (set-all-used! (cdr ex+sym))) + + (define can-remove-count + (for/sum ([e (in-list body)]) + (cond + [(defn? e) + (if (for/or ([sym (in-list (defn-syms e))]) + (hash-ref used-syms sym #f)) + 0 + (length (defn-syms e)))] + [else 0]))) + (log-status "Can remove ~s of ~s defined names, keeping ~s" + can-remove-count + (hash-count sym-to-rhs) + (- (hash-count sym-to-rhs) can-remove-count)) + + (define new-body + (for/list ([e (in-list body)] + #:when (or (not (defn? e)) + (for/or ([sym (in-list (defn-syms e))]) + (hash-ref used-syms sym #f)))) + e)) + + (append (take linklet-expr 3) + new-body)) diff --git a/racket/src/expander/extract/get-linklet.rkt b/racket/src/expander/extract/get-linklet.rkt new file mode 100644 index 0000000000..bf0ada4459 --- /dev/null +++ b/racket/src/expander/extract/get-linklet.rkt @@ -0,0 +1,108 @@ +#lang racket/base +(require "../common/set.rkt" + "../common/phase.rkt" + "../run/status.rkt" + "../host/linklet.rkt" + "../compile/module-use.rkt" + "../syntax/binding.rkt" + "../namespace/provided.rkt" + "link.rkt" + "linklet-info.rkt" + "linklet.rkt" + "module.rkt") + +(provide get-linklets!) + +(define (get-linklets! lnk + #:cache cache + #:compiled-modules compiled-modules + #:seen seen + #:linklets linklets + #:linklets-in-order linklets-in-order + #:side-effect-free-modules side-effect-free-modules) + (let get-linklets! ([lnk lnk] [first? #t]) + (define name (link-name lnk)) + (define phase (link-phase lnk)) + (define root-name (if (pair? name) (car name) name)) ; strip away submodule path + (unless (or (symbol? root-name) ; skip pre-defined modules + (hash-ref seen lnk #f)) + ;; Seeing this module+phase combination for the first time + (log-status "Getting ~s at ~s" name phase) + (define comp-mod (get-compiled-module name root-name + #:compiled-modules compiled-modules + #:cache cache)) + + ;; Extract the relevant linklet (i.e., at a given phase) + ;; from the compiled module + (define h (compiled-module-phase-to-linklet comp-mod)) + (define linklet + (hash-ref h phase #f)) + + ;; Extract other metadata at the module level: + (define reqs (instance-variable-value (compiled-module-declaration comp-mod) 'requires)) + (define provs (instance-variable-value (compiled-module-declaration comp-mod) 'provides)) + + ;; Extract phase-specific (i.e., linklet-specific) info on variables: + (define vars (if linklet + (list->set (linklet-export-variables linklet)) + null)) + ;; Extract phase-specific info on imports (for reporting bootstrap issues): + (define in-vars (if linklet + (skip-abi-imports (linklet-import-variables linklet)) + null)) + ;; Extract phase-specific info on side effects: + (define side-effects? (and (not (hash-ref side-effect-free-modules name #f)) + (member phase (hash-ref h 'side-effects '())) + #t)) + ;; Extract phase-specific mapping of the linklet arguments to modules + (define uses + (hash-ref (instance-variable-value (compiled-module-declaration comp-mod) 'phase-to-link-modules) + phase + null)) + + (define dependencies + (for*/list ([phase+reqs (in-list reqs)] + [req (in-list (cdr phase+reqs))]) + ;; we want whatever required module will have at this module's `phase` + (define at-phase (phase- phase (car phase+reqs))) + (link (module-path-index->module-name req name) + at-phase))) + + ;; Get linklets implied by the module's `require` (although some + ;; of those may turn out to be dead code) + (for ([dependency (in-list dependencies)]) + (get-linklets! dependency #f)) + + ;; Imports are the subset of the transitive closure of `require` + ;; that are used by this linklet's implementation + (define imports + (for/list ([mu (in-list uses)]) + (link (module-path-index->module-name (module-use-module mu) name) + (module-use-phase mu)))) + (when (and (pair? imports) + (not linklet)) + (error "no implementation, but uses arguments?" name phase)) + + ;; Re-exports are the subset of the transitive closure of + ;; `require` that have variables that are re-exported from this + ;; linklet; relevant only for the starting point + (define re-exports + (and first? + (set->list + (for*/set ([(sym binding/p) (in-hash (hash-ref provs phase #hasheq()))] + [(binding) (in-value (provided-as-binding binding/p))] + [l (in-value + (link (module-path-index->module-name (module-binding-module binding) name) + (module-binding-phase binding)))] + [re-li (in-value (hash-ref linklets l #f))] + #:when (and re-li + (set-member? (linklet-info-variables re-li) (module-binding-sym binding)))) + l)))) + + (define li (linklet-info linklet imports re-exports vars in-vars side-effects?)) + + (hash-set! seen lnk li) + + (when linklet + (hash-set! linklets lnk li) + (set-box! linklets-in-order (cons lnk (unbox linklets-in-order))))))) diff --git a/racket/src/expander/extract/known-primitive.rkt b/racket/src/expander/extract/known-primitive.rkt new file mode 100644 index 0000000000..d42e987676 --- /dev/null +++ b/racket/src/expander/extract/known-primitive.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(require "../compile/known.rkt") + +(provide register-known-primitives!) + +(define (register-known-primitives! seen-defns) + ;; Register some core primitives that have specific properties: + (hash-set! seen-defns 'struct:exn:fail (known-struct-op 'struct-type 2)) + (hash-set! seen-defns 'make-thread-cell (known-struct-op 'constructor 1)) + (hash-set! seen-defns 'make-continuation-prompt-tag (known-struct-op 'constructor 1)) + (hash-set! seen-defns 'make-weak-hash (known-struct-op 'constructor 0)) + (hash-set! seen-defns 'gensym (known-struct-op 'constructor 0)) + (hash-set! seen-defns 'string (known-struct-op 'constructor 2)) + (hash-set! seen-defns 'cons (known-struct-op 'constructor 2)) + (hash-set! seen-defns 'eq? (known-struct-op 'constructor 2)) + (hash-set! seen-defns 'not (known-predicate 'anything)) + (hash-set! seen-defns 'null? (known-predicate 'null)) + (hash-set! seen-defns 'integer? (known-predicate 'integer)) + (hash-set! seen-defns 'list? (known-predicate 'list)) + (hash-set! seen-defns 'length (known-function-of-satisfying '(list))) + (hash-set! seen-defns 'arity-at-least? (known-predicate 'arity-at-least)) + (hash-set! seen-defns 'arity-at-least-value (known-function-of-satisfying '(arity-at-least))) + (hash-set! seen-defns 'procedure? (known-predicate 'procedure)) + (hash-set! seen-defns 'procedure-arity (known-function-of-satisfying '(procedure)))) diff --git a/racket/src/expander/extract/link.rkt b/racket/src/expander/extract/link.rkt new file mode 100644 index 0000000000..8ba2f6b7f0 --- /dev/null +++ b/racket/src/expander/extract/link.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide (struct-out link)) + +;; A "link" represent a linklet reference, which is a name +;; (corresponds to a `resolved-module-path-name` result) plus a phase +(struct link (name phase) #:prefab) diff --git a/racket/src/expander/extract/linklet-info.rkt b/racket/src/expander/extract/linklet-info.rkt new file mode 100644 index 0000000000..5d9a4fd746 --- /dev/null +++ b/racket/src/expander/extract/linklet-info.rkt @@ -0,0 +1,13 @@ +#lang racket/base + +(provide (struct-out linklet-info)) + +;; A linklet-info is a phase-specific slice of a module --- mainly a +;; linklet, but we group the linklet together with metadata from the +;; module's declaration linklet +(struct linklet-info (linklet ; the implementation, or #f if the implementation is empty + imports ; list of links: import "arguments" + re-exports ; list of links: links whose variables are re-exported + variables ; set of symbols: defined in the implementation, for detecting re-exports + in-variables ; list of list of symbols: for each import, variables used from the import + side-effects?)) ; whether the implementaiton has side effects other than variable definition diff --git a/racket/src/expander/extract/linklet.rkt b/racket/src/expander/extract/linklet.rkt new file mode 100644 index 0000000000..a04f39ea12 --- /dev/null +++ b/racket/src/expander/extract/linklet.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(require "linklet-info.rkt" + "../host/linklet.rkt" + (prefix-in bootstrap: "../run/linklet.rkt")) + +(provide skip-abi-imports + linklets-are-source-mode?) + +;; Skip over syntax literals and instance: +(define (skip-abi-imports l) + (list-tail l 2)) + +;; Detect source mode, which enables final assembly +(define (linklets-are-source-mode? linklets) + (define bootstrap-mode? + (eq? bootstrap:compile-linklet compile-linklet)) + (and bootstrap-mode? + (not (zero? (hash-count linklets))) + (bootstrap:linklet-as-s-expr? + (linklet-info-linklet + (hash-iterate-value linklets (hash-iterate-first linklets)))))) diff --git a/racket/src/expander/extract/main.rkt b/racket/src/expander/extract/main.rkt new file mode 100644 index 0000000000..fcef8f2d49 --- /dev/null +++ b/racket/src/expander/extract/main.rkt @@ -0,0 +1,147 @@ +#lang racket/base +(require "link.rkt" + "linklet-info.rkt" + "linklet.rkt" + "get-linklet.rkt" + "needed.rkt" + "export.rkt" + "check-and-report.rkt" + "flatten.rkt" + "gc-defn.rkt" + "simplify-defn.rkt" + "prune-name.rkt" + "decompile.rkt" + "save-and-report.rkt" + "underscore.rkt" + racket/pretty) + +(provide extract) + +;; Gather all of the linklets need to run phase 0 of the specified +;; module while keeping the module's variables that are provided from +;; phase 0. In other words, keep enogh to produce any value or effect +;; that `dynamic-require` would produce. +(define (extract start-mod-path cache + #:print-extracted-to print-extracted-to + #:as-c? as-c? + #:as-decompiled? as-decompiled? + ;; Table of symbol -> (listof knot-spec), + ;; to redirect a remaining import back to + ;; an implementation that is defined in the + ;; flattened code; a knot-spec as a module-path + ;; redirect to there, or as 'ignored avoids both + ;; a knot and complaining + #:instance-knot-ties instance-knot-ties + ;; Table of symbol -> string + ;; to replace (hash-ref (or (primitive-table ') ...) ' #f) + ;; with a direct reference to + #:primitive-table-directs primitive-table-directs + ;; Override linklet compiler's simple inference + ;; of side-effects to remove a module from the + ;; flattened form if it's not otherwise referenced: + #:side-effect-free-modules side-effect-free-modules) + ;; Located modules: + (define compiled-modules (make-hash)) + + ;; All linklets that find we based on module `requires` from the + ;; starting module + (define seen (make-hash)) ; link -> linklet-info + + ;; The subset of `seen` that have that non-empty linklets + (define linklets (make-hash)) ; link -> linklet-info + ;; The same linklets are referenced this list, but kept in reverse + ;; order of instantiation: + (define linklets-in-order (box null)) + + ;; Which linklets (as represented by a "link") are actually needed to run + ;; the code, which includes anything referenced by the starting + ;; point's exports and any imported linklet that has a side effect: + (define needed (make-hash)) ; link -> value for reason + + ;; Use the host Racket's module name resolver to normalize the + ;; starting module path: + (define start-name + (resolved-module-path-name + (module-path-index-resolve + (module-path-index-join start-mod-path #f)))) + + ;; We always start at phase 0 + (define start-link (link start-name 0)) + + ;; Start with the given link, and follow dependencies + (get-linklets! start-link + #:cache cache + #:compiled-modules compiled-modules + #:seen seen + #:linklets linklets + #:linklets-in-order linklets-in-order + #:side-effect-free-modules side-effect-free-modules) + + ;; Compute which linklets are actually used as imports + (needed! start-link 'start + #:seen seen + #:needed needed) + + ;; We also want the starting name's re-exports: + (for ([ex-lnk (in-list (linklet-info-re-exports (hash-ref seen start-link)))]) + (needed! ex-lnk `(re-export ,start-link) + #:seen seen + #:needed needed)) + + ;; Anything that shows up in `codes` with a side effect also counts + (for ([(lnk li) (in-hash linklets)]) + (when (linklet-info-side-effects? li) + (needed! lnk 'side-effect + #:seen seen + #:needed needed))) + + ;; Check for bootstrap obstacles, and report what we've found + (check-and-report! #:compiled-modules compiled-modules + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:instance-knot-ties instance-knot-ties) + + ;; If we're in source mode, we can generate a single linklet + ;; that combines all the ones we found + (when (linklets-are-source-mode? linklets) + ;; Get variables to be exported by a flattened linklet; all of the + ;; module provides must refer to instance variables + (define exports + (get-module-export-variables start-link + #:compiled-modules compiled-modules + #:cache cache)) + + ;; Generate the flattened linklet + (define flattened-linklet-expr + (flatten! start-link + #:linklets linklets + #:linklets-in-order linklets-in-order + #:needed needed + #:exports exports + #:instance-knot-ties instance-knot-ties + #:primitive-table-directs primitive-table-directs)) + + (define simplified-expr + (simplify-definitions flattened-linklet-expr)) + + ;; Remove unreferenced definitions + (define gced-linklet-expr + (garbage-collect-definitions simplified-expr)) + + ;; Avoid gratuitous differences due to names generated during + ;; expansion + (define re-renamed-linklet-expr + (simplify-underscore-numbers gced-linklet-expr)) + + ;; Prune any explicit function names (using a `quote` pattern in + ;; the body) when they still match a name that would be inferred + (define pruned-linklet-expr + (prune-names re-renamed-linklet-expr)) + + (cond + [as-decompiled? + (compile-and-decompile pruned-linklet-expr print-extracted-to)] + [else + (save-and-report-flattened! pruned-linklet-expr print-extracted-to + #:as-c? as-c?)]))) diff --git a/racket/src/expander/extract/module.rkt b/racket/src/expander/extract/module.rkt new file mode 100644 index 0000000000..09da87efe0 --- /dev/null +++ b/racket/src/expander/extract/module.rkt @@ -0,0 +1,72 @@ +#lang racket/base +(require "../host/linklet.rkt" + "../run/cache.rkt" + "../compile/serialize.rkt" + "../compile/module-use.rkt" + (prefix-in new: "../common/module-path.rkt")) + +(provide (struct-out compiled-module) + get-compiled-module + module-path-index->module-name) + +;; We locate each module's declation and phase-specific +;; linklets once: +(struct compiled-module (declaration ; linklet instance + phase-to-linklet)) ; phase -> linklet + + +;; Get (possibly already-loaded) representation of a compiled module +;; from the cache +(define (get-compiled-module name root-name + #:compiled-modules compiled-modules + #:cache cache) + (or (hash-ref compiled-modules name #f) + (let ([local-name name]) + ;: Seeing this module for the first time + (define cd (get-cached-compiled cache root-name void)) + (unless cd + (error "unavailable in cache:" name)) + ;; For submodules, recur into the compilation directory: + (define h (let loop ([cd cd] [name name]) + (cond + [(linklet-bundle? cd) + (linklet-bundle->hash cd)] + [else + (define h (linklet-directory->hash cd)) + (if (or (not (pair? name)) + (null? (cdr name))) + (linklet-bundle->hash (hash-ref h #f)) + (loop (hash-ref h (cadr name)) + (cdr name)))]))) + ;; Instantiate the declaration linklet + (define data-instance (instantiate-linklet (hash-ref h 'data) + (list deserialize-instance))) + (define decl (instantiate-linklet (hash-ref h 'decl) + (list deserialize-instance + data-instance))) + ;; Make a `compiled-module` structure to represent the compiled module + ;; and all its linklets (but not its submodules, although they're in `h`) + (define comp-mod (compiled-module decl h)) + (hash-set! compiled-modules name comp-mod) + comp-mod))) + +;; Convert a module path index implemented by our compiler to +;; a module path index in the host Racket: +(define (build-native-module-path-index mpi wrt-name) + (define-values (mod-path base) (new:module-path-index-split mpi)) + (cond + [(not mod-path) (make-resolved-module-path wrt-name)] + [else + (module-path-index-join mod-path + (and base + (build-native-module-path-index base wrt-name)))])) + +;; Convert one of our module path indexes and a name to +;; the referenced name +(define (module-path-index->module-name mod name) + (define p (build-native-module-path-index mod name)) + (resolved-module-path-name + (if (resolved-module-path? p) + p + (module-path-index-resolve p)))) + diff --git a/racket/src/expander/extract/needed.rkt b/racket/src/expander/extract/needed.rkt new file mode 100644 index 0000000000..2d2fa32147 --- /dev/null +++ b/racket/src/expander/extract/needed.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require "link.rkt" + "linklet-info.rkt") + +(provide needed!) + +;; Compute which linklets are actually used as imports +(define (needed! lnk reason + #:seen seen + #:needed needed) + (let needed! ([lnk lnk] [reason reason]) + (unless (hash-ref needed lnk #f) + (define li (hash-ref seen lnk #f)) + (when li + (hash-set! needed lnk reason) + (for ([in-lnk (in-list (linklet-info-imports li))]) + (needed! in-lnk lnk)))))) diff --git a/racket/src/expander/extract/primitive-table.rkt b/racket/src/expander/extract/primitive-table.rkt new file mode 100644 index 0000000000..d330b3262b --- /dev/null +++ b/racket/src/expander/extract/primitive-table.rkt @@ -0,0 +1,73 @@ +#lang racket/base +(provide substitute-primitive-table-access) + +;; Replace +;; (hash-ref (or (primitive-table '
) ...) [default]) +;; with just if
is in `primitive-table-directs`. +(define (substitute-primitive-table-access s primitive-table-directs) + (let loop ([s s]) + (cond + [(primitive-table-lookup-match s) + => (lambda (tables+id) + (define prefix + (for/or ([t (in-list (car tables+id))]) + (hash-ref primitive-table-directs t #f))) + (cond + [prefix + (string->symbol (string-append prefix (symbol->string (cdr tables+id))))] + [else s]))] + [(pair? s) + (cons (loop (car s)) (loop (cdr s)))] + [else s]))) + +(define (primitive-table-lookup-match s) + (cond + [(and (pair? s) + (eq? (car s) 'hash-ref) + (list? s) + (<= 3 (length s) 4) + (let ([q-id (caddr s)]) + (and (list? q-id) + (= (length q-id) 2) + (eq? 'quote (car q-id)) + (symbol? (cadr q-id)) + (cadr q-id)))) + => (lambda (id) + (define tables (accessed-primitive-tables (cadr s))) + (and tables + (cons tables id)))] + [else #f])) + +;; Recognize expansion of +;; (or (primitive-table '
) ...) +(define (accessed-primitive-tables s) + (cond + [(and (list? s) + (= 2 (length s)) + (eq? 'primitive-table (car s)) + (let ([t (cadr s)]) + (and (list? t) + (= 2 (length t)) + (eq? 'quote (car t)) + (symbol? (cadr t)) + (cadr t)))) + => (lambda (table) + (list table))] + [(and (list? s) + (= 3 (length s)) + (eq? (car s) 'let-values) + (= 1 (length (cadr s))) + (= 1 (length (caar (cadr s)))) + (let ([id (car (caar (cadr s)))] + [c (caddr s)]) + (and (list? c) + (= (length c) 4) + (eq? (car c) 'if) + (eq? (cadr c) id) + (eq? (caddr c) id) + (accessed-primitive-tables (cadddr c))))) + => (lambda (tables) + (define pre-tables (accessed-primitive-tables (cadar (cadr s)))) + (and pre-tables + (append tables pre-tables)))] + [else #f])) diff --git a/racket/src/expander/extract/prune-name.rkt b/racket/src/expander/extract/prune-name.rkt new file mode 100644 index 0000000000..5d151e34f3 --- /dev/null +++ b/racket/src/expander/extract/prune-name.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require racket/list + racket/match + "../host/correlate.rkt" + "../run/status.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "defn.rkt") + +(provide prune-names) + +;; Remove function names reported with `quote` when the +;; name is redundant after all transformations. +(define (prune-names linklet-expr) + (define body (bootstrap:s-expr-linklet-body linklet-expr)) + + (define new-body + (for/list ([e (in-list body)]) + (cond + [(defn? e) + (define ids (defn-syms e)) + `(define-values ,ids ,(prune (defn-rhs e) (get-single-id ids)))] + [else + (prune e #f)]))) + + (append (take linklet-expr 3) + new-body)) + +(define (prune e id) + (match e + [`(lambda ,args (begin (quote ,name-id) ,es ...)) + `(lambda ,args ,(if (eq? name-id id) + (prune `(begin . ,es) #f) + (prune `(begin (quote ,name-id) ,@es) #f)))] + [`(lambda ,args ,e) + `(lambda ,args ,(prune e #f))] + [`(case-lambda [,args (begin (quote ,name-id) ,es ...)] + [,argss ,bodys] ...) + `(case-lambda + [,args ,(if (eq? name-id id) + (prune `(begin . ,es) #f) + (prune `(begin (quote ,name-id) ,@es) #f))] + ,@(for/list ([args (in-list argss)] + [body (in-list bodys)]) + `[,args ,(prune body #f)]))] + [`(case-lambda [,argss ,bodys] ...) + `(case-lambda + ,@(for/list ([args (in-list argss)] + [body (in-list bodys)]) + `[,args ,(prune body #f)]))] + [`(let-values ([,idss ,rhss] ...) ,e) + `(let-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(prune rhs (get-single-id ids))]) + ,(prune e id))] + [`(letrec-values ([,idss ,rhss] ...) ,e) + `(letrec-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(prune rhs (get-single-id ids))]) + ,(prune e id))] + [`(if ,tst ,thn ,els) + `(if ,(prune tst #f) ,(prune thn id) ,(prune els id))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(prune key #f) ,(prune val #f) ,(prune body id))] + [`(quote ,_) e] + [`(#%variable-reference . ,_) e] + [`(set! ,id ,e) + `(set! ,id ,(prune e id))] + [`(,rator ,rands ...) + (cons (prune rator #f) + (for/list ([rand (in-list rands)]) + (prune rand #f)))] + [else e])) + +(define (get-single-id ids) + (and (pair? ids) + (null? (cdr ids)) + (car ids))) diff --git a/racket/src/expander/extract/save-and-report.rkt b/racket/src/expander/extract/save-and-report.rkt new file mode 100644 index 0000000000..845ea6738b --- /dev/null +++ b/racket/src/expander/extract/save-and-report.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require racket/pretty + "../host/linklet.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "../run/status.rkt" + "c-encode.rkt") + +(provide save-and-report-flattened!) + +(define (save-and-report-flattened! flattened-linklet-expr + print-extracted-to + #:as-c? as-c?) + (when print-extracted-to + (log-status "Writing combined linklet to ~a" print-extracted-to) + (call-with-output-file + print-extracted-to + #:exists 'truncate + (lambda (o) + (unless as-c? + (displayln ";; This is not the original source code. Instead, this is the code after" o) + (displayln ";; fully expanding and flattening into a single linklet." o)) + (define s-expr-o (if as-c? + (open-output-bytes) + o)) + (parameterize ([pretty-print-columns 120]) + (pretty-write flattened-linklet-expr s-expr-o)) + (when as-c? + (encode-to-c (open-input-bytes (get-output-bytes s-expr-o)) o))))) + + ;; Tentatively compile and report size and time + (log-status "Compiling flattened, just as a sanity check...") + (define linklet + (parameterize ([bootstrap:linklet-compile-to-s-expr #f]) + (compile-linklet flattened-linklet-expr))) + + (define code-bytes + (let ([o (open-output-bytes)]) + (write linklet o) + (get-output-bytes o))) + + (log-status "Flattened code is ~s bytes" (bytes-length code-bytes)) + (log-status "Reading compiled code...") + (time (let ([i (open-input-bytes code-bytes)]) + (parameterize ([read-accept-compiled #t]) + (void (read i)))))) diff --git a/racket/src/expander/extract/simplify-defn.rkt b/racket/src/expander/extract/simplify-defn.rkt new file mode 100644 index 0000000000..3397c72f09 --- /dev/null +++ b/racket/src/expander/extract/simplify-defn.rkt @@ -0,0 +1,159 @@ +#lang racket/base +(require racket/list + racket/match + "../host/correlate.rkt" + "../common/set.rkt" + "../compile/side-effect.rkt" + "../compile/known.rkt" + "../run/status.rkt" + (prefix-in bootstrap: "../run/linklet.rkt") + "symbol.rkt" + "defn.rkt" + "defn-known.rkt" + "known-primitive.rkt") + +(provide simplify-definitions + simplify-expr) + +(define (union-all . args) + (if (null? args) + (seteq) + (set-union (car args) (apply union-all (cdr args))))) + +;; compute the variables that are the target of a set! in e +(define (mutated-vars e) + (match e + [`(set! ,i ,e) (set-add (mutated-vars e) i)] + [`(let-values ,cl ,e) + (define cl* (map (lambda (c) (mutated-vars (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-union (apply union-all (map mutated-vars cl*)) (set-remove (mutated-vars e) binds))] + [`(letrec-values ,cl ,e) + (define cl* (map (lambda (c) (mutated-vars (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-remove (set-union (mutated-vars e) (apply union-all (map mutated-vars cl*))) binds)] + [`(lambda ,args ,e) (mutated-vars e)] + [`(case-lambda [,args ,e] ...) (apply union-all (map mutated-vars e))] + [`(,sym ,e ...) + #:when (memq sym '(begin begin0 with-continuation-mark if)) + (apply union-all (map mutated-vars e))] + [(? symbol? e) (seteq)] + [`(quote ,_) (seteq)] + [e #:when (or (boolean? e) (number? e) (string? e) (bytes? e)) + (seteq)] + [(list app ...) (apply union-all (map mutated-vars app))] + [(? hash?) (seteq)])) + +;; compute the free variables of e +(define (frees e) + (match e + [(? symbol?) (set e)] + [`(let-values ,cl ,e) + (define cl* (map (lambda (c) (frees (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-union (apply union-all cl*) (set-remove (frees e) binds))] + [`(letrec-values ,cl ,e) + (define cl* (map (lambda (c) (frees (cadr c))) cl)) + (define binds (apply seteq (apply append (map car cl)))) + (set-remove (set-union (frees e) (apply union-all cl*)) binds)] + [`(lambda (,args ...) ,e) (set-remove (frees e) (apply seteq args))] + [`(lambda ,args ,e) (frees e)] + [`(case-lambda [,args ,e] ...) (apply union-all (map frees e))] + [`(,sym ,e ...) + #:when (memq sym '(begin begin0 with-continuation-mark if set!)) + (apply union-all (map frees e))] + [`(quote ,_) (seteq)] + [e #:when (or (hash? e) (boolean? e) (number? e) (string? e) (bytes? e)) + (seteq)] + [(list app ...) (apply union-all (map frees app))])) + +(define (simplify-expr e ; expression to simplify + vars ; set of all mutated variables (for variable-reference-constant?) + safe-ref? ; predicate for whether referencing a variable is safe + seen-defns) ; known definitions + (define (simp e) (simplify-expr e vars safe-ref? seen-defns)) + (match e + [`(if ,e0 ,e1 ,e2) + (define e0* (simp e0)) + (case e0* + [(#t) (simp e1)] + [(#f) (simp e2)] + [else `(if ,e0* ,(simp e1) ,(simp e2))])] + [`(let-values ,cl ,e) + (define names (apply append (map car cl))) + (define simp-body (simplify-expr e vars (lambda (e) (or (memq e names) (safe-ref? e))) seen-defns)) + (define body-frees (frees simp-body)) + (define cl* (filter-map + (lambda (c) + (define vars (car c)) + (define rhs (simp (cadr c))) + (cond [(and (for/and ([v (in-list vars)]) (not (set-member? body-frees v))) + (not (any-side-effects? rhs (length vars) #:known-defns seen-defns + #:ready-variable? safe-ref?))) + #f] + [else (list vars rhs)])) + cl)) + `(let-values ,cl* ,simp-body)] + [`(letrec-values ,cl ,e) + (define names (apply append (map car cl))) + (define cl* (map (lambda (c) (list (car c) (simp (cadr c)))) cl)) + `(letrec-values ,cl* ,(simplify-expr e vars (lambda (e) (or (memq e names) (safe-ref? e))) seen-defns))] + [`(lambda (,args ...) ,e) `(lambda ,args ,(simplify-expr e vars (lambda (e) (or (memq e args) (safe-ref? e))) seen-defns))] + [`(lambda ,args ,e) `(lambda ,args ,(simp e))] + [`(case-lambda ,cl ...) + (cons 'case-lambda (for/list ([c (in-list cl)]) + (list (car c) + (simp (cadr c)))))] + [`(variable-reference-constant? (#%variable-reference ,x)) + (not (hash-ref vars x #f))] + [`(,sym ,e ...) + #:when (memq sym '(begin begin0 with-continuation-mark set!)) + `(,sym ,@(map simp e))] + [(? symbol? e) e] + [`(quote ,_) e] + [e #:when (or (boolean? e) (number? e) (string? e) (bytes? e)) + e] + [(list app ...) (map simp app)])) + +(define (simplify-definitions linklet-expr) + (log-status "Simplifying definitions...") + (define body (bootstrap:s-expr-linklet-body linklet-expr)) + + (define all-mutated-vars + (for/fold ([s (seteq)]) ([e (in-list body)]) + (cond [(defn? e) + (set-union s (mutated-vars (defn-rhs e)))] + [else (set-union s (mutated-vars e))]))) + + (define seen-defns (make-hasheq)) + (register-known-primitives! seen-defns) + + (define (safe-defn? e) + (and (defn? e) + (not (any-side-effects? (defn-rhs e) (length (defn-syms e)) #:known-defns seen-defns)))) + + (define (safe-ref? s) (hash-ref seen-defns s #f)) + + (define new-body + (let loop ([body body]) + (cond [(null? body) null] + [(defn? (car body)) + (for* ([d (in-list body)] + #:break (not (safe-defn? d)) + [s (in-list (defn-syms d))]) + (hash-set! seen-defns s (known-defined))) + (define e (car body)) + (define new-defn + (list 'define-values (defn-syms e) (simplify-expr (defn-rhs e) all-mutated-vars safe-ref? seen-defns))) + (add-defn-known! seen-defns (defn-syms e) (defn-rhs e)) + (cons new-defn (loop (cdr body)))] + [else + (define e + (simplify-expr (car body) all-mutated-vars safe-ref? seen-defns)) + (if (equal? e '(void)) + (loop (cdr body)) + (cons e + (loop (cdr body))))]))) + + (append (take linklet-expr 3) + new-body)) diff --git a/racket/src/expander/extract/symbol.rkt b/racket/src/expander/extract/symbol.rkt new file mode 100644 index 0000000000..e235415c2b --- /dev/null +++ b/racket/src/expander/extract/symbol.rkt @@ -0,0 +1,38 @@ +#lang racket +(require "../common/set.rkt") + +(provide all-used-symbols + distinct-symbol + substitute-symbols) + +;; We only have to consider symbols and pairs, because we're looking +;; of variables in a `linklet` form. Also, since there's no shadowing +;; of primitives, we can be especially simplistic about "parsing" to +;; detect `quote`. +(define (all-used-symbols s) + (let loop ([s s] [used (seteq)]) + (cond + [(symbol? s) (set-add used s)] + [(pair? s) + (if (eq? (car s) 'quote) + used + (loop (cdr s) (loop (car s) used)))] + [else used]))) + +;; Pick a symbol like `sym` that's not in the set `used` +(define (distinct-symbol sym used) + (let loop ([n 1]) + (define s (string->symbol (format "~a$~a" sym n))) + (if (set-member? used s) + (loop (add1 n)) + s))) + +(define (substitute-symbols s substs) + (let loop ([s s]) + (cond + [(symbol? s) (hash-ref substs s s)] + [(pair? s) + (if (eq? (car s) 'quote) + s + (cons (loop (car s)) (loop (cdr s))))] + [else s]))) diff --git a/racket/src/expander/extract/underscore.rkt b/racket/src/expander/extract/underscore.rkt new file mode 100644 index 0000000000..37919d57cf --- /dev/null +++ b/racket/src/expander/extract/underscore.rkt @@ -0,0 +1,40 @@ +#lang racket/base + +(provide simplify-underscore-numbers) + +;; Small changes to the input code can trigger lots of renumberings +;; for local variables, where the expander adds "_" suffixes to +;; generate local-variable names, and the ""s count up across all +;; symbols. Renumber with symbol-specific counting to reduce +;; unneccessary changes to generated code. A simple strategy works +;; because no primitive or exported name has a "_" suffix. + +(define (simplify-underscore-numbers s) + (define replacements (make-hasheq)) + (define base-counts (make-hasheq)) + (let loop ([s s]) + (cond + [(symbol? s) + (cond + [(hash-ref replacements s #f) + => (lambda (r) r)] + [else + (define str (symbol->string s)) + (define m (regexp-match-positions #rx"_[0-9]+$" str)) + (cond + [(not m) + (hash-set! replacements s s) + s] + [else + (define base (substring str 0 (caar m))) + (define base-s (string->symbol base)) + (define n (hash-ref base-counts base-s 0)) + (hash-set! base-counts base-s (add1 n)) + (define r (string->symbol (format "~a_~a" base n))) + (hash-set! replacements s r) + r])])] + [(pair? s) + (if (eq? (car s) 'quote) + s + (cons (loop (car s)) (loop (cdr s))))] + [else s]))) diff --git a/racket/src/expander/extract/variable.rkt b/racket/src/expander/extract/variable.rkt new file mode 100644 index 0000000000..861285d4b3 --- /dev/null +++ b/racket/src/expander/extract/variable.rkt @@ -0,0 +1,8 @@ +#lang racket/base + +(provide (struct-out variable)) + +;; Represents a variable that is exported by a used linklet: +(struct variable (link ; link + name) ; symbol + #:prefab) diff --git a/racket/src/expander/host/correlate-syntax.rkt b/racket/src/expander/host/correlate-syntax.rkt new file mode 100644 index 0000000000..20ba00c598 --- /dev/null +++ b/racket/src/expander/host/correlate-syntax.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require racket/private/primitive-table) + +;; Get host notion of syntax for `compile-linklet`. + +;; This module uses `primitive-table` from '#%linklet instead of from +;; "linklet.rkt". When bootstrapping, the underlying values are +;; different. + +(define-syntax-rule (bounce id ...) + (begin + (provide id ...) + (import-from-primitive-table #%kernel id ...))) + +(bounce datum->syntax syntax->datum syntax-property-symbol-keys + syntax-property syntax-span syntax-position syntax-column + syntax-line syntax-source syntax-e syntax?) diff --git a/racket/src/expander/host/correlate.rkt b/racket/src/expander/host/correlate.rkt new file mode 100644 index 0000000000..f3d194522d --- /dev/null +++ b/racket/src/expander/host/correlate.rkt @@ -0,0 +1,111 @@ +#lang racket/base +(require "correlate-syntax.rkt" + "../syntax/datum-map.rkt" + "../common/make-match.rkt") + +;; A "correlated" is the host's notion of syntax objects for +;; `compile-linklet`, which is an S-expression with source locations +;; and properties (but no scopes). + +;; For historical reasons, the names here can be a bit confusing. The +;; host layer provides functions named `syntax?`, `datum->syntax`, +;; etc., but these are wrapped here by functions with the names +;; `correlated?`, `datum->correlated`, etc. Additionally, +;; `racket/linklet` obtains the names `syntax?` etc directly from the +;; `#%kernel` primitive table, and provides them under the name +;; `correlated?` etc. This expander defines other functions with the +;; names `syntax?` etc (see "../syntax/syntax.rkt") which are the +;; syntax objects used by this expander. + +;; When the expander is run as a regular Racket program, the host +;; notion of syntax is a full Racket syntax object, but the expander +;; ignores all but the contained datum, the properties, and the source +;; location. + +;; When the expander is used as the expander for Racket on the older, +;; C-based runtime, it uses a C-level implementation of syntax +;; objects, Scheme_Stx, which contains only the features needed +;; here. In that implementation, the names implemented are `syntax?`, +;; etc. + +;; When the expander is run as the Racket expander on the Chez +;; Scheme-based runtime, it uses a record named `correlated` which +;; provides only the features needed here. There, the implemented +;; operations are named `correlated?`, etc, but are provided to this +;; expander as `syntax?`, etc. + +(provide correlate + correlated? + datum->correlated + correlated-e + correlated-cadr + correlated-length + correlated->list + correlated->datum + correlated-property + correlated-property-symbol-keys + define-correlated-match + + correlated-source + correlated-line + correlated-column + correlated-position + correlated-span) + +(define (correlate src-e s-exp) + (define e (datum->correlated s-exp src-e)) + (define maybe-n (syntax-property src-e 'inferred-name)) + (if maybe-n + (syntax-property e 'inferred-name maybe-n) + e)) + +(define (correlated? e) + (syntax? e)) + +(define (datum->correlated d [srcloc #f]) + (datum->syntax #f d srcloc)) + +(define (correlated-e e) + (if (syntax? e) + (syntax-e e) + e)) + +(define (correlated-cadr e) + (car (correlated-e (cdr (correlated-e e))))) + +(define (correlated-length e) + (define l (correlated-e e)) + (and (list? l) + (length l))) + +(define (correlated->list e) + (let loop ([e e]) + (cond + [(list? e) e] + [(pair? e) (cons (car e) (loop (cdr e)))] + [(null? e) null] + [(syntax? e) (loop (syntax-e e))] + [else (error 'correlated->list "not a list")]))) + +(define (correlated->datum e) + (datum-map e (lambda (tail? d) + (if (syntax? d) + (syntax->datum d) + d)))) + +(define (correlated-property-symbol-keys e) + (syntax-property-symbol-keys e)) + +(define correlated-property + (case-lambda + [(e k) (syntax-property e k)] + [(e k v) (syntax-property e k v)])) + +(define-define-match define-correlated-match + syntax? syntax-e (lambda (false str e) (error str))) + +(define (correlated-source s) (syntax-source s)) +(define (correlated-line s) (syntax-line s)) +(define (correlated-column s) (syntax-column s)) +(define (correlated-position s) (syntax-position s)) +(define (correlated-span s) (syntax-span s)) diff --git a/racket/src/expander/host/linklet.rkt b/racket/src/expander/host/linklet.rkt new file mode 100644 index 0000000000..6b35fabf2e --- /dev/null +++ b/racket/src/expander/host/linklet.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(require racket/private/primitive-table + "../run/linklet-operation.rkt") + +;; The `racket/private/primitive-table` module uses only +;; `primitive-table` directly, so that's the only function needed for +;; bootstrapping --- and generally so we can replace the linklet +;; implementation for bootstrapping. See also "../run/linklet.rkt". + +(define-syntax-rule (bounce id ...) + (begin + (provide id ...) + (import-from-primitive-table + ;; As a hook for bootstrapping, first check for a replacement of + ;; the primitive '#%linklet module: + (#%bootstrap-linklet #%linklet) + id + ...))) + +(linklet-operations=> bounce) + +(void + (unless variable-reference-constant? + (error "broken '#%linklet primitive table; maybe you need to use \"bootstrap-run.rkt\""))) diff --git a/racket/src/expander/host/reader-syntax-to-syntax.rkt b/racket/src/expander/host/reader-syntax-to-syntax.rkt new file mode 100644 index 0000000000..303dd9b5d0 --- /dev/null +++ b/racket/src/expander/host/reader-syntax-to-syntax.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/original.rkt" + "../syntax/datum-map.rkt" + (prefix-in reader: + (only-in "reader-syntax.rkt" + syntax? syntax-e syntax-property + syntax-property-symbol-keys + syntax-source syntax-line syntax-column + syntax-position syntax-span))) + +(provide reader-syntax->syntax) + +(define (reader-syntax->syntax v) + (datum-map v + (lambda (tail? v) + (cond + [(reader:syntax? v) + (define e (reader:syntax-e v)) + (cond + [(syntax? e) + ;; Readtable, #lang, and #reader callbacks can lead to a + ;; reader syntax wrapper on our syntax + e] + [else + (define s + (struct-copy syntax empty-syntax + [content (reader-syntax->syntax (reader:syntax-e v))] + [srcloc (srcloc (reader:syntax-source v) + (reader:syntax-line v) + (reader:syntax-column v) + (reader:syntax-position v) + (reader:syntax-span v))] + [props (case (reader:syntax-property v 'paren-shape) + [(#\[) original-square-props] + [(#\{) original-curly-props] + [else original-props])])) + (define keys (reader:syntax-property-symbol-keys v)) + (cond + [(null? keys) s] + [(and (null? (cdr keys)) (eq? (car keys) 'paren-shape)) s] + [else (for/fold ([s s]) ([key (in-list keys)]) + (syntax-property s key (reader:syntax-property v key) #t))])])] + [else v])))) + +(define original-props + (syntax-props (syntax-property empty-syntax original-property-sym #t))) +(define original-square-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\[))) +(define original-curly-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\{))) diff --git a/racket/src/expander/host/reader-syntax.rkt b/racket/src/expander/host/reader-syntax.rkt new file mode 100644 index 0000000000..7dd79ab887 --- /dev/null +++ b/racket/src/expander/host/reader-syntax.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(require racket/private/primitive-table) + +;; Get host notion of syntax for `datum->syntax`, etc. Bounce the +;; references to these operations through `primitive-table`, so that +;; the bootstrapping process doesn't complain about using them. + +;; Note that if the host has a `compile-linklet`, these syntax objects +;; may not be compatible with it. See "correlate-syntax.rkt" for +;; `compile-linklet`-compatible variants. + +(define-syntax-rule (bounce id ...) + (begin + (provide id ...) + (import-from-primitive-table #%kernel id ...))) + +(bounce datum->syntax syntax->datum syntax-property-symbol-keys + syntax-property syntax-span syntax-position syntax-column + syntax-line syntax-source syntax-e syntax?) diff --git a/racket/src/expander/host/string-to-number.rkt b/racket/src/expander/host/string-to-number.rkt new file mode 100644 index 0000000000..b6d52e46da --- /dev/null +++ b/racket/src/expander/host/string-to-number.rkt @@ -0,0 +1,11 @@ +#lang racket/base +(require racket/private/primitive-table) + +;; Get host implementation of `string->number` for very basic number +;; parsing. Going through `primitive-table` prevents the reference +;; from being tied back to out implementation here when flattening the +;; expander+reader. + +(provide string->number) + +(import-from-primitive-table #%kernel string->number) diff --git a/racket/src/expander/host/syntax-to-reader-syntax.rkt b/racket/src/expander/host/syntax-to-reader-syntax.rkt new file mode 100644 index 0000000000..185d486a3e --- /dev/null +++ b/racket/src/expander/host/syntax-to-reader-syntax.rkt @@ -0,0 +1,28 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/property.rkt" + "../syntax/scope.rkt" + (only-in "reader-syntax.rkt" + [datum->syntax reader:datum->syntax] + [syntax-property reader:syntax-property])) + +(provide syntax->reader-syntax + srcloc->vector) + +(define (syntax->reader-syntax v) + (syntax-map v + (lambda (tail? v) v) + (lambda (orig-s d) + (define s (reader:datum->syntax #f d (srcloc->vector (syntax-srcloc orig-s)))) + (define keys (syntax-property-symbol-keys orig-s)) + (for/fold ([s s]) ([key (in-list keys)]) + (reader:syntax-property s key (syntax-property orig-s key)))) + syntax-e)) + +(define (srcloc->vector s) + (and s + (vector (srcloc-source s) + (srcloc-line s) + (srcloc-column s) + (srcloc-position s) + (srcloc-span s)))) diff --git a/racket/src/expander/info.rkt b/racket/src/expander/info.rkt new file mode 100644 index 0000000000..dbc7b3d96e --- /dev/null +++ b/racket/src/expander/info.rkt @@ -0,0 +1,13 @@ +#lang info + +(define collection "expander") + +(define deps `(["base" #:version "6.6.0.2"] + "zo-lib" + "compiler-lib")) + +(define build-deps `("at-exp-lib")) + +(define pkg-desc "Racket's implementation of macros, modules, and top-level evaluation") + +(define pkg-authors '(mflatt)) diff --git a/racket/src/expander/main.rkt b/racket/src/expander/main.rkt new file mode 100644 index 0000000000..785e87ab17 --- /dev/null +++ b/racket/src/expander/main.rkt @@ -0,0 +1,179 @@ +#lang racket/base +(require "common/set.rkt" + "common/module-path.rkt" + "namespace/namespace.rkt" + "eval/main.rkt" + "eval/dynamic-require.rkt" + "eval/reflect.rkt" + "eval/load.rkt" + "eval/collection.rkt" + "eval/parameter.rkt" + "read/api.rkt" + "read/primitive-parameter.rkt" + "namespace/api.rkt" + (prefix-in wrapper: "eval/api.rkt") + "namespace/attach.rkt" + "namespace/api-module.rkt" + "namespace/core.rkt" + "namespace/primitive-module.rkt" + "expand/missing-module.rkt" + "boot/kernel.rkt" + "boot/read-primitive.rkt" + "boot/main-primitive.rkt" + "boot/utils-primitive.rkt" + "boot/expobs-primitive.rkt" + "boot/place-primitive.rkt" + "boot/linklet-primitive.rkt" + "boot/runtime-primitive.rkt" + "boot/handler.rkt" + "syntax/api.rkt" + (only-in racket/private/config find-main-config)) + +;; All bindings provided by this module must correspond to variables +;; (as opposed to syntax). Provided functions must not accept keyword +;; arguments, both because keyword support involves syntax bindings +;; and because an embedding context won't be able to supply keyword +;; arguments. + +(provide boot ; installs handlers: eval, module name resolver, etc. + seal + + ;; These are direct functions, not ones that use handlers: + expand + compile + eval + read + + load + load/use-compiled + load-extension + + current-eval + current-compile + current-load + current-load/use-compiled + + find-library-collection-paths + find-library-collection-links + find-main-config + + current-library-collection-paths + current-library-collection-links + use-compiled-file-paths + current-compiled-file-roots + use-compiled-file-check + use-collection-link-paths + use-user-specific-search-paths + + compile-to-linklets + + syntax? + read-syntax + datum->syntax syntax->datum + identifier-binding + datum->kernel-syntax + maybe-syntax->datum ; for reader callbacks via a readtable, etc. + + make-namespace + current-namespace + namespace->instance + + namespace-syntax-introduce + namespace-require + dynamic-require + module-declared? + module-predefined? + module->language-info + maybe-raise-missing-module + + namespace-module-identifier + namespace-attach-module + namespace-attach-module-declaration + namespace-mapped-symbols + + module-path-index? + module-path-index-join + resolved-module-path? + module-path? + + declare-primitive-module! ; to support "extensions" + + embedded-load ; for -k + + ;; This functions are provided for basic testing + ;; (such as "demo.rkt") + syntax? syntax-e + identifier? + syntax-property + syntax-debug-info + module-compiled-exports + module-compiled-indirect-exports + read-accept-compiled + + syntax-shift-phase-level + bound-identifier=?) + +;; ---------------------------------------- + +;; Register core forms: +(require "expand/expr.rkt" + "expand/module.rkt" + "expand/top.rkt") + +;; Register core primitives: +(require "boot/core-primitive.rkt") + +;; ---------------------------------------- +;; Initial namespace + +(define ns (make-namespace)) +(void + (begin + (declare-core-module! ns) + (declare-hash-based-module! '#%read read-primitives #:namespace ns) + (declare-hash-based-module! '#%main main-primitives #:namespace ns) + (declare-hash-based-module! '#%utils utils-primitives #:namespace ns) + (declare-hash-based-module! '#%place-struct place-struct-primitives #:namespace ns + ;; Treat place creation as "unsafe", since the new place starts with + ;; permissive guards that can access unsafe features that affect + ;; existing places + #:protected '(dynamic-place)) + (declare-hash-based-module! '#%boot boot-primitives #:namespace ns) + (let ([linklet-primitives + ;; Remove symbols that are in the '#%linklet primitive table + ;; but provided by `#%kernel`: + (hash-remove (hash-remove linklet-primitives + 'variable-reference?) + 'variable-reference-constant?)]) + (declare-hash-based-module! '#%linklet linklet-primitives #:namespace ns + #:primitive? #t + #:register-builtin? #t)) + (declare-hash-based-module! '#%expobs expobs-primitives #:namespace ns + #:protected? #t) + (declare-kernel-module! ns + #:eval eval + #:main-ids (for/set ([name (in-hash-keys main-primitives)]) + name) + #:read-ids (for/set ([name (in-hash-keys read-primitives)]) + name)) + (for ([name (in-list runtime-instances)] + #:unless (eq? name '#%kernel)) + (copy-runtime-module! name + #:namespace ns + #:protected? (or (eq? name '#%foreign) + (eq? name '#%futures) + (eq? name '#%unsafe)))) + (declare-reexporting-module! '#%builtin (list* '#%place-struct + '#%utils + '#%boot + '#%expobs + '#%linklet + runtime-instances) + #:namespace ns + #:reexport? #f) + (current-namespace ns) + + (dynamic-require ''#%kernel 0))) + +(define (datum->kernel-syntax s) + (datum->syntax core-stx s)) diff --git a/racket/src/expander/namespace/api-module.rkt b/racket/src/expander/namespace/api-module.rkt new file mode 100644 index 0000000000..cf7b855ef2 --- /dev/null +++ b/racket/src/expander/namespace/api-module.rkt @@ -0,0 +1,134 @@ +#lang racket/base +(require "../common/module-path.rkt" + "../expand/root-expand-context.rkt" + "namespace.rkt" + (submod "namespace.rkt" for-module) + "module.rkt" + "provide-for-api.rkt" + "provided.rkt" + (submod "module.rkt" for-module-reflect) + "../common/contract.rkt") + +(provide module-declared? + module-predefined? + module->language-info + module->imports + module->exports + module->indirect-exports + module-provide-protected? + module->namespace + namespace-unprotect-module) + +;; ---------------------------------------- + +(define (module-declared? mod [load? #f]) + (unless (module-reference? mod) + (raise-argument-error 'module-declared? module-reference-str mod)) + (define ns (current-namespace)) + (define name (reference->resolved-module-path mod #:load? load?)) + (and (namespace->module ns name) #t)) + +(define (module-predefined? mod) + (unless (module-reference? mod) + (raise-argument-error 'module-predefined? module-reference-str mod)) + (define ns (current-namespace)) + (define name (reference->resolved-module-path mod #:load? #f)) + (define m (namespace->module ns name)) + (and m (module-is-predefined? m))) + +(define (module-> extract who mod [load? #f]) + (unless (module-reference? mod) + (raise-argument-error who module-reference-str mod)) + (define m (namespace->module/complain who + (current-namespace) + (reference->resolved-module-path mod #:load? load?))) + (extract m)) + +(define (module->language-info mod [load? #f]) + (module-> module-language-info 'module->language-info mod load?)) + +(define (module->imports mod) + (module-> module-requires 'module->imports mod)) + +(define (module->exports mod) + (define-values (provides self) + (module-> (lambda (m) (values (module-provides m) (module-self m))) 'module->exports mod)) + (provides->api-provides provides self)) + +(define (module->indirect-exports mod) + (module-> (lambda (m) + (variables->api-nonprovides (module-provides m) + ((module-get-all-variables m)))) + 'module->indirect-exports mod)) + +(define (module-provide-protected? mod sym) + (module-> (lambda (m) + (define b/p (hash-ref (module-provides m) sym #f)) + (or (not b/p) (provided-as-protected? b/p))) + 'module-provide-protected? mod)) + +(define (module->namespace mod [ns (current-namespace)]) + (unless (module-reference? mod) + (raise-argument-error 'module->namespace module-reference-str mod)) + (check 'module->namespace namespace? ns) + (define name (reference->resolved-module-path mod #:load? #t)) + (define phase (namespace-phase ns)) + (define m-ns (namespace->module-namespace ns name phase)) + (unless m-ns + ;; Check for declaration: + (namespace->module/complain 'module->namespace ns name) + ;; Must be declared, but not instantiated + (raise-arguments-error 'module->namespace + "module not instantiated in the current namespace" + "name" name)) + (unless (inspector-superior? (current-code-inspector) (namespace-inspector m-ns)) + (raise-arguments-error 'module->namespace + "current code inspector cannot access namespace of module" + "module name" name)) + (unless (namespace-get-root-expand-ctx m-ns) + ;; Instantiating the module didn't install a context, so make one now + (namespace-set-root-expand-ctx! m-ns (make-root-expand-context))) + ;; Ensure that the module is available + (namespace-module-make-available! ns (namespace-mpi m-ns) phase) + m-ns) + +(define (namespace-unprotect-module insp mod [ns (current-namespace)]) + (check 'namespace-unprotect-module inspector? insp) + (check 'namespace-unprotect-module module-path? mod) + (check 'namespace-unprotect-module namespace? ns) + (define name (reference->resolved-module-path mod #:load? #f)) + (define phase (namespace-phase ns)) + (define m-ns (namespace->module-namespace ns name phase)) + (unless m-ns + (raise-arguments-error 'namespace-unprotect-module + "module not instantiated" + "module name" name)) + (when (inspector-superior? insp (namespace-inspector m-ns)) + (set-namespace-inspector! m-ns (make-inspector (current-code-inspector))))) + +;; ---------------------------------------- + +(define (namespace->module/complain who ns name) + (or (namespace->module ns name) + (raise-arguments-error who + "unknown module in the current namespace" + "name" name))) + +;; ---------------------------------------- + +(define (module-reference? mod) + (or (module-path? mod) + (module-path-index? mod) + (resolved-module-path? mod))) + +(define module-reference-str + "(or/c module-path? module-path-index? resolved-module-path?)") + +(define (reference->resolved-module-path mod #:load? load?) + (cond + [(resolved-module-path? mod) mod] + [else + (define mpi (if (module-path-index? mod) + mod + (module-path-index-join mod #f))) + (module-path-index-resolve mpi load?)])) diff --git a/racket/src/expander/namespace/api.rkt b/racket/src/expander/namespace/api.rkt new file mode 100644 index 0000000000..9f22fb5a05 --- /dev/null +++ b/racket/src/expander/namespace/api.rkt @@ -0,0 +1,253 @@ +#lang racket/base +(require (only-in "../syntax/syntax.rkt" syntax-mpi-shifts empty-syntax) + (only-in "../syntax/scope.rkt" add-scopes push-scope syntax-scope-set) + (only-in "../syntax/fallback.rkt" fallback-first) + (only-in "../syntax/binding.rkt" resolve+shift syntax-transfer-shifts) + "../syntax/module-binding.rkt" + "../syntax/api.rkt" + "../syntax/error.rkt" + "../syntax/mapped-name.rkt" + "namespace.rkt" + "module.rkt" + "attach.rkt" + "core.rkt" + "../common/set.rkt" + "../common/phase.rkt" + "../expand/require+provide.rkt" + "../expand/context.rkt" + "../expand/require.rkt" + "../common/module-path.rkt" + "../common/contract.rkt" + "../expand/protect.rkt" + "../expand/env.rkt" + "../expand/binding-to-module.rkt" + "../host/linklet.rkt") + +(provide make-empty-namespace + + namespace-syntax-introduce + namespace-module-identifier + namespace-symbol->identifier + + namespace-require + namespace-require/copy + namespace-require/constant + namespace-require/expansion-time + + namespace-variable-value + namespace-set-variable-value! + namespace-undefine-variable! + + namespace-mapped-symbols + + namespace-base-phase) + +(define (make-empty-namespace) + (define current-ns (current-namespace)) + (define phase (namespace-phase current-ns)) + (define ns (namespace->namespace-at-phase (make-namespace) + phase)) + ;; For historical reasons, an empty namespace isn't actually + ;; empty; we always carry '#%kernel along + (namespace-attach-module current-ns ''#%kernel ns) + (namespace-primitive-module-visit! ns '#%kernel) + ns) + +(define (namespace-syntax-introduce s [ns (current-namespace)]) + (check 'namespace-syntax-introduce syntax? s) + (check 'namespace-syntax-introduce namespace? ns) + (define root-ctx (namespace-get-root-expand-ctx ns)) + (define post-scope (root-expand-context-post-expansion-scope root-ctx)) + (define other-namespace-scopes (for/list ([sc (in-set + ;; `all-scopes-stx` corresponds to the initial import + (syntax-scope-set (root-expand-context-all-scopes-stx root-ctx) + (namespace-phase ns)))] + #:unless (equal? sc post-scope)) + sc)) + (define (add-ns-scopes s) + (syntax-transfer-shifts (add-scopes (push-scope s post-scope) + other-namespace-scopes) + (root-expand-context-all-scopes-stx root-ctx) + (or (namespace-declaration-inspector ns) + (current-code-inspector)) + #:non-source? #t)) + (define maybe-module-id + (and (pair? (syntax-e s)) + (identifier? (car (syntax-e s))) + (add-ns-scopes (car (syntax-e s))))) + (cond + [(and maybe-module-id + (free-identifier=? maybe-module-id + (namespace-module-identifier ns) + (namespace-phase ns))) + ;; The given syntax object starts `module`, so only add scope to `module`: + (datum->syntax s (cons maybe-module-id (cdr (syntax-e s))) s s)] + [else + ;; Add scope everywhere: + (add-ns-scopes s)])) + +(define (namespace-module-identifier [where (current-namespace)]) + (unless (or (namespace? where) + (phase? where)) + (raise-argument-error 'namespace-module-identifier + (string-append "(or/c namespace? " phase?-string ")") + where)) + (datum->syntax (syntax-shift-phase-level core-stx + (if (namespace? where) + (namespace-phase where) + where)) + 'module)) + +(define (namespace-symbol->identifier sym) + (check 'namespace-symbol->identifier symbol? sym) + (namespace-syntax-introduce (datum->syntax #f sym))) + +;; ---------------------------------------- + +(define (do-namespace-require #:run? [run? #t] #:visit? [visit? #f] + who req ns + #:copy-variable-phase-level [copy-variable-phase-level #f] + #:copy-variable-as-constant? [copy-variable-as-constant? #f] + #:skip-variable-phase-level [skip-variable-phase-level #f]) + (check who namespace? ns) + (define ctx-stx (add-scopes empty-syntax + (root-expand-context-module-scopes + (namespace-get-root-expand-ctx ns)))) + (cond + [(or (module-path-index? req) + (module-path? req)) + (perform-require! (if (module-path-index? req) + req + (module-path-index-join req #f)) + #f #f + ctx-stx ns + #:run? run? + #:visit? visit? + #:phase-shift (namespace-phase ns) + #:run-phase (namespace-phase ns) + #:copy-variable-phase-level copy-variable-phase-level + #:copy-variable-as-constant? copy-variable-as-constant? + #:skip-variable-phase-level skip-variable-phase-level + #:who who)] + [else + ;; Slow way -- to allow renaming, check for conflicts, etc. + (parse-and-perform-requires! #:run? run? + #:visit? visit? + (list (datum->syntax ctx-stx req)) + #f + ns + (namespace-phase ns) + (make-requires+provides #f) + #:skip-variable-phase-level skip-variable-phase-level + #:who who)])) + +(define (namespace-require req [ns (current-namespace)]) + (do-namespace-require 'namespace-require req ns)) + +(define (namespace-require/expansion-time req [ns (current-namespace)]) + (do-namespace-require #:run? #f #:visit? #t 'namespace-require/expansion-time req ns)) + +(define (namespace-require/constant req [ns (current-namespace)]) + (do-namespace-require 'namespace-require/constant req ns + #:copy-variable-phase-level 0 + #:copy-variable-as-constant? #t)) + +(define (namespace-require/copy req [ns (current-namespace)]) + (do-namespace-require 'namespace-require/copy req ns + #:copy-variable-phase-level 0 + #:skip-variable-phase-level 0)) + +;; ---------------------------------------- + +(define (namespace-variable-value sym + [use-mapping? #f] + [failure-thunk #f] + [ns (current-namespace)]) + (check 'namespace-variable-value symbol? sym) + (unless (or (not failure-thunk) + (and (procedure? failure-thunk) + (procedure-arity-includes? failure-thunk 0))) + (raise-argument-error 'namespace-variable-value + "(or/c #f (procedure-arity-includes/c 0))" + failure-thunk)) + (check 'namespace-variable-value namespace? ns) + ((let/ec escape + (define-values (var-ns var-phase-level var-sym) + (cond + [use-mapping? + (define id (datum->syntax #f sym)) + (define b (resolve+shift/extra-inspector (namespace-syntax-introduce id ns) + (namespace-phase ns) + ns)) + (when b (namespace-visit-available-modules! ns)) + (define-values (v primitive? extra-inspector) + (if b + (binding-lookup b empty-env null ns (namespace-phase ns) id) + (values variable #f #f))) + (unless (variable? v) + (escape + (or failure-thunk + (lambda () + (raise (exn:fail:syntax + (format (string-append "namespace-variable-value: bound to syntax\n" + " in: ~s") + sym) + (current-continuation-marks) + null)))))) + (if (module-binding? b) + (values (if (top-level-module-path-index? (module-binding-module b)) + ns + (module-instance-namespace (binding->module-instance b ns (namespace-phase ns) id))) + (module-binding-phase b) + (module-binding-sym b)) + (values ns (namespace-phase ns) sym))] + [else + (values ns (namespace-phase ns) sym)])) + (define val + (namespace-get-variable var-ns var-phase-level var-sym + (lambda () (escape + (or failure-thunk + (raise (exn:fail:contract:variable + (format (string-append + "namespace-variable-value: given name is not defined\n" + " name: ~s") + sym) + (current-continuation-marks) + sym))))))) + (lambda () val)))) + +(define (namespace-set-variable-value! sym + val + [map? #f] + [ns (current-namespace)] + [as-constant? #f]) + (check 'namespace-variable-value symbol? sym) + (check 'namespace-variable-value namespace? ns) + (namespace-set-variable! ns (namespace-phase ns) sym val as-constant?) + (when map? + (namespace-unset-transformer! ns (namespace-phase ns) sym) + (define id (datum->syntax #f sym)) + (add-binding! (namespace-syntax-introduce id ns) + (make-module-binding (namespace-mpi ns) + (namespace-phase ns) + sym) + (namespace-phase ns)))) + +(define (namespace-undefine-variable! sym + [ns (current-namespace)]) + (check 'namespace-variable-value symbol? sym) + (check 'namespace-variable-value namespace? ns) + (namespace-unset-variable! ns (namespace-phase ns) sym)) + +(define (namespace-mapped-symbols [ns (current-namespace)]) + (check 'namespace-mapped-symbols namespace? ns) + (set->list + (set-union + (syntax-mapped-names (root-expand-context-all-scopes-stx (namespace-get-root-expand-ctx ns)) + (namespace-phase ns)) + (list->set + (instance-variable-names (namespace->instance ns 0)))))) + +(define (namespace-base-phase [ns (current-namespace)]) + (check 'namespace-base-phase namespace? ns) + (namespace-phase ns)) diff --git a/racket/src/expander/namespace/attach.rkt b/racket/src/expander/namespace/attach.rkt new file mode 100644 index 0000000000..157f5f8361 --- /dev/null +++ b/racket/src/expander/namespace/attach.rkt @@ -0,0 +1,150 @@ +#lang racket/base +(require "namespace.rkt" + "module.rkt" + "../common/module-path.rkt" + "../common/phase.rkt" + "../common/contract.rkt") + +(provide namespace-attach-module + namespace-attach-module-declaration) + +(define (namespace-attach-module src-namespace + mod-path + [dest-namespace (current-namespace)]) + (do-attach-module 'namespace-attach-module + src-namespace mod-path dest-namespace + #:attach-instances? #t)) + +(define (namespace-attach-module-declaration src-namespace + mod-path + [dest-namespace (current-namespace)]) + (do-attach-module 'namespace-attach-module-declaration + src-namespace mod-path dest-namespace + #:attach-instances? #f)) + +(define (do-attach-module who + src-namespace mod-path dest-namespace + #:attach-instances? [attach-instances? #f]) + (check who namespace? src-namespace) + (unless (or (module-path? mod-path) + (resolved-module-path? mod-path)) + (raise-argument-error who "(or/c module-path? resolved-module-path?)" mod-path)) + (check who namespace? dest-namespace) + + (define phase (namespace-phase src-namespace)) + (unless (eqv? phase (namespace-phase dest-namespace)) + (raise-arguments-error who + "source and destination namespace phases do not match" + "source phase" phase + "destination phase" (namespace-phase dest-namespace))) + + (define todo (make-hasheq)) ; module name -> phase -> namespace-or-#f + + (define missing (gensym 'missing)) + + ;; Loop to check and decide what to transfer + (let loop ([mpi (module-path-index-join + (if (resolved-module-path? mod-path) + (resolved-module-path->module-path mod-path) + mod-path) + #f)] + [phase phase] + [attach-instances? attach-instances?] + [attach-phase phase]) + (define mod-name (parameterize ([current-namespace src-namespace]) + (module-path-index-resolve mpi))) + + (define attach-this-instance? (and attach-instances? (eqv? phase attach-phase))) + (define m-ns (hash-ref (hash-ref todo mod-name #hasheqv()) phase missing)) + + (when (or (eq? missing m-ns) + (and attach-this-instance? (not m-ns))) + (define m (namespace->module src-namespace mod-name)) + (unless m + (raise-arguments-error who + "module not declared (in the source namespace)" + "module name" mod-name)) + + (cond + [(and (module-cross-phase-persistent? m) + (not (label-phase? phase)) + (not (zero-phase? phase))) + ;; Always handle a cross-phase persistent module at phase 0, which means + ;; that all phases will get the same instance if any instance is attached + (loop mpi 0 attach-instances? 0)] + [else + (define already-m (namespace->module dest-namespace mod-name)) + (when (and already-m (not (eq? already-m m))) + (raise-arguments-error who + "a different declaration is already in the destination namespace" + "module name" mod-name)) + + (define-values (m-ns already?) + (cond + [attach-this-instance? + (define m-ns (namespace->module-namespace src-namespace mod-name phase)) + (unless m-ns + (raise-arguments-error who + "module not instantiated (in the source namespace)" + "module name" mod-name)) + + (define already-m-ns (and already-m + (namespace->module-namespace dest-namespace mod-name phase))) + (when (and already-m-ns + (not (eq? m-ns already-m-ns)) + (not (namespace-same-instance? m-ns already-m-ns))) + (raise-arguments-error who + "a different instance is already in the destination namespace" + "module name" mod-name)) + + (values m-ns (and already-m-ns #t))] + [else + (when (and (label-phase? phase) + (not (namespace->module-namespace src-namespace mod-name phase))) + ;; Force instantiation of for-label instance, which ensures that + ;; required modules are declared + (parameterize ([current-namespace src-namespace]) + (namespace-module-instantiate! src-namespace mpi phase))) + + (values #f (and already-m #t))])) + + (hash-update! todo mod-name (lambda (ht) (hash-set ht phase m-ns)) #hasheqv()) + + (unless already? + (for* ([phase+reqs (in-list (module-requires m))] + [req (in-list (cdr phase+reqs))]) + (loop (module-path-index-shift req + (module-self m) + mpi) + (phase+ phase (car phase+reqs)) + attach-instances? + attach-phase)) + (for ([submod-name (in-list (module-submodule-names m))]) + (loop (module-path-index-join `(submod "." ,submod-name) mpi) + ;; Attach submodules at phase #f, which allows + ;; dependencies to be loaded if they're not declared + ;; already, since the submodule has not necessarily + ;; been instantiated + #f + #f + attach-phase)) + (when (module-supermodule-name m) + ;; Associated supermodule is treated like an associated submodule + (loop (module-path-index-join `(submod "..") mpi) #f #f attach-phase)))]))) + + ;; Perform decided transfers + (for* ([(mod-name phases) (in-hash todo)] + [(phase m-ns) (in-hash phases)]) + (define m (namespace->module src-namespace mod-name)) + (module-force-bulk-binding! m src-namespace) + (declare-module! dest-namespace m mod-name) + (when m-ns + (namespace-record-module-instance-attached! src-namespace mod-name phase) + (or (namespace->module-namespace dest-namespace mod-name phase) + (namespace-install-module-namespace! dest-namespace mod-name phase m m-ns)))) + + ;; Send resolver notifications for attached declarations + (define mnr (current-module-name-resolver)) + (parameterize ([current-namespace dest-namespace]) + (for* ([mod-name (in-hash-keys todo)]) + (mnr mod-name src-namespace)))) diff --git a/racket/src/expander/namespace/core.rkt b/racket/src/expander/namespace/core.rkt new file mode 100644 index 0000000000..75ccded1f8 --- /dev/null +++ b/racket/src/expander/namespace/core.rkt @@ -0,0 +1,124 @@ +#lang racket/base +(require "../common/set.rkt" + "../syntax/syntax.rkt" + "../syntax/scope.rkt" + "../syntax/binding.rkt" + "../expand/env.rkt" + "../syntax/match.rkt" + "../common/module-path.rkt" + "provided.rkt" + "namespace.rkt" + "module.rkt") + +(provide core-stx + core-id + + add-core-form! + add-core-primitive! + + declare-core-module! + + core-module-name + core-mpi + core-form-sym) + +;; Accumulate all core bindings in `core-scope`, so we can +;; easily generate a reference to a core form using `core-stx`: +(define core-scope (new-multi-scope)) +(define core-stx (add-scope empty-syntax core-scope)) + +(define core-module-name (make-resolved-module-path '#%core)) +(define core-mpi (module-path-index-join ''#%core #f)) + +;; The expander needs to synthesize some core references + +(define id-cache-0 (make-hasheq)) +(define id-cache-1 (make-hasheq)) + +(define (core-id sym phase) + (cond + [(eqv? phase 0) + (or (hash-ref id-cache-0 sym #f) + (let ([s (datum->syntax core-stx sym)]) + (hash-set! id-cache-0 sym s) + s))] + [(eq? phase 1) + (or (hash-ref id-cache-1 sym #f) + (let ([s (datum->syntax (syntax-shift-phase-level core-stx 1) sym)]) + (hash-set! id-cache-1 sym s) + s))] + [else + (datum->syntax (syntax-shift-phase-level core-stx phase) sym)])) + +;; Core forms and primitives are added by `require`s in "expander.rkt" + +;; Accumulate added core forms and primitives: +(define core-forms #hasheq()) +(define core-primitives #hasheq()) + +(define-syntax-rule (add-core-form! sym proc) + ;; The `void` wrapper suppress a `print-values` wrapper: + (void (add-core-form!* sym proc))) + +(define (add-core-form!* sym proc) + (add-core-binding! sym) + (set! core-forms (hash-set core-forms + sym + proc))) + +(define (add-core-primitive! sym val) + (add-core-binding! sym) + (set! core-primitives (hash-set core-primitives + sym + val))) + +(define (add-core-binding! sym) + (add-binding! (datum->syntax core-stx sym) + (make-module-binding core-mpi 0 sym) + 0)) + +;; Used only after filling in all core forms and primitives: +(define (declare-core-module! ns) + (declare-module! + ns + (make-module #:cross-phase-persistent? #t + #:no-protected? #t + #:predefined? #t + #:self core-mpi + #:provides + (hasheqv 0 (for/hasheq ([syms (in-list (list core-primitives + core-forms))] + [syntax? (in-list '(#f #t))] + #:when #t + [sym (in-hash-keys syms)]) + (define b (make-module-binding core-mpi 0 sym)) + (values sym (if syntax? (provided b #f #t) b)))) + #:phase-level-linklet-info-callback + (lambda (phase-level ns insp) + (and (zero? phase-level) + (let ([ns (namespace->module-namespace ns core-module-name 0)]) + (and ns + (module-linklet-info (namespace->instance ns 0) + #f + core-mpi + #f + #f + #f))))) + #:instantiate-phase-callback + (lambda (data-box ns phase phase-level self bulk-binding-registry insp) + (case phase-level + [(0) + (for ([(sym val) (in-hash core-primitives)]) + (namespace-set-consistent! ns 0 sym val)) + (for ([(sym proc) (in-hash core-forms)]) + (namespace-set-transformer! ns 0 sym (core-form proc sym)))]))) + core-module-name)) + +;; Helper for recognizing and dispatching on core forms: +(define (core-form-sym s phase) + (define-match m s #:try '(id . _)) + (and (m) + (let ([b (resolve+shift (m 'id) phase)]) + (and (module-binding? b) + (eq? core-module-name (module-path-index-resolve (module-binding-module b))) + (module-binding-sym b))))) diff --git a/racket/src/expander/namespace/inspector.rkt b/racket/src/expander/namespace/inspector.rkt new file mode 100644 index 0000000000..29d7af01f4 --- /dev/null +++ b/racket/src/expander/namespace/inspector.rkt @@ -0,0 +1,6 @@ +#lang racket/base + +(provide current-module-code-inspector) + +;; Parameter to select inspector for functions like `syntax-arm` +(define current-module-code-inspector (make-parameter #f)) diff --git a/racket/src/expander/namespace/module.rkt b/racket/src/expander/namespace/module.rkt new file mode 100644 index 0000000000..fd6c482a08 --- /dev/null +++ b/racket/src/expander/namespace/module.rkt @@ -0,0 +1,549 @@ +#lang racket/base +(require "../common/phase.rkt" + "../common/small-hash.rkt" + "../common/performance.rkt" + "../syntax/bulk-binding.rkt" + "../syntax/module-binding.rkt" + "../common/module-path.rkt" + "../compile/module-use.rkt" + "../expand/root-expand-context.rkt" + "../host/linklet.rkt" + "namespace.rkt" + "provided.rkt" + "registry.rkt" + (submod "namespace.rkt" for-module)) + +(provide make-module-namespace + raise-unknown-module-error + + namespace->module-instance + namespace->module-namespace + namespace-install-module-namespace! + namespace-record-module-instance-attached! + module-force-bulk-binding! + + namespace->module-linklet-info + (struct-out module-linklet-info) + + make-module + declare-module! + module-self + module-requires + module-provides + module-primitive? + module-is-predefined? + module-cross-phase-persistent? + module-no-protected? + module-inspector + module-submodule-names + module-supermodule-name + module-get-all-variables + module-access + module-compute-access! + + module-instance-namespace + module-instance-module + + namespace-module-instantiate! + namespace-module-visit! + namespace-module-make-available! + namespace-primitive-module-visit! + namespace-visit-available-modules! + namespace-run-available-modules! + + namespace-module-use->module+linklet-instances) + +(module+ for-module-reflect + (provide (struct-out module))) + +;; ---------------------------------------- + +(struct module (source-name ; #f, symbol, or complete path + self ; module path index used for a self reference + requires ; list of (cons phase list-of-module-path-index) + provides ; phase-level -> sym -> binding or (provided binding bool bool) + [access #:mutable] ; phase-level -> sym -> 'provided or 'protected; computed on demand from `provides` + language-info ; #f or vector + min-phase-level ; phase-level + max-phase-level ; phase-level + phase-level-linklet-info-callback ; phase-level namespace -> module-linklet-info-or-#f + force-bulk-binding ; bulk-binding-registry -> any + prepare-instance ; box namespace phase-shift bulk-binding-registry inspector -> any + instantiate-phase ; box namespace phase-shift phase-level bulk-binding-registry inspector -> any + primitive? ; inline variable values in compiled code? + is-predefined? ; always defined on startup? + cross-phase-persistent? + no-protected? ; short cut for checking protected access + inspector ; declaration-time inspector + submodule-names ; associated submodules (i.e, when declared together) + supermodule-name ; associated supermodule (i.e, when declared together) + get-all-variables)) ; for `module->indirect-exports` + +(struct module-linklet-info (linklet-or-instance ; #f, linklet, or instance supplied for cross-linking optimization + module-uses ; #f or vector for linklet's imports + self ; self modidx + inspector ; declaration-time inspector + extra-inspector ; optional extra inspector + extra-inspectorsss) ; optional extra inspector sets per variable per import + #:transparent) + +(define (make-module #:source-name [source-name #f] + #:self self + #:requires [requires null] + #:provides provides + #:min-phase-level [min-phase-level 0] + #:max-phase-level [max-phase-level 0] + #:instantiate-phase-callback instantiate-phase + #:force-bulk-binding-callback [force-bulk-binding void] + #:prepare-instance-callback [prepare-instance void] + #:phase-level-linklet-info-callback [phase-level-linklet-info-callback + (lambda (phase-level ns insp) #f)] + #:language-info [language-info #f] + #:primitive? [primitive? #f] + #:predefined? [predefined? #f] + #:cross-phase-persistent? [cross-phase-persistent? primitive?] + #:no-protected? [no-protected? #f] + #:submodule-names [submodule-names null] + #:supermodule-name [supermodule-name #f] + #:get-all-variables [get-all-variables (lambda () null)]) ; ok to omit exported + (module source-name + self + (unresolve-requires requires) + provides + #f ; access + language-info + min-phase-level max-phase-level + phase-level-linklet-info-callback + force-bulk-binding + prepare-instance + instantiate-phase + primitive? + predefined? + cross-phase-persistent? + no-protected? + (current-code-inspector) + submodule-names + supermodule-name + get-all-variables)) + +(struct module-instance (namespace + module ; can be #f for the module being expanded + [shifted-requires #:mutable] ; computed on demand; shifted from `module-requires` + phase-level-to-state ; phase-level -> #f, 'available, or 'started + [made-available? #:mutable] ; no #f in `phase-level-to-state`? + [attached? #:mutable] ; whether the instance has been attached elsewhere + data-box)) ; for use by module implementation + +(define (make-module-instance m-ns m) + (module-instance m-ns ; namespace + m ; module + #f ; shifted-requires (not yet computed) + (make-small-hasheqv) ; phase-level-to-state + #f ; made-available? + #f ; attached? + (box #f))) ; data-box + +;; ---------------------------------------- + +;; Create a namespace for expanding a module +(define (make-module-namespace ns + #:mpi name-mpi + #:root-expand-context root-expand-ctx + #:for-submodule? for-submodule?) + (define phase 0) ; always start at 0 when compiling a module + (define name (module-path-index-resolve name-mpi)) + (define m-ns + ;; Keeps all module declarations, but makes a fresh space of instances + (struct-copy namespace (new-namespace ns + #:root-expand-ctx root-expand-ctx + #:register? #f) + [mpi name-mpi] + [source-name (resolved-module-path-root-name name)] + [phase phase] + [0-phase phase] + [submodule-declarations (if for-submodule? + ;; Same set of submodules: + (namespace-submodule-declarations ns) + ;; Fresh set of submodules: + (make-small-hasheq))] + [available-module-instances (make-hasheqv)] + [module-instances (make-hasheqv)] + [declaration-inspector (current-code-inspector)])) + (small-hash-set! (namespace-phase-to-namespace m-ns) phase m-ns) + (define at-phase (make-hasheq)) + (hash-set! (namespace-module-instances m-ns) phase at-phase) + (hash-set! at-phase name (make-module-instance m-ns #f)) + m-ns) + +;; ---------------------------------------- + +(define (declare-module! ns m mod-name #:with-submodules? [with-submodules? #t]) + (define prior-m (and with-submodules? + (hash-ref (module-registry-declarations (namespace-module-registry ns)) + mod-name + #f))) + (define prior-mi (and prior-m + (not (eq? m prior-m)) + (namespace->module-instance ns mod-name (namespace-phase ns)))) + (when (and prior-m (not (eq? m prior-m))) + (check-redeclaration-ok prior-m prior-mi mod-name)) + (if with-submodules? + (hash-set! (module-registry-declarations (namespace-module-registry ns)) mod-name m) + (small-hash-set! (namespace-submodule-declarations ns) mod-name m)) + (when with-submodules? + ;; Register this module's exports for use in resolving bulk + ;; bindings, so that bulk bindings can be shared among other + ;; modules when unmarshaling; we don't do this without + ;; `with-submodules?` to avoid loeaking submodules being + ;; expanded, but see also `bind-all-provides!` + (register-bulk-provide! (namespace-bulk-binding-registry ns) + mod-name + (module-self m) + (module-provides m)) + ;; Tell resolver that the module is declared + ((current-module-name-resolver) mod-name #f)) + ;; If this module is already instantiated, re-instantiate it + (when prior-mi + (define m-ns (module-instance-namespace prior-mi)) + (define states (module-instance-phase-level-to-state prior-mi)) + (define phase (namespace-phase ns)) + (define visit? (eq? 'started (small-hash-ref states (add1 phase) #f))) + (define run? (eq? 'started (small-hash-ref states phase #f))) + + (define at-phase (hash-ref (namespace-module-instances ns) phase)) + (hash-set! at-phase mod-name (make-module-instance m-ns m)) + + (when visit? + (namespace-module-visit! ns (namespace-mpi m-ns) phase)) + (when run? + (namespace-module-instantiate! ns (namespace-mpi m-ns) phase)))) + +(define (check-redeclaration-ok prior-m prior-mi mod-name) + (when (module-cross-phase-persistent? prior-m) + (raise-arguments-error 'module + "cannot redeclare cross-phase persistent module" + "module name" mod-name)) + (when (and prior-mi + (or (module-instance-attached? prior-mi) + (not (inspector-superior? (current-code-inspector) + (namespace-inspector (module-instance-namespace prior-mi)))))) + (raise-arguments-error 'module + "current code inspector cannot redeclare module" + "module name" mod-name))) + +(define (raise-unknown-module-error who mod-name) + (raise-arguments-error who + "unknown module" + "module name" mod-name)) + +(define (namespace->module-linklet-info ns name phase-level) + (define m (namespace->module ns name)) + (and m + ((module-phase-level-linklet-info-callback m) phase-level ns (module-inspector m)))) + +;; ---------------------------------------- + +(define (namespace->module-instance ns name 0-phase + #:complain-on-failure? [complain-on-failure? #f] + #:check-available-at-phase-level [check-available-at-phase-level #f] + #:unavailable-callback [unavailable-callback void]) + (define mi + (or (hash-ref (hash-ref (namespace-module-instances ns) 0-phase #hasheq()) + name + #f) + (let ([c-ns (or (namespace-root-namespace ns) ns)]) + (hash-ref (namespace-module-instances c-ns) name #f)) + (and complain-on-failure? + (error "no module instance found:" name 0-phase)))) + (if (and mi check-available-at-phase-level) + (check-availablilty mi check-available-at-phase-level unavailable-callback) + mi)) + +(define (namespace-install-module-namespace! ns name 0-phase m existing-m-ns) + (define m-ns (struct-copy namespace ns + [mpi (namespace-mpi existing-m-ns)] + [source-name (namespace-source-name existing-m-ns)] + [root-expand-ctx (box (unbox (namespace-root-expand-ctx existing-m-ns)))] + [phase (namespace-phase existing-m-ns)] + [0-phase (namespace-0-phase existing-m-ns)] + [phase-to-namespace (make-small-hasheqv)] + [phase-level-to-definitions (if (module-cross-phase-persistent? m) + (namespace-phase-level-to-definitions existing-m-ns) + (make-small-hasheqv))] + [declaration-inspector (module-inspector m)] + [inspector (namespace-inspector existing-m-ns)])) + (define mi (make-module-instance m-ns m)) + (cond + [(module-cross-phase-persistent? m) + (small-hash-set! (namespace-phase-to-namespace m-ns) 0 m-ns) + (small-hash-set! (namespace-phase-level-to-definitions m-ns) + 0 + (namespace->definitions existing-m-ns 0)) + (small-hash-set! (namespace-phase-to-namespace m-ns) 1 (namespace->namespace-at-phase m-ns 1)) + (small-hash-set! (namespace-phase-level-to-definitions m-ns) + 1 + (namespace->definitions existing-m-ns 1)) + (hash-set! (namespace-module-instances (or (namespace-root-namespace ns) ns)) + name + mi) + (small-hash-set! (module-instance-phase-level-to-state mi) 0 'started)] + [else + (small-hash-set! (namespace-phase-to-namespace m-ns) 0-phase m-ns) + (small-hash-set! (namespace-phase-level-to-definitions m-ns) + 0 + (namespace->definitions existing-m-ns 0)) + (small-hash-set! (module-instance-phase-level-to-state mi) 0 'started) + (define at-phase (or (hash-ref (namespace-module-instances ns) 0-phase #f) + (let ([at-phase (make-hasheq)]) + (hash-set! (namespace-module-instances ns) 0-phase at-phase) + at-phase))) + (hash-set! at-phase name mi)])) + +(define (namespace-create-module-instance! ns name 0-phase m mpi) + (define m-ns (struct-copy namespace ns + [mpi mpi] + [source-name (or (module-source-name m) + (resolved-module-path-root-name + (module-path-index-resolve mpi)))] + [root-expand-ctx (box #f)] ; maybe set to non-#f by running + [phase 0-phase] + [0-phase 0-phase] + [phase-to-namespace (make-small-hasheqv)] + [phase-level-to-definitions (make-small-hasheqv)] + [declaration-inspector (module-inspector m)] + [inspector (make-inspector (module-inspector m))])) + (small-hash-set! (namespace-phase-to-namespace m-ns) 0-phase m-ns) + (define mi (make-module-instance m-ns m)) + (if (module-cross-phase-persistent? m) + (hash-set! (namespace-module-instances ns) name mi) + (let ([at-phase (or (hash-ref (namespace-module-instances ns) 0-phase #f) + (let ([at-phase (make-hasheq)]) + (hash-set! (namespace-module-instances ns) 0-phase at-phase) + at-phase))]) + (hash-set! at-phase name mi))) + mi) + +(define (check-availablilty mi check-available-at-phase-level unavailable-callback) + (define m (module-instance-module mi)) + (if (and m + (<= (module-min-phase-level m) (add1 check-available-at-phase-level) (module-max-phase-level m)) + (not (small-hash-ref (module-instance-phase-level-to-state mi) (add1 check-available-at-phase-level) #f))) + (unavailable-callback mi) + mi)) + +(define (namespace->module-namespace ns name 0-phase + #:complain-on-failure? [complain-on-failure? #f] + #:check-available-at-phase-level [check-available-at-phase-level #f] + #:unavailable-callback [unavailable-callback void]) + (define mi (namespace->module-instance ns name 0-phase + #:complain-on-failure? complain-on-failure? + #:check-available-at-phase-level check-available-at-phase-level + #:unavailable-callback unavailable-callback)) + (and mi (module-instance-namespace mi))) + +(define (namespace-record-module-instance-attached! ns mod-name phase) + (define mi (namespace->module-instance ns mod-name phase)) + (set-module-instance-attached?! mi #t)) + +;; Before attaching amodule declaration to a new namespace, make sure +;; that its syntax deserialization is associated with the original +;; bulk-binding regsitry +(define (module-force-bulk-binding! m ns) + ((module-force-bulk-binding m) (namespace-bulk-binding-registry ns))) + +;; ---------------------------------------- + +;; Create a module instance as needed, and then run the specified phase; +;; see also `run-module-instance!`, below +(define (namespace-module-instantiate! ns mpi instance-phase #:run-phase [run-phase (namespace-phase ns)] + #:skip-run? [skip-run? #f] + #:otherwise-available? [otherwise-available? #t] + #:seen [seen #hasheq()]) + (unless (module-path-index? mpi) + (error "not a module path index:" mpi)) + (define name (module-path-index-resolve mpi #t)) + (define m (namespace->module ns name)) + (unless m (raise-unknown-module-error 'instantiate name)) + (define (instantiate! instance-phase run-phase ns) + ;; Get or create a namespace for the module+phase combination: + (define mi (or (namespace->module-instance ns name instance-phase) + (namespace-create-module-instance! ns name instance-phase m mpi))) + (run-module-instance! mi ns #:run-phase run-phase + #:skip-run? skip-run? + #:otherwise-available? otherwise-available? + #:seen seen)) + ;; If the module is cross-phase persistent, make sure it's instantiated + ;; at phase 0 and registered in `ns` as phaseless; otherwise + (cond + [(module-cross-phase-persistent? m) + (instantiate! 0 0 (or (namespace-root-namespace ns) ns))] + [else + (instantiate! instance-phase run-phase ns)])) + +(define (namespace-module-visit! ns mpi instance-phase #:visit-phase [visit-phase (namespace-phase ns)]) + (namespace-module-instantiate! ns mpi instance-phase #:run-phase (add1 visit-phase))) + +(define (namespace-module-make-available! ns mpi instance-phase #:visit-phase [visit-phase (namespace-phase ns)]) + (namespace-module-instantiate! ns mpi instance-phase #:run-phase (add1 visit-phase) #:skip-run? #t)) + +;; The `instance-phase` corresponds to the phase shift for the module +;; instances. The module may have content at different phase levels, +;; which are all consistently shifted. The `run-phase` is an absolute +;; phase that should be immediately run, unless `skip-run?` is true; +;; to put it another way, phase level `(phase- instance-phase +;; run-phase)` within the instance should be run immediately. +;; Normally, the instance is made available at all other non-negative +;; phases, but `#:otherwise-available?` controls that behavior. +(define (run-module-instance! mi ns #:run-phase run-phase + #:skip-run? skip-run? + #:otherwise-available? otherwise-available? + #:seen [seen #hasheq()]) + (performance-region + ['eval 'requires] + ;; Nothing to do if we've run this phase already and made the + ;; instance sufficiently available: + (define m-ns (module-instance-namespace mi)) + (define instance-phase (namespace-0-phase m-ns)) + (define run-phase-level (phase- run-phase instance-phase)) + (unless (and (or skip-run? + (eq? 'started (small-hash-ref (module-instance-phase-level-to-state mi) run-phase-level #f))) + (or (not otherwise-available?) + (module-instance-made-available? mi))) + ;; Something to do... + (define m (module-instance-module mi)) + (define mpi (namespace-mpi m-ns)) + (define phase-shift instance-phase) ; instance phase = phase shift + (define bulk-binding-registry (namespace-bulk-binding-registry m-ns)) + + (when (hash-ref seen mi #f) + (error 'require "import cycle detected during module instantiation")) + + ;; If we haven't shifted required mpis already, do that + (unless (module-instance-shifted-requires mi) + (set-module-instance-shifted-requires! + mi + (for/list ([phase+mpis (in-list (module-requires m))]) + (cons (car phase+mpis) + (for/list ([req-mpi (in-list (cdr phase+mpis))]) + (module-path-index-shift req-mpi + (module-self m) + mpi)))))) + + ;; Recur for required modules: + (for ([phase+mpis (in-list (module-instance-shifted-requires mi))]) + (define req-phase (car phase+mpis)) + (for ([req-mpi (in-list (cdr phase+mpis))]) + (namespace-module-instantiate! ns req-mpi (phase+ instance-phase req-phase) + #:run-phase run-phase + #:skip-run? skip-run? + #:otherwise-available? otherwise-available? + #:seen (hash-set seen mi #t)))) + + ;; Run or make available phases of the module body: + (unless (label-phase? instance-phase) + (for ([phase-level (in-range (module-max-phase-level m) (sub1 (module-min-phase-level m)) -1)]) + (define phase (phase+ phase-level phase-shift)) + (cond + [(and (not skip-run?) + (eqv? phase run-phase)) + ;; This is the phase to make sure that we've run + (unless (eq? 'started (small-hash-ref (module-instance-phase-level-to-state mi) phase-level #f)) + (small-hash-set! (module-instance-phase-level-to-state mi) phase-level 'started) + (void (namespace->definitions m-ns phase-level)) + (define p-ns (namespace->namespace-at-phase m-ns phase)) + (define insp (module-inspector m)) + (define data-box (module-instance-data-box mi)) + (define prep (module-prepare-instance m)) + (define go (module-instantiate-phase m)) + (prep data-box p-ns phase-shift mpi bulk-binding-registry insp) + (go data-box p-ns phase-shift phase-level mpi bulk-binding-registry insp))] + [(and otherwise-available? + (not (negative? run-phase)) + (not (small-hash-ref (module-instance-phase-level-to-state mi) phase-level #f))) + ;; This is a phase to merely make available + (hash-update! (namespace-available-module-instances ns) + phase + (lambda (l) (cons mi l)) + null) + (small-hash-set! (module-instance-phase-level-to-state mi) phase-level 'available)]))) + + (when otherwise-available? + (set-module-instance-made-available?! mi #t)) + + (unless skip-run? + ;; In case there's no such phase for this module instance, claim 'started + ;; to short-circuit future attempts: + (small-hash-set! (module-instance-phase-level-to-state mi) run-phase-level 'started))))) + +(define (namespace-visit-available-modules! ns [run-phase (namespace-phase ns)]) + (namespace-run-available-modules! ns (add1 run-phase))) + +(define (namespace-run-available-modules! ns [run-phase (namespace-phase ns)]) + ;; For a quick check, we can rely on the atomicity of `eqv?`-based hash tables + (unless (null? (hash-ref (namespace-available-module-instances ns) run-phase null)) + (registry-call-with-lock + (namespace-module-registry ns) + (lambda () + (let loop () + (define mis (hash-ref (namespace-available-module-instances ns) run-phase null)) + (unless (null? mis) + (hash-set! (namespace-available-module-instances ns) run-phase null) + (for ([mi (in-list (reverse mis))]) + (run-module-instance! mi ns #:run-phase run-phase #:skip-run? #f #:otherwise-available? #f)) + ;; In case instantiation added more reflectively: + (loop))))))) + +(define (namespace-primitive-module-visit! ns name) + (define mi (hash-ref (namespace-module-instances ns) (make-resolved-module-path name))) + (run-module-instance! mi ns #:run-phase 1 #:skip-run? #f #:otherwise-available? #t)) + +;; ---------------------------------------- + +(define (namespace-module-use->module+linklet-instances ns mu + #:shift-from [shift-from #f] + #:shift-to [shift-to #f] + #:phase-shift phase-shift) + (define mod (module-use-module mu)) + (define mi + (namespace->module-instance ns + (module-path-index-resolve + (if shift-from + (module-path-index-shift mod shift-from shift-to) + mod)) + phase-shift + #:complain-on-failure? #t)) + (define m-ns (module-instance-namespace mi)) + (define d (small-hash-ref (namespace-phase-level-to-definitions m-ns) (module-use-phase mu) #f)) + (if d + (values mi (definitions-variables d)) + (error 'eval (string-append "namespace mismatch: phase level not found;\n" + " module: ~a\n" + " phase level: ~a\n" + " found phase levels: ~a") + mod + (module-use-phase mu) + (small-hash-keys (namespace-phase-level-to-definitions m-ns))))) + +;; ---------------------------------------- + +;; ensure that each module path index is unresolved, so that resolving +;; on instantiation will trigger module loads +(define (unresolve-requires requires) + (for/list ([phase+mpis (in-list requires)]) + (cons (car phase+mpis) + (for/list ([req-mpi (in-list (cdr phase+mpis))]) + (module-path-index-unresolve req-mpi))))) + +;; ---------------------------------------- + +(define (module-compute-access! m) + (define access + (for/hasheqv ([(phase at-phase) (in-hash (module-provides m))]) + (values phase + (for/hash ([(sym binding/p) (in-hash at-phase)]) + (values (module-binding-sym (provided-as-binding binding/p)) + (if (provided-as-protected? binding/p) + 'protected + 'provided)))))) + (set-module-access! m access) + access) diff --git a/racket/src/expander/namespace/namespace.rkt b/racket/src/expander/namespace/namespace.rkt new file mode 100644 index 0000000000..584c980e5c --- /dev/null +++ b/racket/src/expander/namespace/namespace.rkt @@ -0,0 +1,207 @@ +#lang racket/base +(require racket/promise + "../common/phase.rkt" + "../common/small-hash.rkt" + "../syntax/scope.rkt" + "../syntax/bulk-binding.rkt" + "../common/module-path.rkt" + "../expand/root-expand-context.rkt" + "../host/linklet.rkt" + "registry.rkt") + +(provide make-namespace + new-namespace + namespace? + current-namespace + namespace-module-registry + namespace-phase + namespace-0-phase + namespace-root-namespace + namespace-get-root-expand-ctx + namespace-set-root-expand-ctx! + namespace->namespace-at-phase + namespace->module + namespace-mpi + namespace-source-name + namespace-bulk-binding-registry + + namespace-set-variable! + namespace-set-consistent! + namespace-unset-variable! + namespace-set-transformer! + namespace-unset-transformer! + namespace-get-variable + namespace-get-transformer + + namespace-declaration-inspector + namespace-inspector + set-namespace-inspector! + + namespace->instance + namespace-same-instance?) + +(module+ for-module + (provide (struct-out namespace) + (struct-out module-registry) + (struct-out definitions) + namespace->definitions)) + +(struct namespace (mpi ; module path index (that's already resolved); instance-specific for a module + source-name ; #f (top-level) or symbol or complete path; user-facing alternative to the mpi + root-expand-ctx ; delay of box of context for top-level expansion; set by module instantiation + phase ; phase (not phase level!) of this namespace + 0-phase ; phase of module instance's phase-level 0 + phase-to-namespace ; phase -> namespace for same module [shared for the same module instance] + phase-level-to-definitions ; phase-level -> definitions [shared for the same module instance] + module-registry ; module-registry of (resolved-module-path -> module) [shared among modules] + bulk-binding-registry ; (resolved-module-path -> bulk-provide) for resolving bulk bindings on unmarshal + submodule-declarations ; resolved-module-path -> module [shared during a module compilation] + root-namespace ; #f or namespace for #lang, #reader, and persistent instances [shared among modules] + declaration-inspector ; declaration-time inspector + [inspector #:mutable] ; instantiation-time inspector + available-module-instances ; phase -> list of module-instance [shared among modules] + module-instances) ; union resolved-module-path -> module-instance [shared among modules] + ;; ; 0-phase -> resolved-module-path -> module-instance + ;; ; where the first option is for cross phase persistent modules + #:property prop:custom-write + (lambda (ns port mode) + (write-string "#name ns))) + (define 0-phase (namespace-0-phase ns)) + (define phase-level (phase- (namespace-phase ns) + 0-phase)) + (unless (zero-phase? phase-level) + (fprintf port ":~s" phase-level)) + (unless (zero-phase? 0-phase) + (fprintf port "~a~s" (if (positive? 0-phase) "+" "") 0-phase)) + (write-string ">" port))) + +(struct definitions (variables ; linklet instance + transformers)) ; sym -> val + +(define (make-namespace) + (new-namespace)) + +(define (new-namespace [share-from-ns #f] + #:root-expand-ctx [root-expand-ctx (make-root-expand-context)] + #:register? [register? #t]) + (define phase (if share-from-ns + (namespace-phase share-from-ns) + 0)) + (define ns + (namespace top-level-module-path-index + #f + (box root-expand-ctx) + phase + phase + (make-small-hasheqv) ; phase-to-namespace + (make-small-hasheqv) ; phase-level-to-definitions + (if share-from-ns + (namespace-module-registry share-from-ns) + (make-module-registry)) + (if share-from-ns + (namespace-bulk-binding-registry share-from-ns) + (make-bulk-binding-registry)) + (make-small-hasheq) ; submodule-declarations + (and share-from-ns + (or (namespace-root-namespace share-from-ns) + share-from-ns)) + #f ; no declaration-time inspector for a top-level namespace + (make-inspector (current-code-inspector)) + (if share-from-ns + (namespace-available-module-instances share-from-ns) + (make-hasheqv)) + (if share-from-ns + (namespace-module-instances share-from-ns) + (make-hasheqv)))) + (when register? + (small-hash-set! (namespace-phase-to-namespace ns) phase ns)) + ns) + +(define current-namespace (make-parameter (make-namespace) + (lambda (v) + (unless (namespace? v) + (raise-argument-error 'current-namespace + "namespace?" + v)) + v))) + +(define (namespace-get-root-expand-ctx ns) + (force (unbox (namespace-root-expand-ctx ns)))) + +(define (namespace-set-root-expand-ctx! ns root-ctx) + (set-box! (namespace-root-expand-ctx ns) root-ctx)) + +(define (namespace->module ns name) + (or (small-hash-ref (namespace-submodule-declarations ns) name #f) + (hash-ref (module-registry-declarations (namespace-module-registry ns)) name #f))) + +(define (namespace->namespace-at-phase ns phase) + (or (small-hash-ref (namespace-phase-to-namespace ns) phase #f) + (let ([p-ns (struct-copy namespace ns + [phase phase])]) + (small-hash-set! (namespace-phase-to-namespace ns) phase p-ns) + p-ns))) + +(define (namespace->name ns) + (define n (namespace-source-name ns)) + (define s + (cond + [(not n) 'top-level] + [(symbol? n) (format "'~s" n)] + [else (string-append "\"" (path->string n) "\"")])) + (define r (resolved-module-path-name (module-path-index-resolve (namespace-mpi ns)))) + (if (pair? r) + (string-append "(submod " s " " (substring (format "~s" (cdr r)) 1)) + s)) + +(define (namespace->definitions ns phase-level) + (define d (small-hash-ref (namespace-phase-level-to-definitions ns) phase-level #f)) + (or d + (let () + (define p-ns (namespace->namespace-at-phase ns (phase+ (namespace-0-phase ns) + phase-level))) + (define d (definitions (make-instance (namespace->name p-ns) p-ns) (make-hasheq))) + (small-hash-set! (namespace-phase-level-to-definitions ns) phase-level d) + d))) + +(define (namespace-set-variable! ns phase-level name val [as-constant? #f]) + (define d (namespace->definitions ns phase-level)) + (instance-set-variable-value! (definitions-variables d) name val (and as-constant? 'constant))) + +(define (namespace-set-consistent! ns phase-level name val) + (define d (namespace->definitions ns phase-level)) + (instance-set-variable-value! (definitions-variables d) name val 'consistent)) + +(define (namespace-unset-variable! ns phase-level name) + (define d (namespace->definitions ns phase-level)) + (instance-unset-variable! (definitions-variables d) name)) + +(define (namespace-set-transformer! ns phase-level name val) + (define d (namespace->definitions ns (add1 phase-level))) + (hash-set! (definitions-transformers d) name val)) + +(define (namespace-unset-transformer! ns phase-level name) + (define d (namespace->definitions ns (add1 phase-level))) + (hash-remove! (definitions-transformers d) name)) + +(define (namespace-get-variable ns phase-level name fail-k) + (define d (namespace->definitions ns phase-level)) + (instance-variable-value (definitions-variables d) name fail-k)) + +(define (namespace-get-transformer ns phase-level name fail-k) + (define d (namespace->definitions ns (add1 phase-level))) + (hash-ref (definitions-transformers d) name fail-k)) + +(define (namespace->instance ns phase-shift) + (definitions-variables (namespace->definitions ns phase-shift))) + +(define (namespace-same-instance? a-ns b-ns) + (eq? (small-hash-ref (namespace-phase-level-to-definitions a-ns) + 0 + 'no-a) + (small-hash-ref (namespace-phase-level-to-definitions b-ns) + 0 + 'no-b))) diff --git a/racket/src/expander/namespace/primitive-module.rkt b/racket/src/expander/namespace/primitive-module.rkt new file mode 100644 index 0000000000..d99b96e214 --- /dev/null +++ b/racket/src/expander/namespace/primitive-module.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require "../common/module-path.rkt" + "../syntax/module-binding.rkt" + "../host/linklet.rkt" + "namespace.rkt" + "module.rkt" + "provided.rkt") + +;; Used from the virtual machine to support C "extensions" that +;; declare modules + +(provide declare-primitive-module!) + +(define (declare-primitive-module! name inst in-ns protected cross-phase-persistent?) + (define mpi (module-path-index-join (list 'quote name) #f)) + (declare-module! + in-ns + (make-module #:source-name (current-module-declare-source) + #:cross-phase-persistent? cross-phase-persistent? + #:no-protected? (zero? (hash-count protected)) + #:self mpi + #:provides + (hasheqv 0 (for/hash ([sym (in-list (instance-variable-names inst))]) + (define binding (make-module-binding mpi 0 sym)) + (values sym + (if (hash-ref protected sym #f) + (provided binding #t #f) + binding)))) + #:instantiate-phase-callback + (lambda (data-box ns phase-shift phase-level self bulk-binding-registry insp) + (when (= 0 phase-level) + (for ([sym (in-list (instance-variable-names inst))]) + (define val (instance-variable-value inst sym)) + (namespace-set-variable! ns 0 sym val))))) + (substitute-module-declare-name name))) diff --git a/racket/src/expander/namespace/provide-for-api.rkt b/racket/src/expander/namespace/provide-for-api.rkt new file mode 100644 index 0000000000..f65c9261a6 --- /dev/null +++ b/racket/src/expander/namespace/provide-for-api.rkt @@ -0,0 +1,53 @@ +#lang racket/base +(require "provided.rkt" + "../common/phase.rkt" + "../common/module-path.rkt" + "../syntax/module-binding.rkt") + +(provide provides->api-provides + variables->api-nonprovides) + +(define (provides->api-provides provides self) + (define (extract ok?) + (define result-l + (for*/list ([(phase at-phase) (in-hash provides)] + [l (in-value + (for/list ([(sym b/p) (in-hash at-phase)] + #:when (ok? b/p)) + (define b (provided-as-binding b/p)) + (list sym + (cond + [(eq? self (module-binding-module b)) + null] + [else + (for/list ([b (in-list (cons b (module-binding-extra-nominal-bindings b)))]) + (cond + [(and (eqv? (module-binding-nominal-phase b) + phase) + (eq? (module-binding-nominal-sym b) sym)) + (module-binding-nominal-module b)] + [else + (list (module-binding-nominal-module b) + (module-binding-phase b) + (module-binding-nominal-sym b) + (module-binding-nominal-phase b))]))]))))] + #:unless (null? l)) + (cons phase (sort l symbolapi-nonprovides provides all-vars) + ;; Filter provideded from list of all variables + (define result-l + (for/list ([(phase vars) (in-hash all-vars)] + #:when #t + [l (in-value + (let ([syms (hash-ref provides phase #hasheq())]) + (for/list ([var-sym (in-list vars)] + #:unless (hash-ref syms var-sym #f)) + var-sym)))] + #:unless (null? l)) + (cons phase (sort l symbol module + lock-box)) ; reentrant lock to guard registry for use by on-demand visits + +(define (make-module-registry) + (module-registry (make-hasheq) (box #f))) + +(define (registry-call-with-lock r proc) + (define lock-box (module-registry-lock-box r)) + (let loop () + (define v (unbox lock-box)) + (cond + [(or (not v) + (sync/timeout 0 (car v) (cdr v))) + (define sema (make-semaphore)) + (define lock (cons (semaphore-peek-evt sema) (current-thread))) + ((dynamic-wind + void + (lambda () + (cond + [(box-cas! lock-box v lock) + (proc) + void] + [else + ;; CAS failed; take it from the top + (loop)])) + (lambda () + (semaphore-post sema))))] + [(eq? (current-thread) (cdr v)) + ;; This thread already holds the lock + (proc)] + [else + ; Wait and try again: + (sync (car v) (cdr v)) + (loop)]))) diff --git a/racket/src/expander/namespace/variable-reference.rkt b/racket/src/expander/namespace/variable-reference.rkt new file mode 100644 index 0000000000..2af324e13a --- /dev/null +++ b/racket/src/expander/namespace/variable-reference.rkt @@ -0,0 +1,76 @@ +#lang racket/base +(require "namespace.rkt" + "../common/contract.rkt" + "../common/module-path.rkt" + "../host/linklet.rkt" + "api-module.rkt") + +(provide variable-reference? ; provided by linklet layer, along with `#%variable-reference` + variable-reference-constant? ; provided by linklet layer + variable-reference-from-unsafe? ; provided by linklet layer + + variable-reference->empty-namespace + variable-reference->namespace + variable-reference->module-path-index + variable-reference->resolved-module-path + variable-reference->module-source + variable-reference->phase + variable-reference->module-base-phase + variable-reference->module-declaration-inspector) + +(define (variable-reference->empty-namespace vr) + (check 'variable-reference->empty-namespace variable-reference? vr) + (new-namespace (variable-reference->namespace vr))) + +(define (variable-reference->namespace vr) + (check 'variable-reference->namespace variable-reference? vr) + (define inst (variable-reference->instance vr)) + (cond + [(symbol? inst) + ;; This case happens for `(#%variable-reference id)` where `id` + ;; refers directly to a primitive. The expander doesn't currently + ;; generate that, but just in case... We get a namespace for a + ;; primitive instance; that might not be the same module as + ;; reorted by `identifier-binding`, but close enough. + (module->namespace `',inst (instance-data (variable-reference->instance vr #t)))] + [(not inst) + ;; Anonymous variable reference; use the referencing namespace + (instance-data (variable-reference->instance vr #t))] + [else + ;; Get the defining namespace for the referenced variable + (instance-data inst)])) + +(define (variable-reference->module-path-index vr) + (check 'variable-reference->module-path-index variable-reference? vr) + (define mpi (namespace-mpi (variable-reference->namespace vr))) + (if (top-level-module-path-index? mpi) + #f + mpi)) + +(define (variable-reference->resolved-module-path vr) + (check 'variable-reference->resolved-module-path variable-reference? vr) + (define mpi (variable-reference->module-path-index vr)) + (and mpi (module-path-index-resolve mpi))) + +(define (variable-reference->module-source vr) + (check 'variable-reference->module-source variable-reference? vr) + (define ns (variable-reference->namespace vr)) + (namespace-source-name ns)) + +(define (variable-reference->phase vr) + (check 'variable-reference->phase variable-reference? vr) + (namespace-phase (variable-reference->namespace vr))) + +(define (variable-reference->module-base-phase vr) + (check 'variable-reference->module-base-phase variable-reference? vr) + (namespace-0-phase (variable-reference->namespace vr))) + +(define (variable-reference->module-declaration-inspector vr) + (check 'variable-reference->module-declaration-inspector variable-reference? vr) + (when (variable-reference->instance vr) + (raise-arguments-error 'variable-reference->module-declaration-inspector + "variable reference does not refer to an anonymous module variable" + "variable reference" vr)) + (or (namespace-declaration-inspector (variable-reference->namespace vr)) + (raise-arguments-error 'variable-reference->module-declaration-inspector + "given variable reference is not from a module"))) diff --git a/racket/src/expander/read/accum-string.rkt b/racket/src/expander/read/accum-string.rkt new file mode 100644 index 0000000000..98fb874902 --- /dev/null +++ b/racket/src/expander/read/accum-string.rkt @@ -0,0 +1,84 @@ +#lang racket/base +(require "config.rkt") + +;; An `accum-string` is a buffer for accumulating characters. +;; We cache the buffer in the config record so that it can +;; be reused after the buffered results are extracted. + +(provide accum-string-init! + accum-string-add! + accum-string-convert! + accum-string-count + set-accum-string-count! + accum-string-get! + accum-string-get-bytes! + accum-string-abandon!) + +(struct accum-string ([pos #:mutable] + [str #:mutable])) + +(define (accum-string-init! config) + (define st (read-config-st config)) + (define a (read-config-state-accum-str st)) + (cond + [a + (set-read-config-state-accum-str! st #f) + (set-accum-string-pos! a 0) + a] + [else + (accum-string 0 (make-string 32))])) + +(define (accum-string-add! a c) + (define pos (accum-string-pos a)) + (define str (accum-string-str a)) + (define str2 + (cond + [(pos . < . (string-length str)) + str] + [else + (define str2 (make-string (* (string-length str) 2))) + (string-copy! str2 0 str) + (set-accum-string-str! a str2) + str2])) + (string-set! str2 pos c) + (set-accum-string-pos! a (add1 pos))) + +(define (accum-string-count a) + (accum-string-pos a)) + +(define (set-accum-string-count! a pos) + (set-accum-string-pos! a pos)) + +;; Replace `start-pos` up to `pos` with a converted +;; string. Case folding can change the string length. +(define (accum-string-convert! a convert start-pos) + (define str (accum-string-str a)) + (define s (convert + (substring str + start-pos + (accum-string-pos a)))) + (define len (string-length s)) + (unless ((+ len start-pos) . < . (string-length str)) + (define str2 (make-string (+ start-pos len))) + (string-copy! str2 0 str 0 start-pos) + (set-accum-string-str! a str2)) + (string-copy! (accum-string-str a) start-pos s) + (set-accum-string-pos! a (+ start-pos len))) + +(define (accum-string-get! a config #:start-pos [start-pos 0]) + (define s (substring (accum-string-str a) + start-pos + (accum-string-pos a))) + (accum-string-abandon! a config) + s) + +(define (accum-string-get-bytes! a config #:start-pos [start-pos 0]) + (define bstr (string->bytes/latin-1 (accum-string-str a) + #f + start-pos + (accum-string-pos a))) + (accum-string-abandon! a config) + bstr) + +(define (accum-string-abandon! a config) + (set-read-config-state-accum-str! (read-config-st config) a)) diff --git a/racket/src/expander/read/api.rkt b/racket/src/expander/read/api.rkt new file mode 100644 index 0000000000..993c56c111 --- /dev/null +++ b/racket/src/expander/read/api.rkt @@ -0,0 +1,59 @@ +#lang racket/base +(require "../common/contract.rkt" + "readtable.rkt" + (rename-in "../syntax/read-syntax.rkt" + [read-syntax raw:read-syntax] + [read-syntax/recursive raw:read-syntax/recursive] + [read raw:read] + [read/recursive raw:read/recursive] + [read-language raw:read-language])) + +(provide read-syntax + read-syntax/recursive + read + read/recursive + read-language) + +(define (read-syntax [src (object-name (current-input-port))] [in (current-input-port)]) + (check 'read-syntax input-port? in) + (raw:read-syntax src in)) + +(define (read-syntax/recursive [src (object-name (current-input-port))] + [in (current-input-port)] + [start #f] + [readtable (current-readtable)] + [graph? #t]) + (check 'read-syntax/recursive input-port? in) + (unless (or (char? start) (not start)) + (raise-argument-error 'read-syntax/recursive "(or/c char? #f)" start)) + (unless (or (readtable? readtable) (not readtable)) + (raise-argument-error 'read-syntax/recursive "(or/c readtable? #f)" readtable)) + (raw:read-syntax/recursive src in start readtable graph?)) + +(define (read [in (current-input-port)]) + (check 'read input-port? in) + (raw:read in)) + +(define (read/recursive [in (current-input-port)] + [start #f] + [readtable (current-readtable)] + [graph? #t]) + (check 'read/recursive input-port? in) + (unless (or (char? start) (not start)) + (raise-argument-error 'read/recursive "(or/c char? #f)" start)) + (unless (or (readtable? readtable) (not readtable)) + (raise-argument-error 'read/recursive "(or/c readtable? #f)" readtable)) + (raw:read/recursive in start readtable graph?)) + +(define (read-language [in (current-input-port)] + [fail-thunk read-language-fail-thunk]) + (check 'read-language input-port? in) + (unless (and (procedure? fail-thunk) + (procedure-arity-includes? fail-thunk 0)) + (raise-argument-error 'read-language "(procedure-arity-includes?/c 0)" fail-thunk)) + (raw:read-language in (if (eq? fail-thunk read-language-fail-thunk) + #f + fail-thunk))) + +;; Not actually called --- just used to recognize a default +(define (read-language-fail-thunk) (error "fail")) diff --git a/racket/src/expander/read/box.rkt b/racket/src/expander/read/box.rkt new file mode 100644 index 0000000000..ebff3fccc6 --- /dev/null +++ b/racket/src/expander/read/box.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(require "error.rkt" + "wrap.rkt" + "config.rkt" + "parameter.rkt") + +(provide read-box) + +(define (read-box read-one dispatch-c in config) + (unless (check-parameter read-accept-box config) + (reader-error in config + "`~a&` forms not enabled" + dispatch-c)) + (define e (read-one #f in (next-readtable config))) + (when (eof-object? e) + (reader-error in config #:due-to e + "expected an element for `~a&` box, found end-of-file" + dispatch-c)) + (wrap (box e) in config #f)) diff --git a/racket/src/expander/read/char.rkt b/racket/src/expander/read/char.rkt new file mode 100644 index 0000000000..b93a58fa06 --- /dev/null +++ b/racket/src/expander/read/char.rkt @@ -0,0 +1,113 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "digit.rkt") + +(provide read-character) + +(define (read-character in config) + (define c (read-char/special in config)) + (define char + (cond + [(eof-object? c) + (reader-error in config #:due-to c + "expected a character after `#\\`")] + [(not (char? c)) + (reader-error in config #:due-to c + "found non-character after `#\\`")] + [(octal-digit? c) + ;; Maybe octal + (define c2 (peek-char/special in config)) + (cond + [(and (char? c2) (octal-digit? c2)) + ;; Octal -- must be 3 digits + (consume-char in c2) + (define c3 (read-char/special in config)) + (define v + (cond + [(and (char? c3) (octal-digit? c3)) + (+ (arithmetic-shift (digit->number c) 6) + (arithmetic-shift (digit->number c2) 3) + (digit->number c3))] + [else #f])) + (unless (and v (v . <= . 255)) + (reader-error in config #:due-to c3 + "bad character constant `#\\~a~a~a`" + c c2 (if (char? c3) c3 ""))) + (integer->char v)] + [else + ;; Not octal + c])] + [(or (char=? c #\u) + (char=? c #\U)) + ;; Maybe hex encoding + (define accum-str (accum-string-init! config)) + (define v (read-digits in config accum-str + #:base 16 + #:max-count (if (char=? c #\u) 4 8))) + (cond + [(integer? v) + ;; It's a hex encoding, but make sure it's in range + (cond + [(and (or (v . < . #xD800) (v . > . #xDFFF)) + (v . <= . #x10FFFF)) + (accum-string-abandon! accum-str config) + (integer->char v)] + [else + (reader-error in config + "bad character constant `#\\u~a`" + (accum-string-get! accum-str config))])] + [else + ;; Not a hex encoding + (accum-string-abandon! accum-str config) + c])] + [(char-alphabetic? c) + ;; Maybe a name + (define next-c (peek-char/special in config)) + (cond + [(and (char? next-c) + (char-alphabetic? next-c)) + ;; Must be a name + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str c) + (accum-string-add! accum-str next-c) + (consume-char in next-c) + (let loop () + (define next-c (peek-char/special in config)) + (when (and (char? next-c) + (char-alphabetic? next-c)) + (accum-string-add! accum-str next-c) + (consume-char in next-c) + (loop))) + (define name (string-foldcase + (accum-string-get! accum-str config))) + (case name + [("nul" "null") #\nul] + [("backspace") #\backspace] + [("tab") #\tab] + [("newline" "linefeed") #\newline] + [("vtab") #\vtab] + [("page") #\page] + [("return") #\return] + [("space") #\space] + [("rubout") #\rubout] + [else + (reader-error in config + "bad character constant `#\\~a`" + name)])] + [else + ;; Not a name + c])] + [else + ;; Any other character + c])) + + (wrap char + in + config + char)) diff --git a/racket/src/expander/read/closer.rkt b/racket/src/expander/read/closer.rkt new file mode 100644 index 0000000000..618239e7e4 --- /dev/null +++ b/racket/src/expander/read/closer.rkt @@ -0,0 +1,64 @@ +#lang racket/base +(require "parameter.rkt" + "config.rkt" + "readtable.rkt") + +(provide char-closer? + closer-name + closer->opener + opener-name + dot-name + all-openers-str) + +(define (char-closer? ec config) + (and (not (eof-object? ec)) + (or (char=? ec #\)) + (char=? ec #\]) + (char=? ec #\})))) + +(define (closer-name c config) + (effective-char-names c config "closer")) + +(define (opener-name c config) + (effective-char-names c config "opener")) + +(define (effective-char-names c config fallback-str) + (define rt (read-config-readtable config)) + (cond + [(not rt) + (format "`~a`" c)] + [else + (define cs (readtable-equivalent-chars rt c)) + (cond + [(null? cs) fallback-str] + [(null? (cdr cs)) (format "`~a`" (car cs))] + [(null? (cddr cs)) (format "`~a` or `~a`" (car cs) (cadr cs))] + [else + (apply + string-append + (let loop ([cs cs]) + (cond + [(null? (cdr cs)) (list (format "or `~a`" (car cs)))] + [else (cons (format "`~a`, " (car cs)) + (loop (cdr cs)))])))])])) + +(define (closer->opener c) + (case c + [(#\)) #\(] + [(#\]) #\[] + [(#\}) #\{] + [else c])) + +(define (dot-name config) + "`.`") + +(define (all-openers-str config) + (define p (opener-name #\( config)) + (define s (and (check-parameter read-square-bracket-as-paren config) + (opener-name #\[ config))) + (define c (and (check-parameter read-curly-brace-as-paren config) + (opener-name #\{ config))) + (cond + [(and s c) (format "~a, ~a, or ~a" p s c)] + [(or s c) (format "~a or ~a" p (or s c))] + [else p])) diff --git a/racket/src/expander/read/coerce-key.rkt b/racket/src/expander/read/coerce-key.rkt new file mode 100644 index 0000000000..9e08cf6ff6 --- /dev/null +++ b/racket/src/expander/read/coerce-key.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(require "config.rkt") + +(provide coerce-key) + +(define (coerce-key key config) + (define for-syntax? (read-config-for-syntax? config)) + ((read-config-coerce-key config) + for-syntax? + key)) diff --git a/racket/src/expander/read/coerce.rkt b/racket/src/expander/read/coerce.rkt new file mode 100644 index 0000000000..903edc91c6 --- /dev/null +++ b/racket/src/expander/read/coerce.rkt @@ -0,0 +1,11 @@ +#lang racket/base +(require "config.rkt") + +(provide coerce) + +(define (coerce val in config) + (define for-syntax? (read-config-for-syntax? config)) + ((read-config-coerce config) + for-syntax? + val + (and for-syntax? (port+config->srcloc in config)))) diff --git a/racket/src/expander/read/config.rkt b/racket/src/expander/read/config.rkt new file mode 100644 index 0000000000..c82263fa0d --- /dev/null +++ b/racket/src/expander/read/config.rkt @@ -0,0 +1,135 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "readtable-parameter.rkt") + +(provide (struct*-out read-config) + (struct-out read-config-state) + current-read-config + make-read-config + read-config-update + port+config->srcloc + reading-at + disable-wrapping + keep-comment + discard-comment + next-readtable) + +(struct* read-config (readtable + next-readtable ; readtable to use for recursive reads + for-syntax? ; impose restrictions on graphs, fxvectors, etc? + source + * wrap ; wrapper applied to each datum, intended for syntax objects + read-compiled ; for `#~`: input-port -> any/c + dynamic-require ; for reader extensions: module-path sym -> any + module-declared? ; for `#lang`: module-path -> any/c + coerce ; coerce for syntax or not: any boolean -> any + coerce-key ; coerce unwrapped key for hash + * line + * col + * pos + * indentations ; stack of `indentation` records + * keep-comment? ; make main dispatch return on comment + parameter-override ; mash of parameter -> value + parameter-cache ; hash of parameter -> value + st)) ; other shared mutable state + +(struct read-config-state ([accum-str #:mutable] ; string-buffer cache + [graph #:mutable])) ; #f or hash of number -> value + +(define current-read-config (make-parameter #f)) ; for `read/recursive` + +(define (make-read-config + #:source [source #f] + #:for-syntax? [for-syntax? #f] + #:readtable [readtable (current-readtable)] + #:next-readtable [next-readtable readtable] + #:wrap [wrap #f #;(lambda (s-exp srcloc) s-exp)] + #:read-compiled [read-compiled #f] + #:dynamic-require [dynamic-require #f] + #:module-declared? [module-declared? #f] + #:coerce [coerce #f] + #:coerce-key [coerce-key #f] + #:keep-comment? [keep-comment? #f]) + (read-config readtable + next-readtable + for-syntax? + source + wrap + (or read-compiled + (lambda (in) + (error 'read "no `read-compiled` provided"))) + (or dynamic-require + (lambda (mod-path sym failure-k) + (error 'read "no `dynamic-require` provided"))) + (or module-declared? + (lambda (mod-path) + (error 'read "no `module-declare?` provided"))) + (or coerce + (lambda (for-syntax? v srcloc) v)) + (or coerce-key + (lambda (for-syntax? v) v)) + #f ; line + #f ; col + #f ; pos + null ; indentations + keep-comment? + #hasheq() ; parameter-override + (make-hasheq) ; parameter-cache + (read-config-state #f ; accum-str + #f))) ; graph + +(define (read-config-update config + #:for-syntax? for-syntax? + #:wrap wrap + #:readtable readtable + #:next-readtable [next-readtable (read-config-readtable config)] + #:reset-graph? local-graph? + #:keep-comment? keep-comment?) + (struct*-copy read-config config + [for-syntax? for-syntax?] + [wrap wrap] + [readtable readtable] + [next-readtable next-readtable] + [keep-comment? keep-comment?] + [st (if local-graph? + (read-config-state #f #f) + (read-config-st config))])) + +(define (port+config->srcloc in config) + (define-values (end-line end-col end-pos) (port-next-location in)) + (srcloc (read-config-source config) + (read-config-line config) + (read-config-col config) + (read-config-pos config) + (and (read-config-pos config) end-pos (- end-pos (read-config-pos config))))) + +(define (reading-at config line col pos) + (struct*-copy read-config config + [line line] + [col col] + [pos pos])) + +(define (disable-wrapping config) + (struct*-copy read-config config + [wrap #f])) + +(define (keep-comment config) + (struct*-copy read-config config + [keep-comment? #t])) + +(define (discard-comment config) + (cond + [(not (read-config-keep-comment? config)) + config] + [else + (struct*-copy read-config config + [keep-comment? #f])])) + +(define (next-readtable config) + (cond + [(eq? (read-config-readtable config) + (read-config-next-readtable config)) + config] + [else + (struct*-copy read-config config + [readtable (read-config-next-readtable config)])])) diff --git a/racket/src/expander/read/constant.rkt b/racket/src/expander/read/constant.rkt new file mode 100644 index 0000000000..cadc3f6e8a --- /dev/null +++ b/racket/src/expander/read/constant.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require "special.rkt" + "delimiter.rkt" + "accum-string.rkt" + "error.rkt" + "consume.rkt" + "wrap.rkt") + +(provide read-delimited-constant) + +(define (read-delimited-constant init-c can-match? chars val in config) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str init-c) + (let loop ([chars chars]) + (define c (peek-char/special in config)) + (cond + [(char-delimiter? c config) + (unless (null? chars) + (reader-error in config #:due-to c + "bad syntax `#~a`" (accum-string-get! accum-str config)))] + [(null? chars) + (accum-string-add! accum-str c) + (reader-error in config + "bad syntax `#~a`" (accum-string-get! accum-str config))] + [(and can-match? (char=? c (car chars))) + (consume-char in c) + (accum-string-add! accum-str c) + (loop (cdr chars))] + [else + (consume-char/special in config c) + (accum-string-add! accum-str c) + (reader-error in config + "bad syntax `#~a`" (accum-string-get! accum-str config))])) + (wrap val in config (accum-string-get! accum-str config))) diff --git a/racket/src/expander/read/consume.rkt b/racket/src/expander/read/consume.rkt new file mode 100644 index 0000000000..409147456b --- /dev/null +++ b/racket/src/expander/read/consume.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require "special.rkt" + "config.rkt") + +(provide consume-char + consume-char/special) + +;; Consume a previously peek character. We could +;; double-check that the read character matches `c` +(define (consume-char in c) + (read-char in) + (void)) + +(define (consume-char/special in config c) + (read-char-or-special in special (read-config-source config)) + (void)) diff --git a/racket/src/expander/read/delimiter.rkt b/racket/src/expander/read/delimiter.rkt new file mode 100644 index 0000000000..ff22d018bd --- /dev/null +++ b/racket/src/expander/read/delimiter.rkt @@ -0,0 +1,33 @@ +#lang racket/base +(require "config.rkt" + "readtable.rkt" + "parameter.rkt") + +(provide readtable-char-delimiter? + char-delimiter?) + +(define (readtable-char-delimiter? rt c config) + (define dc (or (and rt + (hash-ref (readtable-delimiter-ht rt) c #f)) ; #f => default for `c` + c)) + (cond + [(eq? dc 'no-delimit) #f] + [(not (char? dc)) #t] + [else + (or (char-whitespace? dc) + (char=? dc #\() + (char=? dc #\)) + (char=? dc #\[) + (char=? dc #\]) + (char=? dc #\{) + (char=? dc #\}) + (char=? dc #\') + (char=? dc #\`) + (char=? dc #\,) + (char=? dc #\;) + (char=? dc #\") + (and (char=? dc #\.) + (check-parameter read-cdot config)))])) + +(define (char-delimiter? c config) + (readtable-char-delimiter? (read-config-readtable config) c config)) diff --git a/racket/src/expander/read/demo.rkt b/racket/src/expander/read/demo.rkt new file mode 100644 index 0000000000..ba8193ec7f --- /dev/null +++ b/racket/src/expander/read/demo.rkt @@ -0,0 +1,186 @@ +#lang at-exp racket/base +(require racket/flonum + (rename-in "main.rkt" + [read main:read] + [read-language main:read-language])) + +(define (s->p . strs) + (define p (open-input-string (apply string-append strs))) + (port-count-lines! p) + p) + +(define test-read + (case-lambda + [(in) (main:read in #:source "input")] + [(in expect) + (define v (test-read in)) + (unless (equal? v expect) + (error 'test "fail\n got: ~s\n expect: ~s" + v + expect)) + v])) + +(test-read (s->p "#:a") + '#:a) +(test-read (s->p "#\\a") + #\a) +(test-read (s->p "#\\110") + #\H) +(test-read (s->p "#\\u0001") + #\u1) +(test-read (s->p "#\\U3BB") + #\u3BB) +(test-read (s->p "#\\\u3BB") + #\u3BB) +(test-read (s->p "|ap ple|Pie") + '|ap plePie|) +(test-read (s->p "\\|\\|") + '\|\|) +(test-read (s->p "(a b #%c)") + '(a b #%c)) +(test-read (s->p "(a #;z b . c)") + '(a b . c)) +(parameterize ([read-cdot #t]) + (test-read (s->p "(a b . c)") + '(a (#%dot b c)))) +(parameterize ([read-cdot #t]) + (test-read (s->p "a.b.c.d|.|f") + '(#%dot (#%dot (#%dot a b) c) d.f))) +(test-read (s->p "(b . a . c)") + '(a b c)) +(test-read (s->p "(b . a #| a |# . c)") + '(a b c)) +(test-read (s->p "(a 1.0 ; comment\n c)") + '(a 1.0 c)) +(test-read (s->p "(a \"1.0\" c)") + '(a "1.0" c)) +(test-read (s->p "'('a `b ,c ,@d ,@ e #'f #`g #,h #,@i)") + ''('a `b ,c ,@d ,@e #'f #`g #,h #,@i)) +(test-read (s->p "(#t)") + '(#t)) +(test-read (s->p "#f") + '#f) +(test-read (s->p "(#true)") + '(#t)) +(test-read (s->p "#ci (#false)") + '(#f)) +(test-read (s->p "#005(fAl Se)") + '#(fAl Se Se Se Se)) +(test-read (s->p "#fl6(1.5 0.33 0.3)") + (flvector 1.5 0.33 0.3 0.3 0.3 0.3)) +(let ([ht (test-read (s->p "#1=#hasheq((#1# . #1#))"))]) + (unless (eq? (hash-ref ht ht) ht) + (error 'test "fail for cyclic hash table"))) +(test-read (s->p "#hash{(fAl . Se) (7 . 9)}") + #hash{(fAl . Se) (7 . 9)}) +(test-read (s->p "#hasheq()") + #hasheq()) +(test-read (s->p "#s(fAl Se)") + #s(fAl Se)) +(test-read (s->p "#&fox") + #&fox) +(test-read @s->p{#px#"fox"} + #px#"fox") +(test-read (s->p "{fAl Se}") + '(fAl Se)) +(test-read (s->p "#{fAl Se}") + '#(fAl Se)) +(test-read (s->p "#! ok \\\n more\n 8") + 8) +(test-read @s->p{"apple\n\"\x30\7\07\u3BB\U1F600\uD83D\uDE00"} + "apple\n\"\x30\7\07\u3BB\U1F600\U1F600") +(test-read @s->p{#"apple\n\"\x30\7\07"} + #"apple\n\"0\a\a") +(test-read @s->p{#<p "{fAl Se}") + '(#%braces fAl Se))) +(parameterize ([read-case-sensitive #f]) + (test-read (s->p "Case\\InSens") + 'caseInsens)) +(with-handlers ([exn:fail:read? exn-message]) + (test-read (s->p "{ fAl\n Se)"))) + +(parameterize ([current-readtable (make-readtable #f + #\$ #\( #f + #\% #\) #f)]) + (test-read (s->p "$inside%") + '(inside))) +(parameterize ([current-readtable (make-readtable #f + #\t 'terminating-macro + (lambda (a b c d e f) 'TEE) + #\u 'non-terminating-macro + (lambda (a b c d e f) 'YOO))]) + (test-read (s->p "(1t2u3)") + '(1 TEE 2u3))) +(parameterize ([current-readtable (make-readtable #f + #\t 'dispatch-macro + (lambda (a b c d e f) 'TEE))]) + (test-read (s->p "(1 #t 2)") + '(1 TEE 2))) +(parameterize ([current-readtable (make-readtable #f + #\t 'dispatch-macro + (lambda (c in src long col pos) + (unless (equal? c #\t) + (error "not the expected character")) + (main:read in + #:recursive? #t + #:readtable #f)))]) + (test-read (s->p "(#1=(a) #t #1# #t#t)") + '((a) (a) #t))) +(parameterize ([read-accept-reader #t]) + (main:read (s->p "#readerok") #:dynamic-require (lambda (lib sym) + (lambda (in src line col pos) + 'OK)))) +(parameterize ([read-accept-reader #t]) + (main:read (s->p "#lang ok ?") + #:dynamic-require (lambda (lib sym) + (lambda (in src line col pos) + 'LANG-OK)) + #:module-declared? (lambda (mp) #f))) +(parameterize ([read-accept-reader #t]) + (main:read (s->p "#!ok ?") + #:dynamic-require (lambda (lib sym) + (lambda (in) + '|#!-OK|)) + #:module-declared? (lambda (mp) #t))) + +(main:read-language (s->p "#lang racket/base") (lambda () (error "fail")) + #:dynamic-require (lambda (lib sym fail-k) + (lambda (in src line col pos) + (lambda (x y) 'LANG-INFO))) + #:module-declared? (lambda (mp) #f)) + +(parameterize ([current-readtable (make-readtable #f + #\# #\a #f)]) + (test-read (s->p "#ab#") + '|#ab#|)) + +(with-handlers ([exn:fail:read? exn-message]) + (parameterize ([current-readtable (make-readtable #f + #\* #\) #f + #\! #\) #f)]) + (main:read (s->p "(x")))) + +(define s (let ([o (open-output-bytes)]) + (display "(" o) + (for ([i 100000]) (display " " o) (display i o)) + (display ")" o) + (get-output-string o))) +(collect-garbage) +(require "accum-string.rkt" + "config.rkt") +(void (time (let ([p (s->p s)]) + ;; Sortof a baseline measurement: + (define accum-str (accum-string-init! (make-read-config))) + (let loop ([v #f]) + (unless (eof-object? (peek-char-or-special p)) + (loop (accum-string-add! accum-str (read-char-or-special p)))))))) +(void (time (test-read (s->p s)))) +(void (time (read (s->p s)))) diff --git a/racket/src/expander/read/digit.rkt b/racket/src/expander/read/digit.rkt new file mode 100644 index 0000000000..95a318be7c --- /dev/null +++ b/racket/src/expander/read/digit.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "consume.rkt" + "accum-string.rkt") + +(provide read-digits + digit? + decimal-digit? + octal-digit? + hex-digit? + digit->number) + +(define (read-digits in config [accum-str #f] + #:base base #:max-count max-count + #:init [init-v 0] + #:zero-digits-result [zero-digits-result #f]) + (define c (peek-char/special in config)) + (cond + [(digit? c base) + (consume-char in c) + (when accum-str (accum-string-add! accum-str c)) + (let loop ([v (+ (digit->number c) (* init-v base))] + [max-count (sub1 max-count)]) + (cond + [(zero? max-count) v] + [else + (define c (peek-char/special in config)) + (cond + [(digit? c base) + (consume-char in c) + (when accum-str (accum-string-add! accum-str c)) + (loop (+ (digit->number c) (* v base)) (sub1 max-count))] + [else v])]))] + [zero-digits-result zero-digits-result] + [else c])) + +(define (digit? c base) + (cond + [(not (char? c)) #f] + [(= base 8) (octal-digit? c)] + [(= base 16) (hex-digit? c)] + [else (decimal-digit? c)])) + +(define (decimal-digit? c) + (and (char>=? c #\0) (char<=? c #\9))) + +(define (octal-digit? c) + (and (char>=? c #\0) (char<=? c #\7))) + +(define (hex-digit? c) + (or (and (char>=? c #\0) (char<=? c #\9)) + (and (char>=? c #\A) (char<=? c #\F)) + (and (char>=? c #\a) (char<=? c #\f)))) + +(define (digit->number c) + (cond + [(and (char>=? c #\0) (char<=? c #\9)) + (- (char->integer c) (char->integer #\0))] + [(and (char>=? c #\A) (char<=? c #\F)) + (- (char->integer c) (- (char->integer #\A) 10))] + [else + (- (char->integer c) (- (char->integer #\a) 10))])) diff --git a/racket/src/expander/read/error.rkt b/racket/src/expander/read/error.rkt new file mode 100644 index 0000000000..6a421240e9 --- /dev/null +++ b/racket/src/expander/read/error.rkt @@ -0,0 +1,47 @@ +#lang racket/base +(require "config.rkt") + +(provide reader-error + bad-syntax-error + catch-and-reraise-as-reader) + +(define (reader-error in config + #:continuation-marks [continuation-marks (current-continuation-marks)] + #:due-to [due-to #\x] + #:who [who (if (read-config-for-syntax? config) + 'read-syntax + 'read)] + str . args) + (define msg (format "~a: ~a" who (apply format str args))) + (define srcloc (and in (port+config->srcloc in config))) + (raise + ((cond + [(eof-object? due-to) exn:fail:read:eof] + [(not (char? due-to)) exn:fail:read:non-char] + [else exn:fail:read]) + (let ([s (and (error-print-source-location) + srcloc + (srcloc->string srcloc))]) + (if s + (string-append s ": " msg) + msg)) + continuation-marks + (if srcloc + (list srcloc) + null)))) + +(define (bad-syntax-error in config str #:due-to [due-to #\x]) + (reader-error in config #:due-to due-to "bad syntax `~a`" str)) + + +(define-syntax-rule (catch-and-reraise-as-reader in config expr) + (catch-and-reraise-as-reader/proc in config (lambda () expr))) + +(define (catch-and-reraise-as-reader/proc in config thunk) + (with-handlers ([exn:fail? (lambda (exn) + (reader-error in config + "~a" + (let ([s (exn-message exn)]) + (regexp-replace "^[a-z-]*: " s "")) + #:continuation-marks (exn-continuation-marks exn)))]) + (thunk))) diff --git a/racket/src/expander/read/extension.rkt b/racket/src/expander/read/extension.rkt new file mode 100644 index 0000000000..fbfe37981d --- /dev/null +++ b/racket/src/expander/read/extension.rkt @@ -0,0 +1,239 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "consume.rkt" + "error.rkt" + "accum-string.rkt" + "parameter.rkt" + "wrap.rkt" + "coerce.rkt" + "special-comment.rkt") + +(provide read-extension-reader + read-extension-lang + read-extension-#!) + +(define (read-extension-reader read-one read-recur dispatch-c in config) + (define extend-str (read-extension-prefix (cons dispatch-c '(#\r #\e)) + '(#\a #\d #\e #\r) + in + config)) + (unless (check-parameter read-accept-reader config) + (reader-error in config + "`~a` not enabled" + extend-str)) + + (define mod-path-wrapped (read-one #f in (next-readtable config))) + (when (eof-object? mod-path-wrapped) + (reader-error in config #:due-to mod-path-wrapped + "expected a datum after `~a`, found end-of-file" + extend-str)) + + (read-extension ((read-config-coerce config) #f mod-path-wrapped #f) + read-recur in config + #:mod-path-wrapped mod-path-wrapped)) + +;; ---------------------------------------- + +(define (read-extension-lang read-recur dispatch-c in config + #:get-info? [get-info? #f]) + (define extend-str (read-extension-prefix (cons dispatch-c '(#\l)) + '(#\a #\n #\g) + in + config)) + (define c (read-char/special in config)) + (unless (char=? c #\space) + (reader-error in config + "expected a single space after `~a`" + extend-str)) + + (read-lang extend-str read-recur in config + #:who '|#lang| + #:get-info? get-info?)) + +(define (read-extension-#! read-recur dispatch-c in config + #:get-info? [get-info? #f]) + (define c (read-char/special in config)) + (unless (char-lang-nonsep? c) + (bad-syntax-error in config (if (char? c) + (string dispatch-c #\! c) + (string dispatch-c #\!)))) + (read-lang (string dispatch-c #\!) read-recur in config + #:init-c c + #:who '|#!| + #:get-info? get-info?)) + +;; ---------------------------------------- + +(define (read-lang extend-str read-recur in config + #:init-c [init-c #f] + #:get-info? [get-info? #f] + #:who who) + (unless (and (check-parameter read-accept-reader config) + (check-parameter read-accept-lang config)) + (reader-error in config + "`~a` not enabled" + extend-str)) + + (define accum-str (accum-string-init! config)) + (when init-c + (accum-string-add! accum-str init-c)) + (let loop () + (define c (peek-char/special in config)) + (cond + [(eof-object? c) (void)] + [(not (char? c)) + (consume-char/special in config c) + (reader-error in config #:due-to c + "found non-character while reading `#~a'" + extend-str)] + [(char-whitespace? c) (void)] + [(or (char-lang-nonsep? c) + (char=? #\/ c)) + (consume-char in c) + (accum-string-add! accum-str c) + (loop)] + [else + (consume-char in c) + (reader-error in config + (string-append "expected only alphanumeric, `-`, `+`, `_`, or `/`" + " characters for `~a`, found `~a`") + extend-str + c)])) + + (define lang-str (accum-string-get! accum-str config)) + (when (equal? lang-str "") + (reader-error in config + "expected a non-empty sequence of alphanumeric, `-`, `+`, `_`, or `/` after `~a`" + extend-str)) + + (when (char=? #\/ (string-ref lang-str 0)) + (reader-error in config + "expected a name that does not start `/` after `~a`" + extend-str)) + + (when (char=? #\/ (string-ref lang-str (sub1 (string-length lang-str)))) + (reader-error in config + "expected a name that does not end `/` after `~a`" + extend-str)) + + (define submod-path `(submod ,(string->symbol lang-str) reader)) + (define reader-path (string->symbol (string-append lang-str "/lang/reader"))) + + (read-extension #:try-first-mod-path submod-path + reader-path read-recur in config + #:get-info? get-info? + #:who who)) + +(define (char-lang-nonsep? c) + (and ((char->integer c) . < . 128) + (or (char-alphabetic? c) + (char-numeric? c) + (char=? #\- c) + (char=? #\+ c) + (char=? #\_ c)))) + +;; ---------------------------------------- + +(define (read-extension-prefix already wanted in config) + (define accum-str (accum-string-init! config)) + (for ([c (in-list already)]) + (accum-string-add! accum-str c)) + (let loop ([wanted wanted]) + (unless (null? wanted) + (define c (read-char/special in config)) + (when (char? c) + (accum-string-add! accum-str c)) + (unless (eqv? c (car wanted)) + (bad-syntax-error in config (accum-string-get! accum-str config) + #:due-to c)) + (loop (cdr wanted)))) + (accum-string-get! accum-str config)) + +;; ---------------------------------------- + +(define (read-extension #:try-first-mod-path [try-first-mod-path #f] + mod-path-datum read-recur in config + #:mod-path-wrapped [mod-path-wrapped + ((read-config-coerce config) + #t + mod-path-datum + #f)] + #:get-info? [get-info? #f] + #:who [who '|#reader|]) + (force-parameters! config) + (define guard (current-reader-guard)) + (define mod-path + (or (and try-first-mod-path + (let ([mod-path (guard try-first-mod-path)]) + (and ((read-config-module-declared? config) try-first-mod-path) + mod-path))) + (guard mod-path-datum))) + + (define for-syntax? (read-config-for-syntax? config)) + + (define dynamic-require (read-config-dynamic-require config)) + + (define no-value (gensym)) + + (define extension + (cond + [get-info? + (dynamic-require mod-path 'get-info (lambda () no-value))] + [else + (dynamic-require mod-path (if for-syntax? 'read-syntax 'read))])) + + (cond + [(eq? extension no-value) + ;; Only for `get-info?` mode: + #f] + [else + (define result-v + (cond + [(and for-syntax? (not get-info?)) + (cond + [(procedure-arity-includes? extension 6) + (parameterize ([current-read-config config]) + (extension (read-config-source config) + in + mod-path-wrapped + (read-config-line config) + (read-config-col config) + (read-config-pos config)))] + [(procedure-arity-includes? extension 2) + (parameterize ([current-read-config config]) + (extension (read-config-source config) in))] + [else + (raise-argument-error who + "(or/c (procedure-arity-includes?/c 2) (procedure-arity-includes?/c 6))" + extension)])] + [else + (cond + [(procedure-arity-includes? extension 5) + (parameterize ([current-read-config config]) + (extension in + mod-path-wrapped + (read-config-line config) + (read-config-col config) + (read-config-pos config)))] + [get-info? + (raise-argument-error who + "(procedure-arity-includes?/c 5)" + extension)] + [(procedure-arity-includes? extension 1) + (parameterize ([current-read-config config]) + (extension in))] + [else + (raise-argument-error who + "(or/c (procedure-arity-includes?/c 1) (procedure-arity-includes?/c 5))" + extension)])])) + + (cond + [get-info? + (unless (and (procedure? result-v) (procedure-arity-includes? result-v 2)) + (raise-result-error 'read-language "(procedure-arity-includes?/c 2)" result-v)) + result-v] + [(special-comment? result-v) + (read-recur in config)] + [else + (coerce result-v in config)])])) diff --git a/racket/src/expander/read/fixnum-flonum.rkt b/racket/src/expander/read/fixnum-flonum.rkt new file mode 100644 index 0000000000..6f2c2697d2 --- /dev/null +++ b/racket/src/expander/read/fixnum-flonum.rkt @@ -0,0 +1,42 @@ +#lang racket/base +(require "config.rkt" + "error.rkt" + "whitespace.rkt" + "location.rkt" + "special.rkt" + "symbol-or-number.rkt") + +(provide read-fixnum + read-flonum) + +(define (read-fixnum read-one init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + (define v (read-number-literal c in config "#e")) + (cond + [(fixnum? v) v] + [(eof-object? v) v] + [else + (reader-error in (reading-at config line col pos) + "expected a fixnum, found ~a" + v)])) + +(define (read-flonum read-one init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + (define v (read-number-literal c in config "#i")) + (cond + [(flonum? v) v] + [(eof-object? v) v] + [else + (reader-error in (reading-at config line col pos) + "expected a flonum, found ~a" + v)])) + +;; ---------------------------------------- + +(define (read-number-literal c in config mode) + (cond + [(not (char? c)) c] + [else + (read-symbol-or-number c in config #:mode mode)])) diff --git a/racket/src/expander/read/graph.rkt b/racket/src/expander/read/graph.rkt new file mode 100644 index 0000000000..0fdee7cf5f --- /dev/null +++ b/racket/src/expander/read/graph.rkt @@ -0,0 +1,108 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "readtable.rkt" + "accum-string.rkt" + "parameter.rkt" + "error.rkt" + "digit.rkt" + "vector.rkt") + +(provide read-vector-or-graph + get-graph-hash) + +(define (read-vector-or-graph read-one dispatch-c init-c in config) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str init-c) + + (define init-v (digit->number init-c)) + + (define v (read-digits in config accum-str + #:base 10 #:max-count +inf.0 + #:init init-v + #:zero-digits-result init-v)) + (define-values (post-line post-col post-pos) (port-next-location in)) + + (define (get-accum c) + (format "~a~a~a" dispatch-c (accum-string-get! accum-str config) c)) + (define-syntax-rule (guard-legal e c body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (get-accum c))])) + + (define c (read-char/special in config)) + (define ec (effective-char c config)) + (case ec + [(#\() + (accum-string-abandon! accum-str config) + (read-vector read-one c #\( #\) in config #:length v)] + [(#\[) + (accum-string-abandon! accum-str config) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + (get-accum c) + (read-vector read-one c #\[ #\] in config #:length v))] + [(#\{) + (accum-string-abandon! accum-str config) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + (get-accum c) + (read-vector read-one c #\{ #\} in config #:length v))] + [else + (case c + [(#\= #\#) + (when (or (read-config-for-syntax? config) + (not (check-parameter read-accept-graph config))) + (reader-error in config + "`#...~a` forms not ~a" + c + (if (read-config-for-syntax? config) + "enabled" + "allowed in `read-syntax` mode"))) + (unless ((accum-string-count accum-str) . <= . 8) + (reader-error in config + "graph ID too long in `~a~a~a`" + dispatch-c (accum-string-get! accum-str config) c)) + (case c + [(#\=) + (define ph (make-placeholder 'placeholder)) + (define ht (get-graph-hash config)) + (when (hash-ref ht v #f) + (reader-error in config + "multiple `~a~a~a` tags" + dispatch-c (accum-string-get! accum-str config) c)) + (hash-set! ht v ph) + (define result-v (read-one #f in (next-readtable config))) + (when (eof-object? result-v) + (reader-error in config #:due-to result-v + "expected an element for graph after `~a~a~a`, found end-of-file" + dispatch-c (accum-string-get! accum-str config) c)) + (accum-string-abandon! accum-str config) + (placeholder-set! ph result-v) + ph] + [(#\#) + (begin0 + (hash-ref + (or (read-config-state-graph (read-config-st config)) + #hash()) + v + (lambda () + (reader-error in config + "no preceding `~a~a=` for `~a~a~a`" + dispatch-c v + dispatch-c (accum-string-get! accum-str config) c))) + (accum-string-abandon! accum-str config))])] + [else + (reader-error in config + #:due-to c + "bad syntax `~a`" + (get-accum c))])])) + +;; ---------------------------------------- + +(define (get-graph-hash config) + (define st (read-config-st config)) + (or (read-config-state-graph st) + (let ([ht (make-hasheqv)]) + (set-read-config-state-graph! st ht) + ht))) diff --git a/racket/src/expander/read/hash.rkt b/racket/src/expander/read/hash.rkt new file mode 100644 index 0000000000..3430d48ec3 --- /dev/null +++ b/racket/src/expander/read/hash.rkt @@ -0,0 +1,180 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "readtable.rkt" + "whitespace.rkt" + "delimiter.rkt" + "consume.rkt" + "location.rkt" + "error.rkt" + "accum-string.rkt" + "indentation.rkt" + "closer.rkt" + "parameter.rkt" + "coerce-key.rkt" + "wrap.rkt" + "sequence.rkt" + "special-comment.rkt") + +(provide read-hash) + +;; `#` and `h` or `H` have been read +(define (read-hash read-one dispatch-c init-c in config) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str dispatch-c) + (accum-string-add! accum-str init-c) + + (define (get-next! expect-c expect-alt-c) + (define c (read-char/special in config)) + (unless (or (eqv? c expect-c) (eqv? c expect-alt-c)) + (reader-error in config #:due-to c + "expected `~a` after `~a`" + expect-c (accum-string-get! accum-str config))) + (accum-string-add! accum-str c)) + + (get-next! #\a #\A) + (get-next! #\s #\S) + (get-next! #\h #\H) + + (define-values (content opener mode) + (let loop ([mode 'equal]) + (define c (read-char/special in config)) + (define ec (effective-char c config)) + (case ec + [(#\() + (define read-one-key+value (make-read-one-key+value read-one c #\))) + (values (read-unwrapped-sequence read-one-key+value c #\( #\) in config + #:elem-config config + #:dot-mode #f) + ec + mode)] + [(#\[) + (cond + [(check-parameter read-square-bracket-as-paren config) + (define read-one-key+value (make-read-one-key+value read-one c #\])) + (values (read-unwrapped-sequence read-one-key+value c #\[ #\] in config + #:elem-config config + #:dot-mode #f) + ec + mode)] + [else + (reader-error in config "illegal use of `~a`" c)])] + [(#\{) + (cond + [(check-parameter read-curly-brace-as-paren config) + (define read-one-key+value (make-read-one-key+value read-one c #\})) + (values (read-unwrapped-sequence read-one-key+value c #\{ #\} in config + #:elem-config config + #:dot-mode #f) + ec + mode)] + [else + (reader-error in config "illegal use of `~a`" c)])] + [(#\e #\E) + (accum-string-add! accum-str c) + (get-next! #\q #\Q) + (loop 'eq)] + [(#\v #\V) + (accum-string-add! accum-str c) + (if (eq? mode 'eq) + (loop 'eqv) + (reader-error in config + "bad syntax `~a`" + (accum-string-get! accum-str config)))] + [else + (when (char? c) + (accum-string-add! accum-str c)) + (reader-error in config #:due-to c + "bad syntax `~a`" + (accum-string-get! accum-str config))]))) + + (define graph? (and (read-config-state-graph + (read-config-st config)) + #t)) + + (wrap (case mode + [(equal) + (if graph? + (make-hash-placeholder content) + (make-immutable-hash content))] + [(eq) + (if graph? + (make-hasheq-placeholder content) + (make-immutable-hasheq content))] + [(eqv) + (if graph? + (make-hasheqv-placeholder content) + (make-immutable-hasheqv content))]) + in + config + opener)) + +;; ---------------------------------------- + +(define ((make-read-one-key+value read-one overall-opener-c overall-closer-ec) init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (open-line open-col open-pos) (port-next-location* in c)) + (define ec (effective-char c config)) + (define elem-config (next-readtable config)) + + (define closer + (case ec + [(#\() #\)] + [(#\[) (and (check-parameter read-square-bracket-as-paren config) + #\])] + [(#\{) (and (check-parameter read-curly-brace-as-paren config) + #\})] + [else #f])) + + (cond + [(not closer) + (cond + [(eof-object? c) + (reader-error in (reading-at config open-line open-col open-pos) + #:due-to c + "expected ~a to close `~a`" + (closer-name overall-closer-ec config) overall-opener-c)] + [(char-closer? ec config) + (reader-error in (reading-at config open-line open-col open-pos) + "~a" + (indentation-unexpected-closer-message ec c config))] + [else + ;; If it's a special or we have a readtable, we need to read ahead + ;; to make sure that it's not a comment. For consistency, always + ;; read ahead. + (define v (read-one c in (keep-comment elem-config))) + (cond + [(special-comment? v) + ;; Try again + ((make-read-one-key+value read-one overall-opener-c overall-closer-ec) #f in config)] + [else + (reader-error in (reading-at config open-line open-col open-pos) + "expected ~a to start a hash pair" + (all-openers-str config))])])] + [else + (define k (read-one #f in (disable-wrapping elem-config))) + + (define dot-c (read-char/skip-whitespace-and-comments #f read-one in config)) + (define-values (dot-line dot-col dot-pos) (port-next-location* in dot-c)) + (define dot-ec (effective-char dot-c config)) + + (unless (and (eqv? dot-ec #\.) + (char-delimiter? (peek-char/special in config) config)) + (reader-error in (reading-at config dot-line dot-col dot-pos) + #:due-to dot-c + "expected ~a and value for hash" + (dot-name config))) + + (define v (read-one #f in elem-config)) + + (define closer-c (read-char/skip-whitespace-and-comments #f read-one in config)) + (define-values (closer-line closer-col closer-pos) (port-next-location* in closer-c)) + (define closer-ec (effective-char closer-c config)) + + (unless (eqv? closer-ec closer) + (reader-error in (reading-at config closer-line closer-col closer-pos) + #:due-to closer-c + "expected ~a after value within a hash" + (closer-name closer config))) + + (cons (coerce-key k elem-config) v)])) diff --git a/racket/src/expander/read/indentation.rkt b/racket/src/expander/read/indentation.rkt new file mode 100644 index 0000000000..150584fd23 --- /dev/null +++ b/racket/src/expander/read/indentation.rkt @@ -0,0 +1,97 @@ +#lang racket/base +(require "config.rkt" + "closer.rkt") + +(provide make-indentation + track-indentation! + indentation-possible-cause + indentation-unexpected-closer-message) + +(struct indentation + (closer ; expected close paren, bracket, etc. + [suspicious-closer #:mutable] ; expected closer when suspicious line found + [multiline? #:mutable] ; set to #f if the match attempt spans a line + start-line ; opener's line + [last-line #:mutable] ; current line, already checked the identation + [suspicious-line #:mutable] ; non-#f => first suspicious line since opener + [max-indent #:mutable] ; max indentation encountered since opener, not counting brackets by a more neseted opener + [suspicious-quote #:mutable])) ; non-#f => first suspicious quote whose closer is on a different line + + +(define (make-indentation closer in config) + (define-values (line col pos) (port-next-location in)) + (indentation closer + #f ; suspicious-closer + #f ; multiline? + line ; start-line + line ; last-line + #f ; suspicious-line + (and col (add1 col)) ; max-indent + #f)) ; suspicious-quote + +(define (track-indentation! config line col) + (define indts (read-config-indentations config)) + (define indt (and (pair? indts) (car indts))) + (when (and indt + line + (indentation-last-line indt) + ;; Already checked this line? + (line . > . (indentation-last-line indt))) + (set-indentation-last-line! indt line) + (set-indentation-multiline?! indt #t) + ;; At least as indented as before? + (cond + [(col . >= . (indentation-max-indent indt)) + (set-indentation-max-indent! indt col)] + [else + (unless (indentation-suspicious-line indt) + ;; Not as indented, and no suspicious line found already. + ;; Suspect that the closer should have appeared earlier. + (set-indentation-suspicious-closer! indt (indentation-closer indt)) + (set-indentation-suspicious-line! indt line))]))) + +(define (indentation-possible-cause config) + (define indt (car (read-config-indentations config))) + (cond + [(indentation-suspicious-line indt) + (format "\n possible cause: indentation suggests a missing ~a before line ~a" + (closer-name (indentation-suspicious-closer indt) config) + (indentation-suspicious-line indt))] + [else ""])) + +(define (indentation-unexpected-closer-message ec c config) + (define indts (read-config-indentations config)) + (cond + [(null? indts) + (format "unexpected `~a`" c)] + [else + (define indt (car indts)) + (string-append + ;; Base message: + (cond + [(char=? ec (indentation-closer indt)) + ;; If this closer is the expected on, why did we get an error? + (format "unexpected `~a`" c)] + [else + ;; If we're expecting this closer later, then it's not so much + ;; "unexpected" as we expected something else... + (define missing + (or (for/or ([indt (in-list (cdr indts))]) + (and (char=? ec (indentation-closer indt)) + "missing")) + "expected")) + (define opener-str + (opener-name (closer->opener (indentation-closer indt)) config)) + (format "~a ~a to close ~a, found instead `~a`" + missing + (closer-name (indentation-closer indt) config) + (cond + [(indentation-multiline? indt) + (format "~a on line ~a" + opener-str + (indentation-start-line indt))] + [else + (format "preceding ~a" opener-str)]) + c)]) + ;; Possibly add a cause based on indentation: + (indentation-possible-cause config))])) diff --git a/racket/src/expander/read/language.rkt b/racket/src/expander/read/language.rkt new file mode 100644 index 0000000000..e1f1bb329f --- /dev/null +++ b/racket/src/expander/read/language.rkt @@ -0,0 +1,52 @@ +#lang racket/base +(require "config.rkt" + "whitespace.rkt" + "consume.rkt" + "parameter.rkt" + "special.rkt" + "error.rkt" + "location.rkt" + "extension.rkt") + +(provide read-language/get-info) + +(define (read-language/get-info read-one in config fail-k) + (define c (read-char/skip-whitespace-and-comments #f read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + + (define l-config (override-parameter read-accept-reader + (reading-at config line col pos) + #t)) + + (cond + [(not (eqv? c #\#)) + (if fail-k + (fail-k) + (lang-error in l-config "" c))] + [else + (define c2 (read-char/special in l-config)) + (cond + [(eqv? c2 #\l) + (read-extension-lang read-one c in l-config #:get-info? #t)] + [(eqv? c2 #\!) + (read-extension-#! read-one c in l-config #:get-info? #t)] + [else + (if fail-k + (fail-k) + (lang-error in l-config (string c) c2))])])) + + +(define (lang-error in config prefix c) + (define (add-prefix s) + (if (string=? prefix "") + (format "`~a` followed by ~a" prefix s) + s)) + (reader-error in config + #:due-to c + #:who 'read-language + (string-append "expected (after whitespace and comments) `#lang ` or `#!` followed" + " immediately by a language name, found ~a") + (cond + [(eof-object? c) (add-prefix "end-of-file")] + [(not (char? c)) (add-prefix "non-character")] + [else (format "`~a~a`" prefix c)]))) diff --git a/racket/src/expander/read/location.rkt b/racket/src/expander/read/location.rkt new file mode 100644 index 0000000000..c80ffd0614 --- /dev/null +++ b/racket/src/expander/read/location.rkt @@ -0,0 +1,14 @@ +#lang racket/base + +(provide port-next-location*) + +(define (port-next-location* in init-c) + ;; If weve already read `init-c`, then back up by one column and + ;; position; we assume that `init-c` is not a newline character + (cond + [(not init-c) (port-next-location in)] + [else + (define-values (line col pos) (port-next-location in)) + (values line + (and col (max 0 (sub1 col))) + (and pos (max 1 (sub1 pos))))])) diff --git a/racket/src/expander/read/main.rkt b/racket/src/expander/read/main.rkt new file mode 100644 index 0000000000..bc7f43fbd1 --- /dev/null +++ b/racket/src/expander/read/main.rkt @@ -0,0 +1,405 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "coerce.rkt" + "readtable.rkt" + "whitespace.rkt" + "delimiter.rkt" + "closer.rkt" + "consume.rkt" + "location.rkt" + "accum-string.rkt" + "error.rkt" + "indentation.rkt" + "parameter.rkt" + "primitive-parameter.rkt" + "special-comment.rkt" + "sequence.rkt" + "vector.rkt" + "struct.rkt" + "graph.rkt" + "hash.rkt" + "symbol-or-number.rkt" + "string.rkt" + "char.rkt" + "quote.rkt" + "constant.rkt" + "box.rkt" + "regexp.rkt" + "extension.rkt" + "language.rkt" + "number.rkt") + +(provide read + read-language + + current-readtable + make-readtable + readtable? + readtable-mapping + + string->number + + (all-from-out "primitive-parameter.rkt") + (all-from-out "special-comment.rkt")) + +;; This is not the `read` to be exposed from `racket/base`, but a +;; general entry to point implement `read` and variants like +;; `read-syntax` and `read/recursive`. To support syntax objects, the +;; caller should provide the `dynamic-require`, `read-compiled`, +;; `module-declared?`, and `corece` functions, even when implementing +;; a plain `read`, since those might be needed by a +;; `read-syntax/recursive`. +(define (read in + #:wrap [wrap #f] + #:init-c [init-c #f] + #:next-readtable [next-readtable (current-readtable)] + #:readtable [readtable next-readtable] + #:recursive? [recursive? #f] + #:local-graph? [local-graph? #f] ; ignored unless `recursive?` + #:source [source #f] + #:for-syntax? [for-syntax? #f] + #:read-compiled [read-compiled #f] ; see "config.rkt" + #:dynamic-require [dynamic-require #f] ; see "config.rkt" + #:module-declared? [module-declared? #f] ; see "config.rkt" + #:coerce [coerce #f] ; see "config.rkt" + #:coerce-key [coerce-key #f] ; see "config.rkt" + #:keep-comment? [keep-comment? recursive?]) + (define config + (cond + [(and recursive? + (current-read-config)) + => (lambda (config) + (read-config-update config + #:for-syntax? for-syntax? + #:wrap wrap + #:readtable readtable + #:next-readtable next-readtable + #:reset-graph? local-graph? + #:keep-comment? keep-comment?))] + [else + (make-read-config #:readtable readtable + #:next-readtable next-readtable + #:source source + #:for-syntax? for-syntax? + #:wrap wrap + #:read-compiled read-compiled + #:dynamic-require dynamic-require + #:module-declared? module-declared? + #:coerce coerce + #:coerce-key coerce-key + #:keep-comment? keep-comment?)])) + (define v (read-one init-c in config)) + (cond + [(and (or (not recursive?) local-graph?) + (read-config-state-graph (read-config-st config))) + (catch-and-reraise-as-reader + #f config + (make-reader-graph v))] + [(and recursive? + (not local-graph?) + (not for-syntax?) + (not (eof-object? v)) + (not (special-comment? v))) + (get-graph-hash config) ; to trigger placeholder resolution + (make-placeholder v)] + [else v])) + +(define (read-language in fail-k + #:for-syntax? [for-syntax? #f] + #:wrap [wrap #f] + #:read-compiled [read-compiled #f] + #:dynamic-require [dynamic-require #f] + #:module-declared? [module-declared? #f] + #:coerce [coerce #f] + #:coerce-key [coerce-key #f]) + (define config (make-read-config #:readtable #f + #:next-readtable #f + #:for-syntax? for-syntax? + #:wrap wrap + #:read-compiled read-compiled + #:dynamic-require dynamic-require + #:module-declared? module-declared? + #:coerce coerce + #:coerce-key coerce-key)) + (define l-config (override-parameter read-accept-reader config #f)) + (read-language/get-info read-undotted in config fail-k)) + +;; ---------------------------------------- +;; The top-level reading layer that takes care of parsing into +;; `#%cdot`. + +(define (read-one init-c in config) + (cond + [(not (check-parameter read-cdot config)) + ;; No parsing of `.` as `#%dot` + (read-undotted init-c in config)] + [(check-parameter read-cdot config) + ;; Look for ` . ` + (define-values (line col pos) (port-next-location in)) + (define v (read-undotted init-c in config)) + (cond + [(special-comment? v) v] + [else + (let loop ([v v]) + (define c (peek-char/special in config)) + (define ec (effective-char c config)) + (cond + [(not (char? ec)) v] + [(char-whitespace? ec) + (consume-char in c) + (loop v)] + [(char=? ec #\.) + (define-values (dot-line dot-col dot-pos) (port-next-location in)) + (consume-char in c) + (define cdot (wrap '#%dot in (reading-at config dot-line dot-col dot-pos) #\.)) + (define post-v (read-undotted #f in config)) + (loop (wrap (list cdot v post-v) in (reading-at config line col pos) #\.))] + [else v]))])])) + +;; ---------------------------------------- +;; The top-level reading layer within `#%dot` handling --- which is +;; the reader's main dispatch layer. + +(define (read-undotted init-c in config) + (define c (read-char/skip-whitespace-and-comments init-c read-one in config)) + (define-values (line col pos) (port-next-location* in c)) + (cond + [(eof-object? c) eof] + [(not (char? c)) + (define v (special-value c)) + (cond + [(special-comment? v) + (if (read-config-keep-comment? config) + v + (read-undotted #f in config))] + [else (coerce v in (reading-at config line col pos))])] + [(readtable-handler config c) + => (lambda (handler) + (define v (readtable-apply handler c in config line col pos)) + (retry-special-comment v in config))] + [else + ;; Map character via readtable: + (define ec (effective-char c config)) + + ;; Track indentation, unless it's a spurious closer: + (when (not (char-closer? ec config)) + (track-indentation! config line col)) + (define r-config (reading-at (discard-comment config) line col pos)) + + (define-syntax-rule (guard-legal e body ...) + (cond + [e body ...] + [else (reader-error in r-config "illegal use of `~a`" c)])) + + ;; Dispatch on character: + (case ec + [(#\#) + (read-dispatch c in r-config config)] + [(#\') + (read-quote read-one 'quote "quoting '" c in r-config)] + [(#\`) + (guard-legal + (check-parameter read-accept-quasiquote config) + (read-quote read-one 'quasiquote "quasiquoting `" c in r-config))] + [(#\,) + (guard-legal + (check-parameter read-accept-quasiquote config) + (define c2 (peek-char/special in config)) + (if (eqv? c2 #\@) + (begin + (consume-char in c2) + (read-quote read-one 'unquote-splicing "unquoting ,@" c in r-config)) + (read-quote read-one 'unquote "unquoting ," c in r-config)))] + [(#\() + (wrap (read-unwrapped-sequence read-one ec #\( #\) in r-config #:shape-tag? #t) in r-config ec)] + [(#\)) + (reader-error in r-config "~a" (indentation-unexpected-closer-message ec c r-config))] + [(#\[) + (guard-legal + (or (check-parameter read-square-bracket-as-paren config) + (check-parameter read-square-bracket-with-tag config)) + (wrap (read-unwrapped-sequence read-one ec #\[ #\] in r-config #:shape-tag? #t) in r-config ec))] + [(#\]) + (guard-legal + (or (check-parameter read-square-bracket-as-paren config) + (check-parameter read-square-bracket-with-tag config)) + (reader-error in r-config "~a" (indentation-unexpected-closer-message ec c r-config)))] + [(#\{) + (guard-legal + (or (check-parameter read-curly-brace-as-paren config) + (check-parameter read-curly-brace-with-tag config)) + (wrap (read-unwrapped-sequence read-one ec #\{ #\} in r-config #:shape-tag? #t) in r-config ec))] + [(#\}) + (guard-legal + (or (check-parameter read-curly-brace-as-paren config) + (check-parameter read-curly-brace-with-tag config)) + (reader-error in r-config "~a" (indentation-unexpected-closer-message ec c r-config)))] + [(#\") + (read-string in r-config)] + [(#\|) + (read-symbol-or-number c in r-config #:mode 'symbol)] + [else + (define v + (read-symbol-or-number c in r-config + ;; Don't read as a number if the effective char + ;; is non-numeric: + #:mode (if (or (eq? c ec) + (and ((char->integer ec) . < . 128) + (char-numeric? ec))) + 'symbol-or-number + 'symbol/indirect))) + (retry-special-comment v in config)])])) + +;; Dispatch on `#` character +(define (read-dispatch dispatch-c in config orig-config) + (define c (read-char/special in config)) + (cond + [(eof-object? c) + (reader-error in config #:due-to c "bad syntax `~a`" dispatch-c)] + [(not (char? c)) + (reader-error in config #:due-to c "bad syntax `~a`" dispatch-c)] + [(readtable-dispatch-handler orig-config c) + => (lambda (handler) + (define line (read-config-line config)) + (define col (read-config-col config)) + (define pos (read-config-pos config)) + (define v (readtable-apply handler c in config line col pos)) + (retry-special-comment v in orig-config))] + [else + (define-syntax-rule (guard-legal e c body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (format "~a~a" dispatch-c c))])) + (case c + [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + ;; Vector, graph definition, or graph reference + (read-vector-or-graph read-one dispatch-c c in config)] + [(#\() + (read-vector read-one #\( #\( #\) in config)] + [(#\[) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + c + (read-vector read-one #\[ #\[ #\] in config))] + [(#\{) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + c + (read-vector read-one #\{ #\{ #\} in config))] + [(#\s) + (read-struct read-one dispatch-c in config)] + [(#\&) + (read-box read-one dispatch-c in config)] + [(#\') + (read-quote read-one 'syntax "quoting #'" c in config)] + [(#\`) + (read-quote read-one 'quasisyntax "quasiquoting #`" c in config)] + [(#\,) + (define c2 (peek-char/special in config)) + (if (eqv? c2 #\@) + (begin + (consume-char in c2) + (read-quote read-one 'unsyntax-splicing "unquoting #,@" c in config)) + (read-quote read-one 'unsyntax "unquoting #," c in config))] + [(#\\) + (read-character in config)] + [(#\") + (read-string in config #:mode '|byte string|)] + [(#\<) + (define c2 (peek-char/special in config)) + (cond + [(eqv? #\< c2) + (consume-char in #\<) + (read-here-string in config)] + [else + (reader-error in config #:due-to c2 "bad syntax `~a<`" dispatch-c)])] + [(#\%) + (read-symbol-or-number c in config #:extra-prefix dispatch-c #:mode 'symbol)] + [(#\:) + (read-symbol-or-number #f in config #:mode 'keyword)] + [(#\t #\T) + (define c2 (peek-char/special in config)) + (cond + [(char-delimiter? c2 config) (wrap #t in config c)] + [else (read-delimited-constant c (char=? c #\t) '(#\r #\u #\e) #t in config)])] + [(#\f #\F) + (define c2 (peek-char/special in config)) + (cond + [(char-delimiter? c2 config) (wrap #f in config c)] + [(or (char=? c2 #\x) (char=? c2 #\l)) + (read-fixnum-or-flonum-vector read-one dispatch-c c c2 in config)] + [else (read-delimited-constant c (char=? c #\f) '(#\a #\l #\s #\e) #f in config)])] + [(#\e) (read-symbol-or-number #f in config #:mode "#e")] + [(#\E) (read-symbol-or-number #f in config #:mode "#E")] + [(#\i) (read-symbol-or-number #f in config #:mode "#i")] + [(#\I) (read-symbol-or-number #f in config #:mode "#I")] + [(#\d) (read-symbol-or-number #f in config #:mode "#d")] + [(#\B) (read-symbol-or-number #f in config #:mode "#B")] + [(#\o) (read-symbol-or-number #f in config #:mode "#o")] + [(#\O) (read-symbol-or-number #f in config #:mode "#O")] + [(#\D) (read-symbol-or-number #f in config #:mode "#D")] + [(#\b) (read-symbol-or-number #f in config #:mode "#b")] + [(#\x) (read-symbol-or-number #f in config #:mode "#x")] + [(#\X) (read-symbol-or-number #f in config #:mode "#X")] + [(#\c #\C) + (define c2 (read-char/special in config)) + (case c2 + [(#\s #\S) (read-one #f in (override-parameter read-case-sensitive config #t))] + [(#\i #\I) (read-one #f in (override-parameter read-case-sensitive config #f))] + [else + (reader-error in config #:due-to c2 + "expected `s', `S`, `i', or `I` after `~a~a`" + dispatch-c c)])] + [(#\h #\H) (read-hash read-one dispatch-c c in config)] + [(#\r) + ;; Maybe regexp or `#reader` + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str dispatch-c) + (accum-string-add! accum-str c) + (define c2 (read-char/special in config)) + (when (char? c2) (accum-string-add! accum-str c2)) + (case c2 + [(#\x) (read-regexp c accum-str in config)] + [(#\e) (read-extension-reader read-one read-undotted dispatch-c in config)] + [else + (bad-syntax-error in config + #:due-to c2 + (accum-string-get! accum-str config))])] + [(#\p) + ;; Maybe pregexp + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str dispatch-c) + (accum-string-add! accum-str c) + (define c2 (read-char/special in config)) + (when (char? c2) (accum-string-add! accum-str c2)) + (case c2 + [(#\x) (read-regexp c accum-str in config)] + [else (bad-syntax-error in config #:due-to c2 + (accum-string-get! accum-str config))])] + [(#\l) + ;; Maybe `#lang` + (read-extension-lang read-undotted dispatch-c in config)] + [(#\!) + ;; Maybe `#lang` + (read-extension-#! read-undotted dispatch-c in config)] + [(#\~) + ;; Compiled code + (cond + [(check-parameter read-accept-compiled config) + (wrap ((read-config-read-compiled config) in) in config c)] + [else + (reader-error in config + "`~a~~` compiled expressions not enabled" + dispatch-c)])] + [else + (reader-error in config "bad syntax `~a~a`" dispatch-c c)])])) + +(define (retry-special-comment v in config) + (cond + [(special-comment? v) + (if (read-config-keep-comment? config) + v + (read-undotted #f in config))] + [else v])) diff --git a/racket/src/expander/read/number.rkt b/racket/src/expander/read/number.rkt new file mode 100644 index 0000000000..b0812da13b --- /dev/null +++ b/racket/src/expander/read/number.rkt @@ -0,0 +1,829 @@ +#lang racket/base +(require racket/private/check + racket/extflonum + ;; Call the host `string->number` function only + ;; on valid fixnum, bignum, {single-,double-,ext}flonum + ;; representations that contain digits, possibly a + ;; leading sign, possibly a `.`, and possibly an + ;; exponent marker + (prefix-in host: "../host/string-to-number.rkt") + "parameter.rkt") + +(provide string->number) + +;; The `string->number` parser is responsible for handling Racket's +;; elaborate number syntax (mostly inherited from Scheme). It relies +;; on a host-system `string->number` that can handle well-formed +;; fixnum, bignum, and {double-,single-,extfl}flonum strings for a +;; given radix in the range [2,16]. Otherwise, the parser here +;; performs all checking that reader needs. + +(define/who (string->number s + [radix 10] + [convert-mode 'number-or-false] + [decimal-mode (if (read-decimal-as-inexact) + 'decimal-as-inexact + 'decimal-as-exact)]) + (check who string? s) + (check who (lambda (p) (and (exact-integer? radix) + (<= 2 radix 16))) + #:contract "(integer-in 2 16)" + radix) + (check who (lambda (p) (or (eq? p 'number-or-false) + (eq? p 'read))) + #:contract "(or/c 'number-or-false 'read)" + convert-mode) + (check who (lambda (p) (or (eq? p 'decimal-as-inexact) + (eq? p 'decimal-as-exact))) + #:contract "(or/c 'decimal-as-inexact decimal-as-exact)" + decimal-mode) + + (do-string->number s 0 (string-length s) + radix #:radix-set? #f + decimal-mode + convert-mode)) + +;; When parsing fails, either return an error string or #f. An error +;; string is reported only in 'read mode and when if we're somehow +;; onligated to parse as a number, such as after `#i`. +(define-syntax-rule (fail mode msg arg ...) + (cond + [(eq? mode 'must-read) + (format msg arg ...)] + [else #f])) + +;; The `convert-mode` argument here can be 'number-or-false, 'read, or +;; 'must-read, where 'must-read reports an error on parsing failure +;; instead of returning #f. At this level, we mostly detect the +;; special numbers `+inf.0` in combinations, and otherwise dispatch +;; to parsing a complex number, fraction, or exponential. +(define (do-string->number s start end + radix #:radix-set? radix-set? + exactness ; 'inexact, 'exact, 'decimal-as-inexact, or 'decimal-as-exact + #:in-complex [in-complex #f] ; #f, 'i, or '@ + convert-mode) + (cond + [(= start end) + (fail convert-mode "no digits")] + [else + (define c (string-ref s start)) + (cond + ;; `#e`, `#x`, etc. + [(char=? #\# c) + (define next (add1 start)) + (cond + [(= next end) + (fail convert-mode "no character after `#` indicator in `~.a`" s)] + [else + (define i (string-ref s next)) + (case i + [(#\e #\E #\i #\I) + (cond + [(or (exactness-set? exactness) in-complex) + (fail convert-mode "misplaced exactness specification at `~.a`" (substring s start end))] + [else + (do-string->number s (add1 next) end + radix #:radix-set? radix-set? + (if (or (char=? i #\e) (char=? i #\E)) 'exact 'inexact) + (if (eq? convert-mode 'read) 'must-read convert-mode))])] + [(#\b #\B #\o #\O #\d #\D #\x #\X) + (cond + [(or radix-set? in-complex) + (fail convert-mode "misplaced radix specification at `~.a`" (substring s start end))] + [else + (define radix + (case i + [(#\b #\B) 2] + [(#\o #\O) 8] + [(#\d #\D) 10] + [else 16])) + (do-string->number s (add1 next) end + radix #:radix-set? #t + exactness + (if (eq? convert-mode 'read) 'must-read convert-mode))])] + [else + ;; The reader always complains about a bad leading `#` + (fail (read-complains convert-mode) "bad `#` indicator `~a` at `~.a`" i (substring s start end))])])] + ;; +inf.0, etc. + [(and (char-sign? c) + (read-special-number s start end convert-mode)) + => + (lambda (v) + (cond + [(eq? exactness 'exact) + (fail convert-mode "no exact representation for `~a`" v)] + [else v]))] + ;; +inf.0+...i, etc. + [(and (char-sign? c) + (not in-complex) + ((- end start) . > . 7) + (char=? #\i (string-ref s (sub1 end))) + (char-sign? (string-ref s 6)) + (read-special-number s start (+ start 6) convert-mode)) + => + (lambda (v) + (read-for-special-compound s (+ start 6) (sub1 end) + radix + exactness + convert-mode + #:in-complex 'i + v (lambda (v v2) + (make-rectangular v v2))))] + ;; ...+inf.0i, etc. + [(and (not in-complex) + ((- end start) . >= . 7) ; allow `+inf.0i` + (char=? #\i (string-ref s (sub1 end))) + (char-sign? (string-ref s (- end 7))) + (read-special-number s (- end 7) (sub1 end) convert-mode)) + => + (lambda (v2) + (cond + [(and (= start (- end 7)) + (not (extflonum? v2))) + (make-rectangular 0 v2)] + [else + (read-for-special-compound s start (- end 7) + radix + exactness + convert-mode + #:in-complex 'i + #:reading-first? #t + v2 (lambda (v2 v) + (make-rectangular v v2)))]))] + ;; +inf.0@..., etc. + [(and (char-sign? c) + (not in-complex) + ((- end start) . > . 7) + (char=? #\@ (string-ref s (+ start 6))) + (read-special-number s start (+ start 6) convert-mode)) + => + (lambda (v) + (read-for-special-compound s (+ start 7) end + radix + exactness + convert-mode + #:in-complex '@ + v (lambda (v v2) + (make-polar v v2))))] + ;; ...@+inf.0, etc. + [(and (not in-complex) + ((- end start) . > . 7) + (char=? #\@ (string-ref s (- end 7))) + (read-special-number s (- end 6) end convert-mode)) + => + (lambda (v2) + (read-for-special-compound s start (- end 7) + radix + exactness + convert-mode + #:in-complex '@ + #:reading-first? #t + v2 (lambda (v2 v) + (make-polar v v2))))] + [else + (do-string->non-special-number s start end + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex + convert-mode)])])) + +(define (do-string->non-special-number s start end + radix #:radix-set? radix-set? + exactness + #:in-complex [in-complex #f] + convert-mode) + ;; Look for `@`, `i`, `+`/`-`, and exponent markers like `e`. + ;; Some of those can be used together, but we detect impossible + ;; combinations here and complain. For example `+` that's not + ;; after an exponential marker cannot appear twice, unless the + ;; the two are separated by `@` or the second eventually supports + ;; an ending `i`. Sometimes we can complain right away, and other + ;; times we collect positions to complain at the end, which as + ;; when an extra sign appears after a `.` or `/`. + (let loop ([i start] [any-digits? #f] [any-hashes? #f] [i-pos #f] [@-pos #f] + [sign-pos #f] [dot-pos #f] [slash-pos #f] [exp-pos #f] + [must-i? #f]) + (cond + [(= i end) + ;; We've finished looking, so dispatch on the kind of number parsing + ;; based on found `@`, etc. + ;; If we saw `@`, then we discarded other positions at that point. + ;; If we saw `i` at the end, then we discarded other positions except `sign-pos`. + ;; If we saw `.`, then we discarded earlier `slash-pos` and `exp-pos` or complained. + ;; If we saw `/`, then we discarded earlier `dot-pos` and `exp-pos` or complained. + ;; If we saw `+` or `-`, then we discarded earlier `exp-pos`. + (cond + [(and (not any-digits?) + ;; A number like `+i` can work with no digits + (not i-pos)) + (fail convert-mode "no digits in `~.a`" (substring s start end))] + [(and must-i? (not i-pos)) + (fail convert-mode "too many signs in `~.a`" (substring s start end))] + [(and sign-pos + (or (and dot-pos (dot-pos . < . sign-pos)) + (and slash-pos (slash-pos . < . sign-pos)))) + (fail convert-mode "misplaced sign in `~.a`" (substring s start end))] + [i-pos + (string->complex-number s start sign-pos sign-pos (sub1 end) + i-pos sign-pos + radix #:radix-set? radix-set? + exactness + #:in-complex 'i + convert-mode)] + [@-pos + (string->complex-number s start @-pos (add1 @-pos) end + i-pos sign-pos + radix #:radix-set? radix-set? + exactness + #:in-complex '@ + convert-mode)] + [else + (string->real-number s start end + dot-pos slash-pos exp-pos + any-hashes? + radix + exactness + convert-mode)])] + [else + (define c (string-ref s i)) + (cond + [(digit? c radix) + (loop (add1 i) #t any-hashes? i-pos @-pos + sign-pos dot-pos slash-pos exp-pos + must-i?)] + [(char=? c #\#) ; treat like a digit + (loop (add1 i) #t #t i-pos @-pos + sign-pos dot-pos slash-pos exp-pos + must-i?)] + [(char-sign? c) + (cond + [(and sign-pos must-i?) + (fail convert-mode "too many signs in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos @-pos + i dot-pos slash-pos #f + ;; must be complex if sign isn't at start + (and (> i start) (or (not @-pos) (> i (add1 @-pos)))))])] + [(char=? c #\.) + (cond + [(or (and exp-pos (or (not sign-pos) (exp-pos . > . sign-pos))) + (and dot-pos (or (not sign-pos) (dot-pos . > . sign-pos)))) + (fail convert-mode "misplaced `.` in `~.a`" (substring s start end))] + [(and slash-pos (or (not sign-pos) (slash-pos . > . sign-pos))) + (fail convert-mode "decimal points and fractions annot be mixed `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos @-pos + sign-pos i #f #f + must-i?)])] + [(char=? c #\/) + (cond + [(and dot-pos (or (not sign-pos) (dot-pos . > . sign-pos))) + (fail convert-mode "decimal points and fractions annot be mixed `~.a`" (substring s start end))] + [(or (and exp-pos (or (not sign-pos) (exp-pos . > . sign-pos))) + (and slash-pos (or (not sign-pos) (slash-pos . > . sign-pos)))) + (fail convert-mode "misplaced `/` in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos @-pos + sign-pos #f i #f + must-i?)])] + [(or (char=? c #\e) (char=? c #\E) + (char=? c #\f) (char=? c #\F) + (char=? c #\d) (char=? c #\D) + (char=? c #\s) (char=? c #\S) + (char=? c #\l) (char=? c #\L) + (char=? c #\t) (char=? c #\T)) + (cond + [exp-pos + (fail convert-mode "misplaced `~a` in `~.a`" c (substring s start end))] + ;; Dont count a sign in something like 1e+2 as `sign-pos` + [(and ((add1 i) . < . end) + (char-sign? (string-ref s (add1 i)))) + (loop (+ i 2) any-digits? any-hashes? i-pos @-pos + sign-pos dot-pos slash-pos (or exp-pos i) + must-i?)] + [else + (loop (+ i 1) any-digits? any-hashes? i-pos @-pos + sign-pos dot-pos slash-pos (or exp-pos i) + must-i?)])] + [(char=? c #\@) + (cond + [(eq? in-complex 'i) + (fail convert-mode "cannot mix `@` and `i` in `~.a`" (substring s start end))] + [(or @-pos (eq? in-complex '@)) + (fail convert-mode "too many `@`s in `~.a`" (substring s start end))] + [(= i start) + (fail convert-mode "`@` cannot be at start in `~.a`" (substring s start end))] + [must-i? + (fail convert-mode "too many signs in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i-pos i + #f #f #f #f + must-i?)])] + [(and (or (char=? c #\i) (char=? c #\I)) + sign-pos) + (cond + [(or @-pos (eq? in-complex '@)) + (fail convert-mode "cannot mix `@` and `i` in `~.a`" (substring s start end))] + [(or ((add1 i) . < . end) (eq? in-complex 'i)) + (fail convert-mode "`i' must be at the end in `~.a`" (substring s start end))] + [else + (loop (add1 i) any-digits? any-hashes? i @-pos + sign-pos #f #f #f + #f)])] + [else + (cond + [(char=? c #\nul) + (fail convert-mode "nul character in `~.a`" s)] + [else + (fail convert-mode "bad digit `~a`" c)])])]))) + +;; Parse and combine the halves of an impginary number, either +;; in `[+-]i` form or `@` form as +;; indicated by `in-complex` +(define (string->complex-number s start1 end1 start2 end2 + i-pos sign-pos + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex ; 'i or '@ + convert-mode) + (define v1 (cond + [(= start1 end1) + ;; The input was "[+-]i", so the real part + ;; is implicitly "0" + (if (eq? exactness 'inexact) + 0.0 + 0)] + [else + (do-string->number s start1 end1 + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex + convert-mode)])) + (define v2 (cond + [(and (eq? in-complex 'i) + (= (- end2 start2) 1)) + ;; The input ends "[+-]i", so the number is implicitly + ;; "1" + (define neg? (char=? (string-ref s start2) #\-)) + (cond + [(eq? exactness 'inexact) + (if neg? -1.0 1.0)] + [else + (if neg? -1 1)])] + [else + (do-string->number s start2 end2 + radix #:radix-set? radix-set? + exactness + #:in-complex in-complex + convert-mode)])) + (cond + [(or (not v1) (not v2)) + #f] + [(and (or (extflonum? v1) (extflonum? v2)) + (not (eq? convert-mode 'must-read))) + ;; If no 'must-read, then an extflonum-combination + ;; failure hides even a divide-by-zero error + (fail-extflonum convert-mode v1)] + [(string? v1) v1] + [(extflonum? v1) + (fail-extflonum convert-mode v1)] + [(string? v2) v2] + [(extflonum? v2) + (fail-extflonum convert-mode v2)] + [(eq? in-complex 'i) + (make-rectangular v1 v2)] + [else + (define p (make-polar v1 v2)) + (if (eq? exactness 'exact) + (inexact->exact p) + p)])) + +;; Parse a real number that might be a faction, have `.`, or have `#`s +(define (string->real-number s start end + dot-pos slash-pos exp-pos + any-hashes? ; can be false-positive + radix + exactness + convert-mode) + ;; Try shortcut of using primitive `string->number`, which should + ;; work on real numbers and extflonums + (define (extfl-mark?) (char=? (char-downcase (string-ref s exp-pos)) #\t)) + (define simple? + (and (not slash-pos) + (or (eq? exactness 'inexact) + (eq? exactness 'decimal-as-inexact) + (and (not dot-pos) (not exp-pos))) + (or (not exp-pos) + (not (eq? convert-mode 'number-or-false)) + (not (extfl-mark?))) + (not (and any-hashes? (hashes? s start end))))) + (define has-sign? (and (end . > . start) (char-sign? (string-ref s start)))) + (cond + [(= (- end start) (+ (if dot-pos 1 0) (if exp-pos 1 0) (if has-sign? 1 0))) + (if (= end start) + (fail convert-mode "missing digits") + (fail convert-mode "missing digits in `~.a`" (substring s start end)))] + [simple? + (cond + [(and exp-pos (= (- exp-pos start) + (+ (if (and dot-pos (< dot-pos exp-pos)) 1 0) + (if has-sign? 1 0)))) + (fail convert-mode "missing digits before exponent marker in `~.a`" (substring s start end))] + [(and exp-pos + (or (= exp-pos (sub1 end)) + (and (= exp-pos (- end 2)) + (char-sign? (string-ref s (sub1 end)))))) + (fail convert-mode "missing digits after exponent marker in `~.a`" (substring s start end))] + [else + (define n (host:string->number (maybe-substring s start end) radix + ;; Use 'read mode as needed to enable extflonum results + (if (or (eq? convert-mode 'number-or-false) + (not exp-pos) + (not (extfl-mark?))) + 'number-or-false + 'read))) + (cond + [(or (not n) (string? n)) + (error 'string->number "host `string->number` failed on ~s" (substring s start end))] + [(eq? exactness 'inexact) + (cond + [(extflonum? n) + (fail convert-mode "cannot convert extflonum `~.a` to inexact" (substring s start end))] + [(and (eqv? n 0) + (char=? (string-ref s start) #\-)) + -0.0] + [else + (exact->inexact n)])] + [else n])])] + [exp-pos + (define m-v (string->real-number s start exp-pos + dot-pos slash-pos #f + any-hashes? + radix + 'exact + convert-mode)) + (define e-v (string->exact-integer-number s (+ exp-pos 1) end + radix + convert-mode)) + (define (real->precision-inexact r) + (case (string-ref s exp-pos) + [(#\s #\S #\f #\F) (real->single-flonum r)] + [(#\t #\T) + (if (extflonum-available?) + (real->extfl r) + ;; The host `string->number` can make a string-based + ;; representation to preserve the content, if not compute + ;; with it + (host:string->number (replace-hashes s start end) radix 'read))] + [else (real->double-flonum r)])) + (define get-extfl? (extfl-mark?)) + (cond + [(or (not m-v) (not e-v)) #f] + [(string? m-v) m-v] + [(string? e-v) e-v] + [(and (eq? convert-mode 'number-or-false) get-extfl?) + #f] + [(and (or (eq? exactness 'inexact) (eq? exactness 'decimal-as-inexact)) + ((abs e-v) . > . (if get-extfl? 6000 400))) + ;; Don't calculate a huge exponential to return a float: + (real->precision-inexact + (cond + [(eqv? m-v 0) (if (char=? (string-ref s start) #\-) + -0.0 + 0.0)] + [(positive? m-v) (if (positive? e-v) + +inf.0 + +0.0)] + [else (if (positive? e-v) + -inf.0 + -0.0)]))] + [(and (exactness-set? exactness) get-extfl?) + (fail convert-mode "cannot convert extflonum `~.a` to ~a" (substring s start end) exactness)] + [else + ;; This calculation would lose precision for floating-point + ;; numbers, but we don't get here for inexact `m-v`: + (define n (* m-v (expt radix e-v))) + (cond + [(and (not get-extfl?) + (or (eq? exactness 'exact) (eq? exactness 'decimal-as-exact))) + n] + [(and (eqv? n 0) + (char=? (string-ref s start) #\-)) + (real->precision-inexact -0.0)] + [else + (real->precision-inexact n)])])] + [slash-pos + ;; the numerator or demoniator doesn't have a decimal + ;; place or exponent marker, but it may have `#`s + (define n-v (string->real-number s start slash-pos + #f #f #f + any-hashes? + radix + 'exact + convert-mode)) + (define d-v (string->real-number s (add1 slash-pos) end + #f #f #f + any-hashes? + radix + 'exact + convert-mode)) + (define (get-inexact? from-pos) + (or (eq? exactness 'inexact) + ;; For historical reasons, `#`s in a fraction trigger an + ;; inexact result, even if `exactness` is 'decimal-as-exact + (and (not (eq? exactness 'exact)) + (hashes? s from-pos end)))) + (cond + [(or (not n-v) (not d-v)) #f] + [(string? n-v) n-v] + [(string? d-v) d-v] + [(eqv? d-v 0) + (cond + [(get-inexact? (add1 slash-pos)) + (if (negative? n-v) + -inf.0 + +inf.0)] + [else + ;; The reader always complains about divide-by-zero + (fail (read-complains convert-mode) "division by zero in `~.a`" (substring s start end))])] + [else + (define n (/ n-v d-v)) + (if (get-inexact? start) + (exact->inexact n) + n)])] + ;; We get this far only if the input has `#` or if the input has a + ;; `.` and we want exact + [else + (string->decimal-number s start end + dot-pos + radix + exactness + convert-mode)])) + +;; Parse a number that might have `.` and/or `#` in additon to digits +;; and possibiliy a leading `+` or `-` +(define (string->decimal-number s start end + dot-pos + radix + exactness + convert-mode) + (define get-exact? (or (eq? exactness 'exact) (eq? exactness 'decimal-as-exact))) + (define new-str (make-string (- end start (if (and dot-pos get-exact?) 1 0)))) + (let loop ([i (sub1 end)] [j (sub1 (string-length new-str))] [hashes-pos end]) + (cond + [(i . < . start) + ;; Convert `new-str` to an integer and finish up + (cond + [(= hashes-pos start) + (fail convert-mode "misplaced `#` in `~.a`" (substring s start end))] + [else + (define n (host:string->number new-str radix)) + (cond + [(not n) + (fail-bad-number convert-mode s start end)] + [(not get-exact?) + (if (and (eqv? n 0) + (char=? (string-ref s start) #\-)) + -0.0 + (exact->inexact n))] + [(and dot-pos get-exact?) + (/ n (expt 10 (- end dot-pos 1)))] + [else n])])] + [else + (define c (string-ref s i)) + (cond + [(char=? c #\.) + (cond + [get-exact? + (loop (sub1 i) j (if (= hashes-pos (add1 i)) i hashes-pos))] + [else + (string-set! new-str j c) + (loop (sub1 i) (sub1 j) (if (= hashes-pos (add1 i)) i hashes-pos))])] + [(or (char=? c #\-) (char=? c #\+)) + (string-set! new-str j c) + (loop (sub1 i) (sub1 j) (if (= hashes-pos (add1 i)) i hashes-pos))] + [(char=? c #\#) + (cond + [(= hashes-pos (add1 i)) + (string-set! new-str j #\0) + (loop (sub1 i) (sub1 j) i)] + [else + (fail convert-mode "misplaced `#` in `~.a`" (substring s start end))])] + [else + (string-set! new-str j c) + (loop (sub1 i) (sub1 j) hashes-pos)])]))) + +;; Parse an integer that might have `#` and a leading `+` or `-`, but +;; no other non-digit characters +(define (string->exact-integer-number s start end + radix + convert-mode) + (cond + [(hashes? s start end) + (fail convert-mode "misplaced `#` in `~.a`" (substring s start end))] + [else + (define n (host:string->number (maybe-substring s start end) radix)) + (cond + [(not n) + (fail convert-mode "bad exponent `~.a`" (substring s start end))] + [else n])])) + +;; Try to read as `+inf.0`, etc. +(define (read-special-number s start end convert-mode) + (and + (= (- end start) 6) + (or (char=? (string-ref s start) #\+) + (char=? (string-ref s start) #\-)) + (or + (and (char=? (char-downcase (string-ref s (+ start 1))) #\i) + (char=? (char-downcase (string-ref s (+ start 2))) #\n) + (char=? (char-downcase (string-ref s (+ start 3))) #\f) + (char=? (char-downcase (string-ref s (+ start 4))) #\.) + (or + (and + (char=? (char-downcase (string-ref s (+ start 5))) #\0) + (if (char=? (string-ref s start) #\+) + +inf.0 + -inf.0)) + (and + (char=? (char-downcase (string-ref s (+ start 5))) #\f) + (if (char=? (string-ref s start) #\+) + +inf.f + -inf.f)) + (and + (char=? (char-downcase (string-ref s (+ start 5))) #\t) + (not (eq? convert-mode 'number-or-false)) + (if (char=? (string-ref s start) #\+) + +inf.t + -inf.t)))) + (and (char=? (char-downcase (string-ref s (+ start 1))) #\n) + (char=? (char-downcase (string-ref s (+ start 2))) #\a) + (char=? (char-downcase (string-ref s (+ start 3))) #\n) + (char=? (char-downcase (string-ref s (+ start 4))) #\.) + (or (and (char=? (char-downcase (string-ref s (+ start 5))) #\0) + +nan.0) + (and (char=? (char-downcase (string-ref s (+ start 5))) #\f) + +nan.f) + (and (char=? (char-downcase (string-ref s (+ start 5))) #\t) + (not (eq? convert-mode 'number-or-false)) + +nan.t)))))) + +(define (fail-extflonum convert-mode v) + (fail convert-mode "cannot combine extflonum `~a` into complex number" v)) + +;; Read the other half of something like `+inf.0+...i` or `...@-inf.0` +(define (read-for-special-compound s start end + radix + exactness + convert-mode + #:in-complex in-complex + #:reading-first? [reading-first? #f] + v combine) + (cond + [(eq? exactness 'exact) + (fail convert-mode "no exact representation for `~a`" v)] + [(and (extflonum? v) (or (not reading-first?) + ;; If no 'must-read, then an extflonum-combination + ;; failure hides even a divide-by-zero error + (not (eq? convert-mode 'must-read)))) + (fail-extflonum convert-mode v)] + [else + (define v2 + (do-string->number s start end + radix #:radix-set? #t + exactness + #:in-complex in-complex + convert-mode)) + (cond + [(string? v2) v2] + [(not v2) v2] + [(extflonum? v) + (fail-extflonum convert-mode v)] + [else (combine v v2)])])) + +(define (hashes? s start end) + (for/or ([c (in-string s start end)]) + (char=? c #\#))) + +(define (replace-hashes s start end) + (define new-s (make-string (- end start))) + (for ([c (in-string s start end)] + [i (in-naturals)]) + (if (char=? c #\#) + (string-set! new-s i #\0) + (string-set! new-s i c))) + new-s) + +(define (maybe-substring s start end) + (if (and (= 0 start) + (= end (string-length s))) + s + (substring s start end))) + +(define (exactness-set? exactness) + (or (eq? exactness 'exact) (eq? exactness 'inexact))) + +(define (char-sign? c) + (or (char=? c #\-) (char=? c #\+))) + +(define (digit? c radix) + (define v (char->integer c)) + (or (and (v . >= . (char->integer #\0)) + ((- v (char->integer #\0)) . < . radix)) + (and (radix . > . 10) + (or (and + (v . >= . (char->integer #\a)) + ((- v (- (char->integer #\a) 10)) . < . radix)) + (and + (v . >= . (char->integer #\A)) + ((- v (- (char->integer #\A) 10)) . < . radix)))))) + +(define (fail-bad-number convert-mode s start end) + (fail convert-mode "bad number `~.a`" (substring s start end))) + +(define (read-complains convert-mode) + (if (eq? convert-mode 'read) 'must-read convert-mode)) + +;; ---------------------------------------- + +(module+ test + (define (try s) + (define expect (host:string->number s 10 'read 'decimal-as-inexact)) + (define got (string->number s 10 'read 'decimal-as-inexact)) + (unless (equal? expect got) + (error 'fail "~e\n expect: ~e\n got: ~e" s expect got))) + + (try "#i+inf.0") + (try "-inf.0") + (try "10") + (try "10.1") + (try "1+2i") + (try "#e10.1") + (try "1#.#") + (try "#e1#.#") + (try "1/2") + (try "#x+e#s+e") + (try "#e#x+e#s+e") + (try "-e#l-e") + (try "#e-e#l-e") + (try "#e#x+e#s+e@-e#l-e") + (try "#e+@1") + (try "3.1415926535897932385t0") + (try "+nan.0+1i") + (try "3.0t0") + (try "+i") + (try "-i") + (try "#i3") + (try "#i3+i") + (try "1/2+i") + (try "1.2+i") + (try "1/2+3") + (try "1.2+3") + (try "#i-0") + (try "#i0") + (try "-0#") + (try "#i1-0i") + (try "1#e500") + (try "1#e10000000000000000000000000000000") + (try "1#e-10000000000000000000000000000000") + (try "-0#e10") + (try "-0#e10000000000000000000000000000000") + (try "1/2@0") + (try "#i+8#i") + (try "1#/3") + (try "+inf.0@1") + (try "+inf.0@1/1") + (try "1/0#") + (try "1#/0") + (try "-1/0#") + (try "#e1/2#e10") + (try "1/0") + (try "1@+inf.0") + (try "1/1@+inf.0") + (try "#d1/0+3.0i") + (try "3.0t0+1/0i") + (try "1/0+3.0t0i") + (try "+inf.t0+1/0i") + (try "1/0+inf.t0i") + (try "3.#t0") + (try "-1-2i") + (try "-4.242154731064108e-5-6.865001427422244e-5i") + (try "1e300+1e300i") + (try "#x8f0767e50d4d0c07563bd81f530d36") + (try "t") + (try "s2") + (try "#ds2") + (try "2e") + (try ".e1") + (try "+.e1") + (try "#e1") + (try "1e#") + (try "1e+") + (try "1e+-") + (try ".#e1") + (try "1/") + (try "/2") + (try "#/2") + (try "1//2") + (try "2..") + (try "2+1")) diff --git a/racket/src/expander/read/parameter.rkt b/racket/src/expander/read/parameter.rkt new file mode 100644 index 0000000000..a8fea7c2bc --- /dev/null +++ b/racket/src/expander/read/parameter.rkt @@ -0,0 +1,55 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "config.rkt" + "primitive-parameter.rkt") + +(provide check-parameter + override-parameter + force-parameters! + (all-from-out "primitive-parameter.rkt")) + +(define unknown (gensym 'unknown)) + +;; Speed up parameter checking and protect against changes +;; by caching parameter values +(define (check-parameter param config) + (define cache (read-config-parameter-cache config)) + (define v (hash-ref (read-config-parameter-override config) + param + (hash-ref cache param unknown))) + (cond + [(eq? v unknown) + (define v (param)) + (hash-set! cache param v) + v] + [else v])) + +(define (override-parameter param config v) + (struct*-copy read-config config + [parameter-override (hash-set + (read-config-parameter-override config) + param + v)])) + +;; Protect against callbacks that can change parameters +;; by caching all parameters at current values: +(define (force-parameters! config) + (define cache (read-config-parameter-cache config)) + (unless (hash-ref cache 'all-forced #f) + (hash-set! cache 'all-forced #t) + (check-parameter read-case-sensitive config) + (check-parameter read-square-bracket-as-paren config) + (check-parameter read-curly-brace-as-paren config) + (check-parameter read-square-bracket-with-tag config) + (check-parameter read-curly-brace-with-tag config) + (check-parameter read-cdot config) + (check-parameter read-accept-graph config) + (check-parameter read-accept-compiled config) + (check-parameter read-accept-box config) + (check-parameter read-accept-bar-quote config) + (check-parameter read-decimal-as-inexact config) + (check-parameter read-accept-dot config) + (check-parameter read-accept-infix-dot config) + (check-parameter read-accept-quasiquote config) + (check-parameter read-accept-reader config) + (check-parameter read-accept-lang config))) diff --git a/racket/src/expander/read/primitive-parameter.rkt b/racket/src/expander/read/primitive-parameter.rkt new file mode 100644 index 0000000000..870f1c405a --- /dev/null +++ b/racket/src/expander/read/primitive-parameter.rkt @@ -0,0 +1,36 @@ +#lang racket/base + +(define (default-reader-guard v) v) + +(provide current-reader-guard) +(define current-reader-guard + (make-parameter default-reader-guard + (lambda (v) + (unless (and (procedure? v) + (procedure-arity-includes? v 1)) + (raise-argument-error 'current-reader-guard + "(procedure-arity-includes/c 1)" + v)) + v))) + +(define-syntax-rule (define-boolean-parameter id val) + (begin + (provide id) + (define id (make-parameter val (lambda (v) (and v #t)))))) + +;; (define-boolean-parameter read-case-sensitive #t) - shared with printer +(define-boolean-parameter read-square-bracket-as-paren #t) +(define-boolean-parameter read-curly-brace-as-paren #t) +(define-boolean-parameter read-square-bracket-with-tag #f) +(define-boolean-parameter read-curly-brace-with-tag #f) +(define-boolean-parameter read-cdot #f) +(define-boolean-parameter read-accept-graph #t) +(define-boolean-parameter read-accept-compiled #f) +(define-boolean-parameter read-accept-box #t) +;; (define-boolean-parameter read-accept-bar-quote #t) - shared with printer +(define-boolean-parameter read-decimal-as-inexact #t) +(define-boolean-parameter read-accept-dot #t) +(define-boolean-parameter read-accept-infix-dot #t) +(define-boolean-parameter read-accept-quasiquote #t) +(define-boolean-parameter read-accept-reader #f) +(define-boolean-parameter read-accept-lang #t) diff --git a/racket/src/expander/read/quote.rkt b/racket/src/expander/read/quote.rkt new file mode 100644 index 0000000000..1ce379361d --- /dev/null +++ b/racket/src/expander/read/quote.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require "error.rkt" + "wrap.rkt") + +(provide read-quote) + +(define (read-quote read-one sym desc c in config) + (define wrapped-sym (wrap sym in config c)) + (define e (read-one #f in config)) + (when (eof-object? e) + (reader-error in config #:due-to e + "expected an element for ~a, found end-of-file" + desc)) + (wrap (list wrapped-sym e) in config #f)) diff --git a/racket/src/expander/read/readtable-parameter.rkt b/racket/src/expander/read/readtable-parameter.rkt new file mode 100644 index 0000000000..e2f4ef1a8b --- /dev/null +++ b/racket/src/expander/read/readtable-parameter.rkt @@ -0,0 +1,16 @@ +#lang racket/base + +(provide current-readtable + prop:readtable prop:readtable?) + +(define-values (prop:readtable prop:readtable? prop:readtable-ref) + (make-struct-type-property 'readtable)) + +(define current-readtable (make-parameter #f + (lambda (v) + (unless (or (not v) + (prop:readtable? v)) + (raise-argument-error 'current-readtable + "(or/c readtable? #f)" + v)) + v))) diff --git a/racket/src/expander/read/readtable.rkt b/racket/src/expander/read/readtable.rkt new file mode 100644 index 0000000000..e124ee5666 --- /dev/null +++ b/racket/src/expander/read/readtable.rkt @@ -0,0 +1,199 @@ +#lang racket/base +(require "../common/inline.rkt" + "config.rkt" + "coerce.rkt" + "parameter.rkt" + "readtable-parameter.rkt" + "special-comment.rkt") + +(provide readtable-delimiter-ht + make-readtable + readtable? + readtable-mapping + current-readtable + readtable-effective-char + effective-char + readtable-handler + readtable-dispatch-handler + readtable-apply + readtable-symbol-parser + readtable-equivalent-chars) + +(struct readtable (symbol-parser ; parser for default token handling: symbol-or-number + ;; The character table maps characters to either a + ;; parsing function or another character whose + ;; default to use + char-ht + ;; The dispatch table maps character for `#` dispatch + dispatch-ht + ;; The delimter table maps a character to 'delimit, + ;; 'no-delimit, or a character whose default to use; + ;; absence of a mapping is the default for that character + delimiter-ht) + #:property prop:readtable #t) + +(define (make-readtable rt . args) + (unless (or (not rt) (readtable? rt)) + (raise-argument-error 'make-readtable "(or/c readtable? #f)" rt)) + (let loop ([args args] + [symbol-parser (and rt (readtable-symbol-parser rt))] + [char-ht (if rt (readtable-char-ht rt) #hasheqv())] + [dispatch-ht (if rt (readtable-dispatch-ht rt) #hasheqv())] + [delimiter-ht (if rt (readtable-delimiter-ht rt) #hasheqv())]) + (cond + [(null? args) (readtable symbol-parser char-ht dispatch-ht delimiter-ht)] + [else + ;; Key is a character or #f + (define key (car args)) + (unless (or (not key) (char? key)) + (raise-argument-error 'make-readtable "(or/c char? #f)" key)) + + ;; Mode determines how the key is mapped + (when (null? args) + (cond + [key (raise-arguments-error 'make-readtable + (string-append "expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro," + " or character argument after character argument") + "character" key)] + [else (raise-arguments-error 'make-readtable + "expected 'non-terminating-macro after #f")])) + (define mode (cadr args)) + (cond + [key + (unless (or (eq? mode 'terminating-macro) + (eq? mode 'non-terminating-macro) + (eq? mode 'dispatch-macro) + (char? mode)) + (raise-argument-error 'make-readtable + "(or/c 'terminating-macro 'non-terminating-macro 'dispatch-macro char?)" + mode))] + [else + (unless (eq? mode 'non-terminating-macro) + (raise-arguments-error 'make-readtable + "expected 'non-terminating-macro after #f"))]) + + ;; Target is what the key is mapped to + (when (null? (cddr args)) + (raise-arguments-error 'make-readtable + (if key + "expected readtable or #f argument after character argument" + "expected procedure argument after symbol argument") + "given" mode)) + (define target (caddr args)) + + ;; Update the readtable + (define rest-args (cdddr args)) + (cond + [(not key) + ;; Update symbol parser + (unless (and (procedure? target) (procedure-arity-includes? target 6)) + (raise-argument-error 'make-readtable "(procedure-arity-includes/c 6)" target)) + (loop rest-args target char-ht dispatch-ht delimiter-ht)] + [(eq? mode 'dispatch-macro) + ;; Update `#`-triggered dispatch table + (unless (and (procedure? target) (procedure-arity-includes? target 6)) + (raise-argument-error 'make-readtable "(procedure-arity-includes/c 6)" target)) + (loop rest-args symbol-parser char-ht (hash-set dispatch-ht key target) delimiter-ht)] + [(char? mode) + ;; Update main character table with a character alias + (unless (or (not target) (readtable? target)) + (raise-argument-error 'make-readtable "(or/c readtable? #f)" target)) + (define actual-target (or (and target (hash-ref (readtable-char-ht target) mode #f)) + mode)) + (define new-char-ht (if actual-target + (hash-set char-ht key actual-target) + (hash-remove char-ht key))) + (define new-delimiter-ht (hash-set delimiter-ht + key + (if target + (hash-ref (readtable-delimiter-ht target) mode mode) + mode))) + (loop rest-args symbol-parser new-char-ht dispatch-ht new-delimiter-ht)] + [else + ;; Update main character table with a new handler + (unless (and (procedure? target) (procedure-arity-includes? target 6)) + (raise-argument-error 'make-readtable "(procedure-arity-includes/c 6)" target)) + (define new-char-ht (hash-set char-ht key target)) + (define new-delimiter-ht (hash-set delimiter-ht key (if (eq? mode 'terminating-macro) + 'delimit + 'no-delimit))) + (loop rest-args symbol-parser new-char-ht dispatch-ht new-delimiter-ht)])]))) + +;; Map a character to another character (if any) whose default +;; treatment should be used; be sure to map non-characters like +;; EOF to themselves. +(define-inline (readtable-effective-char rt c) + (cond + [(or (not rt) (not (char? c))) c] + [else (*readtable-effective-char rt c)])) + +(define (*readtable-effective-char rt c) + (define target (hash-ref (readtable-char-ht rt) c #f)) + (cond + [(not target) c] + [(char? target) target] + [else #\x])) ; return some non-special character + +(define (effective-char c config) + (readtable-effective-char (read-config-readtable config) c)) + +;; Map a character to a handler, if any: +(define (readtable-handler config c) + (define rt (read-config-readtable config)) + (and rt + (let ([target (hash-ref (readtable-char-ht rt) c #f)]) + (and target + (not (char? target)) + target)))) + +;; Map a character after `#` to a handler, if any: +(define (readtable-dispatch-handler config c) + (force-parameters! config) + (define rt (read-config-readtable config)) + (and rt + (hash-ref (readtable-dispatch-ht rt) c #f))) + +(define (readtable-apply handler c in config line col pos) + (define for-syntax? (read-config-for-syntax? config)) + (define v + (cond + [(not for-syntax?) + (parameterize ([current-read-config config]) + (if (procedure-arity-includes? handler 2) + (handler c in) + (handler c in #f line col pos)))] + [else + (parameterize ([current-read-config config]) + (handler c in (read-config-source config) line col pos))])) + (if (special-comment? v) + v + (coerce v in config))) + +;; Part of the public API: +(define (readtable-mapping rt c) + (unless (readtable? rt) + (raise-argument-error 'readtable-mapping "readtable?" rt)) + (unless (char? c) + (raise-argument-error 'readtable-mapping "char?" c)) + (define handler (hash-ref (readtable-char-ht rt) c #f)) + (values (or (and handler + (cond + [(char? handler) handler] + [(eq? 'delimit (hash-ref (readtable-delimiter-ht rt) c #f)) + 'terminating-macro] + [else + 'non-terminating-macro])) + c) + (if (char? handler) #f handler) + (hash-ref (readtable-dispatch-ht rt) c #f))) + +;; Return a list of characters mapped to `c`: +(define (readtable-equivalent-chars rt c) + (define ht (readtable-char-ht rt)) + (append + (if (hash-ref ht c #f) + null + (list c)) + (for/list ([(k v) (in-hash ht)] + #:when (eqv? v c)) + k))) diff --git a/racket/src/expander/read/regexp.rkt b/racket/src/expander/read/regexp.rkt new file mode 100644 index 0000000000..68d24e9e61 --- /dev/null +++ b/racket/src/expander/read/regexp.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "string.rkt") + +(provide read-regexp) + +(define (read-regexp mode-c accum-str in config) + (define c3 (read-char/special in config)) + (define no-wrap-config (disable-wrapping config)) + + (define rx + (case c3 + [(#\") + (accum-string-abandon! accum-str config) + (define str (read-string in no-wrap-config)) + (catch-and-reraise-as-reader + in config + ((if (char=? mode-c #\r) regexp pregexp) str))] + [(#\#) + (accum-string-add! accum-str c3) + (define c4 (read-char/special in config)) + (case c4 + [(#\") + (accum-string-abandon! accum-str config) + (define bstr + (read-string in no-wrap-config #:mode '|byte string|)) + (catch-and-reraise-as-reader + in config + ((if (char=? mode-c #\r) byte-regexp byte-pregexp) bstr))] + [else + (reader-error in config #:due-to c4 + "expected `\"` after `~a`" + (accum-string-get! accum-str config))])] + [else + (reader-error in config #:due-to c3 + "expected `\"` or `#` after `~a`" + (accum-string-get! accum-str config))])) + + (wrap rx + in + config + #f)) diff --git a/racket/src/expander/read/sequence.rkt b/racket/src/expander/read/sequence.rkt new file mode 100644 index 0000000000..a38f29cca0 --- /dev/null +++ b/racket/src/expander/read/sequence.rkt @@ -0,0 +1,131 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "config.rkt" + "special.rkt" + "readtable.rkt" + "whitespace.rkt" + "delimiter.rkt" + "consume.rkt" + "closer.rkt" + "error.rkt" + "indentation.rkt" + "parameter.rkt" + "wrap.rkt" + "location.rkt" + "special-comment.rkt") + +(provide read-unwrapped-sequence) + +(define (read-unwrapped-sequence read-one opener-c opener closer in seq-config + #:elem-config [elem-config (next-readtable seq-config)] + #:dot-mode [dot-mode 'all] + #:shape-tag? [shape-tag? #f] + #:whitespace-read-one [whitespace-read-one read-one] + #:first-read-one [first-read-one read-one]) + (define head #f) + (define indentation (make-indentation closer in seq-config)) + (define config (struct*-copy read-config elem-config + [indentations (cons indentation + (read-config-indentations seq-config))])) + + (define config/keep-comment (keep-comment config)) + + (define (read-one/not-eof init-c read-one config) + (define e (read-one init-c in config)) + (when (eof-object? e) + (reader-error in config #:due-to e + "expected a ~a to close `~a`~a" + (closer-name closer config) + opener-c + (indentation-possible-cause config))) + e) + + (define seq + (let loop ([depth 0] [accum null] [init-c #f] [first? #t] [first-read-one first-read-one]) + (define c (read-char/skip-whitespace-and-comments init-c whitespace-read-one in seq-config)) + (define ec (effective-char c seq-config)) + (cond + [(eqv? ec closer) + (if (null? accum) + null + (reverse accum))] + [(and (not first?) + (eqv? ec #\.) + (check-parameter read-accept-dot config) + (char-delimiter? (peek-char/special in config) seq-config)) + ;; Found a `.`: maybe improper or maybe infix + (define-values (dot-line dot-col dot-pos) (port-next-location* in c)) + (track-indentation! config dot-line dot-col) + + (unless (and dot-mode + ;; don't allow another `.` if we've seen an infix + (not head)) + (reader-error in (reading-at config dot-line dot-col dot-pos) + "illegal use of `.`")) + + ;; Read one item for improper list or for infix: + (define v (read-one/not-eof #f first-read-one config)) + + ;; Check for infix or list termination: + (define rest-c (read-char/skip-whitespace-and-comments #f whitespace-read-one in seq-config)) + (define rest-ec (effective-char rest-c seq-config)) + + (cond + [(eqv? rest-ec closer) + ;; Improper list + (if (null? accum) + v + (append (reverse accum) v))] + [(and (eqv? rest-ec #\.) + (check-parameter read-accept-dot config) + (check-parameter read-accept-infix-dot config) + (char-delimiter? (peek-char/special in config) seq-config)) + ;; Infix mode + (set! head (box v)) + + (define-values (dot2-line dot2-col dot2-pos) (port-next-location in)) + (track-indentation! config dot2-line dot2-col) + + ;; Check for a closer right after the second dot: + (define post-c (read-char/skip-whitespace-and-comments #f whitespace-read-one in seq-config)) + (define post-ec (effective-char post-c seq-config)) + (when (or (eof-object? post-ec) + (eqv? post-ec closer)) + (reader-error in (reading-at config dot-line dot-col dot-pos) + #:due-to post-ec + "illegal use of `.`")) + + ;; No closer => another item or EOF + (loop depth accum post-c #f read-one)] + [else + ;; Something else after a single element after a single dot + (reader-error in (reading-at config dot-line dot-col dot-pos) + #:due-to rest-c + "illegal use of `.`")])] + [else + (define v (read-one/not-eof c first-read-one config/keep-comment)) + (cond + [(special-comment? v) (loop depth accum #f #f read-one)] + [(depth . > . 1024) + ;; At some large depth, it's better to accumlate than recur + (loop depth (cons v accum) #f #f read-one)] + [else + (cons v (loop (add1 depth) null #f #f read-one))])]))) + (define full-seq (if head + (cons (unbox head) seq) + seq)) + (if shape-tag? + (add-shape-tag opener in config full-seq) + full-seq)) + +;; ---------------------------------------- + +(define (add-shape-tag opener in config seq) + (define tag + (case opener + [(#\[) (and (check-parameter read-square-bracket-with-tag config) '#%brackets)] + [(#\{) (and (check-parameter read-curly-brace-with-tag config) '#%braces)] + [else #f])) + (if tag + (cons (wrap tag in config #f) seq) + seq)) diff --git a/racket/src/expander/read/special-comment.rkt b/racket/src/expander/read/special-comment.rkt new file mode 100644 index 0000000000..33c4fef2b3 --- /dev/null +++ b/racket/src/expander/read/special-comment.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(provide special-comment? + make-special-comment + special-comment-value) + +(struct special-comment (value) + #:authentic + #:constructor-name make-special-comment) diff --git a/racket/src/expander/read/special.rkt b/racket/src/expander/read/special.rkt new file mode 100644 index 0000000000..3853022705 --- /dev/null +++ b/racket/src/expander/read/special.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require "../common/inline.rkt" + "config.rkt") + +;; The reader should never use `read-char` or `peek-char`. Instead, +;; use `read-char/special` or `peek-char/special`, so that special +;; values are never treated as characters, and so that `read-syntax` +;; mode provides the source name. + +(provide (struct-out special) + read-char/special + peek-char/special) + +(struct special (value)) + +(define-inline (read-char/special in config [source (read-config-source config)]) + (read-char-or-special in special source)) + +(define-inline (peek-char/special in config [skip-count 0] [source (read-config-source config)]) + (peek-char-or-special in skip-count special source)) diff --git a/racket/src/expander/read/string.rkt b/racket/src/expander/read/string.rkt new file mode 100644 index 0000000000..696f0e8b42 --- /dev/null +++ b/racket/src/expander/read/string.rkt @@ -0,0 +1,224 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "digit.rkt") + +(provide read-string + read-here-string) + +(define (read-string in config #:mode [mode 'string]) + (define source (read-config-source config)) + (define accum-str (accum-string-init! config)) + (define (bad-end c) + (cond + [(eof-object? c) + (reader-error in config #:due-to c "expected a closing `\"`")] + [else + (reader-error in config #:due-to c + "found non-character while reading a ~a" + mode)])) + (let loop () + (define c (read-char/special in config source)) + ;; Note: readtable is not used for a closing " or other string decisions + (cond + [(not (char? c)) + (bad-end c)] + [(char=? #\\ c) + (define escaping-c c) + (define escaped-c (read-char/special in config source)) + (when (not (char? escaped-c)) + (bad-end escaped-c)) + (define (unknown-error) + (reader-error in config + "unknown escape sequence `~a~a` in ~a" + escaping-c escaped-c + mode)) + (case escaped-c + [(#\\ #\" #\') + (accum-string-add! accum-str escaped-c)] + [(#\a) (accum-string-add! accum-str #\u7)] + [(#\b) (accum-string-add! accum-str #\backspace)] + [(#\t) (accum-string-add! accum-str #\tab)] + [(#\n) (accum-string-add! accum-str #\newline)] + [(#\v) (accum-string-add! accum-str #\vtab)] + [(#\f) (accum-string-add! accum-str #\page)] + [(#\r) (accum-string-add! accum-str #\return)] + [(#\e) (accum-string-add! accum-str #\u1B)] + [(#\newline) (void)] + [(#\return) + (define maybe-newline-c (peek-char/special in config 0 source)) + (when (eqv? maybe-newline-c #\newline) + (consume-char in maybe-newline-c)) + (void)] + [(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) + ;; Octal (valid if <= 255) + (define pos (accum-string-count accum-str)) + (accum-string-add! accum-str escaped-c) + (define init-v (digit->number escaped-c)) + (define v (read-digits in config accum-str #:base 8 #:max-count 2 + #:init init-v + #:zero-digits-result init-v)) + (unless (v . <= . 255) + (reader-error in config + "escape sequence `~a~a` is out of range in ~a" + escaping-c (accum-string-get! accum-str config #:start-pos pos) + mode)) + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [(#\x) + ;; Hex, two characters (always valid) + (define pos (accum-string-count accum-str)) + (define v (read-digits in config accum-str #:base 16 #:max-count 2)) + (unless (integer? v) (no-hex-digits in config v escaping-c escaped-c)) + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [(#\u) + ;; Hex, four characters (valid if not surrogate or if surrogate pair) + (unless (eq? mode 'string) (unknown-error)) + (define pos (accum-string-count accum-str)) + (define v (read-digits in config accum-str #:base 16 #:max-count 4)) + (unless (integer? v) (no-hex-digits in config v escaping-c escaped-c)) + (cond + [(or (v . < . #xD800) (v . > . #xDFFF)) + ;; Normal \u escape + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [else + ;; Maybe a surrogate-pair encoding + (define (next!) + (define next-c (read-char/special in config source)) + (when (char? next-c) + (accum-string-add! accum-str next-c)) + next-c) + (define v2 + (let ([next-c (next!)]) + (cond + [(char=? next-c #\\) + (define next-c (next!)) + (cond + [(char=? next-c #\u) + (define v2 (read-digits in config accum-str #:base 16 #:max-count 4)) + (cond + [(integer? v2) + (and (v2 . >= . #xDC00) + (v2 . <= . #xDFFF) + v2)] + [else v2])] ; maybe EOF + [else next-c])] ; maybe EOF + [else next-c]))) ; maybe EOF + (cond + [(integer? v2) + (define combined-v (+ (arithmetic-shift (- v #xD800) 10) + (- v2 #xDC00) + #x10000)) + (cond + [(combined-v . > . #x10FFFF) + (reader-error in config + "escape sequence `~au~a` is out of range in string" + escaping-c (accum-string-get! accum-str config #:start-pos pos))] + [else + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char combined-v))])] + [else + (reader-error in config + #:due-to v2 + "bad or incomplete surrogate-style encoding at `~au~a`" + escaping-c (accum-string-get! accum-str config #:start-pos pos))])])] + [(#\U) + (unless (eq? mode 'string) (unknown-error)) + (define pos (accum-string-count accum-str)) + (define v (read-digits in config accum-str #:base 16 #:max-count 8)) + (unless (integer? v) (no-hex-digits in config v escaping-c escaped-c)) + (cond + [(and (or (v . < . #xD800) (v . > . #xDFFF)) + (v . <= . #x10FFFF)) + (set-accum-string-count! accum-str pos) + (accum-string-add! accum-str (integer->char v))] + [else + (reader-error in config + "escape sequence `~aU~a` is out of range in string" + escaping-c (accum-string-get! accum-str config #:start-pos pos))])] + [else (unknown-error)]) + (loop)] + [(char=? #\" c) + null] + [else + (when (eq? mode '|byte string|) + (unless (byte? (char->integer c)) + (reader-error in config + "character `~a` is out of range in byte string" + c))) + (accum-string-add! accum-str c) + (loop)])) + (define str (if (eq? mode '|byte string|) + (accum-string-get-bytes! accum-str config) + (accum-string-get! accum-str config))) + (wrap str + in + config + str)) + +;; ---------------------------------------- + +(define (read-here-string in config) + (define source (read-config-source config)) + (define accum-str (accum-string-init! config)) + + ;; Parse terminator + (define full-terminator + (let loop () + (define c (read-char/special in config source)) + (cond + [(eof-object? c) + (reader-error in config #:due-to c + "found end-of-file after `#<<` and before a newline")] + [(not (char? c)) + (reader-error in config #:due-to c + "found non-character while reading `#<<`")] + [(char=? c #\newline) null] + [else (cons c (loop))]))) + + ;; Get string content + (let loop ([terminator full-terminator] [terminator-accum null]) + (define c (read-char/special in config source)) + (cond + [(eof-object? c) + (unless (null? terminator) + (reader-error in config #:due-to c + "found end-of-file before terminating `~a`" + (list->string full-terminator)))] + [(not (char? c)) + (reader-error in config #:due-to c + "found non-character while reading `#<<`")] + [(and (pair? terminator) + (char=? c (car terminator))) + (loop (cdr terminator) (cons (car terminator) terminator-accum))] + [(and (null? terminator) + (char=? c #\newline)) + (void)] + [else + (unless (null? terminator-accum) + (for ([c (in-list (reverse terminator-accum))]) + (accum-string-add! accum-str c))) + (accum-string-add! accum-str c) + (loop full-terminator null)])) + + ;; Done + (define str (accum-string-get! accum-str config)) + (wrap str + in + config + str)) + +;; ---------------------------------------- + +(define (no-hex-digits in config c escaping-c escaped-c) + (reader-error in config + #:due-to c + "no hex digit following `~a~a`" + escaping-c escaped-c)) diff --git a/racket/src/expander/read/struct.rkt b/racket/src/expander/read/struct.rkt new file mode 100644 index 0000000000..cba9ec1228 --- /dev/null +++ b/racket/src/expander/read/struct.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require "../common/prefab.rkt" + "readtable.rkt" + "config.rkt" + "special.rkt" + "parameter.rkt" + "error.rkt" + "wrap.rkt" + "closer.rkt" + "sequence.rkt") + +(provide read-struct) + +(define (read-struct read-one dispatch-c in config) + (define c (read-char/special in config)) + + (define-syntax-rule (guard-legal e body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (format "~as~a" dispatch-c c))])) + + (define ec (effective-char c config)) + (define seq + (case ec + [(#\() + (read-struct-sequence read-one c #\( #\) in config)] + [(#\[) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + (read-struct-sequence read-one c #\[ #\] in config))] + [(#\{) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + (read-struct-sequence read-one c #\{ #\} in config))] + [else + (reader-error in config + "expected ~a after `~as`" + (all-openers-str config) + dispatch-c)])) + + (when (null? seq) + (reader-error in config + "missing structure description in `~as' form" + dispatch-c)) + + (unless (prefab-key? (car seq)) + (reader-error in config + "invalid structure description in `~as' form" + dispatch-c)) + + (define st (with-handlers ([exn:fail? (lambda (exn) #f)]) + (prefab-key->struct-type (car seq) (length (cdr seq))))) + (unless st + (reader-error in config + (string-append "mismatch between structure description" + " and number of provided field values in `~as' form") + dispatch-c)) + + (when (read-config-for-syntax? config) + (unless (all-fields-immutable? (car seq)) + (reader-error in config + "cannot read mutable `~as' form as syntax" + dispatch-c))) + + (wrap (apply make-prefab-struct seq) + in + config + ec)) + +;; ---------------------------------------- + +(define (read-struct-sequence read-one opener-c opener closer in config) + (read-unwrapped-sequence read-one opener-c opener closer in config + #:first-read-one (lambda (init-c in config) + (read-one init-c in (disable-wrapping config))))) diff --git a/racket/src/expander/read/symbol-or-number.rkt b/racket/src/expander/read/symbol-or-number.rkt new file mode 100644 index 0000000000..3bd3484500 --- /dev/null +++ b/racket/src/expander/read/symbol-or-number.rkt @@ -0,0 +1,137 @@ +#lang racket/base +(require "config.rkt" + "special.rkt" + "wrap.rkt" + "readtable.rkt" + "delimiter.rkt" + "consume.rkt" + "accum-string.rkt" + "error.rkt" + "parameter.rkt" + "number.rkt") + +(provide read-symbol-or-number) + +(define (read-symbol-or-number init-c in config + ;; `mode` can be 'symbol-or-number, + ;; 'symbol, 'symbol/indirect, 'keyword, + ;; or a number prefix string like "#e"; + ;; only the 'symbol-or-number and + ;; 'symbol modes use a readtable's + ;; symbol handler + #:mode [mode 'symbol-or-number] + #:extra-prefix [extra-prefix #f]) + (define rt (read-config-readtable config)) + (cond + [(and rt + (or (eq? mode 'symbol-or-number) + (eq? mode 'symbol/indirect)) + (readtable-symbol-parser rt)) + => (lambda (handler) + (readtable-apply handler init-c in + config + (read-config-line config) + (read-config-col config) + (read-config-pos config)))] + [else + (define accum-str (accum-string-init! config)) + (define quoted-ever? #f) + (define case-sens? (check-parameter read-case-sensitive config)) + (when extra-prefix + (accum-string-add! accum-str extra-prefix)) + (define source (read-config-source config)) + + ;; If we encounter an EOF or special in the wrong place: + (define (unexpected-quoted c after-c) + (reader-error in config + #:due-to c + "~a following `~a` in ~a" + (if (eof-object? c) "end-of-file" "non-character") + after-c (cond + [(eq? mode 'keyword) "keyword"] + [(string? mode) "number"] + [else "symbol"]))) + + (let loop ([init-c init-c] + [pipe-quote-c #f] ; currently quoting? + [foldcase-from 0]) ; keep track of range to foldcase for case-insens + (define c (or init-c (peek-char/special in config 0 source))) + (define ec (readtable-effective-char rt c)) + (cond + [(and pipe-quote-c + (not (char? ec))) + ;; Interrupted while in quoting mode + (unless init-c (consume-char/special in config c)) + (unexpected-quoted c pipe-quote-c)] + [(and (not pipe-quote-c) + (readtable-char-delimiter? rt c config)) + ;; EOF or other delimiter - done! + (unless case-sens? + (accum-string-convert! accum-str string-foldcase foldcase-from))] + [(and pipe-quote-c + (char=? c pipe-quote-c)) ; note: `pipe-quote-c` determines close, not readtable + ;; End quoting mode + (unless init-c (consume-char in c)) + (loop #f #f (accum-string-count accum-str))] + [(and (char=? ec #\|) + (check-parameter read-accept-bar-quote config)) + ;; Start quoting mode + (unless init-c (consume-char in c)) + (set! quoted-ever? #t) + (unless case-sens? + (accum-string-convert! accum-str string-foldcase foldcase-from)) + (loop #f c (accum-string-count accum-str))] + [(and (char=? ec #\\) + (not pipe-quote-c)) + ;; Single-character quoting + (unless init-c (consume-char in c)) + (define next-c (read-char/special in config source)) + (unless (char? next-c) + (unexpected-quoted next-c c)) + (unless (or pipe-quote-c case-sens?) + (accum-string-convert! accum-str string-foldcase foldcase-from)) + (accum-string-add! accum-str next-c) + (set! quoted-ever? #t) + (loop #f #f (accum-string-count accum-str))] + [else + ;; Everything else + (unless init-c (consume-char in c)) + (accum-string-add! accum-str c) + (loop #f pipe-quote-c foldcase-from)])) + + (define str (accum-string-get! accum-str config)) + + ;; Disallow "." as a symbol + (when (and (= 1 (string-length str)) + (not quoted-ever?) + (char=? #\. (effective-char (string-ref str 0) config))) + (reader-error in config "illegal use of `.`")) + + (define num + (and (or (eq? mode 'symbol-or-number) + (string? mode)) + (not quoted-ever?) + (string->number (if (string? mode) + (string-append mode str) + str) + 10 + 'read + (if (check-parameter read-decimal-as-inexact config) + 'decimal-as-inexact + 'decimal-as-exact)))) + (when (string? num) + (reader-error in config "~a" num)) + + (when (and (not num) + (string? mode)) + (reader-error in config + "bad number: `~a`" + (string-append mode str))) + + (wrap (or num + (and (eq? mode 'keyword) + (string->keyword str)) + (string->symbol str)) + in + config + str)])) diff --git a/racket/src/expander/read/vector.rkt b/racket/src/expander/read/vector.rkt new file mode 100644 index 0000000000..fcf73d11ba --- /dev/null +++ b/racket/src/expander/read/vector.rkt @@ -0,0 +1,134 @@ +#lang racket/base +(require racket/fixnum + racket/flonum + "config.rkt" + "special.rkt" + "sequence.rkt" + "wrap.rkt" + "error.rkt" + "consume.rkt" + "digit.rkt" + "parameter.rkt" + "accum-string.rkt" + "fixnum-flonum.rkt") + +(provide read-vector + read-fixnum-or-flonum-vector) + +(define (read-vector read-one opener-c opener closer in config + #:mode [vector-mode 'any] + #:length [expected-len #f]) + (define read-one-element + (case vector-mode + [(any) read-one] + [(fixnum) (lambda (init-c in config) (read-fixnum read-one init-c in config))] + [(flonum) (lambda (init-c in config) (read-flonum read-one init-c in config))])) + + (define seq (read-unwrapped-sequence read-one-element + opener-c opener closer in config + #:whitespace-read-one read-one + #:dot-mode #f)) + + ;; Extend `seq` as needed to match the declared length + (define vec + (cond + [(not expected-len) + (case vector-mode + [(any) (list->vector seq)] + [(fixnum) (for/fxvector #:length (length seq) ([e (in-list seq)]) e)] + [(flonum) (for/flvector #:length (length seq) ([e (in-list seq)]) e)])] + [else + (define len (length seq)) + (cond + [(= expected-len len) (list->vector seq)] + [(expected-len . < . len) + (reader-error in config + "~avector length ~a is too small, ~a values provided" + (case vector-mode + [(any) ""] + [(fixnum) "fx"] + [(flonum) "fl"]) + expected-len len)] + [else + (define (last-or v) + (if (null? seq) + (wrap v in config #f) + (let loop ([seq seq]) + (if (null? (cdr seq)) (car seq) (loop (cdr seq)))))) + (when ((integer-length expected-len) . >= . 48) + ;; implausibly large + (raise (exn:fail:out-of-memory "out of memory" (current-continuation-marks)))) + (define vec + (case vector-mode + [(any) (make-vector expected-len (last-or 0))] + [(fixnum) (make-fxvector expected-len (last-or 0))] + [(flonum) (make-flvector expected-len (last-or 0.0))])) + (case vector-mode + [(any) (for ([e (in-list seq)] + [i (in-naturals)]) + (vector-set! vec i e))] + [(fixnum) (for ([e (in-list seq)] + [i (in-naturals)]) + (fxvector-set! vec i e))] + [(flonum) (for ([e (in-list seq)] + [i (in-naturals)]) + (flvector-set! vec i e))]) + vec])])) + + (wrap vec + in + config + opener)) + +;; ---------------------------------------- + +(define (read-fixnum-or-flonum-vector read-one dispatch-c c c2 in config) + (define vector-mode (if (char=? c2 #\x) 'fixnum 'flonum)) + (consume-char in c2) + (when (read-config-for-syntax? config) + (reader-error in config "literal f~avectors not allowed" c2)) + + (define c3 (read-char/special in config)) + (define-values (vector-len len-str c4) + (cond + [(decimal-digit? c3) (read-simple-number in config c3)] + [else (values #f "" c3)])) + + (define-syntax-rule (guard-legal e c body ...) + (cond + [e body ...] + [else (bad-syntax-error in config (format "~a~a" dispatch-c c))])) + + (case c4 + [(#\() + (read-vector read-one #\( #\( #\) in config #:mode vector-mode #:length vector-len)] + [(#\[) + (guard-legal + (check-parameter read-square-bracket-as-paren config) + (format "~a~a" c c2) + (read-vector read-one #\[ #\[ #\] in config #:mode vector-mode #:length vector-len))] + [(#\{) + (guard-legal + (check-parameter read-curly-brace-as-paren config) + (format "~a~a" c c2) + (read-vector read-one #\{ #\{ #\} in config #:mode vector-mode #:length vector-len))] + [else + (reader-error in config #:due-to c4 + "expected `(`, `[`, or `{` after `#~a~a~a`" + c c2 len-str)])) + + +(define (read-simple-number in config init-c) + (define accum-str (accum-string-init! config)) + (accum-string-add! accum-str init-c) + (define init-v (digit->number init-c)) + (define v (read-digits in config accum-str + #:base 10 #:max-count +inf.0 + #:init init-v + #:zero-digits-result init-v)) + (values v + (accum-string-get! accum-str config) + ;; We could avoid some peeks vising init-c + ;; and having `read-digit` return its peek + ;; result, but we don't for now + (read-char/special in config))) diff --git a/racket/src/expander/read/whitespace.rkt b/racket/src/expander/read/whitespace.rkt new file mode 100644 index 0000000000..109f34f0a4 --- /dev/null +++ b/racket/src/expander/read/whitespace.rkt @@ -0,0 +1,112 @@ +#lang racket/base +(require "../common/struct-star.rkt" + "config.rkt" + "special.rkt" + "readtable.rkt" + "consume.rkt" + "error.rkt" + "location.rkt" + "special.rkt" + "special-comment.rkt") + +(provide read-char/skip-whitespace-and-comments) + +;; Skip whitespace, including non-character values that are +;; `special-comment?`s --- but return a special comment (always +;; `special`-wrapped) if `(read-config-keep-comment? config)`. The +;; result is a character that has been consumed. +(define (read-char/skip-whitespace-and-comments init-c read-one in config) + (define rt (read-config-readtable config)) + (define source (read-config-source config)) + (let skip-loop ([init-c init-c]) + (define c (or init-c + (read-char/special in config source))) + (define ec (readtable-effective-char rt c)) + (cond + [(eof-object? ec) c] + [(not (char? ec)) + (define v (special-value c)) + (cond + [(and (special-comment? v) + (not (read-config-keep-comment? config))) + (skip-loop #f)] + [else c])] + [(char-whitespace? ec) + (skip-loop #f)] + [(char=? #\; ec) + (let loop () + (define c (read-char/special in config source)) + (unless (or (eof-object? c) + (eqv? #\newline (effective-char c config))) + (loop))) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [(and (char=? #\# ec) + (eqv? #\| (peek-char/special in config 0 source))) + (skip-pipe-comment! c in config) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [(and (char=? #\# ec) + (eqv? #\! (peek-char/special in config 0 source)) + (let ([c3 (peek-char/special in config 1 source)]) + (or (eqv? #\space c3) + (eqv? #\/ c3)))) + (skip-unix-line-comment! in config) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [(and (char=? #\# ec) + (eqv? #\; (peek-char/special in config 0 source))) + (consume-char in #\;) + (define v (read-one #f in config)) + (when (eof-object? v) + (reader-error in config + #:due-to v + "expected a commented-out element for `~a;', but found end-of-file" + ec)) + (if (read-config-keep-comment? config) + (result-special-comment) + (skip-loop #f))] + [else c]))) + +;; For returning a comment as a result: +(define (result-special-comment) + (special (make-special-comment #f))) + +;; Skips balanced pipe comments +(define (skip-pipe-comment! init-c in config) + (define source (read-config-source config)) + (define-values (line col pos) (port-next-location in)) + (consume-char in #\|) + (let loop ([prev-c #f] [depth 0]) + (define c (read-char/special in config source)) + (cond + [(eof-object? c) + (reader-error in (reading-at config line col pos) + #:due-to c + "end of file in `#|` comment")] + [(not (char? c)) + (loop #f depth)] + [(and (char=? #\| c) (eqv? prev-c #\#)) + (loop #f (add1 depth))] + [(and (char=? #\# c) (eqv? prev-c #\|)) + (when (positive? depth) + (loop #f (sub1 depth)))] + [else (loop c depth)]))) + +;; Skips a comment that starts #! and runs to the end of the line, but +;; can be continued with `\` at the end of the line +(define (skip-unix-line-comment! in config) + (let loop ([backslash? #f]) + (define c (read-char/special in config)) + (cond + [(eof-object? c) (void)] + [(not (char? c)) (loop #f)] + [(char=? c #\newline) + (when backslash? + (loop #f))] + [(char=? c #\\) + (loop #t)] + [else (loop #f)]))) diff --git a/racket/src/expander/read/wrap.rkt b/racket/src/expander/read/wrap.rkt new file mode 100644 index 0000000000..155fb703cc --- /dev/null +++ b/racket/src/expander/read/wrap.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(require "config.rkt") + +(provide wrap) + +(define (wrap s-exp in config rep) + (define wrap (read-config-wrap config)) + (if wrap + (wrap s-exp (port+config->srcloc in config) rep) + s-exp)) diff --git a/racket/src/expander/run.rkt b/racket/src/expander/run.rkt new file mode 100644 index 0000000000..cf346d7dfd --- /dev/null +++ b/racket/src/expander/run.rkt @@ -0,0 +1,350 @@ +#lang racket/base +(require racket/cmdline + racket/pretty + racket/runtime-path + (only-in racket/base + [eval host:eval] + [namespace-require host:namespace-require] + [current-library-collection-paths host:current-library-collection-paths] + [current-library-collection-links host:current-library-collection-links]) + compiler/depend + "common/set.rkt" + "main.rkt" + "namespace/namespace.rkt" + "common/module-path.rkt" + "eval/module-read.rkt" + "boot/kernel.rkt" + "run/cache.rkt" + "boot/runtime-primitive.rkt" + "host/linklet.rkt" + "run/status.rkt" + "run/submodule.rkt" + "host/correlate.rkt" + "extract/main.rkt" + (only-in "run/linklet.rkt" linklet-compile-to-s-expr)) + +(define-runtime-path main.rkt "main.rkt") + +;; Record all files that contribute to the result +(define dependencies (make-hash)) +(define extra-module-dependencies null) + +(define extract? #f) +(define expand? #f) +(define linklets? #f) +(define checkout-directory #f) +(define cache-dir #f) +(define cache-read-only? #f) +(define cache-save-only #f) +(define cache-skip-first? #f) +(define time-expand? #f) +(define print-extracted-to #f) +(define check-dependencies #f) +(define dependencies-file #f) +(define makefile-dependencies-target #f) +(define makefile-dependencies-file #f) +(define extract-to-c? #f) +(define extract-to-decompiled? #f) +(define instance-knot-ties (make-hasheq)) +(define primitive-table-directs (make-hasheq)) +(define side-effect-free-modules (make-hash)) +(define quiet-load? #f) +(define startup-module main.rkt) +(define submod-name #f) +(define load-file #f) +(define args + (command-line + #:once-any + [("-x" "--extract") "Extract bootstrap linklet" + (set! extract? #t)] + [("-e" "--expand") "Expand instead of running" + (set! expand? #t)] + [("--linklets") "Compile to linklets instead of running" + (set! linklets? #t)] + [("-O") dir "Use and write bootstrap linklet to Racket checkout at " + (set! checkout-directory (path->complete-path dir)) + (set! extract? #t) + (set! extract-to-c? #t) + (linklet-compile-to-s-expr #t) + (set! print-extracted-to (build-path checkout-directory "src" "racket" "src" "startup.inc"))] + #:once-each + [("-k") dir "Use Racket checkout at " + (set! checkout-directory (path->complete-path dir))] + [("-c" "--cache") dir "Save and load from " + (set! cache-dir (path->complete-path dir))] + [("-r" "--read-only") "Use cache in read-only mode" + (set! cache-read-only? #t)] + [("-y" "--cache-only") file "Cache only for sources listed in " + (set! cache-save-only (call-with-input-file* file read))] + [("-i" "--skip-initial") "Don't use cache for the initial load" + (set! cache-skip-first? #t)] + [("-s" "--s-expr") "Compile to S-expression instead of bytecode" + (linklet-compile-to-s-expr #t)] + [("-q" "--quiet") "Quiet load status" + (set! quiet-load? #t)] + [("--time") "Time re-expansion" + (set! time-expand? #t)] + [("-o" "--output") file "Print extracted bootstrap linklet to " + (when print-extracted-to (raise-user-error 'run "the `-O` flag implies `-o`, so don't use both")) + (set! print-extracted-to file)] + [("--check-depends") file "Skip if dependencies in unchanged" + (set! check-dependencies file)] + [("--depends") file "Record dependencies in " + (set! dependencies-file file)] + [("--makefile-depends") target file "Record makefile dependencies for in " + (set! makefile-dependencies-target target) + (set! makefile-dependencies-file file)] + #:multi + [("++depend") file "Record as a dependency" + (hash-set! dependencies (simplify-path (path->complete-path file)) #t)] + [("++depend-module") mod-file "Add and transitive as dependencies" + (set! extra-module-dependencies (cons mod-file extra-module-dependencies))] + #:once-any + [("-C") "Print extracted bootstrap as a C encoding" + (set! extract-to-c? #t)] + [("-D") "Print extracted bootstrap as a decompiled" + (set! extract-to-decompiled? #t)] + #:multi + [("++knot") sym path "Redirect imports from to flattened from " + (hash-update! instance-knot-ties + (string->symbol (format "#%~a" sym)) + (lambda (l) (cons (if (equal? path "-") + 'ignore + (path->complete-path (normal-case-path path))) + l)) + null)] + [("++direct") primitive-table "Redirect imports from #% to direct references" + (hash-set! primitive-table-directs + (string->symbol (string-append "#%" primitive-table)) + "")] + [("++direct-prefixed") primitive-table "Like ++direct, but prefixes with :" + (hash-set! primitive-table-directs + (string->symbol (string-append "#%" primitive-table)) + (string-append primitive-table ":"))] + [("++pure") path "Insist that is a module without side-effects" + (hash-set! side-effect-free-modules (simplify-path (path->complete-path path)) #t)] + #:once-any + [("-t") file "Load specified file" + (set! startup-module (path->complete-path file))] + [("-l") lib "Load specified library" + (set! startup-module `(lib ,lib))] + [("-f") file "Load non-module file in `racket/base` namespace" + (set! startup-module 'racket/base) + (set! load-file file)] + #:once-each + [("--submod") name "Load specified submodule" + (set! submod-name (string->symbol name))] + #:args args args)) + +;; ---------------------------------------- + +;; If any `--check-depends` is specified, exit as soon as possible if +;; nothing's newer + +(define (read-dependencies-from-file file) + (and (file-exists? file) + (with-handlers ([exn:fail:filesystem? (lambda (exn) + (log-error (exn-message exn)) + #f)]) + (let ([l (call-with-input-file file read)]) + (and (list? l) + (andmap bytes? l) + (map bytes->path l)))))) + +(when check-dependencies + (unless print-extracted-to + (raise-user-error 'run "cannot check dependencies without a specific output file")) + (define ts (file-or-directory-modify-seconds print-extracted-to #f (lambda () #f))) + (when (and + ts + (let ([l (read-dependencies-from-file check-dependencies)]) + (and l + (for/and ([dep (in-list l)]) + (<= (file-or-directory-modify-seconds dep #f (lambda () +inf.0)) + ts))))) + (log-status "No dependencies are newer") + (exit 0))) + +;; ---------------------------------------- + +(define cache + (and (or cache-dir extract?) + (make-cache cache-dir (lambda (path) + (log-status "changed: ~a" path))))) + +(when checkout-directory + ;; After booting, we're going to change the way module paths + ;; resolve. That's not generally ok, but as long we trigger visits + ;; of available modules here, it turns out that it won't cause + ;; trouble. + (host:namespace-require ''#%kernel) + (host:eval '(void))) + +;; Install handlers: +(boot) + +;; Avoid use of ".zo" files: +(use-compiled-file-paths null) + +;; Redirect module search to another installation: +(when checkout-directory + (let ([l (list (build-path checkout-directory "collects"))]) + (host:current-library-collection-paths l)) + (let ([l (list #f + (build-path checkout-directory "share" "links.rktd"))]) + (host:current-library-collection-links l))) + +(current-library-collection-paths (host:current-library-collection-paths)) +(current-library-collection-links (host:current-library-collection-links)) + +;; Replace the load handler to stash compiled modules in the cache +;; and/or load them from the cache +(define orig-load (current-load)) +(current-load (lambda (path expected-module) + (cond + [expected-module + (let loop () + (cond + [(and cache + (not cache-skip-first?) + (get-cached-compiled cache path + (lambda () + (when cache-dir + (unless quiet-load? + (log-status "cached: ~a" path)))))) + => (lambda (m) + ;; Since we've set `use-compiled-file-paths` to null, + ;; the load/use-compiled handler thinks that we're + ;; always loading from source, so don't find the + ;; expected submodule with + ;; `(extract-requested-submodule m expected-module)` + (eval m))] + [(and (pair? expected-module) + (not (car expected-module))) + ;; shouldn't load from source when `expected-module` starts with #f + (void)] + [else + (unless quiet-load? + (log-status "compile: ~a" path)) + (set! cache-skip-first? #f) + (with-handlers ([exn:fail? (lambda (exn) + (unless quiet-load? + (log-status "...during ~a..." path)) + (raise exn))]) + (define s + (call-with-input-file* + path + (lambda (i) + (port-count-lines! i) + (with-module-reading-parameterization + (lambda () + (check-module-form + (read-syntax (object-name i) i) + path)))))) + (cond + [(not cache) + (eval s)] + [else + (define cache-layer (make-cache-layer)) + (define c + (parameterize ([current-cache-layer cache-layer]) + (compile s))) + (when time-expand? + ;; Re-expanding avoids timing load of required modules + (time (expand s))) + (cond + [(and cache + (not cache-read-only?) + (or (not cache-save-only) + (hash-ref cache-save-only (path->string path) #f))) + (cache-compiled! cache path c cache-layer) + (loop)] + [else (eval c)])]))]))] + [else (orig-load path #f)]))) + +(define orig-resolver (current-module-name-resolver)) +(current-module-name-resolver + (case-lambda + [(r ns) (orig-resolver r ns)] + [(r wrt src load?) + (define p (orig-resolver r wrt src load?)) + (define n (resolved-module-path-name p)) + (when (and (path? n) cache) + (register-dependency! cache n)) + p])) + +(define (apply-to-module proc mod-path) + (define path (resolved-module-path-name + (resolve-module-path mod-path #f))) + (define-values (dir file dir?) (split-path path)) + (parameterize ([current-load-relative-directory dir]) + (proc (call-with-input-file* + path + (lambda (i) + (port-count-lines! i) + (with-module-reading-parameterization + (lambda () + (check-module-form + (read-syntax (object-name i) i) + path)))))))) + +(cond + [expand? + (pretty-write (syntax->datum (apply-to-module expand startup-module)))] + [linklets? + (pretty-write (correlated->datum + (datum->correlated + (apply-to-module compile-to-linklets startup-module) #f)))] + [else + ;; Load and run the requested module + (parameterize ([current-command-line-arguments (list->vector args)]) + (namespace-require (if submod-name + `(submod ,startup-module ,submod-name) + startup-module)))]) + +(when extract? + ;; Extract a bootstrapping slice of the requested module + (extract startup-module cache + #:print-extracted-to print-extracted-to + #:as-c? extract-to-c? + #:as-decompiled? extract-to-decompiled? + #:instance-knot-ties instance-knot-ties + #:primitive-table-directs primitive-table-directs + #:side-effect-free-modules side-effect-free-modules)) + +(when load-file + (load load-file)) + +;; ---------------------------------------- + +(when (or dependencies-file + makefile-dependencies-file) + (for ([mod-file (in-list extra-module-dependencies)]) + (define deps (cons mod-file + (module-recorded-dependencies mod-file))) + (for ([dep (in-list deps)]) + (hash-set! dependencies (simplify-path (path->complete-path dep)) #t))) + ;; Note: `cache` currently misses external dependencies, such as + ;; `include`d files. + (for ([dep (in-list (cache->used-paths cache))]) + (hash-set! dependencies (simplify-path dep) #t))) + +(when dependencies-file + (call-with-output-file* + dependencies-file + #:exists 'truncate/replace + (lambda (o) + (writeln (for/list ([dep (in-hash-keys dependencies)]) + (path->bytes dep)) + o)))) + +(when makefile-dependencies-file + (define (quote-if-space s) (if (regexp-match? #rx" " s) (format "\"~a\"" s) s)) + (call-with-output-file* + makefile-dependencies-file + #:exists 'truncate/replace + (lambda (o) + (fprintf o "~a:" (quote-if-space makefile-dependencies-target)) + (for ([dep (in-hash-keys dependencies)]) + (fprintf o " \\\n ~a" (quote-if-space dep))) + (newline o)))) diff --git a/racket/src/expander/run/bootstrap.rkt b/racket/src/expander/run/bootstrap.rkt new file mode 100644 index 0000000000..88957b03d5 --- /dev/null +++ b/racket/src/expander/run/bootstrap.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require "linklet.rkt" + (prefix-in host: '#%linklet) + "linklet-operation.rkt" + "../common/reflect-hash.rkt") + +;; Run this module before "../host/linklet.rkt" to substitute the +;; implementation in "linklet.rkt" + +(define bootstrap-linklet-instance + (host:primitive-table '#%bootstrap-linklet + (linklet-operations=> reflect-hash))) diff --git a/racket/src/expander/run/cache.rkt b/racket/src/expander/run/cache.rkt new file mode 100644 index 0000000000..7ed721c2fa --- /dev/null +++ b/racket/src/expander/run/cache.rkt @@ -0,0 +1,128 @@ +#lang racket/base +(require racket/file + file/sha1) + +(provide make-cache + get-cached-compiled + cache-compiled! + register-dependency! + + current-cache-layer + make-cache-layer + + cache->used-paths) + +(struct cache (dir + [table #:mutable] ; filename -> entry [used for a cache file] + used ; to track dependencies + in-memory)) ; key -> code [when no cache filed is in use] + +(struct entry (key ; sha1 of filename + content ; sha1 of file content + dependencies) ; list of key + #:prefab) + +(define current-cache-layer (make-parameter #f)) + +;; A cache later collects immediate dependencies +;; for a module as it is compiled +(define (make-cache-layer) (box null)) + +(define (cache-dir->file cache-dir) + (build-path cache-dir "cache.rktd")) + +(define (make-cache cache-dir out-of-date-callback) + (define cache-file (and cache-dir + (cache-dir->file cache-dir))) + (define table + (if (and cache-file + (file-exists? cache-file)) + (only-up-to-date (call-with-input-file* cache-file read) + cache-dir + out-of-date-callback) + #hash())) + (cache cache-dir table (make-hash) (make-hash))) + +(define (only-up-to-date table cache-dir out-of-date-callback) + ;; Build a new table imperatively (as a kind of memoization) + (define new-table (make-hash)) + (define reported (make-hash)) + (define (up-to-date? path e) + (or (hash-ref new-table path #f) + (and (file-exists? path) + (file-exists? (build-path cache-dir (entry-key e))) + (equal? (call-with-input-file* path sha1) + (entry-content e)) + (for/and ([path (in-list (entry-dependencies e))]) + (define e (hash-ref table path #f)) + (and e (up-to-date? path e))) + (begin + (hash-set! new-table path e) + #t)) + (begin + (unless (hash-ref reported path #f) + (hash-set! reported path #t) + (out-of-date-callback path)) + #f))) + ;; Check all file content and dependencies: + (for ([(k e) (in-hash table)]) + (up-to-date? k e)) + ;; Convert back to immutable: + (for/hash ([(k e) (in-hash new-table)]) + (values k e))) + +(define (get-cached-compiled cache path [notify-success void]) + (hash-set! (cache-used cache) path #t) + (define e (hash-ref (cache-table cache) + (path->string path) + #f)) + (define cached-file (and e + (cache-dir cache) + (build-path (cache-dir cache) + (entry-key e)))) + (cond + [(and cached-file + (file-exists? cached-file)) + (notify-success) + (parameterize ([read-accept-compiled #t]) + (call-with-input-file* cached-file read))] + [(and e + (hash-ref (cache-in-memory cache) (entry-key e) #f)) + => (lambda (c) + (notify-success) + c)] + [else #f])) + +(define (register-dependency! cache path) + (define l (current-cache-layer)) + (when l + (define deps (unbox l)) + (define s (path->string path)) + (unless (member s deps) + (set-box! l (cons s deps))))) + +(define (cache-compiled! cache path c layer) + (define key (sha1 (open-input-bytes (path->bytes path)))) + (define file-content (call-with-input-file* path sha1)) + (define new-table (hash-set (cache-table cache) (path->string path) + (entry key + file-content + (unbox layer)))) + (set-cache-table! cache new-table) + (cond + [(cache-dir cache) + (define cache-file (cache-dir->file (cache-dir cache))) + (make-directory* (cache-dir cache)) + (call-with-output-file* + #:exists 'truncate + (build-path (cache-dir cache) key) + (lambda (o) (write c o))) + (call-with-atomic-output-file + cache-file + (lambda (o path) (writeln new-table o)))] + [else + (hash-set! (cache-in-memory cache) key c)])) + + +(define (cache->used-paths cache) + (hash-keys (cache-used cache))) diff --git a/racket/src/expander/run/correlated-to-host-syntax.rkt b/racket/src/expander/run/correlated-to-host-syntax.rkt new file mode 100644 index 0000000000..001b880519 --- /dev/null +++ b/racket/src/expander/run/correlated-to-host-syntax.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require "../syntax/datum-map.rkt" + "../host/correlate.rkt") + +;; Convert from `compile-linklet`-compatible representation to a +;; `compile`-compatible representation. + +(provide correlated->host-syntax) + +(define (correlated->host-syntax v) + (datum-map v + (lambda (tail? v) + (cond + [(correlated? v) + (define e (correlated->host-syntax (correlated-e v))) + (define s (datum->syntax #f + e + (vector (correlated-source v) + (correlated-line v) + (correlated-column v) + (correlated-position v) + (correlated-span v)))) + (define keys (correlated-property-symbol-keys v)) + (for/fold ([s s]) ([key (in-list keys)]) + (syntax-property s key (correlated-property v key)))] + [else v])))) diff --git a/racket/src/expander/run/host-syntax-to-syntax.rkt b/racket/src/expander/run/host-syntax-to-syntax.rkt new file mode 100644 index 0000000000..e1b7bf6472 --- /dev/null +++ b/racket/src/expander/run/host-syntax-to-syntax.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require "../syntax/syntax.rkt" + "../syntax/datum-map.rkt" + (prefix-in host: racket/base)) + +;; Just like `reader-syntax->syntax`, but for the host notion of +;; syntax (which can be different if `racket/base` provides a +;; different notion of syntax as its `read-syntax` than then runtime +;; system's reader) + +(provide host-syntax->syntax) + +(define (host-syntax->syntax v) + (datum-map v + (lambda (tail? v) + (cond + [(host:syntax? v) + (define e (host:syntax-e v)) + (cond + [(syntax? e) + ;; Readtable, #lang, and #reader callbacks can lead to a + ;; reader syntax wrapper on our syntax + e] + [else + (define s + (struct-copy syntax empty-syntax + [content (host-syntax->syntax (host:syntax-e v))] + [srcloc (srcloc (host:syntax-source v) + (host:syntax-line v) + (host:syntax-column v) + (host:syntax-position v) + (host:syntax-span v))])) + (define keys (host:syntax-property-symbol-keys v)) + (for/fold ([s s]) ([key (in-list keys)]) + (syntax-property s key (host:syntax-property v key) #t))])] + [else v])))) diff --git a/racket/src/expander/run/linklet-operation.rkt b/racket/src/expander/run/linklet-operation.rkt new file mode 100644 index 0000000000..e18eaffa64 --- /dev/null +++ b/racket/src/expander/run/linklet-operation.rkt @@ -0,0 +1,47 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(provide linklet-operations=>) + +(define-syntax (linklet-operations=> stx) + (syntax-case stx () + [(_ form) + (datum->syntax + #'form + (cons #'form + '(primitive-table + primitive->compiled-position + compiled-position->primitive + primitive-in-category? + + linklet? + compile-linklet ; result is serializable + recompile-linklet + eval-linklet ; optional; result is not serializable + read-compiled-linklet + instantiate-linklet ; fills in an instance given linket an argument instances + + linklet-import-variables + linklet-export-variables + + instance? + make-instance + instance-name ; just for debugging and similar + instance-data + instance-variable-names + instance-variable-value + instance-set-variable-value! + instance-unset-variable! + + linklet-directory? ; maps symbol lists to linklet bundles + hash->linklet-directory ; converts a hash table to a ld + linklet-directory->hash ; the other way + + linklet-bundle? ; maps symbols and fixnums to values + hash->linklet-bundle + linklet-bundle->hash + + variable-reference? + variable-reference->instance + variable-reference-constant? + variable-reference-from-unsafe?)))])) diff --git a/racket/src/expander/run/linklet.rkt b/racket/src/expander/run/linklet.rkt new file mode 100644 index 0000000000..e9d66e8109 --- /dev/null +++ b/racket/src/expander/run/linklet.rkt @@ -0,0 +1,510 @@ +#lang racket/base +(require racket/unsafe/undefined + "../common/set.rkt" + "../syntax/datum-map.rkt" + "../host/correlate.rkt" + "../common/reflect-hash.rkt" + "../boot/runtime-primitive.rkt" + "correlated-to-host-syntax.rkt" + "linklet-operation.rkt") + +;; A "linklet" is the primitive form of separate (not necessarily +;; independent) compilation and linking. A `linklet` is serializable +;; linklet, and instantiation of a linklet produces an "instance" +;; given other instances to satisfy its imports. An instance, which +;; essentially just maps symbols to values, can also be created +;; directly, so it serves as the bridge between the worlds of values +;; and compiled objects. + +;; A "linklet bundle" is similarly a primitive construct that is +;; essentially a mapping of symbols and fixnums to linklets, symbols, +;; and symbol lists. A bundle is used, for example, to implement a +;; module (which is a collection of linklets plus some static +;; metadata). + +;; Finally, a "linklet directory" is a primitive construct that is a +;; mapping of #f to a bundle and symbols to linklet directories. The +;; intent is that individual linklet bundles can be efficiently +;; extracted from the marshaled form of a linklet directory --- the +;; primitive form of accessing an indvidual submodule. + +;; For bootstrapping, we can implement linklets here by compiling +;; `linklet` to `lambda`. If the host Racket supports linklets, then +;; this is not necessary, except to the degree that `compile-linklet` +;; needs to be replaced with a variant that "compiles" to source. + +(define (variable-reference-from-unsafe? x) #f) + +;; See "linklet-operation.rkt": +(linklet-operations=> provide) + +;; Helpers for "extract.rkt" +(provide linklet-compile-to-s-expr ; a parameter; whether to "compile" to a source form + linklet-as-s-expr? + + s-expr-linklet-importss+localss + s-expr-linklet-exports+locals + s-expr-linklet-body) + +(struct linklet (compiled-proc ; takes self instance plus instance arguments to run the linklet body + importss ; list [length is 1 less than proc arity] of list of symbols + exports) ; list of symbols + #:prefab) + +(struct instance (name ; for debugging, typically a module name + phase + data ; any value (e.g., a namespace) + variables)) ; symbol -> value + +(define (make-instance name [data #f] [mode #f] . content) + (define i (instance name data (make-hasheq))) + (let loop ([content content]) + (cond + [(null? content) (void)] + [else + (unless (symbol? (car content)) + (raise-argument-error 'make-instance + "symbol?" + (car content))) + (when (null? (cdr content)) + (raise-arguments-error 'make-instance + "missing variable value" + "variable" (car content))) + (instance-set-variable-value! i (car content) (cadr content) mode) + (loop (cddr content))])) + i) + +(define (instance-variable-names i) + (hash-keys (instance-variables i))) + +(define (instance-variable-box i sym can-create?) + (or (hash-ref (instance-variables i) sym #f) + (if can-create? + (let ([b (box undefined)]) + (hash-set! (instance-variables i) sym b) + b) + (error 'link "missing binding: ~s" sym)))) + +(define (instance-set-variable-value! i sym val [constant? #f]) + (set-box! (instance-variable-box i sym #t) val)) + +(define (instance-unset-variable! i sym) + (set-box! (instance-variable-box i sym #t) undefined)) + +(define (instance-variable-value i sym [fail-k (lambda () (error "instance variable not found:" sym))]) + (define b (hash-ref (instance-variables i) sym #f)) + (cond + [(and b + (not (eq? (unbox b) undefined))) + (unbox b)] + [(procedure? fail-k) (fail-k)] + [else fail-k])) + +;; ---------------------------------------- + +(define undefined (gensym 'undefined)) + +(define (check-not-undefined val sym) + (if (eq? val undefined) + (check-not-unsafe-undefined unsafe-undefined sym) + val)) + +;; ---------------------------------------- + +(define (primitive-table name) + (cond + [(eq? name '#%bootstrap-linklet) #f] + [(eq? name '#%linklet) (linklet-operations=> reflect-hash)] + [else + (define mod-name `(quote ,name)) + (define-values (vars trans) (module->exports mod-name)) + (for/hasheq ([sym (in-list (map car (cdr (assv 0 vars))))]) + (values sym + (dynamic-require mod-name sym)))])) + +;; Bootstrap implementation doesn't support bytecode: +(define (primitive->compiled-position v) #f) +(define (compiled-position->primitive pos) #f) +(define (primitive-in-category? name cat-sym) #f) + +;; ---------------------------------------- + +(struct variable-reference (instance primitive-varref)) + +(define (variable-reference->instance vr [ref-site? #f]) + (and (or ref-site? + ;; It would be better to have a `variable-reference-anonymous?` predicate: + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (variable-reference->module-declaration-inspector + (variable-reference-primitive-varref vr)))) + ;; Always returning ref-site instance; that's good enough to + ;; bootstrap: + (variable-reference-instance vr))) + +(define variable-reference-constant?* + (let ([variable-reference-constant? + (lambda (vr) + (variable-reference-constant? (variable-reference-primitive-varref vr)))]) + variable-reference-constant?)) + + +(define variable-reference-from-unsafe?* + (let ([variable-reference-from-unsafe? + (lambda (vr) + (variable-reference-from-unsafe? (variable-reference-primitive-varref vr)))]) + variable-reference-from-unsafe?)) + +;; ---------------------------------------- + +(define cu-namespace (make-empty-namespace)) +(namespace-attach-module (current-namespace) ''#%builtin cu-namespace) +(parameterize ([current-namespace cu-namespace]) + (for ([name (in-list runtime-instances)]) + (namespace-require `',name)) + (namespace-require ''#%linklet) + (namespace-set-variable-value! 'check-not-undefined check-not-undefined) + (namespace-set-variable-value! 'instance-variable-box instance-variable-box) + (namespace-set-variable-value! 'variable-reference variable-reference) + (namespace-set-variable-value! 'variable-reference? variable-reference? #t) + (namespace-set-variable-value! 'variable-reference->instance variable-reference->instance #t) + (namespace-set-variable-value! 'variable-reference-constant? variable-reference-constant?* #t) + (namespace-set-variable-value! 'variable-reference-from-unsafe? variable-reference-from-unsafe?* #t)) + +;; ---------------------------------------- + +;; Compile a `linklet` to a plain `lambda`. Also, convert from the +;; notion of correlated that works for `compile-linklet` to the notion +;; of host syntax objects that works for `compile`. +(define (desugar-linklet c) + (define imports (list-ref c 1)) + (define exports (list-ref c 2)) + (define bodys (list-tail c 3)) + (define inst-names (for/list ([import (in-list imports)] + [i (in-naturals)]) + (string->symbol (format "in_~a" i)))) + (define import-box-bindings + (for/list ([inst-imports (in-list imports)] + [inst (in-list inst-names)] + #:when #t + [name (in-list inst-imports)]) + (define ext (if (symbol? name) name (car name))) + (define int (if (symbol? name) name (cadr name))) + `[(,int) (instance-variable-box ,inst ',ext #f)])) + (define export-box-bindings + (for/list ([name (in-list exports)]) + (define int (if (symbol? name) name (car name))) + (define ext (if (symbol? name) name (cadr name))) + `[(,int) (instance-variable-box self-inst ',ext #t)])) + (define box-bindings (append import-box-bindings export-box-bindings)) + (define import-box-syms (apply seteq (map caar import-box-bindings))) + (define box-syms (set-union import-box-syms + (apply seteq (map caar export-box-bindings)))) + (define (desugar e) + (cond + [(correlated? e) + (correlate e (desugar (correlated-e e)))] + [(symbol? e) (if (set-member? box-syms e) + (if (set-member? import-box-syms e) + `(unbox ,e) + `(check-not-undefined (unbox ,e) ',e)) + e)] + [(pair? e) + (case (correlated-e (car e)) + [(quote) e] + [(set!) + (define-correlated-match m e '(set! var rhs)) + (if (set-member? box-syms (correlated-e (m 'var))) + `(set-box! ,(m 'var) ,(desugar (m 'rhs))) + `(set! ,(m 'var) ,(desugar (m 'rhs))))] + [(define-values) + (define-correlated-match m e '(define-values (id ...) rhs)) + (define ids (m 'id)) + (define tmps (map gensym (map correlated-e ids))) + `(define-values ,(for/list ([id (in-list ids)] + #:when (not (set-member? box-syms (correlated-e id)))) + id) + (let-values ([,tmps (let-values ([,ids ,(desugar (m 'rhs))]) + (values ,@ids))]) + (begin + ,@(for/list ([id (in-list ids)] + [tmp (in-list tmps)] + #:when (set-member? box-syms (correlated-e id))) + `(set-box! ,id ,tmp)) + (values ,@(for/list ([id (in-list ids)] + [tmp (in-list tmps)] + #:when (not (set-member? box-syms (correlated-e id)))) + tmp)))))] + [(lambda) + (define-correlated-match m e '(lambda formals body)) + `(lambda ,(m 'formals) ,(desugar (m 'body)))] + [(case-lambda) + (define-correlated-match m e '(case-lambda [formals body] ...)) + `(case-lambda ,@(for/list ([formals (in-list (m 'formals))] + [body (in-list (m 'body))]) + `[,formals ,(desugar body)]))] + [(#%variable-reference) + (if (and (pair? (correlated-e (cdr (correlated-e e)))) + (set-member? box-syms (correlated-e (correlated-cadr e)))) + ;; Using a plain `#%variable-reference` (for now) means + ;; that all imported and exported variables count as + ;; mutable: + '(variable-reference self-inst (#%variable-reference)) + ;; Preserve info about a local identifier: + `(variable-reference self-inst ,e))] + [else (map desugar (correlated->list e))])] + [else e])) + (define (last-is-definition? bodys) + (define p (car (reverse bodys))) + (and (pair? p) (eq? (correlated-e (car p)) 'define-values))) + (correlated->host-syntax + `(lambda (self-inst ,@inst-names) + (let-values ,box-bindings + ,(cond + [(null? bodys) '(void)] + [else + `(begin + ,@(for/list ([body (in-list bodys)]) + (desugar body)) + ,@(if (last-is-definition? bodys) + '((void)) + null))]))))) + +;; #:pairs? #f -> list of list of symbols +;; #:pairs? #t -> list of list of (cons ext-symbol int-symbol) +(define (extract-import-variables-from-expression c #:pairs? pairs?) + (for/list ([is (in-list (unmarshal (list-ref c 1)))]) + (for/list ([i (in-list is)]) + (cond + [pairs? (if (symbol? i) + (cons i i) + (cons (car i) (cadr i)))] + [else (if (symbol? i) + i + (car i))])))) + +;; #:pairs? #f -> list of symbols +;; #:pairs? #t -> list of (cons ext-symbol int-symbol) +(define (extract-export-variables-from-expression c #:pairs? pairs?) + (for/list ([e (in-list (unmarshal (list-ref c 2)))]) + (cond + [pairs? (if (symbol? e) + (cons e e) + (cons (cadr e) (car e)))] + [else (if (symbol? e) + e + (cadr e))]))) + +;; ---------------------------------------- + +(define orig-eval (current-eval)) +(define orig-compile (current-compile)) + +(define linklet-compile-to-s-expr (make-parameter #f)) + +;; Compile to a serializable form +(define (compile-linklet c [name #f] [import-keys #f] [get-import (lambda (key) (values #f #f))] [serializable? #t]) + (define l + (cond + [(linklet-compile-to-s-expr) + (marshal (correlated->datum/lambda-name c))] + [else + (define plain-c (desugar-linklet c)) + (parameterize ([current-namespace cu-namespace] + [current-eval orig-eval] + [current-compile orig-compile]) + ;; Use a vector to list the exported variables + ;; with the compiled bytecode + (linklet (compile plain-c) + (marshal (extract-import-variables-from-expression c #:pairs? #f)) + (marshal (extract-export-variables-from-expression c #:pairs? #f))))])) + (if import-keys + (values l import-keys) ; no imports added or removed + l)) + +;; For re-optimizing: +(define (recompile-linklet linklet name [import-keys #f] [get-import (lambda (key) (values #f #f))]) + (if import-keys + (values linklet import-keys) + linklet)) + +;; Intended for JIT preparation +;; (and we could compile to a function here) +(define (eval-linklet c) + c) + +(define (read-compiled-linklet in) + (read in)) + +;; Convert linklet to a procedure +(define (really-eval-linklet cl) + (parameterize ([current-namespace cu-namespace] + [current-eval orig-eval] + [current-compile orig-compile]) + (if (linklet? cl) + ;; Normal mode: compiled to struct + (eval (linklet-compiled-proc cl)) + ;; Assume previously "compiled" to source: + (or (hash-ref eval-cache cl #f) + (let ([proc (eval (desugar-linklet (unmarshal cl)))]) + (hash-set! eval-cache cl proc) + proc))))) +(define eval-cache (make-weak-hasheq)) + +;; Check whether we previously compiled a linket to source +(define (linklet-as-s-expr? cl) + (not (linklet? cl))) + +;; Instantiate +(define (instantiate-linklet linklet import-instances [target-instance #f] [use-prompt? #t]) + (cond + [(not target-instance) + ;; return newly created instance + (define target-instance (make-instance 'anonymous)) + (instantiate-linklet linklet import-instances target-instance) + target-instance] + [else + ;; return results via tail call + (apply (really-eval-linklet linklet) target-instance import-instances)])) + +;; ---------------------------------------- + +(define (linklet-import-variables linklet) + (if (linklet? linklet) + ;; Compiled to a prefab that includes metadata + (linklet-importss linklet) + ;; Previously "compiled" to source + (extract-import-variables-from-expression linklet #:pairs? #f))) + +(define (linklet-export-variables linklet) + (if (linklet? linklet) + ;; Compiled to a prefab that includes metadata + (linklet-exports linklet) + ;; Previously "compiled" to source + (extract-export-variables-from-expression linklet #:pairs? #f))) + +(define (s-expr-linklet-importss+localss linklet) + (extract-import-variables-from-expression linklet #:pairs? #t)) + +(define (s-expr-linklet-exports+locals linklet) + (extract-export-variables-from-expression linklet #:pairs? #t)) + +(define (s-expr-linklet-body linklet) + (unmarshal (list-tail linklet 3))) + +;; ---------------------------------------- + +(struct linklet-directory (table) + #:prefab) + +(define (hash->linklet-directory ht) + (linklet-directory ht)) + +(define (linklet-directory->hash ld) + (linklet-directory-table ld)) + +;; ---------------------------------------- + +(struct linklet-bundle (table) + #:prefab) + +(define (hash->linklet-bundle ht) + (linklet-bundle ht)) + +(define (linklet-bundle->hash ld) + (linklet-bundle-table ld)) + +;; ---------------------------------------- + +(struct path-bytes (bstr) #:prefab) +(struct unreadable (str) #:prefab) +(struct void-value () #:prefab) + +(define (marshal c) + (datum-map c (lambda (tail? c) + (cond + [(path? c) (path-bytes (path->bytes c))] + [(and (symbol? c) (symbol-unreadable? c)) (unreadable (symbol->string c))] + [(void? c) (void-value)] + [else c])))) + +(define (unmarshal c) + (datum-map c + (lambda (tail? c) + (cond + [(path-bytes? c) (bytes->path (path-bytes-bstr c))] + [(unreadable? c) (string->unreadable-symbol (unreadable-str c))] + [(void-value? c) (void)] + [else c])))) + +;; Like `correlated->datum`, but preserves 'inferred-name information +;; by encoding it as a symbol in a `lambda` or `case-lambda` body. +;; Remove any existing symbol in the name position that might +;; otherwise be confused for the name. This conversion avoids parsing +;; expressions in general by relying on the fact that bindings are +;; renamed to avoid shadowing, `lambda`, `case-lambda`, or `quote`. +(define (correlated->datum/lambda-name c) + (define (strip-potential-name-from-body body) + (define-correlated-match m body #:try '(begin (quote _) body bodys ...)) + (cond + [(and (m) + (eq? 'begin (m 'begin)) + (eq? 'quote (m 'quote))) + (strip-potential-name-from-body + (if (null? (m 'bodys)) + (m 'body) + `(begin ,@(m 'bodys))))] + [else body])) + (let correlated->datum/lambda-name ([c c]) + (cond + [(and (pair? c) + (eq? (car c) 'lambda)) + (define-correlated-match m c '(lambda args body)) + `(lambda ,(correlated->datum (m 'args)) + ,(correlated->datum/lambda-name + (strip-potential-name-from-body (m 'body))))] + [(and (pair? c) + (eq? (car c) 'case-lambda)) + (define-correlated-match m c '(case-lambda [argss bodys] ...)) + `(case-lambda + ,@(for/list ([args (in-list (m 'argss))] + [body (in-list (m 'bodys))]) + `[,(correlated->datum args) + ,(correlated->datum/lambda-name + (strip-potential-name-from-body body))]))] + [(and (pair? c) + (eq? (car c) 'quote)) + (correlated->datum c)] + [(pair? c) + (cons (correlated->datum/lambda-name (car c)) + (correlated->datum/lambda-name (cdr c)))] + [(and (correlated? c) + (let ([e (correlated-e c)]) + (and (pair? e) + (or (eq? 'lambda (car e)) + (eq? 'case-lambda (car e))))) + (correlated-property c 'inferred-name)) + => (lambda (name) + (cond + [(void? name) + ;; Don't try to hide the name after all + (correlated->datum/lambda-name (correlated-e c))] + [else + ;; Encode `name` as a symbol in the function body: + (define lam (correlated->datum/lambda-name (correlated-e c))) + (cond + [(eq? 'lambda (car lam)) + (define-correlated-match m lam '(lambda args body)) + `(lambda ,(m 'args) (begin (quote ,name) ,(m 'body)))] + [else + (define-correlated-match m lam '(case-lambda [argss bodys] ...)) + (cond + [(null? (m 'argss)) + ;; give up on naming an empty `case-lambda` + lam] + [else + `(case-lambda + [,(car (m 'argss)) (begin (quote ,name) ,(car (m 'bodys)))] + ,@(cddr lam))])])]))] + [(correlated? c) + (correlated->datum/lambda-name (correlated-e c))] + [else + (correlated->datum c)]))) diff --git a/racket/src/expander/run/status.rkt b/racket/src/expander/run/status.rkt new file mode 100644 index 0000000000..7688a4292e --- /dev/null +++ b/racket/src/expander/run/status.rkt @@ -0,0 +1,28 @@ +#lang racket/base + +(provide log-status + lines) + +(define stderr (current-error-port)) + +(define (log-status fmt . args) + (apply fprintf stderr (string-append fmt "\n") args)) + +(define (lines prefix vals) + (apply + string-append + prefix + (let loop ([col (string-length prefix)] [vals vals]) + (cond + [(null? vals) null] + [else + (define s (format " ~a" (car vals))) + (define slen (string-length s)) + (define new-col (+ col slen)) + (cond + [(new-col . < . 80) + (cons s (loop new-col (cdr vals)))] + [else + (list* "\n" (make-string (string-length prefix) #\space) s + (loop (+ (string-length prefix) slen) + (cdr vals)))])])))) diff --git a/racket/src/expander/run/submodule.rkt b/racket/src/expander/run/submodule.rkt new file mode 100644 index 0000000000..04748e711e --- /dev/null +++ b/racket/src/expander/run/submodule.rkt @@ -0,0 +1,31 @@ +#lang racket/base +(require "../eval/reflect.rkt") + +(provide extract-requested-submodule) + +(define (extract-requested-submodule m expected-module) + (define (drop-submodules m) + (module-compiled-submodules (module-compiled-submodules m #f null) + #t + null)) + (cond + [(symbol? expected-module) + (drop-submodules m)] + [else + (let loop ([m m] + [expected-module (cdr expected-module)] + [pos 1]) + (cond + [(null? expected-module) + (drop-submodules m)] + [else + (define new-m + (for/or ([m (in-list + (append + (module-compiled-submodules m #f) + (module-compiled-submodules m #t)))]) + (and (eq? (car expected-module) + (list-ref (module-compiled-name m) pos)) + m))) + (and new-m + (loop new-m (cdr expected-module) (add1 pos)))]))])) diff --git a/racket/src/expander/syntax/api-taint.rkt b/racket/src/expander/syntax/api-taint.rkt new file mode 100644 index 0000000000..c32589e71b --- /dev/null +++ b/racket/src/expander/syntax/api-taint.rkt @@ -0,0 +1,74 @@ +#lang racket/base +(require "syntax.rkt" + "to-list.rkt" + "scope.rkt" + "taint-dispatch.rkt" + (rename-in "taint.rkt" + [syntax-tainted? raw:syntax-tainted?] + [syntax-arm raw:syntax-arm] + [syntax-disarm raw:syntax-disarm] + [syntax-rearm raw:syntax-rearm] + [syntax-taint raw:syntax-taint]) + (only-in "../expand/syntax-local.rkt" syntax-local-phase-level) + "../namespace/core.rkt" + "../namespace/inspector.rkt" + "../common/contract.rkt") + +;; Provides public versions of taint-related syntax functions + +(provide syntax-tainted? + syntax-arm + syntax-disarm + syntax-rearm + syntax-taint) + +(define (syntax-tainted? s) + (check 'syntax-tainted? syntax? s) + (raw:syntax-tainted? s)) + +(define (syntax-arm s [maybe-insp #f] [use-mode? #f]) + (check 'syntax-arm syntax? s) + (unless (or (not maybe-insp) + (inspector? maybe-insp)) + (raise-argument-error 'syntax-arm "(or/c inspector? #f)" maybe-insp)) + (define insp (inspector-for-taint maybe-insp)) + (cond + [use-mode? + (taint-dispatch + s + (lambda (s) (raw:syntax-arm s insp)) + (syntax-local-phase-level))] + [else + (raw:syntax-arm s insp)])) + +(define (syntax-disarm s maybe-insp) + (check 'syntax-disarm syntax? s) + (unless (or (not maybe-insp) + (inspector? maybe-insp)) + (raise-argument-error 'syntax-disarm "(or/c inspector? #f)" maybe-insp)) + (define insp (inspector-for-taint maybe-insp)) + (raw:syntax-disarm s insp)) + +(define (syntax-rearm s from-s [use-mode? #f]) + (check 'syntax-disarm syntax? s) + (check 'syntax-disarm syntax? from-s) + (cond + [use-mode? (taint-dispatch + s + (lambda (s) (raw:syntax-rearm s from-s)) + (syntax-local-phase-level))] + [else + (raw:syntax-rearm s from-s)])) + +(define (syntax-taint s) + (check 'syntax-taint syntax? s) + (raw:syntax-taint s)) + +;; ---------------------------------------- + +(define (inspector-for-taint maybe-insp) + (or maybe-insp + (current-module-code-inspector) + (current-code-inspector))) + +;; ---------------------------------------- diff --git a/racket/src/expander/syntax/api.rkt b/racket/src/expander/syntax/api.rkt new file mode 100644 index 0000000000..a18c601d93 --- /dev/null +++ b/racket/src/expander/syntax/api.rkt @@ -0,0 +1,188 @@ +#lang racket/base +(require "../common/phase.rkt" + (rename-in "syntax.rkt" + [syntax->datum raw:syntax->datum] + [datum->syntax raw:datum->syntax]) + "property.rkt" + "original.rkt" + (rename-in "to-list.rkt" + [syntax->list raw:syntax->list]) + (rename-in "scope.rkt" + [syntax-e raw:syntax-e] + [bound-identifier=? raw:bound-identifier=?] + [syntax-shift-phase-level raw:syntax-shift-phase-level]) + (rename-in "binding.rkt" + [free-identifier=? raw:free-identifier=?] + [identifier-binding raw:identifier-binding] + [identifier-binding-symbol raw:identifier-binding-symbol]) + (rename-in "track.rkt" + [syntax-track-origin raw:syntax-track-origin]) + "../expand/syntax-local.rkt" + "srcloc.rkt" + "../common/contract.rkt" + (rename-in "debug.rkt" + [syntax-debug-info raw:syntax-debug-info]) + (only-in "../expand/context.rkt" get-current-expand-context) + "../expand/log.rkt") + +;; Provides public versions of syntax functions (with contract checks, +;; for example); see also "taint-api.rkt" + +(provide syntax? + syntax-e + syntax-property + syntax-property-preserved? + syntax-property-symbol-keys + syntax-original? + syntax->datum + maybe-syntax->datum + datum->syntax + syntax->list + identifier? + bound-identifier=? + free-identifier=? + free-transformer-identifier=? + free-template-identifier=? + free-label-identifier=? + identifier-binding + identifier-transformer-binding + identifier-template-binding + identifier-label-binding + identifier-binding-symbol + identifier-prune-lexical-context + syntax-shift-phase-level + syntax-track-origin + syntax-debug-info) + +(define (syntax-e s) + (check 'syntax-e syntax? s) + (raw:syntax-e s)) + +(define (syntax->datum s) + (check 'syntax->datum syntax? s) + (raw:syntax->datum s)) + +(define (maybe-syntax->datum s) + (if (syntax? s) + (raw:syntax->datum s) + s)) + +(define (datum->syntax stx-c s [stx-l #f] [stx-p #f] [ignored #f]) + (unless (or (not stx-c) (syntax? stx-c)) + (raise-argument-error 'datum->syntax "(or #f syntax?)" stx-c)) + (unless (or (not stx-l) + (syntax? stx-l) + (encoded-srcloc? stx-l)) + (raise-argument-error 'datum->syntax + (string-append "(or #f syntax?\n" + " (list/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f))\n" + " (vector/c any/c\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)\n" + " (or/c exact-positive-integer? #f)\n" + " (or/c exact-nonnegative-integer? #f)))") + stx-l)) + (unless (or (not stx-p) (syntax? stx-p)) + (raise-argument-error 'datum->syntax "(or #f syntax?)" stx-p)) + (raw:datum->syntax stx-c s (to-srcloc-stx stx-l) stx-p)) + +(define (syntax->list s) + (check 'syntax->list syntax? s) + (raw:syntax->list s)) + +(define (syntax-original? s) + (check 'syntax-original? syntax? s) + (and (syntax-property s original-property-sym) + (not (syntax-any-macro-scopes? s)))) + +(define (bound-identifier=? a b [phase (syntax-local-phase-level)]) + (check 'bound-identifier=? identifier? a) + (check 'bound-identifier=? identifier? b) + (unless (phase? phase) + (raise-argument-error 'bound-identifier=? phase?-string phase)) + (raw:bound-identifier=? a b phase)) + +(define (free-identifier=? a b + [a-phase (syntax-local-phase-level)] + [b-phase a-phase]) + (check 'free-identifier=? identifier? a) + (check 'free-identifier=? identifier? b) + (unless (phase? a-phase) + (raise-argument-error 'free-identifier=? phase?-string a-phase)) + (unless (phase? b-phase) + (raise-argument-error 'free-identifier=? phase?-string b-phase)) + (raw:free-identifier=? a b a-phase b-phase)) + +(define (free-transformer-identifier=? a b) + (check 'free-transformer-identifier=? identifier? a) + (check 'free-transformer-identifier=? identifier? b) + (define phase (add1 (syntax-local-phase-level))) + (raw:free-identifier=? a b phase phase)) + +(define (free-template-identifier=? a b) + (check 'free-template-identifier=? identifier? a) + (check 'free-template-identifier=? identifier? b) + (define phase (sub1 (syntax-local-phase-level))) + (raw:free-identifier=? a b phase phase)) + +(define (free-label-identifier=? a b) + (check 'free-label-identifier=? identifier? a) + (check 'free-label-identifier=? identifier? b) + (raw:free-identifier=? a b #f #f)) + +(define (identifier-binding id [phase (syntax-local-phase-level)] [top-level-symbol? #f]) + (check 'identifier-binding identifier? id) + (unless (phase? phase) + (raise-argument-error 'identifier-binding phase?-string phase)) + (raw:identifier-binding id phase top-level-symbol?)) + +(define (identifier-transformer-binding id [phase (syntax-local-phase-level)]) + (check 'identifier-transformer-binding identifier? id) + (raw:identifier-binding id (and phase (add1 phase)))) + +(define (identifier-template-binding id) + (check 'identifier-template-binding identifier? id) + (raw:identifier-binding id (sub1 (syntax-local-phase-level)))) + +(define (identifier-label-binding id) + (check 'identifier-label-binding identifier? id) + (raw:identifier-binding id #f)) + +(define (identifier-binding-symbol id [phase (syntax-local-phase-level)]) + (check 'identifier-binding-symbol identifier? id) + (unless (phase? phase) + (raise-argument-error 'identifier-binding-symbol phase?-string phase)) + (raw:identifier-binding-symbol id phase)) + +(define (identifier-prune-lexical-context id [syms null]) + (check 'identifier-prune-lexical-context identifier? id) + (unless (and (list? syms) + (andmap symbol? syms)) + (raise-argument-error 'identifier-prune-lexical-context "(listof symbol?)" syms)) + ;; It's a no-op in the Racket v6.5 expander + id) + +(define (syntax-debug-info s [phase (syntax-local-phase-level)] [all-bindings? #f]) + (check 'syntax-debug-info syntax? s) + (unless (phase? phase) + (raise-argument-error 'syntax-debug-info phase?-string phase)) + (raw:syntax-debug-info s phase all-bindings?)) + +(define (syntax-shift-phase-level s phase) + (check 'syntax-shift-phase-level syntax? s) + (unless (phase? phase) + (raise-argument-error 'syntax-shift-phase-level phase?-string phase)) + (raw:syntax-shift-phase-level s phase)) + +(define (syntax-track-origin new-stx old-stx id) + (check 'syntax-track-origin syntax? new-stx) + (check 'syntax-track-origin syntax? old-stx) + (check 'syntax-track-origin identifier? id) + (define s (raw:syntax-track-origin new-stx old-stx id)) + (define ctx (get-current-expand-context #:fail-ok? #t)) + (when ctx (log-expand ctx 'track-origin new-stx s)) + s) diff --git a/racket/src/expander/syntax/binding-table.rkt b/racket/src/expander/syntax/binding-table.rkt new file mode 100644 index 0000000000..681440d754 --- /dev/null +++ b/racket/src/expander/syntax/binding-table.rkt @@ -0,0 +1,290 @@ +#lang racket/base +(require (for-syntax racket/base) + "../common/set.rkt" + "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "syntax.rkt") + +;; A binding table within a scope maps symbol plus scope set +;; combinations (where the scope binding the binding table is always +;; included in the set). +;; +;; A binding table is one of +;; +;; - hash of sym -> scope-set -> binding +;; +;; - (table-with-bulk-bindings hash[as above] list-of-bulk-binding-at) +;; +;; In the latter case, the symbol-keyed hash table overrides bindings +;; supplied (for the same scope sets) in the bulk bindings. + +(provide empty-binding-table + binding-table-add + binding-table-add-bulk + binding-table-empty? + + in-binding-table + + binding-table-symbols + + prop:bulk-binding + (struct-out bulk-binding-class) + + binding-table-prune-to-reachable + binding-table-register-reachable + + deserialize-table-with-bulk-bindings + deserialize-bulk-binding-at) + +(define empty-binding-table #hasheq()) + +(struct table-with-bulk-bindings (syms + syms/serialize ; copy of `syms`, but maybe with less nominal info + bulk-bindings) + #:property prop:serialize + (lambda (twbb ser-push! state) + (ser-push! 'tag '#:table-with-bulk-bindings) + (ser-push! (table-with-bulk-bindings-syms/serialize twbb)) + (ser-push! (table-with-bulk-bindings-bulk-bindings twbb)))) + +(define (deserialize-table-with-bulk-bindings syms bulk-bindings) + (table-with-bulk-bindings syms syms bulk-bindings)) + +;; ---------------------------------------- + +(struct bulk-binding-at (scopes ; scope set + bulk) ; bulk-binding + #:property prop:serialize + (lambda (bba ser-push! state) + ;; Data that is interpreted by the deserializer: + (ser-push! 'tag '#:bulk-binding-at) + (ser-push! (bulk-binding-at-scopes bba)) + (ser-push! (bulk-binding-at-bulk bba))) + #:property prop:reach-scopes + (lambda (sms reach) + ;; bulk bindings are pruned dependong on whether all scopes + ;; in `scopes` are reachable, and we shouldn't get here + ;; when looking for scopes + (error "shouldn't get here"))) + +(define (deserialize-bulk-binding-at scopes bulk) + (bulk-binding-at scopes bulk)) + +;; Bulk bindings are represented by a property, so that the implementation +;; can be separate and manage serialization: +(define-values (prop:bulk-binding bulk-binding? bulk-binding-ref) + (make-struct-type-property 'bulk-binding)) + +;; Value of `prop:bulk-binding` +(struct bulk-binding-class (get-symbols ; bulk-binding list-of-shift -> sym -> binding-info + create)) ; bul-binding -> binding-info sym -> binding +(define (bulk-binding-symbols b s extra-shifts) + ;; Providing the identifier `s` supports its shifts + ((bulk-binding-class-get-symbols (bulk-binding-ref b)) + b + (append extra-shifts (if s (syntax-mpi-shifts s) null)))) +(define (bulk-binding-create b) + (bulk-binding-class-create (bulk-binding-ref b))) + +;; ---------------------------------------- + +(define (binding-table-empty? bt) + (and (hash? bt) (zero? (hash-count bt)))) + +;; Adding a binding for a single symbol +(define (binding-table-add bt scopes sym binding just-for-nominal?) + (cond + [(hash? bt) + (hash-set bt sym (hash-set (hash-ref bt sym #hash()) scopes binding))] + [else + (define new-syms + (binding-table-add (table-with-bulk-bindings-syms bt) + scopes + sym + binding + just-for-nominal?)) + ;; Keep `syms/serialize` in sync with `syms`, except for bindings + ;; that are just to extend the set of nominal imports. We keep those + ;; separate --- and don't serialize them --- because they interfere + ;; with bulk representations of binding and they're used only to + ;; commuincate to `provide`. + (define new-syms/serialize + (cond + [just-for-nominal? (table-with-bulk-bindings-syms/serialize bt)] + [(eq? (table-with-bulk-bindings-syms bt) + (table-with-bulk-bindings-syms/serialize bt)) + new-syms] + [else (binding-table-add (table-with-bulk-bindings-syms/serialize bt) + scopes + sym + binding + #f)])) + (struct-copy table-with-bulk-bindings bt + [syms new-syms] + [syms/serialize new-syms/serialize])])) + +;; Adding a binding for a computed-on-demand set of symbols +(define (binding-table-add-bulk bt scopes bulk) + (cond + [(table-with-bulk-bindings? bt) + (define new-syms (remove-matching-bindings (table-with-bulk-bindings-syms bt) + scopes + bulk)) + (define new-syms/serialize (if (eq? (table-with-bulk-bindings-syms bt) + (table-with-bulk-bindings-syms/serialize bt)) + new-syms + (remove-matching-bindings (table-with-bulk-bindings-syms/serialize bt) + scopes + bulk))) + (table-with-bulk-bindings new-syms + new-syms/serialize + (cons (bulk-binding-at scopes bulk) + (table-with-bulk-bindings-bulk-bindings bt)))] + [else + (binding-table-add-bulk (table-with-bulk-bindings bt bt null) scopes bulk)])) + +;; The bindings of `bulk` at `scopes` should shadow any existing +;; mappings in `sym-bindings` +(define (remove-matching-bindings syms scopes bulk) + (define bulk-symbols (bulk-binding-symbols bulk #f null)) + (cond + [((hash-count syms) . < . (hash-count bulk-symbols)) + ;; Faster to consider each sym in `sym-binding` + (for/fold ([syms syms]) ([(sym sym-bindings) (in-immutable-hash syms)]) + (if (hash-ref bulk-symbols sym #f) + (remove-matching-binding syms sym sym-bindings scopes) + syms))] + [else + ;; Faster to consider each sym in `bulk-symbols` + (for/fold ([syms syms]) ([sym (in-immutable-hash-keys bulk-symbols)]) + (define sym-bindings (hash-ref syms sym #f)) + (if sym-bindings + (remove-matching-binding syms sym sym-bindings scopes) + syms))])) + +;; Update an individual symbol's bindings to remove a mapping +;; for a given set of scopes +(define (remove-matching-binding syms sym sym-bindings scopes) + (hash-set syms sym (hash-remove sym-bindings scopes))) + +;; ---------------------------------------- + +;; Iterate through all scope+binding combinations for a given symbol; +;; the syntax object and extra shifts expressions may be used for +;; loading bulk bindings. +(define-sequence-syntax in-binding-table + (lambda () #'do-not-use-in-binding-as-an-expression) + (lambda (stx) + (syntax-case stx () + [[(scopes-id binding-id) (_ sym table-expr s-expr extra-shifts-expr)] + (identifier? #'sym) + #'[(scopes-id binding-id) + (:do-in + ([(ht bulk-bindings) + (let ([table table-expr]) + (if (hash? table) + (values (hash-ref table sym #hash()) null) + (values (hash-ref (table-with-bulk-bindings-syms table) sym #hash()) + (table-with-bulk-bindings-bulk-bindings table))))] + [(s) s-expr] + [(extra-shifts) extra-shifts-expr]) + #t + ;; The current index is either a number index for a hash table + ;; (extracted from the symbol-keyed hash table) or it is a pair + ;; for walking down the list of bulk bindings + ([i (or (hash-iterate-first ht) + bulk-bindings)]) + ;; We're done when we've moved on to the bulk-binding part + ;; and none are left: + (not (null? i)) + ;; At each step, extract the current scope set and binding; + ;; either can be #f, in which case the consumer of the + ;; sequence should move on the the next result + ([(scopes-id) (cond + [(pair? i) (bulk-binding-at-scopes (car i))] + [else (hash-iterate-key ht i)])] + [(binding-id) (cond + [(pair? i) + (define bulk (bulk-binding-at-bulk (car i))) + (define b-info (hash-ref (bulk-binding-symbols bulk s extra-shifts) sym #f)) + (and b-info + ((bulk-binding-create bulk) bulk b-info sym))] + [else (hash-iterate-value ht i)])]) + #t + #t + ;; Next value for the index `i`: + [(cond + [(pair? i) (cdr i)] + [else (or (hash-iterate-next ht i) + bulk-bindings)])])]]))) + +;; ---------------------------------------- + +;; Return a set of symbols that have bindings for a given scope set +(define (binding-table-symbols table scs s extra-shifts) + (define-values (ht bulk-bindings) + (if (hash? table) + (values table null) + (values (table-with-bulk-bindings-syms table) + (table-with-bulk-bindings-bulk-bindings table)))) + (set-union + (for/seteq ([(sym at-sym) (in-hash ht)] + #:when (for/or ([an-scs (in-hash-keys at-sym)]) + (subset? an-scs scs))) + sym) + (for*/seteq ([bba (in-list bulk-bindings)] + #:when (subset? (bulk-binding-at-scopes bba) scs) + [sym (in-hash-keys + (bulk-binding-symbols (bulk-binding-at-bulk bba) s extra-shifts))]) + sym))) + +;; ---------------------------------------- +;; Pruning functions are called by scope serialization + +(define (binding-table-prune-to-reachable bt state) + (or (hash-ref (serialize-state-bindings-intern state) bt #f) + (let ([reachable-scopes (serialize-state-reachable-scopes state)]) + (define new-syms + (for*/hasheq ([(sym bindings-for-sym) (in-immutable-hash + (if (hash? bt) + bt + (table-with-bulk-bindings-syms/serialize bt)))] + [new-bindings-for-sym + (in-value + (for/hash ([(scopes binding) (in-immutable-hash bindings-for-sym)] + #:when (subset? scopes reachable-scopes)) + (values (intern-scopes scopes state) binding)))] + #:when (positive? (hash-count new-bindings-for-sym))) + (values sym new-bindings-for-sym))) + (define new-bulk-bindings + (if (hash? bt) + null + (for/list ([bba (in-list (table-with-bulk-bindings-bulk-bindings bt))] + #:when (subset? (bulk-binding-at-scopes bba) reachable-scopes)) + (struct-copy bulk-binding-at bba + [scopes (intern-scopes (bulk-binding-at-scopes bba) state)])))) + (define new-bt + (if (pair? new-bulk-bindings) + (table-with-bulk-bindings new-syms new-syms new-bulk-bindings) + new-syms)) + (hash-set! (serialize-state-bulk-bindings-intern state) bt new-bt) + new-bt))) + +(define (binding-table-register-reachable bt reachable-scopes reach register-trigger) + (for* ([(sym bindings-for-sym) (in-immutable-hash (if (hash? bt) + bt + (table-with-bulk-bindings-syms/serialize bt)))] + [(scopes binding) (in-immutable-hash bindings-for-sym)]) + (scopes-register-reachable scopes binding reachable-scopes reach register-trigger))) + +(define (scopes-register-reachable scopes binding reachable-scopes reach register-trigger) + (define v (and (binding-reach-scopes? binding) + ((binding-reach-scopes-ref binding) binding))) + (when v + (cond + [(subset? scopes reachable-scopes) + (reach v)] + [else + (for ([sc (in-set scopes)] + #:unless (set-member? reachable-scopes sc)) + (register-trigger sc v))]))) diff --git a/racket/src/expander/syntax/binding.rkt b/racket/src/expander/syntax/binding.rkt new file mode 100644 index 0000000000..0f46bc882c --- /dev/null +++ b/racket/src/expander/syntax/binding.rkt @@ -0,0 +1,311 @@ +#lang racket/base +(require "../common/set.rkt" + "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "../common/memo.rkt" + "syntax.rkt" + "property.rkt" + "scope.rkt" + "../common/phase.rkt" + "full-binding.rkt" + "module-binding.rkt" + "local-binding.rkt" + "datum-map.rkt" + "../expand/rename-trans.rkt" + "../common/module-path.rkt") + +(provide + binding-frame-id + binding-free=id + (all-from-out "module-binding.rkt") + (all-from-out "local-binding.rkt") + + free-identifier=? + same-binding? + same-binding-nominals? + identifier-binding + identifier-binding-symbol + + maybe-install-free=id! + binding-set-free=id + + resolve+shift + syntax-module-path-index-shift + + apply-syntax-shifts + syntax-apply-shifts + binding-module-path-index-shift + syntax-transfer-shifts + + syntax-source-module + identifier-prune-to-source-module) + +;; ---------------------------------------- + +(define (free-identifier=? a b a-phase b-phase) + (define ab (resolve+shift a a-phase #:unbound-sym? #t)) + (define bb (resolve+shift b b-phase #:unbound-sym? #t)) + (cond + [(or (symbol? ab) (symbol? bb)) + (eq? ab bb)] + [else + (same-binding? ab bb)])) + +(define (same-binding? ab bb) + (cond + [(module-binding? ab) + (and (module-binding? bb) + (eq? (module-binding-sym ab) + (module-binding-sym bb)) + (eqv? (module-binding-phase ab) + (module-binding-phase bb)) + (eq? (module-path-index-resolve (module-binding-module ab)) + (module-path-index-resolve (module-binding-module bb))))] + [(local-binding? ab) + (and (local-binding? bb) + (eq? (local-binding-key ab) + (local-binding-key bb)))] + [else (error "bad binding" ab)])) + +;; Check whether two bindings that are `same-binding?` also provide +;; the same nominal info (i.e., claim to be required through the same +;; immediate path): +(define (same-binding-nominals? ab bb) + (and (eq? (module-path-index-resolve (module-binding-nominal-module ab)) + (module-path-index-resolve (module-binding-nominal-module bb))) + (eqv? (module-binding-nominal-require-phase ab) + (module-binding-nominal-require-phase bb)) + (eqv? (module-binding-nominal-sym ab) + (module-binding-nominal-sym bb)))) + +(define (identifier-binding-symbol id phase) + (define b (resolve+shift id phase #:unbound-sym? #t)) + (cond + [(symbol? b) b] + [(module-binding? b) + (module-binding-sym b)] + [(local-binding? b) + (local-binding-key b)] + [else (syntax-e id)])) + +(define (identifier-binding id phase [top-level-symbol? #f]) + (define b (resolve+shift id phase)) + (cond + [(module-binding? b) + (if (top-level-module-path-index? (module-binding-module b)) + (if top-level-symbol? + (list (module-binding-nominal-sym b)) + #f) + (list (module-binding-module b) + (module-binding-sym b) + (module-binding-nominal-module b) + (module-binding-nominal-sym b) + (module-binding-phase b) + (module-binding-nominal-require-phase b) + (module-binding-nominal-phase b)))] + [(local-binding? b) + 'lexical] + [else #f])) + +;; ---------------------------------------- + +(define (maybe-install-free=id! val id phase) + (when (rename-transformer? val) + (define free=id (rename-transformer-target val)) + (unless (syntax-property free=id 'not-free-identifier=?) + (define b (resolve+shift id phase #:exactly? #t #:immediate? #t)) + (add-binding-in-scopes! (syntax-scope-set id phase) (syntax-e id) (binding-set-free=id b free=id))))) + +;; Helper to add a `free-identifier=?` equivance to a binding +(define (binding-set-free=id b free=id) + (cond + [(module-binding? b) (module-binding-update b #:free=id free=id)] + [(local-binding? b) (local-binding-update b #:free=id free=id)] + [else (error "bad binding for free=id:" b)])) + +; ---------------------------------------- + +;; To tag shifts that should not count as a module source +;; in the sense of `syntax-source-module`: +(struct non-source-shift (from to) #:prefab) +(define (shift-from s) + (if (pair? s) (car s) (non-source-shift-from s))) +(define (shift-to s) + (if (pair? s) (cdr s) (non-source-shift-to s))) + +;; Adjust `s` (recursively) so that if `resolve+shift` would +;; report `form-mpi`, the same operation on the result will +;; report `to-mpi`. A non-#f `inspector` is provided when shifting +;; syntax literals in a module to match the module's declaration-time +;; inspector. +(define (syntax-module-path-index-shift s from-mpi to-mpi [inspector #f] + #:non-source? [non-source? #f]) + (cond + [(eq? from-mpi to-mpi) + (if inspector + (syntax-set-inspector s inspector) + s)] + [else + (define shift (if non-source? + (non-source-shift from-mpi to-mpi) + (cons from-mpi to-mpi))) + (struct-copy syntax s + [mpi-shifts (cons shift (syntax-mpi-shifts s))] + [inspector (or (syntax-inspector s) + inspector)] + [scope-propagations+tamper (if (datum-has-elements? (syntax-content s)) + (propagation-mpi-shift (syntax-scope-propagations+tamper s) + (lambda (s) (cons shift s)) + inspector + (syntax-scopes s) + (syntax-shifted-multi-scopes s) + (syntax-mpi-shifts s)) + (syntax-scope-propagations+tamper s))])])) + +;; Use `resolve` instead of `resolve+shift` when the module of a +;; module binding is relevant or when `free-identifier=?` equivalences +;; (as installed by a binding to a rename transfomer) are relevant; +;; module path index shifts attached to `s` are taken into account in +;; the result +(define (resolve+shift s phase + #:ambiguous-value [ambiguous-value #f] + #:exactly? [exactly? #f] + #:immediate? [immediate? exactly?] + #:unbound-sym? [unbound-sym? #f] + ;; For resolving bulk bindings in `free-identifier=?` chains: + #:extra-shifts [extra-shifts null]) + (define immediate-b (resolve s phase + #:ambiguous-value ambiguous-value + #:exactly? exactly? + #:extra-shifts extra-shifts)) + (define b (if (and immediate-b + (not immediate?) + (binding-free=id immediate-b)) + (resolve+shift (binding-free=id immediate-b) phase + #:extra-shifts (append extra-shifts (syntax-mpi-shifts s)) + #:ambiguous-value ambiguous-value + #:exactly? exactly? + #:unbound-sym? unbound-sym?) + immediate-b)) + (cond + [(module-binding? b) + (define mpi-shifts (syntax-mpi-shifts s)) + (cond + [(null? mpi-shifts) + b] + [else + (define mod (module-binding-module b)) + (define shifted-mod (apply-syntax-shifts mod mpi-shifts)) + (define nominal-mod (module-binding-nominal-module b)) + (define shifted-nominal-mod (if (eq? mod nominal-mod) + shifted-mod + (apply-syntax-shifts nominal-mod mpi-shifts))) + (if (and (eq? mod shifted-mod) + (eq? nominal-mod shifted-nominal-mod) + (not (binding-free=id b)) + (null? (module-binding-extra-nominal-bindings b))) + b + (module-binding-update b + #:module shifted-mod + #:nominal-module shifted-nominal-mod + #:free=id (and (binding-free=id b) + (syntax-transfer-shifts (binding-free=id b) s)) + #:extra-nominal-bindings + (for/list ([b (in-list (module-binding-extra-nominal-bindings b))]) + (apply-syntax-shifts-to-binding b mpi-shifts))))])] + [(and (not b) unbound-sym?) + (syntax-e s)] + [else b])) + +;; Apply accumulated module path index shifts +(define (apply-syntax-shifts mpi shifts) + (cond + [(null? shifts) mpi] + [else + (define shifted-mpi (apply-syntax-shifts mpi (cdr shifts))) + (define shift (car shifts)) + (module-path-index-shift shifted-mpi (shift-from shift) (shift-to shift))])) + +;; Apply accumulated module path index shifts to a module binding +(define (apply-syntax-shifts-to-binding b shifts) + (cond + [(null? shifts) b] + [else + (define shifted-b (apply-syntax-shifts-to-binding b (cdr shifts))) + (define shift (car shifts)) + (binding-module-path-index-shift shifted-b (shift-from shift) (shift-to shift))])) + + +;; Apply a syntax object's shifts to a given module path index +(define (syntax-apply-shifts s mpi) + (apply-syntax-shifts mpi (syntax-mpi-shifts s))) + +;; Apply a single shift to a single binding +(define (binding-module-path-index-shift b from-mpi to-mpi) + (cond + [(module-binding? b) + (module-binding-update b + #:module (module-path-index-shift (module-binding-module b) + from-mpi + to-mpi) + #:nominal-module (module-path-index-shift (module-binding-nominal-module b) + from-mpi + to-mpi) + #:extra-nominal-bindings (for/list ([b (in-list (module-binding-extra-nominal-bindings b))]) + (binding-module-path-index-shift b from-mpi to-mpi)))] + [else b])) + +(define (syntax-transfer-shifts to-s from-s [inspector #f] #:non-source? [non-source? #f]) + (define shifts (syntax-mpi-shifts from-s)) + (cond + [(and (null? shifts) inspector) + (syntax-set-inspector to-s inspector)] + [else + (for/fold ([s to-s]) ([shift (in-list (reverse shifts))] + [i (in-naturals)]) + (syntax-module-path-index-shift s (shift-from shift) (shift-to shift) (and (zero? i) inspector) + #:non-source? non-source?))])) + +(define (syntax-set-inspector s insp) + ;; This inspector merging is also implemented via propagations in "syntax.rkt" + (struct-copy syntax s + [inspector (or (syntax-inspector s) + insp)] + [scope-propagations+tamper (if (datum-has-elements? (syntax-content s)) + (propagation-mpi-shift (syntax-scope-propagations+tamper s) + #f + insp + (syntax-scopes s) + (syntax-shifted-multi-scopes s) + (syntax-mpi-shifts s)) + (syntax-scope-propagations+tamper s))])) + +;; ---------------------------------------- + +;; We can imagine that a syntax object's source module is determined +;; by adding a module's path index as it is expanded to everything +;; that starts out in the module. It turns out that we're already +;; adding a module path index like that in the form of a shift. So, we +;; infer a source module from the module-path-index shifts that are +;; attached to the syntax object by starting with the initial shift +;; and working our way back. +;; +;; Shifts added for a `module->namespace` context shouldn't count +;; toward a module source, so those are added as `non-source-shift` +;; records, and we skip them here. +(define (syntax-source-module s [source? #f]) + (unless (syntax? s) + (raise-argument-error 'syntax-track-origin "syntax?" s)) + (for/or ([shift (in-list (reverse (syntax-mpi-shifts s)))] + #:unless (non-source-shift? shift)) + (define from-mpi (car shift)) + (define-values (path base) (module-path-index-split from-mpi)) + (and (not path) + (module-path-index-resolved from-mpi) + (apply-syntax-shifts from-mpi (syntax-mpi-shifts s))))) + +(define (identifier-prune-to-source-module id) + (unless (identifier? id) + (raise-argument-error 'identifier-prune-to-source-module "identifier?" id)) + (struct-copy syntax (datum->syntax #f (syntax-e id) id id) + [mpi-shifts (syntax-mpi-shifts id)])) diff --git a/racket/src/expander/syntax/bulk-binding.rkt b/racket/src/expander/syntax/bulk-binding.rkt new file mode 100644 index 0000000000..7540a7d964 --- /dev/null +++ b/racket/src/expander/syntax/bulk-binding.rkt @@ -0,0 +1,177 @@ +#lang racket/base +(require "../compile/serialize-property.rkt" + "syntax.rkt" + "binding-table.rkt" ; defines `prop:bulk-binding` + "binding.rkt" + "../common/module-path.rkt" + (only-in "../compile/reserved-symbol.rkt" bulk-binding-registry-id) + "../namespace/provided.rkt") + +(provide provide-binding-to-require-binding + + make-bulk-binding-registry + register-bulk-provide! + registered-bulk-provide? + + bulk-binding + + bulk-provides-add-prefix-remove-exceptions + deserialize-bulk-binding) + +;; When a require is something like `(require racket/base)`, then +;; we'd like to import the many bindings from `racket/base` in one +;; fast step, and we'd like to share the information in syntax objects +;; from many different modules that all import `racket/base`. A +;; "bulk binding" implements that fast binding and sharing. + +;; The difficult part is restoring sharing when a syntax object is +;; unmarshaled, and also leaving the binding information in the +;; providing moduling instead of the requiring module. Keeping the +;; information with the providing module should be ok, because +;; resolving a chain of module imports should ensure that the relevant +;; module is loaded before a syntax object with a bulk binding is used. +;; Still, we have to communicate information from the loading process +;; down the binding-resolving process. + +;; A bulk-binding registry manages that connection. The registry is +;; similar to the module registry, in that it maps a resolved module +;; name to provide information. But it has only the provide +;; information, and not the rest of the module's implementation. + +;; ---------------------------------------- + +;; Helper for both regular imports and bulk bindings, which converts a +;; providing module's view of a binding to a requiring mdoule's view. +(define (provide-binding-to-require-binding binding/p ; the provided binding + sym ; the symbolic name of the provide + #:self self ; the providing module's view of itself + #:mpi mpi ; the requiring module's view + #:provide-phase-level provide-phase-level + #:phase-shift phase-shift) + (define binding (provided-as-binding binding/p)) + (define from-mod (module-binding-module binding)) + (module-binding-update binding + #:module (module-path-index-shift from-mod self mpi) + #:nominal-module mpi + #:nominal-phase provide-phase-level + #:nominal-sym sym + #:nominal-require-phase phase-shift + #:frame-id #f + #:extra-inspector (and (not (provided-as-protected? binding/p)) ; see [*] below + (module-binding-extra-inspector binding)) + #:extra-nominal-bindings null)) + +;; [*] If a binding has an extra inspector, it's because the binding +;; was provided as a rename transformer with a module (and the rename +;; transformer doesn't have 'not-free-identifier=?). But if we're +;; protecting the rename-transformer output, then the inspector on the +;; providing module should guard the use of the inspector attached to +;; the binding. For now, we approximate(!) that conditional use by +;; just dropping the extra inspector, which means that the original +;; binding (bounding by te rename transformer) is accessible only if +;; the end user has access to the original binding directly. + +;; ---------------------------------------- + +(struct bulk-binding ([provides #:mutable] ; mutable so table can be found lazily on unmarshal + prefix ; #f or a prefix for the import + excepts ; hash table of excluded symbols (before adding prefix) + [self #:mutable] ; the providing module's self + mpi ; this binding's view of the providing module + provide-phase-level ; providing module's import phase + phase-shift ; providing module's instantiation phase + bulk-binding-registry) ; a registry for finding bulk bindings lazily + #:property prop:bulk-binding + (bulk-binding-class + (lambda (b mpi-shifts) + (or (bulk-binding-provides b) + ;; Here's where we find provided bindings for unmarshaled syntax + (let ([mod-name (module-path-index-resolve + (apply-syntax-shifts + (bulk-binding-mpi b) + mpi-shifts))]) + (unless (bulk-binding-bulk-binding-registry b) + (error "namespace mismatch: no bulk-binding registry available:" + mod-name)) + (define table (bulk-binding-registry-table (bulk-binding-bulk-binding-registry b))) + (define bulk-provide (hash-ref table mod-name #f)) + (unless bulk-provide + (error "namespace mismatch: bulk bindings not found in registry for module:" + mod-name)) + ;; Reset `provide` and `self` to the discovered information + (set-bulk-binding-self! b (bulk-provide-self bulk-provide)) + (define provides (hash-ref (bulk-provide-provides bulk-provide) + (bulk-binding-provide-phase-level b))) + ;; Remove exceptions and add prefix + (define excepts (bulk-binding-excepts b)) + (define prefix (bulk-binding-prefix b)) + (define adjusted-provides + (cond + [(or prefix (positive? (hash-count excepts))) + (bulk-provides-add-prefix-remove-exceptions provides prefix excepts)] + [else provides])) + ;; Record the adjusted `provides` table for quick future access: + (set-bulk-binding-provides! b adjusted-provides) + adjusted-provides))) + (lambda (b binding sym) + ;; Convert the provided binding to a required binding on + ;; demand during binding resolution + (provide-binding-to-require-binding + binding (if (bulk-binding-prefix b) + (string->symbol + (substring (symbol->string sym) + (string-length (symbol->string (bulk-binding-prefix b))))) + sym) + #:self (bulk-binding-self b) + #:mpi (bulk-binding-mpi b) + #:provide-phase-level (bulk-binding-provide-phase-level b) + #:phase-shift (bulk-binding-phase-shift b)))) + #:property prop:serialize + ;; Serialization drops the `provides` table and the providing module's `self` + (lambda (b ser-push! reachable-scopes) + (ser-push! 'tag '#:bulk-binding) + (ser-push! (bulk-binding-prefix b)) + (ser-push! (bulk-binding-excepts b)) + (ser-push! (bulk-binding-mpi b)) + (ser-push! (bulk-binding-provide-phase-level b)) + (ser-push! (bulk-binding-phase-shift b)) + (ser-push! 'tag '#:bulk-binding-registry))) + +(define (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry) + (bulk-binding #f prefix excepts #f mpi provide-phase-level phase-shift bulk-binding-registry)) + +(define (bulk-provides-add-prefix-remove-exceptions provides prefix excepts) + (for/hash ([(sym val) (in-hash provides)] + #:unless (hash-ref excepts sym #f)) + (values (if prefix + (string->symbol (format "~a~a" prefix sym)) + sym) + val))) + +;; ---------------------------------------- + +;; A blk binding registry has just the provde part of a module, for +;; use in resolving bulk bindings on unmarshal +(struct bulk-provide (self provides)) + +;; A bulk-binding-registry object is attached to every syntax object +;; in an instantiated module, so that binding resolution on the +;; module's syntax literals can find tables of provided variables +;; based on module names +(struct bulk-binding-registry (table)) ; resolve-module-name -> bulk-provide + +(define (make-bulk-binding-registry) + (bulk-binding-registry (make-hasheq))) + +;; Called when a module is instantiated to register its provides: +(define (register-bulk-provide! bulk-binding-registry mod-name self provides) + (hash-set! (bulk-binding-registry-table bulk-binding-registry) + mod-name + (bulk-provide self provides))) + +;; Called when a module is imported to make sure that it's in the +;; registry (as opposed to a temporary module instance during +;; expansion): +(define (registered-bulk-provide? bulk-binding-registry mod-name) + (and (hash-ref (bulk-binding-registry-table bulk-binding-registry) mod-name #f) + #t)) diff --git a/racket/src/expander/syntax/cache.rkt b/racket/src/expander/syntax/cache.rkt new file mode 100644 index 0000000000..290a0ffa06 --- /dev/null +++ b/racket/src/expander/syntax/cache.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(require "../common/set.rkt") + +(provide clear-resolve-cache! + resolve-cache-get + resolve-cache-set! + + cache-or-reuse-set + cache-or-reuse-hash) + +(define cache (box (make-weak-box #f))) + +(define clear-resolve-cache! + (case-lambda + [(sym) + (define c (weak-box-value (unbox* cache))) + (when c + (hash-remove! c sym))] + [() + (define c (weak-box-value (unbox* cache))) + (when c + (hash-clear! c))])) + +(struct entry (scs smss phase binding) + #:authentic) + +(define (resolve-cache-get sym phase scs smss) + (define c (weak-box-value (unbox* cache))) + (and c + (let ([v (hash-ref c sym #f)]) + (and v + (eqv? phase (entry-phase v)) + (set=? scs (entry-scs v)) + (set=? smss (entry-smss v)) + (entry-binding v))))) + +(define (resolve-cache-set! sym phase scs smss b) + (define wb (unbox* cache)) + (define c (weak-box-value wb)) + (cond + [(not c) + (box-cas! cache wb (make-weak-box (make-hasheq))) + (resolve-cache-set! sym phase scs smss b)] + [else + (hash-set! c sym (entry scs smss phase b))])) + +;; ---------------------------------------- + +;; For scope sets and propagation hashes, we don't intern, but we +;; approximate interning by checking against a small set of recently +;; allocated scope sets or propagation hashes. That's good enough to +;; find sharing for a deeply nested sequence of `let`s from a +;; many-argument `or`, for example, where the interleaving of original +;; an macro-introduced syntax prevents the usual +;; child-is-same-as-parent sharing detecting from working well enough. + +(define NUM-CACHE-SLOTS 8) + +(define cached-sets (make-weak-box (make-vector NUM-CACHE-SLOTS #f))) +(define cached-sets-pos 0) + +(define cached-hashes (make-weak-box (make-vector NUM-CACHE-SLOTS #f))) +(define cached-hashes-pos 0) + +(define-syntax-rule (define-cache-or-reuse cache-or-reuse cached cached-pos same?) + (define (cache-or-reuse s) + (define vec (or (weak-box-value cached) + (let ([vec (make-vector NUM-CACHE-SLOTS #f)]) + (set! cached (make-weak-box vec)) + vec))) + (or (for/or ([s2 (in-vector vec)]) + (and s2 + (same? s s2) + s2)) + (begin + (vector-set! vec cached-pos s) + (set! cached-pos (modulo (add1 cached-pos) NUM-CACHE-SLOTS)) + s)))) + +(define-cache-or-reuse cache-or-reuse-set cached-sets cached-sets-pos set=?) +(define-cache-or-reuse cache-or-reuse-hash cached-hashes cached-hashes-pos equal?) diff --git a/racket/src/expander/syntax/datum-map.rkt b/racket/src/expander/syntax/datum-map.rkt new file mode 100644 index 0000000000..0ef990ec67 --- /dev/null +++ b/racket/src/expander/syntax/datum-map.rkt @@ -0,0 +1,90 @@ +#lang racket/base +(require "../common/prefab.rkt" + "../common/inline.rkt") + +(provide datum-map + datum-has-elements?) + +;; `(datum-map v f)` walks over `v`, traversing objects that +;; `datum->syntax` traverses to convert context to syntax objects. +;; +;; `(f tail? d)` is called to each datum `d`, where `tail?` +;; indicates that the value is a pair/null in a `cdr` --- so that it +;; doesn't need to be wrapped for `datum->syntax`, for example +;; +;; If a `seen` argument is provided, then it should be an `eq?`-based +;; hash table, and cycle checking is enabled; when a cycle is +;; discovered, the procedure attached to 'cycle-fail in the initial +;; table is called + +;; The inline version uses `f` only in an application position to +;; help avoid allocating a closure. It also covers only the most common +;; cases, defering to the general (not inlined) function for other cases. +(define-inline (datum-map s f [seen #f]) + (let loop ([tail? #f] [s s] [prev-depth 0]) + (define depth (add1 prev-depth)) ; avoid cycle-checking overhead for shallow cases + (cond + [(and seen (depth . > . 32)) + (datum-map-slow tail? s (lambda (tail? s) (f tail? s)) seen)] + [(null? s) (f tail? s)] + [(pair? s) + (f tail? (cons (loop #f (car s) depth) + (loop #t (cdr s) depth)))] + [(or (symbol? s) (boolean? s) (number? s)) + (f #f s)] + [(or (vector? s) (box? s) (prefab-struct-key s) (hash? s)) + (datum-map-slow tail? s (lambda (tail? s) (f tail? s)) seen)] + [else (f #f s)]))) + +(define (datum-map-slow tail? s f seen) + (let loop ([tail? tail?] [s s] [prev-seen seen]) + (define seen + (cond + [(and prev-seen (datum-has-elements? s)) + (cond + [(hash-ref prev-seen s #f) + ((hash-ref prev-seen 'cycle-fail) s)] + [else (hash-set prev-seen s #t)])] + [else prev-seen])) + (cond + [(null? s) (f tail? s)] + [(pair? s) + (f tail? (cons (loop #f (car s) seen) + (loop #t (cdr s) seen)))] + [(or (symbol? s) (boolean? s) (number? s)) + (f #f s)] + [(vector? s) + (f #f (vector->immutable-vector + (for/vector #:length (vector-length s) ([e (in-vector s)]) + (loop #f e seen))))] + [(box? s) + (f #f (box-immutable (loop #f (unbox s) seen)))] + [(immutable-prefab-struct-key s) + => (lambda (key) + (f #f + (apply make-prefab-struct + key + (for/list ([e (in-vector (struct->vector s) 1)]) + (loop #f e seen)))))] + [(and (hash? s) (immutable? s)) + (cond + [(hash-eq? s) + (f #f + (for/hasheq ([(k v) (in-hash s)]) + (values k (loop #f v seen))))] + [(hash-eqv? s) + (f #f + (for/hasheqv ([(k v) (in-hash s)]) + (values k (loop #f v seen))))] + [else + (f #f + (for/hash ([(k v) (in-hash s)]) + (values k (loop #f v seen))))])] + [else (f #f s)]))) + +(define (datum-has-elements? d) + (or (pair? d) + (vector? d) + (box? d) + (immutable-prefab-struct-key d) + (and (hash? d) (immutable? d) (positive? (hash-count d))))) diff --git a/racket/src/expander/syntax/debug.rkt b/racket/src/expander/syntax/debug.rkt new file mode 100644 index 0000000000..a531eccdfc --- /dev/null +++ b/racket/src/expander/syntax/debug.rkt @@ -0,0 +1,70 @@ +#lang racket/base +(require "../common/set.rkt" + "syntax.rkt" + "scope.rkt" + "fallback.rkt" + "binding-table.rkt" + (submod "scope.rkt" for-debug) + "binding.rkt" + "module-binding.rkt") + +(provide syntax-debug-info) + +(define (syntax-debug-info s phase all-bindings?) + (define hts + (for/list ([smss (in-list (fallback->list (syntax-shifted-multi-scopes s)))]) + (define init-ht (if (identifier? s) + (hasheq 'name (syntax-e s)) + #hasheq())) + (define s-scs (scope-set-at-fallback s smss phase)) + (define context (scope-set->context s-scs)) + (define context-ht (hash-set init-ht 'context context)) + (define sym (syntax-e s)) + (define bindings + (cond + [(identifier? s) + (define-values (bindings covered-scopess) + (for*/fold ([bindings null] [covered-scope-sets (set)]) + ([sc (in-set s-scs)] + [(scs b) (in-binding-table sym (scope-binding-table sc) s null)] + #:when (and scs b + (or all-bindings? + (subset? scs s-scs)) + ;; Skip overidden: + (not (set-member? covered-scope-sets scs)))) + (values + (cons + (hash 'name (syntax-e s) + 'context (scope-set->context scs) + 'match? (subset? scs s-scs) + (if (local-binding? b) + 'local + 'module) + (if (local-binding? b) + (local-binding-key b) + (vector (module-binding-sym b) + (module-binding-module b) + (module-binding-phase b)))) + bindings) + (set-add covered-scope-sets scs)))) + bindings] + [else null])) + (if (null? bindings) + context-ht + (hash-set context-ht 'bindings bindings)))) + (define ht (car hts)) + (if (null? (cdr hts)) + ht + (hash-set ht 'fallbacks (cdr hts)))) + +(define (scope-set->context scs) + (sort + (for/list ([sc (in-set scs)]) + (if (representative-scope? sc) + (vector (scope-id sc) + (scope-kind sc) + (multi-scope-name (representative-scope-owner sc))) + (vector (scope-id sc) + (scope-kind sc)))) + < + #:key (lambda (v) (vector-ref v 0)))) diff --git a/racket/src/expander/syntax/error.rkt b/racket/src/expander/syntax/error.rkt new file mode 100644 index 0000000000..6e7f69c90a --- /dev/null +++ b/racket/src/expander/syntax/error.rkt @@ -0,0 +1,107 @@ +#lang racket/base +(require "../common/contract.rkt" + "syntax.rkt" + "scope.rkt" + "taint.rkt") + +(provide (struct-out exn:fail:syntax) + make-exn:fail:syntax + (struct-out exn:fail:syntax:unbound) + make-exn:fail:syntax:unbound + + raise-syntax-error + raise-unbound-syntax-error) + +(struct exn:fail:syntax exn:fail (exprs) + #:extra-constructor-name make-exn:fail:syntax + #:transparent + #:property prop:exn:srclocs (lambda (e) (filter values (map syntax-srcloc (exn:fail:syntax-exprs e)))) + #:guard (lambda (str cm exprs info) + (unless (and (list? exprs) + (andmap syntax? exprs)) + (raise-argument-error 'exn:fail:syntax "(listof syntax?)" exprs)) + (values str cm exprs))) +(struct exn:fail:syntax:unbound exn:fail:syntax () + #:extra-constructor-name make-exn:fail:syntax:unbound + #:transparent) + +(define (raise-syntax-error given-name message + [expr #f] [sub-expr #f] + [extra-sources null] + [message-suffix ""]) + (do-raise-syntax-error exn:fail:syntax given-name message + expr sub-expr + extra-sources + message-suffix)) + +(define (raise-unbound-syntax-error given-name message + [expr #f] [sub-expr #f] + [extra-sources null] + [message-suffix ""]) + (do-raise-syntax-error exn:fail:syntax:unbound given-name message + expr sub-expr + extra-sources + message-suffix)) + +(define (do-raise-syntax-error exn:fail:syntax given-name message + expr sub-expr + extra-sources + message-suffix) + (unless (or (not given-name) (symbol? given-name)) + (raise-argument-error 'raise-syntax-error "(or/c symbol? #f)" given-name)) + (check 'raise-syntax-error string? message) + (unless (and (list? extra-sources) + (andmap syntax? extra-sources)) + (raise-argument-error 'raise-syntax-error "(listof syntax?)" extra-sources)) + (check 'raise-syntax-error string? message-suffix) + (define name + (format "~a" (or given-name + (extract-form-name expr) + '?))) + (define at-message + (or (and sub-expr + (error-print-source-location) + (format "\n at: ~.s" (syntax->datum (datum->syntax #f sub-expr)))) + "")) + (define in-message + (or (and expr + (error-print-source-location) + (format "\n in: ~.s" (syntax->datum (datum->syntax #f expr)))) + "")) + (define src-loc-str + (or (extract-source-location sub-expr) + (extract-source-location expr) + "")) + (raise (exn:fail:syntax + (string-append src-loc-str + name ": " + message + at-message + in-message + message-suffix) + (current-continuation-marks) + (map syntax-taint + (if (or sub-expr expr) + (cons (datum->syntax #f (or sub-expr expr)) + extra-sources) + extra-sources))))) + +(define (extract-form-name s) + (cond + [(syntax? s) + (define e (syntax-e s)) + (cond + [(symbol? e) e] + [(and (pair? e) + (identifier? (car e))) + (syntax-e (car e))] + [else #f])] + [else #f])) + +(define (extract-source-location s) + (and (syntax? s) + (syntax-srcloc s) + (let ([str (srcloc->string (syntax-srcloc s))]) + (and str + (string-append str ": "))))) + diff --git a/racket/src/expander/syntax/fallback.rkt b/racket/src/expander/syntax/fallback.rkt new file mode 100644 index 0000000000..4bf8dd0db1 --- /dev/null +++ b/racket/src/expander/syntax/fallback.rkt @@ -0,0 +1,64 @@ +#lang racket/base + +(provide fallback? + fallback-first + fallback-rest + fallback-push + fallback-update-first + fallback-map + fallback->list) + +;; When a syntax object is expanded in namespace A and then +;; re-expanded in namespace B, then the scopes of B are added to rhe +;; syntax object, but a failed binding search will fall back to the +;; scope set that doesn't include the additional scope for B. This +;; fallback makes it easier to work across namespaces (including +;; moving from the top level to a module body or vice versa), and it +;; accomodates existing Racket programs. +;; +;; A syntax object contains a fallback search list only if +;; `push-scope` has been used. The fallback chain is in the +;; `shifted-multi-scopes` part of a syntax object (since the relevant +;; namespace scope is always a multi scope). +;; +;; A fallback is created by `push-scope`, which creates a new fallback +;; layer if the given multi-scope is not in the current set of scopes. + +(struct fallback (search-list) + ;; Can appear in serialized: + #:prefab) + +(define (fallback-first smss) + (if (fallback? smss) + (car (fallback-search-list smss)) + smss)) + +(define (fallback-rest smss) + (define l (cdr (fallback-search-list smss))) + (if (null? (cdr l)) + (car l) + (fallback l))) + +(define (fallback-push smss smss/maybe-fallback) + (fallback + (cons smss + (if (fallback? smss/maybe-fallback) + (fallback-search-list smss/maybe-fallback) + (list smss/maybe-fallback))))) + +(define (fallback-update-first smss f) + (if (fallback? smss) + (let ([l (fallback-search-list smss)]) + (fallback (cons (f (car l)) (cdr l)))) + (f smss))) + +(define (fallback-map smss f) + (if (fallback? smss) + (fallback (for/list ([smss (in-list (fallback-search-list smss))]) + (f smss))) + (f smss))) + +(define (fallback->list smss) + (if (fallback? smss) + (fallback-search-list smss) + (list smss))) diff --git a/racket/src/expander/syntax/full-binding.rkt b/racket/src/expander/syntax/full-binding.rkt new file mode 100644 index 0000000000..ca2377cbb5 --- /dev/null +++ b/racket/src/expander/syntax/full-binding.rkt @@ -0,0 +1,23 @@ +#lang racket/base +(require "../compile/serialize-property.rkt") + +(provide (struct-out full-binding) + binding-frame-id + binding-free=id) + +;; A base struct for bindings with a frame identity or +;; `free-identifier=?` equivalence +(struct full-binding (frame-id ; used to trigger use-site scopes + free=id) ; `free-identifier=?` equivalence via a rename-transformer binding + #:authentic + #:property prop:binding-reach-scopes + (lambda (b) + (binding-free=id b))) + +(define (binding-frame-id b) + (and (full-binding? b) + (full-binding-frame-id b))) + +(define (binding-free=id b) + (and (full-binding? b) + (full-binding-free=id b))) diff --git a/racket/src/expander/syntax/local-binding.rkt b/racket/src/expander/syntax/local-binding.rkt new file mode 100644 index 0000000000..585101d236 --- /dev/null +++ b/racket/src/expander/syntax/local-binding.rkt @@ -0,0 +1,57 @@ +#lang racket/base +(require "full-binding.rkt" + "../compile/serialize-property.rkt") + +(provide make-local-binding + local-binding-update + local-binding? + + local-binding-key + + deserialize-full-local-binding) + +(define (local-binding? b) + ;; must not overlap with `module-binding?` + (or (full-local-binding? b) + (symbol? b))) + +;; Represent a local binding with a key, where the value of +;; the key is kept in a separate environment. That indirection +;; ensures that a fuly expanded program doesn't reference +;; compile-time values from local bindings, but it records that +;; the binding was local. The `frame-id` field is used to +;; trigger use-site scopes as needed +(struct full-local-binding full-binding (key) + #:authentic + #:property prop:serialize + (lambda (b ser-push! state) + ;; Data that is interpreted by the deserializer: + (ser-push! 'tag '#:local-binding) + (ser-push! (full-local-binding-key b)) + (ser-push! (full-binding-free=id b)))) + +(define (deserialize-full-local-binding key free=id) + (full-local-binding #f free=id key)) + +(define (make-local-binding key + #:frame-id [frame-id #f] + #:free=id [free=id #f]) + (cond + [(and (not frame-id) + (not free=id)) + key] + [else + (full-local-binding frame-id free=id key)])) + +(define (local-binding-update b + #:key [key (local-binding-key b)] + #:frame-id [frame-id (binding-frame-id b)] + #:free=id [free=id (binding-free=id b)]) + (make-local-binding key + #:frame-id frame-id + #:free=id free=id)) + +(define (local-binding-key b) + (if (full-local-binding? b) + (full-local-binding-key b) + b)) diff --git a/racket/src/expander/syntax/mapped-name.rkt b/racket/src/expander/syntax/mapped-name.rkt new file mode 100644 index 0000000000..1e46efbd24 --- /dev/null +++ b/racket/src/expander/syntax/mapped-name.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require "../common/set.rkt" + "syntax.rkt" + "scope.rkt" + (submod "scope.rkt" for-debug) + "binding-table.rkt") + +(provide syntax-mapped-names) + +(define (syntax-mapped-names s phase) + (define s-scs (syntax-scope-set s phase)) + (for/fold ([syms (seteq)]) ([sc (in-set s-scs)]) + (set-union syms + (binding-table-symbols (scope-binding-table sc) s-scs s null)))) diff --git a/racket/src/expander/syntax/match.rkt b/racket/src/expander/syntax/match.rkt new file mode 100644 index 0000000000..8ffab74218 --- /dev/null +++ b/racket/src/expander/syntax/match.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require "../common/make-match.rkt" + "syntax.rkt" + "scope.rkt" + "error.rkt") + +(provide define-match) + +;; See "../common/make-match.rkt" for information on using +;; `define-match` + +(define-define-match define-match + syntax? syntax-e raise-syntax-error) diff --git a/racket/src/expander/syntax/module-binding.rkt b/racket/src/expander/syntax/module-binding.rkt new file mode 100644 index 0000000000..1af5903993 --- /dev/null +++ b/racket/src/expander/syntax/module-binding.rkt @@ -0,0 +1,190 @@ +#lang racket/base +(require "../common/set.rkt" + "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "full-binding.rkt") + +(provide make-module-binding + module-binding-update + module-binding? + + module-binding-module + module-binding-phase + module-binding-sym + module-binding-nominal-module + module-binding-nominal-phase + module-binding-nominal-sym + module-binding-nominal-require-phase + module-binding-extra-inspector + module-binding-extra-nominal-bindings + + deserialize-full-module-binding + deserialize-simple-module-binding) + +;; ---------------------------------------- + +(define (make-module-binding module phase sym + #:wrt [wrt-sym sym] + #:nominal-module [nominal-module module] + #:nominal-phase [nominal-phase phase] + #:nominal-sym [nominal-sym sym] + #:nominal-require-phase [nominal-require-phase 0] + #:frame-id [frame-id #f] + #:free=id [free=id #f] + #:extra-inspector [extra-inspector #f] + #:extra-nominal-bindings [extra-nominal-bindings null]) + (cond + [(or frame-id + free=id + extra-inspector + (not (and (eqv? nominal-phase phase) + (eq? nominal-sym sym) + (eqv? nominal-require-phase 0) + (null? extra-nominal-bindings)))) + (full-module-binding frame-id + free=id + module phase sym + nominal-module nominal-phase nominal-sym + nominal-require-phase + extra-inspector + extra-nominal-bindings)] + [else + (simple-module-binding module phase sym nominal-module)])) + +(define (module-binding-update b + #:module [module (module-binding-module b)] + #:phase [phase (module-binding-phase b)] + #:sym [sym (module-binding-sym b)] + #:nominal-module [nominal-module (module-binding-nominal-module b)] + #:nominal-phase [nominal-phase (module-binding-nominal-phase b)] + #:nominal-sym [nominal-sym (module-binding-nominal-sym b)] + #:nominal-require-phase [nominal-require-phase (module-binding-nominal-require-phase b)] + #:frame-id [frame-id (binding-frame-id b)] + #:free=id [free=id (binding-free=id b)] + #:extra-inspector [extra-inspector (module-binding-extra-inspector b)] + #:extra-nominal-bindings [extra-nominal-bindings (module-binding-extra-nominal-bindings b)]) + (make-module-binding module phase sym + #:nominal-module nominal-module + #:nominal-phase nominal-phase + #:nominal-sym nominal-sym + #:nominal-require-phase nominal-require-phase + #:frame-id frame-id + #:free=id free=id + #:extra-inspector extra-inspector + #:extra-nominal-bindings extra-nominal-bindings)) + +(define (module-binding? b) + ;; must not overlap with `local-binding?` + (or (simple-module-binding? b) + (full-module-binding? b))) + +;; See `identifier-binding` docs for information about these fields: +(struct full-module-binding full-binding (module phase sym + nominal-module nominal-phase nominal-sym + nominal-require-phase + extra-inspector ; preserves access to protected definitions + extra-nominal-bindings) + #:authentic + #:transparent + #:property prop:serialize + (lambda (b ser-push! state) + ;; Dropping the frame id may simplify the representation: + (define simplified-b + (if (full-binding-frame-id b) + (module-binding-update b #:frame-id #f) + b)) + (cond + [(full-module-binding? simplified-b) + (ser-push! 'tag '#:module-binding) + (ser-push! (full-module-binding-module b)) + (ser-push! (full-module-binding-sym b)) + (ser-push! (full-module-binding-phase b)) + (ser-push! (full-module-binding-nominal-module b)) + (ser-push! (full-module-binding-nominal-phase b)) + (ser-push! (full-module-binding-nominal-sym b)) + (ser-push! (full-module-binding-nominal-require-phase b)) + (ser-push! (full-binding-free=id b)) + (if (full-module-binding-extra-inspector b) + (ser-push! 'tag '#:inspector) + (ser-push! #f)) + (ser-push! (full-module-binding-extra-nominal-bindings b))] + [else + (ser-push! simplified-b)]))) + +(struct simple-module-binding (module phase sym nominal-module) + #:authentic + #:transparent + #:property prop:serialize + (lambda (b ser-push! state) + (ser-push! 'tag '#:simple-module-binding) + (ser-push! (simple-module-binding-module b)) + (ser-push! (simple-module-binding-sym b)) + (ser-push! (simple-module-binding-phase b)) + (ser-push! (simple-module-binding-nominal-module b)))) + +(define (deserialize-full-module-binding module sym phase + nominal-module + nominal-phase + nominal-sym + nominal-require-phase + free=id + extra-inspector + extra-nominal-bindings) + (make-module-binding module phase sym + #:nominal-module nominal-module + #:nominal-phase nominal-phase + #:nominal-sym nominal-sym + #:nominal-require-phase nominal-require-phase + #:free=id free=id + #:extra-inspector extra-inspector + #:extra-nominal-bindings extra-nominal-bindings)) + +(define (deserialize-simple-module-binding module sym phase nominal-module) + (simple-module-binding module phase sym nominal-module)) + +;; ---------------------------------------- + +(define (module-binding-module b) + (if (simple-module-binding? b) + (simple-module-binding-module b) + (full-module-binding-module b))) + +(define (module-binding-phase b) + (if (simple-module-binding? b) + (simple-module-binding-phase b) + (full-module-binding-phase b))) + +(define (module-binding-sym b) + (if (simple-module-binding? b) + (simple-module-binding-sym b) + (full-module-binding-sym b))) + +(define (module-binding-nominal-module b) + (if (simple-module-binding? b) + (simple-module-binding-nominal-module b) + (full-module-binding-nominal-module b))) + +(define (module-binding-nominal-phase b) + (if (simple-module-binding? b) + (simple-module-binding-phase b) + (full-module-binding-nominal-phase b))) + +(define (module-binding-nominal-sym b) + (if (simple-module-binding? b) + (simple-module-binding-sym b) + (full-module-binding-nominal-sym b))) + +(define (module-binding-nominal-require-phase b) + (if (simple-module-binding? b) + 0 + (full-module-binding-nominal-require-phase b))) + +(define (module-binding-extra-inspector b) + (if (simple-module-binding? b) + #f + (full-module-binding-extra-inspector b))) + +(define (module-binding-extra-nominal-bindings b) + (if (simple-module-binding? b) + null + (full-module-binding-extra-nominal-bindings b))) diff --git a/racket/src/expander/syntax/original.rkt b/racket/src/expander/syntax/original.rkt new file mode 100644 index 0000000000..5feda7fa53 --- /dev/null +++ b/racket/src/expander/syntax/original.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide original-property-sym) + +(define original-property-sym + (gensym 'original)) + diff --git a/racket/src/expander/syntax/preserved.rkt b/racket/src/expander/syntax/preserved.rkt new file mode 100644 index 0000000000..d64f7a92bc --- /dev/null +++ b/racket/src/expander/syntax/preserved.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require "datum-map.rkt" + "../common/prefab.rkt") + +(provide preserved-property-value? + preserved-property-value + plain-property-value + + check-value-to-preserve) + +(struct preserved-property-value (content)) + +(define (plain-property-value v) + (if (preserved-property-value? v) + (preserved-property-value-content v) + v)) + +(define (deserialize-preserved-property-value v) + (preserved-property-value v)) + +(define (check-value-to-preserve v syntax?) + (datum-map v + (lambda (tail? v) + (unless (or (null? v) (boolean? v) (symbol? v) (number? v) + (char? v) (string? v) (bytes? v) (regexp? v) + (syntax? v) + (pair? v) (vector? v) (box? v) (hash? v) + (immutable-prefab-struct-key v)) + (raise-arguments-error 'write + "disallowed value in preserved syntax property" + "value" v)) + v) + disallow-cycles)) + +(define disallow-cycles + (hash 'cycle-fail + (lambda (v) + (raise-arguments-error 'write + "disallowed cycle in preserved syntax property" + "at" v)))) diff --git a/racket/src/expander/syntax/property.rkt b/racket/src/expander/syntax/property.rkt new file mode 100644 index 0000000000..61ee39359b --- /dev/null +++ b/racket/src/expander/syntax/property.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require "syntax.rkt" + "preserved.rkt" + "../common/contract.rkt") + +(provide syntax-property + syntax-property-preserved? + syntax-property-symbol-keys + syntax-property-remove) + +;; ---------------------------------------- + +(define syntax-property + (case-lambda + [(s key) + (check 'syntax-property syntax? s) + (define v (hash-ref (syntax-props s) key #f)) + (plain-property-value v)] + [(s key val) + (check 'syntax-property syntax? s) + (define pval (if (eq? key 'paren-shape) + (preserved-property-value val) + val)) + (struct-copy syntax s + [props (hash-set (syntax-props s) key pval)])] + [(s key val preserved?) + (check 'syntax-property syntax? s) + (when preserved? + (unless (and (symbol? key) (symbol-interned? key)) + (raise-arguments-error 'syntax-property + "key for a perserved property must be an interned symbol" + "given key" key + "given value" val))) + (define pval (if preserved? + (preserved-property-value val) + val)) + (struct-copy syntax s + [props (hash-set (syntax-props s) key pval)])])) + +(define (syntax-property-preserved? s key) + (check 'syntax-property-preserved syntax? s) + (unless (and (symbol? key) (symbol-interned? key)) + (raise-argument-error 'syntax-property "(and/c symbol? symbol-interned?)" key)) + (preserved-property-value? (hash-ref (syntax-props s) key #f))) + +(define syntax-property-symbol-keys + (lambda (s) + (unless (syntax? s) + (raise-argument-error 'syntax-property-symbol-keys "syntax" s)) + (for/list ([(k v) (in-immutable-hash (syntax-props s))] + #:when (and (symbol? k) (symbol-interned? k))) + k))) + +(define (syntax-property-remove s key) + (if (hash-ref (syntax-props s) key #f) + (struct-copy syntax s + [props (hash-remove (syntax-props s) key)]) + s)) diff --git a/racket/src/expander/syntax/read-syntax.rkt b/racket/src/expander/syntax/read-syntax.rkt new file mode 100644 index 0000000000..8889e80e9e --- /dev/null +++ b/racket/src/expander/syntax/read-syntax.rkt @@ -0,0 +1,161 @@ +#lang racket/base +(require "../common/performance.rkt" + (rename-in "../read/main.rkt" + [read main:read] + [read-language main:read-language]) + "syntax.rkt" + "property.rkt" + "original.rkt" + "../eval/dynamic-require.rkt" + "../namespace/api-module.rkt" + "../namespace/namespace.rkt" + "srcloc.rkt" + "../host/linklet.rkt") + +(provide read + read/recursive + read-syntax + read-syntax/recursive + read-language) + +(define (read-syntax src in) + (cond + [(default-read-handler? in) + (maybe-flush-stdout in) + (read* in + #:for-syntax? #t + #:source src)] + [else + ;; `values` forces a single result value: + (values ((port-read-handler in) in src))])) + +(define (read-syntax/recursive src in start readtable graph?) + (read* in + #:for-syntax? #t + #:recursive? #t + #:source src + #:init-c start + #:readtable readtable + #:local-graph? (not graph?))) + +(define (read in) + (cond + [(default-read-handler? in) + (maybe-flush-stdout in) + (read* in + #:for-syntax? #f)] + [else + ;; `values` forces a single result value: + (values ((port-read-handler in) in))])) + +(define (read/recursive in start readtable graph?) + (read* in + #:for-syntax? #f + #:recursive? #t + #:init-c start + #:readtable readtable + #:local-graph? (not graph?))) + +(define (read* in + #:for-syntax? for-syntax? + #:recursive? [recursive? #f] + #:source [source #f] + #:init-c [init-c #f] + #:readtable [readtable (current-readtable)] + #:local-graph? [local-graph? #f]) + (performance-region + ['read] + (main:read in + #:for-syntax? for-syntax? + #:recursive? recursive? + #:source source + #:wrap (and for-syntax? + read-to-syntax) + #:init-c init-c + #:readtable readtable + #:local-graph? local-graph? + #:read-compiled read-compiled-linklet + #:dynamic-require dynamic-require-reader + #:module-declared? read-module-declared? + #:coerce read-coerce + #:coerce-key read-coerce-key))) + +(define (read-language in fail-thunk) + (main:read-language in fail-thunk + #:for-syntax? #t + #:wrap read-to-syntax + #:read-compiled read-compiled-linklet + #:dynamic-require dynamic-require-reader + #:module-declared? read-module-declared? + #:coerce read-coerce + #:coerce-key read-coerce-key)) + +(define (read-to-syntax s-exp srcloc rep) + (struct-copy syntax empty-syntax + [content (datum-intern-literal s-exp)] + [srcloc srcloc] + [props (case rep + [(#\[) original-square-props] + [(#\{) original-curly-props] + [else original-props])])) + +(define original-props + (syntax-props (syntax-property empty-syntax original-property-sym #t))) +(define original-square-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\[))) +(define original-curly-props + (syntax-props (syntax-property (syntax-property empty-syntax original-property-sym #t) + 'paren-shape #\{))) + +(define (read-module-declared? mod-path) + (module-declared? mod-path #t)) + +(define (read-coerce for-syntax? v srcloc) + (cond + [(not for-syntax?) + (cond + [(syntax? v) (syntax->datum v)] + [else v])] + [else + (datum->syntax #f v (and srcloc (to-srcloc-stx srcloc)))])) + +(define (read-coerce-key for-syntax? k) + (cond + [for-syntax? (datum-intern-literal k)] + [else k])) + +;; ---------------------------------------- + +;; Initialized on first port that we read from, on the +;; assuption that we have to read some file before a +;; read handler can possibly be set: +(define default-read-handler #f) + +(define (default-read-handler? in) + (cond + [(not default-read-handler) + (set! default-read-handler (port-read-handler in)) + #t] + [else + (eq? default-read-handler (port-read-handler in))])) + +(define orig-input-port (current-input-port)) +(define orig-output-port (current-output-port)) +(define orig-error-port (current-error-port)) + +(define (maybe-flush-stdout in) + (when (eq? in orig-input-port) + (flush-output orig-output-port) + (flush-output orig-error-port))) + +;; ---------------------------------------- + +(define (dynamic-require-reader mod-path sym [fail-thunk default-dynamic-require-fail-thunk]) + (define root-ns (namespace-root-namespace (current-namespace))) + (if root-ns + ;; Switch to the root namespace: + (parameterize ([current-namespace root-ns]) + (dynamic-require mod-path sym fail-thunk)) + ;; Current namespace is a root namespace: + (dynamic-require mod-path sym fail-thunk))) diff --git a/racket/src/expander/syntax/scope.rkt b/racket/src/expander/syntax/scope.rkt new file mode 100644 index 0000000000..3462343d6a --- /dev/null +++ b/racket/src/expander/syntax/scope.rkt @@ -0,0 +1,837 @@ +#lang racket/base +(require "../common/set.rkt" + "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "../common/memo.rkt" + "../common/inline.rkt" + "syntax.rkt" + "binding-table.rkt" + "tamper.rkt" + "taint.rkt" + "../common/phase.rkt" + "fallback.rkt" + "datum-map.rkt" + "cache.rkt") + +(provide new-scope + new-multi-scope + add-scope + add-scopes + remove-scope + remove-scopes + flip-scope + flip-scopes + push-scope + + syntax-e ; handles lazy scope and taint propagation + syntax-e/no-taint ; like `syntax-e`, but doesn't explode a dye pack + + syntax-scope-set + syntax-any-scopes? + syntax-any-macro-scopes? + + syntax-shift-phase-level + + syntax-swap-scopes + + add-binding-in-scopes! + add-bulk-binding-in-scopes! + + propagation-mpi-shift ; for use by "binding.rkt" + + resolve + + bound-identifier=? + + top-level-common-scope + + deserialize-scope + deserialize-scope-fill! + deserialize-representative-scope + deserialize-representative-scope-fill! + deserialize-multi-scope + deserialize-shifted-multi-scope + + generalize-scope + + scope? + scope" port)) + #:property prop:serialize + (lambda (s ser-push! state) + (unless (set-member? (serialize-state-reachable-scopes state) s) + (error "internal error: found supposedly unreachable scope")) + (cond + [(eq? s top-level-common-scope) + (ser-push! 'tag '#:scope)] + [else + (ser-push! 'tag '#:scope+kind) + (ser-push! (scope-kind s))])) + #:property prop:serialize-fill! + (lambda (s ser-push! state) + (cond + [(binding-table-empty? (scope-binding-table s)) + (ser-push! 'tag #f)] + [else + (ser-push! 'tag '#:scope-fill!) + (ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state))])) + #:property prop:reach-scopes + (lambda (s reach) + ;; the `bindings` field is handled via `prop:scope-with-bindings` + (void)) + #:property prop:scope-with-bindings + (lambda (s reachable-scopes reach register-trigger) + (binding-table-register-reachable (scope-binding-table s) + reachable-scopes + reach + register-trigger))) + +(define deserialize-scope + (case-lambda + [() top-level-common-scope] + [(kind) + (scope (new-deserialize-scope-id!) kind empty-binding-table)])) + +(define (deserialize-scope-fill! s bt) + (set-scope-binding-table! s bt)) + +;; A "multi-scope" represents a group of scopes, each of which exists +;; only at a specific phase, and each in a distinct phase. This +;; infinite group of scopes is realized on demand. A multi-scope is +;; used to represent the inside of a module, where bindings in +;; different phases are distinguished by the different scopes within +;; the module's multi-scope. +;; +;; To compute a syntax's set of scopes at a given phase, the +;; phase-specific representative of the multi scope is combined with +;; the phase-independent scopes. Since a multi-scope corresponds to +;; a module, the number of multi-scopes in a syntax is expected to +;; be small. +(struct multi-scope (id ; identity + name ; for debugging + scopes ; phase -> representative-scope + shifted ; box of table: interned shifted-multi-scopes for non-label phases + label-shifted) ; box of table: interned shifted-multi-scopes for label phases + #:authentic + #:property prop:serialize + (lambda (ms ser-push! state) + (ser-push! 'tag '#:multi-scope) + (ser-push! (multi-scope-name ms)) + (ser-push! (multi-scope-scopes ms))) + #:property prop:reach-scopes + (lambda (ms reach) + (reach (multi-scope-scopes ms)))) + +(define (deserialize-multi-scope name scopes) + (multi-scope (new-deserialize-scope-id!) name scopes (box (hasheqv)) (box (hash)))) + +(struct representative-scope scope (owner ; a multi-scope for which this one is a phase-specific identity + phase) ; phase of this scope + #:authentic + #:mutable ; to support serialization + #:property prop:custom-write + (lambda (sc port mode) + (write-string "#" port)) + #:property prop:serialize + (lambda (s ser-push! state) + (ser-push! 'tag '#:representative-scope) + (ser-push! (scope-kind s)) + (ser-push! (representative-scope-phase s))) + #:property prop:serialize-fill! + (lambda (s ser-push! state) + (ser-push! 'tag '#:representative-scope-fill!) + (ser-push! (binding-table-prune-to-reachable (scope-binding-table s) state)) + (ser-push! (representative-scope-owner s))) + #:property prop:reach-scopes + (lambda (s reach) + ;; the inherited `bindings` field is handled via `prop:scope-with-bindings` + (reach (representative-scope-owner s)))) + +(define (deserialize-representative-scope kind phase) + (define v (representative-scope (new-deserialize-scope-id!) kind #f #f phase)) + v) + +(define (deserialize-representative-scope-fill! s bt owner) + (deserialize-scope-fill! s bt) + (set-representative-scope-owner! s owner)) + +(struct shifted-multi-scope (phase ; non-label phase shift or shifted-to-label-phase + multi-scope) ; a multi-scope + #:authentic + #:property prop:custom-write + (lambda (sms port mode) + (write-string "#" port)) + #:property prop:serialize + (lambda (sms ser-push! state) + (ser-push! 'tag '#:shifted-multi-scope) + (ser-push! (shifted-multi-scope-phase sms)) + (ser-push! (shifted-multi-scope-multi-scope sms))) + #:property prop:reach-scopes + (lambda (sms reach) + (reach (shifted-multi-scope-multi-scope sms)))) + +(define (deserialize-shifted-multi-scope phase multi-scope) + (intern-shifted-multi-scope phase multi-scope)) + +(define (intern-shifted-multi-scope phase multi-scope) + (define (transaction-loop boxed-table key make) + (or (hash-ref (unbox boxed-table) phase #f) + (let* ([val (make)] + [current (unbox boxed-table)] + [next (hash-set current key val)]) + (if (box-cas! boxed-table current next) + val + (transaction-loop boxed-table key make))))) + (cond + [(phase? phase) + ;; `eqv?`-hashed by phase + (or (hash-ref (unbox (multi-scope-shifted multi-scope)) phase #f) + (transaction-loop (multi-scope-shifted multi-scope) + phase + (lambda () (shifted-multi-scope phase multi-scope))))] + [else + ;; `equal?`-hashed by shifted-to-label-phase + (or (hash-ref (unbox (multi-scope-label-shifted multi-scope)) phase #f) + (transaction-loop (multi-scope-label-shifted multi-scope) + phase + (lambda () (shifted-multi-scope phase multi-scope))))])) + +;; A `shifted-to-label-phase` record in the `phase` field of a +;; `shifted-multi-scope` makes the shift reversible; when we're +;; looking up the label phase, then use the representative scope at +;; phase `from`; when we're looking up a non-label phase, there is no +;; corresponding representative scope +(struct shifted-to-label-phase (from) #:prefab) + +;; Each new scope increments the counter, so we can check whether one +;; scope is newer than another. +(define id-counter 0) +(define (new-scope-id!) + (set! id-counter (add1 id-counter)) + id-counter) + +(define (new-deserialize-scope-id!) + ;; negative scope ensures that new scopes are recognized as such by + ;; having a larger id + (- (new-scope-id!))) + +;; A shared "outside-edge" scope for all top-level contexts +(define top-level-common-scope (scope 0 'module empty-binding-table)) + +(define (new-scope kind) + (scope (new-scope-id!) kind empty-binding-table)) + +(define (new-multi-scope [name #f]) + (intern-shifted-multi-scope 0 (multi-scope (new-scope-id!) name (make-hasheqv) (box (hasheqv)) (box (hash))))) + +(define (multi-scope-to-scope-at-phase ms phase) + ;; Get the identity of `ms` at phase` + (or (hash-ref (multi-scope-scopes ms) phase #f) + (let ([s (representative-scope (new-scope-id!) 'module + empty-binding-table + ms phase)]) + (hash-set! (multi-scope-scopes ms) phase s) + s))) + +(define (scope>? sc1 sc2) + ((scope-id sc1) . > . (scope-id sc2))) +(define (scope (or/c 'add 'remove 'flip) + ;; mpi-shifts and inspectors are mostly + ;; implemented at the "binding.rkt" layer, + ;; but we accomodate them here + prev-mss ; owner's mpi-shifts before adds + add-mpi-shifts ; #f or (mpi-shifts -> mpi-shifts) + inspector ; #f or inspector + tamper) ; see "tamper.rkt" + #:authentic + #:property prop:propagation syntax-e + #:property prop:propagation-tamper (lambda (p) (propagation-tamper p)) + #:property prop:propagation-set-tamper (lambda (p v) (propagation-set-tamper p v))) + +(define (propagation-add prop sc prev-scs prev-smss prev-mss) + (if (propagation? prop) + (struct-copy propagation prop + [scope-ops (hash-set (propagation-scope-ops prop) + sc + 'add)]) + (propagation prev-scs prev-smss (hasheq sc 'add) + prev-mss #f #f + prop))) + +(define (propagation-remove prop sc prev-scs prev-smss prev-mss) + (if (propagation? prop) + (struct-copy propagation prop + [scope-ops (hash-set (propagation-scope-ops prop) + sc + 'remove)]) + (propagation prev-scs prev-smss (hasheq sc 'remove) + prev-mss #f #f + prop))) + +(define (propagation-flip prop sc prev-scs prev-smss prev-mss) + (if (propagation? prop) + (let* ([ops (propagation-scope-ops prop)] + [current-op (hash-ref ops sc #f)]) + (cond + [(and (eq? current-op 'flip) + (= 1 (hash-count ops)) + (not (propagation-inspector prop)) + (not (propagation-add-mpi-shifts prop))) + ;; Nothing left to propagate + #f] + [else + (struct-copy propagation prop + [scope-ops + (if (eq? current-op 'flip) + (hash-remove ops sc) + (hash-set ops sc (case current-op + [(add) 'remove] + [(remove) 'add] + [else 'flip])))])])) + (propagation prev-scs prev-smss (hasheq sc 'flip) + prev-mss #f #f + prop))) + +(define (propagation-mpi-shift prop add inspector prev-scs prev-smss prev-mss) + (if (propagation? prop) + (struct-copy propagation prop + [add-mpi-shifts (let ([base-add (propagation-add-mpi-shifts prop)]) + (if (and add base-add) + (lambda (mss) (add (base-add mss))) + (or add base-add)))] + [inspector (or (propagation-inspector prop) + inspector)]) + (propagation prev-scs prev-smss #hasheq() + prev-mss add inspector + prop))) + +(define (propagation-apply prop scs parent-s) + (cond + [(eq? (propagation-prev-scs prop) scs) + (syntax-scopes parent-s)] + [else + (define new-scs + (for/fold ([scs scs]) ([(sc op) (in-immutable-hash (propagation-scope-ops prop))] + #:when (not (shifted-multi-scope? sc))) + (case op + [(add) (set-add scs sc)] + [(remove) (set-remove scs sc)] + [else (set-flip scs sc)]))) + ;; Improve sharing if the result matches the parent: + (if (set=? new-scs (syntax-scopes parent-s)) + (syntax-scopes parent-s) + (cache-or-reuse-set new-scs))])) + +(define (propagation-apply-shifted prop smss parent-s) + (cond + [(eq? (propagation-prev-smss prop) smss) + (syntax-shifted-multi-scopes parent-s)] + [else + (define new-smss + (for/fold ([smss smss]) ([(sms op) (in-immutable-hash (propagation-scope-ops prop))] + #:when (shifted-multi-scope? sms)) + (fallback-update-first + smss + (lambda (smss) + (case op + [(add) (set-add smss sms)] + [(remove) (set-remove smss sms)] + [else (set-flip smss sms)]))))) + ;; Improve sharing if the result clearly matches the parent: + (define parent-smss (syntax-shifted-multi-scopes parent-s)) + (if (and (set? new-smss) + (set? parent-smss) + (set=? new-smss parent-smss)) + parent-smss + (cache-or-reuse-hash new-smss))])) + +(define (propagation-apply-mpi-shifts prop mss parent-s) + (cond + [(eq? (propagation-prev-mss prop) mss) + (syntax-mpi-shifts parent-s)] + [else + (define add (propagation-add-mpi-shifts prop)) + (if add + (add mss) + mss)])) + +(define (propagation-apply-inspector prop i) + (or i (propagation-inspector prop))) + +(define (propagation-set-tamper prop t) + (if (propagation? prop) + (struct-copy propagation prop + [tamper t]) + t)) + +(define (propagation-merge content prop base-prop prev-scs prev-smss prev-mss) + (cond + [(not (datum-has-elements? content)) + (if (tamper-tainted? (propagation-tamper prop)) + 'tainted + base-prop)] + [(not (propagation? base-prop)) + (cond + [(and (eq? (propagation-prev-scs prop) prev-scs) + (eq? (propagation-prev-smss prop) prev-smss) + (eq? (propagation-prev-mss prop) prev-mss) + (eq? (propagation-tamper prop) base-prop)) + prop] + [else + (propagation prev-scs + prev-smss + (propagation-scope-ops prop) + prev-mss + (propagation-add-mpi-shifts prop) + (propagation-inspector prop) + (if (tamper-tainted? (propagation-tamper prop)) + 'tainted/need-propagate + base-prop))])] + [else + (define new-ops + ;; [could call `cache-or-reuse-hash` here (or a copy for propagations), + ;; but that doesn't seem to same time or space overall] + (for/fold ([ops (propagation-scope-ops base-prop)]) ([(sc op) (in-immutable-hash (propagation-scope-ops prop))]) + (case op + [(add) (hash-set ops sc 'add)] + [(remove) (hash-set ops sc 'remove)] + [else ; flip + (define current-op (hash-ref ops sc #f)) + (case current-op + [(add) (hash-set ops sc 'remove)] + [(remove) (hash-set ops sc 'add)] + [(flip) (hash-remove ops sc)] + [else (hash-set ops sc 'flip)])]))) + (define add (propagation-add-mpi-shifts prop)) + (define base-add (propagation-add-mpi-shifts base-prop)) + (define new-tamper + (if (or (tamper-tainted? (propagation-tamper prop)) + (tamper-tainted? (propagation-tamper base-prop))) + 'tainted/need-propagate + (propagation-tamper base-prop))) + (if (and (zero? (hash-count new-ops)) + (not add) + (not base-add) + (not (propagation-inspector prop)) + (not (propagation-inspector base-prop))) + new-tamper + (struct-copy propagation base-prop + [scope-ops new-ops] + [add-mpi-shifts (if (and add base-add) + (lambda (mss) (add (base-add mss))) + (or add base-add))] + [inspector (or (propagation-inspector base-prop) + (propagation-inspector prop))] + [tamper new-tamper]))])) + +;; ---------------------------------------- + +;; To shift a syntax's phase, we only have to shift the phase +;; of any phase-specific scopes. The bindings attached to a +;; scope must be represented in such a way that the binding +;; shift is implicit via the phase in which the binding +;; is resolved. +(define (shift-multi-scope sms delta) + (cond + [(zero-phase? delta) + ;; No-op shift + sms] + [(label-phase? delta) + (cond + [(shifted-to-label-phase? (shifted-multi-scope-phase sms)) + ;; Shifting to the label phase moves only phase 0, so + ;; drop a scope that is already collapsed to phase #f + #f] + [else + ;; Move the current phase 0 to the label phase, which + ;; means recording the negation of the current phase + (intern-shifted-multi-scope (shifted-to-label-phase (phase- 0 (shifted-multi-scope-phase sms))) + (shifted-multi-scope-multi-scope sms))])] + [(shifted-to-label-phase? (shifted-multi-scope-phase sms)) + ;; Numeric shift has no effect on bindings in phase #f + sms] + [else + ;; Numeric shift added to an existing numeric shift + (intern-shifted-multi-scope (phase+ delta (shifted-multi-scope-phase sms)) + (shifted-multi-scope-multi-scope sms))])) + +;; Since we tend to shift rarely and only for whole modules, it's +;; probably not worth making this lazy +(define (syntax-shift-phase-level s phase) + (if (eqv? phase 0) + s + (let () + (define-memo-lite (shift-all smss) + (fallback-map + smss + (lambda (smss) + (for*/seteq ([sms (in-set smss)] + [new-sms (in-value (shift-multi-scope sms phase))] + #:when new-sms) + new-sms)))) + (syntax-map s + (lambda (tail? d) d) + (lambda (s d) + (struct-copy syntax s + [content d] + [shifted-multi-scopes + (shift-all (syntax-shifted-multi-scopes s))])) + syntax-e/no-taint)))) + +;; ---------------------------------------- + +;; Scope swapping is used to make top-level compilation relative to +;; the top level. Each top-level environment has a set of scopes that +;; identify the environment; usually, it's a common outside-edge scope +;; and a namespace-specific inside-edge scope, but there can be +;; additional scopes due to `module->namespace` on a module that was +;; expanded multiple times (where each expansion adds scopes). +(define (syntax-swap-scopes s src-scopes dest-scopes) + (if (equal? src-scopes dest-scopes) + s + (let-values ([(src-smss src-scs) + (set-partition (for/seteq ([sc (in-set src-scopes)]) + (generalize-scope sc)) + shifted-multi-scope? + (seteq) + (seteq))] + [(dest-smss dest-scs) + (set-partition (for/seteq ([sc (in-set dest-scopes)]) + (generalize-scope sc)) + shifted-multi-scope? + (seteq) + (seteq))]) + (define-memo-lite (swap-scs scs) + (if (subset? src-scs scs) + (set-union (set-subtract scs src-scs) dest-scs) + scs)) + (define-memo-lite (swap-smss smss) + (fallback-update-first + smss + (lambda (smss) + (if (subset? src-smss smss) + (set-union (set-subtract smss src-smss) dest-smss) + smss)))) + (syntax-map s + (lambda (tail? d) d) + (lambda (s d) + (struct-copy syntax s + [content d] + [scopes (swap-scs (syntax-scopes s))] + [shifted-multi-scopes + (swap-smss (syntax-shifted-multi-scopes s))])) + syntax-e/no-taint)))) + +;; ---------------------------------------- + +;; Assemble the complete set of scopes at a given phase by extracting +;; a phase-specific representative from each multi-scope. +(define (syntax-scope-set s phase) + (scope-set-at-fallback s (fallback-first (syntax-shifted-multi-scopes s)) phase)) + +(define (scope-set-at-fallback s smss phase) + (for*/fold ([scopes (syntax-scopes s)]) ([sms (in-set smss)] + #:when (or (label-phase? phase) + (not (shifted-to-label-phase? (shifted-multi-scope-phase sms))))) + (set-add scopes (multi-scope-to-scope-at-phase (shifted-multi-scope-multi-scope sms) + (let ([ph (shifted-multi-scope-phase sms)]) + (if (shifted-to-label-phase? ph) + (shifted-to-label-phase-from ph) + (phase- ph phase))))))) + +(define (find-max-scope scopes) + (when (set-empty? scopes) + (error "cannot bind in empty scope set")) + (for/fold ([max-sc (set-first scopes)]) ([sc (in-set scopes)]) + (if (scope>? sc max-sc) + sc + max-sc))) + +(define (add-binding-in-scopes! scopes sym binding #:just-for-nominal? [just-for-nominal? #f]) + (define max-sc (find-max-scope scopes)) + (define bt (binding-table-add (scope-binding-table max-sc) scopes sym binding just-for-nominal?)) + (set-scope-binding-table! max-sc bt) + (clear-resolve-cache! sym)) + +(define (add-bulk-binding-in-scopes! scopes bulk-binding) + (define max-sc (find-max-scope scopes)) + (define bt (binding-table-add-bulk (scope-binding-table max-sc) scopes bulk-binding)) + (set-scope-binding-table! max-sc bt) + (clear-resolve-cache!)) + +(define (syntax-any-scopes? s) + (not (set-empty? (syntax-scopes s)))) + +(define (syntax-any-macro-scopes? s) + (for/or ([sc (in-set (syntax-scopes s))]) + (eq? (scope-kind sc) 'macro))) + +;; ---------------------------------------- + +;; Result is #f for no binding, `ambiguous-value` for an ambiguous binding, +;; or binding value +(define (resolve s phase + #:ambiguous-value [ambiguous-value #f] + #:exactly? [exactly? #f] + #:get-scopes? [get-scopes? #f] ; gets scope set instead of binding + ;; For resolving bulk bindings in `free-identifier=?` chains: + #:extra-shifts [extra-shifts null]) + (define sym (syntax-content s)) + (let fallback-loop ([smss (syntax-shifted-multi-scopes s)]) + (cond + [(and (not exactly?) + (not get-scopes?) + (resolve-cache-get sym phase (syntax-scopes s) (fallback-first smss))) + => (lambda (b) + (cond + [(eq? b '#:none) + (if (fallback? smss) + (fallback-loop (fallback-rest smss)) + #f)] + [else b]))] + [else + (define scopes (scope-set-at-fallback s (fallback-first smss) phase)) + ;; As we look through all scopes, if we find two where neither + ;; is a subset of the other, accumulate them into a list; maybe + ;; we find a superset of both, later; if we end with a list, + ;; then the binding is ambiguous. We expect that creating a list + ;; of ambiguous scopes is rare relative to eventual success. + (define-values (best-scopes best-binding) + (for*/fold ([best-scopes #f] [best-binding #f]) + ([sc (in-set scopes)] + [(b-scopes binding) (in-binding-table sym (scope-binding-table sc) s extra-shifts)] + #:when (and b-scopes binding (subset? b-scopes scopes))) + (cond + [(pair? best-scopes) + ;; We have a list of scopes where none is a superset of the others + (cond + [(for/and ([amb-scopes (in-list best-scopes)]) + (subset? amb-scopes b-scopes)) + ;; Found a superset of all + (values b-scopes binding)] + [else + ;; Accumulate another ambiguous set + (values (cons b-scopes best-scopes) #f)])] + [(not best-scopes) + (values b-scopes binding)] + [(subset? b-scopes best-scopes) ; can be `set=?` if binding is overridden + (values best-scopes best-binding)] + [(subset? best-scopes b-scopes) + (values b-scopes binding)] + [else + ;; Switch to ambiguous mode + (values (list best-scopes b-scopes) #f)]))) + (cond + [(pair? best-scopes) ; => ambiguous + (if (fallback? smss) + (fallback-loop (fallback-rest smss)) + ambiguous-value)] + [best-scopes + (resolve-cache-set! sym phase (syntax-scopes s) (fallback-first smss) best-binding) + (and (or (not exactly?) + (eqv? (set-count scopes) + (set-count best-scopes))) + (if get-scopes? + best-scopes + best-binding))] + [else + (resolve-cache-set! sym phase (syntax-scopes s) (fallback-first smss) '#:none) + (if (fallback? smss) + (fallback-loop (fallback-rest smss)) + #f)])]))) + +;; ---------------------------------------- + +(define (bound-identifier=? a b phase) + (and (eq? (syntax-e a) + (syntax-e b)) + (equal? (syntax-scope-set a phase) + (syntax-scope-set b phase)))) diff --git a/racket/src/expander/syntax/srcloc.rkt b/racket/src/expander/syntax/srcloc.rkt new file mode 100644 index 0000000000..1a5f82ec8a --- /dev/null +++ b/racket/src/expander/syntax/srcloc.rkt @@ -0,0 +1,57 @@ +#lang racket/base +(require "syntax.rkt") + +(provide syntax-source + syntax-line + syntax-column + syntax-position + syntax-span + + encoded-srcloc? + to-srcloc-stx) + +(define (syntax-source-accessor who srcloc-accessor) + (lambda (s) + (unless (syntax? s) + (raise-argument-error who "syntax?" s)) + (define srcloc (syntax-srcloc s)) + (and srcloc + (srcloc-accessor srcloc)))) + +(define syntax-source (syntax-source-accessor 'syntax-source srcloc-source)) +(define syntax-line (syntax-source-accessor 'syntax-line srcloc-line)) +(define syntax-column (syntax-source-accessor 'syntax-column srcloc-column)) +(define syntax-position (syntax-source-accessor 'syntax-position srcloc-position)) +(define syntax-span (syntax-source-accessor 'syntax-span srcloc-span)) + +(define (encoded-srcloc? v) + (or (and (list? v) + (= (length v) 5) + (srcloc-vector? (list->vector v))) + (and (vector? v) + (= (vector-length v) 5) + (srcloc-vector? v)))) + +(define (srcloc-vector? v) + (and (or (not (vector-ref v 1)) + (exact-positive-integer? (vector-ref v 1))) + (or (not (vector-ref v 2)) + (exact-nonnegative-integer? (vector-ref v 2))) + (or (not (vector-ref v 3)) + (exact-positive-integer? (vector-ref v 3))) + (or (not (vector-ref v 4)) + (exact-nonnegative-integer? (vector-ref v 4))))) + +(define (to-srcloc-stx v) + (cond + [(srcloc? v) (struct-copy syntax empty-syntax + [srcloc v])] + [(pair? v) (to-srcloc-stx (list->vector v))] + [(vector? v) + (struct-copy syntax empty-syntax + [srcloc (srcloc (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3) + (vector-ref v 4))])] + [else v])) diff --git a/racket/src/expander/syntax/syntax.rkt b/racket/src/expander/syntax/syntax.rkt new file mode 100644 index 0000000000..2adf9e9f4d --- /dev/null +++ b/racket/src/expander/syntax/syntax.rkt @@ -0,0 +1,297 @@ +#lang racket/base +(require "../compile/serialize-property.rkt" + "../compile/serialize-state.rkt" + "../common/set.rkt" + "../common/inline.rkt" + "preserved.rkt" + "tamper.rkt" + "datum-map.rkt") + +(provide + (struct-out syntax) ; includes `syntax?` + syntax-tamper + empty-syntax + identifier? + + syntax->datum + datum->syntax + + syntax-map + non-syntax-map + + prop:propagation + prop:propagation-tamper + prop:propagation-set-tamper + propagation-set-tamper? + propagation-set-tamper-ref + + deserialize-syntax + deserialize-datum->syntax + current-arm-inspectors) + +(struct syntax ([content #:mutable] ; datum and nested syntax objects; mutated for lazy propagation + scopes ; scopes that apply at all phases + shifted-multi-scopes ; scopes with a distinct identity at each phase; maybe a fallback search + [scope-propagations+tamper #:mutable] ; lazy propagation info and/or tamper state + mpi-shifts ; chain of module-path-index substitutions + srcloc ; source location + props ; properties + inspector) ; inspector for access to protected bindings + #:authentic + ;; Custom printer: + #:property prop:custom-write + (lambda (s port mode) + (write-string "#string srcloc)) + (when srcloc-str + (fprintf port ":~a" srcloc-str))) + (fprintf port " ~.s" (syntax->datum s)) + (write-string ">" port)) + #:property prop:serialize + (lambda (s ser-push! state) + (define prop (syntax-scope-propagations+tamper s)) + (define content + (if (propagation? prop) + ((propagation-ref prop) s) + (syntax-content s))) + (define properties + (intern-properties + (syntax-props s) + (lambda () + (for/hasheq ([(k v) (in-hash (syntax-props s))] + #:when (preserved-property-value? v)) + (values k (check-value-to-preserve (plain-property-value v) syntax?)))) + state)) + (define tamper + (serialize-tamper (syntax-tamper s))) + (define context-triple + (intern-context-triple (intern-scopes (syntax-scopes s) state) + (intern-shifted-multi-scopes (syntax-shifted-multi-scopes s) state) + (intern-mpi-shifts (syntax-mpi-shifts s) state) + state)) + (define stx-state (get-syntax-context state)) + (cond + [(or properties tamper) + (ser-push! 'tag '#:syntax+props) + (push-syntax-context! state #f) + (ser-push! content) + (pop-syntax-context! state) + (ser-push! 'reference context-triple) + (ser-push! 'reference (syntax-srcloc s)) + (ser-push! properties) + (ser-push! tamper) + (when stx-state (set-syntax-state-all-sharing?! stx-state #f))] + [else + ;; We rely on two passes to reach a fixpoint on sharing: + (define sharing-mode (hash-ref (serialize-state-sharing-syntaxes state) s 'unknown)) + (cond + [(eq? sharing-mode 'share) + (ser-push! 'tag '#:datum->syntax) + (ser-push! (syntax->datum s))] + [(eq? sharing-mode 'unknown) + (ser-push! 'tag '#:syntax) + ;; Communicate to nested syntax objects the info that they might share + (define this-state (and (no-pair-syntax-in-cdr? content) + (syntax-state #t context-triple (syntax-srcloc s)))) + (push-syntax-context! state this-state) + ;; Serialize content + (ser-push! content) + ;; Check whether we're sharing for all nested syntax objects + (pop-syntax-context! state) + (define new-sharing-mode + (if (and this-state + (syntax-state-all-sharing? this-state)) + 'share + 'none)) + (hash-set! (serialize-state-sharing-syntaxes state) + s + ;; If the syntax object has only simple content, + ;; it doesn't need any sharing support by itself + (if (datum-has-elements? content) + new-sharing-mode + 'none)) + (when (and stx-state (eq? new-sharing-mode 'none)) + (set-syntax-state-all-sharing?! stx-state #f))] + [else + (ser-push! 'tag '#:syntax) + (push-syntax-context! state #f) + (ser-push! content) + (pop-syntax-context! state)]) + ;; Finish up + (ser-push! 'reference context-triple) + (ser-push! 'reference (syntax-srcloc s)) + (when stx-state + (unless (and (eq? context-triple (syntax-state-context-triple stx-state)) + (equal? (syntax-srcloc s) (syntax-state-srcloc stx-state))) + (set-syntax-state-all-sharing?! stx-state #f)))])) + #:property prop:reach-scopes + (lambda (s reach) + (define prop (syntax-scope-propagations+tamper s)) + (reach (if (propagation? prop) + ((propagation-ref prop) s) + (syntax-content s))) + (reach (syntax-scopes s)) + (reach (syntax-shifted-multi-scopes s)) + (for ([(k v) (in-immutable-hash (syntax-props s))] + #:when (preserved-property-value? v)) + (reach (plain-property-value v))) + (reach (syntax-srcloc s)))) + +;; Property to abstract over handling of propagation for +;; serialization; property value takes a syntax object and +;; returns its content +(define-values (prop:propagation propagation? propagation-ref) + (make-struct-type-property 'propagation)) + +;; Property to abstract over extraction of tamper from propagation +(define-values (prop:propagation-tamper propagation-tamper? propagation-tamper-ref) + (make-struct-type-property 'propagation-tamper)) +(define-values (prop:propagation-set-tamper propagation-set-tamper? propagation-set-tamper-ref) + (make-struct-type-property 'propagation-set-tamper)) + +(define (syntax-tamper s) + (define v (syntax-scope-propagations+tamper s)) + (if (tamper? v) + v + ((propagation-tamper-ref v) v))) + +;; ---------------------------------------- + +(define empty-scopes (seteq)) +(define empty-shifted-multi-scopes (seteq)) +(define empty-mpi-shifts null) +(define empty-props #hasheq()) + +(define empty-syntax + (syntax #f + empty-scopes + empty-shifted-multi-scopes + #f ; scope-propogations+tamper (clean) + empty-mpi-shifts + #f ; srcloc + empty-props + #f)) ; inspector + +(define (identifier? s) + (and (syntax? s) (symbol? (syntax-content s)))) + +(define (syntax->datum s) + (syntax-map s (lambda (tail? x) x) (lambda (s d) d) syntax-content)) + +(define (datum->syntax stx-c s [stx-l #f] [stx-p #f]) + (cond + [(syntax? s) s] + [else + (define (wrap content) + (syntax content + (if stx-c + (syntax-scopes stx-c) + empty-scopes) + (if stx-c + (syntax-shifted-multi-scopes stx-c) + empty-shifted-multi-scopes) + (and stx-c + (syntax-tamper stx-c) + (tamper-tainted-for-content content)) + (if stx-c + (syntax-mpi-shifts stx-c) + empty-mpi-shifts) + (and stx-l (syntax-srcloc stx-l)) + empty-props + (and stx-c + (syntax-inspector stx-c)))) + (define result-s + (non-syntax-map s + (lambda (tail? x) (if tail? x (wrap x))) + (lambda (s) s) + disallow-cycles)) + (if (and stx-p (not (eq? (syntax-props stx-p) empty-props))) + (struct-copy syntax result-s + [props (syntax-props stx-p)]) + result-s)])) + +;; `(syntax-map s f d->s)` walks over `s`: +;; +;; * `(f tail? d)` is called to each datum `d`, where `tail?` +;; indicates that the value is a pair/null in a `cdr` --- so that it +;; doesn't need to be wrapped for `datum->syntax`, for example +;; +;; * `(d->s orig-s d)` is called for each syntax object, +;; and the second argument is result of traversing its datum +;; +;; * the `s-e` function extracts content of a syntax object +;; +;; The optional `seen` argument is an `eq?`-based immutable hash table +;; to detect and reject cycles. See `datum-map`. + +(define-inline (syntax-map s f d->s s-e [seen #f]) + (let loop ([s s]) + (datum-map s + (lambda (tail? v) + (cond + [(syntax? v) (d->s v (loop (s-e v)))] + [else (f tail? v)])) + seen))) + +;; `(non-syntax-map s f s->)` is like `(syntax-map s f d->s)`, except that +;; when a syntax object is found, it is just passed to `d` --- so there's +;; no `d->s` or `s-e`, since they would not be called + +(define-inline (non-syntax-map s f [s-> (lambda (x) x)] [seen #f]) + (datum-map s + (lambda (tail? v) + (cond + [(syntax? v) (s-> v)] + [else (f tail? v)])) + seen)) + +(define disallow-cycles + (hasheq 'cycle-fail + (lambda (s) + (raise-arguments-error 'datum->syntax + "cannot create syntax from cyclic datum" + s)))) + +;; ---------------------------------------- + +;; When serializing syntax objects, let nested objects know the +;; content of an enclosing syntax object, so sharing is enabled if the +;; nested syntax objects have the same context and source location. +(struct syntax-state ([all-sharing? #:mutable] context-triple srcloc)) + +;; When sharing syntax information in serialization, we have to be +;; careful not to lose syntax objects that wrap a pair in a `cdr` (and +;; therefore would not be restored by `datum->syntax`). +(define (no-pair-syntax-in-cdr? content) + (cond + [(pair? content) (let loop ([content (cdr content)]) + (cond + [(and (syntax? content) + (pair? (syntax-content content))) + #f] + [(pair? content) (loop (cdr content))] + [else #t]))] + [else #t])) + +;; ---------------------------------------- + +;; Called by the deserializer + +(define (deserialize-syntax content context-triple srcloc props tamper inspector) + (syntax content + (vector*-ref context-triple 0) + (vector*-ref context-triple 1) + (deserialize-tamper tamper) + (vector*-ref context-triple 2) + srcloc + (if props + (for/hasheq ([(k v) (in-immutable-hash props)]) + (values k (preserved-property-value v))) + empty-props) + inspector)) + +(define (deserialize-datum->syntax content context-triple srcloc inspector) + (define s (deserialize-syntax #f context-triple srcloc #f #f inspector)) + (datum->syntax s content s s)) diff --git a/racket/src/expander/syntax/taint-dispatch.rkt b/racket/src/expander/syntax/taint-dispatch.rkt new file mode 100644 index 0000000000..e137985fa2 --- /dev/null +++ b/racket/src/expander/syntax/taint-dispatch.rkt @@ -0,0 +1,67 @@ +#lang racket/base +(require "syntax.rkt" + "property.rkt" + "to-list.rkt" + "scope.rkt" + "../namespace/core.rkt" + "original.rkt") + +;; The `taint-dispatch` function recognizes syntax properties and +;; bindings that adjust the way that a syntax object is armed. + +(provide taint-dispatch + syntax-remove-taint-dispatch-properties) + +(define (taint-dispatch s proc phase) + (let loop ([s s] [mode (syntax-taint-mode-property s)]) + (case mode + [(none) s] + [(opaque) (proc s)] + [(transparent) + (define c (non-syntax-map (or (syntax->list s) + (syntax-e s)) + (lambda (tail? d) d) + (lambda (s) (loop s (syntax-taint-mode-property s))))) + (datum->syntax #f c s (if (syntax-any-macro-scopes? s) + (syntax-property-remove s original-property-sym) + s))] + [(transparent-binding) + (define c (syntax-e s)) + (cond + [(pair? c) + (define cd (cdr c)) + (cond + [(or (pair? cd) + (and (syntax? cd) (pair? (syntax-e cd)))) + (define d (if (syntax? cd) (syntax-e cd) cd)) + (datum->syntax #f + (cons (loop (car c) (syntax-taint-mode-property (car c))) + (cons (loop (car d) 'transparent) + (non-syntax-map (or (syntax->list (cdr d)) + (cdr d)) + (lambda (tail? d) d) + (lambda (s) (loop s (syntax-taint-mode-property s)))))) + s + (if (syntax-any-macro-scopes? s) + (syntax-property-remove s original-property-sym) + s))] + [else (loop s 'transparent)])] + [else (loop s 'transparent)])] + [else + (define c (syntax-e s)) + (case (core-form-sym c phase) + [(begin begin-for-syntax #%module-begin) + (loop s 'transparent)] + [(define-values define-syntaxes) + (loop s 'transparent-binding)] + [else + (loop s 'opaque)])]))) + +;; ---------------------------------------- + +(define (syntax-taint-mode-property s) + (or (syntax-property s 'taint-mode) + (syntax-property s 'certify-mode))) + +(define (syntax-remove-taint-dispatch-properties s) + (syntax-property-remove (syntax-property-remove s 'taint-mode) 'certify-mode)) diff --git a/racket/src/expander/syntax/taint.rkt b/racket/src/expander/syntax/taint.rkt new file mode 100644 index 0000000000..fa8f405c4e --- /dev/null +++ b/racket/src/expander/syntax/taint.rkt @@ -0,0 +1,117 @@ +#lang racket/base +(require "syntax.rkt" + "tamper.rkt" + "../common/set.rkt") + +(provide taint-content + + syntax-tainted? + syntax-clean? + syntax-arm + syntax-disarm + syntax-rearm + syntax-taint) + +(define-syntax struct-copy/t + (syntax-rules (syntax tamper) + [(struct-copy/t syntax s [tamper v]) + (let ([stx s]) + (struct-copy syntax stx + [scope-propagations+tamper + (let ([t v] + [p (syntax-scope-propagations+tamper stx)]) + (if (tamper? p) + t + ((propagation-set-tamper-ref p) p t)))]))])) + +(define (taint-content d) + (non-syntax-map d + (lambda (tail? x) x) + (lambda (sub-s) + (cond + [(tamper-tainted? (syntax-tamper sub-s)) sub-s] + [else (struct-copy/t syntax sub-s + [tamper + (tamper-tainted-for-content (syntax-content sub-s))])])))) + +(define (syntax-tainted? s) + (tamper-tainted? (syntax-tamper s))) + +(define (syntax-clean? s) + (tamper-clean? (syntax-tamper s))) + +(define (syntax-arm s insp) + (define t (syntax-tamper s)) + (cond + [(tamper-tainted? t) s] + [(and t + (or (set-member? t insp) + (for/or ([already-insp (in-set t)]) + (inspector-superior-or-same? already-insp insp)))) + s] + [else + (struct-copy/t syntax s + [tamper (set-add + (if t + (remove-inferior t insp) + (seteq)) + insp)])])) + + +(define (remove-inferior t insp) + (for/seteq ([already-insp (in-set t)] + #:unless (inspector-superior-or-same? insp already-insp)) + already-insp)) + +(define (syntax-disarm s + [insp #f]) ; #f => superior to all inspectors + (define t (syntax-tamper s)) + (cond + [(not (tamper-armed? t)) s] + [(not insp) + (struct-copy/t syntax s + [tamper #f])] + [else + (define new-t (remove-inferior t insp)) + (struct-copy/t syntax s + [tamper (and (not (set-empty? new-t)) + new-t)])])) + +(define (syntax-rearm s from-s) + (define t (syntax-tamper s)) + (cond + [(tamper-tainted? t) s] + [else + (define from-t (syntax-tamper from-s)) + (cond + [(tamper-clean? from-t) s] + [(tamper-tainted? from-t) + (struct-copy/t syntax s + [tamper (tamper-tainted-for-content (syntax-content s))])] + [(tamper-clean? t) + (struct-copy/t syntax s + [tamper from-t])] + [else + (struct-copy/t syntax s + [tamper (for/fold ([t t]) ([from-i (in-set from-t)]) + (cond + [(set-member? t from-i) t] + [(any-superior? t from-i) t] + [else (set-add (remove-inferior t from-i) + from-i)]))])])])) + +(define (syntax-taint s) + (if (tamper-tainted? (syntax-tamper s)) + s + (struct-copy/t syntax s + [tamper (tamper-tainted-for-content (syntax-content s))]))) + +;; ---------------------------------------- + +(define (any-superior? t from-i) + (for/or ([i (in-set t)]) + (inspector-superior-or-same? i from-i))) + +(define (inspector-superior-or-same? sup-i i) + (or (eq? sup-i i) + (inspector-superior? sup-i i))) diff --git a/racket/src/expander/syntax/tamper.rkt b/racket/src/expander/syntax/tamper.rkt new file mode 100644 index 0000000000..13fc082fb7 --- /dev/null +++ b/racket/src/expander/syntax/tamper.rkt @@ -0,0 +1,60 @@ +#lang racket/base +(require "../common/set.rkt" + "datum-map.rkt") + +(provide tamper? + tamper-tainted? + tamper-armed? + tamper-clean? + tamper-tainted-for-content + tamper-needs-propagate? + tamper-propagated + + serialize-tamper + deserialize-tamper + current-arm-inspectors) + +;; A tamper status is either +;; * #f - clean +;; * 'tainted - tainted +;; * 'tainted/need-propagate - tainted, and taint needs to be propagated to children +;; * a set of inspectors - armed with a dye pack that is removable with those inspectors + +(define (tamper? v) + (or (not v) (symbol? v) (set? v))) + +(define (tamper-tainted? v) + (symbol? v)) + +(define (tamper-armed? v) + (set? v)) + +(define (tamper-clean? v) + (not v)) + +(define (tamper-tainted-for-content v) + (if (datum-has-elements? v) + 'tainted/need-propagate + 'tainted)) + +(define (tamper-needs-propagate? t) + (eq? t 'tainted/need-propagate)) + +(define (tamper-propagated t) + (if (eq? t 'tainted/need-propagate) + 'tainted + t)) + +;; ---------------------------------------- + +(define (serialize-tamper t) + ;; We can't serialize inspectors; any set of inspectors is replaced + ;; with the current inspector at deserialization time (which + ;; matches declaration time for a module) + (if (tamper-armed? t) 'armed t)) + +;; Set during deserialize to select a code inspector: +(define current-arm-inspectors (make-parameter (seteq))) + +(define (deserialize-tamper t) + (if (eq? t 'armed) (current-arm-inspectors) t)) diff --git a/racket/src/expander/syntax/to-list.rkt b/racket/src/expander/syntax/to-list.rkt new file mode 100644 index 0000000000..7c4ac5cbd3 --- /dev/null +++ b/racket/src/expander/syntax/to-list.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require "syntax.rkt" + "scope.rkt") + +(provide syntax->list) + +(define (syntax->list s) + (define l + (let loop ([s s]) + (cond + [(pair? s) (cons (car s) (loop (cdr s)))] + [(syntax? s) (loop (syntax-e s))] + [else s]))) + (and (list? l) + l)) diff --git a/racket/src/expander/syntax/track.rkt b/racket/src/expander/syntax/track.rkt new file mode 100644 index 0000000000..80ed797387 --- /dev/null +++ b/racket/src/expander/syntax/track.rkt @@ -0,0 +1,111 @@ +#lang racket/base +(require "syntax.rkt" + "scope.rkt" + "property.rkt" + "preserved.rkt") + +(provide syntax-track-origin + syntax-track-origin*) + +(define missing (gensym)) + +(define (syntax-track-origin new-stx old-stx [id (if (identifier? old-stx) + old-stx + (let ([v (syntax-e/no-taint old-stx)]) + (and (pair? v) + (car v))))]) + (define old-props (syntax-props old-stx)) + (cond + [(zero? (hash-count old-props)) + (if id + (syntax-property new-stx + 'origin + (cons id (hash-ref (syntax-props new-stx) 'origin null))) + new-stx)] + [else + (define new-props (syntax-props new-stx)) + (cond + [(zero? (hash-count new-props)) + (cond + [id + (define old-origin (plain-property-value + (hash-ref old-props 'origin missing))) + (define origin (if (eq? old-origin missing) + (list id) + (cons id old-origin))) + (struct-copy syntax new-stx + [props (hash-set old-props 'origin origin)])] + [else + (struct-copy syntax new-stx + [props old-props])])] + [else + ;; Merge properties + (define old-props-with-origin + (if id + (hash-set old-props 'origin (cons id (hash-ref old-props 'origin null))) + old-props)) + (define updated-props + (cond + [((hash-count old-props-with-origin) . < . (hash-count new-props)) + (for/fold ([new-props new-props]) ([(k v) (in-immutable-hash old-props-with-origin)]) + (define new-v (hash-ref new-props k missing)) + (hash-set new-props k (if (eq? new-v missing) + v + (cons/preserve new-v v))))] + [else + (for/fold ([old-props old-props-with-origin]) ([(k v) (in-immutable-hash new-props)]) + (define old-v (hash-ref old-props k missing)) + (hash-set old-props k (if (eq? old-v missing) + v + (cons/preserve v old-v))))])) + (struct-copy syntax new-stx + [props updated-props])])])) + +(define (cons/preserve a b) + (if (or (preserved-property-value? a) + (preserved-property-value? b)) + (preserved-property-value (cons (plain-property-value a) + (plain-property-value b))) + (cons a b))) + +(define (syntax-track-origin* old-stxes new-stx) + (for/fold ([new-stx new-stx]) ([old-stx (in-list old-stxes)]) + (syntax-track-origin new-stx old-stx))) + +(module+ test + (define (check-track new-props old-props expected-props-except-origin) + (define old-id (datum->syntax #f 'old)) + (define result-props (syntax-props + (syntax-track-origin + (struct-copy syntax (datum->syntax #f 'new) + [props new-props]) + (struct-copy syntax (datum->syntax #f (list old-id)) + [props old-props])))) + (unless (equal? result-props + (hash-update expected-props-except-origin 'origin + (lambda (v) + (if v + (cons (list old-id) v) + (list old-id))) + #f)) + (error "failed" new-props old-props result-props))) + + (check-track (hasheq 'a 1 'b 2) + (hasheq) + (hasheq 'a 1 'b 2)) + + (check-track (hasheq) + (hasheq 'a 3) + (hasheq 'a 3)) + + (check-track (hasheq 'a 1 'b 2) + (hasheq 'a 3) + (hasheq 'a (cons 1 3) 'b 2)) + + (check-track (hasheq 'a 3) + (hasheq 'a 1 'b 2) + (hasheq 'a (cons 3 1) 'b 2)) + + (check-track (hasheq 'a 3) + (hasheq 'a 1 'b 2) + (hasheq 'a (cons 3 1) 'b 2))) diff --git a/racket/src/foreign/foreign.c b/racket/src/foreign/foreign.c index 49a6762e62..69ce6f2ea8 100644 --- a/racket/src/foreign/foreign.c +++ b/racket/src/foreign/foreign.c @@ -1107,7 +1107,7 @@ static Scheme_Object *default_sym; static Scheme_Object *stdcall_sym; static Scheme_Object *sysv_sym; -static ffi_abi sym_to_abi(char *who, Scheme_Object *sym) +static ffi_abi sym_to_abi(const char *who, Scheme_Object *sym) { if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym)) return FFI_DEFAULT_ABI; @@ -1539,7 +1539,7 @@ int ffi_callback_FIXUP(void *p) { return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct)); } END_XFORM_SKIP; -#endif +#endif /* pointer to another ffi-callback for a curried callback */ /* The sync field: * NULL => non-atomic mode @@ -3481,13 +3481,18 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object /* data := {name, c-function, itypes, otype, cif} */ { Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + int curried = !SCHEME_VEC_ELS(data)[1] && !SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); const char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); - void *c_func = (void*)(SCHEME_VEC_ELS(data)[1]); + void *c_func = (curried + ? (void*)SCHEME_PRIM_CLOSURE_ELS(self)[1] + : (void*)(SCHEME_VEC_ELS(data)[1])); Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2]; Scheme_Object *otype = SCHEME_VEC_ELS(data)[3]; Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); - intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + intptr_t cfoff = (curried + ? SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(self)[2]) + : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5])); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); Scheme_Object *lock = SCHEME_VEC_ELS(data)[7]; #ifdef MZ_USE_PLACES @@ -3644,13 +3649,44 @@ void free_fficall_data(void *data, void *p) static Scheme_Object *ffi_name = NULL; -/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ -/* the real work is done by ffi_do_call above */ -#define MYNAME "ffi-call" -static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) +static Scheme_Object *make_ffi_call_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) { - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; + Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[3], *name, *itypes, *obj, *cp; + intptr_t ooff; + int nargs; + + cp = unwrap_cpointer_property(argv[0]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract("make-ffi-call", "(or/c ffi-obj? cpointer?)", 0, argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract("make-ffi-call", NON_NULL_CPOINTER, 0, argc, argv); + + name = SCHEME_VEC_ELS(data)[0]; + if (SCHEME_FFIOBJP(cp)) + name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); + + itypes = SCHEME_VEC_ELS(data)[2]; + + nargs = scheme_proper_list_length(itypes); + + a[0] = data; + a[1] = obj; + a[2] = scheme_make_integer_value(ooff); + + return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check, + 3, a, + SCHEME_BYTE_STR_VAL(name), + nargs, nargs); + +} + +static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1]; ffi_abi abi; intptr_t ooff; @@ -3664,57 +3700,63 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) # else /* MZ_USE_PLACES undefined */ # define FFI_CALL_VEC_SIZE 8 # endif /* MZ_USE_PLACES */ - cp = unwrap_cpointer_property(argv[0]); - if (!SCHEME_FFIANYPTRP(cp)) - scheme_wrong_contract(MYNAME, "(or/c ffi-obj? cpointer?)", 0, argc, argv); - obj = SCHEME_FFIANYPTR_VAL(cp); - ooff = SCHEME_FFIANYPTR_OFFSET(cp); - if ((obj == NULL) && (ooff == 0)) - scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv); + if (!curry) { + cp = unwrap_cpointer_property(argv[ARGPOS(0)]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract(who, "(or/c ffi-obj? cpointer?)", ARGPOS(0), argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract(who, NON_NULL_CPOINTER, 0, argc, argv); + } else { + cp = NULL; + obj = NULL; + ooff = 0; + } nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - if (argc > 4) { + abi = GET_ABI(who, ARGPOS(3)); + if (argc > ARGPOS(4)) { save_errno = -1; - if (SCHEME_FALSEP(argv[4])) + if (SCHEME_FALSEP(argv[ARGPOS(4)])) save_errno = 0; - else if (SCHEME_SYMBOLP(argv[4]) - && !SCHEME_SYM_WEIRDP(argv[4])) { - if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) + else if (SCHEME_SYMBOLP(argv[ARGPOS(4)]) + && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) { + if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix")) save_errno = 1; - else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) + else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows")) save_errno = 2; } if (save_errno == -1) { - scheme_wrong_contract(MYNAME, "(or/c 'posix 'windows #f)", 4, argc, argv); + scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv); } } else save_errno = 0; # if defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) - if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]); + if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]); else orig_place = 0; # endif /* defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL) */ - if (argc > 6) { - if (!SCHEME_FALSEP(argv[6])) { - if (!SCHEME_CHAR_STRINGP(argv[6])) - scheme_wrong_contract(MYNAME, "(or/c string? #f)", 4, argc, argv); - lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[6])); + if (argc > ARGPOS(6)) { + if (!SCHEME_FALSEP(argv[ARGPOS(6)])) { + if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)])) + scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv); + lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)])); } } - if (SCHEME_FFIOBJP(cp)) + if (cp && SCHEME_FFIOBJP(cp)) name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); else name = ffi_name; atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; i (in-types -> out-value) */ +/* the real work is done by ffi_do_call above */ +#define MYNAME "ffi-call" +static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) +{ + return ffi_call_or_curry(MYNAME, 0, argc, argv); +} +#undef MYNAME + +/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */ +/* Curried version of `ffi-call` */ +#define MYNAME "ffi-call-maker" +static Scheme_Object *foreign_ffi_call_maker(int argc, Scheme_Object *argv[]) +{ + return ffi_call_or_curry(MYNAME, 1, argc, argv); } #undef MYNAME @@ -3755,11 +3823,11 @@ static ffi_callback_struct *extract_ffi_callback(void *userdata) { void *tmp; tmp = *((void**)userdata); - data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp)); + data = (ffi_callback_struct *)SCHEME_WEAK_BOX_VAL(tmp); if (data == NULL) scheme_signal_error("callback lost"); } #else - data = (ffi_callback_struct*)userdata; + data = (ffi_callback_struct *)userdata; #endif return data; @@ -4016,15 +4084,12 @@ static void free_cl_cif_queue_args(void *ignored, void *p) } #endif -/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ -/* the treatment of in-types and out-types is similar to that in ffi-call */ -/* the real work is done by ffi_do_callback above */ -#define MYNAME "ffi-callback" -static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) -{ +/* In `curry` mode, just check arguments */ +static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) ffi_callback_struct *data; - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *sync; Scheme_Object *p, *base; ffi_abi abi; @@ -4071,22 +4136,28 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) int constant_reply_size = 0; # endif /* MZ_USE_MZRT */ - if (!SCHEME_PROCP(argv[0])) - scheme_wrong_contract(MYNAME, "procedure?", 0, argc, argv); + if (!curry && !SCHEME_PROCP(argv[ARGPOS(0)])) + scheme_wrong_contract(who, "procedure?", ARGPOS(0), argc, argv); nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4])); + abi = GET_ABI(who, ARGPOS(3)); + is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)])); sync = (is_atomic ? scheme_true : NULL); - if ((argc > 5) - && !SCHEME_BOXP(argv[5]) - && !scheme_check_proc_arity2(NULL, 1, 5, argc, argv, 1)) - scheme_wrong_contract(MYNAME, "(or/c #f (procedure-arity-includes/c 0) box?)", 5, argc, argv); - if (((argc > 5) && SCHEME_TRUEP(argv[5]))) { + if ((argc > ARGPOS(5)) + && !SCHEME_BOXP(argv[ARGPOS(5)]) + && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1)) + scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv); + + if (curry) { + /* all checks are done */ + return NULL; + } + + if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) { # ifdef MZ_USE_MZRT if (!ffi_sync_queue) { mzrt_os_thread_id tid; @@ -4100,20 +4171,20 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - if (SCHEME_BOXP(argv[5])) { + if (SCHEME_BOXP(argv[ARGPOS(5)])) { /* when called in a foreign thread, return a constant */ constant_reply_size = ctype_sizeof(otype); - if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[5]))) { + if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[ARGPOS(5)]))) { /* void result */ constant_reply = scheme_malloc_atomic(1); } else { /* non-void result */ constant_reply = scheme_malloc_atomic(constant_reply_size); - SCHEME2C(MYNAME, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[5]), NULL, NULL, 0); + SCHEME2C(who, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[ARGPOS(5)]), NULL, NULL, 0); } } else { /* when called in a foreign thread, queue a reply back here */ - sync = argv[5]; + sync = argv[ARGPOS(5)]; if (is_atomic) sync = scheme_box(sync); constant_reply = NULL; constant_reply_size = 0; @@ -4131,9 +4202,9 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); for (i=0, p=itypes; iso.type = ffi_callback_tag; data->callback = (cl_cif_args); - data->proc = (argv[0]); - data->itypes = (argv[1]); - data->otype = (argv[2]); + data->proc = ((curry ? NULL : argv[ARGPOS(0)])); + data->itypes = (argv[ARGPOS(1)]); + data->otype = (argv[ARGPOS(2)]); data->sync = (sync); # ifdef MZ_PRECISE_GC { @@ -4186,7 +4257,56 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) else # endif /* MZ_USE_MZRT */ scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); + return (Scheme_Object*)data; +#undef ARGPOS +} + +/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ +/* the treatment of in-types and out-types is similar to that in ffi-call */ +/* the real work is done by ffi_do_callback above */ +#define MYNAME "ffi-callback" +static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) +{ + return ffi_callback_or_curry(MYNAME, 0, argc, argv); +} +#undef MYNAME + +static Scheme_Object *make_ffi_callback_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) +{ + Scheme_Object *vec = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[6]; + int c = SCHEME_VEC_SIZE(vec), i; + + for (i = 0; i < c; i++) { + a[i+1] = SCHEME_VEC_ELS(vec)[i]; + } + a[0] = argv[0]; + + return ffi_callback_or_curry("make-ffi-callback", 0, c+1, a); +} + +/* (ffi-callback-maker in-types out-type [abi atomic? sync]) -> (proc -> ffi-callback) */ +/* Curried version of `ffi-callback`. Check arguments eagerly, but we don't do anything + otherwise until a function is available. */ +#define MYNAME "ffi-callback-maker" +static Scheme_Object *foreign_ffi_callback_maker(int argc, Scheme_Object *argv[]) +{ + int i; + Scheme_Object *vec, *a[1]; + + (void)ffi_callback_or_curry(MYNAME, 1, argc, argv); + + vec = scheme_make_vector(argc, NULL); + for (i = 0; i < argc; i++) { + SCHEME_VEC_ELS(vec)[i] = argv[i]; + } + a[0] = vec; + + return scheme_make_prim_closure_w_arity(make_ffi_callback_from_curried, + 1, a, + "make-ffi-callback", + 1, 1); } #undef MYNAME @@ -4638,8 +4758,6 @@ void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp) /*****************************************************************************/ /* Initialization */ -static Scheme_Env *ffi_env = NULL; - /* types need to be initialized before places can spawn * types become entries in the GC mark and fixup tables * this function should initialize read-only globals that can be @@ -4734,120 +4852,123 @@ Scheme_Object *scheme_uint32_ctype; Scheme_Object *scheme_int64_ctype; Scheme_Object *scheme_uint64_ctype; -void scheme_init_foreign(Scheme_Env *env) +void scheme_init_foreign(Scheme_Startup_Env *env) { - Scheme_Env *menv; ctype_struct *t; Scheme_Object *s; memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer)); - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); - scheme_add_global_constant("ffi-lib?", - scheme_make_immed_prim(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv); - scheme_add_global_constant("ffi-lib", - scheme_make_noncm_prim(foreign_ffi_lib, "ffi-lib", 1, 3), menv); - scheme_add_global_constant("ffi-lib-name", - scheme_make_noncm_prim(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), menv); - scheme_add_global_constant("ffi-obj?", - scheme_make_immed_prim(foreign_ffi_obj_p, "ffi-obj?", 1, 1), menv); - scheme_add_global_constant("ffi-obj", - scheme_make_noncm_prim(foreign_ffi_obj, "ffi-obj", 2, 2), menv); - scheme_add_global_constant("ffi-obj-lib", - scheme_make_immed_prim(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), menv); - scheme_add_global_constant("ffi-obj-name", - scheme_make_immed_prim(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), menv); - scheme_add_global_constant("ctype?", - scheme_make_immed_prim(foreign_ctype_p, "ctype?", 1, 1), menv); - scheme_add_global_constant("ctype-basetype", - scheme_make_immed_prim(foreign_ctype_basetype, "ctype-basetype", 1, 1), menv); - scheme_add_global_constant("ctype-scheme->c", - scheme_make_immed_prim(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), menv); - scheme_add_global_constant("ctype-c->scheme", - scheme_make_immed_prim(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), menv); - scheme_add_global_constant("make-ctype", - scheme_make_noncm_prim(foreign_make_ctype, "make-ctype", 3, 3), menv); - scheme_add_global_constant("make-cstruct-type", - scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), menv); - scheme_add_global_constant("make-array-type", - scheme_make_noncm_prim(foreign_make_array_type, "make-array-type", 2, 2), menv); - scheme_add_global_constant("make-union-type", - scheme_make_noncm_prim(foreign_make_union_type, "make-union-type", 1, -1), menv); - scheme_add_global_constant("ffi-callback?", - scheme_make_immed_prim(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv); - scheme_add_global_constant("cpointer?", - scheme_make_immed_prim(foreign_cpointer_p, "cpointer?", 1, 1), menv); - scheme_add_global_constant("cpointer-tag", - scheme_make_inline_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv); - scheme_add_global_constant("set-cpointer-tag!", - scheme_make_inline_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv); - scheme_add_global_constant("cpointer-gcable?", - scheme_make_noncm_prim(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), menv); - scheme_add_global_constant("ctype-sizeof", - scheme_make_immed_prim(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv); - scheme_add_global_constant("ctype-alignof", - scheme_make_immed_prim(foreign_ctype_alignof, "ctype-alignof", 1, 1), menv); - scheme_add_global_constant("compiler-sizeof", - scheme_make_immed_prim(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv); - scheme_add_global_constant("malloc", - scheme_make_noncm_prim(foreign_malloc, "malloc", 1, 5), menv); - scheme_add_global_constant("end-stubborn-change", - scheme_make_noncm_prim(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv); - scheme_add_global_constant("free", - scheme_make_noncm_prim(foreign_free, "free", 1, 1), menv); - scheme_add_global_constant("malloc-immobile-cell", - scheme_make_immed_prim(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), menv); - scheme_add_global_constant("free-immobile-cell", - scheme_make_noncm_prim(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), menv); - scheme_add_global_constant("ptr-add", - scheme_make_noncm_prim(foreign_ptr_add, "ptr-add", 2, 3), menv); - scheme_add_global_constant("ptr-add!", - scheme_make_noncm_prim(foreign_ptr_add_bang, "ptr-add!", 2, 3), menv); - scheme_add_global_constant("offset-ptr?", - scheme_make_noncm_prim(foreign_offset_ptr_p, "offset-ptr?", 1, 1), menv); - scheme_add_global_constant("ptr-offset", - scheme_make_noncm_prim(foreign_ptr_offset, "ptr-offset", 1, 1), menv); - scheme_add_global_constant("set-ptr-offset!", - scheme_make_noncm_prim(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), menv); - scheme_add_global_constant("vector->cpointer", - scheme_make_immed_prim(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), menv); - scheme_add_global_constant("flvector->cpointer", - scheme_make_immed_prim(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), menv); - scheme_add_global_constant("extflvector->cpointer", - scheme_make_immed_prim(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), menv); - scheme_add_global_constant("memset", - scheme_make_noncm_prim(foreign_memset, "memset", 3, 5), menv); - scheme_add_global_constant("memmove", - scheme_make_noncm_prim(foreign_memmove, "memmove", 3, 6), menv); - scheme_add_global_constant("memcpy", - scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), menv); - scheme_add_global_constant("ptr-ref", - scheme_make_inline_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), menv); - scheme_add_global_constant("ptr-set!", - scheme_make_inline_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), menv); - scheme_add_global_constant("ptr-equal?", - scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), menv); - scheme_add_global_constant("make-sized-byte-string", - scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv); - scheme_add_global_constant("ffi-call", - scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 7), menv); - scheme_add_global_constant("ffi-callback", - scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), menv); - scheme_add_global_constant("saved-errno", - scheme_make_immed_prim(foreign_saved_errno, "saved-errno", 0, 1), menv); - scheme_add_global_constant("lookup-errno", - scheme_make_immed_prim(foreign_lookup_errno, "lookup-errno", 1, 1), menv); - scheme_add_global_constant("make-stubborn-will-executor", - scheme_make_immed_prim(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv); - scheme_add_global_constant("make-late-weak-box", - scheme_make_immed_prim(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), menv); - scheme_add_global_constant("make-late-weak-hasheq", - scheme_make_immed_prim(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), menv); + scheme_switch_prim_instance(env, "#%foreign"); + scheme_addto_prim_instance("ffi-lib?", + scheme_make_immed_prim(foreign_ffi_lib_p, "ffi-lib?", 1, 1), env); + scheme_addto_prim_instance("ffi-lib", + scheme_make_noncm_prim(foreign_ffi_lib, "ffi-lib", 1, 3), env); + scheme_addto_prim_instance("ffi-lib-name", + scheme_make_noncm_prim(foreign_ffi_lib_name, "ffi-lib-name", 1, 1), env); + scheme_addto_prim_instance("ffi-obj?", + scheme_make_immed_prim(foreign_ffi_obj_p, "ffi-obj?", 1, 1), env); + scheme_addto_prim_instance("ffi-obj", + scheme_make_noncm_prim(foreign_ffi_obj, "ffi-obj", 2, 2), env); + scheme_addto_prim_instance("ffi-obj-lib", + scheme_make_immed_prim(foreign_ffi_obj_lib, "ffi-obj-lib", 1, 1), env); + scheme_addto_prim_instance("ffi-obj-name", + scheme_make_immed_prim(foreign_ffi_obj_name, "ffi-obj-name", 1, 1), env); + scheme_addto_prim_instance("ctype?", + scheme_make_immed_prim(foreign_ctype_p, "ctype?", 1, 1), env); + scheme_addto_prim_instance("ctype-basetype", + scheme_make_immed_prim(foreign_ctype_basetype, "ctype-basetype", 1, 1), env); + scheme_addto_prim_instance("ctype-scheme->c", + scheme_make_immed_prim(foreign_ctype_scheme_to_c, "ctype-scheme->c", 1, 1), env); + scheme_addto_prim_instance("ctype-c->scheme", + scheme_make_immed_prim(foreign_ctype_c_to_scheme, "ctype-c->scheme", 1, 1), env); + scheme_addto_prim_instance("make-ctype", + scheme_make_noncm_prim(foreign_make_ctype, "make-ctype", 3, 3), env); + scheme_addto_prim_instance("make-cstruct-type", + scheme_make_noncm_prim(foreign_make_cstruct_type, "make-cstruct-type", 1, 3), env); + scheme_addto_prim_instance("make-array-type", + scheme_make_noncm_prim(foreign_make_array_type, "make-array-type", 2, 2), env); + scheme_addto_prim_instance("make-union-type", + scheme_make_noncm_prim(foreign_make_union_type, "make-union-type", 1, -1), env); + scheme_addto_prim_instance("ffi-callback?", + scheme_make_immed_prim(foreign_ffi_callback_p, "ffi-callback?", 1, 1), env); + scheme_addto_prim_instance("cpointer?", + scheme_make_immed_prim(foreign_cpointer_p, "cpointer?", 1, 1), env); + scheme_addto_prim_instance("cpointer-tag", + scheme_make_inline_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), env); + scheme_addto_prim_instance("set-cpointer-tag!", + scheme_make_inline_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), env); + scheme_addto_prim_instance("cpointer-gcable?", + scheme_make_noncm_prim(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), env); + scheme_addto_prim_instance("ctype-sizeof", + scheme_make_immed_prim(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), env); + scheme_addto_prim_instance("ctype-alignof", + scheme_make_immed_prim(foreign_ctype_alignof, "ctype-alignof", 1, 1), env); + scheme_addto_prim_instance("compiler-sizeof", + scheme_make_immed_prim(foreign_compiler_sizeof, "compiler-sizeof", 1, 1), env); + scheme_addto_prim_instance("malloc", + scheme_make_noncm_prim(foreign_malloc, "malloc", 1, 5), env); + scheme_addto_prim_instance("end-stubborn-change", + scheme_make_noncm_prim(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), env); + scheme_addto_prim_instance("free", + scheme_make_noncm_prim(foreign_free, "free", 1, 1), env); + scheme_addto_prim_instance("malloc-immobile-cell", + scheme_make_immed_prim(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), env); + scheme_addto_prim_instance("free-immobile-cell", + scheme_make_noncm_prim(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), env); + scheme_addto_prim_instance("ptr-add", + scheme_make_noncm_prim(foreign_ptr_add, "ptr-add", 2, 3), env); + scheme_addto_prim_instance("ptr-add!", + scheme_make_noncm_prim(foreign_ptr_add_bang, "ptr-add!", 2, 3), env); + scheme_addto_prim_instance("offset-ptr?", + scheme_make_noncm_prim(foreign_offset_ptr_p, "offset-ptr?", 1, 1), env); + scheme_addto_prim_instance("ptr-offset", + scheme_make_noncm_prim(foreign_ptr_offset, "ptr-offset", 1, 1), env); + scheme_addto_prim_instance("set-ptr-offset!", + scheme_make_noncm_prim(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), env); + scheme_addto_prim_instance("vector->cpointer", + scheme_make_immed_prim(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), env); + scheme_addto_prim_instance("flvector->cpointer", + scheme_make_immed_prim(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), env); + scheme_addto_prim_instance("extflvector->cpointer", + scheme_make_immed_prim(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), env); + scheme_addto_prim_instance("memset", + scheme_make_noncm_prim(foreign_memset, "memset", 3, 5), env); + scheme_addto_prim_instance("memmove", + scheme_make_noncm_prim(foreign_memmove, "memmove", 3, 6), env); + scheme_addto_prim_instance("memcpy", + scheme_make_noncm_prim(foreign_memcpy, "memcpy", 3, 6), env); + scheme_addto_prim_instance("ptr-ref", + scheme_make_inline_noncm_prim(foreign_ptr_ref, "ptr-ref", 2, 4), env); + scheme_addto_prim_instance("ptr-set!", + scheme_make_inline_noncm_prim(foreign_ptr_set_bang, "ptr-set!", 3, 5), env); + scheme_addto_prim_instance("ptr-equal?", + scheme_make_noncm_prim(foreign_ptr_equal_p, "ptr-equal?", 2, 2), env); + scheme_addto_prim_instance("make-sized-byte-string", + scheme_make_noncm_prim(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), env); + scheme_addto_prim_instance("ffi-call", + scheme_make_noncm_prim(foreign_ffi_call, "ffi-call", 3, 8), env); + scheme_addto_prim_instance("ffi-call-maker", + scheme_make_noncm_prim(foreign_ffi_call_maker, "ffi-call-maker", 2, 7), env); + scheme_addto_prim_instance("ffi-callback", + scheme_make_noncm_prim(foreign_ffi_callback, "ffi-callback", 3, 6), env); + scheme_addto_prim_instance("ffi-callback-maker", + scheme_make_noncm_prim(foreign_ffi_callback_maker, "ffi-callback-maker", 2, 5), env); + scheme_addto_prim_instance("saved-errno", + scheme_make_immed_prim(foreign_saved_errno, "saved-errno", 0, 1), env); + scheme_addto_prim_instance("lookup-errno", + scheme_make_immed_prim(foreign_lookup_errno, "lookup-errno", 1, 1), env); + scheme_addto_prim_instance("make-stubborn-will-executor", + scheme_make_immed_prim(foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), env); + scheme_addto_prim_instance("make-late-weak-box", + scheme_make_immed_prim(foreign_make_late_weak_box, "make-late-weak-box", 1, 1), env); + scheme_addto_prim_instance("make-late-weak-hasheq", + scheme_make_immed_prim(foreign_make_late_weak_hasheq, "make-late-weak-hasheq", 0, 0), env); s = scheme_intern_symbol("void"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_void)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_void); - scheme_add_global_constant("_void", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_void", (Scheme_Object*)t, env); s = scheme_intern_symbol("int8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4856,7 +4977,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_int8); REGISTER_SO(scheme_int8_ctype); scheme_int8_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int8", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int8", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint8"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4865,7 +4986,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint8); REGISTER_SO(scheme_uint8_ctype); scheme_uint8_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint8", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint8", (Scheme_Object*)t, env); s = scheme_intern_symbol("int16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4874,7 +4995,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_int16); REGISTER_SO(scheme_int16_ctype); scheme_int16_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int16", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int16", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4883,7 +5004,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint16); REGISTER_SO(scheme_uint16_ctype); scheme_uint16_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint16", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint16", (Scheme_Object*)t, env); s = scheme_intern_symbol("int32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4892,7 +5013,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_int32); REGISTER_SO(scheme_int32_ctype); scheme_int32_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int32", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int32", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint32"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4901,7 +5022,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint32); REGISTER_SO(scheme_uint32_ctype); scheme_uint32_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint32", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint32", (Scheme_Object*)t, env); s = scheme_intern_symbol("int64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4910,7 +5031,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_int64); REGISTER_SO(scheme_int64_ctype); scheme_int64_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_int64", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_int64", (Scheme_Object*)t, env); s = scheme_intern_symbol("uint64"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4919,35 +5040,35 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_uint64); REGISTER_SO(scheme_uint64_ctype); scheme_uint64_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_uint64", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_uint64", (Scheme_Object*)t, env); s = scheme_intern_symbol("fixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixint); - scheme_add_global_constant("_fixint", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_fixint", (Scheme_Object*)t, env); s = scheme_intern_symbol("ufixint"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_uint32)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixint); - scheme_add_global_constant("_ufixint", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_ufixint", (Scheme_Object*)t, env); s = scheme_intern_symbol("fixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_smzintptr)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fixnum); - scheme_add_global_constant("_fixnum", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_fixnum", (Scheme_Object*)t, env); s = scheme_intern_symbol("ufixnum"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_umzintptr)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_ufixnum); - scheme_add_global_constant("_ufixnum", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_ufixnum", (Scheme_Object*)t, env); s = scheme_intern_symbol("float"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4956,7 +5077,7 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_float); REGISTER_SO(scheme_float_ctype); scheme_float_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_float", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_float", (Scheme_Object*)t, env); s = scheme_intern_symbol("double"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -4965,70 +5086,70 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_double); REGISTER_SO(scheme_double_ctype); scheme_double_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_double", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_double", (Scheme_Object*)t, env); s = scheme_intern_symbol("longdouble"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_slongdouble)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_longdouble); - scheme_add_global_constant("_longdouble", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_longdouble", (Scheme_Object*)t, env); s = scheme_intern_symbol("double*"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_doubleS); - scheme_add_global_constant("_double*", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_double*", (Scheme_Object*)t, env); s = scheme_intern_symbol("bool"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_sint)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bool); - scheme_add_global_constant("_bool", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_bool", (Scheme_Object*)t, env); s = scheme_intern_symbol("stdbool"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_stdbool)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_stdbool); - scheme_add_global_constant("_stdbool", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_stdbool", (Scheme_Object*)t, env); s = scheme_intern_symbol("string/ucs-4"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); - scheme_add_global_constant("_string/ucs-4", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_string/ucs-4", (Scheme_Object*)t, env); s = scheme_intern_symbol("string/utf-16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); - scheme_add_global_constant("_string/utf-16", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_string/utf-16", (Scheme_Object*)t, env); s = scheme_intern_symbol("bytes"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); - scheme_add_global_constant("_bytes", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_bytes", (Scheme_Object*)t, env); s = scheme_intern_symbol("path"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); - scheme_add_global_constant("_path", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_path", (Scheme_Object*)t, env); s = scheme_intern_symbol("symbol"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_symbol); - scheme_add_global_constant("_symbol", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_symbol", (Scheme_Object*)t, env); s = scheme_intern_symbol("pointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -5037,45 +5158,36 @@ void scheme_init_foreign(Scheme_Env *env) t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer); REGISTER_SO(scheme_pointer_ctype); scheme_pointer_ctype = (Scheme_Object *)t; - scheme_add_global_constant("_pointer", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_pointer", (Scheme_Object*)t, env); s = scheme_intern_symbol("gcpointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer); - scheme_add_global_constant("_gcpointer", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_gcpointer", (Scheme_Object*)t, env); s = scheme_intern_symbol("scheme"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme); - scheme_add_global_constant("_scheme", (Scheme_Object*)t, menv); + scheme_addto_prim_instance("_scheme", (Scheme_Object*)t, env); s = scheme_intern_symbol("fpointer"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_fpointer); - scheme_add_global_constant("_fpointer", (Scheme_Object*)t, menv); - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + scheme_addto_prim_instance("_fpointer", (Scheme_Object*)t, env); + scheme_addto_prim_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } /*****************************************************************************/ #else /* DONT_USE_FOREIGN */ -static Scheme_Env *ffi_env = NULL; - int scheme_is_cpointer(Scheme_Object *cp) { return (SCHEME_FALSEP(cp) @@ -5110,145 +5222,141 @@ static Scheme_Object *foreign_make_stubborn_will_executor(int argc, Scheme_Objec void scheme_init_foreign(Scheme_Env *env) { /* Create a dummy module. */ - Scheme_Env *menv; - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); - scheme_add_global_constant("ffi-lib?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), menv); - scheme_add_global_constant("ffi-lib", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), menv); - scheme_add_global_constant("ffi-lib-name", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), menv); - scheme_add_global_constant("ffi-obj?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), menv); - scheme_add_global_constant("ffi-obj", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), menv); - scheme_add_global_constant("ffi-obj-lib", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), menv); - scheme_add_global_constant("ffi-obj-name", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), menv); - scheme_add_global_constant("ctype?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype?", 1, 1), menv); - scheme_add_global_constant("ctype-basetype", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), menv); - scheme_add_global_constant("ctype-scheme->c", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), menv); - scheme_add_global_constant("ctype-c->scheme", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), menv); - scheme_add_global_constant("make-ctype", - scheme_make_noncm_prim((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), menv); - scheme_add_global_constant("make-cstruct-type", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), menv); - scheme_add_global_constant("make-array-type", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), menv); - scheme_add_global_constant("make-union-type", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), menv); - scheme_add_global_constant("ffi-callback?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), menv); - scheme_add_global_constant("cpointer?", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), menv); - scheme_add_global_constant("cpointer-tag", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv); - scheme_add_global_constant("set-cpointer-tag!", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv); - scheme_add_global_constant("cpointer-gcable?", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), menv); - scheme_add_global_constant("ctype-sizeof", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), menv); - scheme_add_global_constant("ctype-alignof", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), menv); - scheme_add_global_constant("compiler-sizeof", - scheme_make_immed_prim((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), menv); - scheme_add_global_constant("malloc", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "malloc", 1, 5), menv); - scheme_add_global_constant("end-stubborn-change", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), menv); - scheme_add_global_constant("free", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free", 1, 1), menv); - scheme_add_global_constant("malloc-immobile-cell", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), menv); - scheme_add_global_constant("free-immobile-cell", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), menv); - scheme_add_global_constant("ptr-add", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), menv); - scheme_add_global_constant("ptr-add!", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), menv); - scheme_add_global_constant("offset-ptr?", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), menv); - scheme_add_global_constant("ptr-offset", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), menv); - scheme_add_global_constant("set-ptr-offset!", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), menv); - scheme_add_global_constant("vector->cpointer", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), menv); - scheme_add_global_constant("flvector->cpointer", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), menv); - scheme_add_global_constant("extflvector->cpointer", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), menv); - scheme_add_global_constant("memset", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memset", 3, 5), menv); - scheme_add_global_constant("memmove", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memmove", 3, 6), menv); - scheme_add_global_constant("memcpy", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), menv); - scheme_add_global_constant("ptr-ref", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), menv); - scheme_add_global_constant("ptr-set!", - scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), menv); - scheme_add_global_constant("ptr-equal?", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), menv); - scheme_add_global_constant("make-sized-byte-string", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), menv); - scheme_add_global_constant("ffi-call", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 7), menv); - scheme_add_global_constant("ffi-callback", - scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), menv); - scheme_add_global_constant("saved-errno", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "saved-errno", 0, 1), menv); - scheme_add_global_constant("lookup-errno", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), menv); - scheme_add_global_constant("make-stubborn-will-executor", - scheme_make_immed_prim((Scheme_Prim *)foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), menv); - scheme_add_global_constant("make-late-weak-box", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), menv); - scheme_add_global_constant("make-late-weak-hasheq", - scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), menv); - scheme_add_global_constant("_void", scheme_false, menv); - scheme_add_global_constant("_int8", scheme_false, menv); - scheme_add_global_constant("_uint8", scheme_false, menv); - scheme_add_global_constant("_int16", scheme_false, menv); - scheme_add_global_constant("_uint16", scheme_false, menv); - scheme_add_global_constant("_int32", scheme_false, menv); - scheme_add_global_constant("_uint32", scheme_false, menv); - scheme_add_global_constant("_int64", scheme_false, menv); - scheme_add_global_constant("_uint64", scheme_false, menv); - scheme_add_global_constant("_fixint", scheme_false, menv); - scheme_add_global_constant("_ufixint", scheme_false, menv); - scheme_add_global_constant("_fixnum", scheme_false, menv); - scheme_add_global_constant("_ufixnum", scheme_false, menv); - scheme_add_global_constant("_float", scheme_false, menv); - scheme_add_global_constant("_double", scheme_false, menv); - scheme_add_global_constant("_longdouble", scheme_false, menv); - scheme_add_global_constant("_double*", scheme_false, menv); - scheme_add_global_constant("_bool", scheme_false, menv); - scheme_add_global_constant("_stdbool", scheme_false, menv); - scheme_add_global_constant("_string/ucs-4", scheme_false, menv); - scheme_add_global_constant("_string/utf-16", scheme_false, menv); - scheme_add_global_constant("_bytes", scheme_false, menv); - scheme_add_global_constant("_path", scheme_false, menv); - scheme_add_global_constant("_symbol", scheme_false, menv); - scheme_add_global_constant("_pointer", scheme_false, menv); - scheme_add_global_constant("_gcpointer", scheme_false, menv); - scheme_add_global_constant("_scheme", scheme_false, menv); - scheme_add_global_constant("_fpointer", scheme_false, menv); - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + scheme_switch_prim_instance(env, "#%foreign"); + scheme_addto_primitive_instance("ffi-lib?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-lib?", 1, 1), env); + scheme_addto_primitive_instance("ffi-lib", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib", 1, 3), env); + scheme_addto_primitive_instance("ffi-lib-name", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-lib-name", 1, 1), env); + scheme_addto_primitive_instance("ffi-obj?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj?", 1, 1), env); + scheme_addto_primitive_instance("ffi-obj", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-obj", 2, 2), env); + scheme_addto_primitive_instance("ffi-obj-lib", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-lib", 1, 1), env); + scheme_addto_primitive_instance("ffi-obj-name", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-obj-name", 1, 1), env); + scheme_addto_primitive_instance("ctype?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype?", 1, 1), env); + scheme_addto_primitive_instance("ctype-basetype", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-basetype", 1, 1), env); + scheme_addto_primitive_instance("ctype-scheme->c", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-scheme->c", 1, 1), env); + scheme_addto_primitive_instance("ctype-c->scheme", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-c->scheme", 1, 1), env); + scheme_addto_primitive_instance("make-ctype", + scheme_make_noncm_prim((Scheme_Prim *)foreign_make_ctype, "make-ctype", 3, 3), env); + scheme_addto_primitive_instance("make-cstruct-type", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-cstruct-type", 1, 3), env); + scheme_addto_primitive_instance("make-array-type", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-array-type", 2, 2), env); + scheme_addto_primitive_instance("make-union-type", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-union-type", 1, -1), env); + scheme_addto_primitive_instance("ffi-callback?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ffi-callback?", 1, 1), env); + scheme_addto_primitive_instance("cpointer?", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), env); + scheme_addto_primitive_instance("cpointer-tag", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), env); + scheme_addto_primitive_instance("set-cpointer-tag!", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), env); + scheme_addto_primitive_instance("cpointer-gcable?", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), env); + scheme_addto_primitive_instance("ctype-sizeof", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), env); + scheme_addto_primitive_instance("ctype-alignof", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "ctype-alignof", 1, 1), env); + scheme_addto_primitive_instance("compiler-sizeof", + scheme_make_immed_prim((Scheme_Prim *)foreign_compiler_sizeof, "compiler-sizeof", 1, 1), env); + scheme_addto_primitive_instance("malloc", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "malloc", 1, 5), env); + scheme_addto_primitive_instance("end-stubborn-change", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "end-stubborn-change", 1, 1), env); + scheme_addto_primitive_instance("free", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free", 1, 1), env); + scheme_addto_primitive_instance("malloc-immobile-cell", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "malloc-immobile-cell", 1, 1), env); + scheme_addto_primitive_instance("free-immobile-cell", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "free-immobile-cell", 1, 1), env); + scheme_addto_primitive_instance("ptr-add", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add", 2, 3), env); + scheme_addto_primitive_instance("ptr-add!", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-add!", 2, 3), env); + scheme_addto_primitive_instance("offset-ptr?", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "offset-ptr?", 1, 1), env); + scheme_addto_primitive_instance("ptr-offset", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-offset", 1, 1), env); + scheme_addto_primitive_instance("set-ptr-offset!", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-ptr-offset!", 2, 3), env); + scheme_addto_primitive_instance("vector->cpointer", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), env); + scheme_addto_primitive_instance("flvector->cpointer", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), env); + scheme_addto_primitive_instance("extflvector->cpointer", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), env); + scheme_addto_primitive_instance("memset", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memset", 3, 5), env); + scheme_addto_primitive_instance("memmove", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memmove", 3, 6), env); + scheme_addto_primitive_instance("memcpy", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "memcpy", 3, 6), env); + scheme_addto_primitive_instance("ptr-ref", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-ref", 2, 4), env); + scheme_addto_primitive_instance("ptr-set!", + scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "ptr-set!", 3, 5), env); + scheme_addto_primitive_instance("ptr-equal?", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ptr-equal?", 2, 2), env); + scheme_addto_primitive_instance("make-sized-byte-string", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "make-sized-byte-string", 2, 2), env); + scheme_addto_primitive_instance("ffi-call", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call", 3, 8), env); + scheme_addto_primitive_instance("ffi-call-maker", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-call-maker", 2, 7), env); + scheme_addto_primitive_instance("ffi-callback", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback", 3, 6), env); + scheme_addto_primitive_instance("ffi-callback-maker", + scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "ffi-callback-maker", 2, 5), env); + scheme_addto_primitive_instance("saved-errno", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "saved-errno", 0, 1), env); + scheme_addto_primitive_instance("lookup-errno", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "lookup-errno", 1, 1), env); + scheme_addto_primitive_instance("make-stubborn-will-executor", + scheme_make_immed_prim((Scheme_Prim *)foreign_make_stubborn_will_executor, "make-stubborn-will-executor", 0, 0), env); + scheme_addto_primitive_instance("make-late-weak-box", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-box", 1, 1), env); + scheme_addto_primitive_instance("make-late-weak-hasheq", + scheme_make_immed_prim((Scheme_Prim *)unimplemented, "make-late-weak-hasheq", 0, 0), env); + scheme_add_global_constant("_void", scheme_false, env); + scheme_add_global_constant("_int8", scheme_false, env); + scheme_add_global_constant("_uint8", scheme_false, env); + scheme_add_global_constant("_int16", scheme_false, env); + scheme_add_global_constant("_uint16", scheme_false, env); + scheme_add_global_constant("_int32", scheme_false, env); + scheme_add_global_constant("_uint32", scheme_false, env); + scheme_add_global_constant("_int64", scheme_false, env); + scheme_add_global_constant("_uint64", scheme_false, env); + scheme_add_global_constant("_fixint", scheme_false, env); + scheme_add_global_constant("_ufixint", scheme_false, env); + scheme_add_global_constant("_fixnum", scheme_false, env); + scheme_add_global_constant("_ufixnum", scheme_false, env); + scheme_add_global_constant("_float", scheme_false, env); + scheme_add_global_constant("_double", scheme_false, env); + scheme_add_global_constant("_longdouble", scheme_false, env); + scheme_add_global_constant("_double*", scheme_false, env); + scheme_add_global_constant("_bool", scheme_false, env); + scheme_add_global_constant("_stdbool", scheme_false, env); + scheme_add_global_constant("_string/ucs-4", scheme_false, env); + scheme_add_global_constant("_string/utf-16", scheme_false, env); + scheme_add_global_constant("_bytes", scheme_false, env); + scheme_add_global_constant("_path", scheme_false, env); + scheme_add_global_constant("_symbol", scheme_false, env); + scheme_add_global_constant("_pointer", scheme_false, env); + scheme_add_global_constant("_gcpointer", scheme_false, env); + scheme_add_global_constant("_scheme", scheme_false, env); + scheme_add_global_constant("_fpointer", scheme_false, env); + scheme_addto_primitive_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } #endif diff --git a/racket/src/foreign/foreign.rktc b/racket/src/foreign/foreign.rktc index cde0f2f0ab..15fa556f0b 100755 --- a/racket/src/foreign/foreign.rktc +++ b/racket/src/foreign/foreign.rktc @@ -936,7 +936,7 @@ static void free_libffi_type_two_layers(void *ignored, void *p) @defsymbols[default stdcall sysv] -static ffi_abi sym_to_abi(char *who, Scheme_Object *sym) +static ffi_abi sym_to_abi(const char *who, Scheme_Object *sym) { if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym)) return FFI_DEFAULT_ABI; @@ -1316,9 +1316,9 @@ static int all_float_types(GC_CAN_IGNORE ffi_type *libffi_type) @cdefstruct[ffi-callback [] [callback "NON_GCBALE_PTR(void)"] [proc "Scheme_Object*"] - [itypes "Scheme_Object*"] - [otype "Scheme_Object*"] - [sync "Scheme_Object*"]] + [itypes "Scheme_Object*"] ;; NULL for a curried callback + [otype "Scheme_Object*"] ;;NULL for a curried callback */ + [sync "Scheme_Object*"]] /* pointer to another ffi-callback for a curried callback */ /* The sync field: * NULL => non-atomic mode @@ -2652,13 +2652,18 @@ static Scheme_Object *ffi_do_call(int argc, Scheme_Object *argv[], Scheme_Object /* data := {name, c-function, itypes, otype, cif} */ { Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + int curried = !SCHEME_VEC_ELS(data)[1] && !SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); const char *name = SCHEME_BYTE_STR_VAL(SCHEME_VEC_ELS(data)[0]); - void *c_func = (void*)(SCHEME_VEC_ELS(data)[1]); + void *c_func = (curried + ? (void*)SCHEME_PRIM_CLOSURE_ELS(self)[1] + : (void*)(SCHEME_VEC_ELS(data)[1])); Scheme_Object *itypes = SCHEME_VEC_ELS(data)[2]; Scheme_Object *otype = SCHEME_VEC_ELS(data)[3]; Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); - intptr_t cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + intptr_t cfoff = (curried + ? SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(self)[2]) + : SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5])); int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); Scheme_Object *lock = SCHEME_VEC_ELS(data)[7]; #ifdef MZ_USE_PLACES @@ -2815,11 +2820,44 @@ void free_fficall_data(void *data, void *p) static Scheme_Object *ffi_name = NULL; -/* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ -/* the real work is done by ffi_do_call above */ -@cdefine[ffi-call 3 7]{ - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; +static Scheme_Object *make_ffi_call_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) +{ + Scheme_Object *data = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[3], *name, *itypes, *obj, *cp; + intptr_t ooff; + int nargs; + + cp = unwrap_cpointer_property(argv[0]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract("make-ffi-call", "(or/c ffi-obj? cpointer?)", 0, argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract("make-ffi-call", NON_NULL_CPOINTER, 0, argc, argv); + + name = SCHEME_VEC_ELS(data)[0]; + if (SCHEME_FFIOBJP(cp)) + name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); + + itypes = SCHEME_VEC_ELS(data)[2]; + + nargs = scheme_proper_list_length(itypes); + + a[0] = data; + a[1] = obj; + a[2] = scheme_make_integer_value(ooff); + + return scheme_make_prim_closure_w_arity(ffi_do_call_after_stack_check, + 3, a, + SCHEME_BYTE_STR_VAL(name), + nargs, nargs); + +} + +static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *obj, *data, *p, *base, *cp, *name, *a[1]; ffi_abi abi; intptr_t ooff; @@ -2833,57 +2871,63 @@ static Scheme_Object *ffi_name = NULL; }{ @DEFINE{FFI_CALL_VEC_SIZE 8} } - cp = unwrap_cpointer_property(argv[0]); - if (!SCHEME_FFIANYPTRP(cp)) - scheme_wrong_contract(MYNAME, "(or/c ffi-obj? cpointer?)", 0, argc, argv); - obj = SCHEME_FFIANYPTR_VAL(cp); - ooff = SCHEME_FFIANYPTR_OFFSET(cp); - if ((obj == NULL) && (ooff == 0)) - scheme_wrong_contract(MYNAME, NON_NULL_CPOINTER, 0, argc, argv); + if (!curry) { + cp = unwrap_cpointer_property(argv[ARGPOS(0)]); + if (!SCHEME_FFIANYPTRP(cp)) + scheme_wrong_contract(who, "(or/c ffi-obj? cpointer?)", ARGPOS(0), argc, argv); + obj = SCHEME_FFIANYPTR_VAL(cp); + ooff = SCHEME_FFIANYPTR_OFFSET(cp); + if ((obj == NULL) && (ooff == 0)) + scheme_wrong_contract(who, NON_NULL_CPOINTER, 0, argc, argv); + } else { + cp = NULL; + obj = NULL; + ooff = 0; + } nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - if (argc > 4) { + abi = GET_ABI(who, ARGPOS(3)); + if (argc > ARGPOS(4)) { save_errno = -1; - if (SCHEME_FALSEP(argv[4])) + if (SCHEME_FALSEP(argv[ARGPOS(4)])) save_errno = 0; - else if (SCHEME_SYMBOLP(argv[4]) - && !SCHEME_SYM_WEIRDP(argv[4])) { - if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) + else if (SCHEME_SYMBOLP(argv[ARGPOS(4)]) + && !SCHEME_SYM_WEIRDP(argv[ARGPOS(4)])) { + if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "posix")) save_errno = 1; - else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) + else if (!strcmp(SCHEME_SYM_VAL(argv[ARGPOS(4)]), "windows")) save_errno = 2; } if (save_errno == -1) { - scheme_wrong_contract(MYNAME, "(or/c 'posix 'windows #f)", 4, argc, argv); + scheme_wrong_contract(who, "(or/c 'posix 'windows #f)", ARGPOS(4), argc, argv); } } else save_errno = 0; @@IF{defined(MZ_USE_PLACES) && !defined(MZ_USE_FFIPOLL)}{ - if (argc > 5) orig_place = SCHEME_TRUEP(argv[5]); + if (argc > ARGPOS(5)) orig_place = SCHEME_TRUEP(argv[ARGPOS(5)]); else orig_place = 0; } - if (argc > 6) { - if (!SCHEME_FALSEP(argv[6])) { - if (!SCHEME_CHAR_STRINGP(argv[6])) - scheme_wrong_contract(MYNAME, "(or/c string? #f)", 4, argc, argv); - lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[6])); + if (argc > ARGPOS(6)) { + if (!SCHEME_FALSEP(argv[ARGPOS(6)])) { + if (!SCHEME_CHAR_STRINGP(argv[ARGPOS(6)])) + scheme_wrong_contract(who, "(or/c string? #f)", ARGPOS(6), argc, argv); + lock = name_to_ffi_lock(scheme_char_string_to_byte_string(argv[ARGPOS(6)])); } } - if (SCHEME_FFIOBJP(cp)) + if (cp && SCHEME_FFIOBJP(cp)) name = scheme_make_byte_string(((ffi_obj_struct*)(cp))->name); else name = ffi_name; atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; i (in-types -> out-value) */ +/* the real work is done by ffi_do_call above */ +@cdefine[ffi-call 3 8]{ + return ffi_call_or_curry(MYNAME, 0, argc, argv); +} + +/* (ffi-call-maker in-types out-type [abi save-errno? orig-place? lock-name blocking?]) -> (ffi->obj -> (in-types -> out-value)) */ +/* Curried version of `ffi-call` */ +@cdefine[ffi-call-maker 2 7]{ + return ffi_call_or_curry(MYNAME, 1, argc, argv); } /*****************************************************************************/ @@ -2923,11 +2988,11 @@ static ffi_callback_struct *extract_ffi_callback(void *userdata) { void *tmp; tmp = *((void**)userdata); - data = (ffi_callback_struct*)(SCHEME_WEAK_BOX_VAL(tmp)); + data = (ffi_callback_struct *)SCHEME_WEAK_BOX_VAL(tmp); if (data == NULL) scheme_signal_error("callback lost"); } #else - data = (ffi_callback_struct*)userdata; + data = (ffi_callback_struct *)userdata; #endif return data; @@ -3180,13 +3245,12 @@ static void free_cl_cif_queue_args(void *ignored, void *p) } #endif -/* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ -/* the treatment of in-types and out-types is similar to that in ffi-call */ -/* the real work is done by ffi_do_callback above */ -@cdefine[ffi-callback 3 6]{ +/* In `curry` mode, just check arguments */ +static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc, Scheme_Object **argv) { +# define ARGPOS(n) ((n) - (curry ? 1 : 0)) ffi_callback_struct *data; - Scheme_Object *itypes = argv[1]; - Scheme_Object *otype = argv[2]; + Scheme_Object *itypes = argv[ARGPOS(1)]; + Scheme_Object *otype = argv[ARGPOS(2)]; Scheme_Object *sync; Scheme_Object *p, *base; ffi_abi abi; @@ -3233,22 +3297,28 @@ static void free_cl_cif_queue_args(void *ignored, void *p) int constant_reply_size = 0; } - if (!SCHEME_PROCP(argv[0])) - scheme_wrong_contract(MYNAME, "procedure?", 0, argc, argv); + if (!curry && !SCHEME_PROCP(argv[ARGPOS(0)])) + scheme_wrong_contract(who, "procedure?", ARGPOS(0), argc, argv); nargs = scheme_proper_list_length(itypes); if (nargs < 0) - scheme_wrong_contract(MYNAME, "list?", 1, argc, argv); + scheme_wrong_contract(who, "list?", ARGPOS(1), argc, argv); if (NULL == (base = get_ctype_base(otype))) - scheme_wrong_contract(MYNAME, "ctype?", 2, argc, argv); + scheme_wrong_contract(who, "ctype?", ARGPOS(2), argc, argv); rtype = CTYPE_ARG_PRIMTYPE(base); - abi = GET_ABI(MYNAME,3); - is_atomic = ((argc > 4) && SCHEME_TRUEP(argv[4])); + abi = GET_ABI(who, ARGPOS(3)); + is_atomic = ((argc > ARGPOS(4)) && SCHEME_TRUEP(argv[ARGPOS(4)])); sync = (is_atomic ? scheme_true : NULL); - if ((argc > 5) - && !SCHEME_BOXP(argv[5]) - && !scheme_check_proc_arity2(NULL, 1, 5, argc, argv, 1)) - scheme_wrong_contract(MYNAME, "(or/c #f (procedure-arity-includes/c 0) box?)", 5, argc, argv); - if (((argc > 5) && SCHEME_TRUEP(argv[5]))) { + if ((argc > ARGPOS(5)) + && !SCHEME_BOXP(argv[ARGPOS(5)]) + && !scheme_check_proc_arity2(NULL, 1, ARGPOS(5), argc, argv, 1)) + scheme_wrong_contract(who, "(or/c #f (procedure-arity-includes/c 0) box?)", ARGPOS(5), argc, argv); + + if (curry) { + /* all checks are done */ + return NULL; + } + + if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) { @@IFDEF{MZ_USE_MZRT}{ if (!ffi_sync_queue) { mzrt_os_thread_id tid; @@ -3262,20 +3332,20 @@ static void free_cl_cif_queue_args(void *ignored, void *p) ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - if (SCHEME_BOXP(argv[5])) { + if (SCHEME_BOXP(argv[ARGPOS(5)])) { /* when called in a foreign thread, return a constant */ constant_reply_size = ctype_sizeof(otype); - if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[5]))) { + if (!constant_reply_size && SCHEME_VOIDP(SCHEME_BOX_VAL(argv[ARGPOS(5)]))) { /* void result */ constant_reply = scheme_malloc_atomic(1); } else { /* non-void result */ constant_reply = scheme_malloc_atomic(constant_reply_size); - SCHEME2C(MYNAME, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[5]), NULL, NULL, 0); + SCHEME2C(who, otype, constant_reply, 0, SCHEME_BOX_VAL(argv[ARGPOS(5)]), NULL, NULL, 0); } } else { /* when called in a foreign thread, queue a reply back here */ - sync = argv[5]; + sync = argv[ARGPOS(5)]; if (is_atomic) sync = scheme_box(sync); constant_reply = NULL; constant_reply_size = 0; @@ -3293,15 +3363,15 @@ static void free_cl_cif_queue_args(void *ignored, void *p) atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); for (i=0, p=itypes; i ffi-callback */ +/* the treatment of in-types and out-types is similar to that in ffi-call */ +/* the real work is done by ffi_do_callback above */ +@cdefine[ffi-callback 3 6]{ + return ffi_callback_or_curry(MYNAME, 0, argc, argv); +} + +static Scheme_Object *make_ffi_callback_from_curried(int argc, Scheme_Object *argv[], Scheme_Object *self) +{ + Scheme_Object *vec = SCHEME_PRIM_CLOSURE_ELS(self)[0]; + Scheme_Object *a[6]; + int c = SCHEME_VEC_SIZE(vec), i; + + for (i = 0; i < c; i++) { + a[i+1] = SCHEME_VEC_ELS(vec)[i]; + } + a[0] = argv[0]; + + return ffi_callback_or_curry("make-ffi-callback", 0, c+1, a); +} + +/* (ffi-callback-maker in-types out-type [abi atomic? sync]) -> (proc -> ffi-callback) */ +/* Curried version of `ffi-callback`. Check arguments eagerly, but we don't do anything + otherwise until a function is available. */ +@cdefine[ffi-callback-maker 2 5]{ + int i; + Scheme_Object *vec, *a[1]; + + (void)ffi_callback_or_curry(MYNAME, 1, argc, argv); + + vec = scheme_make_vector(argc, NULL); + for (i = 0; i < argc; i++) { + SCHEME_VEC_ELS(vec)[i] = argv[i]; + } + a[0] = vec; + + return scheme_make_prim_closure_w_arity(make_ffi_callback_from_curried, + 1, a, + "make-ffi-callback", + 1, 1); } /*****************************************************************************/ @@ -3552,8 +3666,6 @@ void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp) /*****************************************************************************/ /* Initialization */ -static Scheme_Env *ffi_env = NULL; - /* types need to be initialized before places can spawn * types become entries in the GC mark and fixup tables * this function should initialize read-only globals that can be @@ -3625,18 +3737,17 @@ static Scheme_Object *scheme_make_inline_noncm_prim(Scheme_Prim *prim, @list{Scheme_Object *scheme_@|exported|_ctype}) exported-types) -void scheme_init_foreign(Scheme_Env *env) +void scheme_init_foreign(Scheme_Startup_Env *env) { - Scheme_Env *menv; ctype_struct *t; Scheme_Object *s; memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer)); - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); + scheme_switch_prim_instance(env, "#%foreign"); @(maplines (lambda (x) (define-values (sname cfun min max kind) (apply values x)) - @list{scheme_add_global_constant("@sname", - scheme_make_@|kind|_prim(@cfun, "@sname", @min, @max), menv)}) + @list{scheme_addto_prim_instance("@sname", + scheme_make_@|kind|_prim(@cfun, "@sname", @min, @max), env)}) (reverse (cfunctions))) @(map-types ;; no need for these, at least for now: @@ -3652,24 +3763,15 @@ void scheme_init_foreign(Scheme_Env *env) scheme_@|stype|_ctype = (Scheme_Object *)t;} '("\n")) null)@; - scheme_add_global_constant("_@stype", (Scheme_Object*)t, menv)}) - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + scheme_addto_prim_instance("_@stype", (Scheme_Object*)t, env)}) + scheme_addto_prim_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } /*****************************************************************************/ #else /* DONT_USE_FOREIGN */ -static Scheme_Env *ffi_env = NULL; - int scheme_is_cpointer(Scheme_Object *cp) { return (SCHEME_FALSEP(cp) @@ -3711,25 +3813,17 @@ static Scheme_Object *foreign_make_stubborn_will_executor(int argc, Scheme_Objec void scheme_init_foreign(Scheme_Env *env) { /* Create a dummy module. */ - Scheme_Env *menv; - menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); + scheme_switch_prim_instance(env, "#%foreign"); @(maplines (lambda (x) (define-values (sname cfun min max kind) (apply values x)) - @list{scheme_add_global_constant("@sname", - scheme_make_@|kind|_prim((Scheme_Prim *)@(lookup cfun), "@sname", @min, @max), menv)}) + @list{scheme_addto_primitive_instance("@sname", + scheme_make_@|kind|_prim((Scheme_Prim *)@(lookup cfun), "@sname", @min, @max), env)}) (reverse (cfunctions))) @(map-types - @list{scheme_add_global_constant("_@stype", scheme_false, menv)}) - scheme_add_global_constant("prop:cpointer", scheme_cpointer_property, menv); - scheme_finish_primitive_module(menv); - scheme_protect_primitive_provide(menv, NULL); - MZ_REGISTER_STATIC(ffi_env); - ffi_env = menv; -} - -Scheme_Env *scheme_get_foreign_env() { - return ffi_env; + @list{scheme_add_global_constant("_@stype", scheme_false, env)}) + scheme_addto_primitive_instance("prop:cpointer", scheme_cpointer_property, env); + scheme_restore_prim_instance(env); } #endif diff --git a/racket/src/gracket/Makefile.in b/racket/src/gracket/Makefile.in index 6783a34ccc..a77884663b 100644 --- a/racket/src/gracket/Makefile.in +++ b/racket/src/gracket/Makefile.in @@ -89,6 +89,8 @@ LINKRESULT_wx_xt = gracket@CGC@ LINKRESULT_wx_mac = GRacket@CGC@.app/Contents/MacOS/GRacket@CGC@ LINKRESULT = $(LINKRESULT_@WXVARIANT@) +BOOT_SETUP = @BOOT_MODE@ $(srcdir)/../setup-go.rkt ../compiled + # Incremented each time the binaries change: DOWNLOAD_BIN_VERSION = 1 @@ -126,7 +128,8 @@ GRacket@CGC@.app/Contents/MacOS/GRacket@CGC@: $(MZFW) $(MRAPPSKEL) grmain.@LTO@ /usr/bin/install_name_tool -change "Racket.framework/Versions/$(FWVERSION)/Racket" "@executable_path/../../../../racket/Racket.framework/Versions/$(FWVERSION)/Racket" GRacket@CGC@.app/Contents/MacOS/GRacket@CGC@ $(MRAPPSKEL): $(srcdir)/../mac/osx_appl.rkt $(srcdir)/../racket/src/schvers.h $(srcdir)/../mac/icon/GRacket.icns - env BUILDBASE=.. @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) -cqu $(srcdir)/../mac/osx_appl.rkt $(srcdir)/.. "@CGC@" + env BUILDBASE=.. @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) -l- setup $(BOOT_SETUP) $(MRAPPSKEL) mrappskel.d $(srcdir)/../mac/osx_appl.rkt $(srcdir)/.. "@CGC@" +@INCLUDEDEP@ mrappskel.d ee-app: gracket grmain_ee.@LTO@ if [ "$(EEAPP)" = '' ] ; then echo "ERROR: You must specify EEAPP" ; else $(GRACKETLINKER) $(GRACKETLDFLAGS) $(MRSTATIC) -o $(EEAPP) grmain_ee.@LTO@ $(EEOBJECTS) $(GRACKETLDLIBS) $(MRSTATIC_STUB) ; fi diff --git a/racket/src/gracket/gc2/Makefile.in b/racket/src/gracket/gc2/Makefile.in index ea253661a9..cb4af63efd 100644 --- a/racket/src/gracket/gc2/Makefile.in +++ b/racket/src/gracket/gc2/Makefile.in @@ -56,11 +56,13 @@ MZMMM_wx_xt = @RUN_RACKET_MMM@ MZMMM_wx_mac = @RUN_RACKET_MMM@ MZMMM = $(MZMMM_@WXVARIANT@) -XFORM_CMD = $(MZMMM) $(SELF_RACKET_FLAGS) -cqu $(srcdir)/../../racket/gc2/xform.rkt --setup ../../racket/gc2 +SETUP_BOOT = -l- setup @BOOT_MODE@ $(srcdir)/../../setup-go.rkt ../../compiled + +XFORM_CMD = $(MZMMM) $(SELF_RACKET_FLAGS) $(SETUP_BOOT) --tag ++out $(srcdir)/../../racket/gc2/xform-mod.rkt XFORM_CPP_ARGS = -I$(srcdir)/../../racket/gc2 $(NOGCINC) $(OPTIONS) @PREFLAGS@ $(XFORM_INC_@WXVARIANT@) -XFORM = $(XFORM_CMD) --cpp "$(CPP) $(XFORM_CPP_ARGS)" @XFORMFLAGS@ -o -XFORMDEP = $(srcdir)/../../racket/gc2/xform.rkt $(srcdir)/../../racket/gc2/xform-mod.rkt $(srcdir)/../../racket/gc2/gc2.h +XFORM = $(XFORM_CMD) --cpp "$(CPP) $(XFORM_CPP_ARGS)" @XFORMFLAGS@ -o ++out +XFORMDEP = $(srcdir)/../../racket/gc2/xform-mod.rkt $(srcdir)/../../racket/gc2/gc2.h GRACKETLDFLAGS = $(LDFLAGS) -L../../racket @@ -72,6 +74,7 @@ XFORMWP = $(XFORM) xsrc/grmain.c: $(srcdir)/../grmain.c $(XFORMDEP) $(XFORMWP) xsrc/grmain.c $(DEF_C_DIRS) $(srcdir)/../grmain.c +@INCLUDEDEP@ grmain.d GCPREINC = -include $(srcdir)/../../racket/gc2/gc2.h POSTFLAGS = $(OPTIONS) @@ -116,7 +119,8 @@ $(MRFW) : $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../racket/libracket3m.@LIBSFX@ w $(GRACKETLINKER) $(LDFLAGS) -dynamiclib -o $(MRFW) -Wl,-headerpad_max_install_names $(XOBJS) $(@WXVARIANT@_PLAIN_OBJS) ../../racket/libracket3m.@LIBSFX@ $(@WXVARIANT@_LIBS) @X_EXTRA_LIBS@ wx_font.o wx_file_dialog.o $(MRAPPSKEL): $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../../racket/src/schvers.h $(srcdir)/../../mac/icon/GRacket.icns - env BUILDBASE=../.. BUILDING_3M=yes @RUN_RACKET_MMM@ $(SELF_RACKET_FLAGS) -cqu $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "@MMM@" + env BUILDBASE=../.. BUILDING_3M=yes @RUN_RACKET_MMM@ $(SELF_RACKET_FLAGS) $(SETUP_BOOT) $(MRAPPSKEL) mrappskel.d $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "@MMM@" +@INCLUDEDEP@ mrappskel.d ../gracket@MMM@@OSX@ : $(MAKE) ../GRacket@MMM@.app/Contents/MacOS/GRacket@MMM@ diff --git a/racket/src/gracket/grmain.c b/racket/src/gracket/grmain.c index 415ce62132..e5b02fb1f2 100644 --- a/racket/src/gracket/grmain.c +++ b/racket/src/gracket/grmain.c @@ -637,110 +637,4 @@ END_XFORM_SKIP; #endif -/***********************************************************************/ -/* X11 flag handling */ -/***********************************************************************/ - -#ifdef wx_xt - -typedef struct { - char *flag; - int arg_count; -} X_flag_entry; - -#define SINGLE_INSTANCE "-singleInstance" - -X_flag_entry X_flags[] = { - { "-display", 1 }, - { "-geometry", 1 }, - { "-bg", 1 }, - { "-background", 1 }, - { "-fg", 1 }, - { "-foreground", 1 }, - { "-fn", 1 }, - { "-font", 1 }, - { "-iconic", 0 }, - { "-name", 1 }, - { "-rv", 0 }, - { "-reverse", 0 }, - { "+rv", 0 }, - { "-selectionTimeout", 1 }, - { "-synchronous", 0 }, - { "-title", 1 }, - { "-xnllanguage", 1 }, - { "-xrm", 1 }, - { SINGLE_INSTANCE, 0}, - { NULL, 0 } -}; - -static int filter_x_readable(char **argv, int argc) - XFORM_SKIP_PROC -{ - int pos = 1, i; - - while (pos < argc) { - for (i = 0; X_flags[i].flag; i++) { - if (!strcmp(X_flags[i].flag, argv[pos])) - break; - } - - if (!X_flags[i].flag) - return pos; - else { - int newpos = pos + X_flags[i].arg_count + 1; - if (newpos > argc) { - printf("%s: X Window System flag \"%s\" expects %d arguments, %d provided\n", - argv[0], argv[pos], X_flags[i].arg_count, argc - pos - 1); - exit(-1); - } - pos = newpos; - } - } - - return pos; -} - -static void pre_filter_cmdline_arguments(int *argc, char ***argv) - XFORM_SKIP_PROC -{ - int pos; - char **naya; - - pos = filter_x_readable(*argv, *argc); - if (pos > 1) { - scheme_register_process_global("PLT_X11_ARGUMENT_COUNT", (void *)(intptr_t)pos); - scheme_register_process_global("PLT_X11_ARGUMENTS", *argv); - naya = malloc((*argc - (pos - 1)) * sizeof(char *)); - memcpy(naya, *argv + (pos - 1), (*argc - (pos - 1)) * sizeof(char *)); - naya[0] = (*argv)[0]; - *argv = naya; - *argc -= (pos - 1); - } -} - -#endif - -/***********************************************************************/ -/* Mac OS X flag handling */ -/***********************************************************************/ - -#ifdef wx_mac - -static void pre_filter_cmdline_arguments(int *argc, char ***argv) - XFORM_SKIP_PROC -{ - if ((*argc > 1) && !strncmp((*argv)[1], "-psn_", 5)) { - /* Finder adds "-psn_" when you double-click on the application. - Drop it. */ - char **new_argv; - new_argv = (char **)malloc(((*argc) - 1) * sizeof(char *)); - new_argv[0] = (*argv)[0]; - memcpy(new_argv + 1, (*argv) + 2, ((*argc) - 2) * sizeof(char *)); - (*argc)--; - *argv = new_argv; - } - scheme_register_process_global("PLT_IS_FOREGROUND_APP", (void *)(intptr_t)0x1); -} - -#endif - +#include "../start/gui_filter.inc" diff --git a/racket/src/io/Makefile b/racket/src/io/Makefile new file mode 100644 index 0000000000..e6866284d1 --- /dev/null +++ b/racket/src/io/Makefile @@ -0,0 +1,51 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion, and declaring "collect.rkt" pure works +# around a limitation of the flattener: +IGNORE = ++knot read - ++pure ../../collects/racket/private/collect.rkt + +# Can be set to empty to avoid building rktio +RKTIO_DEP=../build/so-rktio/Makefile + +io-src: $(RKTIO_DEP) + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) io-src-generate + +GENERATE_ARGS = -t main.rkt --submod main \ + --check-depends $(BUILDDIR)compiled/io-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + ++depend ../rktio/rktio.rktl \ + --depends $(BUILDDIR)compiled/io-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/io.rktl $(BUILDDIR)compiled/io.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/io.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +io-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(GENERATE_ARGS) + +demo: compiled/rktio.rktl + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +demo-thread: compiled/rktio.rktl + $(RACO) make demo-thread.rkt + $(RACKET) demo-thread.rkt + + +../build/so-rktio/Makefile: ../rktio/configure ../rktio/Makefile.in ../rktio/rktio_config.h.in + mkdir -p ../build/so-rktio + $(MAKE) build-rktio RACKET="`$(RACKET) ../cs/absify.rkt --exec $(RACKET)`" PREFIX="`$(RACKET) ../cs/absify.rkt ../..`" + +build-rktio: + cd ../build/so-rktio; ../../rktio/configure --enable-standalone --prefix=$(PREFIX) + cd ../build/so-rktio; make install-shared-object + + +.PHONY: io-src io-src-generate demo rktio build-rktio diff --git a/racket/src/io/README.txt b/racket/src/io/README.txt new file mode 100644 index 0000000000..d3807441b0 --- /dev/null +++ b/racket/src/io/README.txt @@ -0,0 +1,16 @@ +This package implements the port, path, encoding, printing, and +formatting layer. It can be run in a host Racket with `make demo`, but +it's meant to be compiled for use in Racket on Chez Scheme; see +"../cs/README.txt". + +Core error support must be provided as a more primitive layer, +including the exception structures and error functions that do not +involve formatting, such as `raise-argument-error`. The more primitive +layer should provide a `error-value->string-handler` paramemeter, but +this layer sets that parameter (so the primitive error function slike +`raise-argument-error` won't work right until this layer is loaded). + +Thread and event support is similarly provided as a more primitive +layer. Running `make demo` doesn't rely on that, while running `make +demo-thread` uses the thread implementation in "../thread" to +demonstrate cooperation between the layers. diff --git a/racket/src/io/bootstrap-main.rkt b/racket/src/io/bootstrap-main.rkt new file mode 100644 index 0000000000..0326ffbee8 --- /dev/null +++ b/racket/src/io/bootstrap-main.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "host/bootstrap.rkt" ; must be before "main.rkt" + "main.rkt") + +(provide (all-from-out "main.rkt")) diff --git a/racket/src/io/bootstrap-thread-main.rkt b/racket/src/io/bootstrap-thread-main.rkt new file mode 100644 index 0000000000..449ee869b8 --- /dev/null +++ b/racket/src/io/bootstrap-thread-main.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(require "host/bootstrap-thread.rkt" ; must be before "main.rkt" + "main.rkt" + "../thread/main.rkt") + +(provide (all-from-out "main.rkt") + (all-from-out "../thread/main.rkt")) diff --git a/racket/src/io/common/bytes-no-nuls.rkt b/racket/src/io/common/bytes-no-nuls.rkt new file mode 100644 index 0000000000..01a9d831ee --- /dev/null +++ b/racket/src/io/common/bytes-no-nuls.rkt @@ -0,0 +1,8 @@ +#lang racket/base + +(provide bytes-no-nuls?) + +(define (bytes-no-nuls? s) + (and (bytes? s) + (not (for/or ([c (in-bytes s)]) + (= c 0))))) diff --git a/racket/src/io/common/check.rkt b/racket/src/io/common/check.rkt new file mode 100644 index 0000000000..7c0c5af920 --- /dev/null +++ b/racket/src/io/common/check.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require "../../common/check.rkt" + (for-syntax racket/base)) + +(provide (all-from-out "../../common/check.rkt") + check-range + check-immutable-field) + +(define (check-range who start-pos end-pos max-end in-value) + (when (start-pos . > . max-end) + (raise-range-error who + "byte string" + "starting " + start-pos + in-value + 0 + max-end + #f)) + (when (or (end-pos . < . start-pos) + (end-pos . > . max-end)) + (raise-range-error who + "byte string" + "starting " + end-pos + in-value + 0 + max-end + start-pos))) + +(define (check-immutable-field who v sti) + (when (exact-integer? v) + (unless (memv v (list-ref sti 5)) + (raise-arguments-error who "field index not declared immutable" + "field index" v)))) diff --git a/racket/src/io/common/internal-error.rkt b/racket/src/io/common/internal-error.rkt new file mode 100644 index 0000000000..46b2936d5c --- /dev/null +++ b/racket/src/io/common/internal-error.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide internal-error) + +(define (internal-error msg) + (raise (exn:fail (string-append "internal error: " msg) + (current-continuation-marks)))) diff --git a/racket/src/io/common/resource.rkt b/racket/src/io/common/resource.rkt new file mode 100644 index 0000000000..4e4c57d31f --- /dev/null +++ b/racket/src/io/common/resource.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt") + +(provide call-with-resource) + +;; in atomic mode +;; +;; Calls `handle` in atomic mode, but expects any escape to be out of +;; atomic mode. +;; +;; The `destroy` function is called in atomic mode only if `handle` +;; hasn't returned by the time of an escape or thread kill and only if +;; the resource `r` is not a rktio error or a boxed rktio error. So, +;; at the point where `r` is destoyed by `handle`, `handle` must +;; return still in atomic mode to ensure that `destroy` is note +;; triggered. +;; +(define (call-with-resource r destroy handle) + (cond + [(or (rktio-error? r) + (and (box? r) + (rktio-error? (unbox r)))) + (handle r)] + [else + (define completed? #f) + (define (do-destroy) + (unless completed? + (destroy r))) + (thread-push-kill-callback! do-destroy) + (dynamic-wind + void + (lambda () + (begin0 + (handle r) + (set! completed? #t))) + (lambda () + ;; In case of an escape out of the body, we + ;; may not be in atomic mode: + (start-atomic) + (thread-pop-kill-callback!) + (do-destroy) + (end-atomic)))])) diff --git a/racket/src/io/common/set-two.rkt b/racket/src/io/common/set-two.rkt new file mode 100644 index 0000000000..7dca40a96f --- /dev/null +++ b/racket/src/io/common/set-two.rkt @@ -0,0 +1,14 @@ +#lang racket/base + +(provide bytes-set-two!) + +(define big-endian? (system-big-endian?)) + +(define (bytes-set-two! out-bstr j hi lo) + (cond + [big-endian? + (bytes-set! out-bstr j hi) + (bytes-set! out-bstr (+ j 1) lo)] + [else + (bytes-set! out-bstr j lo) + (bytes-set! out-bstr (+ j 1) hi)])) diff --git a/racket/src/io/converter/encoding.rkt b/racket/src/io/converter/encoding.rkt new file mode 100644 index 0000000000..9370bb580a --- /dev/null +++ b/racket/src/io/converter/encoding.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../string/convert.rkt" + "../locale/parameter.rkt") + +(provide encoding->bytes + locale-encoding-is-utf-8?) + +;; in atomic mode +(define (encoding->bytes who str) + (cond + [(equal? str "") + (locale-string-encoding/bytes)] + [else + (string->bytes/utf-8 str (char->integer #\?))])) diff --git a/racket/src/io/converter/main.rkt b/racket/src/io/converter/main.rkt new file mode 100644 index 0000000000..b1390bbd53 --- /dev/null +++ b/racket/src/io/converter/main.rkt @@ -0,0 +1,230 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "encoding.rkt" + "utf-8.rkt") + +(provide bytes-converter? + bytes-open-converter + bytes-close-converter + bytes-convert + bytes-convert-end) + +(struct bytes-converter ([c #:mutable] + [custodian-reference #:mutable])) + +;; The "-ish" variants allow unparied surrogates and the surrogates +;; encoded in the obvious extension of UTF-8. Those variants are +;; intended for converting to and from arbitrary 16-byte sequences, +;; which is useful for encoding Windows paths. +(define windows? (eq? 'windows (system-type))) +(define platform-utf-8 (if windows? 'utf-8-ish 'utf-8)) +(define platform-utf-8-permissive (if windows? 'utf-8-ish-permissive 'utf-8-permissive)) +(define platform-utf-16 (if windows? 'utf-16-ish 'utf-16)) + +(define/who (bytes-open-converter from-str to-str) + (check who string? from-str) + (check who string? to-str) + (cond + [(and (string=? from-str "UTF-8") (string=? to-str "UTF-8")) + (bytes-converter (utf-8-converter 'utf-8 'utf-8) + #f)] + [(and (string=? from-str "UTF-8-permissive") (string=? to-str "UTF-8")) + (bytes-converter (utf-8-converter 'utf-8-permissive 'utf-8) + #f)] + [(and (string=? from-str "platform-UTF-8") (string=? to-str "platform-UTF-16")) + (bytes-converter (utf-8-converter platform-utf-8 platform-utf-16) + #f)] + [(and (string=? from-str "platform-UTF-8-permissive") (string=? to-str "platform-UTF-16")) + (bytes-converter (utf-8-converter platform-utf-8-permissive platform-utf-16) + #f)] + [(and (string=? from-str "platform-UTF-16") (string=? to-str "platform-UTF-8")) + (bytes-converter (utf-8-converter platform-utf-16 platform-utf-8) + #f)] + ;; "UTF-8-ish" is also known as "WTF-8". + ;; "UTF-16-ish" is similar to UTF-16, but allows unpaired surrogates --- which is still + ;; different from UCS-2, since paired surrogates are decoded as in UTF-16. + [(and (string=? from-str "UTF-8-ish") (string=? to-str "UTF-16-ish")) + (bytes-converter (utf-8-converter 'utf-8-ish 'utf-16-ish) + #f)] + [(and (string=? from-str "UTF-8-ish-permissive") (string=? to-str "UTF-16-ish")) + (bytes-converter (utf-8-converter 'utf-8-ish-permissive 'utf-16-ish) + #f)] + [(and (string=? from-str "UTF-16-ish") (string=? to-str "UTF-8-ish")) + (bytes-converter (utf-8-converter 'utf-16-ish 'utf-8-ish) + #f)] + [(and (or (and (string=? from-str "UTF-8") (string=? to-str "")) + (and (string=? from-str "") (string=? to-str "UTF-8"))) + (locale-encoding-is-utf-8?)) + (bytes-converter (utf-8-converter 'utf-8 'utf-8) + #f)] + [else + (define props (rktio_convert_properties rktio)) + (cond + [(zero? (bitwise-and props RKTIO_CONVERTER_SUPPORTED)) + #f] + [else + (start-atomic) + (check-current-custodian who) + (define c (rktio_converter_open rktio + (encoding->bytes who to-str) + (encoding->bytes who from-str))) + (cond + [(rktio-error? c) + (end-atomic) + #; + (raise-rktio-error who c "failed") + #f] + [else + (define converter (bytes-converter c #f)) + (define cref (unsafe-custodian-register (current-custodian) converter close-converter #f #f)) + (set-bytes-converter-custodian-reference! converter cref) + (end-atomic) + converter])])])) + +;; ---------------------------------------- + +;; in atomic mode +(define (close-converter converter) + (define c (bytes-converter-c converter)) + (when c + (cond + [(utf-8-converter? c) (void)] + [else + (rktio_converter_close rktio c) + (unsafe-custodian-unregister converter (bytes-converter-custodian-reference converter))]) + (set-bytes-converter-c! converter #f))) + +(define/who (bytes-close-converter converter) + (check who bytes-converter? converter) + (atomically + (close-converter converter))) + +;; ---------------------------------------- + +(define/who (bytes-convert converter + src-bstr + [src-start-pos 0] + [src-end-pos (and (bytes? src-bstr) (bytes-length src-bstr))] + [dest-bstr #f] + [dest-start-pos 0] + [dest-end-pos (and (bytes? dest-bstr) (bytes-length dest-bstr))]) + (check who bytes-converter? converter) + (check who bytes? src-bstr) + (check who exact-nonnegative-integer? src-start-pos) + (check who exact-nonnegative-integer? src-end-pos) + (check who #:or-false bytes? dest-bstr) + (check who exact-nonnegative-integer? dest-start-pos) + (check who #:or-false exact-nonnegative-integer? dest-end-pos) + (check-range who src-start-pos src-end-pos (bytes-length src-bstr) src-bstr) + (check-dest-range who dest-bstr dest-start-pos dest-end-pos) + (do-convert who converter + src-bstr src-start-pos src-end-pos + dest-bstr dest-start-pos dest-end-pos + (if (not dest-bstr) + ;; guess at needed length + (max 1 (- src-end-pos src-start-pos)) + 1))) + +(define/who (bytes-convert-end converter + [dest-bstr #f] + [dest-start-pos 0] + [dest-end-pos (and (bytes? dest-bstr) (bytes-length dest-bstr))]) + (check who bytes-converter? converter) + (check who #:or-false bytes? dest-bstr) + (check who exact-nonnegative-integer? dest-start-pos) + (check who #:or-false exact-nonnegative-integer? dest-end-pos) + (check-dest-range who dest-bstr dest-start-pos dest-end-pos) + (define-values (bstr used status) + (do-convert who converter + #f 0 0 + dest-bstr dest-start-pos dest-end-pos + ;; guess at needed length + 6)) + (values bstr status)) + +(define (check-dest-range who dest-bstr dest-start-pos dest-end-pos) + (cond + [dest-bstr + (define len (bytes-length dest-bstr)) + (check-range who dest-start-pos (or dest-end-pos len) len dest-bstr)] + [dest-end-pos + (unless (dest-start-pos . <= . dest-end-pos) + (raise-arguments-error who "ending index is less than the starting index" + "staring index" dest-start-pos + "ending index" dest-end-pos))])) + +;; ---------------------------------------- + +(define (do-convert who converter + src-bstr src-start-pos src-end-pos + dest-bstr dest-start-pos dest-end-pos + guess-dest-size) + (start-atomic) + (define c (bytes-converter-c converter)) + (unless c + (end-atomic) + (raise-argument-error who "converter is closed" + "converter" converter)) + (define use-dest-bstr (or dest-bstr + (make-bytes (if dest-end-pos + (- dest-end-pos dest-start-pos) + guess-dest-size)))) + ;; Loop for the case that `dest-bstr` and `dest-end-pos` are #f, + ;; since we must grow output bytes as needed to consume all input + (let loop ([use-dest-bstr use-dest-bstr] + [src-start-pos src-start-pos] + [use-dest-start-pos (if dest-bstr dest-start-pos 0)] + [use-dest-end-pos (or (and dest-bstr dest-end-pos) (bytes-length use-dest-bstr))] + [in-already-consumed 0] + [out-already-produced 0]) + ;; Call the iconv-based converter or a utf-8-based converter: + (define-values (in-consumed out-produced err) + (convert-in c + src-bstr src-start-pos src-end-pos + use-dest-bstr use-dest-start-pos use-dest-end-pos)) + (cond + [(and (eqv? err RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE) + (not dest-bstr) + (not dest-end-pos)) + ;; grow the output vector and try to decode more + (define all-out-produced (+ out-produced out-already-produced)) + (define new-dest-bstr (make-bytes (* 2 (bytes-length use-dest-bstr)))) + (bytes-copy! new-dest-bstr 0 use-dest-bstr 0 all-out-produced) + (loop new-dest-bstr + (+ src-start-pos in-consumed) + all-out-produced + (bytes-length new-dest-bstr) + (+ in-consumed in-already-consumed) + all-out-produced)] + [else + ;; report results + (define all-out-produced (+ out-produced out-already-produced)) + (end-atomic) + (values (if dest-bstr + all-out-produced + (subbytes use-dest-bstr 0 all-out-produced)) + (+ in-already-consumed in-consumed) + (cond + [(eqv? err RKTIO_ERROR_CONVERT_BAD_SEQUENCE) 'error] + [(eqv? err RKTIO_ERROR_CONVERT_PREMATURE_END) 'aborts] + [(eqv? err RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE) 'continues] + [else 'complete]))]))) + +;; in atomic mode +(define (convert-in c src src-start src-end dest dest-start dest-end) + (cond + [(utf-8-converter? c) + (utf-8-convert-in c src src-start src-end dest dest-start dest-end)] + [else + (define r (rktio_convert_in rktio c src src-start src-end dest dest-start dest-end)) + (define v (rktio_convert_result_to_vector r)) + (rktio_free r) + (define in-consumed (vector-ref v 0)) + (define out-produced (vector-ref v 1)) + (define converted (vector-ref v 2)) + (define err (and (= converted RKTIO_CONVERT_ERROR) + (rktio_get_last_error rktio))) + (values in-consumed out-produced err)])) diff --git a/racket/src/io/converter/utf-8.rkt b/racket/src/io/converter/utf-8.rkt new file mode 100644 index 0000000000..53ca542f83 --- /dev/null +++ b/racket/src/io/converter/utf-8.rkt @@ -0,0 +1,307 @@ +#lang racket/base +(require (only-in "../host/rktio.rkt" + RKTIO_ERROR_CONVERT_BAD_SEQUENCE + RKTIO_ERROR_CONVERT_PREMATURE_END + RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE) + "../string/utf-8-encode.rkt" + "../common/set-two.rkt") + +(provide utf-8-converter + utf-8-converter? + utf-8-convert-in) + +(struct utf-8-converter (from to)) + +(define big-endian? (system-big-endian?)) + +(define (utf-8-convert-in c src src-start src-end dest dest-start dest-end) + (define from (utf-8-converter-from c)) + (define to (utf-8-converter-to c)) + (define-values (in-consumed out-produced status) + (if (or (eq? from 'utf-16) + (eq? from 'utf-16-ish)) + (utf-16-ish-reencode! src src-start src-end + dest dest-start dest-end + #:from-utf-16-ish? (eq? from 'utf-16-ish)) + (utf-8-ish-reencode! src src-start src-end + dest dest-start dest-end + #:permissive? (or (eq? from 'utf-8-permissive) + (eq? from 'utf-8-ish-permissive)) + #:from-utf-8-ish? (or (eq? from 'utf-8-ish) + (eq? from 'utf-8-ish-permissive)) + #:to-utf-16? (or (eq? to 'utf-16) + (eq? to 'utf-16-ish))))) + (values in-consumed + out-produced + (case status + [(error) RKTIO_ERROR_CONVERT_BAD_SEQUENCE] + [(aborts) RKTIO_ERROR_CONVERT_PREMATURE_END] + [(continues) RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE] + [else #f]))) + +;; Similar to `utf-8-decode` in "../string/utf-8-decode.rkt", but +;; "decodes" back to a byte string either as UTF-8 or UTF-16, and also +;; supports a "utf-8-ish" encoding that allows unpaired surrogates. +;; +;; There's a lot of similarly to the implementation of `utf-8-decode`, +;; but with enough differences to make abstraction difficult. +(define (utf-8-ish-reencode! in-bstr in-start in-end + out-bstr out-start out-end + #:permissive? permissive? + #:from-utf-8-ish? from-utf-8-ish? + #:to-utf-16? to-utf-16?) + (let loop ([i in-start] [j out-start] [base-i in-start] [accum 0] [remaining 0]) + + ;; Shared handling for encoding failures: + (define (encoding-failure) + (cond + [permissive? + ;; Try to write #\uFFFD, which is #"\357\277\275" in UTF-8 + (define (continue-after-permissive next-j) + (define next-i (add1 base-i)) + (cond + [(= next-j out-end) + (values (- next-i in-start) + (- next-j out-start) + 'continues)] + [else + (loop next-i next-j next-i 0 0)])) + (cond + [(and (not to-utf-16?) ((+ j 3) . <= . out-end)) + (bytes-set! out-bstr j #o357) + (bytes-set! out-bstr (+ j 1) #o277) + (bytes-set! out-bstr (+ j 2) #o275) + (continue-after-permissive (+ j 3))] + [(and to-utf-16? ((+ j 2) . <= . out-end)) + (bytes-set-two! out-bstr j #xFF #xFD) + (continue-after-permissive (+ j 2))] + [else + (values (- base-i in-start) + (- j out-start) + 'continues)])] + [else + (values (- base-i in-start) + (- j out-start) + 'error)])) + + ;; Shared handling for decoding success: + (define (continue next-j) + (define next-i (add1 i)) + (cond + [(= next-j out-end) + (values (- next-i in-start) + (- next-j out-start) + (if (= next-i in-end) + 'complete + 'continues))] + [else + (loop next-i next-j next-i 0 0)])) + + ;; Dispatch on byte: + (cond + [(= i in-end) + ;; End of input + (cond + [(zero? remaining) + (values (- base-i in-start) + (- j out-start) + 'complete)] + [else + (values (- base-i in-start) + (- j out-start) + 'aborts)])] + [else + (define b (bytes-ref in-bstr i)) + (cond + [(b . < . 128) + (cond + [(zero? remaining) + ;; Found ASCII + (cond + [(and (not to-utf-16?) + (j . < . out-end)) + (bytes-set! out-bstr j b) + (continue (add1 j))] + [((add1 j) . < . out-end) + (bytes-set-two! out-bstr j 0 b) + (continue (+ j 2))] + [else + (values (- base-i in-start) + (- j out-start) + 'continues)])] + [else + ;; We were accumulating bytes for an encoding, and + ;; the encoding didn't complete + (encoding-failure)])] + [else + ;; An encoding... + (cond + [(= #b10000000 (bitwise-and b #b11000000)) + ;; A continuation byte + (cond + [(zero? remaining) + ;; We weren't continuing + (encoding-failure)] + [else + (define next (bitwise-and b #b00111111)) + (define next-accum (+ (arithmetic-shift accum 6) next)) + (cond + [(= 1 remaining) + ;; This continuation byte finishes an encoding + (define v next-accum) + (define next-i (add1 i)) + (cond + [(v . < . 128) + ;; A shorter byte sequence would work + (encoding-failure)] + [(or from-utf-8-ish? + (not (or (v . > . #x10FFFF) + (and (v . >= . #xD800) + (v . <= . #xDFFF))))) + ;; A character to write, either in UTF-16 output for UTF-8 + (cond + [to-utf-16? + ;; Write one character in UTF-16 + (cond + [(and (v . < . #x10000) + ((+ j 2) . <= . out-end)) + ;; No need for a surrogate pair (so, 2 bytes) + (bytes-set-two! out-bstr j (arithmetic-shift v -8) (bitwise-and v #xFF)) + (continue (+ j 2))] + [((+ j 4) . <= . out-end) + ;; Write surrogate pair (as 4 bytes) + (define av (- v #x10000)) + (define hi (bitwise-ior #xD800 (bitwise-and (arithmetic-shift av -10) #x3FF))) + (define lo (bitwise-ior #xDC00 (bitwise-and av #x3FF))) + (bytes-set-two! out-bstr j (arithmetic-shift hi -8) (bitwise-and hi #xFF)) + (bytes-set-two! out-bstr (+ j 2) (arithmetic-shift lo -8) (bitwise-and lo #xFF)) + (continue (+ j 4))] + [else + ;; Not enought space for UTF-16 encoding + (values (- base-i in-start) + (- j out-start) + 'continues)])] + [else + ;; From UTF-8-to-UTF-8 with no "-ish" corrections, we can just copy + ;; the input encoding bytes to the output bytes + (let loop ([from-i base-i] [to-j j]) + (cond + [(= from-i next-i) + (continue to-j)] + [(= to-j out-end) + (values (- base-i in-start) + (- j out-start) + 'continues)] + [else + (bytes-set! out-bstr to-j (bytes-ref in-bstr from-i)) + (loop (add1 from-i) (add1 to-j))]))])] + [else + ;; Not a valid character --- an unpaired surrogate + ;; or too-large value in normal UTF-8 decoding (not UTF-8-ish) + (encoding-failure)])] + [(and (= 2 remaining) + (next-accum . <= . #b11111)) + ;; A shorter byte sequence would work + (encoding-failure)] + [(and (= 3 remaining) + (next-accum . <= . #b1111)) + ;; A shorter byte sequence would work + (encoding-failure)] + ;; We could check here for 3 remaining and `next-accum` + ;; >= #b100010000, which implies a result above #x10FFFF. + ;; The old decoder doesn't do that, and we'll stick to the + ;; old behavior for now + [else + ;; An encoding continues... + (loop (add1 i) j base-i next-accum (sub1 remaining))])])] + [(not (zero? remaining)) + ;; Trying to start a new encoding while one is in + ;; progress + (encoding-failure)] + [(= #b11000000 (bitwise-and b #b11100000)) + ;; Start a two-byte encoding + (define accum (bitwise-and b #b11111)) + ;; If `accum` is zero, that's an encoding mistake + (cond + [(zero? accum) (encoding-failure)] + [else (loop (add1 i) j i accum 1)])] + [(= #b11100000 (bitwise-and b #b11110000)) + ;; Start a three-byte encoding + (define accum (bitwise-and b #b1111)) + (loop (add1 i) j i accum 2)] + [(= #b11110000 (bitwise-and b #b11111000)) + ;; Start a four-byte encoding + (define accum (bitwise-and b #b111)) + (cond + [(accum . > . 4) + ;; Will be greater than #x10FFFF + (encoding-failure)] + [else + (loop (add1 i) j i accum 3)])] + [else + ;; Five- or six-byte encodings don't produce valid + ;; characters + (encoding-failure)])])]))) + +;; Converts UTF-16 into UTF-8 +(define (utf-16-ish-reencode! in-bstr in-start in-end + out-bstr out-start out-end + #:from-utf-16-ish? from-utf-16-ish?) + (let loop ([i in-start] [j out-start]) + (define (done status) + (values (- i in-start) + (- j out-start) + status)) + + (cond + [(= i in-end) + (done 'complete)] + [((+ i 2) . > . in-end) + (done 'aborts)] + [else + (define a (bytes-ref in-bstr i)) + (define b (bytes-ref in-bstr (add1 i))) + (define v (if big-endian? + (+ (arithmetic-shift a 8) b) + (+ (arithmetic-shift b 8) a))) + (define (continue v next-i) + (define (continue next-j) (loop next-i next-j)) + (utf-8-encode-dispatch v + in-start i + out-bstr out-start out-end j + continue)) + (cond + [(and (v . >= . #xD800) + (v . <= . #xDFFF)) + (cond + [(v . <= . #xDBFF) + ;; Look for surrogate pair + (cond + [((+ i 4) . > . in-end) + (done 'aborts)] + [else + (define a (bytes-ref in-bstr (+ i 2))) + (define b (bytes-ref in-bstr (+ i 3))) + (define v2 (if big-endian? + (+ (arithmetic-shift a 8) b) + (+ (arithmetic-shift b 8) a))) + (cond + [(and (v2 . >= . #xDC00) + (v2 . <= . #xDFFF)) + (define v3 (+ #x10000 + (bitwise-ior (arithmetic-shift (bitwise-and v #x3FF) 10) + (bitwise-and v2 #x3FF)))) + (continue v3 (+ i 4))] + [from-utf-16-ish? + ;; continue anyway as as unpaired surrogate + (continue v (+ i 2))] + [else + (done 'error)])])] + [else + ;; unpaired surrogate + (cond + [from-utf-16-ish? + ;; continue anyway + (continue v (+ i 2))] + [else (done 'aborts)])])] + [else (continue v (+ i 2))])]))) diff --git a/racket/src/io/demo-thread.rkt b/racket/src/io/demo-thread.rkt new file mode 100644 index 0000000000..4fc14130cd --- /dev/null +++ b/racket/src/io/demo-thread.rkt @@ -0,0 +1,235 @@ +#lang racket/base +(require "bootstrap-thread-main.rkt" + (only-in racket/base + [current-directory host:current-directory] + [path->string host:path->string])) + +;; Don't use exceptions here; see "../thread/demo.rkt" + +(current-directory (host:path->string (host:current-directory))) + +(define done? #f) + +(define-syntax-rule (test expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))) + +(call-in-main-thread + (lambda () + + ;; Make `N` threads trying to write `P` copies + ;; of each possible byte into a limited pipe, and + ;; make `N` other threads try to read those bytes. + (let () + (define N 8) + (define M (/ 256 N)) + (define P 1) + (define-values (in out) (make-pipe N)) + (test #f (byte-ready? in)) + (test out (sync/timeout #f out)) + (test N (write-bytes (make-bytes N 42) out)) + (test #t (byte-ready? in)) + (test #f (sync/timeout 0 out)) + (test 42 (read-byte in)) + (test #t (byte-ready? in)) + (test out (sync/timeout #f out)) + (write-byte 42 out) + (test #f (sync/timeout 0 out)) + (test (make-bytes N 42) (read-bytes N in)) + (test #f (byte-ready? in)) + (test out (sync/timeout #f out)) + (define vec (make-vector 256)) + (define lock-vec (for/vector ([i 256]) (make-semaphore 1))) + (define out-ths + (for/list ([i N]) + (thread (lambda () + (for ([k P]) + (for ([j M]) + (write-byte (+ j (* i M)) out))))))) + (define in-ths + (for/list ([i N]) + (thread (lambda () + (for ([k P]) + (for ([j M]) + (define v (read-byte in)) + (semaphore-wait (vector-ref lock-vec v)) + (vector-set! vec v (add1 (vector-ref vec v))) + (semaphore-post (vector-ref lock-vec v)))))))) + (map sync out-ths) + (map sync in-ths) + (for ([count (in-vector vec)]) + (unless (= count P) + (error "contended-pipe test failed")))) + + ;; Peeking effectively extends the buffer: + (let-values ([(in out) (make-pipe 3)]) + (test 3 (write-bytes-avail #"12345" out)) + (test #f (sync/timeout 0 out)) + (test #\1 (peek-char in)) + (test out (sync/timeout 0 out)) + (test 1 (write-bytes-avail #"12345" out)) + (test #f (sync/timeout 0 out)) + (test #\1 (peek-char in)) + (test 0 (write-bytes-avail* #"12345" out)) + (test #\2 (peek-char in 1)) + (test 1 (write-bytes-avail* #"12345" out)) + (let ([s (make-bytes 6 (char->integer #\-))]) + (test 5 (read-bytes-avail! s in)) + (test #"12311-" s)) + (test 3 (let loop ([n 0]) + (define v (write-bytes-avail* #"1234" out)) + (if (zero? v) + n + (loop (+ n v)))))) + + ;; Further test of peeking in a limited pipe (shouldn't get stuck): + (let-values ([(i o) (make-pipe 50)] + [(s) (make-semaphore)]) + (define t + (thread (lambda () + (peek-bytes 100 0 i) + (semaphore-wait s) + (peek-bytes 200 0 i)))) + (display (make-bytes 100 65) o) + (sync (system-idle-evt)) + (semaphore-post s) + (display (make-bytes 100 66) o) + (sync t)) + + ;; Check progress events + (define (check-progress-on-port make-in) + (define (check-progress dest-evt fail-dest-evt) + (define in (make-in)) ; content = #"hello" + (test #"he" (peek-bytes 2 0 in)) + (test #"hello" (peek-bytes 5 0 in)) + (test #"hel" (peek-bytes 3 0 in)) + (define progress1 (port-progress-evt in)) + ;(test #t (evt? progress1)) + (test #f (sync/timeout 0 progress1)) + (test #"hel" (peek-bytes 3 0 in)) + (test #f (sync/timeout 0 progress1)) + (test #f (port-commit-peeked 3 progress1 fail-dest-evt in)) + (test #"hel" (peek-bytes 3 0 in)) + (test #f (sync/timeout 0 progress1)) + (test #t (port-commit-peeked 3 progress1 dest-evt in)) + (test #"lo" (peek-bytes 2 0 in)) + (test progress1 (sync/timeout #f progress1)) + (test #f (port-commit-peeked 1 progress1 always-evt in)) + (close-input-port in)) + (check-progress always-evt never-evt) + (check-progress (make-semaphore 1) (make-semaphore 0)) + (check-progress (semaphore-peek-evt (make-semaphore 1)) (semaphore-peek-evt (make-semaphore 0))) + (let () + (define ch1 (make-channel)) + (define ch2 (make-channel)) + (thread (lambda () (channel-put ch1 'ok))) + (thread (lambda () (channel-get ch2))) + (sync (system-idle-evt)) + (check-progress ch1 ch2) + (check-progress (channel-put-evt ch2 'ok) (channel-put-evt ch1 'ok)))) + (check-progress-on-port + (lambda () + (define-values (in out) (make-pipe)) + (write-bytes #"hello" out) + in)) + (check-progress-on-port + (lambda () + (open-input-bytes #"hello"))) + (call-with-output-file "compiled/hello.txt" + (lambda (o) (write-bytes #"hello" o)) + 'truncate) + (check-progress-on-port + (lambda () + (open-input-file "compiled/hello.txt"))) + + (define (check-out-evt make-out [block #f] [unblock #f]) + (define o (make-out)) + (test #t (port-writes-atomic? o)) + (define evt (write-bytes-avail-evt #"hello" o)) + (test 5 (sync evt)) + (when block + (block o) + (define evt (write-bytes-avail-evt #"hello" o)) + (test #f (sync/timeout 0 evt)) + (test #f (sync/timeout 0.1 evt)) + (unblock) + (test #t (and (memq (sync evt) '(1 2 3 4 5)) #t))) + (close-output-port o)) + (let ([i #f]) + (check-out-evt (lambda () + (define-values (in out) (make-pipe 10)) + (set! i in) + out) + (lambda (o) + (write-bytes #"01234" o)) + (lambda () + (read-bytes 6 i)))) + (check-out-evt (lambda () + (open-output-bytes))) + (check-out-evt (lambda () + (open-output-file "compiled/hello.txt" 'truncate))) + + ;; Custodian shutdown closes port => don't run out of file descriptors + (for ([i 512]) + (define c (make-custodian)) + (parameterize ([current-custodian c]) + (for ([j 10]) + (open-input-file "compiled/hello.txt"))) + (custodian-shutdown-all c)) + + ;; TCP and accept evts + (parameterize ([current-custodian (make-custodian)]) + (define l (tcp-listen 59078 5 #t)) + (test #t (tcp-listener? l)) + + (define acc-evt (tcp-accept-evt l)) + (test #f (sync/timeout 0 acc-evt)) + + (define-values (ti to) (tcp-connect "localhost" 59078)) + + (define-values (tai tao) (apply values (sync acc-evt))) + + (test 6 (write-string "hello\n" to)) + (flush-output to) + (test "hello" (read-line tai)) + + (custodian-shutdown-all (current-custodian))) + + ;; UDP and evts + (define u1 (udp-open-socket)) + (test (void) (udp-bind! u1 #f 10768)) + + (define u2 (udp-open-socket)) + + (define bstr (make-bytes 10)) + (define r1-evt (udp-receive!-evt u1 bstr)) + + (test #f (sync/timeout 0 r1-evt)) + + (test (void) (sync (udp-send-to-evt u2 "localhost" 10768 #"hello"))) + + (let ([l (sync r1-evt)]) + (test 5 (car l)) + (test #"hello" (subbytes bstr 0 5))) + + (test #f (sync/timeout 0 r1-evt)) + (udp-close u1) + (udp-close u2) + + ;; Check some expected errors: + (printf "[two expected errors coming up...]\n") + (sync (thread (lambda () (sync r1-evt)))) + (sync (thread (lambda () (sync (udp-send-to-evt u2 "localhost" 10768 #""))))) + (printf "[two error messages about a UDP socket being closed were expected]\n") + + ;; ---------------------------------------- + + (printf "Enter to continue after confirming process sleeps...\n") + (read-line) + + (set! done? #t))) + +(unless done? + (error "main thread stopped running due to deadlock?")) diff --git a/racket/src/io/demo.rkt b/racket/src/io/demo.rkt new file mode 100644 index 0000000000..c16359a5f8 --- /dev/null +++ b/racket/src/io/demo.rkt @@ -0,0 +1,812 @@ +#lang racket/base +(require "bootstrap-main.rkt" + (only-in racket/base + [string->bytes/utf-8 host:string->bytes/utf-8] + [bytes->string/utf-8 host:bytes->string/utf-8] + [open-input-file host:open-input-file] + [close-input-port host:close-input-port] + [read-line host:read-line] + [read-byte host:read-byte] + [file-stream-buffer-mode host:file-stream-buffer-mode] + [port-count-lines! host:port-count-lines!] + [current-directory host:current-directory] + [path->string host:path->string])) + +(current-directory (host:path->string (host:current-directory))) +(set-string->number?! string->number) + +(define-syntax-rule (test expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))) + +(test #f (bytes-utf-8-ref #"\364\220\200\200" 0)) + +(test #t (file-exists? "demo.rkt")) +(test #f (file-exists? "compiled")) +(test #f (file-exists? "compiled/demo-file")) + +(test #t (directory-exists? "compiled")) +(test #f (directory-exists? "compiled/demo-dir")) + +(test #f (link-exists? "compiled")) +(test #f (link-exists? "compiled/demo-dir")) + +(call-with-output-file "compiled/demo-file" void) +(call-with-output-file "compiled/demo-file" void 'replace) +(let ([now (current-seconds)] + [f-now (file-or-directory-modify-seconds "compiled/demo-file")]) + (test #t (<= (- now 10) f-now now)) + (file-or-directory-modify-seconds "compiled/demo-file" (- now 5)) + (test (- now 5) (file-or-directory-modify-seconds "compiled/demo-file"))) +(rename-file-or-directory "compiled/demo-file" "compiled/demo-file2") +(delete-file "compiled/demo-file2") + +(test 88 (file-or-directory-modify-seconds "compiled/bad" #f (lambda () 88))) +(test 89 (file-or-directory-modify-seconds "compiled/bad" (current-seconds) (lambda () 89))) + +(test #t (and (memq 'read (file-or-directory-permissions "demo.rkt")) #t)) +(test #t (and (memq 'read (file-or-directory-permissions "compiled")) #t)) + +(printf "~s\n" (filesystem-root-list)) +(printf "~s\n" (directory-list)) +(make-directory "compiled/demo-dir") +(delete-directory "compiled/demo-dir") + +(printf "demo.rkt = ~s\n" (file-or-directory-identity "demo.rkt")) +(test (file-or-directory-identity "demo.rkt") (file-or-directory-identity "demo.rkt")) +(test #f (= (file-or-directory-identity "compiled") (file-or-directory-identity "demo.rkt"))) + +(test (call-with-input-file "demo.rkt" + (lambda (i) + (let loop ([n 0]) + (if (eof-object? (read-byte i)) + n + (loop (add1 n)))))) + (file-size "demo.rkt")) + +(copy-file "demo.rkt" "compiled/demo-copy" #t) +(test (file-size "demo.rkt") + (file-size "compiled/demo-copy")) +(test (file-or-directory-permissions "demo.rkt" 'bits) + (file-or-directory-permissions "compiled/demo-copy" 'bits)) +(delete-file "compiled/demo-copy") + +(make-file-or-directory-link "../demo.rkt" "compiled/also-demo.rkt") +(test #t (link-exists? "compiled/also-demo.rkt")) +(test (string->path "../demo.rkt") (resolve-path "compiled/also-demo.rkt")) +(delete-file "compiled/also-demo.rkt") +(test #f (link-exists? "compiled/also-demo.rkt")) + +(printf "~s\n" (expand-user-path "~/at-home")) + +(struct animal (name weight) + #:property prop:custom-write (lambda (v o mode) + (fprintf o "<~a>" (animal-name v)))) + +(test "1\n\rx0!\"hi\"" (format "1~%~ \n \rx~ ~o~c~s" 0 #\! "hi")) + +(test "*(1 2 3 apple\t\u0001 end file 1\"2\"3 #hash((a . 1) (b . 2)))*" + (format "*~a*" `(1 2 3 "apple\t\001" end ,(animal 'spot 155) ,(string->path "file") #"1\"2\"3" #hash((b . 2) (a . 1))))) +(test "*'(1 2 3 \"apple\\t\\u0001\" end #\"1\\\"2\\\"3\\t\\0010\")*" + (format "*~.v*" `(1 2 3 "apple\t\001" end ,(animal 'spot 155) #"1\"2\"3\t\0010"))) + +(fprintf (current-output-port) "*~v*" '!!!) +(newline) + +(test "no: hi 10" + (with-handlers ([exn:fail? exn-message]) + (error 'no "hi ~s" 10))) + +(test "error: format string requires 1 arguments, given 3" + (with-handlers ([exn:fail? exn-message]) + (error 'no "hi ~s" 1 2 3))) +(test "error: format string requires 2 arguments, given 1" + (with-handlers ([exn:fail? exn-message]) + (error 'no "hi ~s ~s" 8))) + +(define infinite-ones + (make-input-port 'ones + (lambda (s) + (bytes-set! s 0 (char->integer #\1)) + 1) + #f + void)) + +(test 49 (read-byte infinite-ones)) +(test #\1 (read-char infinite-ones)) +(test #"11111" (read-bytes 5 infinite-ones)) +(test #"11111" (peek-bytes 5 3 infinite-ones)) +(test #"11111" (read-bytes 5 infinite-ones)) +(test "11111" (read-string 5 infinite-ones)) + +(define fancy-infinite-ones + (make-input-port 'fancy-ones + (lambda (s) + (bytes-set! s 0 (char->integer #\1)) + 1) + (lambda (s skip progress-evt) + (bytes-set! s 0 (char->integer #\1)) + 1) + (lambda () (void)) + (lambda () (make-semaphore)) + (lambda (amt evt ext-evt) (make-bytes amt (char->integer #\1))) + (lambda () (values 7 42 1024)) + (lambda () (void)) + (lambda () 99) + (case-lambda + [() 'block] + [(m) (void)]))) +(test #"11111" (read-bytes 5 fancy-infinite-ones)) +(test #t (evt? (port-progress-evt fancy-infinite-ones))) +(test #t (port-commit-peeked 5 (port-progress-evt fancy-infinite-ones) always-evt fancy-infinite-ones)) +(test '(#f #f 99) (call-with-values (lambda () (port-next-location fancy-infinite-ones)) list)) +(port-count-lines! fancy-infinite-ones) +(test '(7 42 1024) (call-with-values (lambda () (port-next-location fancy-infinite-ones)) list)) +(test 98 (file-position fancy-infinite-ones)) +(test 'block (file-stream-buffer-mode fancy-infinite-ones)) +(test (void) (file-stream-buffer-mode fancy-infinite-ones 'none)) + +(define mod3-peeked? #f) +(define mod3-cycle/one-thread + (let* ([n 2] + [mod! (lambda (s delta) + (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3))) + 1)]) + (make-input-port + 'mod3-cycle/not-thread-safe + (lambda (s) + (set! n (modulo (add1 n) 3)) + (mod! s 0)) + (lambda (s skip progress-evt) + (set! mod3-peeked? #t) + (mod! s (add1 skip))) + void))) +(test "01201" (read-string 5 mod3-cycle/one-thread)) +(test #f mod3-peeked?) +(test "01201" (peek-string 5 (expt 2 5000) mod3-cycle/one-thread)) + +(let-values ([(r w) (make-pipe)]) + (write-byte 200 w) + (test #t (byte-ready? r)) + (test #f (char-ready? r))) + +(let () + (define-values (r w) (make-pipe)) + (define ch (make-channel)) + (display "hi" w) + (peek-byte r) + (let ([t (thread (lambda () + (port-commit-peeked 1 (port-progress-evt r) ch r)))]) + (sync (system-idle-evt)) + (let ([t2 + (thread (lambda () + (port-commit-peeked 1 (port-progress-evt r) ch r)))]) + (sync (system-idle-evt)) + (test #t (thread-running? t)) + (test #t (thread-running? t2)) + (thread-suspend t2) + (break-thread t2) + (kill-thread t) + (thread-resume t2) + (sleep))) + (test (char->integer #\h) (peek-byte r))) + +(let () + (define i (open-input-bytes #"apple")) + (test (char->integer #\a) (peek-byte i)) + (define threads + (for/list ([n (in-range 100)]) + (thread (lambda () (test #f (port-commit-peeked 1 (port-progress-evt i) (make-semaphore) i)))))) + (sync (system-idle-evt)) + (test #t (andmap thread-running? threads)) + (test (char->integer #\a) (read-byte i)) + (sync (system-idle-evt)) + (test #f (andmap thread-running? threads))) + +(define accum-list '()) +(define accum-sema (make-semaphore 1)) +(define (accum-ready?) (and (sync/timeout 0 (semaphore-peek-evt accum-sema)) #t)) +(define (maybe-accum-evt) + (if (zero? (random 2)) + (wrap-evt (semaphore-peek-evt accum-sema) (lambda (v) #f)) + #f)) +(define accum-o + (make-output-port 'accum + (semaphore-peek-evt accum-sema) + (lambda (bstr start end no-buffer/block? enable-break?) + (cond + [(accum-ready?) + (set! accum-list (cons (subbytes bstr start end) accum-list)) + (- end start)] + [else + (maybe-accum-evt)])) + void + (lambda (v no-buffer/block? enable-break?) + (cond + [(accum-ready?) + (set! accum-list (cons v accum-list)) + #t] + [else + (maybe-accum-evt)])) + (lambda (bstr start end) + (wrap-evt (semaphore-peek-evt accum-sema) + (lambda (a) + (set! accum-list (cons (subbytes bstr start end) accum-list)) + (- end start)))) + (lambda (v) + (wrap-evt (semaphore-peek-evt accum-sema) + (lambda (a) + (set! accum-list (cons v accum-list)) + #t))))) + +(test 5 (write-bytes #"hello" accum-o)) +(test '(#"hello") accum-list) +(test 0 (write-bytes #"" accum-o)) +(test '(#"hello") accum-list) +(test (void) (flush-output accum-o)) +(test '(#"" #"hello") accum-list) +(test 4 (sync (write-bytes-avail-evt #"hola!!" accum-o 0 4))) +(test '(#"hola" #"" #"hello") accum-list) +(test #t (port-writes-special? accum-o)) +(test #t (write-special 'howdy accum-o)) +(test '(howdy #"hola" #"" #"hello") accum-list) + +(set! accum-list '()) +(semaphore-wait accum-sema) +(test #f (sync/timeout 0 accum-o)) +(test 0 (write-bytes-avail* #"hello" accum-o)) +(test accum-list '()) +(semaphore-post accum-sema) +(test accum-o (sync/timeout 0 accum-o)) +(test 5 (write-bytes-avail* #"hello" accum-o)) +(test accum-list '(#"hello")) + +(define specialist + (let ([special + (lambda (source line col pos) + (list 'special source line col pos))]) + (make-input-port 'ones + (lambda (s) special) + (lambda (bstr skip-k p-evt) special) + void))) +(port-count-lines! specialist) + +(test '(special #f #f #f #f) (read-byte-or-special specialist)) +(test '#&(special src 1 1 2) (read-byte-or-special specialist box 'src)) +(test '(special #f #f #f #f) (peek-byte-or-special specialist)) +(test '#&(special src 1 2 3) (peek-byte-or-special specialist 0 #f box 'src)) + +(let-values ([(i o) (make-pipe)]) + (struct my-i (i) #:property prop:input-port 0) + (struct my-o (o) #:property prop:output-port 0) + (define c-i (let ([i (my-i i)]) + (make-input-port 'c-i i i void))) + (define c-o (let ([o (my-o o)]) + (make-output-port 'c-o o o void))) + (write-bytes #"hello" c-o) + (test #"hello" (read-bytes 5 c-i))) + +(test "apλple" (bytes->string/utf-8 (string->bytes/utf-8 "!!ap\u3BBple__" #f 2) #f 0 7)) +(test "ap?ple" (bytes->string/latin-1 (string->bytes/latin-1 "ap\u3BBple" (char->integer #\?)))) +(test "apλp\uF7F8\U00101234le" (bytes->string/utf-8 (string->bytes/utf-8 "ap\u3BBp\uF7F8\U101234le"))) +(test (string (integer->char #x10400)) (bytes->string/utf-8 #"\360\220\220\200")) + +(define apple (string->bytes/utf-8 "ap\u3BBple")) +(define elppa (list->bytes (reverse (bytes->list (string->bytes/utf-8 "ap\u3BBple"))))) + +(let () + (define-values (i o) (make-pipe)) + (for ([n 3]) + (write-bytes (make-bytes 4096 (char->integer #\a)) o) + (for ([j (in-range 4096)]) + (read-byte i)) + (unless (zero? (pipe-content-length i)) + (error "pipe loop failed\n")))) + +(define p (open-input-bytes apple)) +(define-values (i o) (make-pipe)) + +(void (write-bytes #"x" o)) +(test + 256 + (let loop ([x 1] [content '(#"x")] [accum null]) + (cond + [(= x 256) x] + [(null? content) + (loop x (reverse accum) null)] + [else + (define bstr (list->bytes + (for/list ([j (in-range x)]) + (modulo j 256)))) + (write-bytes bstr o) + (write-bytes bstr o) + (unless (equal? (read-bytes (bytes-length (car content)) i) + (car content)) + (error)) + (loop (add1 x) (cdr content) (list* bstr bstr accum))]))) + + +(let () + (define path (build-path "compiled" "demo-out")) + (define o (open-output-file path 'truncate)) + ;; We expect this to be buffered: + (test 12 (write-bytes #"abcdefghijkl" o)) + (test 12 (file-position o)) + (test (void) (file-position o 6)) + (test 3 (write-bytes #"xyz" o)) + (test (void) (file-position o eof)) + (test 1 (write-bytes #"!" o)) + (close-output-port o) + + (test 13 (file-size path)) + + (define i (open-input-file path)) + (test #"abcdefxyzjkl!" (read-bytes 20 i)) + (test (void) (file-position i 0)) + (test #"abcdef" (read-bytes 6 i)) + (test (void) (file-position i 9)) + (test #"jkl!" (read-bytes 6 i)) + (close-input-port i)) + +(let () + (define in (open-input-bytes #"hello")) + (test 0 (file-position in)) + (test #"hel" (read-bytes 3 in)) + (test 3 (file-position in)) + (test (void) (file-position in 2)) + (test #"llo" (read-bytes 3 in)) + (test 5 (file-position in)) + (test eof (read-bytes 3 in)) + (test 5 (file-position in)) + (test (void) (file-position in eof)) + (test 5 (file-position in)) + (test (void) (file-position in 100)) + (test 100 (file-position in))) + +(let () + (define out (open-output-bytes)) + (test 0 (file-position out)) + (write-bytes #"hello" out) + (test 5 (file-position out)) + (test (void) (file-position out 1)) + (test 1 (file-position out)) + (write-bytes #"ola" out) + (test 4 (file-position out)) + (test #"holao" (get-output-bytes out)) + (write-bytes #"!!" out) + (test 6 (file-position out)) + (test #"hola!!" (get-output-bytes out)) + (test (void) (file-position out 10)) + (test #"hola!!\0\0\0\0" (get-output-bytes out))) + +(let () + (define-values (i o) (make-pipe)) + (port-count-lines! i) + (port-count-lines! o) + (define (next-location p) + (define-values (line col pos) (port-next-location p)) + (list line col pos)) + (test '(1 0 1) (next-location i)) + (test '(1 0 1) (next-location o)) + + (write-bytes #"a\n b" o) + (test '(2 2 5) (next-location o)) + + (test #"a" (read-bytes 1 i)) + (test '(1 1 2) (next-location i)) + (test #"\n" (read-bytes 1 i)) + (test '(2 0 3) (next-location i)) + (test #" b" (read-bytes 2 i)) + (test '(2 2 5) (next-location i)) + + (write-bytes #"x\r" o) + (test '(3 0 7) (next-location o)) + (write-bytes #"\n" o) + (test '(3 0 7) (next-location o)) + (write-bytes #"!" o) + (test '(3 1 8) (next-location o)) + + (test #"x\r" (read-bytes 2 i)) + (test '(3 0 7) (next-location i)) + (test #"\n!" (read-bytes 2 i)) + (test '(3 1 8) (next-location i))) + +;; ---------------------------------------- + +(let ([c (bytes-open-converter "latin1" "UTF-8")]) + (test '(#"A\302\200" 2 complete) + (call-with-values (lambda () (bytes-convert c #"A\200")) list)) + (define bstr (make-bytes 3)) + (test '(3 2 complete) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 bstr)) list)) + (test #"A\302\200" bstr) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 #f 0 2)) list)) + (test '(#"A\302\200" 2 complete) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 2 #f 0 3)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\200" 0 1 #f 0 2)) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8" "latin1")]) + (test '(#"A\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list)) + (test '(#"A\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 2)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list)) + (test '(#"A" 1 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8" "UTF-8")]) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list)) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 3)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list)) + (test '(#"A" 1 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list)) + (test '(#"A" 1 error) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 3)) list)) + (test '(#"A" 1 error) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 2)) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 1)) list)) + (test '(#"\360\220\220\200" 4 complete) + (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8-permissive" "UTF-8")]) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 1)) list)) + (test '(#"A\302\200" 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 3 #f 0 3)) list)) + (test '(#"A" 1 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 1 #f 0 2)) list)) + (test '(#"A" 1 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\200" 0 2 #f 0 2)) list)) + (test '(#"A" 1 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 3)) list)) + (test '(#"A\357\277\275" 2 continues) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 4)) list)) + (test '(#"A\357\277\275" 2 aborts) + (call-with-values (lambda () (bytes-convert c #"A\302\302" 0 3 #f 0 5)) list)) + (test '(#"A\357\277\275" 2 continues) + (call-with-values (lambda () (bytes-convert c #"A\302x" 0 3 #f 0 4)) list)) + (test (void) (bytes-close-converter c))) + +(define (reorder little) + (if (system-big-endian?) + (let* ([len (bytes-length little)] + [bstr (make-bytes len)]) + (for ([i (in-range len)]) + (bytes-set! bstr i (bytes-ref little (bitwise-xor i 1))))) + little)) + +(let ([c (bytes-open-converter "platform-UTF-8" "platform-UTF-16")]) + (test `(,(reorder #"A\0\200\0") 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test `(,(reorder #"A\0") 1 error) + (call-with-values (lambda () (bytes-convert c #"A\200")) list)) + ;; unpaired high surrogate + (test `(#"" 0 error) + (call-with-values (lambda () (bytes-convert c #"\355\240\200")) list)) + ;; unpaired low surrogate + (test `(#"" 0 error) + (call-with-values (lambda () (bytes-convert c #"\355\260\201")) list)) + (test `(,(reorder #"\1\330\0\334") 4 complete) + (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-8-ish" "UTF-16-ish")]) + (test `(,(reorder #"A\0\200\0") 3 complete) + (call-with-values (lambda () (bytes-convert c #"A\302\200")) list)) + (test `(,(reorder #"A\0") 1 error) + (call-with-values (lambda () (bytes-convert c #"A\200")) list)) + ;; unpaired high surrogate + (test `(,(reorder #"\0\330") 3 complete) + (call-with-values (lambda () (bytes-convert c #"\355\240\200")) list)) + ;; unpaired low surrogate + (test `(,(reorder #"\1\334") 3 complete) + (call-with-values (lambda () (bytes-convert c #"\355\260\201")) list)) + ;; surrogate pair where each is separately encoded + (test `(,(reorder #"\0\330\1\334") 6 complete) + (call-with-values (lambda () (bytes-convert c #"\355\240\200\355\260\201")) list)) + (test `(,(reorder #"\1\330\0\334") 4 complete) + (call-with-values (lambda () (bytes-convert c #"\360\220\220\200")) list)) + (test (void) (bytes-close-converter c))) + +(let ([c (bytes-open-converter "UTF-16-ish" "UTF-8-ish")]) + (test `(#"A\302\200" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"A\0\200\0"))) list)) + ;; unpaired high surrogate + (test `(#"" 0 aborts) + (call-with-values (lambda () (bytes-convert c (reorder #"\0\330"))) list)) + (test `(#"\355\240\200X" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\0\330X\0"))) list)) + ;; unpaired low surrogate + (test `(#"\355\260\201" 2 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\1\334"))) list)) + (test `(#"\355\260\201X" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\1\334X\0"))) list)) + ;; surrogate pair + (test `(#"\360\220\200\201" 4 complete) + (call-with-values (lambda () (bytes-convert c (reorder #"\0\330\1\334"))) list)) + (test (void) (bytes-close-converter c))) + +;; ---------------------------------------- + +(parameterize ([current-locale "C"]) + (test #"A*Z" (string->bytes/locale "A\u3BBZ" 42))) + +;; Latin-1 +(parameterize ([current-locale "en_US.ISO8859-1"]) + (test #"!\xD6!" (string->bytes/locale "!\uD6!")) + (test "!\uD6!" (bytes->string/locale #"!\xD6!"))) + +(parameterize ([current-locale "en_US.UTF-8"]) + (test #f (string? "apple" "applex")) + +(test #t (string-locale? "apple\0x" "apple\0y")) + +(test #t (string-locale-ci=? "apple" "AppLE")) +(test #f (string-locale-ci=? "apple" "AppLEx")) + +(test #t (boolean? (string-localestring/utf-8 (string->bytes/utf-8 "ap\u3BBple")))) +(time + (for/fold ([v #f]) ([i (in-range 1000000)]) + (host:bytes->string/utf-8 (host:string->bytes/utf-8 "ap\u3BBple")))) + +(test "a" (read-line (open-input-string "a"))) +(test "a" (read-line (open-input-string "a\nb"))) +(test "a" (read-line (open-input-string "a\r\nb") 'any)) +(test "a" (read-line (open-input-string "a\rb") 'any)) + +(test #\l (bytes-utf-8-ref #"apple" 3)) +(test #\λ (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 2)) +(test #\p (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 3)) +(test #\l (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 3 #\? 1)) +(test #f (bytes-utf-8-ref (string->bytes/utf-8 "apλple") 6)) + +(test 3 (bytes-utf-8-index #"apple" 3)) +(test 4 (bytes-utf-8-index (string->bytes/utf-8 "apλple") 3)) diff --git a/racket/src/io/demo2.rkt b/racket/src/io/demo2.rkt new file mode 100644 index 0000000000..0a97fa3a22 --- /dev/null +++ b/racket/src/io/demo2.rkt @@ -0,0 +1,49 @@ +#lang racket/base + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.rktl")) + (port-count-lines! p) + (let loop () + (define s (read-string 100 p)) + (unless (eof-object? s) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.rktl")) + (port-count-lines! p) + (let loop () + (unless (eof-object? (read-byte p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) + +'read-line +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (host:open-input-file "compiled/io.rktl")) + (let loop () + (unless (eof-object? (host:read-line p)) + (loop))) + (host:close-input-port p) + (loop (sub1 j)))))) + +(time + (let loop ([j 10]) + (unless (zero? j) + (let () + (define p (open-input-file "compiled/io.rktl")) + (let loop () + (unless (eof-object? (read-line p)) + (loop))) + (close-input-port p) + (loop (sub1 j)))))) diff --git a/racket/src/io/envvar/main.rkt b/racket/src/io/envvar/main.rkt new file mode 100644 index 0000000000..84416b2e9a --- /dev/null +++ b/racket/src/io/envvar/main.rkt @@ -0,0 +1,125 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/rktio.rkt" + "../host/thread.rkt" + "../host/error.rkt" + "string.rkt") + +(provide environment-variables? + make-environment-variables + environment-variables-ref + current-environment-variables + environment-variables-set! + environment-variables-copy + environment-variables-names) + +(struct environment-variables ([ht #:mutable]) ; #f => use OS-level environment variables + #:authentic) + +(define/who current-environment-variables + (make-parameter (environment-variables #f) + (lambda (v) + (check who environment-variables? v) + v))) + +(define/who (make-environment-variables . args) + (let loop ([args args] [ht #hash()]) + (cond + [(null? args) (environment-variables ht)] + [else + (define key0 (car args)) + (define key (if (bytes? key0) + (bytes->immutable-bytes key0) + key0)) + (check who bytes-environment-variable-name? key) + (cond + [(null? args) + (raise-arguments-error who + "key does not have a value (i.e., an odd number of arguments were provided)" + "key" (car args))] + [else + (define val0 (cadr args)) + (define val (and (bytes? val0) + (bytes->immutable-bytes val0) + val0)) + (check who bytes-no-nuls? val) + (loop (cddr args) (hash-set ht (normalize-key key) val))])]))) + +(define/who (environment-variables-ref e k) + (check who environment-variables? e) + (check who bytes-environment-variable-name? k) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + (start-atomic) + (define v (rktio_getenv rktio k)) + (define s (and (not (rktio-error? v)) + (begin0 + (rktio_to_bytes v) + (rktio_free v)))) + (end-atomic) + s] + [else + (hash-ref ht (normalize-key k) #f)])) + +(define none (gensym 'none)) + +(define/who (environment-variables-set! e k0 v0 [fail none]) + (check who environment-variables? e) + (define k (if (bytes? k0) (bytes->immutable-bytes k0) k0)) + (check who bytes-environment-variable-name? k) + (define v (if (bytes? v0) (bytes->immutable-bytes v0) v0)) + (check who bytes-no-nuls? #:or-false v) + (unless (eq? fail none) + (check who (procedure-arity-includes/c 0) fail)) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + (define r (rktio_setenv rktio k v)) + (when (rktio-error? r) + (cond + [(eq? fail none) + (raise-rktio-error who r "change failed")] + [else (fail)]))] + [else + (define nk (normalize-key k)) + (set-environment-variables-ht! e (if v (hash-set ht nk v) (hash-remove ht nk)))])) + +(define/who (environment-variables-copy e) + (check who environment-variables? e) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + ;; Make a copy of current OS-level environment variables + (start-atomic) + (define ev (rktio_envvars rktio)) + (define ht + (cond + [(rktio-error? ev) #hash()] + [else + (begin0 + (for/hash ([i (in-range (rktio_envvars_count rktio ev))]) + (define k (rktio_envvars_name_ref rktio ev i)) + (define v (rktio_envvars_value_ref rktio ev i)) + (values + (begin0 + (bytes->immutable-bytes (rktio_to_bytes k)) + (rktio_free k)) + (begin0 + (bytes->immutable-bytes (rktio_to_bytes v)) + (rktio_free v)))) + (rktio_envvars_free rktio ev))])) + (end-atomic) + (environment-variables ht)] + [else + ;; Copy wrapper around immutable `ht`: + (environment-variables ht)])) + +(define/who (environment-variables-names e) + (check who environment-variables? e) + (define ht (environment-variables-ht e)) + (cond + [(not ht) + (environment-variables-names (environment-variables-copy e))] + [else + (hash-keys ht)])) diff --git a/racket/src/io/envvar/string.rkt b/racket/src/io/envvar/string.rkt new file mode 100644 index 0000000000..13a5737587 --- /dev/null +++ b/racket/src/io/envvar/string.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require "../common/bytes-no-nuls.rkt" + "../host/rktio.rkt") + +(provide bytes-no-nuls? + bytes-environment-variable-name? + normalize-key) + +(define (bytes-environment-variable-name? k) + (and (bytes-no-nuls? k) + (rktio_is_ok_envvar_name rktio k))) + +(define (normalize-key k) + (if (rktio_are_envvar_names_case_insensitive rktio) + (string->immutable-string (string-foldcase k)) + k)) diff --git a/racket/src/io/error/main.rkt b/racket/src/io/error/main.rkt new file mode 100644 index 0000000000..8ef4da9700 --- /dev/null +++ b/racket/src/io/error/main.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require "../port/string-port.rkt" + (submod "../print/main.rkt" internal) + "../format/printf.rkt") + +(provide error + raise-user-error + error-print-source-location) + +(define (error init . args) + (do-error 'error exn:fail init args)) + +(define (raise-user-error init . args) + (do-error 'raise-user-error exn:fail:user init args)) + +(define (do-error who exn:fail init args) + (cond + [(and (symbol? init) + (null? args)) + (raise + (exn:fail + (format "error: ~a" init) + (current-continuation-marks)))] + [(symbol? init) + (unless (string? (car args)) + (raise-argument-error who "string?" (car args))) + (define o (open-output-string)) + (do-printf who o (car args) (cdr args)) + (raise + (exn:fail + (string-append (symbol->string init) + ": " + (get-output-string o)) + (current-continuation-marks)))] + [(string? init) + (raise + (exn:fail + (apply string-append + init + (for/list ([arg (in-list args)]) + (string-append " " + ((error-value->string-handler) + arg + (error-print-width))))) + (current-continuation-marks)))] + [else + (raise-argument-error who "(or/c symbol? string?)" init)])) + +(define error-print-source-location + (make-parameter #t (lambda (v) (and v #t)))) + +;; Install the default error-value->string handler, +;; replacing the non-working primitive placeholder +(void + (error-value->string-handler + (lambda (v len) + (unless (exact-nonnegative-integer? len) + (raise-argument-error 'default-error-value->string-handler + "exact-nonnegative-integer?" + len)) + (define o (open-output-string)) + (do-global-print 'default-error-value->string-handler v o 0 len) + (get-output-string o)))) diff --git a/racket/src/io/file/error.rkt b/racket/src/io/file/error.rkt new file mode 100644 index 0000000000..9a432b548b --- /dev/null +++ b/racket/src/io/file/error.rkt @@ -0,0 +1,72 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt") + +(provide raise-filesystem-error + copy-file-step-string + + maybe-raise-missing-module + set-maybe-raise-missing-module!) + +(define (raise-filesystem-error who orig-err base-msg) + (define err (cond + [(racket-error? orig-err RKTIO_ERROR_EXISTS) + orig-err] + [else + (remap-rktio-error orig-err)])) + (define msg (cond + [(racket-error? err RKTIO_ERROR_EXISTS) + ;; don't add "system error", because it + ;; will be redundant + (if who + (string-append (symbol->string who) ": " base-msg) + base-msg)] + [else + (format-rktio-message who err base-msg)])) + (raise + (cond + [(racket-error? err RKTIO_ERROR_EXISTS) + (exn:fail:filesystem:exists + msg + (current-continuation-marks))] + [(not (eq? (rktio-errkind err) RKTIO_ERROR_KIND_RACKET)) + (exn:fail:filesystem:errno + msg + (current-continuation-marks) + (cons (rktio-errno err) + (let ([kind (rktio-errkind err)]) + (cond + [(eqv? kind RKTIO_ERROR_KIND_POSIX) 'posix] + [(eqv? kind RKTIO_ERROR_KIND_WINDOWS) 'windows] + [(eqv? kind RKTIO_ERROR_KIND_GAI) 'gai] + [else (error 'raise-filesystem-error "confused about rktio error")]))))] + [else + (exn:fail:filesystem + msg + (current-continuation-marks))]))) + +(define (copy-file-step-string err) + (cond + [(racket-error? err RKTIO_ERROR_EXISTS) + "destination exists"] + [else + (define step (vector-ref err 2)) + (cond + [(eqv? step RKTIO_COPY_STEP_OPEN_SRC) + "cannot open source file"] + [(eqv? step RKTIO_COPY_STEP_OPEN_DEST) + "cannot open destination file"] + [(eqv? step RKTIO_COPY_STEP_READ_SRC_DATA) + "error reading source file"] + [(eqv? step RKTIO_COPY_STEP_WRITE_DEST_DATA) + "error writing destination file"] + [(eqv? step RKTIO_COPY_STEP_READ_SRC_METADATA) + "error reading source-file metadata"] + [(eqv? step RKTIO_COPY_STEP_WRITE_DEST_METADATA) + "error writing destination-file metadata"] + [else "copy failed"])])) + +(define maybe-raise-missing-module void) + +(define (set-maybe-raise-missing-module! proc) + (set! maybe-raise-missing-module proc)) diff --git a/racket/src/io/file/host.rkt b/racket/src/io/file/host.rkt new file mode 100644 index 0000000000..ad49ba85ee --- /dev/null +++ b/racket/src/io/file/host.rkt @@ -0,0 +1,33 @@ +#lang racket/base +(require "../path/path.rkt" + "../path/complete.rkt" + "../path/parameter.rkt" + "../path/cleanse.rkt" + "../host/rktio.rkt" + "../security/main.rkt") + +(provide ->host + ->host/as-is + host->) + +;; Note: `(host-> (->host x who flags))` is not the same as `x`, since +;; it normalizes `x`. That's why `(host-> (->host x))` is generally +;; used in error reporting. + +(define (->host p who guards) + (let ([p (->path p)]) + (when who + (security-guard-check-file who p guards)) + (path-bytes (cleanse-path (path->complete-path p (current-directory)))))) + +(define (->host/as-is p who src) + (let ([p (->path p)]) + (when who + (if src + (security-guard-check-file-link who src p) + (security-guard-check-file who p '(exists)))) + (path-bytes p))) + +(define (host-> s) + (path (bytes->immutable-bytes s) + (system-path-convention-type))) diff --git a/racket/src/io/file/identity.rkt b/racket/src/io/file/identity.rkt new file mode 100644 index 0000000000..6bc58f7d26 --- /dev/null +++ b/racket/src/io/file/identity.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt" + "host.rkt" + "error.rkt") + +(provide path-or-fd-identity) + +;; In atomic mode; returns out of atomic mode +(define (path-or-fd-identity who + #:host-path [host-path #f] + #:as-link? [as-link? #f] ; used only if `host-path` + #:fd [fd #f] + #:port [port #f]) ; for errors, and non-#f if `fd` provided + (define r0 (if host-path + (rktio_path_identity rktio host-path (not as-link?)) + (rktio_fd_identity rktio fd))) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_identity_to_vector r0) + (rktio_free r0)))) + (end-atomic) + (when (rktio-error? r0) + (raise-filesystem-error who + r + (if host-path + (format (string-append + "error obtaining identity for path\n" + " path: ~a") + (host-> host-path)) + (format (string-append + "error obtaining identity for port\n" + " port: ~v") + port)))) + (+ (vector-ref r 0) + (arithmetic-shift (vector-ref r 1) + (vector-ref r 3)) + (arithmetic-shift (vector-ref r 2) + (+ (vector-ref r 3) (vector-ref r 4))))) diff --git a/racket/src/io/file/main.rkt b/racket/src/io/file/main.rkt new file mode 100644 index 0000000000..0f0f7a6880 --- /dev/null +++ b/racket/src/io/file/main.rkt @@ -0,0 +1,390 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/resource.rkt" + "../path/path.rkt" + "../path/parameter.rkt" + "../path/directory-path.rkt" + "../host/rktio.rkt" + "../host/thread.rkt" + "../host/error.rkt" + "../format/main.rkt" + "../security/main.rkt" + "parameter.rkt" + "host.rkt" + "identity.rkt" + "error.rkt" + (only-in "error.rkt" + set-maybe-raise-missing-module!)) + +(provide directory-exists? + file-exists? + link-exists? + make-directory + directory-list + current-force-delete-permissions + delete-file + delete-directory + rename-file-or-directory + file-or-directory-modify-seconds + file-or-directory-permissions + file-or-directory-identity + file-size + copy-file + make-file-or-directory-link + resolve-path + expand-user-path + filesystem-root-list + + ;; For the expander to register `maybe-raise-missing-module`: + set-maybe-raise-missing-module!) + +(define/who (directory-exists? p) + (check who path-string? p) + (rktio_directory_exists rktio (->host p who '(exists)))) + +(define/who (file-exists? p) + (check who path-string? p) + (rktio_file_exists rktio (->host p who '(exists)))) + +(define/who (link-exists? p) + (check who path-string? p) + (rktio_link_exists rktio (->host p who '(exists)))) + +(define/who (make-directory p) + (check who path-string? p) + (define host-path (->host p who '(write))) + (define r (rktio_make_directory rktio host-path)) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot make directory~a\n" + " path: ~a") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n the path already exists" + "") + (host-> host-path))))) + +(define/who (directory-list [p (current-directory)]) + (check who path-string? p) + (define host-path (->host p who '(read))) + (atomically + (call-with-resource + (rktio_directory_list_start rktio host-path) + ;; in atomic mode + (lambda (dl) (rktio_directory_list_stop rktio dl)) + ;; in atomic mode + (lambda (dl) + (cond + [(rktio-error? dl) + (end-atomic) + (raise-filesystem-error who + dl + (format (string-append + "could not open directory\n" + " path: ~a") + (host-> host-path)))] + [else + (end-atomic) + (let loop ([accum null]) + (start-atomic) + (define fnp (rktio_directory_list_step rktio dl)) + (define fn (if (rktio-error? fnp) + fnp + (rktio_to_bytes fnp))) + (cond + [(rktio-error? fn) + (end-atomic) + (check-rktio-error fn "error reading directory")] + [(equal? fn #"") + ;; `dl` is no longer valid; need to return still in + ;; atomic mode, so that `dl` is not destroyed again + accum] + [else + (rktio_free fnp) + (end-atomic) + (loop (cons (host-> fn) accum))]))]))))) + +(define/who (delete-file p) + (check who path-string? p) + (define host-path (->host p who '(delete))) + (define r (rktio_delete_file rktio + host-path + (current-force-delete-permissions))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot delete file\n" + " path: ~a") + (host-> host-path))))) + +(define/who (delete-directory p) + (check who path-string? p) + (define host-path (->host p who '(delete))) + (define r (rktio_delete_directory rktio + host-path + (->host (current-directory) #f #f) + (current-force-delete-permissions))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot delete directory\n" + " path: ~a") + (host-> host-path))))) + +(define/who (rename-file-or-directory old new [exists-ok? #f]) + (check who path-string? old) + (check who path-string? new) + (define host-old (->host old who '(read))) + (define host-new (->host new who '(write))) + (define r (rktio_rename_file rktio host-new host-old exists-ok?)) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot rename file or directory~a\n" + " source path: ~a\n" + " dest path: ~a") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n the destination path already exists" + "") + (host-> host-old) + (host-> host-new))))) + +(define/who file-or-directory-modify-seconds + (case-lambda + [(p) + (check who path-string? p) + (do-file-or-directory-modify-seconds who p #f #f)] + [(p secs) + (check who path-string? p) + (check who exact-integer? secs) + (do-file-or-directory-modify-seconds who p secs #f)] + [(p secs fail) + (check who path-string? p) + (check who #:or-false exact-integer? secs) + (check who (procedure-arity-includes/c 0) fail) + (do-file-or-directory-modify-seconds who p secs fail)])) + +(define (do-file-or-directory-modify-seconds who p secs fail) + (when secs + (unless (rktio_is_timestamp secs) + (raise-arguments-error who + "integer value is out-of-range" + "value" secs))) + (define host-path (->host p who (if secs '(write) '(read)))) + (start-atomic) + (define r0 (if secs + (rktio_set_file_modify_seconds rktio host-path secs) + (rktio_get_file_modify_seconds rktio host-path))) + (define r (if (and (not secs) (not (rktio-error? r0))) + (rktio_timestamp_ref r0) + r0)) + (end-atomic) + (cond + [(rktio-error? r) + (if fail + (fail) + (raise-filesystem-error who + r + (format (string-append + "error ~a file/directory time\n" + " path: ~a") + (if secs "setting" "getting") + (host-> host-path))))] + [else r])) + +(define/who (file-or-directory-permissions p [mode #f]) + (check who path-string? p) + (check who (lambda (m) + (or (not m) + (eq? m 'bits) + (and (exact-integer? m) + (<= 0 m 65535)))) + #:contract "(or/c #f 'bits (integer-in 0 65535))" + mode) + (define host-path (->host p who (if (integer? mode) '(write) '(read)))) + (define r + (if (integer? mode) + (rktio_set_file_or_directory_permissions rktio host-path mode) + (rktio_get_file_or_directory_permissions rktio host-path (eq? mode 'bits)))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "~a failed~a\n" + " path: ~a~a") + (if (integer? mode) "update" "access") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n unsupported bit combination" + "") + (host-> host-path) + (if (racket-error? r RKTIO_ERROR_EXISTS) + (format "\n permission value: ~a" mode) + "")))) + (cond + [(integer? mode) (void)] + [(eq? 'bits mode) r] + [else + (define (set? n) (eqv? n (bitwise-and r n))) + (let* ([l '()] + [l (if (set? RKTIO_PERMISSION_READ) + (cons 'read l) + l)] + [l (if (set? RKTIO_PERMISSION_WRITE) + (cons 'write l) + l)] + [l (if (set? RKTIO_PERMISSION_EXEC) + (cons 'execute l) + l)]) + l)])) + +(define/who (file-or-directory-identity p [as-link? #f]) + (check who path-string? p) + (define host-path (->host p who '(exists))) + (start-atomic) + (path-or-fd-identity who #:host-path host-path #:as-link? as-link?)) + +(define/who (file-size p) + (check who path-string? p) + (define host-path (->host p who '(read))) + (start-atomic) + (define r0 (rktio_file_size rktio host-path)) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_filesize_ref r0) + (rktio_free r0)))) + (end-atomic) + (cond + [(rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot get size\n" + " path: ~a") + (host-> host-path)))] + [else r])) + +(define/who (copy-file src dest [exists-ok? #f]) + (check who path-string? src) + (check who path-string? dest) + (define src-host (->host src who '(read))) + (define dest-host (->host dest who '(write delete))) + (define (report-error r) + (raise-filesystem-error who + r + (format (string-append + "~a\n" + " source path: ~a\n" + " destination path: ~a") + (copy-file-step-string r) + (host-> src-host) + (host-> dest-host)))) + (start-atomic) + (let ([cp (rktio_copy_file_start rktio dest-host src-host exists-ok?)]) + (cond + [(rktio-error? cp) + (end-atomic) + (report-error cp)] + [else + (thread-push-kill-callback! + (lambda () (rktio_copy_file_stop rktio cp))) + (dynamic-wind + void + (lambda () + (end-atomic) + (let loop () + (cond + [(rktio_copy_file_is_done rktio cp) + (define r (rktio_copy_file_finish_permissions rktio cp)) + (when (rktio-error? r) (report-error r))] + [else + (define r (rktio_copy_file_step rktio cp)) + (when (rktio-error? r) (report-error r)) + (loop)]))) + (lambda () + (start-atomic) + (rktio_copy_file_stop rktio cp) + (thread-pop-kill-callback!) + (end-atomic)))]))) + +(define/who (make-file-or-directory-link to path) + (check who path-string? to) + (check who path-string? path) + (define to-path (->path to)) + (define path-host (->host path who '(write))) + (define to-host (->host/as-is to-path who (host-> path-host))) + (define r (rktio_make_link rktio path-host to-host (directory-path? to-path))) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "cannot make link~a\n" + " path: ~a") + (if (racket-error? r RKTIO_ERROR_EXISTS) + ";\n the path already exists" + "") + (host-> path-host))))) + +(define/who (resolve-path p) + (check who path-string? p) + (define host-path (->host (path->path-without-trailing-separator (->path p)) who '(exists))) + (start-atomic) + (define r0 (rktio_readlink rktio host-path)) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_to_bytes r0) + (rktio_free r0)))) + (end-atomic) + (cond + [(rktio-error? r) + ;; Errors are not reported, but are treated like non-links + (define new-path (host-> host-path)) + ;; If cleansing didn't change p, then return an `eq?` path + (cond + [(equal? new-path p) p] + [else new-path])] + [else (host-> r)])) + +(define/who (expand-user-path p) + (check who path-string? p) + (define path (->path p)) + (define bstr (path-bytes path)) + (cond + [(and (positive? (bytes-length bstr)) + (eqv? (bytes-ref bstr 0) (char->integer #\~))) + (define host-path (->host/as-is path who #f)) + (start-atomic) + (define r0 (rktio_expand_user_tilde rktio host-path)) + (define r (if (rktio-error? r0) + r0 + (begin0 + (rktio_to_bytes r0) + (rktio_free r0)))) + (end-atomic) + (when (rktio-error? r) + (raise-filesystem-error who + r + (format (string-append + "bad username in path\n" + " path: ~a") + (host-> host-path)))) + (host-> r)] + [else path])) + +(define/who (filesystem-root-list) + (security-guard-check-file who #f '(exists)) + (start-atomic) + (define r0 (rktio_filesystem_roots rktio)) + (define r (if (rktio-error? r0) + r0 + (rktio_to_bytes_list r0))) + (end-atomic) + (when (rktio-error? r) + (raise-filesystem-error who r "cannot get roots")) + (for/list ([p (in-list r)]) + (host-> p))) diff --git a/racket/src/io/file/parameter.rkt b/racket/src/io/file/parameter.rkt new file mode 100644 index 0000000000..680af6de71 --- /dev/null +++ b/racket/src/io/file/parameter.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide current-force-delete-permissions) + +(define current-force-delete-permissions + (make-parameter #t (lambda (v) (and v #t)))) + diff --git a/racket/src/io/filesystem-change-evt/main.rkt b/racket/src/io/filesystem-change-evt/main.rkt new file mode 100644 index 0000000000..b9efbd112a --- /dev/null +++ b/racket/src/io/filesystem-change-evt/main.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide filesystem-change-evt? + filesystem-change-evt + filesystem-change-evt-cancel) + +(define (filesystem-change-evt? v) #f) + +(define filesystem-change-evt + (case-lambda + [(p) (error 'filesystem-change-evt "unsupported")] + [(p fail) (fail)])) + +(define/who (filesystem-change-evt-cancel e) + (check who filesystem-change-evt? e) + (void)) diff --git a/racket/src/io/foreign/main.rkt b/racket/src/io/foreign/main.rkt new file mode 100644 index 0000000000..fca6d32352 --- /dev/null +++ b/racket/src/io/foreign/main.rkt @@ -0,0 +1,92 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../path/path.rkt" + "../file/host.rkt" + "../file/error.rkt" + "../string/convert.rkt" + "../locale/string.rkt") + +(provide ffi-get-lib + ffi-get-obj + current-load-extension) + +;; The FFI is mostly implemented in "cs/core/foreign.ss" +;; and `ffi/unsafe`, but rktio provides the implementation +;; of loading and searching shared libraries. + +(define (ffi-get-lib who path as-global? fail-as-false? success-k) + (check who path-string? #:or-false path) + (check who (procedure-arity-includes/c 1) success-k) + (define bstr (and path (->host/as-is path #f #f))) + (start-atomic) + (define dll (rktio_dll_open rktio bstr as-global?)) + (define err-str (dll-get-error dll)) + (end-atomic) + (cond + [(rktio-error? dll) + (cond + [fail-as-false? #f] + [else + (define msg (string-append "could not load foreign library" + "\n path: " (if bstr (bytes->string/locale bstr #\?) "[all opened]"))) + (cond + [err-str + (raise + (exn:fail:filesystem + (string-append (symbol->string who) ": " msg + "\n system error: " (bytes->string/utf-8 err-str #\?)) + (current-continuation-marks)))] + [else + (raise-filesystem-error who dll msg)])])] + [else (success-k dll)])) + +(define (ffi-get-obj who dll dll-name name success-k) + (check who path-string? #:or-false dll-name) + (check who bytes? name) + (check who (procedure-arity-includes/c 1) success-k) + (start-atomic) + (define obj (rktio_dll_find_object rktio dll name)) + (define err-str (dll-get-error obj)) + (end-atomic) + (cond + [(rktio-error? obj) + (define msg (string-append "could not find export from foreign library" + "\n name: " (bytes->string/utf-8 name #\?) + "\n library: " (if dll-name (bytes->string/locale (path-bytes (->path dll-name)) #\?) "[all opened]"))) + (cond + [err-str + (raise + (exn:fail:filesystem + (string-append (symbol->string who) ": " msg + "\n system error: " (bytes->string/utf-8 err-str #\?)) + (current-continuation-marks)))] + [else + (raise-filesystem-error who dll msg)])] + [else (success-k obj)])) + +;; in atomic mode +(define (dll-get-error v) + (and (rktio-error? v) + (let ([p (rktio_dll_get_error rktio)]) + (and p + (begin0 + (rktio_to_bytes p) + (rktio_free p)))))) + +; ---------------------------------------- + +(define/who (default-load-extension path sym) + (check who path-string? path) + (check who symbol? sym) + (raise (exn:fail:unsupported + "default-load-extension: extensions are not supported" + (current-continuation-marks)))) + + +(define/who current-load-extension + (make-parameter default-load-extension + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) diff --git a/racket/src/io/format/main.rkt b/racket/src/io/format/main.rkt new file mode 100644 index 0000000000..def8484c2c --- /dev/null +++ b/racket/src/io/format/main.rkt @@ -0,0 +1,30 @@ +#lang racket/base +(require "../common/check.rkt" + "../port/parameter.rkt" + "../port/output-port.rkt" + "../port/string-port.rkt" + "printf.rkt") + +(provide format + fprintf + printf + eprintf) + +(define/who (format fmt . args) + (check who string? fmt) + (define o (open-output-string)) + (do-printf 'printf o fmt args) + (get-output-string o)) + +(define/who (fprintf o fmt . args) + (check who output-port? o) + (check who string? fmt) + (do-printf who o fmt args)) + +(define/who (printf fmt . args) + (check who string? fmt) + (do-printf who (current-output-port) fmt args)) + +(define/who (eprintf fmt . args) + (check who string? fmt) + (do-printf who (current-error-port) fmt args)) diff --git a/racket/src/io/format/printf.rkt b/racket/src/io/format/printf.rkt new file mode 100644 index 0000000000..3de31f0386 --- /dev/null +++ b/racket/src/io/format/printf.rkt @@ -0,0 +1,196 @@ +#lang racket/base +(require "../print/main.rkt" + (submod "../print/main.rkt" internal) + "../port/string-output.rkt") + +(provide do-printf) + +;; Since this module implements formatting, it can't use the usual +;; error functions or other formatting functions. + +(define (do-printf who o fmt all-args) + (define len (string-length fmt)) + + ;; First pass: check format and argument consistency + (define (next args) (and (pair? args) (cdr args))) + (let loop ([i 0] [expected-count 0] [args all-args] [error-thunk #f]) + (cond + [(= i len) + (check-conclusions who expected-count args error-thunk fmt all-args)] + [else + (case (string-ref fmt i) + [(#\~) + (let ([i (add1 i)]) + (when (= i len) + (ill-formed-error who "cannot end in `~`" fmt all-args)) + (case (string-ref fmt i) + [(#\~ #\% #\n #\N) + (loop (add1 i) expected-count args error-thunk)] + [(#\a #\A #\s #\S #\v #\V #\e #\E) + (loop (add1 i) (add1 expected-count) (next args) error-thunk)] + [(#\.) + (let ([i (add1 i)]) + (define (bad-dot) + (ill-formed-error who "tag `~.` not followed by `a`, `s`, or `v`" fmt all-args)) + (when (= i len) + (bad-dot)) + (case (string-ref fmt i) + [(#\a #\A #\s #\S #\v #\V) + (loop (add1 i) (add1 expected-count) (next args) error-thunk)] + [else (bad-dot)]))] + [(#\x #\X #\o #\O #\b #\B) + (define new-error-thunk (and (not error-thunk) + (pair? args) + (let ([a (car args)]) + (or (not (number? a)) + (not (exact? a)))) + (lambda () + (arg-type-error who "exact integer" (car args) fmt args)))) + (loop (add1 i) (add1 expected-count) (next args) new-error-thunk)] + [(#\c #\C) + (define new-error-thunk (and (not error-thunk) + (pair? args) + (not (char? (car args))) + (lambda () + (arg-type-error who "character" (car args) fmt args)))) + (loop (add1 i) (add1 expected-count) (next args) new-error-thunk)] + [else + (cond + [(char-whitespace? (string-ref fmt i)) + (loop (add1 i) expected-count args error-thunk)] + [else + (ill-formed-error who + (string-append "tag `~" (substring fmt i (add1 i)) "` not allowed") + fmt + all-args)])]))] + [else (loop (add1 i) expected-count args error-thunk)])])) + + ;; Second pass: output + (let loop ([start-i 0] [i 0] [args all-args]) + (cond + [(= i len) + (write-string fmt o start-i i)] + [else + (case (string-ref fmt i) + [(#\~) + (define (next i args) (let ([i (add1 i)]) + (loop i i args))) + (write-string fmt o start-i i) + (let ([i (add1 i)]) + (define c (string-ref fmt i)) + (case c + [(#\~) + (write-string "~" o) + (next i args)] + [(#\% #\n #\N) + (write-string "\n" o) + (next i args)] + [(#\a #\A) + (do-display who (car args) o) + (next i (cdr args))] + [(#\s #\S) + (do-write who (car args) o) + (next i (cdr args))] + [(#\v #\V) + (do-global-print who (car args) o) + (next i (cdr args))] + [(#\e #\E) + (write-string ((error-value->string-handler) + (car args) + (error-print-width)) + o) + (next i (cdr args))] + [(#\.) + (let ([i (add1 i)]) + (case (string-ref fmt i) + [(#\a #\A) + (do-display who (car args) o (error-print-width)) + (next i (cdr args))] + [(#\s #\S) + (do-write who (car args) o (error-print-width)) + (next i (cdr args))] + [(#\v #\V) + ;; Intentionally using `do-print` instead of + ;; `do-global-print`: + (do-print who (car args) o 0 (error-print-width)) + (next i (cdr args))]))] + [(#\x #\X) + (write-string (number->string (car args) 16) o) + (next i (cdr args))] + [(#\o #\O) + (write-string (number->string (car args) 8) o) + (next i (cdr args))] + [(#\b #\B) + (write-string (number->string (car args) 2) o) + (next i (cdr args))] + [(#\c #\C) + (write-string (string (car args)) o) + (next i (cdr args))] + [else + (cond + [(char-whitespace? c) + ;; Skip whitespace, but no more than one newline/return: + (let ws-loop ([i i] [saw-newline? #f]) + (cond + [(= i len) (loop i i args)] + [else + (define c (string-ref fmt i)) + (case c + [(#\newline) + (if saw-newline? + (loop i i args) + (ws-loop (add1 i) #t))] + [(#\return) + (if saw-newline? + (loop i i args) + (ws-loop (if (and ((add1 i) . < . len) + (char=? #\newline (string-ref fmt (add1 i)))) + (+ i 2) + (add1 i)) + #t))] + [else (if (char-whitespace? c) + (ws-loop (add1 i) saw-newline?) + (loop i i args))])]))])]))] + [else + (loop start-i (add1 i) args)])])) + + (void)) + +;; ---------------------------------------- + +(define (raise-error str) + (raise (exn:fail:contract str (current-continuation-marks)))) + +(define (check-conclusions who expected-count args error-thunk fmt all-args) + (unless (null? args) + (raise-error (string-append + (symbol->string who) + ": " + "format string requires " + (number->string expected-count) + " arguments, given " + (number->string (length all-args)) + (arguments->string (cons fmt all-args))))) + (when error-thunk (error-thunk))) + +(define (ill-formed-error who explanation fmt args) + (raise-error (string-append + (symbol->string who) + ": " + "ill-formed pattern string\n" + " explanation: " explanation + (arguments->string (cons fmt args))))) + +(define (arg-type-error who what val fmt args) + (raise-error (string-append + (symbol->string who) + ": " + "format string requires a " what ", given something else\n" + " bad argument: " (value->string val) + (arguments->string (cons fmt args))))) + +(define (value->string v) + ((error-value->string-handler) v (error-print-width))) + +(define (arguments->string args) + "") diff --git a/racket/src/io/host/bootstrap-rktio.rkt b/racket/src/io/host/bootstrap-rktio.rkt new file mode 100644 index 0000000000..e064c679be --- /dev/null +++ b/racket/src/io/host/bootstrap-rktio.rkt @@ -0,0 +1,218 @@ +#lang racket/base +(require racket/include + (only-in '#%linklet primitive-table) + ffi/unsafe + ffi/unsafe/atomic + (for-syntax racket/base) + (only-in racket/base + [void racket:void])) + +(define librktio (ffi-lib "librktio")) + +(define << arithmetic-shift) + +(define void _void) +(define char _byte) +(define int _int) +(define unsigned-short _ushort) +(define intptr_t _intptr) +(define uintptr_t _uintptr) +(define rktio_int64_t _int64) +(define float _float) +(define double _double) +(define NULL #f) + +(define-syntax-rule (define-constant n v) (define n v)) + +(define-syntax (define-type stx) + (syntax-case stx (rktio_bool_t rktio_ok_t) + [(_ rktio_bool_t _) + (with-syntax ([(_ rktio_bool_t _) stx]) + #'(define rktio_bool_t _bool))] + [(_ rktio_ok_t _) + (with-syntax ([(_ rktio_ok_t _) stx]) + #'(define rktio_ok_t _bool))] + [(_ n t) #'(define n t)])) + +(define-syntax (define-struct-type stx) + (syntax-case stx () + [(_ n ([type name] ...)) + (with-syntax ([_n (datum->syntax #'n + (string->symbol (format "_R~a" (syntax-e #'n))))] + [_n-pointer (datum->syntax #'n + (string->symbol (format "_R~a-pointer" (syntax-e #'n))))]) + #'(begin + (define-cstruct _n ([name type] ...)) + (define n _n-pointer)))])) + +(define-syntax-rule (ref t) _pointer) +(define-syntax-rule (*ref t) _pointer) + +(define-syntax-rule (define-function flags ret-type name ([arg-type arg-name] ...)) + (define name + (get-ffi-obj 'name librktio (_fun arg-type ... -> ret-type)))) + +(define-syntax-rule (define-function/errno* err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...) + err-expr) + (begin + (define proc + (get-ffi-obj 'name librktio (_fun rktio-type arg-type ... -> ret-type))) + (define (name rktio-name arg-name ...) + (begin + (start-atomic) + (begin0 + (let ([v (proc rktio-name arg-name ...)]) + (if (eqv? v err-v) + err-expr + v)) + (end-atomic)))))) + +(define-syntax-rule (define-function/errno err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...)) + (define-function/errno* err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...) + (vector (rktio_get_last_error_kind rktio-name) + (rktio_get_last_error rktio-name)))) + +(define-syntax-rule (define-function/errno+step err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...)) + (define-function/errno* err-v flags ret-type name ([rktio-type rktio-name] [arg-type arg-name] ...) + (vector (rktio_get_last_error_kind rktio-name) + (rktio_get_last_error rktio-name) + (rktio_get_last_error_step rktio-name)))) + +(include "../compiled/rktio.rktl") + +(define rktio_NULL #f) + +(define (rktio_filesize_ref fs) + (ptr-ref fs rktio_filesize_t)) +(define (rktio_timestamp_ref fs) + (ptr-ref fs rktio_timestamp_t)) +(define (rktio_is_timestamp v) + (let ([radix (arithmetic-shift 1 (sub1 (* 8 (ctype-sizeof rktio_timestamp_t))))]) + (<= (- radix) v (sub1 radix)))) + +(define (rktio_recv_length_ref p) + (Rrktio_length_and_addrinfo_t-len (cast p _pointer rktio_length_and_addrinfo_t))) + +(define (rktio_recv_address_ref p) + (Rrktio_length_and_addrinfo_t-address (cast p _pointer rktio_length_and_addrinfo_t))) + +(define (rktio_identity_to_vector p) + (let ([p (cast p _pointer _Rrktio_identity_t-pointer)]) + (vector + (Rrktio_identity_t-a p) + (Rrktio_identity_t-b p) + (Rrktio_identity_t-c p) + (Rrktio_identity_t-a_bits p) + (Rrktio_identity_t-b_bits p) + (Rrktio_identity_t-c_bits p)))) + +(define (rktio_convert_result_to_vector p) + (let ([p (cast p _pointer _Rrktio_convert_result_t-pointer)]) + (vector + (Rrktio_convert_result_t-in_consumed p) + (Rrktio_convert_result_t-out_produced p) + (Rrktio_convert_result_t-converted p)))) + +(define (rktio_to_bytes fs) + (bytes-copy (cast fs _pointer _bytes))) + +(define (rktio_to_shorts fs) + (let loop ([len 0]) + (cond + [(zero? (ptr-ref fs _short len)) + (define bstr (make-bytes (* len 2))) + (memcpy bstr fs (* len 2)) + bstr] + [else + (loop (add1 len))]))) + +;; Unlike `rktio_to_bytes`, frees the array and strings +(define (rktio_to_bytes_list lls [len #f]) + (begin0 + (let loop ([i 0]) + (cond + [(and len (= i len)) + null] + [else + (define bs (ptr-ref lls _bytes i)) + (if bs + (cons (begin0 + (bytes-copy bs) + (rktio_free bs)) + (loop (add1 i))) + null)])) + (rktio_free lls))) + +(define (rktio_from_bytes_list bstrs) + (cast bstrs (_list i _bytes) _gcpointer)) + +(define (rktio_free_bytes_list lls len) + (racket:void)) + +(define (rktio_process_result_stdin_fd r) + (Rrktio_process_result_t-stdin_fd (cast r _pointer _Rrktio_process_result_t-pointer))) +(define (rktio_process_result_stdout_fd r) + (Rrktio_process_result_t-stdout_fd (cast r _pointer _Rrktio_process_result_t-pointer))) +(define (rktio_process_result_stderr_fd r) + (Rrktio_process_result_t-stderr_fd (cast r _pointer _Rrktio_process_result_t-pointer))) +(define (rktio_process_result_process r) + (Rrktio_process_result_t-process (cast r _pointer _Rrktio_process_result_t-pointer))) + +(define (rktio_status_running r) + (Rrktio_status_t-running (cast r _pointer _Rrktio_status_t-pointer))) +(define (rktio_status_result r) + (Rrktio_status_t-result (cast r _pointer _Rrktio_status_t-pointer))) + +(define (rktio_do_install_os_signal_handler rktio) + (racket:void)) +(define (rktio_get_ctl_c_handler) + (lambda (k) + (racket:void))) + +(primitive-table '#%rktio + (let () + (define-syntax extract-functions + (syntax-rules (define-constant + define-type + define-struct-type + define-function + define-function/errno + define-function/errno+step) + [(_ accum) (hasheq . accum)] + [(_ accum (define-constant . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-struct-type . _) . rest) + (extract-functions accum . rest)] + [(_ accum (define-function _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)] + [(_ accum (define-function/errno+step _ _ _ id . _) . rest) + (extract-functions ('id id . accum) . rest)])) + (define-syntax-rule (begin form ...) + (extract-functions [#;(begin) + 'rktio_NULL rktio_NULL + 'rktio_filesize_ref rktio_filesize_ref + 'rktio_timestamp_ref rktio_timestamp_ref + 'rktio_is_timestamp rktio_is_timestamp + 'rktio_recv_length_ref rktio_recv_length_ref + 'rktio_recv_address_ref rktio_recv_address_ref + 'rktio_identity_to_vector rktio_identity_to_vector + 'rktio_convert_result_to_vector rktio_convert_result_to_vector + 'rktio_to_bytes rktio_to_bytes + 'rktio_to_bytes_list rktio_to_bytes_list + 'rktio_to_shorts rktio_to_shorts + 'rktio_from_bytes_list rktio_from_bytes_list + 'rktio_free_bytes_list rktio_free_bytes_list + 'rktio_process_result_stdin_fd rktio_process_result_stdin_fd + 'rktio_process_result_stdout_fd rktio_process_result_stdout_fd + 'rktio_process_result_stderr_fd rktio_process_result_stderr_fd + 'rktio_process_result_process rktio_process_result_process + 'rktio_status_running rktio_status_running + 'rktio_status_result rktio_status_result + 'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler + 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] + form ...)) + (include "../compiled/rktio.rktl"))) diff --git a/racket/src/io/host/bootstrap-thread.rkt b/racket/src/io/host/bootstrap-thread.rkt new file mode 100644 index 0000000000..0f5eacf164 --- /dev/null +++ b/racket/src/io/host/bootstrap-thread.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table) + "../../thread/bootstrap-main.rkt" + "bootstrap-rktio.rkt") + +;; Use the "thread" layer implementation in combination with +;; with the rktio bootstrap bindings. + +(primitive-table '#%thread #%thread-instance) diff --git a/racket/src/io/host/bootstrap.rkt b/racket/src/io/host/bootstrap.rkt new file mode 100644 index 0000000000..a69158fb23 --- /dev/null +++ b/racket/src/io/host/bootstrap.rkt @@ -0,0 +1,114 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table) + (only-in '#%unsafe + unsafe-custodian-register + unsafe-custodian-unregister) + "../../thread/sandman.rkt" + ffi/unsafe/atomic + "bootstrap-rktio.rkt") + +;; Approximate scheduler cooperation where `async-evt` can be used +;; within the dynamic extent of a `poller` callback to mean that the +;; poller is selected. Since `nack` propagation is based on a thread, +;; this approximation won't work right if an event is actually +;; contended. Also, `prop:secondary-evt` is just `prop:evt`, so +;; `prop:evt` cannot be mixed with `prop:input-port` or +;; `prop:output-port`. + +(struct poller (proc) + #:property prop:procedure + (lambda (p s) + (define async-sema (make-semaphore)) + (poll-guard-evt + (lambda (poll?) + (parameterize ([current-async-semaphore async-sema]) + (define-values (results new-evt) + ((poller-proc p) (if poll? never-evt s) (poll-ctx poll? (lambda () (semaphore-post async-sema))))) + (if results + (wrap-evt always-evt (lambda (v) (apply values results))) + new-evt)))))) + +(define (poller-evt v) + (struct poller-evt () + #:property prop:evt (lambda (self) (v self))) + (poller-evt)) + +(struct poll-ctx (poll? select-proc)) + +(define (poll-ctx-sched-info ctx) #f) + +(struct control-state-evt (evt interrupt abandon retry) + #:property prop:evt (lambda (cse) + (nack-guard-evt + (lambda (nack) + (thread (lambda () (sync nack) ((control-state-evt-abandon cse)))) + (control-state-evt-evt cse))))) + +(define current-async-semaphore (make-parameter #f)) + +(define (async-evt) + (or (current-async-semaphore) + (error 'async-evt "not in a `poller` callback"))) + +(define current-kill-callbacks (make-parameter '())) + +(define (thread-push-kill-callback! p) + (current-kill-callbacks (cons p (current-kill-callbacks)))) + +(define (thread-pop-kill-callback!) + (current-kill-callbacks (cdr (current-kill-callbacks)))) + +(define schedule-info-current-exts + (case-lambda + [() #f] + [(v) (void)])) + +(define (sync-atomic-poll-evt? evt) + (or (channel-put-evt? evt) + (channel? evt) + (semaphore? evt) + (semaphore-peek-evt? evt) + (eq? always-evt evt) + (eq? never-evt evt))) + +(primitive-table '#%thread + (hasheq 'make-semaphore make-semaphore + 'semaphore-post semaphore-post + 'semaphore-wait semaphore-wait + 'semaphore-peek-evt semaphore-peek-evt + 'wrap-evt wrap-evt + 'always-evt always-evt + 'choice-evt (lambda (l) (apply choice-evt l)) + 'sync sync + 'sync/timeout sync/timeout + 'sync-atomic-poll-evt? sync-atomic-poll-evt? + 'evt? evt? + 'prop:evt prop:evt + 'prop:secondary-evt prop:evt + 'poller poller + 'poller-evt poller-evt + 'poll-ctx-poll? poll-ctx-poll? + 'poll-ctx-select-proc poll-ctx-select-proc + 'poll-ctx-sched-info poll-ctx-sched-info + 'set-poll-ctx-incomplete?! void + 'schedule-info-did-work! void + 'control-state-evt control-state-evt + 'async-evt async-evt + 'schedule-info-current-exts schedule-info-current-exts + 'current-sandman current-sandman + 'start-atomic start-atomic + 'end-atomic end-atomic + 'start-atomic/no-interrupts start-atomic + 'end-atomic/no-interrupts end-atomic + 'current-custodian current-custodian + 'custodian-shut-down? (lambda (c) + (define v (box 1)) + (define ref (unsafe-custodian-register c v void #f #f)) + (cond + [ref (unsafe-custodian-unregister v ref) #f] + [else #t])) + 'unsafe-custodian-register unsafe-custodian-register + 'unsafe-custodian-unregister unsafe-custodian-unregister + 'thread-push-kill-callback! thread-push-kill-callback! + 'thread-pop-kill-callback! thread-pop-kill-callback! + 'set-get-subprocesses-time! void)) diff --git a/racket/src/io/host/error.rkt b/racket/src/io/host/error.rkt new file mode 100644 index 0000000000..70ca62b63f --- /dev/null +++ b/racket/src/io/host/error.rkt @@ -0,0 +1,62 @@ +#lang racket/base +(require "../string/convert.rkt" + "rktio.rkt" + "thread.rkt") + +(provide remap-rktio-error + format-rktio-message + format-rktio-system-error-message + raise-rktio-error + check-rktio-error + check-rktio-error*) + +(define (remap-rktio-error err) + (start-atomic) + (rktio_set_last_error rktio + (rktio-errkind err) + (rktio-errno err)) + (rktio_remap_last_error rktio) + (define errno (rktio_get_last_error rktio)) + (define errkind (rktio_get_last_error_kind rktio)) + (end-atomic) + (vector errkind errno)) + +(define (format-rktio-message who err base-msg) + (string-append (if who (symbol->string who) "") + (if who ": " "") + base-msg + "\n system error: " + (format-rktio-system-error-message err))) + +(define (format-rktio-system-error-message err) + (start-atomic) + (define p (rktio_get_error_string rktio + (rktio-errkind err) + (rktio-errno err))) + (define system-msg (rktio_to_bytes p)) + (end-atomic) + (string-append (bytes->string/utf-8 system-msg #\?) + "; " + (let ([kind (rktio-errkind err)]) + (cond + [(eqv? kind RKTIO_ERROR_KIND_POSIX) "errno"] + [(eqv? kind RKTIO_ERROR_KIND_WINDOWS) "win_err"] + [(eqv? kind RKTIO_ERROR_KIND_GAI) "gai_err"] + [else "rkt_err"])) + "=" + (number->string (rktio-errno err)))) + +(define (raise-rktio-error who err base-msg) + (raise + (exn:fail + (format-rktio-message who err base-msg) + (current-continuation-marks)))) + +(define (check-rktio-error v base-msg) + (when (rktio-error? v) + (raise-rktio-error #f v base-msg)) + v) + +(define (check-rktio-error* v base-msg) + (check-rktio-error v base-msg) + (void)) diff --git a/racket/src/io/host/rktio.rkt b/racket/src/io/host/rktio.rkt new file mode 100644 index 0000000000..360d7ba5c1 --- /dev/null +++ b/racket/src/io/host/rktio.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require racket/include + (for-syntax racket/base) + (only-in '#%linklet primitive-table)) + +(provide rktio + rktio-error? + rktio-errkind + rktio-errno + rktio-errstep + racket-error?) +;; More `provide`s added by macros below + +(define rktio-table + (or (primitive-table '#%rktio) + (error '#%rktio "rktio not supported by host"))) + +(define (lookup n) + (hash-ref rktio-table n)) + +(define << arithmetic-shift) + +(define-syntax-rule (define-constant n v) + (begin + (define n v) + (provide n))) + +(define-syntax-rule (define-type . _) (void)) +(define-syntax-rule (define-struct-type . _) (void)) + +(define-syntax-rule (define-function _ _ name . _) + (begin + (define name (lookup 'name)) + (provide name))) + +(define-syntax-rule (define-function/errno _ _ _ name . _) + (define-function () #f name)) +(define-syntax-rule (define-function/errno+step _ _ _ name . _) + (define-function () #f name)) + +(include "../../rktio/rktio.rktl") + +(define-function () #f rktio_filesize_ref) +(define-function () #f rktio_timestamp_ref) +(define-function () #f rktio_is_timestamp) +(define-function () #f rktio_recv_length_ref) +(define-function () #f rktio_recv_address_ref) +(define-function () #f rktio_identity_to_vector) +(define-function () #f rktio_convert_result_to_vector) +(define-function () #f rktio_to_bytes) +(define-function () #f rktio_to_bytes_list) +(define-function () #f rktio_to_shorts) +(define-function () #f rktio_NULL) +(define-function () #f rktio_do_install_os_signal_handler) +(define-function () #f rktio_get_ctl_c_handler) +(define-function () #f rktio_from_bytes_list) +(define-function () #f rktio_free_bytes_list) +(define-function () #f rktio_process_result_stdin_fd) +(define-function () #f rktio_process_result_stdout_fd) +(define-function () #f rktio_process_result_stderr_fd) +(define-function () #f rktio_process_result_process) +(define-function () #f rktio_status_running) +(define-function () #f rktio_status_result) + +;; Error results are represented as vectors: +(define rktio-error? vector?) +(define (rktio-errkind v) (vector-ref v 0)) +(define (rktio-errno v) (vector-ref v 1)) +(define (rktio-errstep v) (vector-ref v 2)) + +(define (racket-error? v errno) + (and (eqv? (rktio-errkind v) RKTIO_ERROR_KIND_RACKET) + (eqv? (rktio-errno v) errno))) + +(define rktio (rktio_init)) + +(void (rktio_do_install_os_signal_handler rktio)) diff --git a/racket/src/io/host/thread.rkt b/racket/src/io/host/thread.rkt new file mode 100644 index 0000000000..e7dc0accf8 --- /dev/null +++ b/racket/src/io/host/thread.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require (only-in '#%linklet primitive-table)) + +(provide atomically + non-atomically + atomically/no-interrupts + check-current-custodian) + +(define table + (or (primitive-table '#%thread) + (error '#%thread "scheduler cooperation not supported by host"))) + +(define-syntax bounce + (syntax-rules () + [(_ id) + (begin + (provide id) + (define id (hash-ref table 'id)))] + [(_ id ...) + (begin (bounce id) ...)])) + +(bounce make-semaphore + semaphore-post + semaphore-wait + semaphore-peek-evt + wrap-evt + always-evt + choice-evt ; raw variant that takes a list of evts + sync + sync/timeout + evt? + sync-atomic-poll-evt? + prop:evt + prop:secondary-evt + poller + poller-evt + poll-ctx-poll? + poll-ctx-select-proc + poll-ctx-sched-info + set-poll-ctx-incomplete?! + schedule-info-did-work! + control-state-evt + async-evt + schedule-info-current-exts + current-sandman + start-atomic + end-atomic + start-atomic/no-interrupts ; => disable GC, too, if GC can call back + end-atomic/no-interrupts + current-custodian + unsafe-custodian-register + unsafe-custodian-unregister + thread-push-kill-callback! + thread-pop-kill-callback! + set-get-subprocesses-time!) + +(define-syntax-rule (atomically e ...) + (begin + (start-atomic) + (begin0 + (let () e ...) + (end-atomic)))) + +(define-syntax-rule (non-atomically e ...) + (begin + (end-atomic) + (begin0 + (let () e ...) + (start-atomic)))) + +;; Cannot be exited with `non-atomically`: +(define-syntax-rule (atomically/no-interrupts e ...) + (begin + (start-atomic/no-interrupts) + (begin0 + (let () e ...) + (end-atomic/no-interrupts)))) + +;; in atomic mode +(define (check-current-custodian who) + (when (custodian-shut-down? (current-custodian)) + (end-atomic) + (raise + (exn:fail + (string-append (symbol->string who) ": the current custodian has been shut down") + (current-continuation-marks))))) diff --git a/racket/src/io/locale/collate.rkt b/racket/src/io/locale/collate.rkt new file mode 100644 index 0000000000..85351c1c17 --- /dev/null +++ b/racket/src/io/locale/collate.rkt @@ -0,0 +1,158 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../string/utf-16-encode.rkt" + "../converter/main.rkt" + "parameter.rkt" + "string.rkt" + "recase.rkt" + "nul-char.rkt" + "ucs-4.rkt") + +(provide string-locale? + string-locale-ci?) + +(define (make-string-comparsion who cmp portable-cmp ci?) + (lambda (arg . args) + (check who string? arg) + (for ([arg (in-list args)]) + (check who string? arg)) + (define locale-on? (current-locale)) + (let loop ([prev arg] [args args]) + (cond + [(null? args) #t] + [(if locale-on? + (cmp (collate prev (car args) ci?) 0) + (portable-cmp prev (car args))) + (loop (car args) (cdr args))] + [else #f])))) + +(define/who string-locale? + (make-string-comparsion who > string>? #f)) + +(define/who string-locale-ci? + (make-string-comparsion who > string-ci>? #t)) + +;; The rktio-provided string-comparison functions don't handle strings +;; that contain the nul character, and locale-specific conversion also +;; may not support nul characters. So, we handle nul ourselves, +;; imposing the rule that a string is greater than any prefix of the +;; string. +(define (collate s1 s2 ci?) + (define l1 (string-length s1)) + (define l2 (string-length s2)) + (let loop ([i1 0] [i2 0]) + (define t-l1 (+ i1 (string-length-up-to-nul s1 i1 l1))) + (define t-l2 (+ i2 (string-length-up-to-nul s2 i2 l2))) + (cond + [(and (= l1 t-l1) + (= l2 t-l2)) + (collate/no-nul (maybe-substring s1 i1 l1) (maybe-substring s2 i2 l2) ci?)] + [else + (define v (collate/no-nul (substring s1 i1 t-l1) + (substring s2 i2 t-l2) + ci?)) + (cond + [(not (zero? v)) v] + [(= l1 t-l1) (if (= l2 t-l2) 0 -1)] + [(= l2 t-l2) 1] + [else + ;; Both strings have more content, so skip nuls and check more + (loop (+ t-l1 1) (+ t-l2 1))])]))) + +;; Compare two strings that do not include the nul character +(define (collate/no-nul s1 s2 ci?) + (cond + [(and (equal? (current-locale) "") + (not (zero? (bitwise-and (rktio_convert_properties rktio) RKTIO_CONVERT_STRCOLL_UTF16)))) + ;; The OS provides a UTF-16-based collation function, so use that + (define s1-16 (utf-16-encode s1)) + (define s2-16 (utf-16-encode s2)) + (rktio_strcoll_utf16 rktio + s1-16 (arithmetic-shift (bytes-length s1-16) -1) + s2-16 (arithmetic-shift (bytes-length s2-16) -1) + ci?)] + [else + ;; We don't just convert to a locale encoding and compare, + ;; because there might be an encoding error, and we want + ;; to treat unencodable as strictly greater than encodable. + (define c1 #f) + (define c2 #f) + (define in-bstr1 (string->bytes/ucs-4 s1 0 (string-length s1))) + (define in-bstr2 (string->bytes/ucs-4 s2 0 (string-length s2))) + (dynamic-wind + (lambda () + (set! c1 (bytes-open-converter ucs-4-encoding (locale-string-encoding))) + (set! c2 (bytes-open-converter ucs-4-encoding (locale-string-encoding)))) + (lambda () + (let loop ([pos1 0] [pos2 0] [end1 (bytes-length in-bstr1)] [end2 (bytes-length in-bstr2)]) + (define-values (bstr1 in-used1 status1) + (bytes-convert c1 in-bstr1 pos1 end1)) + (define-values (bstr2 in-used2 status2) + (bytes-convert c2 in-bstr2 pos2 end2)) + (define new-pos1 (+ in-used1 pos1)) + (define new-pos2 (+ in-used2 pos2)) + (define done1? (= new-pos1 end1)) + (define done2? (= new-pos2 end2)) + (define (check-one-byte) + (define ch1 (string-ref s1 (arithmetic-shift new-pos1 -2))) + (define ch2 (string-ref s2 (arithmetic-shift new-pos2 -2))) + (cond + [(charstring/locale + string->bytes/locale + + string-locale? + string-locale-ci? + + string-locale-downcase + string-locale-upcase) + diff --git a/racket/src/io/locale/nul-char.rkt b/racket/src/io/locale/nul-char.rkt new file mode 100644 index 0000000000..a8de96d3db --- /dev/null +++ b/racket/src/io/locale/nul-char.rkt @@ -0,0 +1,18 @@ +#lang racket/base + +(provide string-length-up-to-nul + maybe-substring) + +;; Get the number of characters available before a nul character +(define (string-length-up-to-nul s i l) + (let loop ([j i]) + (cond + [(= j l) (- j i)] + [(eqv? (string-ref s j) #\nul) (- j i)] + [else (loop (add1 j))]))) + + +(define (maybe-substring s i l) + (if (zero? i) + s + (substring s i l))) diff --git a/racket/src/io/locale/parameter.rkt b/racket/src/io/locale/parameter.rkt new file mode 100644 index 0000000000..eac4202c9f --- /dev/null +++ b/racket/src/io/locale/parameter.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../string/convert.rkt") + +(provide current-locale + locale-string-encoding + system-language+country + + locale-encoding-is-utf-8? + locale-string-encoding/bytes + sync-locale!) + +(define current-locale + (make-parameter (string->immutable-string "") + (lambda (v) + (unless (or (not v) (string? v)) + (raise-argument-error 'current-locale "(or/c #f string?)" v)) + (and v (string->immutable-string v))))) + +(define installed-locale #f) + +;; in atomic mode +;; Any rktio function that depends on the locale should be called in +;; an atomic region that includes an earlier `(sync-locale!)` +(define (sync-locale!) + (define loc (current-locale)) + (unless (or (not loc) + (equal? installed-locale loc)) + (set! installed-locale (current-locale)) + (rktio_set_locale rktio (string->bytes/utf-8 installed-locale)))) + +(define (locale-encoding-is-utf-8?) + (define t (system-type)) + (define loc (current-locale)) + (or (not loc) + (and (or (eq? t 'macosx) + (eq? t 'windows)) + (equal? loc "")) + (zero? (bitwise-and (rktio_convert_properties rktio) RKTIO_CONVERTER_SUPPORTED)))) + +;; in atomic mode +(define (locale-string-encoding/bytes) + (sync-locale!) + (define e (rktio_locale_encoding rktio)) + (cond + [(rktio-error? e) + (end-atomic) + (raise-rktio-error 'locale-string-encoding e "error getting locale encoding")] + [else + (begin0 + (rktio_to_bytes e) + (rktio_free e))])) + +(define (locale-string-encoding) + (bytes->string/utf-8 (atomically (locale-string-encoding/bytes)) #\?)) + +(define/who (system-language+country) + (start-atomic) + (define c (rktio_system_language_country rktio)) + (cond + [(rktio-error? c) + (end-atomic) + (raise-rktio-error who c "error getting language and country information")] + [else + (begin0 + (rktio_to_bytes c) + (rktio_free c) + (end-atomic))])) diff --git a/racket/src/io/locale/recase.rkt b/racket/src/io/locale/recase.rkt new file mode 100644 index 0000000000..c247ebe1a9 --- /dev/null +++ b/racket/src/io/locale/recase.rkt @@ -0,0 +1,105 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../string/utf-16-encode.rkt" + "../string/utf-16-decode.rkt" + "../converter/main.rkt" + "parameter.rkt" + "string.rkt" + "nul-char.rkt" + "ucs-4.rkt") + +(provide string-locale-upcase + string-locale-downcase + + locale-recase) + +(define/who (string-locale-upcase s) + (check who string? s) + (recase s #:up? #t)) + +(define/who (string-locale-downcase s) + (check who string? s) + (recase s #:up? #f)) + +(define (recase s #:up? up?) + ;; Primitive functions don't work with nul characters, so we handle + ;; those directly + (define len (string-length s)) + (let loop ([pos 0]) + (define i-len (+ pos (string-length-up-to-nul s pos len))) + (cond + [(= i-len len) + (define new-s (recase/no-nul (maybe-substring s pos len) up?)) + (if (eqv? pos 0) + new-s + (list new-s))] + [else + (define new-s (recase/no-nul (substring s pos i-len) up?)) + (define r (loop (+ i-len 1))) + (if (eqv? pos 0) + (apply string-append new-s (string #\nul) r) + (cons new-s (cons (string #\nul) r)))]))) + +(define (recase/no-nul s up?) + (cond + [(and (equal? (current-locale) "") + (not (zero? (bitwise-and (rktio_convert_properties rktio) RKTIO_CONVERT_RECASE_UTF16)))) + ;; The OS provides a UTF-16-based function, so use that + (define s-16 (utf-16-encode s)) + (start-atomic) + (define r (rktio_recase_utf16 rktio + up? + s-16 (arithmetic-shift (bytes-length s-16) -1) + #f)) + (define sr (rktio_to_shorts r)) + (rktio_free r) + (end-atomic) + (utf-16-decode sr)] + [else + ;; We don't just convert to a locale encoding and recase, + ;; because there might be an encoding error; we'll leave + ;; encoding-error bytes alone. + (define c #f) + (define in-bstr (string->bytes/ucs-4 s 0 (string-length s))) + (dynamic-wind + (lambda () + (set! c (bytes-open-converter ucs-4-encoding (locale-string-encoding)))) + (lambda () + (let loop ([pos 0]) + (cond + [(= pos (bytes-length in-bstr)) + (if (eqv? pos 0) + "" + '(""))] + [else + (define-values (bstr in-used status) + (bytes-convert c in-bstr pos)) + (start-atomic) + (sync-locale!) + (define sr (locale-recase #:up? up? bstr)) + (end-atomic) + (define ls (bytes->string/locale sr)) + (cond + [(eq? status 'complete) + (if (eqv? pos 0) + ls + (list ls))] + [else + (define r (loop (+ pos in-used 4))) + (define err-s (string (string-ref s (arithmetic-shift (+ pos in-used) -2)))) + (if (eqv? pos 0) + (apply string-append ls err-s r) + (list* ls err-s r))])]))) + (lambda () + (bytes-close-converter c)))])) + +;; in atomic mode +;; Assumes that the locale is sync'ed +(define (locale-recase #:up? up? s) + (define p (rktio_locale_recase rktio up? s)) + (define r (rktio_to_bytes p)) + (rktio_free p) + r) diff --git a/racket/src/io/locale/string.rkt b/racket/src/io/locale/string.rkt new file mode 100644 index 0000000000..8312a8f81f --- /dev/null +++ b/racket/src/io/locale/string.rkt @@ -0,0 +1,98 @@ +#lang racket/base +(require "../common/check.rkt" + "../string/convert.rkt" + "../string/utf-8-decode.rkt" + "../converter/main.rkt" + "parameter.rkt" + "ucs-4.rkt") + +(provide string->bytes/locale + bytes->string/locale) + +(define/who (string->bytes/locale str [err-byte #f] [start 0] [end (and (string? str) (string-length str))]) + (check who string? str) + (check who byte? #:or-false err-byte) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + (cond + [(locale-encoding-is-utf-8?) + (string->bytes/utf-8 str err-byte start end)] + [else + (define c #f) + (dynamic-wind + (lambda () + (set! c (bytes-open-converter ucs-4-encoding (locale-string-encoding)))) + (lambda () + (define in-bstr (string->bytes/ucs-4 str start end)) + (let loop ([pos 0]) + (define-values (bstr in-used status) + (bytes-convert c in-bstr pos)) + (cond + [(eq? status 'complete) + (if (eqv? pos 0) + bstr + (list bstr))] + [(not err-byte) + (raise-arguments-error who "string cannot be encoded for the current locale" + "string" str)] + [else + (define err-bstr (bytes err-byte)) + (cond + [(eq? status 'aborts) + (if (eqv? pos 0) + (bytes-append bstr err-bstr) + (list bstr err-bstr))] + [else + ;; Skip the next character; we're assuming that + ;; `in-used` is a multiple of 4 + (define r (loop (+ pos in-used 4))) + (if (eqv? pos 0) + (apply bytes-append (cons bstr (cons err-bstr r))) + (cons bstr (cons err-bstr r)))])]))) + (lambda () + (bytes-close-converter c)))])) + +(define/who (bytes->string/locale in-bstr [err-char #f] [start 0] [end (and (bytes? in-bstr) + (bytes-length in-bstr))]) + (check who bytes? in-bstr) + (check who char? #:or-false err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length in-bstr) in-bstr) + (cond + [(locale-encoding-is-utf-8?) + (bytes->string/utf-8 in-bstr err-char start end)] + [else + (define c #f) + (dynamic-wind + (lambda () + (set! c (bytes-open-converter (locale-string-encoding) "UTF-8"))) + (lambda () + (let loop ([pos 0]) + (define-values (bstr in-used status) + (bytes-convert c in-bstr pos)) + (cond + [(eq? status 'complete) + (if (eqv? pos 0) + (bytes->string/utf-8 bstr) + (list bstr))] + [(not err-char) + (raise-arguments-error who "byte string is not a valid encoding for the current locale" + "byte string" in-bstr)] + [else + + (define err-bstr (string->bytes/utf-8 (string err-char))) + (cond + [(eq? status 'aborts) + (if (eqv? pos 0) + (bytes->string/utf-8 (bytes-append bstr err-bstr)) + (list bstr err-bstr))] + [else + ;; Skip the byte and try again + (define r (loop (+ pos in-used 1))) + (if (eqv? pos 0) + (bytes->string/utf-8 (apply bytes-append (cons bstr (cons err-bstr r)))) + (cons bstr (cons err-bstr r)))])]))) + (lambda () + (bytes-close-converter c)))])) diff --git a/racket/src/io/locale/ucs-4.rkt b/racket/src/io/locale/ucs-4.rkt new file mode 100644 index 0000000000..e72812e415 --- /dev/null +++ b/racket/src/io/locale/ucs-4.rkt @@ -0,0 +1,29 @@ +#lang racket/base + +(provide ucs-4-encoding + string->bytes/ucs-4) + +(define ucs-4-encoding + (if (system-big-endian?) + "UCS-4BE" + "UCS-4LE")) + +(define (string->bytes/ucs-4 str start end) + (define len (* 4 (- end start))) + (define bstr (make-bytes len)) + (if (system-big-endian?) + (for ([c (in-string str start end)] + [i (in-range 0 len 4)]) + (define n (char->integer c)) + (bytes-set! bstr i (arithmetic-shift n -24)) + (bytes-set! bstr (+ i 1) (bitwise-and 255 (arithmetic-shift n -16))) + (bytes-set! bstr (+ i 2) (bitwise-and 255 (arithmetic-shift n -8))) + (bytes-set! bstr (+ i 3) (bitwise-and 255 n))) + (for ([c (in-string str start end)] + [i (in-range 0 len 4)]) + (define n (char->integer c)) + (bytes-set! bstr (+ i 3) (arithmetic-shift n -24)) + (bytes-set! bstr (+ i 2) (bitwise-and 255 (arithmetic-shift n -16))) + (bytes-set! bstr (+ i 1) (bitwise-and 255 (arithmetic-shift n -8))) + (bytes-set! bstr i (bitwise-and 255 n)))) + bstr) diff --git a/racket/src/io/logger/demo.rkt b/racket/src/io/logger/demo.rkt new file mode 100644 index 0000000000..3e1f155845 --- /dev/null +++ b/racket/src/io/logger/demo.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require "../host/bootstrap.rkt" + "main.rkt") + +(define-syntax-rule (test expect rhs) + (let ([e expect] + [v rhs]) + (unless (equal? e v) + (error 'failed "~s: ~e" 'rhs v)))) + +(define root-logger (make-logger)) + +(test 'none (log-max-level root-logger)) +(add-stderr-log-receiver! root-logger 'warning) + +(test 'warning (log-max-level root-logger)) + +(log-message root-logger 'error "this should print to stderr" 5) + +(define demo1-logger (make-logger 'demo1 root-logger)) +(define demo2-logger (make-logger 'demo2 root-logger 'fatal)) + +(log-message demo1-logger 'error "this should print to stderr, too" 5) +(log-message demo2-logger 'error "this should not print to stderr" 5) + +(test 'warning (log-max-level demo1-logger)) +(test 'fatal (log-max-level demo2-logger)) + +(define lr1 (make-log-receiver root-logger 'info 'cats)) + +(test 'info (log-max-level demo1-logger)) +(test 'fatal (log-max-level demo2-logger)) + +(test 'info (log-max-level demo1-logger 'cats)) +(test 'fatal (log-max-level demo2-logger 'cats)) + +(test 'warning (log-max-level demo1-logger 'dogs)) +(test 'fatal (log-max-level demo2-logger 'dogs)) + +(test #t (log-level? demo1-logger 'info 'cats)) +(test #f (log-level? demo1-logger 'debug 'cats)) +(test #f (log-level? demo1-logger 'info 'dogs)) + +(define msg1 #f) +(define th1 (thread (lambda () (set! msg1 (sync lr1))))) +(sync (system-idle-evt)) +(test #f msg1) + +(log-message demo1-logger 'info 'cats "hello" 7) +(sync (system-idle-evt)) +(test '#(info "cats: hello" 7 cats) msg1) + +(log-message demo1-logger 'info 'cats "goodbye" 9) +(test '#(info "cats: goodbye" 9 cats) (sync lr1)) diff --git a/racket/src/io/logger/level.rkt b/racket/src/io/logger/level.rkt new file mode 100644 index 0000000000..27b51058b0 --- /dev/null +++ b/racket/src/io/logger/level.rkt @@ -0,0 +1,89 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide check-level + level>=? + level-max + level-min + parse-filters + filters-level-for-topic + filters-max-level) + +;; A filter set is represented as an improper list of pairs ending +;; with a (non-pair) level symbol. The ending symbol is the level that +;; applies if a name match is not found for any of the preceding +;; elements of the list. + +(define (level->value lvl) + (case lvl + [(none) 0] + [(fatal) 1] + [(error) 2] + [(warning) 3] + [(info) 4] + [(debug) 5] + [else #f])) + +(define (level>=? a b) + ((level->value a) . >= . (level->value b))) + +(define (level-max a b) + (if ((level->value a) . < . (level->value b)) + b + a)) + +(define (level-min a b) + (if ((level->value a) . < . (level->value b)) + a + b)) + +(define (check-level who v) + (unless (level->value v) + (raise-argument-error who + "(or/c 'none 'fatal 'error 'warning 'info 'debug)" + v))) + +;; ---------------------------------------- + +(define (parse-filters who l #:default-level default-level) + (let loop ([l l] [accum null] [default-level default-level]) + (cond + [(null? l) + (append accum default-level)] + [else + (define level (car l)) + (check-level who level) + (cond + [(null? (cdr l)) + (append accum level)] + [else + (define topic (cadr l)) + (unless (or (not topic) (symbol? topic)) + (raise-argument-error who "(or/c #f symbol?)" topic)) + (if (not topic) + (loop (cddr l) accum level) + (loop (cddr l) + (cons (cons topic level) accum) + default-level))])]))) + +(define (filters-level-for-topic filters topic) + (let loop ([filters filters]) + (cond + [(pair? filters) + (cond + [(eq? (caar filters) topic) + (cdar filters)] + [else + (loop (cdr filters))])] + [else + ;; default: + filters]))) + +(define (filters-max-level filters) + (let loop ([filters filters] [best-level 'none]) + (cond + [(pair? filters) + (loop (cdr filters) + (level-max best-level (cdar filters)))] + [else + (level-max best-level filters)]))) diff --git a/racket/src/io/logger/logger.rkt b/racket/src/io/logger/logger.rkt new file mode 100644 index 0000000000..20a5f435f9 --- /dev/null +++ b/racket/src/io/logger/logger.rkt @@ -0,0 +1,46 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide (struct-out logger) + logger-name + create-logger + logger-receivers) + +(struct logger (topic ; symbol or #f + parent ; logger or #f + propagate-filters + [receiver-boxes #:mutable] ; list of weak boxes + [prune-counter #:mutable] ; number of adds before checking empied boxes + [permanent-receivers #:mutable] ; receivers to retain strongly + [max-receiver-level #:mutable] ; up-to-date if `local-level-timestamp` = `(unbox root-level-timestamp-box)` + topic-level-cache ; topic -> level cache + [local-level-timestamp #:mutable] ; integer + root-level-timestamp-box ; box of integer + [level-sema #:mutable])) ; to report when a receiver is added + +(define/who (logger-name logger) + (check who logger? logger) + (logger-topic logger)) + +(define (create-logger #:topic topic #:parent parent #:propagate-filters propagate-filters) + (logger topic + parent + propagate-filters + null ; receiver-boxes + 8 ; prune-counter + null ; permanent-receivers + 'none ; max-receiver-level + (make-vector 16) ; topic-level-cache + -1 ; local-level-timestamp + (if parent + (logger-root-level-timestamp-box parent) + (box 0)) + #f)) ; level-sema + +;; Get log receivers, dropping any boxes made empty due to a weak +;; reference: +(define (logger-receivers logger) + (for*/list ([rb (in-list (logger-receiver-boxes logger))] + [b (in-value (weak-box-value rb))] + #:when b) + b)) diff --git a/racket/src/io/logger/main.rkt b/racket/src/io/logger/main.rkt new file mode 100644 index 0000000000..2ae0c4d053 --- /dev/null +++ b/racket/src/io/logger/main.rkt @@ -0,0 +1,123 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "logger.rkt" + "level.rkt" + "wanted.rkt" + "receiver.rkt") + +(provide logger? + logger-name + current-logger + make-logger + log-level? ; ok to call in host-Scheme interrupt handler + log-max-level + log-all-levels + log-level-evt + log-message ; ok to call in host-Scheme interrupt handler + log-receiver? + make-log-receiver + add-stderr-log-receiver!) + +(define root-logger + (create-logger #:topic #f #:parent #f #:propagate-filters 'none)) + +(define current-logger + (make-parameter root-logger + (lambda (l) + (unless (logger? l) + (raise-argument-error 'current-logger "logger?" l)) + l))) + +(define (make-logger [topic #f] [parent #f] . filters) + (unless (or (not topic) (symbol? topic)) + (raise-argument-error 'make-logger "(or/c symbol? #f)" topic)) + (unless (or (not parent) (logger? parent)) + (raise-argument-error 'make-logger "(or/c logger? #f)" parent)) + (create-logger #:topic topic + #:parent parent + #:propagate-filters (parse-filters 'make-logger filters #:default-level 'debug))) + +;; Can be called in any host Scheme thread, including in an interrupt +;; handler (where "interrupt" is a host-Scheme concept, such as a GC +;; handler). If it's not the thread that runs Racket, then it's in +;; atomic, non-interrupt mode and we assume that the argument checks +;; will pass. +(define/who (log-level? logger level [topic #f]) + (check who logger? logger) + (check-level who level) + (check who #:or-false symbol? topic) + (level>=? (logger-wanted-level logger topic) level)) + +(define/who (log-max-level logger [topic #f]) + (check who logger? logger) + (check who #:or-false symbol? topic) + (logger-wanted-level logger topic)) + +(define/who (log-all-levels logger) + (check who logger? logger) + (logger-all-levels logger)) + +(define/who (log-level-evt logger) + (check who logger? logger) + (define s + (atomically + (cond + [(logger-level-sema logger) + => (lambda (s) s)] + [else + (define s (make-semaphore)) + (set-logger-level-sema! logger s)]))) + (semaphore-peek-evt s)) + +;; Can be called in any host Scheme thread and in interrupt handler, +;; like `log-level?`: +(define/who log-message + ;; Complex dispatch based on number and whether third is a string: + (case-lambda + [(logger level message data) + (define topic (and (logger? logger) (logger-name logger))) + (do-log-message who logger level topic message data #t)] + [(logger level topic/message message/data data/prefix?) + (cond + [(string? topic/message) + (define topic (and (logger? logger) (logger-name logger))) + (do-log-message who logger level topic topic/message message/data data/prefix?)] + [(symbol? topic/message) + (do-log-message who logger level topic/message message/data data/prefix? #t)] + [else + (check who logger? logger) + (check-level who level) + (raise-argument-error who "(or/c string? symbol?)" topic/message)])] + [(logger level topic message data prefix?) + (do-log-message who logger level topic message data prefix?)])) + +;; Can be called in any host Scheme thread and in interrupt handler, +;; like `log-level?`: +(define (do-log-message who logger level topic message data prefix?) + (check who logger? logger) + (check-level who level) + (check who #:or-false symbol? topic) + (check who string? message) + (define msg #f) + (atomically/no-interrupts + (when ((logger-max-wanted-level logger) . level>=? . level) + (let loop ([logger logger]) + (for ([r (in-list (logger-receivers logger))]) + (when ((filters-level-for-topic (log-receiver-filters r) topic) . level>=? . level) + (unless msg + (set! msg (vector-immutable + level + (string->immutable-string + (if (and prefix? topic) + (string-append (symbol->string topic) + ": " + message) + message)) + data + topic))) + (log-receiver-send! r msg))) + (let ([parent (logger-parent logger)]) + (when (and parent + ((filters-level-for-topic (logger-propagate-filters logger) topic) . level>=? . level)) + (loop parent))))))) diff --git a/racket/src/io/logger/receiver.rkt b/racket/src/io/logger/receiver.rkt new file mode 100644 index 0000000000..c33675cb0d --- /dev/null +++ b/racket/src/io/logger/receiver.rkt @@ -0,0 +1,126 @@ +#lang racket/base +(require "../common/check.rkt" + "../../common/queue.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../string/convert.rkt" + "level.rkt" + "logger.rkt") + +(provide (struct-out log-receiver) + make-log-receiver + add-stderr-log-receiver! + log-receiver-send!) + +(struct log-receiver (filters)) + +(define-values (prop:receiver-send receiver-send? receiver-send-ref) + (make-struct-type-property 'receiver-send)) + +;; ---------------------------------------- + +(struct queue-log-receiver log-receiver (msgs ; queue of messages ready for `sync` [if `waiters` is null] + waiters) ; queue of (box callback) to receive ready messages [if `msgs` is null] + #:reflection-name 'log-receiver + #:property + prop:receiver-send + (lambda (lr msg) + ;; called in atomic mode and possibly in host interrupt handler, + ;; so anything we touch here should only be modified with + ;; interrupts disabled + (atomically/no-interrupts + (define b (queue-remove! (queue-log-receiver-waiters lr))) + (cond + [b + (define select! (unbox b)) + (set-box! b msg) + (select!)] + [else + (queue-add! (queue-log-receiver-msgs lr) msg)]))) + #:property + prop:evt + (poller (lambda (lr ctx) + (define msg (atomically/no-interrupts (queue-remove! (queue-log-receiver-msgs lr)))) + (cond + [msg + (values (list msg) #f)] + [else + (define b (box (poll-ctx-select-proc ctx))) + (define n (atomically/no-interrupts (queue-add! (queue-log-receiver-waiters lr) b))) + (values #f (control-state-evt + (wrap-evt async-evt (lambda (e) (unbox b))) + (lambda () (atomically/no-interrupts (queue-remove-node! (queue-log-receiver-waiters lr) n))) + void + (lambda () + (atomically/no-interrupts + (define msg (queue-remove! (queue-log-receiver-msgs lr))) + (cond + [msg + (set-box! b msg) + (values msg #t)] + [else + (set! n (queue-add! (queue-log-receiver-waiters lr) b)) + (values #f #f)])))))])))) + +(define/who (make-log-receiver logger level . args) + (check who logger? logger) + (define lr (queue-log-receiver (parse-filters 'make-log-receiver (cons level args) #:default-level 'none) + (make-queue) + (make-queue))) + (add-log-receiver! logger lr) + lr) + +;; ---------------------------------------- + +(struct stderr-log-receiver log-receiver () + #:property + prop:receiver-send + (lambda (lr msg) + ;; called in atomic mode and possibly in host interrupt handler + (define fd (rktio_std_fd rktio RKTIO_STDERR)) + (define bstr (bytes-append (string->bytes/utf-8 (vector-ref msg 1)) #"\n")) + (define len (bytes-length bstr)) + (let loop ([i 0]) + (define v (rktio_write_in rktio fd bstr i len)) + (unless (rktio-error? v) + (let ([i (+ i v)]) + (unless (= i len) + (loop i))))) + (rktio_forget rktio fd))) + +(define/who (add-stderr-log-receiver! logger . args) + (check who logger? logger) + (define lr (stderr-log-receiver (parse-filters 'make-stderr-log-receiver args #:default-level 'none))) + (atomically + (add-log-receiver! logger lr) + (set-logger-permanent-receivers! logger (cons lr (logger-permanent-receivers logger))))) + +;; ---------------------------------------- + +(define (add-log-receiver! logger lr) + (atomically/no-interrupts + ;; Add receiver to the logger's list, purning empty boxes + ;; every time the list length doubles (roughly): + (cond + [(zero? (logger-prune-counter logger)) + (set-logger-receiver-boxes! logger (cons (make-weak-box lr) + (for/list ([b (in-list (logger-receiver-boxes logger))] + #:when (weak-box-value b)) + b))) + (set-logger-prune-counter! logger (max 8 (length (logger-receiver-boxes logger))))] + [else + (set-logger-receiver-boxes! logger (cons (make-weak-box lr) (logger-receiver-boxes logger))) + (set-logger-prune-counter! logger (sub1 (logger-prune-counter logger)))]) + ;; Increment the timestamp, so that wanted levels will be + ;; recomputed on demand: + (define ts-box (logger-root-level-timestamp-box logger)) + (set-box! ts-box (add1 (unbox ts-box))) + ;; Post a semaphore to report that wanted levels may have + ;; changed: + (when (logger-level-sema logger) + (semaphore-post (logger-level-sema logger)) + (set-logger-level-sema! logger #f)))) + +;; Called in atomic mode and with interrupts disabled +(define (log-receiver-send! r msg) + ((receiver-send-ref r) r msg)) diff --git a/racket/src/io/logger/wanted.rkt b/racket/src/io/logger/wanted.rkt new file mode 100644 index 0000000000..2eec7016e8 --- /dev/null +++ b/racket/src/io/logger/wanted.rkt @@ -0,0 +1,96 @@ +#lang racket/base +(require "../host/thread.rkt" + "logger.rkt" + "receiver.rkt" + "level.rkt") + +(provide logger-wanted-level + logger-max-wanted-level + logger-all-levels) + +(define (logger-wanted-level logger topic) + (atomically/no-interrupts + (cond + [(not topic) (logger-max-wanted-level logger)] + [else + (cond + [((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger))) + ;; Cache is up-to-date, so search it + (define cache (logger-topic-level-cache logger)) + (or (for/or ([i (in-range 0 (vector-length cache) 2)]) + (and (eq? (vector-ref cache i) topic) + (vector-ref cache (add1 i)))) + ;; Didn't find in cache, so update the cache + (begin + (update-logger-wanted-level! logger topic) + (logger-wanted-level logger topic)))] + [else + ;; Update the cache and retry: + (update-logger-wanted-level! logger topic) + (logger-wanted-level logger topic)])]))) + +(define (logger-max-wanted-level logger) + (atomically/no-interrupts + (cond + [((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger))) + ;; Ccahed value is up-to-date + (logger-max-receiver-level logger)] + [else + ;; Traverse to set cache: + (update-logger-wanted-level! logger #f) + (logger-max-receiver-level logger)]))) + +(define (update-logger-wanted-level! logger topic) + (unless ((logger-local-level-timestamp logger) . >= . (unbox (logger-root-level-timestamp-box logger))) + (define cache (logger-topic-level-cache logger)) + (for/or ([i (in-range 0 (vector-length cache) 2)]) + (vector-set! cache i #f)) + (set-logger-local-level-timestamp! logger (unbox (logger-root-level-timestamp-box logger)))) + ;; As we traverse the parent chain, keep track of the "ceiling" + ;; level as the maximum level that would be propagated; for any + ;; receiver, clip the wanted levels to that ceiling. + (let loop ([parent logger] [ceiling-level 'debug] [old-max-level 'none] [old-topic-max-level 'none]) + (define-values (max-level topic-max-level) + (for/fold ([max-level old-max-level] [topic-max-level old-topic-max-level]) + ([r (in-list (logger-receivers parent))] + #:break (and (max-level . level>=? . ceiling-level) + (or (not topic) + (topic-max-level . level>=? . ceiling-level)))) + (values (level-max max-level + (level-min (filters-max-level (log-receiver-filters r)) + ceiling-level)) + (and topic + (level-max topic-max-level + (level-min (filters-level-for-topic (log-receiver-filters r) topic) + ceiling-level)))))) + (cond + [(and (or (ceiling-level . level>=? . max-level) + (and topic (ceiling-level . level>=? . topic-max-level))) + (logger-parent parent)) + => (lambda (next-parent) + (let ([ceiling-level (level-min ceiling-level (filters-max-level (logger-propagate-filters parent)))]) + (loop next-parent ceiling-level max-level topic-max-level)))] + [else + ;; No more parents, so save the result + (set-logger-max-receiver-level! logger max-level) + (when topic + (define cache (logger-topic-level-cache logger)) + (or + ;; Look for empty cache slot: + (for/or ([i (in-range 0 (vector-length cache) 2)]) + (and (not (vector-ref cache i)) + (begin + (vector-set! cache i topic) + (vector-set! cache (add1 i) topic-max-level)) + #t)) + ;; Rotate cache and put new value at start + (begin + (for ([i (in-range 0 (- (vector-length cache) 2) 2)]) + (vector-set! cache (+ i 2) (vector-ref cache i)) + (vector-set! cache (+ i 3) (vector-ref cache (+ i 1)))) + (vector-set! cache 0 topic) + (vector-set! cache 1 topic-max-level))))]))) + + +(define (logger-all-levels logger) + '(none #f)) diff --git a/racket/src/io/main.rkt b/racket/src/io/main.rkt new file mode 100644 index 0000000000..68564d4556 --- /dev/null +++ b/racket/src/io/main.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require "sandman/main.rkt" + "port/main.rkt" + "path/main.rkt" + "string/main.rkt" + "converter/main.rkt" + "locale/main.rkt" + "format/main.rkt" + "print/main.rkt" + "error/main.rkt" + "srcloc/main.rkt" + "logger/main.rkt" + "file/main.rkt" + "filesystem-change-evt/main.rkt" + "security/main.rkt" + "envvar/main.rkt" + "subprocess/main.rkt" + "network/main.rkt" + "foreign/main.rkt" + "unsafe/main.rkt" + "run/main.rkt") + +(provide (all-from-out "port/main.rkt") + (all-from-out "path/main.rkt") + (all-from-out "string/main.rkt") + (all-from-out "converter/main.rkt") + (all-from-out "locale/main.rkt") + (all-from-out "format/main.rkt") + (all-from-out "print/main.rkt") + (all-from-out "error/main.rkt") + (all-from-out "srcloc/main.rkt") + (all-from-out "logger/main.rkt") + (all-from-out "file/main.rkt") + (all-from-out "filesystem-change-evt/main.rkt") + (all-from-out "security/main.rkt") + (all-from-out "envvar/main.rkt") + (all-from-out "subprocess/main.rkt") + (all-from-out "network/main.rkt") + (all-from-out "foreign/main.rkt") + (all-from-out "unsafe/main.rkt") + (all-from-out "run/main.rkt")) + +(module main racket/base) diff --git a/racket/src/io/network/address.rkt b/racket/src/io/network/address.rkt new file mode 100644 index 0000000000..3aa881d5ed --- /dev/null +++ b/racket/src/io/network/address.rkt @@ -0,0 +1,93 @@ +#lang racket/base +(require "../common/resource.rkt" + "../string/convert.rkt" + "../host/rktio.rkt" + "../host/thread.rkt" + "evt.rkt" + "error.rkt") + +(provide call-with-resolved-address + register-address-finalizer) + +;; in atomic mode +(define (call-with-resolved-address hostname port-no proc + #:who [who #f] ; not #f => report errors + #:which [which ""] ; for error reporting, including trailing space + #:port-number-on-error? [port-number-on-error? #t] + #:enable-break? [enable-break? #f] + #:family [family RKTIO_FAMILY_ANY] + #:passive? [passive? #f] + #:tcp? [tcp? #t] + #:retain-address? [retain-address? #f]) + (poll-address-finalizations) + (cond + [(and (not hostname) + (not port-no)) + (proc #f)] + [else + (call-with-resource + (box (rktio_start_addrinfo_lookup rktio + (and hostname (string->bytes/utf-8 hostname)) + (or port-no 0) + family passive? tcp?)) + ;; in atomic mode + (lambda (lookup-box) + (define lookup (unbox lookup-box)) + (when lookup + (rktio_addrinfo_lookup_stop lookup))) + ;; in atomic mode + (lambda (lookup-box) + (define lookup (unbox lookup-box)) + (let loop () + (cond + [(and (not (rktio-error? lookup)) + (eqv? (rktio_poll_addrinfo_lookup_ready rktio lookup) + RKTIO_POLL_NOT_READY)) + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (not (eqv? (rktio_poll_addrinfo_lookup_ready rktio lookup) + RKTIO_POLL_NOT_READY))) + (lambda (ps) + (rktio_poll_add_addrinfo_lookup rktio lookup ps)))) + (start-atomic) + (loop)] + [else + (set-box! lookup-box #f) ; receiving result implies `lookup` is destroyed + (call-with-resource + (if (rktio-error? lookup) + lookup + (rktio_addrinfo_lookup_get rktio lookup)) + ;; in atomic mode + (lambda (addr) (rktio_addrinfo_free rktio addr)) + ;; in atomic mode + (lambda (addr) + (cond + [(and who (rktio-error? addr)) + (raise-network-error who addr (string-append + "can't resolve " which "address" + "\n address: " (or hostname "") + (if (and port-number-on-error? port-no) + (string-append "\n port number: " (number->string port-no)) + "")))] + [else + ;; `addr` may be an error; if so, let `proc` handle it + (begin0 + (proc addr) + (unless retain-address? + (rktio_addrinfo_free rktio addr)))])))]))))])) + +;; ---------------------------------------- + +(define address-will-executor (make-will-executor)) + +(define (register-address-finalizer addr) + (will-register address-will-executor + addr + (lambda (addr) + (rktio_addrinfo_free rktio addr) + #t))) + +(define (poll-address-finalizations) + (when (will-try-execute address-will-executor) + (poll-address-finalizations))) diff --git a/racket/src/io/network/check.rkt b/racket/src/io/network/check.rkt new file mode 100644 index 0000000000..df67405729 --- /dev/null +++ b/racket/src/io/network/check.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide check-bstr) + +(define (check-bstr who bstr start end) + (check who bytes? bstr) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (define len (bytes-length bstr)) + (unless (<= 0 start len) + (raise-range-error who "byte string" "starting " start bstr 0 len #f)) + (unless (<= start end len) + (raise-range-error who "byte string" "ending " end bstr 0 len start))) diff --git a/racket/src/io/network/error.rkt b/racket/src/io/network/error.rkt new file mode 100644 index 0000000000..c917974c56 --- /dev/null +++ b/racket/src/io/network/error.rkt @@ -0,0 +1,39 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt") + +(provide raise-network-error + raise-network-arguments-error) + +(define (raise-network-error who orig-err base-msg) + (define err (remap-rktio-error orig-err)) + (define msg (format-rktio-message who err base-msg)) + (raise + (cond + [(not (eq? (rktio-errkind err) RKTIO_ERROR_KIND_RACKET)) + (exn:fail:network:errno + msg + (current-continuation-marks) + (cons (rktio-errno err) + (let ([kind (rktio-errkind err)]) + (cond + [(eqv? kind RKTIO_ERROR_KIND_POSIX) 'posix] + [(eqv? kind RKTIO_ERROR_KIND_WINDOWS) 'windows] + [(eqv? kind RKTIO_ERROR_KIND_GAI) 'gai] + [else (error 'raise-network-error "confused about rktio error")]))))] + [else + (exn:fail:network + msg + (current-continuation-marks))]))) + +(define (raise-network-arguments-error who msg socket-str u) + (unless (equal? socket-str "socket") + (raise-argument-error 'raise-network-arguments-error + "\"socket\"" + socket-str)) + (raise + (exn:fail:network + (string-append (symbol->string who) ": " msg + "\n socket: " + ((error-value->string-handler) u (error-print-width))) + (current-continuation-marks)))) diff --git a/racket/src/io/network/evt.rkt b/racket/src/io/network/evt.rkt new file mode 100644 index 0000000000..2896c19a6d --- /dev/null +++ b/racket/src/io/network/evt.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/thread.rkt" + "../sandman/main.rkt") + +(provide rktio-evt) + +(struct rktio-evt (poll add-to-poll-set) + #:property + prop:evt + (poller + (lambda (self poll-ctx) + (cond + [((rktio-evt-poll self)) + (values (list self) #f)] + [else + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + ;; Cooperate with the sandman by registering a function that + ;; takes a poll set and adds to it: + (schedule-info-current-exts sched-info + (sandman-add-poll-set-adder + (schedule-info-current-exts sched-info) + (rktio-evt-add-to-poll-set self)))) + (values #f self)]))) + #:authentic) diff --git a/racket/src/io/network/main.rkt b/racket/src/io/network/main.rkt new file mode 100644 index 0000000000..541d73c913 --- /dev/null +++ b/racket/src/io/network/main.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "tcp.rkt" + "udp.rkt") + +(provide (all-from-out "tcp.rkt") + (all-from-out "udp.rkt")) diff --git a/racket/src/io/network/port-number.rkt b/racket/src/io/network/port-number.rkt new file mode 100644 index 0000000000..03fc01ce1e --- /dev/null +++ b/racket/src/io/network/port-number.rkt @@ -0,0 +1,12 @@ +#lang racket/base + +(provide port-number? + listen-port-number?) + +(define (port-number? v) + (and (fixnum? v) + (<= 1 v 65535))) + +(define (listen-port-number? v) + (and (fixnum? v) + (<= 0 v 65535))) diff --git a/racket/src/io/network/tcp-accept.rkt b/racket/src/io/network/tcp-accept.rkt new file mode 100644 index 0000000000..5dad7ea2c7 --- /dev/null +++ b/racket/src/io/network/tcp-accept.rkt @@ -0,0 +1,128 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt" + "tcp-listen.rkt" + "tcp-port.rkt" + "evt.rkt" + "error.rkt") + +(provide tcp-accept + tcp-accept/enable-break + tcp-accept-evt + tcp-accept-ready?) + +(define/who (tcp-accept listener) + (do-tcp-accept who listener)) + +(define/who (tcp-accept/enable-break listener) + (do-tcp-accept who #:enable-break? #t listener)) + +(define (do-tcp-accept who listener + #:enable-break? [enable-break? #f]) + (check who tcp-listener? listener) + (let loop () + (start-atomic) + (cond + [(tcp-listener-closed? listener) + (closed-error who listener)] + [(accept-ready? listener) + (check-current-custodian who) + (define fd (rktio_accept rktio (tcp-listener-lnr listener))) + (cond + [(rktio-error? fd) + (end-atomic) + (raise-network-error who fd "accept from listener failed")] + [else + (begin0 + (open-input-output-accetped-tcp fd) + (end-atomic))])] + [else + (end-atomic) + (sync (rktio-evt + ;; in atomic mode + (lambda () + (or (tcp-listener-closed? listener) + (accept-ready? listener))) + ;; in atomic mode + (lambda (ps) + (rktio_poll_add_accept rktio (tcp-listener-lnr listener) ps)))) + (loop)]))) + +(define/who (tcp-accept-ready? listener) + (check who tcp-listener? listener) + (start-atomic) + (cond + [(tcp-listener-closed? listener) + (closed-error who listener)] + [else (accept-ready? listener)])) + +;; ---------------------------------------- + +(define/who (tcp-accept-evt listener) + (check who tcp-listener? listener) + (accept-evt listener)) + +(struct accept-evt (listener) + #:property + prop:evt + (poller + ;; in atomic mode + (lambda (self poll-ctx) + (define listener (accept-evt-listener self)) + (cond + [(tcp-listener-closed? listener) + (error-result (lambda () + (start-atomic) + (closed-error 'tcp-accept-evt listener)))] + [(custodian-shut-down? (current-custodian)) + (let ([c (current-custodian)]) + (error-result (lambda () + (start-atomic) + (parameterize ([current-custodian c]) + (check-current-custodian 'tcp-accept-evt)))))] + [(accept-ready? listener) + (define fd (rktio_accept rktio (tcp-listener-lnr listener))) + (cond + [(rktio-error? fd) + (end-atomic) + (error-result (lambda () + (raise-network-error 'tcp-accept-evt fd "accept from listener failed")))] + [else + (values (list (call-with-values (lambda () (open-input-output-accetped-tcp fd)) + list)) + #f)])] + [else + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + (schedule-info-current-exts sched-info + (sandman-add-poll-set-adder + (schedule-info-current-exts sched-info) + (lambda (ps) + (rktio_poll_add_accept rktio (tcp-listener-lnr listener) ps))))) + (values #f self)]))) + #:reflection-name 'tcp-accept-evt) + +(define (error-result thunk) + (values #f + (wrap-evt always-evt (lambda (v) (thunk))))) + +;; ---------------------------------------- + +;; in atomic mode +;; assumes that listener is not closed +(define (accept-ready? listener) + (not (eqv? (rktio_poll_accept_ready rktio (tcp-listener-lnr listener)) + RKTIO_POLL_NOT_READY))) + +;; in atomic mode +(define (closed-error who listener) + (end-atomic) + (raise-arguments-error who + "listener is closed" + "listener" listener)) + +;; in atomic mode +(define (open-input-output-accetped-tcp fd) + (open-input-output-tcp fd "tcp-accepted")) diff --git a/racket/src/io/network/tcp-address.rkt b/racket/src/io/network/tcp-address.rkt new file mode 100644 index 0000000000..9f4e06a121 --- /dev/null +++ b/racket/src/io/network/tcp-address.rkt @@ -0,0 +1,76 @@ +#lang racket/base +(require "../common/check.rkt" + "../string/convert.rkt" + "../string/integer.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../port/close.rkt" + "../port/fd-port.rkt" + "tcp-port.rkt" + "tcp-listen.rkt" + "udp-socket.rkt" + "error.rkt") + +(provide tcp-addresses) + +(define/who (tcp-addresses p [port-numbers? #f]) + (check who (lambda (p) (or (tcp-port? p) (tcp-listener? p) (udp? p))) + #:contract "(or/c tcp-port? tcp-listener? udp?)" + p) + (start-atomic) + (define-values (local-address peer-address) + (cond + [(tcp-listener? p) + (cond + [(tcp-listener-closed? p) + (end-atomic) + (raise-arguments-error who + "listener is closed" + "listener" p)] + [else + (values (rktio_listener_address rktio (tcp-listener-lnr p)) + #f)])] + [else + (define fd + (cond + [(udp? p) + (check-udp-closed who p) + (udp-s p)] + [(port-closed? p) + (end-atomic) + (raise-arguments-error who + "port is closed" + "port" p)] + [else (fd-port-fd p)])) + (values (rktio_socket_address rktio fd) + (rktio_socket_peer_address rktio fd))])) + (define local-address-bytes (and (not (rktio-error? local-address)) + (rktio_to_bytes_list local-address 2))) + (define peer-address-bytes (and peer-address + (not (rktio-error? peer-address)) + (rktio_to_bytes_list peer-address 2))) + (end-atomic) + + (when (rktio-error? local-address) + (raise-network-error who local-address "could not get address")) + (when (and (rktio-error? peer-address) + ;; It's ok for the peer-address request to fail for UDP sockets + (not (udp? p))) + (raise-network-error who peer-address "could not get peer address")) + + (define (convert bstr) (bytes->string/utf-8 bstr #\?)) + (define local-hostname (convert (car local-address-bytes))) + (define peer-hostname (if peer-address-bytes + (convert (car peer-address-bytes)) + "0.0.0.0")) + + (cond + [port-numbers? + (values local-hostname + (string->integer (convert (cadr local-address-bytes))) + peer-hostname + (if peer-address-bytes + (string->integer (convert (cadr peer-address-bytes))) + 0))] + [else + (values local-hostname peer-hostname)])) diff --git a/racket/src/io/network/tcp-connect.rkt b/racket/src/io/network/tcp-connect.rkt new file mode 100644 index 0000000000..9526f3bba5 --- /dev/null +++ b/racket/src/io/network/tcp-connect.rkt @@ -0,0 +1,109 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/resource.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../security/main.rkt" + "../format/main.rkt" + "tcp-port.rkt" + "port-number.rkt" + "address.rkt" + "evt.rkt" + "error.rkt") + +(provide tcp-connect + tcp-connect/enable-break) + +(define/who (tcp-connect hostname port-no [local-hostname #f] [local-port-no #f]) + (do-tcp-connect who hostname port-no local-hostname local-port-no)) + +(define/who (tcp-connect/enable-break hostname port-no [local-hostname #f] [local-port-no #f]) + (do-tcp-connect who #:enable-break? #t hostname port-no local-hostname local-port-no)) + +(define (do-tcp-connect who hostname port-no [local-hostname #f] [local-port-no #f] + #:enable-break? [enable-break? #f]) + (check who string? hostname) + (check who port-number? port-no) + (check who string? #:or-false local-hostname) + (check who port-number? #:or-false local-port-no) + (when (and local-hostname (not local-port-no)) + (raise-arguments-error who + "no local port number supplied when local hostname was supplied" + "hostname" local-hostname)) + ;; in atomic mode (but exits atomic mode to raise an exception) + (define (raise-connect-error err + [what "connection failed"] + [hostname hostname] + [port-no port-no]) + (end-atomic) + (raise-network-error who err + (string-append what + (if hostname + (format "\n hostname: ~a" hostname) + "") + (if port-no + (format "\n port number: ~a" port-no) + "")))) + (security-guard-check-network who hostname port-no #t) + (atomically + (call-with-resolved-address + hostname port-no + #:enable-break? enable-break? + ;; in atomic mode + (lambda (remote-addr) + (cond + [(rktio-error? remote-addr) + (raise-connect-error remote-addr "host not found")] + [else + (call-with-resolved-address + local-hostname local-port-no + #:enable-break? enable-break? + ;; in atomic mode + (lambda (local-addr) + (cond + [(rktio-error? local-addr) + (raise-connect-error local-addr "local host not found" local-hostname local-port-no)] + [else + (call-with-resource + (box (rktio_start_connect rktio remote-addr local-addr)) + ;; in atomic mode + (lambda (conn-box) + (define conn (unbox conn-box)) + (when conn + (rktio_connect_stop rktio conn))) + ;; in atomic mode + (lambda (conn-box) + (define conn (unbox conn-box)) + (cond + [(rktio-error? conn) + (raise-connect-error conn)] + [else + (let loop () + (cond + [(eqv? (rktio_poll_connect_ready rktio conn) + RKTIO_POLL_NOT_READY) + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (not (eqv? (rktio_poll_connect_ready rktio conn) + RKTIO_POLL_NOT_READY))) + (lambda (ps) + (rktio_poll_add_connect rktio conn ps)))) + (start-atomic) + (loop)] + [else + (check-current-custodian who) + (define fd (rktio_connect_finish rktio conn)) + (cond + [(rktio-error? fd) + (cond + [(racket-error? fd RKTIO_ERROR_CONNECT_TRYING_NEXT) + (loop)] + [else + ;; other errors imply that `conn` is destroyed + (set-box! conn-box #f) + (raise-connect-error fd)])] + [else + (define name (string->immutable-string hostname)) + (open-input-output-tcp fd name)])]))])))])))]))))) diff --git a/racket/src/io/network/tcp-listen.rkt b/racket/src/io/network/tcp-listen.rkt new file mode 100644 index 0000000000..aee2a30b7b --- /dev/null +++ b/racket/src/io/network/tcp-listen.rkt @@ -0,0 +1,110 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../security/main.rkt" + "../sandman/main.rkt" + "port-number.rkt" + "address.rkt" + "error.rkt") + +(provide tcp-listen + tcp-listener? + tcp-close + + tcp-listener-lnr + tcp-listener-closed?) + +(struct tcp-listener (lnr + closed ; boxed boolean + custodian-reference) + #:authentic + #:property prop:evt (poller (lambda (l ctx) (poll-listener l ctx)))) + +(define/who (tcp-listen port-no [max-allow-wait 4] [reuse? #f] [hostname #f]) + (check who listen-port-number? port-no) + (check who exact-nonnegative-integer? max-allow-wait) + (check who string? #:or-false hostname) + (define (raise-listen-error what err) + (end-atomic) + (raise-network-error who err + (string-append what + (if hostname + (format "\n hostname: ~a" hostname) + "") + (format "\n port number: ~a" port-no)))) + (security-guard-check-network who hostname port-no #f) + (let loop ([family RKTIO_FAMILY_ANY]) + ((atomically + ;; Result is a thunk that might call `loop` + ;; or might return a listener + (call-with-resolved-address + hostname port-no + ;; in atomic mode + (lambda (addr) + (cond + [(rktio-error? addr) + (raise-listen-error "address-resolution error" addr)] + [else + (check-current-custodian who) + (define lnr (rktio_listen rktio addr (min max-allow-wait 10000) reuse?)) + (cond + [(rktio-error? lnr) + (cond + [(racket-error? lnr RKTIO_ERROR_TRY_AGAIN_WITH_IPV4) + (lambda () (loop (rktio_get_ipv4_family rktio)))] + [else + (raise-listen-error "listen failed" lnr)])] + [else + (define closed (box #f)) + (define custodian-reference + (unsafe-custodian-register (current-custodian) + lnr + ;; in atomic mode + (lambda (fd) (do-tcp-close lnr closed)) + #f + #f)) + (lambda () + (tcp-listener lnr closed custodian-reference))])]))))))) + +; in atomic mode +(define (do-tcp-close lnr closed) + (rktio_listen_stop rktio lnr) + (set-box! closed #t)) + +(define/who (tcp-close listener) + (check who tcp-listener? listener) + (define closed (tcp-listener-closed listener)) + (start-atomic) + (cond + [(unbox closed) + (end-atomic) + (raise-arguments-error who + "listener is closed" + "listener" listener)] + [else + (define lnr (tcp-listener-lnr listener)) + (do-tcp-close lnr closed) + (unsafe-custodian-unregister lnr (tcp-listener-custodian-reference listener)) + (end-atomic)])) + +;; in atomic mode +(define (tcp-listener-closed? listener) + (unbox (tcp-listener-closed listener))) + +;; ---------------------------------------- + +;; in atomic mode +(define (poll-listener l ctx) + (cond + [(unbox (tcp-listener-closed l)) + (values (list l) #f)] + [(eqv? (rktio_poll_accept_ready rktio (tcp-listener-lnr l)) + RKTIO_POLL_READY) + (values (list l) #f)] + [else + (sandman-poll-ctx-add-poll-set-adder! + ctx + (lambda (ps) + (rktio_poll_add_accept rktio (tcp-listener-lnr l) ps))) + (values #f l)])) diff --git a/racket/src/io/network/tcp-port.rkt b/racket/src/io/network/tcp-port.rkt new file mode 100644 index 0000000000..c26aa4a41b --- /dev/null +++ b/racket/src/io/network/tcp-port.rkt @@ -0,0 +1,59 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/rktio.rkt" + "../port/port.rkt" + "../port/input-port.rkt" + "../port/output-port.rkt" + "../port/fd-port.rkt") + +(provide open-input-output-tcp + tcp-port? + tcp-abandon-port) + +(struct tcp-data (abandon-in? abandon-out?) + #:mutable + #:authentic) + +(define (open-input-output-tcp fd name #:close? [close? #t]) + (define refcount (box (if close? 2 3))) + (define extra-data (tcp-data #f #f)) + (values + (open-input-fd fd name + #:extra-data extra-data + #:on-close + ;; in atomic mode + (lambda () + (unless (tcp-data-abandon-in? extra-data) + (rktio_socket_shutdown rktio fd RKTIO_SHUTDOWN_READ))) + #:fd-refcount refcount) + (open-output-fd fd name + #:extra-data extra-data + #:on-close + ;; in atomic mode + (lambda () + (unless (tcp-data-abandon-out? extra-data) + (rktio_socket_shutdown rktio fd RKTIO_SHUTDOWN_WRITE))) + #:fd-refcount refcount + #:buffer-mode 'block))) + +(define (port-tcp-data p) + (maybe-fd-data-extra + (cond + [(input-port? p) + (core-port-data + (->core-input-port p))] + [(output-port? p) + (core-port-data + (->core-output-port p))] + [else #f]))) + +(define/who (tcp-port? p) + (tcp-data? (port-tcp-data p))) + +(define/who (tcp-abandon-port p) + (define data (port-tcp-data p)) + (unless (tcp-data? data) + (raise-argument-error who "tcp-port?" p)) + (if (input-port? p) + (set-tcp-data-abandon-in?! data #t) + (set-tcp-data-abandon-out?! data #t))) diff --git a/racket/src/io/network/tcp.rkt b/racket/src/io/network/tcp.rkt new file mode 100644 index 0000000000..d7e9ffb625 --- /dev/null +++ b/racket/src/io/network/tcp.rkt @@ -0,0 +1,23 @@ +#lang racket/base +(require "tcp-port.rkt" + "tcp-connect.rkt" + "tcp-listen.rkt" + "tcp-accept.rkt" + "tcp-address.rkt") + +(provide tcp-port? + tcp-abandon-port + + tcp-connect + tcp-connect/enable-break + + tcp-listen + tcp-listener? + tcp-close + + tcp-accept + tcp-accept-evt + tcp-accept-ready? + tcp-accept/enable-break + + tcp-addresses) diff --git a/racket/src/io/network/udp-multicast.rkt b/racket/src/io/network/udp-multicast.rkt new file mode 100644 index 0000000000..53d7a760a2 --- /dev/null +++ b/racket/src/io/network/udp-multicast.rkt @@ -0,0 +1,143 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../string/convert.rkt" + "udp-socket.rkt" + "address.rkt" + "error.rkt") + +(provide udp-multicast-join-group! + udp-multicast-leave-group! + + udp-multicast-interface + udp-multicast-set-interface! + + udp-multicast-loopback? + udp-multicast-set-loopback! + + udp-multicast-ttl + udp-multicast-set-ttl!) + +;; ---------------------------------------- + +(define/who (udp-multicast-join-group! u + multicast-hostname + hostname) + (do-udp-multicast-join-or-leave-group! who + RKTIO_ADD_MEMBERSHIP + u + multicast-hostname + hostname)) + +(define/who (udp-multicast-leave-group! u + multicast-hostname + hostname) + (do-udp-multicast-join-or-leave-group! who + RKTIO_DROP_MEMBERSHIP + u + multicast-hostname + hostname)) + +(define (do-udp-multicast-join-or-leave-group! who action u multicast-hostname hostname) + (check who udp? u) + (check who string? multicast-hostname) + (check who string? #:or-false hostname) + (atomically + (call-with-resolved-address + #:who who + #:which "multicast " + #:port-number-on-error? #f + multicast-hostname -1 + #:family (udp-default-family) + #:tcp? #f + (lambda (multicast-addr) + (call-with-resolved-address + #:who who + #:which "interface " + #:port-number-on-error? #f + hostname (and hostname -1) + #:family (udp-default-family) + #:tcp? #f + (lambda (intf-addr) + (check-udp-closed who u) + (define v (rktio_udp_change_multicast_group rktio (udp-s u) multicast-addr intf-addr action)) + (when (rktio-error? v) + (raise-option-error who "set" v)))))))) + +(define (raise-option-error who mode v) + (end-atomic) + (raise-network-error who v (string-append mode "sockopt failed"))) + +;; ---------------------------------------- + +(define/who (udp-multicast-interface u) + (check who udp? u) + (start-atomic) + (check-udp-closed who u) + (define v (rktio_udp_multicast_interface rktio (udp-s u))) + (cond + [(rktio-error? v) + (raise-option-error who "get" v)] + [else + (define bstr (rktio_to_bytes v)) + (rktio_free v) + (end-atomic) + (bytes->string/utf-8 bstr)])) + +(define/who (udp-multicast-set-interface! u hostname) + (check who udp? u) + (check who string? #:or-false hostname) + (atomically + (call-with-resolved-address + #:who who + #:port-number-on-error? #f + hostname (and hostname -1) + #:family (udp-default-family) + #:tcp? #f + (lambda (addr) + (check-udp-closed who u) + (define r (rktio_udp_set_multicast_interface rktio (udp-s u) addr)) + (when (rktio-error? r) + (raise-option-error who "set" r)))))) + +;; ---------------------------------------- + +(define/who (udp-multicast-loopback? u) + (check who udp? u) + (atomically + (check-udp-closed who u) + (define v (rktio_udp_get_multicast_loopback rktio (udp-s u))) + (cond + [(rktio-error? v) + (raise-option-error who "get" v)] + [else (not (zero? v))]))) + +(define/who (udp-multicast-set-loopback! u loopback?) + (check who udp? u) + (atomically + (check-udp-closed who u) + (define r (rktio_udp_set_multicast_loopback rktio (udp-s u) loopback?)) + (when (rktio-error? r) + (raise-option-error who "set" r)))) + +;; ---------------------------------------- + +(define/who (udp-multicast-ttl u) + (check who udp? u) + (atomically + (check-udp-closed who u) + (define v (rktio_udp_get_multicast_ttl rktio (udp-s u))) + (cond + [(rktio-error? v) + (raise-option-error who "get" v)] + [else v]))) + +(define/who (udp-multicast-set-ttl! u ttl) + (check who udp? u) + (check who byte? ttl) + (atomically + (check-udp-closed who u) + (define r (rktio_udp_set_multicast_ttl rktio (udp-s u) ttl)) + (when (rktio-error? r) + (raise-option-error who "set" r)))) diff --git a/racket/src/io/network/udp-receive.rkt b/racket/src/io/network/udp-receive.rkt new file mode 100644 index 0000000000..bdfaa064a9 --- /dev/null +++ b/racket/src/io/network/udp-receive.rkt @@ -0,0 +1,155 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt" + "../string/convert.rkt" + "../string/integer.rkt" + "port-number.rkt" + "check.rkt" + "address.rkt" + "udp-socket.rkt" + "error.rkt" + "evt.rkt") + +(provide udp-receive! + udp-receive!* + udp-receive!/enable-break + + udp-receive!-evt + udp-receive-ready-evt) + +(define/who (udp-receive! u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (do-udp-receive! who u bstr start end)) + +(define/who (udp-receive!* u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (do-udp-receive! who #:wait? #f u bstr start end)) + +(define/who (udp-receive!/enable-break u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (do-udp-receive! who #:enable-break? #t u bstr start end)) + +(define (do-udp-receive! who u bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f]) + (check-receive! who u bstr start end) + (atomically + (do-udp-maybe-receive! who u bstr start end + #:wait? wait? + #:enable-break? enable-break?))) + +(define/who (udp-receive!-evt u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-receive! who u bstr start end) + (udp-receiving-evt + u + ;; in atomic mode: + (lambda () + (do-udp-maybe-receive! who u bstr start end + #:wait? #f + #:handle-error (lambda (thunk) thunk))))) + +(define/who (udp-receive-ready-evt u) + (check who udp? u) + (udp-receiving-ready-evt + (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_read_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_READ)))) + +(define (check-receive! who u bstr start end) + (check who udp? u) + (check-bstr who bstr start end)) + +;; ---------------------------------------- + +;; in atomic mode +(define (do-udp-maybe-receive! who u bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f] + #:handle-error [handle-error handle-error-immediately]) + (let loop () + ;; re-check closed on every iteration, in case the state changes + ;; while we block + (check-udp-closed + who u + #:handle-error handle-error + #:continue + (lambda () + (cond + [(not (udp-bound? u)) + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is not bound" + "socket" u)))] + [else + (define r (rktio_udp_recvfrom_in rktio (udp-s u) bstr start end)) + (cond + [(rktio-error? r) + (cond + [(or (racket-error? r RKTIO_ERROR_TRY_AGAIN) + (racket-error? r RKTIO_ERROR_INFO_TRY_AGAIN)) + (cond + [wait? + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_read_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_READ)))) + (start-atomic) + (loop)] + [else (values #f #f #f)])] + [else + (handle-error + (lambda () + (raise-network-error who r "receive failed")))])] + [else + (define len (rktio_recv_length_ref r)) + (define address (rktio_to_bytes_list (rktio_recv_address_ref r) 2)) + (rktio_free r) + (values len + (if (bytes=? (car address) cached-address-bytes) + cached-address-string + (begin + (set! cached-address-bytes (car address)) + (set! cached-address-string (string->immutable-string + (bytes->string/utf-8 cached-address-bytes #\?))) + cached-address-string)) + (string->integer (bytes->string/utf-8 (cadr address))))])]))))) + +(define cached-address-bytes #"") +(define cached-address-string "") + +;; ---------------------------------------- + +(struct udp-receiving-evt (u try) + #:property + prop:evt + (poller + ;; in atomic mode + (lambda (self poll-ctx) + (define try (udp-receiving-evt-try self)) + (call-with-values try + (case-lambda + [(thunk) + ;; `thunk` that raises an exception + (values #f (wrap-evt always-evt (lambda (v) (thunk))))] + [(r hostname port-no) + (cond + [r + (values (list (list r hostname port-no)) #f)] + [else + (sandman-poll-ctx-add-poll-set-adder! + poll-ctx + (lambda (ps) + (rktio_poll_add rktio (udp-s (udp-receiving-evt-u self)) ps RKTIO_POLL_WRITE))) + (values #f self)])])))) + #:reflection-name 'udp-receive-evt + #:authentic) + +(struct udp-receiving-ready-evt rktio-evt () + #:reflection-name 'udp-receive-ready-evt + #:authentic) diff --git a/racket/src/io/network/udp-send.rkt b/racket/src/io/network/udp-send.rkt new file mode 100644 index 0000000000..c110c701f1 --- /dev/null +++ b/racket/src/io/network/udp-send.rkt @@ -0,0 +1,199 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt" + "../security/main.rkt" + "port-number.rkt" + "check.rkt" + "address.rkt" + "udp-socket.rkt" + "error.rkt" + "evt.rkt") + +(provide udp-send + udp-send* + udp-send-to/enable-break + + udp-send-to + udp-send-to* + udp-send/enable-break + + udp-send-evt + udp-send-to-evt + udp-send-ready-evt) + +(define/who (udp-send u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to who u #f #f bstr start end)) + +(define/who (udp-send* u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to who #:wait? #f u #f #f bstr start end)) + +(define/who (udp-send/enable-break u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to who #:enable-break? #t u #f #f bstr start end)) + +(define/who (udp-send-to u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to who u hostname port-no bstr start end)) + +(define/who (udp-send-to* u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to who #:wait? #f u hostname port-no bstr start end)) + +(define/who (udp-send-to/enable-break u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to who #:enable-break? #t u hostname port-no bstr start end)) + +(define/who (udp-send-evt u bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send who u bstr start end) + (do-udp-send-to-evt who u #f #f bstr start end)) + +(define/who (udp-send-to-evt u hostname port-no bstr [start 0] [end (and (bytes? bstr) (bytes-length bstr))]) + (check-send-to who u hostname port-no bstr start end) + (do-udp-send-to-evt who u hostname port-no bstr start end)) + +(define/who (udp-send-ready-evt u) + (check who udp? u) + (udp-sending-ready-evt + (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_write_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_WRITE)))) + +;; ---------------------------------------- + +(define (check-send who u bstr start end) + (check who udp? u) + (check-bstr who bstr start end)) + +(define (check-send-to who u hostname port-no bstr start end) + (check who udp? u) + (check who string? hostname) + (check who port-number? port-no) + (check-bstr who bstr start end) + (security-guard-check-network who hostname port-no #t)) + +;; ---------------------------------------- + +(define (do-udp-send-to who u hostname port-no bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f]) + (atomically + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + (lambda (addr) + (do-udp-maybe-send-to-addr who u addr bstr start end + #:wait? wait? + #:enable-break? enable-break?))))) + +(define (do-udp-send-to-evt who u hostname port-no bstr start end) + (atomically + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + #:retain-address? #t + (lambda (addr) + ;; FIXME: need to finalize `addr` + (udp-sending-evt + u + ;; in atomic mode: + (lambda () + (when addr (register-address-finalizer addr)) + (do-udp-maybe-send-to-addr who u addr bstr start end + #:wait? #f + #:handle-error (lambda (thunk) thunk)))))))) + +; in atomic mode +(define (do-udp-maybe-send-to-addr who u addr bstr start end + #:wait? [wait? #t] + #:enable-break? [enable-break? #f] + #:handle-error [handle-error handle-error-immediately]) + (let loop () + ;; re-check closed, connected, etc., on every iteration, + ;; in case the state changes while we block + (check-udp-closed + who u + #:handle-error handle-error + #:continue + (lambda () + (cond + [(and addr (udp-connected? u)) + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is connected" + "socket" u)))] + [(and (not addr) (not (udp-connected? u))) + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is not connected" + "socket" u)))] + [else + ;; if the socket is not bound already, send[to] binds it + (set-udp-bound?! u #t) + (define r (rktio_udp_sendto_in rktio (udp-s u) addr bstr start end)) + (cond + [(rktio-error? r) + (handle-error + (lambda () + (raise-network-error who r "send failed")))] + [(eqv? r 0) + (cond + [(not wait?) #f] + [else + (end-atomic) + ((if enable-break? sync/enable-break sync) + (rktio-evt (lambda () + (or (not (udp-s u)) + (not (eqv? (rktio_poll_write_ready rktio (udp-s u)) + RKTIO_POLL_NOT_READY)))) + (lambda (ps) + (rktio_poll_add rktio (udp-s u) ps RKTIO_POLL_WRITE)))) + (start-atomic) + (loop)])] + [(= r (- end start)) (if wait? (void) #t)] + [else + (handle-error + (lambda () + (raise + (exn:fail:network + (string-append (symbol->string who) ": didn't send enough" + "\n requested bytes: " (number->string (- end start)) + "\n sent bytes: " r) + (current-continuation-marks)))))])]))))) + +;; ---------------------------------------- + +(struct udp-sending-evt (u try) + #:property + prop:evt + (poller + ;; in atomic mode + (lambda (self poll-ctx) + (define try (udp-sending-evt-try self)) + (define r (try)) + (cond + [(procedure? r) + ;; `r` is a thunk that raises an exception + (values #f (wrap-evt always-evt (lambda (v) (r))))] + [r + (values (list (void)) #f)] + [else + (sandman-poll-ctx-add-poll-set-adder! + poll-ctx + (lambda (ps) + (rktio_poll_add rktio (udp-s (udp-sending-evt-u self)) ps RKTIO_POLL_READ))) + (values #f self)]))) + #:reflection-name 'udp-send-evt + #:authentic) + +(struct udp-sending-ready-evt rktio-evt () + #:reflection-name 'udp-send-ready-evt + #:authentic) diff --git a/racket/src/io/network/udp-socket.rkt b/racket/src/io/network/udp-socket.rkt new file mode 100644 index 0000000000..18d8632a2a --- /dev/null +++ b/racket/src/io/network/udp-socket.rkt @@ -0,0 +1,145 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../security/main.rkt" + "port-number.rkt" + "address.rkt" + "error.rkt") + +(provide udp? + udp-open-socket + udp-close + + udp-bound? + udp-connected? + + udp-bind! + udp-connect! + + check-udp-closed + handle-error-immediately + udp-default-family + + udp-s + set-udp-bound?! + set-udp-connected?!) + +(struct udp (s bound? connected?) + #:mutable + #:authentic) + +(define/who (udp-open-socket [family-hostname #f] [family-port-no #f]) + (check who string? #:or-false family-hostname) + (check who port-number? #:or-false family-port-no) + (security-guard-check-network who family-hostname family-port-no #f) + (atomically + (call-with-resolved-address + #:who who + family-hostname family-port-no + #:tcp? #f + (lambda (addr) + (define s (rktio_udp_open rktio addr (udp-default-family))) + (cond + [(rktio-error? s) + (end-atomic) + (raise-network-error who s "creation failed")] + [else + (udp s #f #f)]))))) + +(define/who (udp-close u) + (check who udp? u) + (atomically + (cond + [(udp-s u) + (rktio_close rktio (udp-s u)) + (set-udp-s! u #f)] + [else + (end-atomic) + (raise-network-arguments-error who "udp socket was already closed" + "socket" u)]))) + +;; ---------------------------------------- + +(define/who (udp-bind! u hostname port-no [reuse? #f]) + (check who udp? u) + (check who string? #:or-false hostname) + (check who listen-port-number? port-no) + (security-guard-check-network who hostname port-no #f) + (atomically + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + #:passive? #t + (lambda (addr) + (check-udp-closed who u) + (when (udp-bound? u) + (end-atomic) + (raise-arguments-error who "udp socket is already bound" + "socket" u)) + (define b (rktio_udp_bind rktio (udp-s u) addr reuse?)) + (when (rktio-error? b) + (end-atomic) + (raise-network-error who b + (string-append "can't bind" (if reuse? " as reusable" "") + "\n address: " (or hostname "") + "\n port number: " (number->string port-no)))) + (set-udp-bound?! u #t))))) + +(define/who (udp-connect! u hostname port-no) + (check who udp? u) + (check who string? #:or-false hostname) + (check who port-number? #:or-false port-no) + (unless (eq? (not hostname) (not port-no)) + (raise-arguments-error who + "last second and third arguments must be both #f or both non-#f" + "second argument" hostname + "third argument" port-no)) + (security-guard-check-network who hostname port-no #t) + (atomically + (cond + [(not hostname) + (check-udp-closed who u) + (when (udp-connected? u) + (define d (rktio_udp_disconnect rktio (udp-s u))) + (when (rktio-error? d) + (end-atomic) + (raise-network-error who d "can't disconnect")) + (set-udp-connected?! u #f))] + [else + (call-with-resolved-address + #:who who + hostname port-no + #:tcp? #f + (lambda (addr) + (check-udp-closed who u) + (define c (rktio_udp_connect rktio (udp-s u) addr)) + (when (rktio-error? c) + (end-atomic) + (raise-network-error who c + (string-append "can't connect" + "\n address: " hostname + "\n port number: " (number->string port-no)))) + (set-udp-connected?! u #t)))]))) + +;; ---------------------------------------- + +;; in atomic mode +(define (check-udp-closed who u + #:handle-error [handle-error handle-error-immediately] + #:continue [continue void]) + (cond + [(udp-s u) (continue)] + [else + (handle-error + (lambda () + (raise-network-arguments-error who "udp socket is closed" + "socket" u)))])) + +(define (handle-error-immediately thunk) + (end-atomic) + (thunk)) + +(define (udp-default-family) + (rktio_get_ipv4_family rktio)) diff --git a/racket/src/io/network/udp.rkt b/racket/src/io/network/udp.rkt new file mode 100644 index 0000000000..f48aeab087 --- /dev/null +++ b/racket/src/io/network/udp.rkt @@ -0,0 +1,38 @@ +#lang racket/base +(require "udp-socket.rkt" + "udp-send.rkt" + "udp-receive.rkt" + "udp-multicast.rkt") + +(provide udp-open-socket + udp-close + udp? + udp-bound? + udp-connected? + udp-bind! + udp-connect! + + udp-send + udp-send* + udp-send-to/enable-break + udp-send-to + udp-send-to* + udp-send/enable-break + udp-send-evt + udp-send-to-evt + udp-send-ready-evt + + udp-receive! + udp-receive!* + udp-receive!/enable-break + udp-receive!-evt + udp-receive-ready-evt + + udp-multicast-join-group! + udp-multicast-leave-group! + udp-multicast-interface + udp-multicast-set-interface! + udp-multicast-loopback? + udp-multicast-set-loopback! + udp-multicast-ttl + udp-multicast-set-ttl!) diff --git a/racket/src/io/path/api.rkt b/racket/src/io/path/api.rkt new file mode 100644 index 0000000000..5ade8cfaea --- /dev/null +++ b/racket/src/io/path/api.rkt @@ -0,0 +1,53 @@ +#lang racket/base +(require "../common/check.rkt" + "../security/main.rkt" + "../file/host.rkt" + (prefix-in raw: "parameter.rkt") + (rename-in "complete.rkt" + [path->complete-path raw:path->complete-path]) + (only-in '#%kernel + ;; get `chaperone-procedure` that doesn't support keyword arguments: + chaperone-procedure) + "path.rkt") + +(provide path->complete-path + current-drive + + current-directory + current-directory-for-user + current-load-relative-directory) + +(define path->complete-path + (case-lambda + [(p) + ;; Supplying `current-directory` (as opposed to `raw:current-directory`) + ;; triggers an appropriate security-guard check if needed: + (raw:path->complete-path p current-directory #:wrt-given? #f)] + [(p wrt) (raw:path->complete-path p wrt #:wrt-given? #t)])) + +(define/who (current-drive) + (security-guard-check-file who #f '(exists)) + (if (eq? (system-path-convention-type) 'unix) + (string->path "/") + (error who "not yet ready"))) + +;; ---------------------------------------- + +(define (make-guard-paths who) + (case-lambda + [() + (security-guard-check-file who #f '(exists)) + (values)] + [(path) + (when (path-string? path) + (->host path who '(exists))) + path])) + +(define/who current-directory + (chaperone-procedure raw:current-directory (make-guard-paths who))) + +(define/who current-directory-for-user + (chaperone-procedure raw:current-directory-for-user (make-guard-paths who))) + +(define/who current-load-relative-directory + (chaperone-procedure raw:current-load-relative-directory (make-guard-paths who))) diff --git a/racket/src/io/path/build.rkt b/racket/src/io/path/build.rkt new file mode 100644 index 0000000000..f29f9c9c8f --- /dev/null +++ b/racket/src/io/path/build.rkt @@ -0,0 +1,408 @@ +#lang racket/base +(require "../locale/string.rkt" + "check.rkt" + "path.rkt" + "sep.rkt" + "windows.rkt") + +(provide build-path + build-path/convention-type) + +(define (build-path base . subs) + (build 'build-path #f base subs)) + +(define (build-path/convention-type convention base . subs) + (build 'build-path/convention-type convention base subs)) + +(define (build who init-convention base subs) + (check-build-path-arg who base) + (define convention + (let loop ([convention (argument->convention base init-convention who #:first? #t)] + [subs subs]) + (cond + [(null? subs) convention] + [else + (define sub (car subs)) + (check-build-path-arg who sub) + (loop (argument->convention sub convention who #:first? #f) + (cdr subs))]))) + (path (append-path-parts convention who base subs) + convention)) + +;; ---------------------------------------- + +(define (check-build-path-arg who p) + (check who + (lambda (p) (or (path-string? p) + (path-for-some-system? p) + (eq? p 'up) + (eq? p 'same))) + #:contract "(or/c path-string? path-for-some-system? 'up 'same)" + p)) + +(define (argument->convention p convention who #:first? first?) + (define (check c) + (when (and convention (not (eq? c convention))) + (raise-arguments-error who + (format + (if first? + "specified convention incompatible with ~a path element" + "preceding path's convention incompatible with ~a path element") + (if (string? p) + "string" + "given")) + "path element" p + (if first? "convention" "preceding path's convention") + convention)) + c) + (cond + [(path? p) (check (path-convention p))] + [(string? p) (check (system-path-convention-type))] + [else (or convention (system-path-convention-type))])) + +;; ---------------------------------------- + +(define (append-path-parts convention who base subs) + (define result-is-backslash-backslash-questionmark? + (and (eq? convention 'windows) + (for/or ([sub (in-list (cons base subs))]) + (backslash-backslash-questionmark? (as-bytes sub))))) + (define base-accum + (let ([bstr (as-bytes base)]) + (cond + [(eq? convention 'windows) + (if result-is-backslash-backslash-questionmark? + (convert-to-initial-backslash-backslash-questionmark bstr) + (list (strip-trailing-spaces bstr)))] + [else (list bstr)]))) + ;; The `accum` list accumulates byte strings in reverse order to be + ;; appended. On Windows in \\?\ mode, each byte string corresponds + ;; to a single path element with a leading backslash, except that + ;; the last item is a arting-point`; otherwise, the byte strings can + ;; be a mixture of compound path elements and separators + (let loop ([accum base-accum] [subs subs] [first? #t]) + (cond + [(null? subs) + (define elems (reverse accum)) + (combine-build-elements elems)] + [else + (define sub (car subs)) + (define bstr (as-bytes sub)) + (case convention + [(unix) + ;; Unix is fairly straightforward + (when (is-sep? (bytes-ref bstr 0) 'unix) + (raise-arguments-error who + "absolute path cannot be added to a path" + "absolute path" sub)) + (define prev (car accum)) + (cond + [(is-sep? (bytes-ref prev (sub1 (bytes-length prev))) 'unix) + (loop (cons bstr accum) (cdr subs) #f)] + [else + (loop (list* bstr #"/" accum) (cdr subs) #f)])] + [(windows) + ;; For Windows, the implementation immediately here is + ;; mostly error checking, and actual combining work is in + ;; `combine-windows-path` + (define len (bytes-length bstr)) + (define (combine is-rel? is-complete? is-drive?) + (when (or is-complete? + (and (not is-rel?) + (not first?) + (not (and (null? (cdr accum)) + (drive? (car accum)))))) + (define what (if is-drive? "drive" "absolute path")) + (raise-arguments-error who + (string-append what " cannot be added to a base path") + what sub + "base path" (path (combine-build-elements (reverse accum)) + 'windows))) + (loop (combine-windows-path (if (and (null? subs) + ;; because \\?\ mode does its own stripping: + (not result-is-backslash-backslash-questionmark?)) + bstr + (strip-trailing-spaces bstr)) + accum + result-is-backslash-backslash-questionmark?) + (cdr subs) + #f)) + (cond + [(is-sep? (bytes-ref bstr 0) 'windows) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + (combine (eq? kind 'rel) + (eq? kind 'abs) + (and (eq? kind 'abs) + (just-backslashes-after? bstr drive-len)))] + [(parse-unc bstr 0) + => (lambda (drive-len) + (combine #t #t (just-separators-after? bstr drive-len)))] + [else + (combine #f #f #f)])] + [(letter-drive-start? bstr len) + (combine #f #t (just-separators-after? bstr 2))] + [else + (combine #t #f #f)])])]))) + +(define (combine-windows-path bstr accum result-is-backslash-backslash-questionmark?) + (cond + [result-is-backslash-backslash-questionmark? + ;; Split `bstr` into pieces, and handle the pieces one-by-one + (let loop ([elems (windows-split-into-path-elements bstr)] [accum accum]) + (cond + [(null? elems) accum] + [else + (define sub (car elems)) + (cond + [(eq? 'same sub) + ;; Ignore 'same for \\?\ mode + (loop (cdr elems) accum)] + [(eq? 'up sub) + ;; Drop previous element for 'up in \\?\ mode + (loop (cdr elems) + (if (null? (cdr accum)) + (list (starting-point-add-up (car accum))) + (cdr accum)))] + [else + (loop (cdr elems) (cons sub accum))])]))] + [else + ;; Not in \\?\ mode, so `bstr` must not be a \\?\ path. + ;; In case `accum` is drive-relative, start by dropping any + ;; leading slashes. + (define len (bytes-length bstr)) + (define sub (let loop ([i 0]) + (cond + [(= i len) #""] + [(is-sep? (bytes-ref bstr i) 'windows) + (loop (add1 i))] + [(zero? i) bstr] + [else (subbytes bstr i)]))) + ;; Now, relatively simple: add a slash if needed between the parts + (define prev-bstr (car accum)) + (define new-accum (if (is-sep? (bytes-ref prev-bstr (sub1 (bytes-length prev-bstr))) 'windows) + accum + (cons #"\\" accum))) + (if (equal? sub #"") ; in case the argument was just "/" + new-accum + (cons sub new-accum))])) + +(define (windows-split-into-path-elements bstr) + (cond + [(backslash-backslash-questionmark? bstr) + ;; It must be REL or RED (with only a drive to build on) + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) + (append (extract-dot-ups bstr 8 (or dots-end 8)) + (extract-separate-parts bstr literal-start #:bbq-mode? #t))] + [else + (extract-separate-parts bstr 0)])) + +(define (as-bytes p) + (cond + [(eq? p 'up) #".."] + [(eq? p 'same) #"."] + [(path? p) (path-bytes p)] + [else (string->bytes/locale p (char->integer #\?))])) + +(define (just-separators-after? bstr drive-len) + (for/and ([b (in-bytes bstr drive-len)]) + (is-sep? b 'windows))) + +(define (just-backslashes-after? bstr drive-len) + (for/and ([b (in-bytes bstr drive-len)]) + (eqv? b (char->integer #\\)))) + +;; Check whether `s`, a byte string or a `starting-point`, +;; is just a drive, in which case we can add a non-complete +;; absolute path +(define (drive? s) + (cond + [(starting-point? s) (starting-point-drive? s)] + ;; must be a byte string + [(parse-unc s 0) + => (lambda (drive-len) (just-separators-after? s drive-len))] + [(letter-drive-start? s (bytes-length s)) + (just-separators-after? s 2)])) + +(struct starting-point (bstr ; byte string that contains the starting path + len ; number of bytes to use when adding more element + orig-len ; number of bytes to use when not adding more elements + extra-sep ; extra separator before first added element + add-ups? ; whether to add `up`s to the base string, as opposed to dropping them + drive?)) ; is bstr an absolute root? + +(define (make-starting-point bstr + len + #:orig-len [orig-len len] + #:extra-sep [extra-sep #""] + #:add-ups? [add-ups? #f] + #:drive? [drive? #t]) + (list + (starting-point bstr len orig-len extra-sep add-ups? drive?))) + +(define (combine-build-elements elems) + (cond + [(starting-point? (car elems)) + ;; in \\?\ mode for Windows + (define s (car elems)) + (cond + [(null? (cdr elems)) + (let ([bstr (subbytes (starting-point-bstr s) + 0 + (starting-point-orig-len s))]) + (cond + [(equal? bstr #"\\\\?\\REL") + #"."] + [(equal? bstr #"\\\\?\\RED") + #"\\"] + [else bstr]))] + [else + (define init-bstr (subbytes (starting-point-bstr s) + 0 + (starting-point-len s))) + (define rel-..-special-case? (and (bytes=? init-bstr #"\\\\?\\REL") + (bytes=? (cadr elems) #"\\.."))) + (apply bytes-append + init-bstr + (if rel-..-special-case? ; => need extra `\` to indicate that ".." is not 'up + #"\\" + #"") + (starting-point-extra-sep s) + (cdr elems))])] + [else + ;; simple case + (apply bytes-append elems)])) + +(define (convert-to-initial-backslash-backslash-questionmark bstr) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep) + (parse-backslash-backslash-questionmark bstr)) + (case kind + [(abs) + (append (reverse (extract-separate-parts bstr drive-len #:bbq-mode? #t)) + (if (equal? add-sep #"") + ;; drop implicit terminator in drive: + (make-starting-point bstr (sub1 drive-len) #:orig-len orig-drive-len) + (make-starting-point bstr drive-len #:orig-len orig-drive-len #:extra-sep (subbytes add-sep 1))))] + [else + ;; We can't back up over any dots before `dots-end`, + ;; so keep those toegether with \\?\REL + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) + (append (reverse (extract-separate-parts bstr literal-start #:bbq-mode? #t)) + (make-starting-point bstr (or dots-end 7) #:add-ups? (eq? kind 'rel) #:drive? #f))])] + [(parse-unc bstr 0) + => (lambda (root-len) + (define-values (machine volume) + (let ([l (extract-separate-parts (subbytes bstr 0 root-len) 0)]) + (values (car l) (cadr l)))) + (append (reverse (simplify-dots (extract-separate-parts bstr root-len) #:drop-leading? #t)) + (let* ([unc-bstr (bytes-append #"\\\\?\\UNC" machine volume)] + [unc-len (bytes-length unc-bstr)]) + (make-starting-point unc-bstr unc-len))))] + [(bytes=? #"." bstr) + (make-starting-point #"\\\\?\\REL" 7 #:add-ups? #t #:drive? #f)] + [(bytes=? #".." bstr) + (make-starting-point #"\\\\?\\REL\\.." 10 #:add-ups? #t #:drive? #f)] + [(is-sep? (bytes-ref bstr 0) 'windows) + (append (reverse (extract-separate-parts bstr 0)) + (make-starting-point #"\\\\?\\RED" 7 #:drive? #f))] + [(and ((bytes-length bstr) . >= . 2) + (drive-letter? (bytes-ref bstr 0)) + (eqv? (bytes-ref bstr 1) (char->integer #\:))) + (append (reverse (simplify-dots (extract-separate-parts bstr 2) #:drop-leading? #t)) + (let ([drive-bstr (bytes-append #"\\\\?\\" (subbytes bstr 0 2) #"\\")]) + (make-starting-point drive-bstr 6 #:orig-len 7)))] + [else + ;; Create \\?\REL, combinding any leading dots into the \\?\REL part: + (define elems (simplify-dots (extract-separate-parts bstr 2) #:drop-leading? #f)) + (let loop ([dots null] [elems elems]) + (cond + [(or (null? elems) + (not (equal? (car elems) 'up))) + (append (reverse elems) + (let* ([rel-bstr (apply bytes-append #"\\\\?\\REL" dots)] + [rel-len (bytes-length rel-bstr)]) + (make-starting-point rel-bstr rel-len #:add-ups? #t #:drive? #f)))] + [else + (loop (cons (car elems) dots) (cdr elems))]))])) + +;; Split on separators, removing trailing whitespace from the last +;; element, and prefix each extracted element with a backslash: +(define (extract-separate-parts bstr pos #:bbq-mode? [bbq-mode? #f]) + (define (is-a-sep? b) + (if bbq-mode? + (eqv? b (char->integer #\\)) + (is-sep? b 'windows))) + (define len (bytes-length bstr)) + (let loop ([pos pos]) + (cond + [(= pos len) null] + [(is-a-sep? (bytes-ref bstr pos)) + (loop (add1 pos))] + [else + (let e-loop ([end-pos (add1 pos)]) + (cond + [(or (= end-pos len) + (is-a-sep? (bytes-ref bstr end-pos))) + (define rest (loop end-pos)) + (define elem-bstr (subbytes bstr pos end-pos)) + (define new-bstr (if (and (null? rest) + (not bbq-mode?)) + (strip-trailing-spaces elem-bstr) + elem-bstr)) + (define new-sub (cond + [(and (not bbq-mode?) + (bytes=? new-bstr #".")) + 'same] + [(and (not bbq-mode?) + (bytes=? new-bstr #"..")) + 'up] + [else + (bytes-append #"\\" new-bstr)])) + (cons new-sub rest)] + [else (e-loop (add1 end-pos))]))]))) + +;; Create a list containing one 'up for each ".." in the range: +(define (extract-dot-ups bstr start dots-end) + (if (= start dots-end) + '() + (let loop ([i (add1 start)]) + (cond + [(i . >= . dots-end) '()] + [(and (eqv? (bytes-ref bstr i) (char->integer #\.)) + (eqv? (bytes-ref bstr (sub1 i)) (char->integer #\.))) + (cons 'up (loop (add1 i)))] + [else (loop (add1 i))])))) + +;; For \\?\REL paths, add an 'up at the start to the initial path. +;; Otherwise, at a root, just drop an 'up. +(define (starting-point-add-up s) + (cond + [(starting-point-add-ups? s) + (define bstr (bytes-append (subbytes (starting-point-bstr s) + 0 + (starting-point-len s)) + #"\\..")) + (define len (bytes-length bstr)) + (struct-copy starting-point s + [bstr bstr] + [len len] + [orig-len len])] + [else s])) + +(define (simplify-dots bstrs #:drop-leading? [drop-leading? #t]) + (let loop ([bstrs bstrs] [accum null]) + (cond + [(null? bstrs) (reverse accum)] + [(eq? 'up (car bstrs)) (loop (cdr bstrs) accum)] + [(eq? 'same (car bstrs)) (if (null? accum) + (if drop-leading? + (loop (cdr bstrs) accum) + (loop (cdr bstrs) (cons (car bstrs) accum))) + (loop (cdr bstrs) (cdr accum)))] + [else (loop (cdr bstrs) (cons (car bstrs) accum))]))) diff --git a/racket/src/io/path/check-path.rkt b/racket/src/io/path/check-path.rkt new file mode 100644 index 0000000000..db991d9a03 --- /dev/null +++ b/racket/src/io/path/check-path.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(require "check.rkt" + "path.rkt") + +(provide check-path-argument) + +(define (check-path-argument who p) + (check who (lambda (p) (or (path-string? p) (path-for-some-system? p))) + #:contract "(or/c path-string? path-for-some-system?)" + p)) diff --git a/racket/src/io/path/check.rkt b/racket/src/io/path/check.rkt new file mode 100644 index 0000000000..eee1c8b874 --- /dev/null +++ b/racket/src/io/path/check.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require (for-syntax racket/base) + "../common/check.rkt") + +(provide (all-from-out "../common/check.rkt") + check-convention + check-path-string + check-path-bytes) + +(define (check-convention who c) + (check who (lambda (c) (or (eq? c 'windows) (eq? c 'unix))) + #:contract "(or/c 'windows 'unix)" + c)) + +(define (check-path-string who s) + (when (zero? (string-length s)) + (raise-arguments-error who "path string is empty")) + (for ([c (in-string s)]) + (when (char=? c #\nul) + (raise-arguments-error who "path string contains a nul character" + "path string" s)))) + +(define (check-path-bytes who s) + (when (zero? (bytes-length s)) + (raise-arguments-error who "byte string is empty")) + (for ([c (in-bytes s)]) + (when (zero? c) + (raise-arguments-error who "byte string contains a nul character" + "byte string" s)))) diff --git a/racket/src/io/path/cleanse.rkt b/racket/src/io/path/cleanse.rkt new file mode 100644 index 0000000000..e52b427f58 --- /dev/null +++ b/racket/src/io/path/cleanse.rkt @@ -0,0 +1,94 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/internal-error.rkt" + "path.rkt" + "check-path.rkt" + "sep.rkt" + "windows.rkt") + +(provide cleanse-path + clean-double-slashes) + +(define/who (cleanse-path p-in) + (check-path-argument who p-in) + (define p (->path p-in)) + (define convention (path-convention p)) + (define (return bstr) + (if (eq? bstr (path-bytes p)) + p + (path bstr convention))) + (define bstr (path-bytes p)) + (case convention + [(unix) + (return (clean-double-slashes bstr 'unix 0))] + [(windows) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos sep-bstr) + (parse-backslash-backslash-questionmark (path-bytes p))) + (cond + [clean-start-pos + (return (clean-double-slashes bstr 'windows clean-start-pos + #:only-backslash? #t))] + [else + ;; Must be \\?\REL or \\?\RED + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) + (define new-bstr (clean-double-slashes bstr 'windows literal-start + #:only-backslash? #t)) + (define has-extra-backslash? + (and (eqv? (bytes-ref bstr (- literal-start 1)) (char->integer #\\)) + (eqv? (bytes-ref bstr (- literal-start 2)) (char->integer #\\)))) + (cond + [has-extra-backslash? (return new-bstr)] + [else + (return (bytes-append (subbytes new-bstr 0 literal-start) + #"\\" + (subbytes new-bstr literal-start)))])])] + [(parse-unc bstr 0) + => (lambda (drive-len) + (return (clean-double-slashes bstr 'windows drive-len)))] + [(letter-drive-start? bstr (bytes-length bstr)) + (cond + [(and ((bytes-length bstr) . > . 2) + (is-sep? (bytes-ref bstr 2) 'windows)) + (return (clean-double-slashes bstr 'windows 2))] + [else + (return (bytes-append (subbytes bstr 0 2) + #"\\" + (clean-double-slashes (subbytes bstr 2) 'windows 0)))])] + [else + (return (clean-double-slashes bstr 'windows 0))])])) + +;; ---------------------------------------- + +(define (clean-double-slashes bstr convention allow-double-before + #:only-backslash? [only-backslash? #f]) + (define (is-a-sep? b) + (if only-backslash? + (eqv? b (char->integer #\\)) + (is-sep? b convention))) + (define extra-count + (let loop ([i (sub1 (bytes-length bstr))]) + (cond + [(i . <= . allow-double-before) 0] + [(and (is-a-sep? (bytes-ref bstr i)) + (is-a-sep? (bytes-ref bstr (sub1 i)))) + (add1 (loop (sub1 i)))] + [else (loop (sub1 i))]))) + (cond + [(zero? extra-count) + bstr] + [else + (define new-bstr (make-bytes (- (bytes-length bstr) extra-count))) + (let loop ([i (sub1 (bytes-length bstr))] [j (sub1 (bytes-length new-bstr))]) + (unless (i . <= . allow-double-before) + (cond + [(and (is-a-sep? (bytes-ref bstr i)) + (is-a-sep? (bytes-ref bstr (sub1 i)))) + (loop (sub1 i) j)] + [else + (bytes-set! new-bstr j (bytes-ref bstr i)) + (loop (sub1 i) (sub1 j))]))) + (bytes-copy! new-bstr 0 bstr 0 (add1 allow-double-before)) + new-bstr])) diff --git a/racket/src/io/path/complete.rkt b/racket/src/io/path/complete.rkt new file mode 100644 index 0000000000..0d6cd170e2 --- /dev/null +++ b/racket/src/io/path/complete.rkt @@ -0,0 +1,47 @@ +#lang racket/base +(require "../common/internal-error.rkt" + "path.rkt" + "check.rkt" + "check-path.rkt" + "relativity.rkt" + "build.rkt" + "windows.rkt") + +(provide path->complete-path) + +;; If `wrt-given?` is #f, then `wrt` can be a thunk to get a path, +;; so that any security checks associated with the thunk are delayed +(define/who (path->complete-path p-in wrt #:wrt-given? [wrt-given? #t]) + (check-path-argument who p-in) + (when wrt-given? + (check who (lambda (p) (and (or (path-string? p) (path-for-some-system? p)) + (complete-path? p))) + #:contract "(and/c (or/c path-string? path-for-some-system?) complete-path?)" + wrt)) + (unless (eq? (convention-of-path p-in) + (if (procedure? wrt) + (system-path-convention-type) + (convention-of-path wrt))) + (if wrt-given? + (raise-arguments-error who + "convention of first path incompatible with convention of second path" + "first path" p-in + "second path" wrt) + (raise-arguments-error who + "no second path supplied, and given path is not for the current platform" + "given path" p-in))) + (define p (->path p-in)) + (cond + [(complete-path? p) p] + [(relative-path? p) + (build-path (if (procedure? wrt) (wrt) wrt) p)] + [else + ;; non-complete, non-relative path on Windows, so fill in the drive + (define wrt-path (->path (if (procedure? wrt) (wrt) wrt))) + (define drive (split-drive (path-bytes wrt-path))) + (build-path (path drive 'windows) p)])) + +(define (convention-of-path p) + (if (path? p) + (path-convention p) + (system-path-convention-type))) diff --git a/racket/src/io/path/directory-path.rkt b/racket/src/io/path/directory-path.rkt new file mode 100644 index 0000000000..77e4f89c75 --- /dev/null +++ b/racket/src/io/path/directory-path.rkt @@ -0,0 +1,76 @@ +#lang racket/base +(require "../common/check.rkt" + "path.rkt" + "check-path.rkt" + "sep.rkt" + "windows.rkt") + +(provide directory-path? + path->directory-path + path->path-without-trailing-separator) + +(define/who (path->directory-path p-in) + (check-path-argument who p-in) + (define p (->path p-in)) + (cond + [(directory-path? p #:require-sep? #t) p] + [else + (case (path-convention p) + [(unix) + (path (bytes-append (path-bytes p) #"/") 'unix)] + [(windows) + (path (bytes-append (path-bytes p) #"\\") 'windows)])])) + +(define (directory-path? p #:require-sep? [require-sep? #f]) + (define bstr (path-bytes p)) + (define len (bytes-length bstr)) + (define convention (path-convention p)) + (define (unixish-path-directory-path?) + (or (is-sep? (bytes-ref bstr (sub1 len)) convention) + (and (not require-sep?) + (or (and (len . >= . 2) + (eq? (bytes-ref bstr (sub1 len)) (char->integer #\.)) + (eq? (bytes-ref bstr (- len 2)) (char->integer #\.)) + (or (len . = . 2) + (is-sep? (bytes-ref bstr (- len 3)) convention))) + (and (len . >= . 1) + (eq? (bytes-ref bstr (sub1 len)) (char->integer #\.)) + (or (len . = . 1) + (is-sep? (bytes-ref bstr (- len 2)) convention))))))) + + (case convention + [(unix) (unixish-path-directory-path?)] + [(windows) + (cond + [(backslash-backslash-questionmark? bstr) + ;; Dots are literal in a ".." path, except as a sequence at + ;; the start of a \\?\REL\.. path (with a single backslash) + (or (eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\)) + (and (not require-sep?) + (eq? 'rel (backslash-backslash-questionmark-kind bstr)) + (eqv? len (backslash-backslash-questionmark-dot-ups-end bstr len))))] + [else (unixish-path-directory-path?)])])) + +(define (path->path-without-trailing-separator p) + (define bstr (path-bytes p)) + (define orig-len (bytes-length bstr)) + (cond + [(= orig-len 1) p] + [(and (eq? (path-convention p) 'windows) + (backslash-backslash-questionmark? bstr)) + ;; \\?\ is more complicated. Do we need to do anything, + ;; considering that the use for this function is `resolve-path`? + p] + [else + (define len + (let loop ([len orig-len]) + (cond + [(zero? len) 0] + [else + (define c (bytes-ref bstr (sub1 len))) + (if (is-sep? c (path-convention p)) + (loop (sub1 len)) + len)]))) + (cond + [(< len orig-len) (path (subbytes bstr 0 len) (path-convention p))] + [else p])])) diff --git a/racket/src/io/path/ffi.rkt b/racket/src/io/path/ffi.rkt new file mode 100644 index 0000000000..8259d9c2e4 --- /dev/null +++ b/racket/src/io/path/ffi.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require '#%foreign + "../common/check.rkt" + "../file/host.rkt" + "path.rkt") + +(provide _path) + +(define/who _path + (make-ctype _bytes + (lambda (p) + (check who path-string? #:or-false p) + (and p (bytes-append (->host p #f '()) #"\0"))) + (lambda (bstr) (and bstr (path (bytes->immutable-bytes bstr) + (system-path-convention-type)))))) diff --git a/racket/src/io/path/main.rkt b/racket/src/io/path/main.rkt new file mode 100644 index 0000000000..865132b5be --- /dev/null +++ b/racket/src/io/path/main.rkt @@ -0,0 +1,157 @@ +#lang racket/base +(require "../locale/string.rkt" + (rename-in "path.rkt" + [string->path raw:string->path]) + "check.rkt" + "sep.rkt" + "build.rkt" + "string.rkt" + "split.rkt" + "protect.rkt" + "relativity.rkt" + "cleanse.rkt" + "simplify.rkt" + "directory-path.rkt" + "system.rkt" + "api.rkt" + "ffi.rkt") + +(provide (rename-out [is-path? path?]) + path-for-some-system? + + string->path + path->string + bytes->path + path->bytes + + string->path-element + bytes->path-element + path-element->string + path-element->bytes + + pathcomplete-path + path->directory-path + + cleanse-path + simplify-path + + find-system-path + set-exec-file! + set-run-file! + set-collects-dir! + set-config-dir! + + _path) + + +(define/who (bytes->path bstr [convention (system-path-convention-type)]) + (check who bytes? bstr) + (check-convention who convention) + (check-path-bytes who bstr) + (path (bytes->immutable-bytes bstr) convention)) + +(define/who (path->bytes p) + (check who path? #:contract "path-for-some-system?" p) + (bytes-copy (path-bytes p))) + +(define/who (string->path-element s) + (check who string? s) + (check-path-string who s) + (do-bytes->path-element (string->path-bytes s) + (system-path-convention-type) + who + s)) + +(define/who (bytes->path-element bstr [convention (system-path-convention-type)]) + (check who bytes? bstr) + (check-convention who convention) + (check-path-bytes who bstr) + (do-bytes->path-element bstr convention who bstr)) + +(define (path-element? p) + (cond + [(path? p) + (define bstr (path-bytes p)) + (define convention (path-convention p)) + (and + ;; Quick pre-check: any separators? + (or (not (eq? convention 'unix)) + (not (for/or ([c (in-bytes bstr)] + [i (in-naturals)]) + (and (is-sep? c convention) + i)))) + (let-values ([(base name dir?) (split-path p)]) + (and (symbol? base) + (path? name))))] + [else #f])) + +(define (do-bytes->path-element bstr convention who orig-arg) + (define (bad-element) + (raise-arguments-error who + "cannot be converted to a path element" + "path" orig-arg + "explanation" "path can be split, is not relative, or names a special element")) + (when (eq? 'windows convention) + ;; Make sure we don't call `protect-path-element` on a + ;; byte string that contains a "\": + (when (for/or ([b (in-bytes bstr)]) + (eqv? b (char->integer #\\))) + (bad-element))) + (define len (bytes-length bstr)) + (define p (path (protect-path-element (bytes->immutable-bytes bstr) convention) + convention)) + (unless (path-element? p) + (bad-element)) + p) + +(define/who (path-element->string p) + (check who path-element? p) + (bytes->string/locale (path-bytes p) #\?)) + +(define/who (path-element->bytes p) + (check who path-element? p) + (bytes-copy (path-bytes p))) + +(define/who pathcomplete-path v (current-directory)))))) + +(define (check-directory-path who v) + (check who path-string? v) + (path->complete-path v (current-directory))) diff --git a/racket/src/io/path/path.rkt b/racket/src/io/path/path.rkt new file mode 100644 index 0000000000..7398ca70bc --- /dev/null +++ b/racket/src/io/path/path.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require "../print/custom-write.rkt" + "../port/string-output.rkt" + "../locale/string.rkt") + +(provide (struct-out path) + is-path? + path-for-some-system? + path-string? + string-no-nuls? + string->path + string->path-bytes + ->path) + +(struct path (bytes convention) + #:property prop:custom-write + (lambda (p port mode) + (when mode + (write-string "#string/locale (path-bytes p)) port) + (when mode + (write-string ">" port))) + #:property prop:equal+hash + (list + (lambda (p1 p2 eql?) + (eql? (path-bytes p1) (path-bytes p2))) + (lambda (p hc) + (hc (path-bytes p))) + (lambda (p hc) + (hc (path-bytes p))))) + +(define is-path? + (let ([path? (lambda (p) + (and (path? p) + (eq? (path-convention p) + (system-path-convention-type))))]) + path?)) + +(define (path-for-some-system? p) + (path? p)) + +(define (path-string? p) + (or (is-path? p) + (and (string? p) + (positive? (string-length p)) + (string-no-nuls? p)))) + +(define (string-no-nuls? s) + (and (string? s) + (for/and ([c (in-string s)]) + (not (char=? c #\nul))))) + +(define (string->path s) + (path (string->path-bytes s) + (system-path-convention-type))) + +(define (string->path-bytes s) + (string->bytes/locale s (char->integer #\?))) + +(define (->path p) + (if (string? p) + (string->path p) + p)) diff --git a/racket/src/io/path/protect.rkt b/racket/src/io/path/protect.rkt new file mode 100644 index 0000000000..ce25edf5c4 --- /dev/null +++ b/racket/src/io/path/protect.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require "windows.rkt") + +(provide protect-path-element) + +(define (protect-path-element bstr convention) + (cond + [(eq? convention 'windows) + (if (needs-protect? bstr) + (bytes-append #"\\\\?\\REL\\\\" bstr) + bstr)] + [else + bstr])) + +(define (needs-protect? bstr) + (define len (bytes-length bstr)) + (cond + [(and (eqv? len 1) + (eqv? (bytes-ref bstr 0) (char->integer #\.))) + ;; would also be covered by loop below + #t] + [(and (eqv? len 2) + (eqv? (bytes-ref bstr 0) (char->integer #\.)) + (eqv? (bytes-ref bstr 1) (char->integer #\.))) + ;; would also be covered by loop below + #t] + [(special-filename? bstr) + #t] + [else + (let loop ([i+1 len] [at-end? #t]) + (cond + [(zero? i+1) #f] + [else + (define i (sub1 i+1)) + (define b (bytes-ref bstr i)) + (cond + [(and at-end? + (or (eqv? b (char->integer #\.)) + (eqv? b (char->integer #\space)))) + #t] + [(or (eqv? b (char->integer #\/)) + (eqv? b (char->integer #\")) + (eqv? b (char->integer #\|)) + (eqv? b (char->integer #\:)) + (eqv? b (char->integer #\<)) + (eqv? b (char->integer #\>))) + #t] + [else (loop i #f)])]))])) diff --git a/racket/src/io/path/relativity.rkt b/racket/src/io/path/relativity.rkt new file mode 100644 index 0000000000..b574904351 --- /dev/null +++ b/racket/src/io/path/relativity.rkt @@ -0,0 +1,76 @@ +#lang racket/base +(require "../common/check.rkt" + "path.rkt" + "sep.rkt" + "windows.rkt") + +(provide relative-path? + absolute-path? + complete-path?) + +(define-syntax-rule (define-...-path? id + unix-bstr-check unix-str-check + windows-bstr-check) + (define (id p) + (check-path-test-argument 'id p) + (cond + [(path? p) + (case (path-convention p) + [(unix) + (define bstr (path-bytes p)) + (unix-bstr-check bstr)] + [(windows) + (windows-bstr-check (path-bytes p))])] + [(string? p) + (and (string-no-nuls? p) + (positive? (string-length p)) + (case (system-path-convention-type) + [(unix) + (unix-str-check p)] + [(windows) + (windows-bstr-check (string->path-bytes p))]))]))) + +(define (check-path-test-argument who p) + (check who (lambda (p) (or (path? p) (string? p) (path-for-some-system? p))) + #:contract "(or/c path? string? path-for-some-system?)" + p)) + +(define-...-path? relative-path? + (lambda (p) + (not (is-sep? (bytes-ref p 0) 'unix))) + (lambda (p) + (not (is-sep? (char->integer (string-ref p 0)) 'unix))) + (lambda (p) + (windows-relative-path-bytes? p))) + +(define (windows-relative-path-bytes? p) + (let ([bbq (backslash-backslash-questionmark-kind p)]) + (cond + [(eq? bbq 'rel) #t] + [bbq #f] + [(is-sep? (bytes-ref p 0) 'windows) #f] + [(letter-drive-start? p (bytes-length p)) #f] + [else #t]))) + +(define-...-path? absolute-path? + (lambda (p) + (is-sep? (bytes-ref p 0) 'unix)) + (lambda (p) + (is-sep? (char->integer (string-ref p 0)) 'unix)) + (lambda (p) + (not (windows-relative-path-bytes? p)))) + +(define-...-path? complete-path? + (lambda (p) + (is-sep? (bytes-ref p 0) 'unix)) + (lambda (p) + (is-sep? (char->integer (string-ref p 0)) 'unix)) + (lambda (p) + (let ([bbq (backslash-backslash-questionmark-kind p)]) + (cond + [bbq + (and (not (eq? bbq 'red)) + (not (eq? bbq 'rel)))] + [else + (or (letter-drive-start? p (bytes-length p)) + (and (parse-unc p 0) #t))])))) diff --git a/racket/src/io/path/sep.rkt b/racket/src/io/path/sep.rkt new file mode 100644 index 0000000000..579a8efa13 --- /dev/null +++ b/racket/src/io/path/sep.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(provide is-sep?) + +(define (is-sep? c convention) + (or (eq? c (char->integer #\/)) + (and (eq? convention 'windows) + (eq? c (char->integer #\\))))) diff --git a/racket/src/io/path/simplify.rkt b/racket/src/io/path/simplify.rkt new file mode 100644 index 0000000000..503ab3af02 --- /dev/null +++ b/racket/src/io/path/simplify.rkt @@ -0,0 +1,124 @@ +#lang racket/base +(require "../file/main.rkt" + "path.rkt" + "check.rkt" + "check-path.rkt" + "sep.rkt" + "relativity.rkt" + "split.rkt" + "build.rkt" + "cleanse.rkt" + "directory-path.rkt" + "complete.rkt" + "parameter.rkt") + +(provide simplify-path) + +(define/who (simplify-path p-in [use-filesystem? #t]) + (check-path-argument who p-in) + (define p (->path p-in)) + (define convention (path-convention p)) + (cond + [(simple? p convention) p] + [else + (define clean-p (cleanse-path p)) + (cond + [(simple? clean-p convention) clean-p] + [else + (define l (explode-path clean-p)) + (define simple-p + (cond + [use-filesystem? + ;; Use the filesystem, which requires building + ;; a full path + (define (combine base accum) + (if (null? accum) + base + (apply build-path base (reverse accum)))) + (let loop ([l (if (path? (car l)) (cdr l) l)] + [base (if (path? (car l)) + ;; convert starting point absolute as needed + (path->complete-path (car l) (current-directory)) + ;; original must be relative + (current-directory))] + [accum '()] + [seen #hash()]) + (cond + [(null? l) (combine base accum)] + [(eq? 'same (car l)) + (loop (cdr l) base accum seen)] + [(eq? 'up (car l)) + (define new-base (combine base accum)) + (define target (resolve-path new-base)) + (define-values (from-base new-seen) + (cond + [(eq? target new-base) (values new-base seen)] + [else + (define from-base + (cond + [(complete-path? target) target] + [else + (define-values (base-dir name dir?) (split-path new-base)) + (path->complete-path target base-dir)])) + (when (hash-ref seen from-base #f) + (raise + (exn:fail:filesystem + (string-append (symbol->string who) ": cycle detected at link" + "\n link path: " (path->string new-base)) + (current-continuation-marks)))) + (values from-base (hash-set seen from-base #t))])) + (define-values (next-base name dir?) (split-path from-base)) + (cond + [(not next-base) + ;; discard ".." after a root + (loop (cdr l) from-base '() new-seen)] + [else + (loop (cdr l) next-base '() new-seen)])] + [else (loop (cdr l) base (cons (car l) accum) seen)]))] + [else + ;; Don't use the filesystem, so just remove + ;; "." and ".." syntactically + (define simpler-l + (let loop ([l l] [accum null]) + (cond + [(null? l) (reverse accum)] + [(eq? 'same (car l)) (loop (cdr l) accum)] + [(and (eq? 'up (car l)) (pair? accum)) + (loop (cdr l) (cdr accum))] + [else (loop (cdr l) (cons (car l) accum))]))) + (apply build-path simpler-l)])) + (if (directory-path? p) + (path->directory-path simple-p) + simple-p)])])) + +;; ---------------------------------------- + +;; Quick check for whether the path is already simple: +(define (simple? p convention) + (define bstr (path-bytes p)) + (define len (bytes-length bstr)) + (let loop ([i 0]) + (cond + [(= i len) #t] + [(is-sep? (bytes-ref bstr i) convention) + (cond + [(= (add1 i) len) #t] + [(is-sep? (bytes-ref bstr (add1 i)) convention) + #f] + [(and (eq? (bytes-ref bstr (add1 i)) (char->integer #\.)) + (or (= (+ i 2) len) + (is-sep? (bytes-ref bstr (+ i 2)) convention) + (and (eq? (bytes-ref bstr (+ i 2)) (char->integer #\.)) + (or (= (+ i 3) len) + (is-sep? (bytes-ref bstr (+ i 3)) convention))))) + #f] + [else (loop (add1 i))])] + [(and (zero? i) + (eq? (bytes-ref bstr 0) (char->integer #\.)) + (or (= 1 len) + (is-sep? (bytes-ref bstr 1) convention) + (and (eq? (bytes-ref bstr 1) (char->integer #\.)) + (or (= 2 len) + (is-sep? (bytes-ref bstr 2) convention))))) + #f] + [else (loop (add1 i))]))) diff --git a/racket/src/io/path/split.rkt b/racket/src/io/path/split.rkt new file mode 100644 index 0000000000..b98a78c1e6 --- /dev/null +++ b/racket/src/io/path/split.rkt @@ -0,0 +1,290 @@ +#lang racket/base +(require "../common/check.rkt" + "path.rkt" + "check-path.rkt" + "sep.rkt" + "cleanse.rkt" + "windows.rkt" + "protect.rkt") + +(provide split-path + explode-path) + +(define/who (split-path p) + (check-path-argument who p) + (split (->path p))) + +(define/who (explode-path p) + (check-path-argument who p) + (reverse (split (->path p) #:explode? #t))) + +;; ---------------------------------------- + +(define (split p #:explode? [explode? #f]) + (cond + [(not (eq? (path-convention p) 'windows)) + (split-after-drive p #:explode? explode?)] + [else + ;; Look for a Windows drive spec, then (usually) continue + ;; to `split-after-drive`: + (define bstr (path-bytes p)) + (cond + [(and ((bytes-length bstr) . > . 2) + (is-sep? (bytes-ref bstr 0) 'windows) + (is-sep? (bytes-ref bstr 1) 'windows)) + (define-values (//?-kind //?-drive-end) (parse-//?-drive bstr)) + (cond + [//?-kind + (define allow-double-before //?-drive-end) + (cond + [(or (eq? //?-kind 'rel) + (eq? //?-kind 'red)) + ;; `\\?\REL\` or `\\?\RED\` path. Handle it directly as a special case + (split-reld bstr)] + [else + (split-after-drive p + #:drive-end (cond + [(and (//?-drive-end . < . (bytes-length bstr)) + (eq? (bytes-ref bstr //?-drive-end) (char->integer #\\))) + ;; Happens with \\?\c:\\, for example + (add1 //?-drive-end)] + [else //?-drive-end]) + #:no-slash-sep? #t + #:no-up? #t + #:explode? explode?)])] + [else + (define //-drive-end (parse-//-drive bstr)) + (cond + [//-drive-end + (split-after-drive p + #:drive-end (cond + [(and (//-drive-end . < . (bytes-length bstr)) + (is-sep? (bytes-ref bstr //?-drive-end) 'windows)) + (add1 //-drive-end)] + [else //-drive-end]) + #:allow-double-before 1 + #:explode? explode?)] + [else + (split-after-drive p #:explode? explode?)])])] + [(and ((bytes-length bstr) . > . 2) + (drive-letter? (bytes-ref bstr 0)) + (eq? (bytes-ref bstr 1) (char->integer #\:))) + (split-after-drive p + #:drive-end (cond + [(and (2 . < . (bytes-length bstr)) + (is-sep? (bytes-ref bstr 2) 'windows)) + 3] + [else 2]) + #:explode? explode?)] + [else (split-after-drive p #:explode? explode?)])])) + +;; ---------------------------------------- + +;; Find a separator to split on, avoiding the Windows drive portion of +;; a path +(define (split-after-drive p + #:len [in-len #f] + #:drive-end [drive-end 0] + #:no-slash-sep? [no-slash-sep? #f] + #:no-up? [no-up? #f] + #:allow-double-before [allow-double-before 0] + #:explode? explode?) + (define convention (path-convention p)) + ;; Consecutive slashes can cause all sorts of mischief, both for + ;; finding a separtor and making an unintended result after splitting, + ;; so clean them up as a first step + (define bstr (if in-len + (path-bytes p) + (clean-double-slashes (path-bytes p) convention allow-double-before))) + (define len (or in-len (bytes-length bstr))) + + (define-values (split-pos ends-sep?) + (let loop ([i (sub1 len)] [ends-sep? #f]) + (cond + [(i . < . drive-end) (values #f ends-sep?)] + [else + (define sep? + (cond + [no-slash-sep? (eq? (bytes-ref bstr i) #\\)] + [else (is-sep? (bytes-ref bstr i) convention)])) + (cond + [sep? + (if (i . < . (sub1 len)) + (values i ends-sep?) + (loop (sub1 i) #t))] + [else + (loop (sub1 i) ends-sep?)])]))) + ;; The `split-pos` argument is #f or less than `(sub1 len)` + + (cond + [(not split-pos) + ;; No splitting available: relative or exactly a root + (cond + [(or (is-sep? (bytes-ref bstr 0) convention) + (positive? drive-end)) + ;; root + (define new-p (path (subbytes bstr 0 len) convention)) + (if explode? + (list new-p) + (values #f new-p #t))] + [else + ;; relative + (define-values (name is-dir?) (split-tail bstr len 0 + convention + #:ends-sep? ends-sep? + #:no-up? no-up?)) + (if explode? + (list name) + (values 'relative name is-dir?))])] + [else + ;; Split at the discovered separator + (define-values (name is-dir?) (split-tail bstr len (add1 split-pos) + convention + #:ends-sep? ends-sep? + #:no-up? no-up?)) + (cond + [(zero? split-pos) + (define base (if (eq? (bytes-ref bstr 0) #\/) + (path #"/" convention) + (path (subbytes bstr 0 1) convention))) + (cond + [explode? + (list name base)] + [else + (values base name is-dir?)])] + [else + ;; Is it possible that by removing the last path element, we'll leave + ;; a directory path that needs conversion to \\?\ on Windows? I think + ;; not, because even if the remaining path ends in spaces and "."s, the + ;; path separator will stay in place to make the trailing spaces and + ;; "."s significant. + (define-values (exposed-bstr exposed-len) (values bstr (add1 split-pos))) + (cond + [explode? + (cons name + (split-after-drive (path exposed-bstr convention) + #:explode? #t + #:len exposed-len + #:drive-end drive-end + #:no-slash-sep? no-slash-sep? + #:no-up? no-up? + #:allow-double-before allow-double-before))] + [else + (define base (path (subbytes exposed-bstr 0 exposed-len) convention)) + (values base name is-dir?)])])])) + +;; ---------------------------------------- + +;; Extract a name and `is-dir?` result from the end of a path: +(define (split-tail bstr len start-pos + convention + #:ends-sep? ends-sep? + #:no-up? no-up?) + (cond + ;; check for 'up + [(and (not no-up?) + ((+ start-pos 2) . <= . len) + (eq? (bytes-ref bstr start-pos) (char->integer #\.)) + (eq? (bytes-ref bstr (+ start-pos 1)) (char->integer #\.)) + (or ((+ start-pos 2) . = . len) + (and ((+ start-pos 3) . = . len) + ends-sep?))) + (values 'up #t)] + ;; check for 'same + [(and (not no-up?) + ((+ start-pos 1) . <= . len) + (eq? (bytes-ref bstr start-pos) (char->integer #\.)) + (or ((+ start-pos 1) . = . len) + (and ((+ start-pos 2) . = . len) + ends-sep?))) + (values 'same #t)] + ;; other relative + [else + (define new-bstr (cond + [ends-sep? + (subbytes bstr start-pos (sub1 len))] + [(zero? start-pos) + (bytes->immutable-bytes bstr)] + [else + (subbytes bstr start-pos)])) + (define prot-bstr (if (or no-up? ends-sep?) + (protect-path-element new-bstr convention) + new-bstr)) + (values (path prot-bstr convention) + ends-sep?)])) + +;; ---------------------------------------- + +(define (parse-//?-drive bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + (values kind drive-len)) + +(define (parse-//-drive bstr) + (parse-unc bstr 0)) + +;; Splits a \\?\REL or \\?\RED path +(define (split-reld bstr) + (define-values (len is-dir?) + (let ([len (bytes-length bstr)]) + (cond + [(eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\)) + (values (sub1 len) #t)] + [else + (values len #f)]))) + (define-values (dots-end literal-start) + (backslash-backslash-questionmark-dot-ups-end bstr len)) + (cond + [(literal-start . < . len) + ;; There's at least one literal path + (let loop ([p (sub1 len)]) + (cond + [(p . <= . (if dots-end (sub1 literal-start) literal-start)) + ;; One one element and no dots + (cond + [(eqv? (bytes-ref bstr 6) (char->integer #\L)) + ;; keep \\?\REL\ on path, and report 'relative as base */ + (values 'relative + (path (if is-dir? (subbytes bstr 0 len) bstr) 'windows) + is-dir?)] + [else + ;; Switch "D" to "L", and simplify base to just "\\" + (values (path #"\\" 'windows) + (path + (bytes-append #"\\\\?\\REL\\" + (if (eqv? (bytes-ref bstr 8) (char->integer #\\)) + #"" + #"\\") + (subbytes bstr 8)) + 'windows) + is-dir?)])] + [(eqv? (bytes-ref bstr p) (char->integer #\\)) + ;; Prefix path element with \\?\REL\\ + (define elem-bstr + (bytes-append #"\\\\?\\REL\\\\" + (subbytes bstr (add1 p) len))) + (define nsep + (cond + [(or (eqv? dots-end p) (eqv? dots-end (sub1 p))) + ;; stripping the only element: drop reundant separator(s) after .. + (if (eqv? dots-end p) 0 -1)] + [(eqv? (bytes-ref bstr 6) (char->integer #\L)) + ;; preserve separator + 1] + ;; preserve one separator, but not two + [(eqv? (bytes-ref bstr (sub1 p)) (char->integer #\\)) + 0] + [else 1])) + (values (path (subbytes bstr 0 (+ p nsep)) 'windows) + (path elem-bstr 'windows) + is-dir?)] + [else (loop (sub1 p))]))] + [else + ;; There are no literals --- just dots + (cond + [((- dots-end 3) . > . 8) + (values (path (subbytes bstr 0 (- dots-end 3)) 'windows) + 'up + #t)] + [else + (values 'relative 'up #t)])])) diff --git a/racket/src/io/path/string.rkt b/racket/src/io/path/string.rkt new file mode 100644 index 0000000000..e6e41f5514 --- /dev/null +++ b/racket/src/io/path/string.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require "../locale/string.rkt" + (rename-in "path.rkt" + [string->path raw:string->path]) + "check.rkt") + +(provide string->path + path->string) + +(define/who (string->path s) + (check who string? s) + (check-path-string who s) + (raw:string->path s)) + +(define/who (path->string p) + (check who is-path? #:contract "path?" p) + (bytes->string/locale (path-bytes p) #\?)) diff --git a/racket/src/io/path/system.rkt b/racket/src/io/path/system.rkt new file mode 100644 index 0000000000..cb619bd452 --- /dev/null +++ b/racket/src/io/path/system.rkt @@ -0,0 +1,70 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../security/main.rkt" + "path.rkt") + +(provide find-system-path + set-exec-file! + set-run-file! + set-collects-dir! + set-config-dir!) + +(define/who (find-system-path key) + (begin0 + (case key + [(exec-file) (or exec-file + (string->path "/usr/local/bin/racket"))] + [(run-file) (or run-file + (find-system-path 'exec-file))] + [(config-dir host-config-dir) (or config-dir + (string->path "../etc"))] + [(collects-dir host-collects-dir) (or collects-dir + (string->path "../collects"))] + [(orig-dir) (string->path (|#%app| current-directory))] + [(temp-dir) (rktio-system-path who RKTIO_PATH_TEMP_DIR)] + [(sys-dir) (rktio-system-path who RKTIO_PATH_SYS_DIR)] + [(pref-dir) (rktio-system-path who RKTIO_PATH_PREF_DIR)] + [(pref-file) (rktio-system-path who RKTIO_PATH_PREF_FILE)] + [(addon-dir) (rktio-system-path who RKTIO_PATH_ADDON_DIR)] + [(home-dir) (rktio-system-path who RKTIO_PATH_HOME_DIR)] + [(desk-dir) (rktio-system-path who RKTIO_PATH_DESK_DIR)] + [(doc-dir) (rktio-system-path who RKTIO_PATH_DOC_DIR)] + [(init-dir) (rktio-system-path who RKTIO_PATH_INIT_DIR)] + [(init-file) (rktio-system-path who RKTIO_PATH_INIT_FILE)] + [else (raise-argument-error who + (string-append + "(or/c 'home-dir 'pref-dir 'pref-file 'temp-dir\n" + " 'init-dir 'init-file 'addon-dir\n" + " 'doc-dir 'desk-dir 'sys-dir 'exec-file 'run-file\n" + " 'collects-dir 'config-dir 'orig-dir\n" + " 'host-collects-dir 'host-config-dir)") + key)]) + (security-guard-check-file who #f '(exists)))) + +(define exec-file #f) +(define (set-exec-file! p) (set! exec-file p)) + +(define run-file #f) +(define (set-run-file! p) (set! run-file p)) + +(define collects-dir #f) +(define (set-collects-dir! p) (set! collects-dir p)) + +(define config-dir #f) +(define (set-config-dir! p) (set! config-dir p)) + +(define (rktio-system-path who key) + (start-atomic) + (define s (rktio_system_path rktio key)) + (cond + [(rktio-error? s) + (end-atomic) + (raise-rktio-error who s "path lookup failed")] + [else + (define bstr (rktio_to_bytes s)) + (rktio_free s) + (end-atomic) + (path bstr (system-path-convention-type))])) diff --git a/racket/src/io/path/windows.rkt b/racket/src/io/path/windows.rkt new file mode 100644 index 0000000000..bbead6395a --- /dev/null +++ b/racket/src/io/path/windows.rkt @@ -0,0 +1,408 @@ +#lang racket/base +(require "sep.rkt") + +(provide special-filename? + drive-letter? + letter-drive-start? + backslash-backslash-questionmark? + backslash-backslash-questionmark-kind + parse-backslash-backslash-questionmark + parse-unc + backslash-backslash-questionmark-dot-ups-end + split-drive + strip-trailing-spaces) + +(define special-filenames + ;; and "CLOCK$" on NT --- but not traditionally detected by Racket + '("NUL" "CON" "PRN" "AUX" + "COM1" "COM2" "COM3" "COM4" "COM5" + "COM6" "COM7" "COM8" "COM9" + "LPT1" "LPT2" "LPT3" "LPT4" "LPT5" + "LPT6" "LPT7" "LPT8" "LPT9")) + +(define (special-filename? in-bstr #:immediate? [immediate? #t]) + (define bstr (cond + [immediate? in-bstr] + [(backslash-backslash-questionmark? in-bstr) #""] + [else + ;; Extract bytes after last sep or after drive letter: + (define len (bytes-length in-bstr)) + (let loop ([i+1 len]) + (cond + [(zero? i+1) + (if (letter-drive-start? bstr len) + (subbytes in-bstr 2) + in-bstr)] + [else + (define i (sub1 i+1)) + (if (is-sep? (bytes-ref in-bstr i) 'windows) + (subbytes in-bstr i+1) + (loop i))]))])) + (define len (bytes-length bstr)) + (cond + [(zero? len) #f] + [(backslash-backslash-questionmark? bstr) #f] + [else + (for/or ([fn (in-list special-filenames)]) + ;; check for case-insensitive `fn` match followed by + ;; '.' or ':' or (whitespace|'.')* + (define fn-len (string-length fn)) + (and (len . >= . fn-len) + (for/and ([c (in-string fn)] + [b (in-bytes bstr)]) + (or (eqv? (char->integer c) b) + (eqv? (char->integer (char-downcase c)) b))) + (or (= len fn-len) + (eqv? (bytes-ref bstr fn-len) (char->integer #\.)) + (eqv? (bytes-ref bstr fn-len) (char->integer #\:)) + (for/and ([b (in-bytes bstr len)]) + (or (eqv? b (char->integer #\space)) + (eqv? b (char->integer #\.)))))))])) + +(define (drive-letter? c) + (or (<= (char->integer #\a) c (char->integer #\z)) + (<= (char->integer #\A) c (char->integer #\Z)))) + +(define (letter-drive-start? bstr len) + (and (len . >= . 2) + (drive-letter? (bytes-ref bstr 0)) + (eqv? (bytes-ref bstr 1) (char->integer #\:)))) + +(define (backslash-backslash-questionmark? bstr) + (define len (bytes-length bstr)) + (and (len . >= . 4) + (eqv? (bytes-ref bstr 0) (char->integer #\\)) + (eqv? (bytes-ref bstr 1) (char->integer #\\)) + (eqv? (bytes-ref bstr 2) (char->integer #\?)) + (eqv? (bytes-ref bstr 3) (char->integer #\\)))) + +;; Returns #f, 'rel, 'red, or 'abs +(define (backslash-backslash-questionmark-kind bstr) + (define-values (kind drive-end-pos orig-drive-end-pos clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + kind) + +;; Returns (values kind drive-len orig-drive-len clean-start-pos sep-bstr) +;; where `kind` is #f, 'rel, 'red, or 'abs +;; +;; For 'abs, then `drive-len` is set to the length of the root +;; specification. For example, if the drive is terminated by \\\ (a +;; weird "root"), then `drive-len` is after the third \. If the drive +;; is \\?\C:\, then `drive-len` is after the last slash. In the case +;; of \\?\UNC\..., `drive-len` is after the UNC part as in +;; `parse-unc` (so it doesn't include a slash after the volume name). +;; +;; The `orig-drive-len` result is almost the same as `drive-len`, +;; but maybe longer. It preserves an artifact of the given specification: +;; a backslash after a \\?\UNC\\ drive. +;; +;; For 'abs, `clean-start-pos` is the position where it's ok to start +;; removing extra slashes. It's usually the same as `drive-len`. In +;; the case of a \\?\UNC\ path, `clean-start` is 7 (i.e., just after +;; that prefix). In the case of a \\?\REL\ or \\?\RED\ path, +;; `clean-start-pos` is the end of the string. +;; +;; For 'abs, the sep-bstr result is a byte string to insert after +;; the root to add further elements. +(define (parse-backslash-backslash-questionmark bstr) + (cond + [(not (backslash-backslash-questionmark? bstr)) + (values #f #f #f #f #f)] + [else + (define len (bytes-length bstr)) + ;; Allow one extra "\": + (define base + (if (and (len . >= . 5) + (eqv? (bytes-ref bstr 4) (char->integer #\\))) + 5 + 4)) + ;; If there are two backslashes in a row at the end, count everything + ;; as the drive; there are two exceptions: two backslashes are ok + ;; at the end in the form \\?\C:\\, and \\?\\\ is \\?\ + (define two-backslashes? + (and (len . > . 5) + (eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\)) + (eqv? (bytes-ref bstr (- len 2)) (char->integer #\\)))) + (cond + [(and two-backslashes? + (= len 6)) + ;; \\?\ is the root + (values 'abs 4 4 3 #"\\\\")] + [(and two-backslashes? + (or (not (= len (+ base 4))) + (not (and (len . > . base) + (drive-letter? (bytes-ref bstr base)))) + (not (and (len . > . (add1 base)) + (eqv? (bytes-ref bstr (add1 base)) (char->integer #\:)))))) + ;; Not the special case \\?\C:\\ + (values 'abs len len len + ;; If not already three \s, preserve this root when + ;; adding more: + (if (not (eqv? (bytes-ref bstr (- len 3)) (char->integer #\\))) + #"\\" + #""))] + ;; If there are three backslashes in a row, count everything + ;; up to the slashes as the drive + [(and (len . > . 6) + (let loop ([i+1 len]) + (cond + [(= i+1 6) #f] + [else + (define i (sub1 i+1)) + (if (and (eqv? (bytes-ref bstr i) (char->integer #\\)) + (eqv? (bytes-ref bstr (- i 1)) (char->integer #\\)) + (eqv? (bytes-ref bstr (- i 2)) (char->integer #\\))) + i + (loop i))]))) + => (lambda (i) + (define i+1 (add1 i)) + (values 'abs i+1 i+1 i+1 #""))] + ;; Check for drive-letter case + [(and (len . > . 6) + (drive-letter? (bytes-ref bstr base)) + (eqv? (bytes-ref bstr (add1 base)) (char->integer #\:)) + (len . > . (+ 2 base)) + (eqv? (bytes-ref bstr (+ 2 base)) (char->integer #\\))) + (define drive-len (if (and (len . > . (+ 3 base)) + (eqv? (bytes-ref bstr (+ 3 base)) (char->integer #\\))) + (+ base 4) + (+ base 3))) + (values 'abs drive-len drive-len (+ base 2) #"")] + ;; Check for UNC + [(and (len . > . (+ base 3)) + (let ([b (bytes-ref bstr base)]) + (or (eqv? b (char->integer #\U)) (eqv? b (char->integer #\u)))) + (let ([b (bytes-ref bstr (add1 base))]) + (or (eqv? b (char->integer #\N)) (eqv? b (char->integer #\n)))) + (let ([b (bytes-ref bstr (+ base 2))]) + (or (eqv? b (char->integer #\C)) (eqv? b (char->integer #\c)))) + (eqv? (bytes-ref bstr (+ 3 base)) (char->integer #\\)) + (parse-unc bstr #:no-forward-slash? #t + (if (and (len . > . (+ base 4)) + (eqv? (bytes-ref bstr (+ 4 base)) (char->integer #\\))) + (+ base 5) + (+ base 4)))) + => (lambda (drive-len) + (define orig-drive-len + (if (and (len . > . drive-len) + (eqv? (bytes-ref bstr drive-len) (char->integer #\\))) + (add1 drive-len) + drive-len)) + (values 'abs drive-len orig-drive-len (+ base 3) #"\\"))] + ;; Check for REL and RED + [(and (= base 4) + (len . > . 8) + (eqv? (bytes-ref bstr 4) (char->integer #\R)) + (eqv? (bytes-ref bstr 5) (char->integer #\E)) + (let ([b (bytes-ref bstr 6)]) + (or (eqv? b (char->integer #\L)) + (eqv? b (char->integer #\D)))) + (eqv? (bytes-ref bstr 7) (char->integer #\\)) + (or (not (eqv? (bytes-ref bstr 8) (char->integer #\\))) + (len . > . 9))) + (values (if (eqv? (bytes-ref bstr 6) (char->integer #\L)) + 'rel + 'red) + #f + #f + #f + #f)] + ;; Otherwise, \\?\ is the (non-existent) drive + [else + (define clean-start-pos + (if (or (and (= len 5) + (eqv? (bytes-ref bstr 4) (char->integer #\\))) + (and (= len 6) + (eqv? (bytes-ref bstr 4) (char->integer #\\)) + (eqv? (bytes-ref bstr 5) (char->integer #\\)))) + 3 + 4)) + (values 'abs 4 4 clean-start-pos #"\\\\")])])) + +;; Returns an integer if this path is a UNC path, #f otherwise. +;; If `delta` is non-0, then `delta` is after a leading \\. +;; (It starts by checking for \\?\ paths, so they won't be +;; treated as UNC. Unless delta is non-0, in which case the +;; check isn't necessary, presumably because the original +;; `next' already started with \\?\UNC\.) +;; An integer result is set to the length (including offset) of +;; the \\server\vol part; which means that it's either the length of +;; the given byte string or a position that has a separator. +;; If `exact?`, then an integer is returned only if `bstr' is just the +;; drive; that is, only if only slashes are +;; in `bstr' starting with the result integer. +;; If `no-forward-slash?', then only backslashes are recognized. +(define (parse-unc bstr delta + #:exact? [exact? #f] + #:no-forward-slash? [no-forward-slash? #f]) + (cond + [(and (zero? delta) + (backslash-backslash-questionmark? bstr)) + #f] + ;; Bail out fast on an easy non-match: + [(and (zero? delta) + (not + (and ((bytes-length bstr) . > . 2) + (is-sep? (bytes-ref bstr 0) 'windows) + (is-sep? (bytes-ref bstr 1) 'windows)))) + #f] + [else + ;; Check for a drive form: //x/y + (define (is-a-sep? c) (if no-forward-slash? + (eqv? c (char->integer #\\)) + (is-sep? c 'windows))) + (define len (bytes-length bstr)) + (define j (if (zero? delta) 2 delta)) + (and + (not (and (len . > . j) + (is-a-sep? (bytes-ref bstr j)))) + ;; Found non-sep; skip over more + (let loop ([j j]) + (cond + [(= j len) + ;; Didn't find a sep, so not //x/ + #f] + [(not (is-a-sep? (bytes-ref bstr j))) + (cond + [(and no-forward-slash? + (eqv? (bytes-ref bstr j) (char->integer #\/))) + ;; Found / when only \ is allowed as separator + #f] + [else + ;; Keep looking + (loop (add1 j))])] + [else + ;; Found sep again, so we have //x/: + (let* ([j (add1 j)] + [j (if (and no-forward-slash? + (j . < . len) + (is-a-sep? (bytes-ref bstr j))) + ;; two backslashes ok in \\?\UNC mode + (add1 j) + j)]) + (cond + [(and (= j (if (zero? delta) 4 (+ delta 2))) + (eqv? (bytes-ref bstr (- j 2)) (char->integer #\?))) + ;; We have //?/, with up to 2 backslashes. + ;; This doesn't count as UNC, to avoid confusion with \\?\. + #f] + [else + (let loop ([j j]) + (cond + [(= j len) + ;; Didn't find a non-sep, so not UNC + #f] + [(is-a-sep? (bytes-ref bstr j)) + ;; Keep looking for non-sep + (loop (add1 j))] + [else + ;; Found non-sep again; this is UNC + (let loop ([j j]) + (cond + [(= j len) + ;; Whole string is drive + len] + [(is-a-sep? (bytes-ref bstr j)) + ;; Found sep that ends UNC drive + (and (or (not exact?) + ;; Make sure there are no more separators: + (for/and ([b (in-bytes bstr (add1 j))]) + (not (is-a-sep? b)))) + j)] + [else (loop (add1 j))]))]))]))])))])) + +;; Assumes `bstr` is of the form \\?\REL or \\?\RED and returns +;; (values dots-end literal-start) +;; If `bstr` is \\?\REL\..\..\.., the `dots-end` result is the index just +;; past the last "\..". This might be the first "\" of a "\\" +;; separator, the "\" before a non-".." element, or the end of the +;; string. For a \\?\RED\ path, it's as if there are no ".."s +;; (because ".." is not special in "RED" paths). Otherwise, `dots-end` +;; is #f. +;; The `literal-start` result is the starting index of the literal part of +;; the path (i.e., after one or two slashes, possibly after dots). +(define (backslash-backslash-questionmark-dot-ups-end bstr len) + (define pos + (and (eqv? (bytes-ref bstr 6) (char->integer #\L)) + (let loop ([pos #f] + [j 7]) ;; \\?\REL\ + (cond + [((+ j 3) . > . len) + pos] + [(and (eqv? (bytes-ref bstr j) (char->integer #\\)) + (eqv? (bytes-ref bstr (+ j 1)) (char->integer #\.)) + (eqv? (bytes-ref bstr (+ j 2)) (char->integer #\.)) + (or (= len (+ j 3)) + (eqv? (bytes-ref bstr (+ j 3)) (char->integer #\\)))) + (define j+3 (+ j 3)) + (loop j+3 j+3)] + [else pos])))) + (cond + [pos + (cond + [(= pos len) + (values pos len)] + [(and ((+ pos 2) . < . len) + (eqv? (bytes-ref bstr (add1 pos)) (char->integer #\\))) + (values pos (+ pos 2))] + [else + (values pos (+ pos 1))])] + [(len . > . 8) + (cond + [(eqv? (bytes-ref bstr 8) (char->integer #\\)) + (values #f 9)] + [else + (values #f 8)])] + [else + (values #f 8)])) + + +(define (split-drive bstr) + (cond + [(backslash-backslash-questionmark? bstr) + (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) + (parse-backslash-backslash-questionmark bstr)) + (subbytes bstr 0 drive-len)] + [(parse-unc bstr 0) + => (lambda (pos) (subbytes bstr 0 pos))] + [else + (subbytes bstr 0 (min 3 (bytes-length bstr)))])) + + +(define (strip-trailing-spaces bstr) + (cond + [(backslash-backslash-questionmark? bstr) + ;; all spaces are significant, so don't strip them + bstr] + [else + (define len (bytes-length bstr)) + ;; ignore/keep trailing separators + (define len-before-seps + (let loop ([i+1 len]) + (define i (sub1 i+1)) + (cond + [(is-sep? (bytes-ref bstr i) 'windows) + (loop i)] + [else i+1]))) + (let loop ([i+1 len-before-seps]) + (cond + [(zero? i+1) + ;; A path element that's all spaces; don't trim + bstr] + [else + (define i (sub1 i+1)) + (define b (bytes-ref bstr i)) + (cond + [(is-sep? b 'windows) + ;; A path element that's all spaces; don't trim + bstr] + [(or (eqv? b (char->integer #\.)) + (eqv? b (char->integer #\space))) + (loop i)] + [(= i+1 len-before-seps) + ;; Nothing to trim + bstr] + [else + ;; Trim + (bytes-append (subbytes bstr 0 i+1) + (subbytes bstr len-before-seps len))])]))])) diff --git a/racket/src/io/port/buffer-mode.rkt b/racket/src/io/port/buffer-mode.rkt new file mode 100644 index 0000000000..cf5dc932e2 --- /dev/null +++ b/racket/src/io/port/buffer-mode.rkt @@ -0,0 +1,55 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "check.rkt") + +(provide file-stream-buffer-mode) + +(define/who file-stream-buffer-mode + (case-lambda + [(p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'file-stream-buffer-mode "port?" p)])]) + (define buffer-mode (core-port-buffer-mode p)) + (atomically + (check-not-closed who p) + (and buffer-mode + (buffer-mode))))] + [(p mode) + (unless (or (input-port? p) (output-port? p)) + (raise-argument-error who "port?" p)) + (unless (or (eq? mode 'none) (eq? mode 'line) (eq? mode 'block)) + (raise-argument-error who "(or/c 'none 'line 'block)" mode)) + (when (and (eq? mode 'line) (not (output-port? p))) + (raise-arguments-error who + "'line buffering not supported for an input port" + "port" p)) + (define (set-buffer-mode p) + (atomically + (check-not-closed who p) + (define buffer-mode (core-port-buffer-mode p)) + (cond + [buffer-mode + (buffer-mode mode) + #t] + [else #f]))) + (cond + [(input-port? p) + (or (set-buffer-mode (->core-input-port p)) + (raise-arguments-error 'file-stream-buffer-mode + "buffering not supported for input port" + "mode" mode + "input port" p))] + [else + (or (set-buffer-mode (->core-output-port p)) + (raise-arguments-error 'file-stream-buffer-mode + "buffering not supported for output port" + "mode" mode + "output port" p))]) + (void)])) diff --git a/racket/src/io/port/bytes-input.rkt b/racket/src/io/port/bytes-input.rkt new file mode 100644 index 0000000000..96bd330370 --- /dev/null +++ b/racket/src/io/port/bytes-input.rkt @@ -0,0 +1,200 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "parameter.rkt" + "read-and-peek.rkt" + "input-port.rkt" + "count.rkt" + "progress-evt.rkt" + "flush-output.rkt") + +(provide read-byte + read-bytes + read-bytes! + read-bytes-avail! + read-bytes-avail!* + read-bytes-avail!/enable-break + + peek-byte + peek-bytes + peek-bytes! + peek-bytes-avail! + peek-bytes-avail!* + peek-bytes-avail!/enable-break) + +(module+ internal + (provide do-read-bytes!)) + +;; ---------------------------------------- + +;; Read `(- end start)` bytes, stopping early only if an EOF is found +(define (do-read-bytes! who in bstr start end) + (define amt (- end start)) + (define v (read-some-bytes! who in bstr start end)) + (cond + [(not (exact-integer? v)) v] + [(= v amt) v] + [else + (let loop ([got v]) + (define v (read-some-bytes! who in bstr got amt #:keep-eof? #t #:special-ok? #f)) + (cond + [(eof-object? v) + got] + [else + (define new-got (+ got v)) + (cond + [(= new-got amt) amt] + [else (loop new-got)])]))])) + +;; ---------------------------------------- + +(define/who (read-byte [orig-in (current-input-port)]) + (check who input-port? orig-in) + (let ([in (->core-input-port orig-in)]) + (define read-byte (core-input-port-read-byte in)) + (cond + [read-byte (do-read-byte who read-byte in)] + [else (read-byte-via-bytes in #:special-ok? #f)]))) + +(define/who (read-bytes amt [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-bytes amt)) + (define v (do-read-bytes! 'read-bytes in bstr 0 amt)) + (if (exact-integer? v) + (if (= v amt) + bstr + (subbytes bstr 0 v)) + v))) + +(define/who (read-bytes! bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-read-bytes! who in bstr start-pos end-pos))) + +(define (do-read-bytes-avail! who bstr in start-pos end-pos + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (check who bytes? bstr) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (read-some-bytes! who in bstr start-pos end-pos #:zero-ok? zero-ok? #:enable-break? enable-break?))) + +(define/who (read-bytes-avail! bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-read-bytes-avail! who bstr in start-pos end-pos)) + +(define/who (read-bytes-avail!* bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-read-bytes-avail! who bstr in start-pos end-pos #:zero-ok? #t)) + +(define/who (read-bytes-avail!/enable-break bstr [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-read-bytes-avail! who bstr in start-pos end-pos #:enable-break? #t)) + +;; ---------------------------------------- + +;; Peek `(- end start)` bytes, stopping early only if an EOF is found +(define (do-peek-bytes! who in bstr start end skip) + (define amt (- end start)) + (define v (peek-some-bytes! who in bstr start end skip)) + (if (exact-integer? v) + (cond + [(= v amt) v] + [else + (let loop ([got v]) + (define v (peek-some-bytes! who in bstr got amt (+ got skip) #:copy-bstr? #f #:special-ok? #f)) + (cond + [(eof-object? v) + got] + [else + (define new-got (+ got v)) + (cond + [(= new-got amt) amt] + [else (loop new-got)])]))]) + v)) + +(define/who (peek-byte [orig-in (current-input-port)] [skip-k 0]) + (check who input-port? orig-in) + (check who exact-nonnegative-integer? skip-k) + (let ([in (->core-input-port orig-in)]) + (define peek-byte (and (zero? skip-k) + (core-input-port-peek-byte in))) + (cond + [peek-byte (do-peek-byte who peek-byte in orig-in)] + [else (peek-byte-via-bytes in skip-k #:special-ok? #f)]))) + +(define/who (peek-bytes amt skip-k [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-bytes amt)) + (define v (do-peek-bytes! 'read-bytes in bstr 0 amt skip-k)) + (if (exact-integer? v) + (if (= v amt) + bstr + (subbytes bstr 0 v)) + v))) + +(define/who (peek-bytes! bstr skip-k [in (current-input-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-peek-bytes! who in bstr start-pos end-pos skip-k))) + +(define (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (check who bytes? bstr) + (check who exact-nonnegative-integer? skip-k) + (check who (lambda (e) (or (not e) (progress-evt? e))) + #:contract "(or/c #f progress-evt?)" progress-evt) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (when progress-evt + (check-progress-evt who progress-evt in)) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (peek-some-bytes! who in bstr start-pos end-pos skip-k + #:progress-evt (unwrap-progress-evt progress-evt) + #:zero-ok? zero-ok? + #:enable-break? enable-break?))) + +(define/who (peek-bytes-avail! bstr skip-k [progress-evt #f] [in (current-input-port)] + [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos)) + +(define/who (peek-bytes-avail!* bstr skip-k [progress-evt #f] [in (current-input-port)] + [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos + #:zero-ok? #t)) + +(define/who (peek-bytes-avail!/enable-break bstr skip-k [progress-evt #f] [in (current-input-port)] + [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-peek-bytes-avail! who bstr skip-k progress-evt in start-pos end-pos + #:enable-break? #t)) diff --git a/racket/src/io/port/bytes-output.rkt b/racket/src/io/port/bytes-output.rkt new file mode 100644 index 0000000000..021b81bda5 --- /dev/null +++ b/racket/src/io/port/bytes-output.rkt @@ -0,0 +1,89 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "output-port.rkt" + "parameter.rkt" + "write.rkt" + "check.rkt") + +(provide write-byte + write-bytes + write-bytes-avail + write-bytes-avail* + write-bytes-avail/enable-break + write-bytes-avail-evt + port-writes-atomic?) + +(module+ internal + (provide do-write-bytes)) + +(define/who (write-byte b [out (current-output-port)]) + (check who byte? b) + (check who output-port? out) + (let ([out (->core-output-port out)]) + (write-some-bytes 'write-byte out (bytes b) 0 1 #:buffer-ok? #t #:copy-bstr? #f)) + (void)) + +(define (do-write-bytes who out bstr start end) + (let loop ([i start]) + (cond + [(= i end) (- i start)] + [else + (define n (write-some-bytes who out bstr i end #:buffer-ok? #t)) + (loop (+ n i))]))) + +(define/who (write-bytes bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who output-port? out) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (let ([out (->core-output-port out)]) + (do-write-bytes who out bstr start-pos end-pos))) + +(define (do-write-bytes-avail who bstr out start-pos end-pos + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (check who bytes? bstr) + (check who output-port? out) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (let ([out (->core-output-port out)]) + (write-some-bytes who out bstr start-pos end-pos #:zero-ok? zero-ok? #:enable-break? enable-break?))) + +(define/who (write-bytes-avail bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-write-bytes-avail who bstr out start-pos end-pos)) + +(define/who (write-bytes-avail* bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-write-bytes-avail who bstr out start-pos end-pos #:zero-ok? #t)) + +(define/who (write-bytes-avail/enable-break bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (do-write-bytes-avail who bstr out start-pos end-pos #:enable-break? #t)) + +(define/who (write-bytes-avail-evt bstr [out (current-output-port)] [start-pos 0] [end-pos (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who output-port? out) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (bytes-length bstr) bstr) + (let ([out (->core-output-port out)]) + (atomically + (check-not-closed who out) + (define get-write-evt (core-output-port-get-write-evt out)) + (unless get-write-evt + (end-atomic) + (raise-arguments-error who + "port does not support output events" + "port" out)) + (get-write-evt bstr start-pos end-pos)))) + +(define/who (port-writes-atomic? out) + (check who output-port? out) + (let ([out (->core-output-port out)]) + (and (core-output-port-get-write-evt out) #t))) diff --git a/racket/src/io/port/bytes-port.rkt b/racket/src/io/port/bytes-port.rkt new file mode 100644 index 0000000000..03fac1bf9d --- /dev/null +++ b/racket/src/io/port/bytes-port.rkt @@ -0,0 +1,227 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "pipe.rkt" + "bytes-input.rkt" + "count.rkt" + "commit-manager.rkt") + +(provide open-input-bytes + open-output-bytes + get-output-bytes + string-port?) + +(struct input-bytes-data ()) + +(define/who (open-input-bytes bstr [name 'string]) + (check who bytes? bstr) + (define i 0) + (define alt-pos #f) + (define len (bytes-length bstr)) + + (define progress-sema #f) + (define (progress!) + (when progress-sema + (semaphore-post progress-sema) + (set! progress-sema #f))) + + (define commit-manager #f) + + ;; in atomic mode [can leave atomic mode temporarily] + ;; After this function returns, complete any commit-changing work + ;; before leaving atomic mode again. + (define (pause-waiting-commit) + (when commit-manager + (commit-manager-pause commit-manager))) + ;; in atomic mode [can leave atomic mode temporarily] + (define (wait-commit progress-evt ext-evt finish) + (cond + [(and (not commit-manager) + ;; Try shortcut: + (not (sync/timeout 0 progress-evt)) + (sync/timeout 0 ext-evt)) + (finish) + #t] + [else + ;; General case to support blocking and potentially multiple + ;; commiting threads: + (unless commit-manager + (set! commit-manager (make-commit-manager))) + (commit-manager-wait commit-manager progress-evt ext-evt finish)])) + + (define p + (make-core-input-port + #:name name + #:data (input-bytes-data) + + #:prepare-change + (lambda () + (pause-waiting-commit)) + + #:read-byte + (lambda () + (let ([pos i]) + (if (pos . < . len) + (begin + (set! i (add1 pos)) + (progress!) + (bytes-ref bstr pos)) + eof))) + + #:read-in + (lambda (dest-bstr start end copy?) + (define pos i) + (cond + [(pos . < . len) + (define amt (min (- end start) (- len pos))) + (set! i (+ pos amt)) + (bytes-copy! dest-bstr start bstr pos (+ pos amt)) + (progress!) + amt] + [else eof])) + + #:peek-byte + (lambda () + (let ([pos i]) + (if (pos . < . len) + (bytes-ref bstr pos) + eof))) + + #:peek-in + (lambda (dest-bstr start end skip progress-evt copy?) + (define pos (+ i skip)) + (cond + [(and progress-evt (sync/timeout 0 progress-evt)) + #f] + [(pos . < . len) + (define amt (min (- end start) (- len pos))) + (bytes-copy! dest-bstr start bstr pos (+ pos amt)) + amt] + [else eof])) + + #:byte-ready + (lambda (work-done!) + (i . < . len)) + + #:close + (lambda () + (set! commit-manager #f) ; to indicate closed + (progress!)) + + #:get-progress-evt + (lambda () + (unless progress-sema + (set! progress-sema (make-semaphore))) + (semaphore-peek-evt progress-sema)) + + #:commit + (lambda (amt progress-evt ext-evt finish) + (unless commit-manager + (set! commit-manager (make-commit-manager))) + (commit-manager-wait + commit-manager + progress-evt ext-evt + ;; in atomic mode, maybe in a different thread: + (lambda () + (let ([amt (min amt (- len i))]) + (define dest-bstr (make-bytes amt)) + (bytes-copy! dest-bstr 0 bstr i (+ i amt)) + (set! i (+ i amt)) + (progress!) + (finish dest-bstr))))) + + #:file-position + (case-lambda + [() (or alt-pos i)] + [(new-pos) + (set! i (if (eof-object? new-pos) + len + (min len new-pos))) + (set! alt-pos + (and new-pos + (not (eof-object? new-pos)) + (new-pos . > . i) + new-pos))]))) + + (when (port-count-lines-enabled) + (port-count-lines! p)) + p) + +;; ---------------------------------------- + +(struct output-bytes-data (i reset)) + +(define (open-output-bytes [name 'string]) + (define-values (i o) (make-pipe)) + (define p + (make-core-output-port + #:name name + #:data (output-bytes-data i (lambda () (pipe-discard-all i))) + #:evt o + #:write-out (core-output-port-write-out o) + #:close (core-port-close o) + #:get-write-evt (core-output-port-get-write-evt o) + #:get-location (core-port-get-location o) + #:count-lines! (core-port-count-lines! o) + #:file-position + (case-lambda + [() (pipe-write-position o)] + [(new-pos) + (define len (pipe-content-length i)) + (cond + [(eof-object? new-pos) + (pipe-write-position o len)] + [(new-pos . > . len) + (when (new-pos . >= . (expt 2 48)) + ;; implausibly large + (end-atomic) + (raise-arguments-error 'file-position + "new position is too large" + "port" p + "position" new-pos)) + (pipe-write-position o len) + (define amt (- new-pos len)) + ((core-output-port-write-out o) (make-bytes amt 0) 0 amt #f #f #f) + (void)] + [else + (pipe-write-position o new-pos)])]))) + (when (port-count-lines-enabled) + (port-count-lines! p)) + p) + +(define/who (get-output-bytes o [reset? #f] [start-pos 0] [end-pos #f]) + (check who (lambda (v) (and (output-port? o) (string-port? o))) + #:contract "(and/c output-port? string-port?)" + o) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? #:or-false end-pos) + (let ([o (->core-output-port o)]) + (define i (output-bytes-data-i (core-port-data o))) + (define len (pipe-content-length i)) + (when (start-pos . > . len) + (raise-range-error who "port content" "starting " start-pos o 0 len #f)) + (when end-pos + (unless (<= start-pos end-pos len) + (raise-range-error who "port content" "ending " end-pos o 0 len start-pos))) + (define amt (- (min len (or end-pos len)) start-pos)) + (define bstr (make-bytes amt)) + (peek-bytes! bstr start-pos i) + (when reset? + ((output-bytes-data-reset (core-port-data o)))) + bstr)) + +;; ---------------------------------------- + +(define (string-port? p) + (cond + [(input-port? p) + (let ([p (->core-input-port p)]) + (input-bytes-data? (core-port-data p)))] + [(output-port? p) + (let ([p (->core-output-port p)]) + (output-bytes-data? (core-port-data p)))] + [else + (raise-argument-error 'string-port? "port?" p)])) diff --git a/racket/src/io/port/check.rkt b/racket/src/io/port/check.rkt new file mode 100644 index 0000000000..991c590ebf --- /dev/null +++ b/racket/src/io/port/check.rkt @@ -0,0 +1,25 @@ +#lang racket/base +(require "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "close.rkt") + +(provide check-not-closed) + +;; in atomic mode +;; Atomic mode is required on entry because an operation +;; that is prefixed when a port-closed check normally needs +;; to happen atomically with respect to the check. +(define (check-not-closed who cp) + (when (closed-state-closed? (core-port-closed cp)) + (end-atomic) + (define input? (core-input-port? cp)) + (raise-arguments-error who + (if input? + "input port is closed" + "output port is closed") + (if input? + "input port" + "output port") + cp))) diff --git a/racket/src/io/port/close.rkt b/racket/src/io/port/close.rkt new file mode 100644 index 0000000000..ea12d1f079 --- /dev/null +++ b/racket/src/io/port/close.rkt @@ -0,0 +1,64 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt") + +(provide port-closed? + close-input-port + close-output-port + port-closed-evt + + close-port + set-closed-state!) + +(define (port-closed? p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'close-input-port "port?" p)])]) + (closed-state-closed? (core-port-closed p)))) + +;; maybe in atomic mode via custodian shutdown: +(define (close-port p) + (define closed (core-port-closed p)) + (unless (closed-state-closed? closed) + (atomically + ((core-port-close p)) + (set-closed-state! closed)))) + +;; in atomic mode +(define (set-closed-state! closed) + (unless (closed-state-closed? closed) + (set-closed-state-closed?! closed #t) + (let ([s (closed-state-closed-sema closed)]) + (when s (semaphore-post s))))) + +(define/who (close-input-port p) + (check who input-port? p) + (close-port (->core-input-port p))) + +(define/who (close-output-port p) + (check who output-port? p) + (close-port (->core-output-port p))) + +(define (port-closed-evt p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'port-closed-evt "port?" p)])]) + (define closed (core-port-closed p)) + (define sema + (atomically + (or (closed-state-closed-sema closed) + (let ([s (make-semaphore)]) + (set-closed-state-closed-sema! closed s) + (when (closed-state-closed? closed) + (semaphore-post s)) + s)))) + (define self (wrap-evt (semaphore-peek-evt sema) + (lambda (v) self))) + self)) diff --git a/racket/src/io/port/commit-manager.rkt b/racket/src/io/port/commit-manager.rkt new file mode 100644 index 0000000000..f91eb94093 --- /dev/null +++ b/racket/src/io/port/commit-manager.rkt @@ -0,0 +1,139 @@ +#lang racket/base +(require "../host/thread.rkt") + +;; A commit manager orchestrates attempts to commit peeked +;; bytes in potentially many threads + +(provide make-commit-manager + commit-manager-pause + commit-manager-wait) + +(struct commit-manager (pause-channel commit-channel thread)) + +(struct commit-request (ext-evt progress-evt abandon-evt finish result-ch)) +(struct commit-response (abandon-evt result-put-evt)) + +(define (make-commit-manager) + (define pause-ch (make-channel)) + (define commit-ch (make-channel)) + (commit-manager + pause-ch + commit-ch + (thread + (lambda () + (let loop ([reqs '()] [resps '()]) + ;; Poll progress and abandon evts: + (define-values (live-reqs new-resps) + (poll-commit-liveness reqs resps)) + ;; Drop abandoned responses, too: + (define live-resps + (drop-abandoned new-resps)) + (apply + sync + (handle-evt pause-ch + (lambda (evt) + ;; The port's state can change in other + ;; threads only while the manager thread is + ;; right here, before the `sync` completes: + (sync evt) + (loop live-reqs live-resps))) + (handle-evt commit-ch + (lambda (req) + (loop (cons req live-reqs) live-resps))) + (append + (for/list ([req (in-list live-reqs)]) + (handle-evt (commit-request-ext-evt req) + (lambda (v) + ;; commit request succeeds + (atomically + ((commit-request-finish req))) + (loop (remq req live-reqs) + (cons (commit-response + (commit-request-abandon-evt req) + (channel-put-evt + (commit-request-result-ch req) + #t)) + live-resps))))) + (for/list ([resp (in-list live-resps)]) + (handle-evt (commit-response-result-put-evt resp) + (lambda (ignored) + ;; response delivered + (loop live-reqs + (remq resp live-resps)))))))))))) + +(define (poll-commit-liveness reqs resps) + (let loop ([reqs reqs] [live-reqs '()] [resps resps]) + (cond + [(null? reqs) (values live-reqs resps)] + [(sync/timeout 0 (commit-request-progress-evt (car reqs))) + ;; commit fails + (loop (cdr reqs) + live-reqs + (cons (commit-response + (commit-request-abandon-evt (car reqs)) + (channel-put-evt + (commit-request-result-ch (car reqs)) + #f)) + resps))] + [(sync/timeout 0 (commit-request-abandon-evt (car reqs))) + ;; request abandoned + (loop (cdr reqs) live-reqs resps)] + [else + (loop (cdr reqs) (cons (car reqs) live-reqs) resps)]))) + +(define (drop-abandoned resps) + (for/list ([resp (in-list resps)] + #:unless (sync/timeout 0 (commit-response-abandon-evt resp))) + resp)) + +;; in atomic mode; can leave it and return +;; After this function returns, the committing thread +;; is definitely not trying to sync to complete +;; a commit, but it can resume as soon as we go back +;; out of atomic mode +(define (commit-manager-pause mgr) + (define lock (make-semaphore)) + (define suspend-evt (thread-suspend-evt (current-thread))) + (dynamic-wind + void + (lambda () + (non-atomically + ;; the manager thread, just in case: + (thread-resume (commit-manager-thread mgr) (current-thread)) + ;; ask the manager to pause; syncing on the channel means that + ;; it has stopped trying a commit sync; we let the manager + ;; thread resume by posting to th elock --- but beware that + ;; *this* thread might get suspended or killed + (sync + (channel-put-evt (commit-manager-pause-channel mgr) + (choice-evt (list lock + suspend-evt + (thread-dead-evt (current-thread)))))))) + (lambda () + ;; Either back in atomic mode or escaping, so it's ok for the + ;; waiting thread to try again when it eventually gets to run + (semaphore-post lock))) + ;; If this thread was suspended during `pause-waiting-commit`, we + ;; may have let the committing thread go, so try again + (when (sync/timeout 0 suspend-evt) + (commit-manager-pause mgr))) + +;; in atmomic mode; can leave it and return +(define (commit-manager-wait mgr progress-evt ext-evt finish) + (define result-ch (make-channel)) + (define abandon-evt (make-semaphore)) + (dynamic-wind + void + (lambda () + (non-atomically + (sync + (channel-put-evt (commit-manager-commit-channel mgr) + (commit-request ext-evt + progress-evt + (choice-evt (list abandon-evt + (thread-dead-evt (current-thread)))) + finish + result-ch))) + (sync result-ch))) + (lambda () + (semaphore-post abandon-evt)))) diff --git a/racket/src/io/port/count.rkt b/racket/src/io/port/count.rkt new file mode 100644 index 0000000000..883f0e1728 --- /dev/null +++ b/racket/src/io/port/count.rkt @@ -0,0 +1,210 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "check.rkt" + "file-position.rkt" + "../string/utf-8-decode.rkt") + +(provide port-count-lines-enabled + + port-count-lines! + port-counts-lines? + port-next-location + set-port-next-location! + + port-count! + port-count-byte! + + port-count-all! + port-count-byte-all!) + +(define port-count-lines-enabled + (make-parameter #f (lambda (v) (and v #t)))) + +(define/who (port-count-lines! p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else (check who #:test #f #:contract "port?" p)])]) + (atomically + (check-not-closed who p) + (unless (core-port-count? p) + (set-core-port-count?! p #t) + (set-core-port-line! p 1) + (set-core-port-column! p 0) + (set-core-port-position! p (add1 (or (core-port-offset p) 0))) + (define count-lines! (core-port-count-lines! p)) + (when count-lines! + (count-lines!)))))) + +(define/who (port-counts-lines? p) + (core-port-count? + (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (check who #:test #f #:contract "port?" p)]))) + +(define/who (port-next-location p) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (check who #:test #f #:contract "port?" p)])]) + (cond + [(core-port-count? p) + (atomically + (check-not-closed who p) + (define get-location (core-port-get-location p)) + (cond + [get-location + (get-location)] + [else + (values (core-port-line p) + (core-port-column p) + (core-port-position p))]))] + [(core-port-file-position p) + (define offset (do-simple-file-position who p (lambda () #f))) + (values #f #f (and offset (add1 offset)))] + [else + (define offset (core-port-offset p)) + (values #f #f (and offset (add1 offset)))]))) + +(define/who (set-port-next-location! p line col pos) + (check who (lambda (p) (or (input-port? p) (output-port? p))) + #:contract "port?" + p) + (check who #:or-false exact-positive-integer? line) + (check who #:or-false exact-nonnegative-integer? col) + (check who #:or-false exact-positive-integer? pos) + (let ([p (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])]) + (atomically + (when (and (core-port-count? p) + (not (core-port-count-lines! p))) + (set-core-port-line! p line) + (set-core-port-column! p col) + (set-core-port-position! p pos))))) + +;; in atomic mode +;; When line counting is enabled, increment line, column, etc. counts +;; --- which involves UTF-8 decoding. To make column and position counting +;; interact well with decoding errors, the column and position are advanced +;; while accumulating decoding information, and then the column and position +;; can go backwards when the decoding completes. +(define (port-count! in amt bstr start) + (increment-offset! in amt) + (when (core-port-count? in) + (define end (+ start amt)) + (let loop ([i start] + [span 0] ; number of previous bytes still to send to UTF-8 decoding + [line (core-port-line in)] + [column (core-port-column in)] + [position (core-port-position in)] + [state (core-port-state in)] + [cr-state (core-port-cr-state in)]) ; #t => previous char was #\return + (define (finish-utf-8 i abort-mode) + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr (- i span) i + #f 0 #f + #:error-char #\? + #:abort-mode abort-mode + #:state state)) + (define delta-chars (- got-chars + ;; Correct for earlier increment of position + ;; and column based on not-yet-decoded bytes, + ;; leaving counts for still-not-decoded bytes + ;; in place: + (+ span + (- (if (utf-8-state? state) + (utf-8-state-pending-amt state) + 0) + (if (utf-8-state? new-state) + (utf-8-state-pending-amt new-state) + 0))))) + (define (keep-aborts s) (if (eq? s 'complete) #f s)) + (loop i 0 line (and column (+ column delta-chars)) (and position (+ position delta-chars)) + (keep-aborts new-state) #f)) + (cond + [(= i end) + (cond + [(zero? span) + (set-core-port-line! in line) + (set-core-port-column! in column) + (set-core-port-position! in position) + (set-core-port-state! in state) + (set-core-port-cr-state! in cr-state)] + [else + ;; span doesn't include CR, LF, or tab + (finish-utf-8 end 'state)])] + [else + (define b (bytes-ref bstr i)) + (define (end-utf-8) ; => next byte is ASCII, so we can terminate a UTF-8 sequence + (finish-utf-8 i 'error)) + (cond + [(eq? b (char->integer #\newline)) + (cond + [(or state (not (zero? span))) (end-utf-8)] + [cr-state + ;; "\r\n" combination counts as a single position + (loop (add1 i) 0 line column position #f #f)] + [else + (loop (add1 i) 0 (and line (add1 line)) (and column 0) (and position (add1 position)) #f #f)])] + [(eq? b (char->integer #\return)) + (if (and (zero? span)(not state)) + (loop (add1 i) 0 (and line (add1 line)) (and column 0) (and position (add1 position)) #f #t) + (end-utf-8))] + [(eq? b (char->integer #\tab)) + (if (and (zero? span) (not state)) + (loop (add1 i) 0 line (and column (+ (bitwise-and column -8) 8)) (and position (add1 position)) #f #f) + (end-utf-8))] + [(b . < . 128) + (if (and (zero? span) (not state)) + (loop (add1 i) 0 line (and column (add1 column)) (and position (add1 position)) #f #f) + (loop (add1 i) (add1 span) line (and column (add1 column)) (and position (add1 position)) state #f))] + [else + ;; This is where we tentatively increment the column and position, to be + ;; reverted later if decoding collapses multiple bytes: + (loop (add1 i) (add1 span) line (and column (add1 column)) (and position (add1 position)) state #f)])])))) + +;; in atomic mode +(define (port-count-all! in extra-ins amt bstr start) + (port-count! in amt bstr start) + (for ([in (in-list extra-ins)]) + (port-count! in amt bstr start))) + +;; in atomic mode +;; If `b` is not a byte, it is treated like +;; a non-whitespace byte. +(define (port-count-byte! in b) + (increment-offset! in 1) + (when (core-port-count? in) + (cond + [(or (core-port-state in) + (core-port-cr-state in) + (and (fixnum? b) (b . > . 127)) + (eq? b (char->integer #\return)) + (eq? b (char->integer #\newline)) + (eq? b (char->integer #\tab))) + (port-count! in 1 (bytes b) 0)] + [else + (let ([column (core-port-column in)] + [position (core-port-position in)]) + (when position (set-core-port-position! in (add1 position))) + (when column (set-core-port-column! in (add1 column))))]))) + +;; in atomic mode +(define (port-count-byte-all! in extra-ins b) + (port-count-byte! in b) + (for ([in (in-list extra-ins)]) + (port-count-byte! in b))) + +;; in atomic mode +(define (increment-offset! in amt) + (define old-offset (core-port-offset in)) + (when old-offset + (set-core-port-offset! in (+ amt old-offset)))) diff --git a/racket/src/io/port/custom-input-port.rkt b/racket/src/io/port/custom-input-port.rkt new file mode 100644 index 0000000000..9a1871afa7 --- /dev/null +++ b/racket/src/io/port/custom-input-port.rkt @@ -0,0 +1,297 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "input-port.rkt" + "output-port.rkt" + "custom-port.rkt" + "pipe.rkt" + "peek-via-read-port.rkt" + "buffer-mode.rkt") + +(provide make-input-port) + +(define/who (make-input-port name + user-read-in + user-peek-in + user-close + [user-get-progress-evt #f] + [user-commit #f] + [user-get-location #f] + [user-count-lines! void] + [user-init-position 1] + [user-buffer-mode #f]) + (check who + (lambda (p) (or (input-port? p) (and (procedure? p) (procedure-arity-includes? p 1)))) + #:contract "(or/c (procedure-arity-includes/c 1) input-port?)" + user-read-in) + (check who + (lambda (p) (or (not p) (input-port? p) (and (procedure? p) (procedure-arity-includes? p 3)))) + #:contract "(or/c (procedure-arity-includes/c 3) input-port? #f)" + user-peek-in) + (check who (procedure-arity-includes/c 0) user-close) + (check who (procedure-arity-includes/c 0) #:or-false user-get-progress-evt) + (check who (procedure-arity-includes/c 3) #:or-false user-commit) + (check who (procedure-arity-includes/c 0) #:or-false user-get-location) + (check who (procedure-arity-includes/c 0) #:or-false user-count-lines!) + (check-init-position who user-init-position) + (check-buffer-mode who user-buffer-mode) + + (when (not (eqv? (input-port? user-read-in) (input-port? user-peek-in))) + (raise-arguments-error who (if (input-port? user-read-in) + "read argument is an input port, but peek argument is not a port" + "read argument is not an input port, but peek argument is a port") + "read argument" user-read-in + "peek argument" user-peek-in)) + + (when (and (not user-peek-in) user-get-progress-evt) + (raise-arguments-error who "peek argument is #f, but progress-evt argument is not" + "progress-evt argument" user-get-progress-evt)) + + (when (and (not user-get-progress-evt) user-commit) + (raise-arguments-error who "progress-evt argument is #f, but commit argument is not" + "commit argument" user-commit)) + (when (and (not user-commit) user-get-progress-evt) + (raise-arguments-error who "commit argument is #f, but progress-evt argument is not" + "progress-evt argument" user-get-progress-evt)) + + (define input-pipe #f) ; `user-read-in` can redirect input + + (define (protect-in dest-bstr dest-start dest-end copy? read-in) + ;; We don't trust `read-in` to refrain from modifying its + ;; byte-string argument after it returns, and the `read-in` + ;; interface doesn't deal with start and end positions, so copy` + ;; dest-bstr` if needed + (define len (- dest-end dest-start)) + (define user-bstr + (if (or copy? + (not (zero? dest-start)) + (not (= len dest-end))) + (make-bytes len) + dest-bstr)) + (define n (read-in user-bstr)) + (cond + [(eq? user-bstr dest-bstr) + n] + [(evt? n) + (wrap-evt n + (lambda (n) + (when (exact-positive-integer? n) + (bytes-copy! dest-bstr dest-start user-bstr 0 n)) + n))] + [else + (when (exact-positive-integer? n) + (bytes-copy! dest-bstr dest-start user-bstr 0 n)) + n])) + + ;; in atomic mode + (define (check-read-result who r dest-start dest-end #:peek? [peek? #f] #:ok-false? [ok-false? #f]) + (cond + [(exact-nonnegative-integer? r) + (unless (r . <= . (- dest-end dest-start)) + (end-atomic) + (raise-arguments-error who "result integer is larger than the supplied byte string" + "result" r + "byte-string length" (- dest-end dest-start)))] + [(eof-object? r) (void)] + [(and (procedure? r) (procedure-arity-includes? r 4)) + (unless user-peek-in + (end-atomic) + (raise-arguments-error who + (string-append "the port has no specific peek procedure, so" + " a special read result is not allowed") + "special result" r))] + [(pipe-input-port? r) + (set! input-pipe r)] + [(evt? r) r] + [(and peek? (not r)) + (unless ok-false? + (end-atomic) + (raise-arguments-error who "returned #f when no progress evt was supplied"))] + [else + (end-atomic) + (raise-result-error who + (string-append + "(or/c exact-nonnegative-integer? eof-object? evt? pipe-input-port?" + (if (and peek? ok-false?) + " #f" + "") + (if user-peek-in + " (procedure-arity-includes/c 4)" + "") + ")") + r)])) + + ;; possibly in atomic mode + (define (wrap-check-read-evt-result who evt dest-start dest-end peek? ok-false?) + (wrap-evt evt (lambda (r) + (start-atomic) + (check-read-result who r dest-start dest-end #:peek? peek? #:ok-false? ok-false?) + (end-atomic) + (cond + [(pipe-input-port? r) 0] + [(evt? r) + (wrap-check-read-evt-result who r dest-start dest-end peek? ok-false?)] + [else r])))) + + ;; possibly in atomic mode + (define (wrap-procedure-result r) + (define called? #f) + (define (called!) + (when called? + (raise-arguments-error 'read-special "cannot be called a second time")) + (set! called? #t)) + (define (four-args a b c d) + (called!) + (check 'read-special exact-positive-integer? #:or-false b) + (check 'read-special exact-nonnegative-integer? #:or-false c) + (check 'read-special exact-positive-integer? #:or-false d) + (r a b c d)) + (cond + [(procedure-arity-includes? r 0) + (case-lambda + [() (called!) (r)] + [(a b c d) (four-args a b c d)])] + [else + four-args])) + + ;; in atomic mode + (define (read-in dest-bstr dest-start dest-end copy?) + (cond + [input-pipe + (cond + [(zero? (pipe-content-length input-pipe)) + (set! input-pipe #f) + (read-in dest-bstr dest-start dest-end copy?)] + [else + ((core-input-port-read-in input-pipe) dest-bstr dest-start dest-end copy?)])] + [else + (define r + (parameterize-break #f + (non-atomically + (protect-in dest-bstr dest-start dest-end copy? user-read-in)))) + (check-read-result '|user port read| r dest-start dest-end) + (cond + [(pipe-input-port? r) + (read-in dest-bstr dest-start dest-end copy?)] + [(evt? r) + (wrap-check-read-evt-result '|user port read| r dest-start dest-end #f #f)] + [(procedure? r) + (wrap-procedure-result r)] + [else r])])) + + ;; in atomic mode + ;; Used only if `user-peek-in` is a function: + (define (peek-in dest-bstr dest-start dest-end skip-k progress-evt copy?) + (cond + [input-pipe + (cond + [((pipe-content-length input-pipe) . <= . skip-k) + (set! input-pipe #f) + (peek-in dest-bstr dest-start dest-end skip-k progress-evt copy?)] + [else + ((core-input-port-peek-in input-pipe) dest-bstr dest-start dest-end skip-k progress-evt copy?)])] + [else + (define r + (parameterize-break #f + (non-atomically + (protect-in dest-bstr dest-start dest-end copy? + (lambda (user-bstr) (user-peek-in user-bstr skip-k progress-evt)))))) + (check-read-result '|user port peek| r dest-start dest-end #:peek? #t #:ok-false? progress-evt) + (cond + [(pipe-input-port? r) + (peek-in dest-bstr dest-start dest-end skip-k progress-evt copy?)] + [(evt? r) + (wrap-check-read-evt-result '|user port peek| r dest-start dest-end #t progress-evt)] + [(procedure? r) + (wrap-procedure-result r)] + [else r])])) + + ;; in atomic mode + ;; Used only if `user-peek-in` is a function: + (define (byte-ready work-done!) + (cond + [(and input-pipe + (positive? (pipe-content-length input-pipe))) + #t] + [else + (define bstr (make-bytes 1)) + (define v (peek-in bstr 0 1 0 #f #f)) + (work-done!) + (cond + [(evt? v) v] + [else (not (eqv? v 0))])])) + + ;; in atomic mode + (define (close) + (end-atomic) + (user-close) + (start-atomic)) + + (define (get-progress-evt) + (define r (user-get-progress-evt)) + (unless (evt? r) + (raise-result-error '|user port progress-evt| "evt?" r)) + r) + + ;; in atomic mode + (define (commit amt evt ext-evt finish) + (define r + (parameterize-break #f + (non-atomically + (user-commit amt evt ext-evt)))) + (cond + [(not r) #f] + [(bytes? r) (finish r) #t] + [else (finish (make-bytes amt (char->integer #\x))) #t])) + + (define get-location + (and user-get-location + (make-get-location user-get-location))) + + (define count-lines! + (and user-count-lines! + (lambda () (end-atomic) (user-count-lines!) (start-atomic)))) + + (define-values (init-offset file-position) + (make-init-offset+file-position user-init-position)) + + (define buffer-mode + (and user-buffer-mode + (make-buffer-mode user-buffer-mode))) + + (cond + [user-peek-in + (make-core-input-port + #:name name + #:read-in + (if (input-port? user-read-in) + user-read-in + read-in) + #:peek-in + (if (input-port? user-peek-in) + user-peek-in + peek-in) + #:byte-ready + (if (input-port? user-peek-in) + user-peek-in + byte-ready) + #:close close + #:get-progress-evt (and user-get-progress-evt get-progress-evt) + #:commit (and user-commit commit) + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:buffer-mode buffer-mode)] + [else + (define-values (port buffer-flusher) + (open-input-peek-via-read + #:name name + #:read-in read-in + #:close close + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:alt-buffer-mode buffer-mode)) + port])) diff --git a/racket/src/io/port/custom-output-port.rkt b/racket/src/io/port/custom-output-port.rkt new file mode 100644 index 0000000000..f6fb6000bb --- /dev/null +++ b/racket/src/io/port/custom-output-port.rkt @@ -0,0 +1,186 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "output-port.rkt" + "custom-port.rkt" + "pipe.rkt") + +(provide make-output-port) + +(define/who (make-output-port name + evt + user-write-out + user-close + [user-write-out-special #f] + [user-get-write-evt #f] + [user-get-write-special-evt #f] + [user-get-location #f] + [user-count-lines! void] + [user-init-position 1] + [user-buffer-mode #f]) + (check who evt? evt) + (check who (lambda (p) (or (output-port? p) + (and (procedure? p) + (procedure-arity-includes? p 5)))) + #:contract "(or/c output-port? (procedure-arity-includes/c 5))" + user-write-out) + (check who (procedure-arity-includes/c 0) user-close) + (check who (lambda (p) (or (not p) + (output-port? p) + (and (procedure? p) + (procedure-arity-includes? p 3)))) + #:contract "(or/c #f output-port? (procedure-arity-includes/c 3))" + user-write-out-special) + (check who #:or-false (procedure-arity-includes/c 3) user-get-write-evt) + (check who #:or-false (procedure-arity-includes/c 1) user-get-write-special-evt) + (check who #:or-false (procedure-arity-includes/c 0) user-get-location) + (check who (procedure-arity-includes/c 0) user-count-lines!) + (check-init-position who user-init-position) + (check-buffer-mode who user-buffer-mode) + + (when (and (not user-write-out-special) user-get-write-special-evt) + (raise-arguments-error who "write-special argument is #f, but get-write-special-evt argument is not" + "get-write-special-evt argument" user-get-write-special-evt)) + + (when (and (not user-get-write-evt) user-get-write-special-evt) + (raise-arguments-error who "get-write-evt argument is #f, but get-write-special-evt argument is not" + "get-write-special-evt argument" user-get-write-special-evt)) + + (when (and (not user-get-write-special-evt) user-get-write-evt user-write-out-special) + (raise-arguments-error who + "get-write-special-evt argument is #f, but get-write-evt argument is not, and write-special argument is not" + "get-write-evt argument" user-get-write-evt + "get-write-special-evt argument" user-get-write-special-evt)) + + (define output-pipe #f) + + ;; in atomic mode + (define (check-write-result who r start end non-block/buffer? #:as-evt? [as-evt? #f]) + (cond + [(exact-nonnegative-integer? r) + (if (eqv? r 0) + (unless (= start end) + (end-atomic) + (raise-arguments-error who (string-append + "bad result for non-flush write" + (if as-evt? " event" "")) + "result" r)) + (unless (r . <= . (- end start)) + (end-atomic) + (raise-arguments-error who "result integer is larger than the supplied byte string" + "result" r + "byte string length" (- end start))))] + [(not r) r] + [(pipe-output-port? r) + (when (= start end) + (end-atomic) + (raise-arguments-error who "bad result for a flushing write" + "result" r)) + (when non-block/buffer? + (end-atomic) + (raise-arguments-error who "bad result for a non-blocking write" + "result" r)) + (set! output-pipe r)] + [(evt? r) + (void)] + [else + (end-atomic) + (raise-result-error who "(or/c exact-nonnegative-integer? #f evt?)" r)])) + + + ;; possibly in atomic mode + (define (wrap-check-write-evt-result who evt start end non-block/buffer?) + (wrap-evt evt (lambda (r) + (start-atomic) + (check-write-result who r start end non-block/buffer? #:as-evt? #t) + (end-atomic) + (cond + [(pipe-output-port? r) 0] + [(evt? r) + (wrap-check-write-evt-result who r start end non-block/buffer?)] + [else r])))) + + ;; in atomic mode + (define (write-out bstr start end non-block/buffer? enable-break? copy?) + (cond + [output-pipe + (cond + [(or non-block/buffer? + (= start end) + (not (sync/timeout 0 output-pipe))) + (set! output-pipe #f) + (write-out bstr start end non-block/buffer? enable-break? copy?)] + [else + ((core-output-port-write-out output-pipe) bstr start end non-block/buffer? enable-break? copy?)])] + [else + (define r + ;; Always tell user port to re-enable breaks if it blocks, since + ;; we always disable breaks: + (let ([enable-break? (and (not non-block/buffer?) (break-enabled))]) + (parameterize-break #f + (non-atomically + (if copy? + (user-write-out (subbytes bstr start end) 0 (- end start) non-block/buffer? enable-break?) + (user-write-out bstr start end non-block/buffer? enable-break?)))))) + (check-write-result '|user port write| r start end non-block/buffer?) + (cond + [(pipe-output-port? r) + (write-out bstr start end non-block/buffer? enable-break? copy?)] + [(evt? r) + (wrap-check-write-evt-result '|user port write| r start end non-block/buffer?)] + [else r])])) + + (define (get-write-evt bstr start end) + (end-atomic) + (define r (user-get-write-evt bstr start end)) + (unless (evt? r) + (raise-result-error '|user port get-write-evt| "evt?" r)) + (start-atomic) + (wrap-check-write-evt-result '|user port write-evt| r start end #t)) + + (define (write-out-special v non-block/buffer? enable-break?) + (let ([enable-break? (and (not non-block/buffer?) (break-enabled))]) + (parameterize-break #f + (non-atomically + (user-write-out-special v non-block/buffer? enable-break?))))) + + (define get-location + (and user-get-location + (make-get-location user-get-location))) + + (define count-lines! + (and user-count-lines! + (lambda () (end-atomic) (user-count-lines!) (start-atomic)))) + + (define-values (init-offset file-position) + (make-init-offset+file-position user-init-position)) + + (define buffer-mode + (and user-buffer-mode + (make-buffer-mode user-buffer-mode #:output? #t))) + + ;; in atomic mode + (define (close) + (end-atomic) + (user-close) + (start-atomic)) + + (make-core-output-port + #:name name + #:evt evt + #:write-out + (if (output-port? user-write-out) + user-write-out + write-out) + #:close close + #:write-out-special + (if (output-port? user-write-out-special) + user-write-out-special + (and user-write-out-special write-out-special)) + #:get-write-evt (and user-get-write-evt get-write-evt) + #:get-write-special-evt user-get-write-special-evt + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:buffer-mode buffer-mode)) diff --git a/racket/src/io/port/custom-port.rkt b/racket/src/io/port/custom-port.rkt new file mode 100644 index 0000000000..78f91ed16c --- /dev/null +++ b/racket/src/io/port/custom-port.rkt @@ -0,0 +1,96 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "input-port.rkt" + "output-port.rkt") + +;; Common functionality for "custom-input-port.rkt" and +;; "custom-output-port.rkt" + +(provide make-get-location + + check-init-position + make-init-offset+file-position + + check-buffer-mode + make-buffer-mode) + + +;; in atomic mode +(define (make-get-location user-get-location) + (lambda () + (end-atomic) + (call-with-values + (lambda () (user-get-location)) + (case-lambda + [(line col pos) + (unless (or (not line) (exact-positive-integer? line)) + (raise-result-error '|user port get-location| "(or/c #f exact-positive-integer?)" line)) + (unless (or (not line) (exact-nonnegative-integer? col)) + (raise-result-error '|user port get-location| "(or/c #f exact-nonnegative-integer?)" col)) + (unless (or (not line) (exact-positive-integer? pos)) + (raise-result-error '|user port get-location| "(or/c #f exact-positive-integer?)" pos)) + (start-atomic) + (values line col pos)] + [args + (apply raise-arity-error '|user port get-location return| 3 args)])))) + +(define (check-init-position who user-init-position) + (check who (lambda (p) (or (exact-positive-integer? p) + (input-port? p) + (output-port? p) + (not p) + (and (procedure? p) (procedure-arity-includes? p 0)))) + #:contract "(or/c exact-positive-integer? port? #f (procedure-arity-includes/c 0))" + user-init-position)) + +(define (make-init-offset+file-position user-init-position) + (define init-offset + (if (or (procedure? user-init-position) + (input-port? user-init-position) + (output-port? user-init-position) + (not user-init-position)) + #f + (sub1 user-init-position))) + + (define file-position + (cond + [(input-port? user-init-position) user-init-position] + [(output-port? user-init-position) user-init-position] + [(procedure? user-init-position) + (lambda () + (define pos (user-init-position)) + (unless (or (not pos) (exact-positive-integer? pos)) + (raise-result-error '|user port init-position| "(or/c exact-positive-integer? #f)" pos)) + (and pos (sub1 pos)))] + [else #f])) + + (values init-offset file-position)) + +(define (check-buffer-mode who user-buffer-mode) + (check who (lambda (p) (or (not p) + (and (procedure? p) + (procedure-arity-includes? p 0) + (procedure-arity-includes? p 1)))) + #:contract (string-append "(or/c #f (and/c (procedure-arity-includes/c 0)\n" + " (procedure-arity-includes/c 1)))") + user-buffer-mode)) + +(define (make-buffer-mode user-buffer-mode #:output? [output? #f]) + (case-lambda + [() + (end-atomic) + (define m (user-buffer-mode)) + (cond + [(or (not m) (eq? m 'block) (eq? m 'none) (and output? (eq? m 'line))) + (start-atomic) + m] + [else + (raise-result-error '|user port buffer-mode| + (if output? + "(or/c 'block 'line 'none #f)" + "(or/c 'block 'none #f)") + m)])] + [(m) + (non-atomically + (user-buffer-mode m))])) diff --git a/racket/src/io/port/evt.rkt b/racket/src/io/port/evt.rkt new file mode 100644 index 0000000000..e0b35909e4 --- /dev/null +++ b/racket/src/io/port/evt.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require "../host/thread.rkt") + +;; To make a port act like an event, the `prop:secondary-evt` property +;; must be mapped to `port->evt` --- both for the `core-port` +;; structure type and implied by `prop:input-port` and +;; `prop:output-port`. As the name suggests, `prop:secondary-evt` is +;; used only when a structure doesn't have `prop:evt`, so `prop:input-port` +;; and `prop:output-port` can be mixed with `prop:evt`. + +;; A structue with `prop:secondary-evt` mapped to `port->evt` should +;; also have `prop:input-port-evt` or `prop:input-port-evt`. Those +;; properties provide an indirection to avoid a dependency cycle between +;; this module and the implement of input and output ports. + +(provide port->evt + prop:input-port-evt input-port-evt? input-port-evt-ref + prop:output-port-evt output-port-evt? output-port-evt-ref) + +(define-values (prop:input-port-evt input-port-evt? input-port-evt-ref) + (make-struct-type-property 'input-port-evt)) + +(define-values (prop:output-port-evt output-port-evt? output-port-evt-ref) + (make-struct-type-property 'output-port-evt)) + +(define (port->evt p) + ;; A structure can be both an input port and an output + ;; port, and the input nature take precedence + (cond + [(input-port-evt? p) + (wrap-evt ((input-port-evt-ref p) p) + (lambda (v) p))] + [else + (wrap-evt ((output-port-evt-ref p) p) + (lambda (v) p))])) diff --git a/racket/src/io/port/fd-port.rkt b/racket/src/io/port/fd-port.rkt new file mode 100644 index 0000000000..7515b59b82 --- /dev/null +++ b/racket/src/io/port/fd-port.rkt @@ -0,0 +1,335 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt" + "../host/thread.rkt" + "../sandman/main.rkt" + "../file/error.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "peek-via-read-port.rkt" + "file-stream.rkt" + "file-truncate.rkt" + "buffer-mode.rkt" + "close.rkt" + "count.rkt" + "check.rkt") + +(provide open-input-fd + open-output-fd + terminal-port? + fd-port-fd + maybe-fd-data-extra) + +(struct fd-data (fd extra) + #:property prop:file-stream (lambda (fdd) (fd-data-fd fdd)) + #:property prop:file-truncate (case-lambda + [(fdd pos) + (check-rktio-error* + (rktio_set_file_size rktio + (fd-data-fd fdd) + pos) + "error setting file size")])) + +(define (maybe-fd-data-extra data) + (and (fd-data? data) + (fd-data-extra data))) + +;; in atomic mode +(define (fd-close fd fd-refcount) + (set-box! fd-refcount (sub1 (unbox fd-refcount))) + (when (zero? (unbox fd-refcount)) + (define v (rktio_close rktio fd)) + (when (rktio-error? v) + (end-atomic) + (raise-rktio-error #f v "error closing stream port")))) + +;; ---------------------------------------- + +;; in atomic mode +;; Current custodian must not be shut down. +(define (open-input-fd fd name + #:extra-data [extra-data #f] + #:on-close [on-close void] + #:fd-refcount [fd-refcount (box 1)]) + (define-values (port buffer-control) + (open-input-peek-via-read + #:name name + #:data (fd-data fd extra-data) + #:read-in + ;; in atomic mode + (lambda (dest-bstr start end copy?) + (define n (rktio_read_in rktio fd dest-bstr start end)) + (cond + [(rktio-error? n) + (end-atomic) + (raise-filesystem-error #f n "error reading from stream port")] + [(eqv? n RKTIO_READ_EOF) eof] + [(eqv? n 0) (wrap-evt (fd-evt fd RKTIO_POLL_READ (core-port-closed port)) + (lambda (v) 0))] + [else n])) + #:read-is-atomic? #t + #:close + ;; in atomic mode + (lambda () + (on-close) + (fd-close fd fd-refcount) + (unsafe-custodian-unregister fd custodian-reference)) + #:file-position (make-file-position + fd + (case-lambda + [() (buffer-control)] + [(pos) (buffer-control pos)])))) + (define custodian-reference + (register-fd-close (current-custodian) fd fd-refcount port)) + port) + +;; ---------------------------------------- + +;; in atomic mode +;; Current custodian must not be shut down. +(define (open-output-fd fd name + #:extra-data [extra-data #f] + #:buffer-mode [buffer-mode 'infer] + #:fd-refcount [fd-refcount (box 1)] + #:on-close [on-close void]) + (define buffer (make-bytes 4096)) + (define buffer-start 0) + (define buffer-end 0) + (define flush-handle + (plumber-add-flush! (current-plumber) + (lambda (h) + (flush-buffer-fully #f) + (plumber-flush-handle-remove! h)))) + + (when (eq? buffer-mode 'infer) + (if (rktio_fd_is_terminal rktio fd) + (set! buffer-mode 'line) + (set! buffer-mode 'block))) + + (define evt (fd-evt fd RKTIO_POLL_WRITE #f)) + + ;; in atomic mode + ;; Returns `#t` if the buffer is already or successfully flushed + (define (flush-buffer) + (cond + [(not (= buffer-start buffer-end)) + (define n (rktio_write_in rktio fd buffer buffer-start buffer-end)) + (cond + [(rktio-error? n) + (end-atomic) + (raise-filesystem-error #f n "error writing to stream port")] + [(zero? n) + #f] + [else + (define new-buffer-start (+ buffer-start n)) + (cond + [(= new-buffer-start buffer-end) + (set! buffer-start 0) + (set! buffer-end 0) + #t] + [else + (set! buffer-start new-buffer-start) + #f])])] + [else #t])) + + ;; in atomic mode + (define (flush-buffer-fully enable-break?) + (let loop () + (unless (flush-buffer) + (end-atomic) + (if enable-break? + (sync/enable-break evt) + (sync evt)) + (start-atomic) + (when buffer ; in case it was closed + (loop))))) + + ;; in atomic mode + (define (flush-buffer-fully-if-newline src-bstr src-start src-end enable-break?) + (for ([b (in-bytes src-bstr src-start src-end)]) + (define newline? (or (eqv? b (char->integer #\newline)) + (eqv? b (char->integer #\return)))) + (when newline? (flush-buffer-fully enable-break?)) + #:break newline? + (void))) + + (define port + (make-core-output-port + #:name name + #:data (fd-data fd extra-data) + + #:evt evt + + #:write-out + ;; in atomic mode + (lambda (src-bstr src-start src-end nonbuffer/nonblock? enable-break? copy?) + (cond + [(= src-start src-end) + ;; Flush request + (and (flush-buffer) 0)] + [(and (not (eq? buffer-mode 'none)) + (not nonbuffer/nonblock?) + (< buffer-end (bytes-length buffer))) + (define amt (min (- src-end src-start) (- (bytes-length buffer) buffer-end))) + (bytes-copy! buffer buffer-end src-bstr src-start (+ src-start amt)) + (set! buffer-end (+ buffer-end amt)) + (unless nonbuffer/nonblock? + (when (eq? buffer-mode 'line) + ;; can temporarily leave atomic mode: + (flush-buffer-fully-if-newline src-bstr src-start src-end enable-break?))) + amt] + [(not (flush-buffer)) ; <- can temporarily leave atomic mode + #f] + [else + (define n (rktio_write_in rktio fd src-bstr src-start src-end)) + (cond + [(rktio-error? n) + (end-atomic) + (raise-filesystem-error #f n "error writing to stream port")] + [(zero? n) (wrap-evt evt (lambda (v) #f))] + [else n])])) + + #:count-write-evt-via-write-out + (lambda (v bstr start) + (port-count! port v bstr start)) + + #:close + ;; in atomic mode + (lambda () + (flush-buffer-fully #f) ; can temporarily leave atomic mode + (when buffer ; <- in case a concurrent close succeeded + (on-close) + (plumber-flush-handle-remove! flush-handle) + (set! buffer #f) + (fd-close fd fd-refcount) + (unsafe-custodian-unregister fd custodian-reference))) + + #:file-position (make-file-position + fd + ;; in atomic mode + (case-lambda + [() + (flush-buffer-fully #f) + ;; flushing can leave atomic mode, so make sure the + ;; port is still open before continuing + (unless buffer + (check-not-closed 'file-position port))] + [(pos) + (+ pos (- buffer-end buffer-start))])) + #:buffer-mode (case-lambda + [() buffer-mode] + [(mode) (set! buffer-mode mode)]))) + + (define custodian-reference + (register-fd-close (current-custodian) fd fd-refcount port)) + + (set-fd-evt-closed! evt (core-port-closed port)) + + port) + +;; ---------------------------------------- + +(define (terminal-port? p) + (define data + (core-port-data + (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'terminal-port? "port?" p)]))) + (and (fd-data? data) + (rktio_fd_is_terminal rktio (fd-data-fd data)))) + +(define (fd-port-fd p) + (define data + (core-port-data + (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)]))) + (and (fd-data? data) + (fd-data-fd data))) + +;; ---------------------------------------- + +(define (make-file-position fd buffer-control) + ;; in atomic mode + (case-lambda + [() + (define ppos (rktio_get_file_position rktio fd)) + (cond + [(rktio-error? ppos) + ;; #f => not supported, so use port's own counter, instead + #f] + [else + (define pos (rktio_filesize_ref ppos)) + (rktio_free ppos) + (buffer-control pos)])] + [(pos) + (buffer-control) + (define r + (rktio_set_file_position rktio + fd + (if (eof-object? pos) + 0 + pos) + (if (eof-object? pos) + RKTIO_POSITION_FROM_END + RKTIO_POSITION_FROM_START))) + (when (rktio-error? r) + (end-atomic) + (raise-rktio-error 'file-position r "error setting stream position"))])) + +;; ---------------------------------------- + +(struct fd-evt (fd mode [closed #:mutable]) + #:property + prop:evt + (poller + ;; This function is called by the scheduler for `sync` to check + ;; whether the file descriptor has data available: + (lambda (fde ctx) + (cond + [(closed-state-closed? (fd-evt-closed fde)) + (values (list fde) #f)] + [else + (define mode (fd-evt-mode fde)) + (define ready? + (or + (and (eqv? RKTIO_POLL_READ (bitwise-and mode RKTIO_POLL_READ)) + (eqv? (rktio_poll_read_ready rktio (fd-evt-fd fde)) + RKTIO_POLL_READY)) + (and (eqv? RKTIO_POLL_WRITE (bitwise-and mode RKTIO_POLL_WRITE)) + (eqv? (rktio_poll_write_ready rktio (fd-evt-fd fde)) + RKTIO_POLL_READY)))) + (cond + [ready? + (values (list fde) #f)] + [else + ;; If `sched-info` in `poll-ctx` is not #f, then we can register this file + ;; descriptor so that if no thread is able to make progress, + ;; the Racket process will sleep, but it will wake up when + ;; input is available. The implementation of external events + ;; is from the current sandman, which will in turn be the + ;; one (or build on the one) in "../sandman". + (sandman-poll-ctx-add-poll-set-adder! + ctx + ;; Cooperate with the sandman by registering + ;; a function that takes a poll set and + ;; adds to it: + (lambda (ps) + (rktio_poll_add rktio (fd-evt-fd fde) ps mode))) + (values #f fde)])])))) + +;; ---------------------------------------- + +(define (register-fd-close custodian fd fd-refcount port) + (define closed (core-port-closed port)) + (unsafe-custodian-register custodian + fd + ;; in atomic mode + (lambda (fd) + (fd-close fd fd-refcount) + (set-closed-state! closed)) + #f + #f)) diff --git a/racket/src/io/port/file-identity.rkt b/racket/src/io/port/file-identity.rkt new file mode 100644 index 0000000000..f1d5ef7a8e --- /dev/null +++ b/racket/src/io/port/file-identity.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../file/identity.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "file-stream.rkt" + "check.rkt") + +(provide port-file-identity) + +(define/who (port-file-identity p) + (check who file-stream-port? p) + (define cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])) + (start-atomic) + (check-not-closed who cp) + (define fd (let ([pd (core-port-data cp)]) + ((file-stream-ref pd) pd))) + (path-or-fd-identity who #:fd fd #:port p)) diff --git a/racket/src/io/port/file-lock.rkt b/racket/src/io/port/file-lock.rkt new file mode 100644 index 0000000000..8c41b7b024 --- /dev/null +++ b/racket/src/io/port/file-lock.rkt @@ -0,0 +1,56 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "file-stream.rkt" + "check.rkt") + +(provide port-try-file-lock? + port-file-unlock) + +(define/who (port-try-file-lock? p mode) + (check who file-stream-port? p) + (check who (lambda (m) (or (eq? m 'shared) (eq? m 'exclusive))) + #:contract "(or/c 'shared 'exclusive)" + mode) + (define exclusive? (eq? mode 'exclusive)) + (when (and exclusive? (not (output-port? p))) + (raise-arguments-error who "port for 'exclusive locking is not an output port" + "port" p)) + (when (and (not exclusive?) (not (input-port? p))) + (raise-arguments-error who "port for 'shared locking is not an input port" + "port" p)) + (define cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])) + (start-atomic) + (check-not-closed who cp) + (define fd (let ([pd (core-port-data cp)]) + ((file-stream-ref pd) pd))) + (define r (rktio_file_lock_try rktio fd exclusive?)) + (end-atomic) + (when (rktio-error? r) + (raise-rktio-error who + r + (string-append "error getting file " + (if exclusive? "exclusive" "shared") + " lock"))) + (eqv? r RKTIO_LOCK_ACQUIRED)) + +(define/who (port-file-unlock p) + (check who file-stream-port? p) + (define cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])) + (start-atomic) + (check-not-closed who cp) + (define fd (let ([pd (core-port-data cp)]) + ((file-stream-ref pd) pd))) + (define r (rktio_file_unlock rktio fd)) + (end-atomic) + (when (rktio-error? r) + (raise-rktio-error who r "error unlocking file"))) diff --git a/racket/src/io/port/file-port.rkt b/racket/src/io/port/file-port.rkt new file mode 100644 index 0000000000..4cbd2b8607 --- /dev/null +++ b/racket/src/io/port/file-port.rkt @@ -0,0 +1,180 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../path/path.rkt" + "../file/parameter.rkt" + "../file/host.rkt" + "../file/error.rkt" + "../format/main.rkt" + "fd-port.rkt" + "close.rkt" + "parameter.rkt" + "count.rkt") + +(provide open-input-file + open-output-file + open-input-output-file + call-with-input-file + call-with-output-file + with-input-from-file + with-output-to-file) + +(define none (gensym)) + +(define/who (open-input-file path [mode1 none] [mode2 none]) + (check who path-string? path) + (define (mode->flags mode) + (case mode + [(text) RKTIO_OPEN_TEXT] + [else 0])) + (define host-path (->host path who '(read))) + (start-atomic) + (check-current-custodian who) + (define fd (rktio_open rktio + host-path + (+ RKTIO_OPEN_READ + (mode->flags mode1) + (mode->flags mode2)))) + (when (rktio-error? fd) + (end-atomic) + (when (or (eq? mode1 'module) (eq? mode2 'module)) + (maybe-raise-missing-module who (host-> host-path) "" "" "" + (format-rktio-system-error-message fd))) + (raise-filesystem-error who + fd + (format (string-append + "cannot open input file\n" + " path: ~a") + (host-> host-path)))) + (define p (open-input-fd fd (host-> host-path))) + (end-atomic) + (when (port-count-lines-enabled) + (port-count-lines! p)) + p) + +(define (do-open-output-file #:plus-input? [plus-input? #f] who path mode1 mode2) + (check who path-string? path) + (define (mode->flags mode) + (case mode + [(test) RKTIO_OPEN_TEXT] + [(truncate truncate/replace) (+ RKTIO_OPEN_TRUNCATE + RKTIO_OPEN_CAN_EXIST)] + [(must-truncate) (+ RKTIO_OPEN_TRUNCATE + RKTIO_OPEN_MUST_EXIST)] + [(update) RKTIO_OPEN_CAN_EXIST] + [(must-update) RKTIO_OPEN_MUST_EXIST] + [(append) RKTIO_OPEN_APPEND] + [else 0])) + (define (mode? v) + (or (eq? mode1 v) (eq? mode2 v))) + (define host-path (->host path who (append '(write) + (if (or (mode? 'replace) + (mode? 'truncate/replace)) + '(delete) + '()) + (if (or (mode? 'append) + (mode? 'update) + (mode? 'must-update)) + '(read) + '())))) + (start-atomic) + (check-current-custodian who) + (define flags + (+ RKTIO_OPEN_WRITE + (if plus-input? RKTIO_OPEN_READ 0) + (mode->flags mode1) + (mode->flags mode2))) + (define fd0 + (rktio_open rktio host-path flags)) + (define fd + (cond + [(not (rktio-error? fd0)) fd0] + [(and (or (racket-error? fd0 RKTIO_ERROR_EXISTS) + (racket-error? fd0 RKTIO_ERROR_ACCESS_DENIED)) + (or (mode? 'replace) (mode? 'truncate/replace))) + (define r (rktio_delete_file rktio + host-path + (current-force-delete-permissions))) + (when (rktio-error? r) + (end-atomic) + (raise-filesystem-error who + r + (format (string-append + "error deleting file\n" + " path: ~a") + (host-> host-path)))) + (rktio_open rktio host-path flags)] + [else fd0])) + (when (rktio-error? fd) + (end-atomic) + (raise-filesystem-error who + fd + (format (string-append + "~a\n" + " path: ~a") + (cond + [(racket-error? fd0 RKTIO_ERROR_EXISTS) + "file exists"] + [(racket-error? fd0 RKTIO_ERROR_IS_A_DIRECTORY) + "path is a directory"] + [else "error opening file"]) + (host-> host-path)))) + (define opened-path (host-> host-path)) + (define refcount (box (if plus-input? 2 1))) + (define op (open-output-fd fd opened-path #:fd-refcount refcount)) + (define ip (and plus-input? + (open-input-fd fd opened-path #:fd-refcount refcount))) + (end-atomic) + (when (port-count-lines-enabled) + (port-count-lines! op) + (when plus-input? + (port-count-lines! ip))) + (if plus-input? + (values ip op) + op)) + +(define/who (open-output-file path [mode1 none] [mode2 none]) + (do-open-output-file who path mode1 mode2)) + +(define/who (open-input-output-file path [mode1 none] [mode2 none]) + (do-open-output-file #:plus-input? #t who path mode1 mode2)) + +(define/who (call-with-input-file path proc [mode none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 1) proc) + (define i (open-input-file path mode)) + (begin0 + (proc i) + (close-input-port i))) + +(define/who (call-with-output-file path proc [mode1 none] [mode2 none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 1) proc) + (define o (open-output-file path mode1 mode2)) + (begin0 + (proc o) + (close-output-port o))) + +(define/who (with-input-from-file path proc [mode none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 0) proc) + (define i (open-input-file path mode)) + (parameterize ([current-input-port i]) + (dynamic-wind + void + proc + (lambda () + (close-input-port i))))) + +(define/who (with-output-to-file path proc [mode1 none] [mode2 none]) + (check who path-string? path) + (check who (procedure-arity-includes/c 0) proc) + (define o (open-output-file path mode1 mode2)) + (parameterize ([current-output-port o]) + (dynamic-wind + void + proc + (lambda () + (close-output-port o))))) diff --git a/racket/src/io/port/file-position.rkt b/racket/src/io/port/file-position.rkt new file mode 100644 index 0000000000..488caabcda --- /dev/null +++ b/racket/src/io/port/file-position.rkt @@ -0,0 +1,68 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "check.rkt") + +(provide file-position + file-position* + + do-simple-file-position) + +(define/who file-position + (case-lambda + [(p) + (do-simple-file-position who p + (lambda () + (raise + (exn:fail:filesystem + (string-append + "file-position: the port's current position is not known\n port: " + ((error-value->string-handler) p (error-print-width))) + (current-continuation-marks)))))] + [(p pos) + (unless (or (input-port? p) (output-port? p)) + (raise-argument-error who "port?" p)) + (check who + (lambda (p) (or (exact-nonnegative-integer? p) (eof-object? p))) + #:contract "(or/c exact-nonnegative-integer? eof-object?)" + pos) + (let ([cp (cond + [(input-port? p) (->core-input-port p)] + [else (->core-output-port p)])]) + (define file-position (core-port-file-position cp)) + (cond + [(and (procedure? file-position) (procedure-arity-includes? file-position 1)) + (atomically + (check-not-closed who cp) + (file-position pos))] + [else + (raise-arguments-error who + "setting position allowed for file-stream and string ports only" + "port" p + "position" pos)]))])) + +(define/who (file-position* p) + (do-simple-file-position who p (lambda () #f))) + +(define (do-simple-file-position who orig-p fail-k) + (let ([p (cond + [(input-port? orig-p) (->core-input-port orig-p)] + [(output-port? orig-p) (->core-output-port orig-p)] + [else (raise-argument-error who "port?" orig-p)])]) + (start-atomic) + (check-not-closed who p) + (define file-position (core-port-file-position p)) + (cond + [(or (input-port? file-position) + (output-port? file-position)) + (end-atomic) + (do-simple-file-position who file-position fail-k)] + [else + (define pos (or (and file-position + (file-position)) + (core-port-offset p))) + (end-atomic) + (or pos (fail-k))]))) diff --git a/racket/src/io/port/file-stream.rkt b/racket/src/io/port/file-stream.rkt new file mode 100644 index 0000000000..763797893f --- /dev/null +++ b/racket/src/io/port/file-stream.rkt @@ -0,0 +1,23 @@ +#lang racket/base +(require "port.rkt" + "input-port.rkt" + "output-port.rkt") + +(provide prop:file-stream + file-stream-ref + file-stream-port?) + +;; Property value should be a funciton that returns a file descriptor +(define-values (prop:file-stream file-stream? file-stream-ref) + (make-struct-type-property 'file-stream)) + +(define (file-stream-port? p) + (file-stream? + (core-port-data + (cond + [(input-port? p) (->core-input-port p)] + [(output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'file-stream-port? + "port?" + p)])))) diff --git a/racket/src/io/port/file-truncate.rkt b/racket/src/io/port/file-truncate.rkt new file mode 100644 index 0000000000..521e0d1910 --- /dev/null +++ b/racket/src/io/port/file-truncate.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require "../common/check.rkt" + "port.rkt" + "output-port.rkt" + "file-stream.rkt") + +(provide prop:file-truncate + file-truncate) + +(define-values (prop:file-truncate file-truncate? file-truncate-ref) + (make-struct-type-property 'file-truncate)) + +(define (file-truncate p pos) + (unless (and (output-port? p) + (file-stream-port? p)) + (raise-argument-error 'file-truncate "(and/c output-port? file-stream-port?)" p)) + (check 'file-truncate exact-nonnegative-integer? pos) + (let ([p (->core-output-port p)]) + (define data (core-port-data p)) + ((file-truncate-ref data) data pos))) diff --git a/racket/src/io/port/flush-output.rkt b/racket/src/io/port/flush-output.rkt new file mode 100644 index 0000000000..6cdf1d05dd --- /dev/null +++ b/racket/src/io/port/flush-output.rkt @@ -0,0 +1,33 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "parameter.rkt" + "output-port.rkt" + "pipe.rkt") + +(provide flush-output + maybe-flush-stdout) + +(define/who (flush-output [p (current-output-port)]) + (check who output-port? p) + (let ([p (->core-output-port p)]) + (let loop () + (define r (atomically + ((core-output-port-write-out p) #"" 0 0 #f #f #f))) + (let r-loop ([r r]) + (cond + [(eq? r 0) (void)] + [(not r) (loop)] + [(evt? r) (r-loop (sync r))] + [else (error 'flush-output "weird result")]))))) + +;; ---------------------------------------- + +(define orig-input-port (current-input-port)) +(define orig-output-port (current-output-port)) +(define orig-error-port (current-error-port)) + +(define (maybe-flush-stdout in) + (when (eq? in orig-input-port) + (flush-output orig-output-port) + (flush-output orig-error-port))) diff --git a/racket/src/io/port/handler.rkt b/racket/src/io/port/handler.rkt new file mode 100644 index 0000000000..f82ee99fe0 --- /dev/null +++ b/racket/src/io/port/handler.rkt @@ -0,0 +1,148 @@ +#lang racket/base +(require "../common/check.rkt" + "input-port.rkt" + "output-port.rkt" + "flush-output.rkt" + (submod "../print/main.rkt" internal)) + +(provide port-read-handler + port-write-handler + port-display-handler + port-print-handler + + global-port-print-handler + default-global-port-print-handler + + install-reader! + installed-read-syntax + installed-read-accept-reader + installed-read-accept-lang) + +(define/who port-read-handler + (case-lambda + [(i) + (check who input-port? i) + (let ([i (->core-input-port i)]) + (or (core-input-port-read-handler i) + default-port-read-handler))] + [(i h) + (check who input-port? i) + (check who (lambda (p) + (and (procedure? p) + (procedure-arity-includes? p 1) + (procedure-arity-includes? p 2))) + #:contract "(and/c (procedure-arity-includes/c 1) (procedure-arity-includes/c 2))" + h) + (let ([i (->core-input-port i)]) + (set-core-input-port-read-handler! i h))])) + +(define/who default-port-read-handler + (case-lambda + [(i) + (check who input-port? i) + (maybe-flush-stdout i) + (installed-read i)] + [(i src) + (check who input-port? i) + (maybe-flush-stdout i) + (installed-read-syntax src i)])) + +(define installed-read #f) +(define installed-read-syntax #f) +(define installed-read-accept-reader #f) +(define installed-read-accept-lang #f) + +(define (install-reader! read read-syntax read-accept-reader read-accept-lang) + (set! installed-read read) + (set! installed-read-syntax read-syntax) + (set! installed-read-accept-reader installed-read-accept-reader) + (set! installed-read-accept-lang read-accept-lang)) + +;; ---------------------------------------- + +(define/who port-write-handler + (case-lambda + [(o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (or (core-output-port-write-handler o) + default-port-write-handler))] + [(o h) + (check who output-port? o) + (check who (procedure-arity-includes/c 2) h) + (let ([o (->core-output-port o)]) + (set-core-output-port-write-handler! o (if (eq? h default-port-write-handler) + #f + h)))])) + +(define/who (default-port-write-handler v o) + (check who output-port? o) + (do-write 'write v o)) + +(define/who port-display-handler + (case-lambda + [(o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (or (core-output-port-display-handler o) + default-port-display-handler))] + [(o h) + (check who output-port? o) + (check who (procedure-arity-includes/c 2) h) + (let ([o (->core-output-port o)]) + (set-core-output-port-display-handler! o (if (eq? h default-port-display-handler) + #f + h)))])) + +(define/who (default-port-display-handler v o) + (check who output-port? o) + (do-display 'display v o)) + +(define/who port-print-handler + (case-lambda + [(o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (or (core-output-port-print-handler o) + default-port-print-handler))] + [(o h) + (check who output-port? o) + (check who (procedure-arity-includes/c 2) h) + (let ([o (->core-output-port o)]) + (set-core-output-port-print-handler! o (cond + [(eq? h default-port-print-handler) + #f] + [(procedure-arity-includes? h 3) + h] + [else + (lambda (v o [w #f]) (h v o))])))])) + +(define/who (default-port-print-handler v o [quote-depth 0]) + (check who output-port? o) + (check who (lambda (d) (or (eq? d 0) (eq? d 1))) + #:contract "(or/c 0 1)" + quote-depth) + ((global-port-print-handler) v o quote-depth)) + +(define/who (default-global-port-print-handler v o [quote-depth 0]) + (check who output-port? o) + (check who (lambda (d) (or (eq? d 0) (eq? d 1))) + #:contract "(or/c 0 1)" + quote-depth) + (do-print 'print v o quote-depth)) + +(define/who global-port-print-handler + (make-parameter default-global-port-print-handler + (lambda (p) + (check who + (procedure-arity-includes/c 2) + #:contract (string-append + "(or/c (->* (any/c output-port?) ((or/c 0 1)) any)\n" + " (any/c output-port? . -> . any))") + p) + (if (procedure-arity-includes? p 3) + p + (lambda (v o [quote-depth 0]) (p v o)))))) + +(void (install-do-global-print! global-port-print-handler + default-global-port-print-handler)) diff --git a/racket/src/io/port/input-port.rkt b/racket/src/io/port/input-port.rkt new file mode 100644 index 0000000000..161c64e0fd --- /dev/null +++ b/racket/src/io/port/input-port.rkt @@ -0,0 +1,203 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "evt.rkt") + +(provide prop:input-port + input-port? + ->core-input-port + (struct-out core-input-port) + make-core-input-port) + +(define-values (prop:input-port input-port-via-property? input-port-ref) + (make-struct-type-property 'input-port + (lambda (v sti) + (check 'prop:input-port (lambda (v) (or (exact-nonnegative-integer? v) + (input-port? v))) + #:contract "(or/c input-port? exact-nonnegative-integer?)" + v) + (check-immutable-field 'prop:input-port v sti) + (if (exact-nonnegative-integer? v) + (make-struct-field-accessor (list-ref sti 3) v) + v)) + (list (cons prop:secondary-evt + (lambda (v) port->evt)) + (cons prop:input-port-evt + (lambda (i) + (input-port-evt-ref (->core-input-port i))))))) + +(define (input-port? p) + (or (core-input-port? p) + (input-port-via-property? p))) + +;; This function should not be called in atomic mode, +;; since it can invoke an artitrary function +(define (->core-input-port v) + (cond + [(core-input-port? v) v] + [(input-port? v) + (let ([p (input-port-ref v)]) + (cond + [(struct-accessor-procedure? p) + (->core-input-port (p v))] + [else + (->core-input-port p)]))] + [else + empty-input-port])) + +(struct core-input-port core-port + ( + ;; Various functions below are called in atomic mode. The intent of + ;; atomic mode is to ensure that the completion and return of the + ;; function is atomic with respect to some further activity, such + ;; as position and line counting. Also, a guard against operations + ;; on a closed port precedes most operations. Any of the functions + ;; is free to exit and re-enter atomic mode, but they may take on + ;; the burden of re-checking for a closed port. Leave atomic mode + ;; explicitly before raising an exception. + + prepare-change ; #f or (-> void) + ;; Called in atomic mode + ;; May leave atomic mode temporarily, but on return, + ;; ensures that other atomic operations are ok to + ;; change the port. The main use of `prepare-change` + ;; is to pause and `port-commit-peeked` attempts to + ;; not succeed while a potential change is in + ;; progress, where the commit attempts can resume after + ;; atomic mode is left. The `close` operation + ;; is *not* guarded by a call to `prepare-change`. + + read-byte ; #f or (-> (or/c byte? eof-object? evt?)) + ;; Called in atomic mode. + ;; This shortcut is optional. + ;; Non-blocking byte read, where an event must be + ;; returned if no byte is available. The event's result + ;; is ignored, so it should not consume a byte. + + read-in ; port or (bytes start-k end-k copy? -> (or/c integer? ...)) + ;; Called in atomic mode. + ;; A port value redirects to the port. Otherwise, the function + ;; never blocks, and can assume `(- end-k start-k)` is non-zero. + ;; The `copy?` flag indicates that the given byte string should + ;; not be exposed to untrusted code, and instead of should be + ;; copied if necessary. The return values are the same as + ;; documented for `make-input-port`, except that a pipe result + ;; is not allowed (or, more precisely, it's treated as an event). + + peek-byte ; #f or (-> (or/c byte? eof-object? evt?)) + ;; Called in atomic mode. + ;; This shortcut is optional. + ;; Non-blocking byte read, where an event must be + ;; returned if no byte is available. The event's result + ;; is ignored. + + peek-in ; port or (bytes start-k end-k skip-k progress-evt copy? -> (or/c integer? ...)) + ;; Called in atomic mode. + ;; A port value redirects to the port. Otherwise, the function + ;; never blocks, and it can assume that `(- end-k start-k)` is non-zero. + ;; The `copy?` flag is the same as for `read-in`. The return values + ;; are the same as documented for `make-input-port`. + + byte-ready ; port or ((->) -> (or/c boolean? evt)) + ;; Called in atomic mode. + ;; A port value makes sense when `peek-in` has a port value. + ;; Otherwise, check whether a peek on one byte would succeed + ;; without blocking and return a boolean, or return an event + ;; that effectively does the same. The event's value doesn't + ;; matter, because it will be wrapped to return some original + ;; port. When `byte-ready` is a function, it should call the + ;; given funciton (for its side effect) when work has been + ;; done that might unblock this port or some other port. + + get-progress-evt ; #f or (-> evt?) + ;; *Not* called in atomic mode. + ;; Optional support for progress events, and may be + ;; called on a closed port. + + commit ; (amt-k progress-evt? evt? (bytes? -> any) -> boolean) + ;; Called in atomic mode. + ;; Goes with `get-progress-evt`. The final `evt?` + ;; argument is constrained to a few kinds of events; + ;; see docs for `port-commit-peeked` for more information. + ;; On success, a completion function is called in atomic mode, + ;; but possibly in a different thread, with the committed bytes. + ;; The result is a boolean indicating success or failure. + + [pending-eof? #:mutable] + [read-handler #:mutable]) + #:authentic + #:property prop:input-port-evt (lambda (i) + (cond + [(closed-state-closed? (core-port-closed i)) + always-evt] + [else + (define byte-ready (core-input-port-byte-ready i)) + (cond + [(input-port? byte-ready) + byte-ready] + [else + (poller-evt + (poller + (lambda (self poll-ctx) + (define v (byte-ready (lambda () + (schedule-info-did-work! (poll-ctx-sched-info poll-ctx))))) + (cond + [(evt? v) + (values #f v)] + [(eq? v #t) + (values (list #t) #f)] + [else + (values #f self)]))))])]))) + +(define (make-core-input-port #:name name + #:data [data #f] + #:prepare-change [prepare-change #f] + #:read-byte [read-byte #f] + #:read-in read-in + #:peek-byte [peek-byte #f] + #:peek-in peek-in + #:byte-ready byte-ready + #:close close + #:get-progress-evt [get-progress-evt #f] + #:commit [commit #f] + #:get-location [get-location #f] + #:count-lines! [count-lines! #f] + #:init-offset [init-offset 0] + #:file-position [file-position #f] + #:buffer-mode [buffer-mode #f]) + (core-input-port name + data + + close + count-lines! + get-location + file-position + buffer-mode + + (closed-state #f #f) + init-offset ; offset + #f ; count? + #f ; state + #f ; cr-state + #f ; line + #f ; column + #f ; position + + prepare-change + read-byte + read-in + peek-byte + peek-in + byte-ready + get-progress-evt + commit + #f ; pending-eof? + #f)) ; read-handler + +(define empty-input-port + (make-core-input-port #:name 'empty + #:read-in (lambda (bstr start-k end-k copy?) eof) + #:peek-in (lambda (bstr start-k end-k skip-k copy?) eof) + #:byte-ready (lambda (did-work!) #f) + #:close void)) diff --git a/racket/src/io/port/line-input.rkt b/racket/src/io/port/line-input.rkt new file mode 100644 index 0000000000..ad9105445b --- /dev/null +++ b/racket/src/io/port/line-input.rkt @@ -0,0 +1,69 @@ +#lang racket/base +(require "../common/check.rkt" + "input-port.rkt" + "bytes-input.rkt" + "string-input.rkt" + "parameter.rkt" + "flush-output.rkt") + +(provide read-bytes-line + read-line) + +(define (ok-mode? v) + (memq v '(linefeed return return-linefeed any any-one))) +(define ok-mode-str "(or/c 'linefeed 'return 'return-linefeed 'any 'any-one)") + +(define-syntax-rule (define-read-line read-line + make-string string-length string-set! + string-copy! substring + read-char peek-char + as-char) + (define/who (read-line [in (current-input-port)] [mode 'linefeed]) + (check who input-port? in) + (check who ok-mode? #:contract ok-mode-str mode) + (maybe-flush-stdout in) + (define cr? (memq mode '(return any any-one))) + (define lf? (memq mode '(linefeed any any-one))) + (define crlf? (memq mode '(return-linefeed any))) + (let loop ([str (make-string 32)] [pos 0]) + (define ch (read-char in)) + (define (keep-char) + (if (pos . < . (string-length str)) + (begin + (string-set! str pos ch) + (loop str (add1 pos))) + (let ([new-str (make-string (* (string-length str) 2))]) + (string-copy! new-str 0 str 0) + (string-set! new-str pos ch) + (loop new-str (add1 pos))))) + (cond + [(eof-object? ch) + (if (zero? pos) + eof + (substring str 0 pos))] + [(and (or cr? crlf?) + (eqv? ch (as-char #\return))) + (cond + [(and crlf? + (eqv? (peek-char in) (as-char #\linefeed))) + (read-char in) + (substring str 0 pos)] + [cr? + (substring str 0 pos)] + [else (keep-char)])] + [(and lf? + (eqv? ch (as-char #\newline))) + (substring str 0 pos)] + [else (keep-char)])))) + +(define-read-line read-line + make-string string-length string-set! + string-copy! substring + read-char peek-char + values) + + (define-read-line read-bytes-line + make-bytes bytes-length bytes-set! + bytes-copy! subbytes + read-byte peek-byte + char->integer) diff --git a/racket/src/io/port/main.rkt b/racket/src/io/port/main.rkt new file mode 100644 index 0000000000..a3f9ef36cd --- /dev/null +++ b/racket/src/io/port/main.rkt @@ -0,0 +1,154 @@ +#lang racket/base +(require (only-in "input-port.rkt" + input-port? + prop:input-port) + (only-in "output-port.rkt" + output-port? + prop:output-port) + "bytes-input.rkt" + "string-input.rkt" + "special-input.rkt" + "progress-evt.rkt" + "bytes-output.rkt" + "string-output.rkt" + "special-output.rkt" + "line-input.rkt" + "file-port.rkt" + "file-stream.rkt" + (only-in "fd-port.rkt" + terminal-port?) + "file-identity.rkt" + "file-lock.rkt" + "bytes-port.rkt" + "string-port.rkt" + "custom-input-port.rkt" + "custom-output-port.rkt" + "handler.rkt" + "pipe.rkt" + "close.rkt" + "count.rkt" + "buffer-mode.rkt" + "file-position.rkt" + "file-truncate.rkt" + "flush-output.rkt" + "parameter.rkt" + "ready.rkt") + +(provide read-byte + read-bytes + read-bytes! + read-bytes-avail! + read-bytes-avail!* + read-bytes-avail!/enable-break + + peek-byte + peek-bytes + peek-bytes! + peek-bytes-avail! + peek-bytes-avail!* + peek-bytes-avail!/enable-break + + read-byte-or-special + peek-byte-or-special + read-char-or-special + peek-char-or-special + + port-provides-progress-evts? + progress-evt? + port-progress-evt + port-commit-peeked + + read-char + read-string + read-string! + + peek-char + peek-string + peek-string! + + byte-ready? + char-ready? + + write-byte + write-bytes + write-bytes-avail + write-bytes-avail* + write-bytes-avail/enable-break + write-bytes-avail-evt + write-char + write-string + port-writes-atomic? + + write-special + write-special-avail* + write-special-evt + port-writes-special? + + read-line + read-bytes-line + + make-input-port + make-output-port + + port-read-handler + port-write-handler + port-display-handler + port-print-handler + install-reader! + global-port-print-handler + + prop:input-port + prop:output-port + input-port? + output-port? + + open-input-file + open-output-file + open-input-output-file + call-with-input-file + call-with-output-file + with-input-from-file + with-output-to-file + + file-stream-port? + terminal-port? + + open-input-bytes + open-output-bytes + get-output-bytes + open-input-string + open-output-string + get-output-string + string-port? + + make-pipe + pipe-input-port? + pipe-output-port? + pipe-content-length + + port-closed? + close-input-port + close-output-port + port-closed-evt + + file-stream-buffer-mode + + port-file-identity + port-try-file-lock? + port-file-unlock + + file-position + file-position* + file-truncate + + port-count-lines! + port-counts-lines? + port-next-location + set-port-next-location! + port-count-lines-enabled + + current-input-port + current-output-port + current-error-port + + flush-output) diff --git a/racket/src/io/port/nowhere.rkt b/racket/src/io/port/nowhere.rkt new file mode 100644 index 0000000000..5e13ff2a91 --- /dev/null +++ b/racket/src/io/port/nowhere.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require "output-port.rkt") + +(provide open-output-nowhere) + +(define (open-output-nowhere) + (make-core-output-port #:name 'nowhere + #:evt always-evt + #:write-out (lambda (bstr start-k end-k no-block/buffer? enable-break? copy?) + (- end-k start-k)) + #:close void + #:write-out-special (lambda (any no-block/buffer? enable-break?) + #t))) diff --git a/racket/src/io/port/output-port.rkt b/racket/src/io/port/output-port.rkt new file mode 100644 index 0000000000..e2d0d1406c --- /dev/null +++ b/racket/src/io/port/output-port.rkt @@ -0,0 +1,159 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "evt.rkt") + +(provide prop:output-port + output-port? + ->core-output-port + (struct-out core-output-port) + make-core-output-port) + +(define-values (prop:output-port output-port-via-property? output-port-ref) + (make-struct-type-property 'output-port + (lambda (v sti) + (check 'prop:output-port (lambda (v) (or (exact-nonnegative-integer? v) + (output-port? v))) + #:contract "(or/c output-port? exact-nonnegative-integer?)" + v) + (check-immutable-field 'prop:output-port v sti) + (if (exact-nonnegative-integer? v) + (make-struct-field-accessor (list-ref sti 3) v) + v)) + (list (cons prop:secondary-evt + (lambda (v) port->evt)) + (cons prop:output-port-evt + (lambda (o) + (output-port-evt-ref (->core-output-port o))))))) + +(define (output-port? p) + (or (core-output-port? p) + (output-port-via-property? p))) + +;; This function should not be called in atomic mode, +;; since it can invoke an artitrary function +(define (->core-output-port v) + (cond + [(core-output-port? v) v] + [(output-port? v) + (let ([p (output-port-ref v)]) + (cond + [(struct-accessor-procedure? p) + (->core-output-port (p v))] + [else + (->core-output-port p)]))] + [else + empty-output-port])) + +(struct core-output-port core-port + ( + ;; Various functions below are called in atomic mode; see + ;; `core-input-port` for more information on atomicity. + + evt ; An evt that is ready when writing a byte won't block + + write-out ; (bstr start-k end-k no-block/buffer? enable-break? copy? -> ...) + ;; Called in atomic mode. + ;; Doesn't block if `no-block/buffer?` is true. + ;; Does enable breaks while blocking if `enable-break?` is true. + ;; The `copy?` flag indicates that the given byte string should + ;; not be exposed to untrusted code, and instead of should be + ;; copied if necessary. The return values are the same as + ;; documented for `make-output-port`. + + write-out-special ; (any no-block/buffer? enable-break? -> boolean?) + ;; Called in atomic mode. + + get-write-evt ; (bstr start-k end-k -> evt?) + ;; Called in atomic mode. + ;; The given bstr should not be exposed to untrusted code. + + get-write-special-evt ; (-> evt?) + ;; *Not* called in atomic mode. + + [write-handler #:mutable] + [print-handler #:mutable] + [display-handler #:mutable]) + #:authentic + #:property prop:output-port-evt (lambda (o) + (choice-evt + (list + (poller-evt + (poller + (lambda (self sched-info) + (cond + [(closed-state-closed? (core-port-closed o)) + (values '(#t) #f)] + [else (values #f self)])))) + (core-output-port-evt o))))) + +(struct write-evt (proc) + #:property prop:evt (poller + (lambda (self sched-info) + ((write-evt-proc self) self)))) + +(define (make-core-output-port #:name name + #:data [data #f] + #:evt evt + #:write-out write-out + #:close close + #:write-out-special [write-out-special #f] + #:get-write-evt [get-write-evt #f] + #:count-write-evt-via-write-out [count-write-evt-via-write-out #f] + #:get-write-special-evt [get-write-special-evt #f] + #:get-location [get-location #f] + #:count-lines! [count-lines! #f] + #:file-position [file-position #f] + #:init-offset [init-offset 0] + #:buffer-mode [buffer-mode #f]) + (core-output-port name + data + + close + count-lines! + get-location + file-position + buffer-mode + + (closed-state #f #f) + init-offset ; offset + #f ; count? + #f ; state + #f ; cr-state + #f ; line + #f ; column + #f ; position + + evt + write-out + write-out-special + (or get-write-evt + (and count-write-evt-via-write-out + ;; If `write-out` is always atomic (in no-block, no-buffer mode), + ;; then an event can poll `write-out`: + (lambda (src-bstr src-start src-end) + (write-evt + ;; in atomic mode: + (lambda (self) + (define v (write-out src-bstr src-start src-end #f #f #t)) + (when (exact-integer? v) + (count-write-evt-via-write-out v src-bstr src-start)) + (if (evt? v) + ;; FIXME: should be `(replace-evt v self)` + (values #f self) + (values (list v) #f))))))) + get-write-special-evt + + #f ; write-handler + #f ; display-handler + #f)) ; print-handler + +(define empty-output-port + (make-core-output-port #:name 'empty + #:evt always-evt + #:write-out (lambda (bstr start end no-buffer? enable-break?) + (- end start)) + #:write-out-special (lambda (v no-buffer? enable-break?) + #t) + #:close void)) diff --git a/racket/src/io/port/parameter.rkt b/racket/src/io/port/parameter.rkt new file mode 100644 index 0000000000..00f2ad2d11 --- /dev/null +++ b/racket/src/io/port/parameter.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../host/error.rkt" + "output-port.rkt" + "input-port.rkt" + "fd-port.rkt") + +(provide current-input-port + current-output-port + current-error-port) + +(define current-input-port + (make-parameter (open-input-fd (check-rktio-error + (rktio_std_fd rktio RKTIO_STDIN) + "error initializing stdin") + 'stdin) + (lambda (v) + (unless (input-port? v) + (raise-argument-error 'current-input-port + "input-port?" + v)) + v))) + +(define current-output-port + (make-parameter (open-output-fd (check-rktio-error + (rktio_std_fd rktio RKTIO_STDOUT) + "error initializing stdout") + 'stdout + #:buffer-mode 'infer) + (lambda (v) + (unless (output-port? v) + (raise-argument-error 'current-output-port + "output-port?" + v)) + v))) + +(define current-error-port + (make-parameter (open-output-fd (check-rktio-error + (rktio_std_fd rktio RKTIO_STDERR) + "error initializing stderr") + 'stderr + #:buffer-mode 'none) + (lambda (v) + (unless (output-port? v) + (raise-argument-error 'current-error-port + "output-port?" + v)) + v))) diff --git a/racket/src/io/port/peek-via-read-port.rkt b/racket/src/io/port/peek-via-read-port.rkt new file mode 100644 index 0000000000..8f30480a7b --- /dev/null +++ b/racket/src/io/port/peek-via-read-port.rkt @@ -0,0 +1,193 @@ +#lang racket/base +(require "../host/thread.rkt" + "input-port.rkt" + "output-port.rkt" + "pipe.rkt") + +(provide open-input-peek-via-read) + +(define (open-input-peek-via-read #:name name + #:data [data #f] + #:read-in read-in + #:read-is-atomic? [read-is-atomic? #f] ; => can implement progress evts + #:close close + #:get-location [get-location #f] + #:count-lines! [count-lines! #f] + #:init-offset [init-offset 0] + #:file-position [file-position #f] + #:alt-buffer-mode [alt-buffer-mode #f]) + (define-values (peek-pipe-i peek-pipe-o) (make-pipe)) + (define peeked-eof? #f) + (define buf (make-bytes 4096)) + (define buffer-mode 'block) + + ;; in atomic mode + (define (prepare-change) + ((core-input-port-prepare-change peek-pipe-i))) + + ;; in atomic mode + (define (pull-some-bytes [amt (bytes-length buf)] #:keep-eof? [keep-eof? #t]) + (define v (read-in buf 0 amt #f)) + (cond + [(eof-object? v) + (when keep-eof? + (set! peeked-eof? #t)) + eof] + [(evt? v) v] + [(eqv? v 0) 0] + [else + (let loop ([wrote 0]) + (define just-wrote ((core-output-port-write-out peek-pipe-o) buf wrote v #t #f #f)) + (define next-wrote (+ wrote just-wrote)) + (unless (= v next-wrote) + (loop next-wrote))) + v])) + + (define (retry-pull? v) + (and (integer? v) (not (eqv? v 0)))) + + ;; in atomic mode + (define (do-read-in dest-bstr start end copy?) + (let try-again () + (cond + [(positive? (pipe-content-length peek-pipe-i)) + ((core-input-port-read-in peek-pipe-i) dest-bstr start end copy?)] + [peeked-eof? + (set! peeked-eof? #f) + ;; an EOF doesn't count as progress + eof] + [else + (cond + [(and (< (- end start) (bytes-length buf)) + (eq? 'block buffer-mode)) + (define v (pull-some-bytes)) + (cond + [(or (eqv? v 0) (evt? v)) v] + [else (try-again)])] + [else + (define v (read-in dest-bstr start end copy?)) + (unless (eq? v 0) + (progress!)) + v])]))) + + ;; in atomic mode + (define (read-byte) + (define b ((core-input-port-read-byte peek-pipe-i))) + (cond + [(not (evt? b)) + b] + [peeked-eof? + (set! peeked-eof? #f) + ;; an EOF doesn't count as progress + eof] + [else + (define v (pull-some-bytes #:keep-eof? #f)) + (cond + [(retry-pull? v) (read-byte)] + [else + (progress!) + v])])) + + ;; in atomic mode + (define (do-peek-in dest-bstr start end skip progress-evt copy?) + (let try-again () + (define peeked-amt (if peek-pipe-i + (pipe-content-length peek-pipe-i) + 0)) + (cond + [(and progress-evt + (sync/timeout 0 progress-evt)) + #f] + [(and peek-pipe-i + (peeked-amt . > . skip)) + ((core-input-port-peek-in peek-pipe-i) dest-bstr start end skip progress-evt copy?)] + [peeked-eof? + eof] + [else + (define v (pull-some-bytes)) + (if (retry-pull? v) + (try-again) + v)]))) + + ;; in atomic mode + (define (peek-byte) + (cond + [(positive? (pipe-content-length peek-pipe-i)) + ((core-input-port-peek-byte peek-pipe-i))] + [peeked-eof? + eof] + [else + (define v (pull-some-bytes)) + (if (retry-pull? v) + (peek-byte) + v)])) + + ;; in atomic mode + (define (do-byte-ready work-done!) + (cond + [(positive? (pipe-content-length peek-pipe-i)) + #t] + [peeked-eof? + #t] + [else + (define v (pull-some-bytes)) + (work-done!) + (cond + [(retry-pull? v) + (do-byte-ready void)] + [(evt? v) v] + [else + (not (eqv? v 0))])])) + + ;; in atomic mode + (define (purge-buffer) + (set!-values (peek-pipe-i peek-pipe-o) (make-pipe)) + (set! peeked-eof? #f)) + + ;; in atomic mode + (define (get-progress-evt) + ((core-input-port-get-progress-evt peek-pipe-i))) + + ;; in atomic mode + (define (progress!) + ;; Relies on support for `0 #f #f` arguments in pipe implementation: + ((core-input-port-commit peek-pipe-i) 0 #f #f void)) + + (define (commit amt evt ext-evt finish) + ((core-input-port-commit peek-pipe-i) amt evt ext-evt finish)) + + (define do-buffer-mode + (case-lambda + [() buffer-mode] + [(mode) (set! buffer-mode mode)])) + + (values (make-core-input-port + #:name name + #:data data + + #:prepare-change prepare-change + + #:read-byte read-byte + #:read-in do-read-in + #:peek-byte peek-byte + #:peek-in do-peek-in + #:byte-ready do-byte-ready + + #:get-progress-evt (and read-is-atomic? + get-progress-evt) + #:commit commit + + #:close (lambda () + (close) + (purge-buffer)) + + #:get-location get-location + #:count-lines! count-lines! + #:init-offset init-offset + #:file-position file-position + #:buffer-mode (or alt-buffer-mode do-buffer-mode)) + + ;; in atomic mode: + (case-lambda + [() (purge-buffer)] + [(pos) (- pos (pipe-content-length peek-pipe-i))]))) diff --git a/racket/src/io/port/pipe.rkt b/racket/src/io/port/pipe.rkt new file mode 100644 index 0000000000..7e2538da77 --- /dev/null +++ b/racket/src/io/port/pipe.rkt @@ -0,0 +1,424 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "output-port.rkt" + "count.rkt" + "commit-manager.rkt") + +(provide make-pipe + pipe-input-port? + pipe-output-port? + pipe-content-length + pipe-write-position + pipe-discard-all) + +(define (min+1 a b) (if a (min (add1 a) b) b)) + +(struct pipe-data (get-content-length + write-position + discard-all)) + +(define (pipe-input-port? p) + (and (input-port? p) + (pipe-data? (core-port-data (->core-input-port p))))) + +(define (pipe-output-port? p) + (and (output-port? p) + (pipe-data? (core-port-data (->core-output-port p))))) + +(define (pipe-content-length p) + ((pipe-data-get-content-length + (core-port-data + (cond + [(pipe-input-port? p) (->core-input-port p)] + [(pipe-output-port? p) (->core-output-port p)] + [else + (raise-argument-error 'pipe-contact-length "(or/c pipe-input-port? pipe-output-port?)" p)]))))) + +(define pipe-write-position + (case-lambda + [(p) ((pipe-data-write-position (core-port-data p)))] + [(p pos) ((pipe-data-write-position (core-port-data p)) pos)])) + +(define (pipe-discard-all p) + ((pipe-data-discard-all (core-port-data p)))) + +(define/who (make-pipe [limit #f] [input-name 'pipe] [output-name 'pipe]) + (check who #:or-false exact-positive-integer? limit) + (define bstr (make-bytes (min+1 limit 16))) + (define len (bytes-length bstr)) + (define peeked-amt 0) ; peeked but not yet read effectively extends `limit` + (define start 0) + (define end 0) + (define write-pos #f) ; to adjust the write position via `file-position` on a string port + (define input-closed? #f) + (define output-closed? #f) + + (define (content-length) + (if (start . <= . end) + (- end start) + (+ end (- len start)))) + (define (input-empty?) (= start end)) + (define (output-full?) + (and limit + ((content-length) . >= . (+ limit peeked-amt)))) + + (define data + (pipe-data + ;; get-content-length + (lambda () + (atomically (content-length))) + ;; write-position + (case-lambda + [() (or write-pos end)] + [(pos) + ;; `pos` must be between `start` and `end` + (if (= pos end) + (set! write-pos #f) + (set! write-pos pos))]) + ;; discard-all + (lambda () + (set! peeked-amt 0) + (set! start 0) + (set! end 0) + (set! write-pos #f)))) + + (define read-ready-sema (make-semaphore)) + (define write-ready-sema (and limit (make-semaphore 1))) + (define more-read-ready-sema #f) ; for lookahead peeks + (define read-ready-evt (wrap-evt (semaphore-peek-evt read-ready-sema) + (lambda (v) 0))) + (define write-ready-evt (if limit + (semaphore-peek-evt write-ready-sema) + always-evt)) + (define progress-sema #f) + + ;; Used before/after read: + (define (check-output-unblocking) + (when (output-full?) (semaphore-post write-ready-sema))) + (define (check-input-blocking) + (when (input-empty?) (semaphore-wait read-ready-sema))) + + ;; Used before/after write: + (define (check-input-unblocking) + (when (and (input-empty?) (not output-closed?)) (semaphore-post read-ready-sema)) + (when more-read-ready-sema + (semaphore-post more-read-ready-sema) + (set! more-read-ready-sema #f))) + (define (check-output-blocking) + (when (output-full?) (semaphore-wait write-ready-sema))) + + ;; Used after peeking: + (define (peeked! amt) + (when (amt . > . peeked-amt) + (check-output-unblocking) + (set! peeked-amt amt))) + + (define (progress!) + (when progress-sema + (semaphore-post progress-sema) + (set! progress-sema #f))) + + (define commit-manager #f) + + ;; in atomic mode [can leave atomic mode temporarily] + ;; After this function returns, complete any commit-changing work + ;; before leaving atomic mode again. + (define (pause-waiting-commit) + (when commit-manager + (commit-manager-pause commit-manager))) + + ;; in atomic mode [can leave atomic mode temporarily] + (define (wait-commit progress-evt ext-evt finish) + (cond + [(and (not commit-manager) + ;; Try shortcut: + (not (sync/timeout 0 progress-evt)) + (sync/timeout 0 ext-evt)) + (finish) + #t] + [else + ;; General case to support blocking and potentially multiple + ;; commiting threads: + (unless commit-manager + (set! commit-manager (make-commit-manager))) + (commit-manager-wait commit-manager progress-evt ext-evt finish)])) + + ;; input ---------------------------------------- + (define ip + (make-core-input-port + #:name input-name + #:data data + + #:prepare-change + (lambda () + (pause-waiting-commit)) + + #:read-byte + (lambda () + (cond + [(input-empty?) + (if output-closed? + eof + ;; event's synchronization value is ignored: + read-ready-evt)] + [else + (define pos start) + (check-output-unblocking) + (set! start (add1 pos)) + (set! peeked-amt (max 0 (sub1 peeked-amt))) + (when (= start len) + (set! start 0)) + (check-input-blocking) + (progress!) + (bytes-ref bstr pos)])) + + #:read-in + (lambda (dest-bstr dest-start dest-end copy?) + (cond + [(input-empty?) + (if output-closed? + eof + read-ready-evt)] + [else + (check-output-unblocking) + (begin0 + (cond + [(start . < . end) + (define amt (min (- dest-end dest-start) + (- end start))) + (bytes-copy! dest-bstr dest-start bstr start (+ start amt)) + (set! start (+ start amt)) + (set! peeked-amt (max 0 (- peeked-amt amt))) + amt] + [else + (define amt (min (- dest-end dest-start) + (- len start))) + (bytes-copy! dest-bstr dest-start bstr start (+ start amt)) + (set! start (modulo (+ start amt) len)) + (set! peeked-amt (max 0 (- peeked-amt amt))) + amt]) + (check-input-blocking) + (progress!))])) + + #:peek-byte + (lambda () + (cond + [(input-empty?) + (if output-closed? + eof + read-ready-evt)] + [else + (peeked! 1) + (bytes-ref bstr start)])) + + #:peek-in + (lambda (dest-bstr dest-start dest-end skip progress-evt copy?) + (define content-amt (content-length)) + (cond + [(and progress-evt + (sync/timeout 0 progress-evt)) + #f] + [(content-amt . <= . skip) + (cond + [output-closed? eof] + [else + (unless (or (zero? skip) more-read-ready-sema) + (set! more-read-ready-sema (make-semaphore))) + (define evt (if (zero? skip) + read-ready-evt + (wrap-evt (semaphore-peek-evt more-read-ready-sema) + (lambda (v) 0)))) + evt])] + [else + (define peek-start (modulo (+ start skip) len)) + (cond + [(peek-start . < . end) + (define amt (min (- dest-end dest-start) + (- end peek-start))) + (bytes-copy! dest-bstr dest-start bstr peek-start (+ peek-start amt)) + (peeked! (+ skip amt)) + amt] + [else + (define amt (min (- dest-end dest-start) + (- len peek-start))) + (bytes-copy! dest-bstr dest-start bstr peek-start (+ peek-start amt)) + (peeked! (+ skip amt)) + amt])])) + + #:byte-ready + (lambda (work-done!) + (or output-closed? + (not (zero? (content-length))))) + + #:close + (lambda () + (unless input-closed? + (set! input-closed? #t) + (progress!))) + + #:get-progress-evt + (lambda () + (atomically + (cond + [input-closed? always-evt] + [else + (unless progress-sema + (set! progress-sema (make-semaphore))) + (semaphore-peek-evt progress-sema)]))) + + #:commit + ;; Allows `amt` to be zero and #f for other arguments, + ;; which is helpful for `open-input-peek-via-read`. + (lambda (amt progress-evt ext-evt finish) + ;; `progress-evt` is a `semepahore-peek-evt`, and `ext-evt` + ;; is constrained; we can send them over to different threads + (cond + [(zero? amt) + (progress!)] + [else + (wait-commit + progress-evt ext-evt + ;; in atomic mode, maybe in a different thread: + (lambda () + (let ([amt (min amt (content-length))]) + (cond + [(zero? amt) + ;; There was nothing to commit; claim success for 0 bytes + (finish #"")] + [else + (define dest-bstr (make-bytes amt)) + (cond + [(start . < . end) + (bytes-copy! dest-bstr 0 bstr start (+ start amt))] + [else + (define amt1 (min (- len start) amt)) + (bytes-copy! dest-bstr 0 bstr start (+ start amt1)) + (when (amt1 . < . amt) + (bytes-copy! dest-bstr amt1 bstr 0 (- amt amt1)))]) + (set! start (modulo (+ start amt) len)) + (progress!) + (check-input-blocking) + (finish dest-bstr)]))))])))) + + ;; out ---------------------------------------- + (define op + (make-core-output-port + #:name output-name + #:data data + + #:evt write-ready-evt + + #:write-out + ;; in atomic mode + (lambda (src-bstr src-start src-end nonblock? enable-break? copy?) + (let try-again () + (define top-pos (if (zero? start) + (sub1 len) + len)) + (define (maybe-grow) + (cond + [(or (not limit) + ((+ limit peeked-amt) . > . (sub1 len))) + ;; grow pipe size + (define new-bstr (make-bytes (min+1 (and limit (+ limit peeked-amt)) (* len 2)))) + (cond + [(zero? start) + (bytes-copy! new-bstr 0 bstr 0 (sub1 len))] + [else + (bytes-copy! new-bstr 0 bstr start len) + (bytes-copy! new-bstr (- len start) bstr 0 end) + (set! start 0) + (set! end (sub1 len))]) + (set! bstr new-bstr) + (set! len (bytes-length new-bstr)) + (try-again)] + [else (pipe-is-full)])) + (define (pipe-is-full) + (wrap-evt write-ready-evt (lambda (v) #f))) + (define (apply-limit amt) + (if limit + (min amt (- (+ limit peeked-amt) (content-length))) + amt)) + (cond + [(= src-start src-end) ;; => flush + 0] + [write-pos ; set by `file-position` on a bytes port + (define amt (apply-limit (min (- end write-pos) + (- src-end src-start)))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr write-pos src-bstr src-start (+ src-start amt)) + (let ([new-write-pos (+ write-pos amt)]) + (if (= new-write-pos end) + (set! write-pos #f) ; back to normal mode + (set! write-pos new-write-pos))) + (check-output-blocking) + amt])] + [(and (end . >= . start) + (end . < . top-pos)) + (define amt (apply-limit (min (- top-pos end) + (- src-end src-start)))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr end src-bstr src-start (+ src-start amt)) + (let ([new-end (+ end amt)]) + (set! end (if (= new-end len) 0 new-end))) + (check-output-blocking) + amt])] + [(= end top-pos) + (cond + [(zero? start) + (maybe-grow)] + [else + (define amt (min (sub1 start) + (- src-end src-start))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr 0 src-bstr src-start (+ src-start amt)) + (set! end amt) + (check-output-blocking) + amt])])] + [(end . < . (sub1 start)) + (define amt (apply-limit (min (- (sub1 start) end) + (- src-end src-start)))) + (cond + [(zero? amt) (pipe-is-full)] + [else + (check-input-unblocking) + (bytes-copy! bstr end src-bstr src-start (+ src-start amt)) + (set! end (+ end amt)) + (check-output-blocking) + amt])] + [else + (maybe-grow)]))) + + #:count-write-evt-via-write-out + (lambda (v bstr start) + (port-count! op v bstr start)) + + #:close + ;; in atomic mode + (lambda () + (unless output-closed? + (set! output-closed? #t) + (when write-ready-sema + (semaphore-post write-ready-sema)) + (when more-read-ready-sema + (semaphore-post more-read-ready-sema)) + (semaphore-post read-ready-sema))))) + + ;; Results ---------------------------------------- + (when (port-count-lines-enabled) + (port-count-lines! ip) + (port-count-lines! op)) + + (values ip op)) diff --git a/racket/src/io/port/port.rkt b/racket/src/io/port/port.rkt new file mode 100644 index 0000000000..6756447fe4 --- /dev/null +++ b/racket/src/io/port/port.rkt @@ -0,0 +1,34 @@ +#lang racket/base +(require "../host/thread.rkt" + "evt.rkt") + +(provide (struct-out core-port) + (struct-out closed-state)) + +(struct core-port (name ; anything, reported as `object-name` for the port + data ; anything, effectively a subtype indicator + + close ; -> (void) + ;; Called in atomic mode. + + count-lines! ; #f or procedure called in atomic mode + get-location ; #f or procedure called in atomic mode + file-position ; #f, port, or procedure called in atomic mode + buffer-mode ; #f or procedure in atomic mode + + closed ; `closed-state` + + [offset #:mutable] ; count plain bytes + [count? #:mutable] ; whether line counting is enabled + [state #:mutable] ; state of UTF-8 decoding + [cr-state #:mutable] ; state of CRLF counting as a single LF + [line #:mutable] ; count newlines + [column #:mutable] ; count UTF-8 characters in line + [position #:mutable]) ; count UTF-8 characters + #:authentic + #:property prop:object-name (struct-field-index name) + #:property prop:secondary-evt port->evt) + +(struct closed-state ([closed? #:mutable] + [closed-sema #:mutable]) ; #f or a semaphore posed on close + #:authentic) diff --git a/racket/src/io/port/prepare-change.rkt b/racket/src/io/port/prepare-change.rkt new file mode 100644 index 0000000000..cfe580c9de --- /dev/null +++ b/racket/src/io/port/prepare-change.rkt @@ -0,0 +1,11 @@ +#lang racket/base +(require "input-port.rkt") + +(provide prepare-change) + +;; in atomic mode +;; ... but may leave and return to atomic mode +(define (prepare-change in) + (define prepare-change (core-input-port-prepare-change in)) + (when prepare-change + (prepare-change))) diff --git a/racket/src/io/port/progress-evt.rkt b/racket/src/io/port/progress-evt.rkt new file mode 100644 index 0000000000..9a57aa8de3 --- /dev/null +++ b/racket/src/io/port/progress-evt.rkt @@ -0,0 +1,74 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "parameter.rkt" + "input-port.rkt" + "count.rkt" + "check.rkt") + +(provide (rename-out [progress-evt?* progress-evt?]) + port-provides-progress-evts? + port-progress-evt + port-commit-peeked + + check-progress-evt + unwrap-progress-evt) + +(struct progress-evt (port evt) + #:property prop:evt (lambda (pe) + (wrap-evt (progress-evt-evt pe) + (lambda args pe)))) + +(define progress-evt?* + (let ([progress-evt? + (case-lambda + [(v) (progress-evt? v)] + [(v port) + (and (progress-evt? v) + (eq? port (progress-evt-port v)))])]) + progress-evt?)) + +;; ---------------------------------------- + +(define/who (port-provides-progress-evts? in) + (check who input-port? in) + (let ([in (->core-input-port in)]) + (and (core-input-port-get-progress-evt in) #t))) + +(define/who (port-progress-evt orig-in) + (check who input-port? orig-in) + (let ([in (->core-input-port orig-in)]) + (define get-progress-evt (core-input-port-get-progress-evt in)) + (if get-progress-evt + (progress-evt orig-in (get-progress-evt)) + (raise-arguments-error 'port-progress-evt + "port does not provide progress evts" + "port" orig-in)))) + +(define/who (port-commit-peeked amt progress-evt evt [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who progress-evt? progress-evt) + (check who sync-atomic-poll-evt? + #:contract "(or/c channel-put-evt? channel? semaphore? semaphore-peek-evt? always-evt never-evt)" + evt) + (check who input-port? in) + (check-progress-evt who progress-evt in) + (let ([in (->core-input-port in)]) + (define commit (core-input-port-commit in)) + (atomically + ;; We specially skip a check on whether the port is closed, + ;; since that's handled as the progress evt becoming ready + (commit amt (progress-evt-evt progress-evt) evt + ;; in atomic mode (but maybe leaves atomic mode in between) + (lambda (bstr) + (port-count! in (bytes-length bstr) bstr 0)))))) + +(define (check-progress-evt who progress-evt in) + (unless (progress-evt?* progress-evt in) + (raise-arguments-error who "evt is not a progress evt for the given port" + "evt" progress-evt + "port" in))) + +(define (unwrap-progress-evt progress-evt) + (and progress-evt + (progress-evt-evt progress-evt))) diff --git a/racket/src/io/port/read-and-peek.rkt b/racket/src/io/port/read-and-peek.rkt new file mode 100644 index 0000000000..6e87a709c3 --- /dev/null +++ b/racket/src/io/port/read-and-peek.rkt @@ -0,0 +1,241 @@ +#lang racket/base +(require "../common/internal-error.rkt" + "../host/thread.rkt" + "port.rkt" + "input-port.rkt" + "count.rkt" + "check.rkt" + "prepare-change.rkt") + +(provide read-some-bytes! + peek-some-bytes! + + do-read-byte + read-byte-via-bytes + do-peek-byte + peek-byte-via-bytes) + +;; Read up to `(- end start)` bytes, producing at least a +;; single by unless `zero-ok?` is true. The result is +;; EOF or the number of bytes read. +(define (read-some-bytes! who orig-in bstr start end + ;; Zero is ok for `read-bytes!*`: + #:zero-ok? [zero-ok? #f] + ;; Enable breaks while blocking? + #:enable-break? [enable-break? #f] + ;; When calling an externally implemented + ;; port, we normally make a fresh byte + ;; string, because we don't trust the + ;; reading proc to not retain the byte + ;; string and change it later. We can skip + ;; the copy if the bstr is the right length + ;; and won't be exposed, though. + #:copy-bstr? [copy-bstr? #t] + ;; If `keep-eof?`, don't consume an EOF + #:keep-eof? [keep-eof? #f] + ;; If not `special-ok?` and a special value is + ;; received, raise an exception + #:special-ok? [special-ok? #t] + ;; For a special result, limit the procedure + ;; to 4 unless `read-byte-or-special`, etc., + ;; need access to a 0-argument version + #:limit-special-arity? [limit-special-arity? #t]) + (let loop ([in orig-in] [extra-count-ins null]) + (start-atomic) + (prepare-change in) + (cond + [(= start end) ; intentionally before the port-closed check + (end-atomic) + 0] + [(closed-state-closed? (core-port-closed in)) + (check-not-closed who in)] + ;; previously detected EOF? + [(core-input-port-pending-eof? in) + (unless keep-eof? + (set-core-input-port-pending-eof?! in #f)) + (end-atomic) + eof] + [else + ;; normal mode... + (define read-in (core-input-port-read-in in)) + (cond + [(procedure? read-in) + (define v (read-in bstr start end copy-bstr?)) + (let result-loop ([v v]) + (cond + [(and (integer? v) (not (eq? v 0))) + (port-count-all! in extra-count-ins v bstr start)] + [(procedure? v) + (port-count-byte-all! in extra-count-ins #f)]) + (end-atomic) + (cond + [(exact-nonnegative-integer? v) + (cond + [(zero? v) + (if zero-ok? + 0 + (loop in extra-count-ins))] + [(v . <= . (- end start)) v] + [else + (raise-arguments-error who + "result integer is larger than the supplied byte string" + "result" v + "byte-string length" (- end start))])] + [(eof-object? v) eof] + [(evt? v) + ;; If `zero-ok?`, we should at least poll the event + (define timeout (if zero-ok? (lambda () 0) #f)) + (define next-v (if enable-break? + (sync/timeout/enable-break timeout v) + (sync/timeout timeout v))) + (cond + [(and zero-ok? (evt? next-v)) + ;; Avoid looping on events + 0] + [else + (start-atomic) + (result-loop next-v)])] + [(procedure? v) + (if special-ok? + (if limit-special-arity? + (lambda (a b c d) (v a b c d)) + v) + (raise-arguments-error who + "non-character in an unsupported context" + "port" orig-in))] + [else + (internal-error (format "weird read-bytes result ~s" v))]))] + [else + (end-atomic) + (loop (->core-input-port read-in) (cons in extra-count-ins))])]))) + +;; Like `read-some-bytes!`, but merely peeks +(define (peek-some-bytes! who orig-in bstr start end skip + #:progress-evt [progress-evt #f] + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f] + #:copy-bstr? [copy-bstr? #t] + #:special-ok? [special-ok? #t] + #:limit-special-arity? [limit-special-arity? #t]) + (let loop ([in orig-in]) + (start-atomic) + (prepare-change in) + (cond + [(= start end) + (end-atomic) + 0] + ;; check progress evt before continuing with other possibilities + [(and progress-evt + (sync/timeout 0 progress-evt)) + (end-atomic) + 0] + [(closed-state-closed? (core-port-closed in)) + (check-not-closed who in)] + ;; previously detected EOF? (never skip past it) + [(core-input-port-pending-eof? in) + (end-atomic) + + eof] + [else + (define peek-in (core-input-port-peek-in in)) + (cond + [(procedure? peek-in) + (define v (peek-in bstr start end skip progress-evt copy-bstr?)) + (end-atomic) + (let result-loop ([v v]) + (cond + [(exact-nonnegative-integer? v) + (cond + [(zero? v) + (if zero-ok? + 0 + (loop in))] + [(v . <= . (- end start)) v] + [else + (raise-arguments-error who + "result integer is larger than the supplied byte string" + "result" v + "byte-string length" (- end start))])] + [(eof-object? v) eof] + [(evt? v) + (cond + [zero-ok? 0] + [else (result-loop (if enable-break? + (sync/enable-break v) + (sync v)))])] + [(procedure? v) + (if special-ok? + (if limit-special-arity? + (lambda (a b c d) (v a b c d)) + v) + (raise-arguments-error who + "non-character in an unsupported context" + "port" orig-in))] + [else + (internal-error (format "weird peek-bytes result ~s" v))]))] + [else + (end-atomic) + (loop (->core-input-port peek-in))])]))) + + +;; Use a `read-byte` shortcut +(define (do-read-byte who read-byte in) + (let loop () + (start-atomic) + (prepare-change in) + (cond + [(closed-state-closed? (core-port-closed in)) + (check-not-closed who in)] + [else + (define b (read-byte)) + (cond + [(eof-object? b) + (end-atomic) + b] + [(evt? b) + (end-atomic) + (sync b) + (loop)] + [else + (port-count-byte! in b) + (end-atomic) + b])]))) + +;; Use the general path; may return a procedure for a special +(define (read-byte-via-bytes in #:special-ok? [special-ok? #t]) + (define bstr (make-bytes 1)) + (define v (read-some-bytes! 'read-byte in bstr 0 1 + #:copy-bstr? #f + #:special-ok? special-ok? + #:limit-special-arity? #f)) + (if (eq? v 1) + (bytes-ref bstr 0) + v)) + +;; Use a `peek-byte` shortcut +(define (do-peek-byte who peek-byte in orig-in) + (let loop () + (start-atomic) + (prepare-change in) + (check-not-closed who in) + (define b (peek-byte)) + (end-atomic) + (cond + [(evt? b) + (sync b) + (loop)] + [else b]))) + +;; Use the general path; may return a procedure for a special +(define (peek-byte-via-bytes in skip-k + #:special-ok? [special-ok? #t] + #:progress-evt [progress-evt #f]) + (define bstr (make-bytes 1)) + (define v (peek-some-bytes! 'peek-byte in bstr 0 1 skip-k + #:copy-bstr? #f + #:special-ok? special-ok? + #:limit-special-arity? #f + #:progress-evt progress-evt)) + (if (eq? v 1) + (bytes-ref bstr 0) + v)) diff --git a/racket/src/io/port/ready.rkt b/racket/src/io/port/ready.rkt new file mode 100644 index 0000000000..368a529792 --- /dev/null +++ b/racket/src/io/port/ready.rkt @@ -0,0 +1,57 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "../string/utf-8-decode.rkt" + "port.rkt" + "input-port.rkt" + "bytes-input.rkt" + "check.rkt" + "prepare-change.rkt") + +(provide byte-ready? + char-ready?) + +(define/who (byte-ready? in) + (check who input-port? in) + (let loop ([in (->core-input-port in)]) + (define byte-ready (core-input-port-byte-ready in)) + (cond + [(input-port? byte-ready) (loop (->core-input-port byte-ready))] + [else + (start-atomic) + (prepare-change in) + (check-not-closed who in) + (define r (byte-ready void)) + (end-atomic) + (eq? #t r)]))) + +(define/who (char-ready? in) + (check who input-port? in) + (let ([in (->core-input-port in)]) + (cond + [(byte-ready? in) + (define peek-byte (core-input-port-peek-byte in)) + (define b (and peek-byte (peek-byte))) + (cond + [(and b + (or (eof-object? b) + (b . < . 128))) + ;; Shortcut worked + #t] + [else + (define bstr (make-bytes 1)) + (let loop ([offset 0] [state #f]) + (cond + [(eq? 1 (peek-bytes-avail!* bstr offset #f in)) + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr 0 1 + #f 0 #f + #:error-char #\? + #:abort-mode 'state + #:state state)) + (cond + [(utf-8-state? new-state) + (loop (add1 offset) new-state)] + [else #t])] + [else #f]))])] + [else #f]))) diff --git a/racket/src/io/port/special-input.rkt b/racket/src/io/port/special-input.rkt new file mode 100644 index 0000000000..6af5899cda --- /dev/null +++ b/racket/src/io/port/special-input.rkt @@ -0,0 +1,94 @@ +#lang racket/base +(require "../common/check.rkt" + "input-port.rkt" + "parameter.rkt" + "read-and-peek.rkt" + "string-input.rkt" + "progress-evt.rkt" + "count.rkt") + +(provide read-byte-or-special + peek-byte-or-special + read-char-or-special + peek-char-or-special) + +(define/who (read-byte-or-special [orig-in (current-input-port)] + [special-wrap #f] + [source-name #f]) + (check who input-port? orig-in) + (check who #:or-false (procedure-arity-includes/c 1) special-wrap) + (let ([in (->core-input-port orig-in)]) + (define read-byte (core-input-port-read-byte in)) + (cond + [read-byte (do-read-byte who read-byte in)] + [else + (extract-special-value (read-byte-via-bytes in) + in source-name -1 + special-wrap)]))) + + +(define/who (peek-byte-or-special [orig-in (current-input-port)] + [skip-k 0] + [progress-evt #f] + [special-wrap #f] + [source-name #f]) + (check who input-port? orig-in) + (check who exact-nonnegative-integer? skip-k) + (check who #:or-false evt? progress-evt) + (check who #:or-false (procedure-arity-includes/c 1) special-wrap) + (when progress-evt + (check-progress-evt who progress-evt orig-in)) + (let ([in (->core-input-port orig-in)]) + (define peek-byte (core-input-port-read-byte in)) + (cond + [peek-byte (do-peek-byte who peek-byte in orig-in)] + [else + (extract-special-value (peek-byte-via-bytes in skip-k #:progress-evt progress-evt) + in source-name skip-k + special-wrap)]))) + +;; ---------------------------------------- + +(define/who (read-char-or-special [in (current-input-port)] + [special-wrap #f] + [source-name #f]) + (check who input-port? in) + (check who #:or-false (procedure-arity-includes/c 1) special-wrap) + (extract-special-value (do-read-char who in #:special-ok? #t) + in source-name -1 + special-wrap)) + +(define/who (peek-char-or-special [in (current-input-port)] + [skip-k 0] + [special-wrap #f] + [source-name #f]) + (check who input-port? in) + (check who exact-nonnegative-integer? skip-k) + (check who #:or-false (procedure-arity-includes/c 1) special-wrap) + (extract-special-value (do-peek-char who in skip-k #:special-ok? #t) + in source-name skip-k + special-wrap)) + +;; ---------------------------------------- + +(define (extract-special-value v in source-name delta special-wrap) + (cond + [(procedure? v) + (define special + (cond + [(not source-name) + (cond + [(procedure-arity-includes? v 0) + (v)] + [else + (v #f #f #f #f)])] + [else + (define-values (line col pos) (port-next-location in)) + (v source-name + line + (and col (+ col delta)) + (and pos (+ pos delta)))])) + (if special-wrap + (special-wrap special) + special)] + [else v])) diff --git a/racket/src/io/port/special-output.rkt b/racket/src/io/port/special-output.rkt new file mode 100644 index 0000000000..e414f1ef6f --- /dev/null +++ b/racket/src/io/port/special-output.rkt @@ -0,0 +1,64 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "output-port.rkt" + "parameter.rkt" + "count.rkt") + +(provide write-special + write-special-avail* + write-special-evt + port-writes-special?) + +(define/who (port-writes-special? o) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (and (core-output-port-write-out-special o) #t))) + +(define (do-write-special who v orig-o #:retry? retry?) + (check who output-port? orig-o) + (let port-loop ([o orig-o] [extra-count-os null]) + (let ([o (->core-output-port o)]) + (define write-out-special (core-output-port-write-out-special o)) + (unless write-out-special + (raise-arguments-error who + "port does not support special values" + "port" orig-o)) + (cond + [(output-port? write-out-special) + (port-loop write-out-special (cons o extra-count-os))] + [else + (let loop () + (start-atomic) + (define r (write-out-special v (not retry?) #f)) + (let result-loop ([r r]) + (cond + [(not r) + (end-atomic) + (if retry? + (loop) + #f)] + [(evt? r) + (end-atomic) + (and retry? + (result-loop (sync r)))] + [else + (port-count-all! o extra-count-os 1 #"x" 0) + (end-atomic) + #t])))])))) + +(define/who (write-special v [o (current-output-port)]) + (do-write-special who #:retry? #t v o)) + +(define/who (write-special-avail* v [o (current-output-port)]) + (do-write-special who #:retry? #f v o)) + +(define/who (write-special-evt v [o (current-output-port)]) + (check who output-port? o) + (let ([o (->core-output-port o)]) + (define get-write-special-evt (core-output-port-get-write-special-evt o)) + (unless get-write-special-evt + (raise-arguments-error who + "port does not support special-value events" + "port" o)) + (get-write-special-evt v))) diff --git a/racket/src/io/port/string-input.rkt b/racket/src/io/port/string-input.rkt new file mode 100644 index 0000000000..9a23472b6e --- /dev/null +++ b/racket/src/io/port/string-input.rkt @@ -0,0 +1,362 @@ +#lang racket/base +(require "../common/check.rkt" + "../host/thread.rkt" + "parameter.rkt" + "read-and-peek.rkt" + "port.rkt" + "input-port.rkt" + (submod "bytes-input.rkt" internal) + "../string/utf-8-decode.rkt" + "count.rkt" + "flush-output.rkt" + "check.rkt" + "prepare-change.rkt") + +(provide read-char + read-string + read-string! + + peek-char + peek-string + peek-string! + + do-read-char + do-peek-char) + +;; ---------------------------------------- + +;; Read up to `(- end start)` characters by UTF-8 decoding of bytes, +;; producing at least one character unless `zero-ok?`, but it's +;; possible that fewer that `(- end start)` characters are read. The +;; result is two values: either EOF or the number of read characters, +;; and the number of converted bytes +(define (read-some-chars! who orig-in str start end + #:zero-ok? [zero-ok? #f] + #:extra-bytes-amt [extra-bytes-amt 0] + #:keep-eof? [keep-eof? #f] + #:just-peek? [just-peek? #f] + #:skip [skip-k 0] ; must be 0 if `(not just-peek?)` + #:special-ok? [special-ok? #f]) + (define amt (- end start)) + (define bstr (make-bytes amt)) + ;; We're allowed to read up to `amt` characters, which means at + ;; least `amt` bytes. + (define consumed-v + (cond + [just-peek? 0] + [else + (read-some-bytes! who orig-in bstr 0 amt + #:zero-ok? zero-ok? + #:copy-bstr? #f + #:keep-eof? keep-eof? + #:special-ok? special-ok?)])) + (define v + (cond + [just-peek? + (peek-some-bytes! who orig-in + bstr consumed-v amt skip-k + #:copy-bstr? #f + #:zero-ok? zero-ok?)] + [else consumed-v])) + ;; At this point, `v` is the number of bytes that we have ready, and + ;; the first `consumed-v` of those are read (as opposed to just + ;; peeked) from the port. [Currently, `consumed-v` is either 0 or `v`.] + (cond + [(not (exact-integer? v)) (values v 0)] + [(zero? v) (values 0 0)] + [else + (define-values (used-bytes got-chars state) + (utf-8-decode! bstr 0 v + str start (+ start amt) + #:error-char #\uFFFD + #:abort-mode 'state)) + ;; Includes consumed bytes: + (define actually-used-bytes (- used-bytes + (if (utf-8-state? state) + (utf-8-state-pending-amt state) + 0))) + ;; The `state` result can't be 'continues, because N + ;; bytes will never produce > N chars; it can't be + ;; 'error, because we provide an error character; it + ;; can't be 'aborts, because we request an abort state + (cond + [(or (zero? got-chars) + (actually-used-bytes . < . consumed-v)) + ;; The state must be an abort state. + ;; We need to try harder to get a character; even if + ;; `zero-ok?` is true, we may need to try asking + ;; for more bytes to make any progress for a polling + ;; request + (let loop ([skip-k (+ skip-k (- v consumed-v))] + [total-used-bytes used-bytes] + [state state] + [total-chars got-chars] + [start (+ start got-chars)] + [amt (- amt got-chars)]) + (define v (peek-some-bytes! who orig-in bstr 0 1 skip-k + #:zero-ok? zero-ok? + #:special-ok? special-ok?)) + (cond + [(and (eq? v 0) + (zero? consumed-v)) + ;; `zero-ok?` must be true, and we haven't + ;; consumed any bytes, so give up + (values 0 0)] + [else + ;; Try to convert with the additional byte; v can be + ;; `eof` or a special-value procedure, in which case the + ;; abort mode should be 'error to trigger decodings as + ;; errors + (define-values (used-bytes got-chars new-state) + (if (eq? v 0) + (values 0 0 state) + (utf-8-decode! bstr 0 (if (integer? v) v 0) + str start (+ start amt) + #:error-char #\uFFFD + #:state (and (utf-8-state? state) state) + #:abort-mode (if (integer? v) + 'state + 'error)))) + (cond + [(zero? got-chars) + ;; Try even harder; we shouldn't get here if v was `eof` + ;; or a special-value procedure + (loop (+ skip-k v) (+ total-used-bytes used-bytes) new-state total-chars start amt)] + [else + ;; At this point `used-bytes` by itself can be negative, since + ;; conversion may not have used all the bytes that + ;; we peeked to try to complete a decoding. Those unused bytes + ;; count again `skip-k`. Meanwhile, an error state might + ;; report that some other bytes aren't actually consumed, yet. + ;; Does not include consumed bytes: + (define actually-used-bytes (- (+ total-used-bytes + used-bytes) + (if (utf-8-state? new-state) + (utf-8-state-pending-amt new-state) + 0))) + (cond + [(actually-used-bytes . < . consumed-v) + ;; We need to inspect at least one more byte to + ;; consume the bytes that we have already consumed from + ;; the point + (loop (+ skip-k v) (+ total-used-bytes used-bytes) new-state + (+ total-chars got-chars) (+ start got-chars) (- amt got-chars))] + [else + (unless just-peek? + (let ([discard-bytes (- actually-used-bytes consumed-v)]) + (define finish-bstr (if (discard-bytes . <= . (bytes-length bstr)) + bstr + (make-bytes discard-bytes))) + (do-read-bytes! who orig-in finish-bstr 0 discard-bytes))) + (values (+ total-chars got-chars) + actually-used-bytes)])])]))] + [else + ;; Conversion succeeded for at least 1 character. Since we used + ;; all bytes that we consumed from the port, if more characters are needed, + ;; another call to `read-some-chars!` can deal with it. + (unless (or just-peek? + (= actually-used-bytes consumed-v)) + (do-read-bytes! who orig-in bstr 0 (- actually-used-bytes consumed-v))) + (values got-chars actually-used-bytes)])])) + +;; ---------------------------------------- + +;; Read `(- end start)` chars, stopping early only if an EOF is found +(define (do-read-string! who in str start end + #:just-peek? [just-peek? #f] + #:skip [skip-k 0] + #:special-ok? [special-ok? #f]) + (define amt (- end start)) + (define-values (v used-bytes) (read-some-chars! who in str start end + #:just-peek? just-peek? + #:skip skip-k + #:special-ok? special-ok?)) + (cond + [(not (exact-integer? v)) v] + [(= v amt) v] + [else + (let loop ([got v] [total-used-bytes used-bytes]) + (define-values (v used-bytes) (read-some-chars! who in str (+ start got) end + #:keep-eof? #t + #:just-peek? just-peek? + #:skip (if just-peek? + (+ skip-k total-used-bytes) + 0))) + (cond + [(eof-object? v) + got] + [else + (define new-got (+ got v)) + (cond + [(= new-got amt) amt] + [else (loop new-got (+ total-used-bytes used-bytes))])]))])) + +;; ---------------------------------------- + +;; A shortcut to implement `read-char` in terms of a port-specific +;; `read-byte`: +(define (read-char-via-read-byte who in read-byte #:special-ok? [special-ok? #t]) + (define b + (let loop () + (start-atomic) + (prepare-change in) + (check-not-closed who in) + (define b (read-byte)) + (cond + [(evt? b) + (end-atomic) + (sync b) + (loop)] + [else + (unless (eof-object? b) + (port-count-byte! in b)) + (end-atomic) + b]))) + (cond + [(eof-object? b) b] + [else + (cond + [(b . < . 128) (integer->char b)] + [else + ;; UTF-8 decoding... May need to peek bytes to discover + ;; whether the decoding will work (in which case this wasn't + ;; much of a shortcut) + (define bstr (bytes b)) + (define str (make-string 1)) + (define-values (used-bytes got-chars state) + (utf-8-decode! bstr 0 1 + #f 0 #f + #:abort-mode 'state)) + (cond + [(eq? state 'error) + ;; This happens if the byte is a UTF-8 continuation byte + #\uFFFD] + [else + ;; Need to peek ahead + (let loop ([skip-k 0] [state state]) + (define v (peek-some-bytes! who in bstr 0 1 skip-k #:copy-bstr? #f #:special-ok? special-ok?)) + (cond + [(or (eof-object? v) + (procedure? v)) + ;; Already-consumed byte is an error byte + #\uFFFD] + [else + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr 0 1 + str 0 1 + #:state state + #:error-char #\uFFFD + #:abort-mode 'state)) + (cond + [(= got-chars 1) + (define actually-used-bytes (+ skip-k used-bytes)) + (unless (zero? actually-used-bytes) + (define finish-bstr (if (actually-used-bytes . <= . (bytes-length bstr)) + bstr + (make-bytes actually-used-bytes))) + (do-read-bytes! who in finish-bstr 0 actually-used-bytes)) + (string-ref str 0)] + [else + (loop (add1 skip-k) new-state)])]))])])])) + +;; ---------------------------------------- + +;; If `special-ok?`, can return a special-value procedure +(define (do-read-char who in #:special-ok? [special-ok? #f]) + (check who input-port? in) + (let ([in (->core-input-port in)]) + (define read-byte (core-input-port-read-byte in)) + (cond + [(not read-byte) + (define str (make-string 1)) + (define-values (v used-bytes) (read-some-chars! who in str 0 1 #:special-ok? special-ok?)) + (if (eq? v 1) + (string-ref str 0) + v)] + [else + ;; Byte-level shortcut is available, so try it as a char shortcut + (read-char-via-read-byte who in read-byte #:special-ok? special-ok?)]))) + +(define/who (read-char [in (current-input-port)]) + (check who input-port? in) + (do-read-char who in)) + +(define/who (read-string amt [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-string amt)) + (define v (do-read-string! 'read-string in bstr 0 amt)) + (if (exact-integer? v) + (if (= v amt) + bstr + (substring bstr 0 v)) + v))) + +(define/who (read-string! str [in (current-input-port)] [start-pos 0] [end-pos (and (string? str) + (string-length str))]) + (check who string? str) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (string-length str) str) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-read-string! who in str start-pos end-pos))) + +;; ---------------------------------------- + +(define (do-peek-string! who in str start end skip #:special-ok? [special-ok? #f]) + (do-read-string! who in str start end #:skip skip #:just-peek? #t #:special-ok? special-ok?)) + +(define (do-peek-char who in skip-k #:special-ok? [special-ok? #f]) + (let ([in (->core-input-port in)]) + (define peek-byte (and (zero? skip-k) + (core-input-port-peek-byte in))) + (define b (and peek-byte (peek-byte))) + (cond + [(and b + (or (eof-object? b) + (and (byte? b) + (b . < . 128)))) + ;; Shortcut worked + (if (eof-object? b) b (integer->char b))] + [else + ;; General mode + (define bstr (make-string 1)) + (define v (do-peek-string! who in bstr 0 1 skip-k #:special-ok? special-ok?)) + (if (eq? v 1) + (string-ref bstr 0) + v)]))) + +(define/who (peek-char [in (current-input-port)] [skip-k 0]) + (check who input-port? in) + (check who exact-nonnegative-integer? skip-k) + (do-peek-char who in skip-k #:special-ok? #f)) + +(define/who (peek-string amt skip-k [in (current-input-port)]) + (check who exact-nonnegative-integer? amt) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (define bstr (make-string amt)) + (define v (do-peek-string! who in bstr 0 amt skip-k)) + (if (exact-integer? v) + (if (= v amt) + bstr + (substring bstr 0 v)) + v))) + +(define/who (peek-string! str skip-k [in (current-input-port)] [start-pos 0] [end-pos (and (string? str) + (string-length str))]) + (check who string? str) + (check who exact-nonnegative-integer? skip-k) + (check who input-port? in) + (check who exact-nonnegative-integer? start-pos) + (check who exact-nonnegative-integer? end-pos) + (check-range who start-pos end-pos (string-length str) str) + (maybe-flush-stdout in) + (let ([in (->core-input-port in)]) + (do-peek-string! who str in start-pos end-pos skip-k))) diff --git a/racket/src/io/port/string-output.rkt b/racket/src/io/port/string-output.rkt new file mode 100644 index 0000000000..0e534fb1e5 --- /dev/null +++ b/racket/src/io/port/string-output.rkt @@ -0,0 +1,31 @@ +#lang racket/base +(require "../common/check.rkt" + "parameter.rkt" + "output-port.rkt" + "../string/convert.rkt" + (submod "bytes-output.rkt" internal)) + +(provide write-char + write-string) + +(define/who (write-char ch [out (current-output-port)]) + (check who char? ch) + (check who output-port? out) + (write-string (string ch) out 0 1)) + +(define/who (write-string str [out (current-output-port)] [start 0] [end (and (string? str) + (string-length str))]) + (check who string? str) + (check who output-port? out) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + (let ([out (->core-output-port out)]) + (let loop ([i start]) + (cond + [(= i end) (- i start)] + [else + (define next-i (min end (+ i 4096))) + (define bstr (string->bytes/utf-8 str 0 i next-i)) + (do-write-bytes who out bstr 0 (bytes-length bstr)) + (loop next-i)])))) diff --git a/racket/src/io/port/string-port.rkt b/racket/src/io/port/string-port.rkt new file mode 100644 index 0000000000..9512f94a2e --- /dev/null +++ b/racket/src/io/port/string-port.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(require "../common/check.rkt" + "output-port.rkt" + "bytes-port.rkt" + "../string/convert.rkt") + +(provide open-input-string + open-output-string + get-output-string) + +(define/who (open-input-string str [name 'string]) + (check who string? str) + (open-input-bytes (string->bytes/utf-8 str) name)) + +(define (open-output-string [name 'string]) + (open-output-bytes name)) + +(define/who (get-output-string o) + (check who (lambda (v) (and (output-port? o) (string-port? o))) + #:contract "(and/c output-port? string-port?)" + o) + (bytes->string/utf-8 (get-output-bytes o) #\?)) diff --git a/racket/src/io/port/write.rkt b/racket/src/io/port/write.rkt new file mode 100644 index 0000000000..ac91e8aaf9 --- /dev/null +++ b/racket/src/io/port/write.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require "../common/internal-error.rkt" + "../host/thread.rkt" + "port.rkt" + "output-port.rkt" + "count.rkt" + "check.rkt") + +(provide write-some-bytes) + +(define (write-some-bytes who out bstr start end + #:copy-bstr? [copy-bstr? #t] + #:buffer-ok? [buffer-ok? #f] + #:zero-ok? [zero-ok? #f] + #:enable-break? [enable-break? #f]) + (let try-again ([out out] [extra-count-outs null]) + (start-atomic) + (check-not-closed who out) + (cond + [(= start end) + (end-atomic) + 0] + [else + (define write-out (core-output-port-write-out out)) + (cond + [(procedure? write-out) + (define v (write-out bstr start end (not buffer-ok?) enable-break? copy-bstr?)) + (let result-loop ([v v]) + (cond + [(not v) + (end-atomic) + (if zero-ok? + 0 + (try-again out extra-count-outs))] + [(evt? v) + (end-atomic) + (cond + [zero-ok? 0] + [else + (define new-v (if enable-break? + (sync/enable-break v) + (sync v))) + (start-atomic) + (result-loop new-v)])] + [(exact-positive-integer? v) + (port-count-all! out extra-count-outs v bstr start) + (end-atomic) + v] + [else + (end-atomic) + (internal-error (format "write-some-bytes: weird result ~s for ~s ~s ~s at ~s" v bstr start end out))]))] + [else + (end-atomic) + (try-again (->core-output-port write-out) (cons out extra-count-outs))])]))) diff --git a/racket/src/io/print/bytes.rkt b/racket/src/io/print/bytes.rkt new file mode 100644 index 0000000000..fa7fa7c503 --- /dev/null +++ b/racket/src/io/print/bytes.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(require "../port/string-output.rkt" + "write-with-max.rkt") + +(provide print-bytes) + +(define (print-bytes bstr o max-length) + (let ([max-length (write-bytes/max #"#\"" o max-length)]) + (define len (bytes-length bstr)) + (let loop ([start-i 0] [i 0] [max-length max-length]) + (cond + [(eq? max-length 'full) 'full] + [(or (= i len) + (and max-length ((- i start-i) . > . max-length))) + (let ([max-length (write-bytes/max bstr o max-length start-i i)]) + (write-bytes/max #"\"" o max-length))] + [else + (define b (bytes-ref bstr i)) + (cond + [(and (b . < . 128) + (let ([c (integer->char b)]) + (and (or (char-blank? c) + (char-graphic? c)) + (not (char=? c #\tab)) + (not (char=? c #\")) + (not (char=? c #\\))))) + (loop start-i (add1 i) max-length)] + [else + (let* ([max-length (write-bytes/max bstr o max-length start-i i)]) + (define escaped + (case (and (b . < . 128) (integer->char b)) + [(#\") #"\\\""] + [(#\\) #"\\\\"] + [(#\u7) #"\\a"] + [(#\backspace) #"\\b"] + [(#\u1B) #"\\e"] + [(#\page) #"\\f"] + [(#\newline) #"\\n"] + [(#\return) #"\\r"] + [(#\tab) #"\\t"] + [(#\vtab) #"\\v"] + [else #f])) + (cond + [escaped + (let ([max-length (write-bytes/max escaped o max-length)] + [i (add1 i)]) + (loop i i max-length))] + [else + (let ([i (add1 i)]) + (define next-b (or (and (i . < . len) + (bytes-ref bstr i)) + 0)) + (cond + [(or (b . >= . 64) + (and (>= next-b (char->integer #\0)) + (<= next-b (char->integer #\7)))) + (let* ([max-length (write-bytes/max #"\\" o max-length)] + [max-length (write-bytes/max (digit (arithmetic-shift b -6)) o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 (arithmetic-shift b -3))) o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 b)) o max-length)]) + (loop i i max-length))] + [(b . >= . 8) + (let* ([max-length (write-bytes/max #"\\" o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 (arithmetic-shift b -3))) o max-length)] + [max-length (write-bytes/max (digit (bitwise-and 7 b)) o max-length)]) + (loop i i max-length))] + [else + (let* ([max-length (write-bytes/max #"\\" o max-length)] + [max-length (write-bytes/max (digit b) o max-length)]) + (loop i i max-length))]))]))])])))) + +(define (digit v) + (case v + [(0) #"0"] + [(1) #"1"] + [(2) #"2"] + [(3) #"3"] + [(4) #"4"] + [(5) #"5"] + [(6) #"6"] + [(7) #"7"])) diff --git a/racket/src/io/print/char.rkt b/racket/src/io/print/char.rkt new file mode 100644 index 0000000000..e47f2477e1 --- /dev/null +++ b/racket/src/io/print/char.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require "../port/string-output.rkt" + "../port/bytes-output.rkt" + "write-with-max.rkt") + +(provide print-char) + +(define (print-char c o max-length) + (define esc-str + (case c + [(#\nul) "#\\nul"] + [(#\backspace) "#\\backspace"] + [(#\tab) "#\\tab"] + [(#\page) "#\\page"] + [(#\newline) "#\\newline"] + [(#\return) "#\\return"] + [(#\vtab) "#\\vtab"] + [(#\space) "#\\space"] + [(#\rubout) "#\\rubout"] + [else #f])) + (cond + [esc-str + (write-string/max esc-str o max-length)] + [(char-graphic? c) + (let ([max-length (write-string/max "#\\" o max-length)]) + (write-string/max (string c) o max-length))] + [else + (define n (char->integer c)) + (define (pad n s) + (define len (string-length s)) + (if (len . < . n) + (string-append (make-string (- n len) #\0) s) + s)) + (cond + [(n . <= . #xFFFF) + (let ([max-length (write-string/max "#\\u" o max-length)]) + (write-string/max (pad 4 (number->string n 16)) o max-length))] + [else + (let ([max-length (write-string/max "#\\U" o max-length)]) + (write-string/max (pad 8 (number->string n 16)) o max-length))])])) diff --git a/racket/src/io/print/config.rkt b/racket/src/io/print/config.rkt new file mode 100644 index 0000000000..4b70e65185 --- /dev/null +++ b/racket/src/io/print/config.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +(provide make-print-config + config-get) + +;; Make a container for looking up parameters on-demand: +(define (make-print-config) + (make-hasheq)) + +(define (config-get config param) + (hash-ref config param (lambda () + (define v (param)) + (hash-set! config param v) + v))) + diff --git a/racket/src/io/print/custom-write.rkt b/racket/src/io/print/custom-write.rkt new file mode 100644 index 0000000000..58d794843d --- /dev/null +++ b/racket/src/io/print/custom-write.rkt @@ -0,0 +1,30 @@ +#lang racket/base + +(provide prop:custom-write + custom-write? + custom-write-accessor + + prop:custom-print-quotable + custom-print-quotable? + custom-print-quotable-accessor) + +(define-values (prop:custom-write custom-write? custom-write-accessor) + (make-struct-type-property 'custom-write + (lambda (v info) + (unless (and (procedure? v) + (procedure-arity-includes? v 3)) + (raise-argument-error + 'guard-for-prop:custom-write + "(procedure-arity-includes?/c 3)" + v)) + v))) + +(define-values (prop:custom-print-quotable custom-print-quotable? custom-print-quotable-accessor) + (make-struct-type-property 'custom-print-quotable + (lambda (v info) + (unless (or (eq? v 'self) (eq? v 'never) (eq? v 'maybe) (eq? v 'always)) + (raise-argument-error + 'guard-for-prop:custom-print-quotable + "(or/c 'self 'never 'maybe 'always)" + v)) + v))) diff --git a/racket/src/io/print/graph.rkt b/racket/src/io/print/graph.rkt new file mode 100644 index 0000000000..56ddec3316 --- /dev/null +++ b/racket/src/io/print/graph.rkt @@ -0,0 +1,211 @@ +#lang racket/base +(require "../port/nowhere.rkt" + "../port/output-port.rkt" + "parameter.rkt" + "custom-write.rkt" + "mode.rkt" + "config.rkt" + "recur-handler.rkt") + +(provide detect-graph + (struct-out as-constructor)) + +(define (detect-graph v mode config) + (define print-graph? (print-graph)) + (cond + [(quick-no-graph? v 100 mode print-graph? config) #f] + [else + (define ht (make-hasheq)) + (build-graph v ht print-graph? mode config)])) + +;; ---------------------------------------- + +;; Returns a true value if `v` can print without graph annotations and +;; without a constructor form (as opposed to quoted form) in `print` +;; mode +(define (quick-no-graph? v fuel mode print-graph? config) + (let quick-no-graph? ([v v] [fuel fuel]) + (cond + [(or (not fuel) (zero? fuel)) #f] + [(pair? v) + (and (not print-graph?) + (quick-no-graph? (cdr v) (quick-no-graph? (car v) (sub1 fuel))))] + [(vector? v) + (and (not print-graph?) + (for/fold ([fuel (sub1 fuel)]) ([e (in-vector v)] + #:break (not fuel)) + (quick-no-graph? e fuel)))] + [(and (box? v) + (config-get config print-box)) + (and (not print-graph?) + (quick-no-graph? (unbox v) (sub1 fuel)))] + [(and (hash? v) + (not (hash-weak? v)) + (config-get config print-hash-table)) + (and (not print-graph?) + (for/fold ([fuel (sub1 fuel)]) ([(k v) (in-hash v)] + #:break (not fuel)) + (quick-no-graph? v (quick-no-graph? k fuel))))] + [(mpair? v) + (and (not print-graph?) + (not (eq? mode PRINT-MODE/UNQUOTED)) + (quick-no-graph? (mcdr v) (quick-no-graph? (mcar v) (sub1 fuel))))] + [(custom-write? v) + #f] + [(and (struct? v) + (config-get config print-struct)) + (and (not print-graph?) + (or (not (eq? mode PRINT-MODE/UNQUOTED)) + (prefab-struct-key v)) ; can quote a prefab in `print` mode + (quick-no-graph? (struct->vector v) (sub1 fuel)))] + [else fuel]))) + +;; ---------------------------------------- + +(struct as-constructor (tag)) ; `tag` is #f or a number for graph printing + +;; Create a hash table that maps some values to a number, +;; which indicates that that the value should be printed with +;; a `#=` prefix and referenced with `##` thereafter. +;; The hash table records the to be used as a number, +;; and the printer mutates the table to turn that into `#=` +;; after the first reference. +;; +;; In addition, the table indicates whether an item needs +;; to be printed in constructor form, as opposed to quoted +;; form. Printing in constructor form is indicated by +;; mapping to a wrapped `as-constructor` wapper on an integer +;; or `#f`. +;; +;; During `build-graph`, the table maps a value to one of +;; - 'checking: currently checking, so finding again +;; implies a cycle +;; - 'checked: finished checking, but might be referenced +;; again, which is relevant if graph printing is one of +;; we go into graph-printing mode +;; - number: graph-rereference detected, and assigned +;; the number via `counter` +;; - (as-constructor #f): like 'checked, but should be printed in +;; constructor mode, as opposed to quoted +;; - (as-constructor number): graph-rereference detected, and +;; initial reference print in construcor mode +;; If no cycle is detected and `(print-graph)` is false, then +;; values other than `as-constructor` are removed. All +;; 'checked entries will be cleared out before the hash table +;; is returned. +(define (build-graph v ht print-graph? mode config) + (define counter 0) + (define cycle? #f) + (define constructor? #f) + (define checking-port #f) + (define (checking! v) + (hash-set! ht v 'checking)) + (define (done! v unquoted?) + (when (eq? 'checking (hash-ref ht v #f)) + (hash-set! ht v 'checked)) + (when unquoted? + (define c (hash-ref ht v #f)) + (hash-set! ht v (as-constructor (and (integer? c) c))) + (set! constructor? #t)) + unquoted?) + ;; Returns #t if `v` needs to be unquoted + (let build-graph ([v v] [mode mode]) + (cond + [(not v) #f] + [(hash-ref ht v #f) + => (lambda (g) + (when (or (eq? g 'checking) + (eq? g 'checked) + (and (as-constructor? g) + (not (as-constructor-tag g)))) + (hash-set! ht v (if (as-constructor? g) + (as-constructor counter) + counter)) + (set! counter (add1 counter)) + (when (eq? g 'checking) + (set! cycle? #t))) + #f)] + [(pair? v) + (checking! v) + (define car-unquoted? (build-graph (car v) mode)) + (define unquoted? + (or (build-graph (cdr v) mode) + car-unquoted?)) + (done! v unquoted?)] + [(vector? v) + (checking! v) + (define unquoted? + (for/fold ([unquoted? #f]) ([e (in-vector v)]) + (or (build-graph e mode) + unquoted?))) + (done! v unquoted?)] + [(and (box? v) + (config-get config print-box)) + (checking! v) + (define unquoted? (build-graph (unbox v) mode)) + (done! v unquoted?)] + [(and (hash? v) + (not (hash-weak? v)) + (config-get config print-hash-table)) + (checking! v) + (define unquoted? + (for/fold ([unquoted? #f]) ([(k v) (in-hash v)]) + (define k-unquoted? (build-graph k mode)) + (or (build-graph v mode) + k-unquoted? + unquoted?))) + (done! v unquoted?)] + [(mpair? v) + (checking! v) + (build-graph (mcar v) mode) + (build-graph (mcdr v) mode) + (done! v (eq? mode PRINT-MODE/UNQUOTED))] + [(custom-write? v) + (define print-quotable (if (eq? mode PRINT-MODE/UNQUOTED) + (custom-print-quotable-accessor v 'self) + 'self)) + (define unquoted? (eq? print-quotable 'never)) + (unless checking-port + (set! checking-port (open-output-nowhere)) + (set-port-handlers-to-recur! + checking-port + (lambda (e p mode) + (cond + [(or (eq? mode PRINT-MODE/QUOTED) + (eq? mode PRINT-MODE/UNQUOTED)) + (define e-unquoted? (build-graph e mode)) + (unless (eq? print-quotable 'always) + (set! unquoted? (or e-unquoted? unquoted?)))] + [else (build-graph e mode)])))) + (checking! v) + ((custom-write-accessor v) v checking-port mode) + (done! v unquoted?)] + [(struct? v) + (checking! v) + (define unquoted? + (or (for/fold ([unquoted? #f]) ([e (in-vector (struct->vector v))]) + (or (build-graph e mode) + unquoted?)) + (and (eq? mode PRINT-MODE/UNQUOTED) + (not (prefab-struct-key v))))) + (done! v unquoted?)] + [else #f])) + ;; Clean out unwanted entries + (cond + [(and (not cycle?) (not constructor?) (not print-graph?)) + ;; No table needed after all + #f] + [(and (not cycle?) (not print-graph?)) + (for ([k (in-list (hash-keys ht))]) + (define v (hash-ref ht k)) + (cond + [(not (as-constructor? v)) + (hash-remove! ht k)] + [(as-constructor-tag v) + (hash-set! ht k (as-constructor #f))])) + ht] + [else + (for ([k (in-list (hash-keys ht))]) + (when (eq? 'checked (hash-ref ht k)) + (hash-remove! ht k))) + ht])) diff --git a/racket/src/io/print/hash.rkt b/racket/src/io/print/hash.rkt new file mode 100644 index 0000000000..f877d13bb5 --- /dev/null +++ b/racket/src/io/print/hash.rkt @@ -0,0 +1,57 @@ +#lang racket/base +(require "../port/string-output.rkt" + "write-with-max.rkt") + +(provide print-hash) + +(define (print-hash v o max-length p who mode graph config) + (define tag (cond + [(hash-eq? v) "#hasheq("] + [(hash-eqv? v) "#hasheqv("] + [else "#hash("])) + (define keys (try-sort (hash-keys v))) + (let loop ([keys keys] [max-length (write-string/max tag o max-length)] [first? #t]) + (cond + [(eq? max-length 'full) 'full] + [(null? keys) + (write-string/max ")" o max-length)] + [else + (define key (car keys)) + (define val (hash-ref v key none)) + (cond + [(eq? val none) + ;; hash table changed, or maybe an impersonator does strange things to the table + (loop (cdr keys) max-length first?)] + [else + (let* ([max-length (write-string/max (if first? "(" " (") o max-length)] + [max-length (p who key mode o max-length graph config)] + [max-length (write-string/max " . " o max-length)] + [max-length (p who val mode o max-length graph config)]) + (loop (cdr keys) (write-string/max ")" o max-length) #f))])]))) + +(define none (gensym 'none)) + +(define (try-sort keys) + (cond + [(null? keys) null] + [(real? (car keys)) + (if (andmap real? (cdr keys)) + (sort keys <) + keys)] + [(symbol? (car keys)) + (if (andmap symbol? (cdr keys)) + (sort keys symbolcore-output-port o)]) + (define display-handler (core-output-port-display-handler co)) + (if display-handler + (display-handler v o) + (do-display who v co)) + (void))) + +(define (do-display who v o [max-length #f]) + (define config (make-print-config)) + (dots (p who v DISPLAY-MODE o (sub3 max-length) (detect-graph v DISPLAY-MODE config) config) o) + (void)) + +(define/who (write v [o (current-output-port)]) + (check who output-port? o) + (let ([co (->core-output-port o)]) + (define write-handler (core-output-port-write-handler co)) + (if write-handler + (write-handler v o) + (do-write who v co)) + (void))) + +(define (do-write who v o [max-length #f]) + (define config (make-print-config)) + (dots (p who v WRITE-MODE o (sub3 max-length) (detect-graph v WRITE-MODE config) config) o) + (void)) + +(define/who (print v [o (current-output-port)] [quote-depth PRINT-MODE/UNQUOTED]) + (check who output-port? o) + (check who print-mode? #:contract "(or/c 0 1)" quote-depth) + (let ([co (->core-output-port o)]) + (define print-handler (core-output-port-print-handler co)) + (if print-handler + (print-handler v o quote-depth) + (do-global-print who v co quote-depth)) + (void))) + +(define (do-print who v o [quote-depth PRINT-MODE/UNQUOTED] [max-length #f]) + (define config (make-print-config)) + (dots (p who v quote-depth o (sub3 max-length) (detect-graph v quote-depth config) config) o) + (void)) + +(define do-global-print void) + +(define (install-do-global-print! param default-value) + (set! do-global-print + (lambda (who v o [quote-depth PRINT-MODE/UNQUOTED] [max-length #f]) + (define global-print (param)) + (cond + [(eq? global-print default-value) + (do-print who v o quote-depth max-length)] + [(not max-length) + (global-print v o quote-depth)] + [else + ;; There's currently no way to communicate `max-length` + ;; to the `global-print` function, but we should only get + ;; here when `o` is a string port for errors, so write to + ;; a fresh string port and truncate as needed. + (define o2 (open-output-bytes)) + (global-print v o2 quote-depth) + (define bstr (get-output-bytes o2)) + (if ((bytes-length bstr) . <= . max-length) + (write-bytes bstr o) + (begin + (write-bytes (subbytes bstr 0 (sub3 max-length)) o) + (write-bytes #"..." o)))]) + (void)))) + +(define/who (newline [o (current-output-port)]) + (check who output-port? o) + (write-bytes #"\n" o) + (void)) + +;; ---------------------------------------- + +(define (max-length? v) + (or (not v) + (and (exact-nonnegative-integer? v) + (v . >= . 3)))) + +(define max-length-contract "(or/c #f (and/c exact-integer? (>=/c 3)))") + +(define (sub3 n) (and n (- n 3))) + +(define (dots max-length o) + (when (eq? max-length 'full) + (write-string "..." o))) + +;; ---------------------------------------- + +;; Returns the max length that is still available +(define (p who v mode o max-length graph config) + (cond + [(and graph (hash-ref graph v #f)) + => (lambda (g) + (cond + [(and (as-constructor? g) + (not (as-constructor-tag g))) + (p/no-graph-no-quote who v mode o max-length graph config)] + [(string? g) + (let* ([max-length (write-string/max "#" o max-length)] + [max-length (write-string/max g o max-length)]) + (write-string/max "#" o max-length))] + [else + (let* ([gs (number->string (if (as-constructor? g) + (as-constructor-tag g) + g))] + [max-length (write-string/max "#" o max-length)] + [max-length (write-string/max gs o max-length)] + [max-length (write-string/max "=" o max-length)]) + (hash-set! graph v gs) + (p/no-graph who v mode o max-length graph config))]))] + [else + (p/no-graph who v mode o max-length graph config)])) + +(define (p/no-graph who v mode o max-length graph config) + (cond + [(and (eq? mode PRINT-MODE/UNQUOTED) + (or (null? v) + (symbol? v) + (keyword? v) + (pair? v) + (vector? v) + (box? v) + (hash? v) + (prefab-struct-key v))) + ;; Since this value is not marked for constructor mode, + ;; transition to quote mode: + (let ([max-length (write-string/max "'" o max-length)]) + (p/no-graph-no-quote who v PRINT-MODE/QUOTED o max-length graph config))] + [else + (p/no-graph-no-quote who v mode o max-length graph config)])) + +(define (p/no-graph-no-quote who v mode o max-length graph config) + (cond + [(eq? max-length 'full) 'full] + [(null? v) + (write-string/max "()" o max-length)] + [(number? v) + (write-string/max (number->string v) o max-length)] + [(string? v) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max v o max-length)] + [else (print-string v o max-length)])] + [(bytes? v) + (cond + [(eq? mode DISPLAY-MODE) (write-bytes/max v o max-length)] + [else (print-bytes v o max-length)])] + [(symbol? v) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max (symbol->string v) o max-length)] + [else (print-symbol v o max-length config)])] + [(keyword? v) + (let ([max-length (write-string/max "#:" o max-length)]) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max (keyword->string v) o max-length)] + [else + (print-symbol (string->symbol (keyword->string v)) o max-length config + #:for-keyword? #t)]))] + [(char? v) + (cond + [(eq? mode DISPLAY-MODE) (write-string/max (string v) o max-length)] + [else (print-char v o max-length)])] + [(not v) + (write-string/max "#f" o max-length)] + [(eq? v #t) + (write-string/max "#t" o max-length)] + [(pair? v) + (print-list p who v mode o max-length graph config #f #f)] + [(vector? v) + (print-list p who (vector->list v) mode o max-length graph config "#(" "(vector")] + [(flvector? v) + (define l (for/list ([e (in-flvector v)]) e)) + (print-list p who l mode o max-length graph config "#fl(" "(flvector")] + [(fxvector? v) + (define l (for/list ([e (in-fxvector v)]) e)) + (print-list p who l mode o max-length graph config "#fx(" "(fxvector")] + [(box? v) + (if (config-get config print-box) + (p who (unbox v) mode o (write-string/max "#&" o max-length) graph config) + (write-string/max "#" o max-length))] + [(hash? v) + (if (and (config-get config print-hash-table) + (not (hash-weak? v))) + (print-hash v o max-length p who mode graph config) + (write-string/max "#" o max-length))] + [(mpair? v) + (print-mlist p who v mode o max-length graph config)] + [(custom-write? v) + (let ([o (make-output-port/max o max-length)]) + (set-port-handlers-to-recur! + o + (lambda (v o mode) + (p who v mode o (output-port/max-max-length o max-length) graph config))) + ((custom-write-accessor v) v o mode) + (output-port/max-max-length o max-length))] + [(struct? v) + (cond + [(eq? mode PRINT-MODE/UNQUOTED) + (define l (vector->list (struct->vector v))) + (define alt-list-constructor + ;; strip "struct:" from the first element of `l`: + (string-append "(" (substring (symbol->string (car l)) 7))) + (print-list p who (cdr l) mode o max-length graph config #f alt-list-constructor)] + [(prefab-struct-key v) + => (lambda (key) + (define l (cons key (cdr (vector->list (struct->vector v))))) + (print-list p who l mode o max-length graph config "#s(" #f))] + [else + (p who (struct->vector v) mode o max-length graph config)])] + [(procedure? v) + (print-named "procedure" v mode o max-length)] + [(struct-type? v) + (print-named "struct-type" v mode o max-length)] + [(struct-type-property? v) + (print-named "struct-type-property" v mode o max-length)] + [(eof-object? v) + (write-string/max "#" o max-length)] + [(core-input-port? v) + (print-named "input-port" v mode o max-length)] + [(core-output-port? v) + (print-named "output-port" v mode o max-length)] + [else + ;; As a last resort, fall back to the host `format`: + (write-string/max (format "~s" v) o max-length)])) diff --git a/racket/src/io/print/mlist.rkt b/racket/src/io/print/mlist.rkt new file mode 100644 index 0000000000..af22272475 --- /dev/null +++ b/racket/src/io/print/mlist.rkt @@ -0,0 +1,31 @@ +#lang racket/base +(require "write-with-max.rkt" + "mode.rkt") + +(provide print-mlist) + +(define (print-mlist p who v mode o max-length graph config) + (define unquoted? (eq? mode PRINT-MODE/UNQUOTED)) + (let ([max-length + (cond + [unquoted? (write-string/max "(mcons " o max-length)] + [else (write-string/max "{" o max-length)])]) + (let loop ([v v] [max-length max-length]) + (cond + [(eq? max-length 'full) 'full] + [(and (null? (mcdr v)) + (not unquoted?)) + (let ([max-length (p who (mcar v) mode o max-length graph config)]) + (write-string/max "}" o max-length))] + [(and (mpair? (mcdr v)) + (or (not graph) (not (hash-ref graph (mcdr v) #f))) + (not unquoted?)) + (let ([max-length (p who (mcar v) mode o max-length graph config)]) + (loop (mcdr v) (write-string/max " " o max-length)))] + [else + (let* ([max-length (p who (mcar v) mode o max-length graph config)] + [max-length (if unquoted? + (write-string/max " " o max-length) + (write-string/max " . " o max-length))] + [max-length (p who (mcdr v) mode o max-length graph config)]) + (write-string/max (if unquoted? ")" "}") o max-length))])))) diff --git a/racket/src/io/print/mode.rkt b/racket/src/io/print/mode.rkt new file mode 100644 index 0000000000..f92d00c1af --- /dev/null +++ b/racket/src/io/print/mode.rkt @@ -0,0 +1,18 @@ +#lang racket/base + +(provide DISPLAY-MODE + WRITE-MODE + PRINT-MODE/UNQUOTED + PRINT-MODE/QUOTED + + print-mode?) + +;; These are fixed by the `prop:custom-write` and `print` APIs: +(define DISPLAY-MODE #f) +(define WRITE-MODE #t) +(define PRINT-MODE/UNQUOTED 0) +(define PRINT-MODE/QUOTED 1) + +(define (print-mode? mode) + (or (eq? mode PRINT-MODE/UNQUOTED) + (eq? mode PRINT-MODE/QUOTED))) diff --git a/racket/src/io/print/named.rkt b/racket/src/io/print/named.rkt new file mode 100644 index 0000000000..803734d14e --- /dev/null +++ b/racket/src/io/print/named.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require "../port/string-output.rkt" + (only-in "../path/path.rkt" path?) + (only-in "../path/string.rkt" path->string) + "write-with-max.rkt" + "symbol.rkt") + +(provide print-named) + +(define (print-named what v mode o max-length) + (define name (object-name v)) + (let* ([max-length (write-string/max "#<" o max-length)] + [max-length (write-string/max what o max-length)] + [name-str + (cond + [(symbol? name) + (symbol->print-string name #:for-type? #t)] + [(path? name) ; especially for input & output ports + (path->string name)] + [else #f])]) + (cond + [name-str + (let* ([max-length (write-string/max ":" o max-length)] + [max-length (write-string/max name-str o max-length)]) + (write-string/max ">" o max-length))] + [else + (write-string/max ">" o max-length)]))) diff --git a/racket/src/io/print/parameter.rkt b/racket/src/io/print/parameter.rkt new file mode 100644 index 0000000000..d2d46f4172 --- /dev/null +++ b/racket/src/io/print/parameter.rkt @@ -0,0 +1,61 @@ +#lang racket/base +(require "../common/check.rkt" + "../path/path.rkt" + "../path/relativity.rkt") + +(provide current-write-relative-directory + print-syntax-width) + +(define-syntax-rule (define-boolean-parameter print-x init-val) + (begin + (provide print-x) + (define print-x (make-parameter init-val (lambda (v) (and v #t)))))) + +(define-boolean-parameter print-graph #f) +(define-boolean-parameter print-struct #t) +(define-boolean-parameter print-box #t) +(define-boolean-parameter print-unreadable #t) +(define-boolean-parameter print-hash-table #t) +(define-boolean-parameter print-as-expression #f) +(define-boolean-parameter print-vector-length #f) +(define-boolean-parameter print-pair-curly-braces #f) +(define-boolean-parameter print-mpair-curly-braces #t) +(define-boolean-parameter print-boolean-long-form #f) +(define-boolean-parameter print-reader-abbreviations #t) + +(define-boolean-parameter read-accept-bar-quote #t) +(define-boolean-parameter read-case-sensitive #t) + +(define/who current-write-relative-directory + (make-parameter #f (lambda (v) + (check who (lambda (v) + (or (not v) + (and (path-string? v) + (complete-path? v)) + (and (pair? v) + (path-string? (car v)) + (complete-path? (car v)) + (path-string? (cdr v)) + (complete-path? (cdr v))))) + #:contract (string-append + "(or/c (and/c path-string? complete-path?)\n" + " (cons/c (and/c path-string? complete-path?)\n" + " (and/c path-string? complete-path?))" + " #f)") + v) + (cond + [(string? v) (->path v)] + [(pair? v) (cons (->path (car v)) (->path (cdr v)))] + [else v])))) + +(define print-syntax-width + (make-parameter 32 (lambda (v) + (unless (or (eqv? v +inf.0) + (and (exact-integer? v) + (v . >= . 3))) + (raise-argument-error 'print-syntax-width + "(or/c +inf.0 0 (and/c exact-integer? (>/c 3)))" + v)) + v))) + + diff --git a/racket/src/io/print/recur-handler.rkt b/racket/src/io/print/recur-handler.rkt new file mode 100644 index 0000000000..46e7a887ea --- /dev/null +++ b/racket/src/io/print/recur-handler.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require "../port/output-port.rkt" + "mode.rkt") + +(provide set-port-handlers-to-recur!) + +(define (set-port-handlers-to-recur! port handle) + (set-core-output-port-print-handler! port + (lambda (e p [mode 0]) + (handle e p mode))) + (set-core-output-port-write-handler! port + (lambda (e p) + (handle e p WRITE-MODE))) + (set-core-output-port-display-handler! port + (lambda (e p) + (handle e p DISPLAY-MODE)))) diff --git a/racket/src/io/print/string.rkt b/racket/src/io/print/string.rkt new file mode 100644 index 0000000000..c69eedb2d5 --- /dev/null +++ b/racket/src/io/print/string.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require "../port/string-output.rkt" + "write-with-max.rkt") + +(provide print-string) + +(define (print-string str o max-length) + (let ([max-length (write-bytes/max #"\"" o max-length)]) + (define len (string-length str)) + (let loop ([start-i 0] [i 0] [max-length max-length]) + (cond + [(eq? max-length 'full) 'full] + [(or (= i len) + (and max-length ((- i start-i) . > . max-length))) + (let ([max-length (write-string/max str o max-length start-i i)]) + (write-bytes/max #"\"" o max-length))] + [else + (define c (string-ref str i)) + (define escaped + (case c + [(#\") #"\\\""] + [(#\\) #"\\\\"] + [(#\u7) #"\\a"] + [(#\backspace) #"\\b"] + [(#\u1B) #"\\e"] + [(#\page) #"\\f"] + [(#\newline) #"\\n"] + [(#\return) #"\\r"] + [(#\tab) #"\\t"] + [(#\vtab) #"\\v"] + [else #f])) + (cond + [escaped + (let* ([max-length (write-string/max str o max-length start-i i)] + [max-length (write-bytes/max escaped o max-length)] + [i (add1 i)]) + (loop i i max-length))] + [(or (char-graphic? c) + (char-blank? c)) + (loop start-i (add1 i) max-length)] + [else + (define n (char->integer c)) + (define (pad n s) + (define len (string-length s)) + (if (len . < . n) + (string-append (make-string (- n len) #\0) s) + s)) + (let* ([max-length (write-string/max str o max-length start-i i)] + [max-length + (cond + [(n . <= . #xFFFF) + (let ([max-length (write-bytes/max #"\\u" o max-length)]) + (write-string/max (pad 4 (number->string n 16)) o max-length))] + [else + (let ([max-length (write-bytes/max #"\\U" o max-length)]) + (write-string/max (pad 8 (number->string n 16)) o max-length))])] + [i (add1 i)]) + (loop i i max-length))])])))) diff --git a/racket/src/io/print/symbol.rkt b/racket/src/io/print/symbol.rkt new file mode 100644 index 0000000000..f1bc8b4b9f --- /dev/null +++ b/racket/src/io/print/symbol.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require "../port/string-output.rkt" + "../string/number.rkt" + "write-with-max.rkt" + "parameter.rkt" + "config.rkt") + +(provide print-symbol + symbol->print-string) + +(define (print-symbol sym o max-length config + #:for-keyword? [for-keyword? #f]) + (define str (symbol->print-string sym #:config config #:for-keyword? for-keyword?)) + (write-string/max str o max-length)) + +(define (symbol->print-string sym + #:config [config #f] + #:for-type? [for-type? #f] + #:case-sensitive? [case-sensitive? (if config + (config-get config read-case-sensitive) + #t)] + #:for-keyword? [for-keyword? #f]) + (define str (symbol->string sym)) + (define (is-simple? ch i) + (not (or (char=? ch #\() + (char=? ch #\[) + (char=? ch #\{) + (char=? ch #\)) + (char=? ch #\]) + (char=? ch #\}) + (char=? ch #\") + (char=? ch #\\) + (char=? ch #\') + (char=? ch #\,) + (and (char=? ch #\|) + (or (not config) (config-get config read-accept-bar-quote))) + (and for-type? + (or (char=? ch #\<) + (char=? ch #\>))) + (and (char-whitespace? ch) + (or (not for-type?) + (not (char=? ch #\space)))) + (and (char=? ch #\#) + (zero? i) + (or ((string-length str) . < . 2) + (not (char=? (string-ref str 1) #\%)))) + (and (char=? ch #\.) + (zero? i) + (= (string-length str) 1)) + (and (not case-sensitive?) + (not (char=? ch (char-foldcase ch))))))) + (cond + [(for/and ([ch (in-string str)] + [i (in-naturals)]) + (is-simple? ch i)) + (cond + [(or for-keyword? + for-type? + (not (string->number? str))) + str] + ;; Remaining two cases add some form of quoting to + ;; protect against a symbol looking like a number + [(and config (not (config-get config read-accept-bar-quote))) + (string-append "\\" str)] + [else + (string-append "|" str "|")])] + [(or (and config (not (config-get config read-accept-bar-quote))) + (for/or ([ch (in-string str)]) + (char=? ch #\|))) + ;; Need to use backslashes for quoting + (define len (string-length str)) + (apply + string-append + (let loop ([start 0] [i 0]) + (cond + [(= i len) (list (substring str start len))] + [(is-simple? (string-ref str i) i) (loop start (add1 i))] + [else + (list* (substring str start i) + "\\" + (substring str i (add1 i)) + (loop (add1 i) (add1 i)))])))] + [else + ;; Can use bars for quoting: + (string-append "|" str "|")])) diff --git a/racket/src/io/print/write-with-max.rkt b/racket/src/io/print/write-with-max.rkt new file mode 100644 index 0000000000..c76118746b --- /dev/null +++ b/racket/src/io/print/write-with-max.rkt @@ -0,0 +1,69 @@ +#lang racket/base +(require "../port/string-output.rkt" + "../port/bytes-output.rkt" + "../port/port.rkt" + "../port/output-port.rkt") + +(provide write-string/max + write-bytes/max + + make-output-port/max + output-port/max-max-length) + +(define (write-string/max str o max-length [start 0] [end (string-length str)]) + (cond + [(eq? max-length 'full) 'full] + [(not max-length) + (write-string str o start end) + #f] + [else + (define len (- end start)) + (cond + [(len . < . max-length) + (write-string str o start end) + (- max-length len)] + [else + (write-string str o start (+ start max-length)) + 'full])])) + +;; For measuring purposes, just treat bytes as characters: +(define (write-bytes/max bstr o max-length [start 0] [end (bytes-length bstr)]) + (cond + [(eq? max-length 'full) 'full] + [(not max-length) + (write-bytes bstr o start end) + #f] + [else + (define len (- end start)) + (cond + [(len . < . max-length) + (write-bytes bstr o start end) + (- max-length len)] + [else + (write-bytes bstr o start (+ start max-length)) + 'full])])) + +(define (make-output-port/max o max-length) + (make-core-output-port + #:name (object-name o) + #:data (lambda () max-length) + #:evt o + #:write-out + (lambda (src-bstr src-start src-end nonblock? enable-break? copy?) + (cond + [max-length + (define len (- src-end src-start)) + (unless (eq? max-length 'full) + (define write-len (min len max-length)) + (define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len))) + (if (= max-length wrote-len) + (set! max-length 'full) + (set! max-length (- max-length wrote-len)))) + len] + [else + (write-bytes src-bstr o src-start src-end)])) + #:close void)) + +(define (output-port/max-max-length o max-length) + (and max-length + ((core-port-data o)))) diff --git a/racket/src/io/run/main.rkt b/racket/src/io/run/main.rkt new file mode 100644 index 0000000000..0856f42b99 --- /dev/null +++ b/racket/src/io/run/main.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require "../common/check.rkt" + "../print/main.rkt" + "../error/main.rkt" + "../port/parameter.rkt" + "../port/handler.rkt") + +(provide executable-yield-handler + current-command-line-arguments + current-print + current-read-interaction + current-prompt-read + current-get-interaction-input-port + cache-configuration) + +(define/who executable-yield-handler + (make-parameter void (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define/who current-command-line-arguments + (make-parameter '#() (lambda (v) + (define l (and (vector? v) + (vector->list v))) + (unless (and (vector? v) + (andmap string? l)) + (raise-argument-error who "(vectorof string?)" l)) + (list->vector (map string->immutable-string l))))) + +(define/who current-print + (make-parameter (lambda (v) + (unless (void? v) + (print v) + (newline))) + (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define/who current-read-interaction + (make-parameter (lambda (src in) + (parameterize ([installed-read-accept-reader #t] + [installed-read-accept-lang #f]) + (installed-read-syntax src in))) + (lambda (p) + (check who (procedure-arity-includes/c 2) p) + p))) + +(define/who current-prompt-read + (make-parameter (lambda () + (display "> ") + (let ([in ((current-get-interaction-input-port))]) + ((current-read-interaction) (object-name in) in))) + (lambda (p) + (check who (procedure-arity-includes/c 0) p) + p))) + +(define/who current-get-interaction-input-port + (make-parameter (lambda () (current-input-port)) + (lambda (p) + (check who (procedure-arity-includes/c 0) p) + p))) + +;; ---------------------------------------- + +(define cached-values (make-hasheq)) +(define (cache-configuration index thunk) + (hash-ref cached-values index + (lambda () + (let ([v (thunk)]) + (hash-set! cached-values index v) + v)))) diff --git a/racket/src/io/sandman/lock.rkt b/racket/src/io/sandman/lock.rkt new file mode 100644 index 0000000000..b7f5982612 --- /dev/null +++ b/racket/src/io/sandman/lock.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require "../common/internal-error.rkt") + +;; Simple lock for sandman + +(provide make-lock + lock-acquire + lock-release) + +(define (make-lock) + (box 0)) + +(define (lock-acquire box) + (let loop () + (unless (and (= 0 (unbox box)) (box-cas! box 0 1)) + (loop)))) + +(define (lock-release box) + (unless (box-cas! box 1 0) + (internal-error "failed to release lock"))) diff --git a/racket/src/io/sandman/main.rkt b/racket/src/io/sandman/main.rkt new file mode 100644 index 0000000000..50af6cd559 --- /dev/null +++ b/racket/src/io/sandman/main.rkt @@ -0,0 +1,182 @@ +#lang racket/base +(require "../../thread/sandman-struct.rkt" + "../common/internal-error.rkt" + "../host/thread.rkt" + "../host/rktio.rkt" + "lock.rkt") + +;; Create an extended sandman that can sleep with a rktio poll set. An +;; external-event set might be naturally implemented with a poll set, +;; except that poll sets are single-use values. So, an external-event +;; set is instead implemented as a tree of callbacks to registers with +;; a (fresh) poll set each time. + +;; This sandman builds on the default one to handles timeouts. While +;; it might make sense to all threads to sleep on pollable external +;; events, we don't implement that, and it's probably simpler to +;; connect events to semaphores through a long-term poll set... + +(provide sandman-add-poll-set-adder + sandman-poll-ctx-add-poll-set-adder! + sandman-poll-ctx-merge-timeout + sandman-set-background-sleep!) + +(struct exts (timeout-at fd-adders)) + +(define (sandman-add-poll-set-adder old-exts adder) + (exts (and old-exts (exts-timeout-at old-exts)) + (cons adder (and old-exts (exts-fd-adders old-exts))))) + +(define (sandman-poll-ctx-add-poll-set-adder! poll-ctx adder) + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + (schedule-info-current-exts sched-info + (sandman-add-poll-set-adder + (schedule-info-current-exts sched-info) + adder)))) + +(define (sandman-poll-ctx-merge-timeout poll-ctx timeout) + (define sched-info (poll-ctx-sched-info poll-ctx)) + (when sched-info + (schedule-info-current-exts sched-info + ((sandman-do-merge-timeout (current-sandman)) + (schedule-info-current-exts sched-info) + timeout)))) + + +(define background-sleep #f) +(define background-sleep-fd #f) + +(define (sandman-set-background-sleep! sleep fd) + (set! background-sleep sleep) + (set! background-sleep-fd fd)) + +(void + (current-sandman + (let ([timeout-sandman (current-sandman)] + [lock (make-lock)] + [waiting-threads '()] + [awoken-threads '()]) + (sandman + ;; sleep + (lambda (exts) + (define timeout-at (and exts (exts-timeout-at exts))) + (define fd-adders (and exts (exts-fd-adders exts))) + (define ps (rktio_make_poll_set rktio)) + (let loop ([fd-adders fd-adders]) + (cond + [(not fd-adders) (void)] + [(pair? fd-adders) + (loop (car fd-adders)) + (loop (cdr fd-adders))] + [else + (fd-adders ps)])) + (define sleep-secs (and timeout-at + (/ (- timeout-at (current-inexact-milliseconds)) 1000.0))) + (unless (and sleep-secs (sleep-secs . <= . 0.0)) + (cond + [background-sleep + (rktio_start_sleep rktio (or sleep-secs 0.0) ps rktio_NULL background-sleep-fd) + (background-sleep) + (rktio_end_sleep rktio)] + [else + (rktio_sleep rktio + (or sleep-secs 0.0) + ps + rktio_NULL)])) + (rktio_poll_set_forget rktio ps)) + + ;; poll + (lambda (mode wakeup) + (let check-signals () + (define v (rktio_poll_os_signal rktio)) + (unless (eqv? v RKTIO_OS_SIGNAL_NONE) + ((rktio_get_ctl_c_handler) (cond + [(eqv? v RKTIO_OS_SIGNAL_HUP) 'hang-up] + [(eqv? v RKTIO_OS_SIGNAL_TERM) 'terminate] + [else 'break])) + (check-signals))) + ((sandman-do-poll timeout-sandman) mode wakeup)) + + ;; any-sleepers? + (lambda () + ((sandman-do-any-sleepers? timeout-sandman))) + + ;; sleepers-external-events + (lambda () + (define timeout-at ((sandman-do-sleepers-external-events timeout-sandman))) + (and timeout-at + (exts timeout-at #f))) + + ;; add-thread! + (lambda (t exts) + (define fd-adders (exts-fd-adders exts)) + (unless (or (not fd-adders) + (null? fd-adders)) + (internal-error "cannot sleep on fds")) + ((sandman-do-add-thread! timeout-sandman) t (exts-timeout-at exts))) + + ;; remove-thread! + (lambda (t timeout-handle) + ((sandman-do-remove-thread! timeout-sandman) t timeout-handle)) + + ;; merge-exts + (lambda (a-exts b-exts) + (if (and a-exts b-exts) + (exts ((sandman-do-merge-external-event-sets + timeout-sandman) + (exts-timeout-at a-exts) + (exts-timeout-at b-exts)) + (if (and (exts-fd-adders a-exts) + (exts-fd-adders b-exts)) + (cons (exts-fd-adders a-exts) + (exts-fd-adders b-exts)) + (or (exts-fd-adders a-exts) + (exts-fd-adders b-exts)))) + (or a-exts b-exts))) + + ;; merge-timeout + (lambda (old-exts timeout-at) + (exts ((sandman-do-merge-timeout timeout-sandman) + (and old-exts + (exts-timeout-at old-exts)) + timeout-at) + (and old-exts + (exts-fd-adders old-exts)))) + + ;; extract-timeout + (lambda (exts) + (exts-timeout-at exts)) + + ;; condition-wait + (lambda (t) + (lock-acquire lock) + (set! waiting-threads (cons t waiting-threads)) + (lock-release lock) + ;; awoken callback. for when thread is awoken + (lambda () + (lock-acquire lock) + (if (memq t waiting-threads) + (begin + (set! waiting-threads (remove t waiting-threads eq?)) + (set! awoken-threads (cons t awoken-threads)) + (rktio_signal_received_at (rktio_get_signal_handle rktio))) ;; wakeup main thread if sleeping + (internal-error "thread is not a member of waiting-threads\n")) + (lock-release lock))) + + ;; condition-poll + (lambda (mode wakeup) + (lock-acquire lock) + (define at awoken-threads) + (set! awoken-threads '()) + (lock-release lock) + (for-each (lambda (t) + (wakeup t)) at)) + + ;; any-waiters? + (lambda () + (or (not (null? waiting-threads)) (not (null? awoken-threads)))) + + + ;; lock + lock)))) diff --git a/racket/src/io/security/main.rkt b/racket/src/io/security/main.rkt new file mode 100644 index 0000000000..72592705d4 --- /dev/null +++ b/racket/src/io/security/main.rkt @@ -0,0 +1,89 @@ +#lang racket/base +(require "../common/check.rkt" + "../path/path.rkt" + "../path/relativity.rkt" + "../network/port-number.rkt") + +(provide make-security-guard + security-guard? + current-security-guard + + security-guard-check-file + security-guard-check-file-link + security-guard-check-network + + unsafe-make-security-guard-at-root) + +(struct security-guard (parent + file-guard + network-guard + link-guard)) + +(define root-security-guard + (security-guard #f void void void)) + +(define/who current-security-guard + (make-parameter root-security-guard + (lambda (v) + (check who security-guard? v) + v))) + +(define/who (make-security-guard parent + file-guard + network-guard + [link-guard void]) + (check who security-guard? parent) + (check who (procedure-arity-includes/c 3) file-guard) + (check who (procedure-arity-includes/c 4) network-guard) + (check who #:or-false (procedure-arity-includes/c 3) link-guard) + (security-guard parent file-guard network-guard (or link-guard void))) + +(define/who (unsafe-make-security-guard-at-root [file-guard void] + [network-guard void] + [link-guard void]) + (check who (procedure-arity-includes/c 3) file-guard) + (check who (procedure-arity-includes/c 4) network-guard) + (check who (procedure-arity-includes/c 3) link-guard) + (security-guard #f file-guard network-guard link-guard)) + +(define/who (security-guard-check-file check-who given-path guards) + (check who symbol? check-who) + (check who path-string? #:or-false given-path) + (check who (lambda (l) + (and (list? l) + (for/and ([s (in-list l)]) + (or (eq? s 'read) + (eq? s 'write) + (eq? s 'execute) + (eq? s 'delete) + (eq? s 'exists))))) + #:contract "(or/c 'read 'write 'execute 'delete 'exists)" + guards) + (define path (->path given-path)) + (let loop ([sg (current-security-guard)]) + (when sg + ((security-guard-file-guard sg) check-who path guards) + (loop (security-guard-parent sg))))) + +(define/who (security-guard-check-file-link check-who given-path given-dest) + (check who symbol? check-who) + (check who (lambda (p) (and (path-string? p) (complete-path? p))) + #:contract "(and/c path? complete-path?)" + given-path) + (check who path-string? given-dest) + (define path (->path given-path)) + (define dest (->path given-dest)) + (let loop ([sg (current-security-guard)]) + (when sg + ((security-guard-link-guard sg) check-who path dest) + (loop (security-guard-parent sg))))) + +(define/who (security-guard-check-network check-who given-host port client?) + (check who symbol? check-who) + (check who string? #:or-false given-host) + (check who listen-port-number? #:or-false port) + (define host (and given-host (string->immutable-string given-host))) + (let loop ([sg (current-security-guard)]) + (when sg + ((security-guard-network-guard sg) check-who host port (if client? 'client 'server)) + (loop (security-guard-parent sg))))) diff --git a/racket/src/io/srcloc/main.rkt b/racket/src/io/srcloc/main.rkt new file mode 100644 index 0000000000..eaa852d38c --- /dev/null +++ b/racket/src/io/srcloc/main.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require "../common/check.rkt" + "../format/main.rkt" + "../path/parameter.rkt") + +(provide srcloc->string) + +(define/who (srcloc->string s) + (check who srcloc? s) + (and (srcloc-source s) + (cond + [(and (srcloc-line s) + (srcloc-column s)) + (format "~a:~s:~s" + (adjust-path (srcloc-source s)) + (srcloc-line s) + (srcloc-column s))] + [else + (format "~a::~s" + (adjust-path (srcloc-source s)) + (srcloc-position s))]))) + +(define (adjust-path p) + (define dir (current-directory-for-user)) + ;; FIXME + p) diff --git a/racket/src/io/string/convert.rkt b/racket/src/io/string/convert.rkt new file mode 100644 index 0000000000..082154b3e5 --- /dev/null +++ b/racket/src/io/string/convert.rkt @@ -0,0 +1,189 @@ +#lang racket/base +(require "utf-8-decode.rkt" + "utf-8-encode.rkt" + "../common/check.rkt") + +(provide bytes->string/latin-1 + bytes->string/utf-8 + bytes-utf-8-length + + bytes-utf-8-index + bytes-utf-8-ref + + string->bytes/latin-1 + string->bytes/utf-8 + string-utf-8-length + + char-utf-8-length) + +;; ---------------------------------------- + +(define/who (bytes->string/latin-1 bstr [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (check who bytes? bstr) + (check who char? #:or-false err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length bstr) bstr) + (define len (- end start)) + (define s (make-string len)) + (let loop ([i len]) + (unless (zero? i) + (let ([i (sub1 i)]) + (string-set! s i (integer->char (bytes-ref bstr (+ i start)))) + (loop i)))) + s) + +(define (do-bytes->string/utf-8 who bstr err-char start end #:just-length? [just-length? #f]) + (check who bytes? bstr) + (check who char? #:or-false err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length bstr) bstr) + ;; Measure result string: + (define-values (used-bytes got-chars state) + (utf-8-decode! bstr start end + #f 0 #f + #:error-char err-char + #:abort-mode 'error)) + (cond + [(eq? state 'error) (if just-length? + #f + (raise-encoding-error who bstr start end))] + [just-length? got-chars] + [else + ;; Create result string: + (define str (make-string got-chars)) + (utf-8-decode! bstr start end + str 0 #f + #:error-char err-char + #:abort-mode 'error) + str])) + +(define/who (bytes->string/utf-8 bstr [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes->string/utf-8 who bstr err-char start end)) + +(define/who (bytes-utf-8-length bstr [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes->string/utf-8 who bstr err-char start end #:just-length? #t)) + +(define (raise-encoding-error who bstr start end) + (raise-arguments-error who "byte string is not a well-formed UTF-8 encoding" + "byte string" (subbytes bstr start end))) + +;; ---------------------------------------- + +(define (do-bytes-utf-8-ref who bstr skip err-char start end + #:get-index? [get-index? #f]) + (check who bytes? bstr) + (check who exact-nonnegative-integer? skip) + (check who (lambda (c) (or (not c) (char? c))) + #:contract "(or/c char? #f)" + err-char) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (bytes-length bstr) bstr) + ;; First, decode `skip` items: + (define-values (initial-used-bytes initial-got-chars state) + (if (zero? skip) + (values 0 0 (if (= start end) 'complete 'continues)) + (utf-8-decode! bstr start end + #f 0 skip + #:error-char err-char + #:abort-mode 'error))) + (cond + [(eq? state 'error) + #f] + [(eq? state 'continues) + (cond + [(and get-index? ((+ start initial-used-bytes) . < . end)) + initial-used-bytes] + [else + ;; Get one more byte + (define str (and (not get-index?) (make-string 1))) + (define-values (used-bytes got-chars new-state) + (utf-8-decode! bstr (+ start initial-used-bytes) end + str 0 1 + #:error-char err-char)) + (cond + [(eq? new-state 'error) + #f] + [(or (eq? state 'continues) + (or (and (eq? state 'complete) + (= got-chars 1)))) + (if get-index? + initial-used-bytes + (string-ref str 0))] + [else #f])])] + [else #f])) + +(define/who (bytes-utf-8-ref bstr [skip 0] [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes-utf-8-ref who bstr skip err-char start end)) + +(define/who (bytes-utf-8-index bstr [skip 0] [err-char #f] [start 0] [end (and (bytes? bstr) + (bytes-length bstr))]) + (do-bytes-utf-8-ref who bstr skip err-char start end #:get-index? #t)) + +;; ---------------------------------------- + +(define/who (string->bytes/latin-1 str [err-byte #f] [start 0] [end (and (string? str) + (string-length str))]) + (check who string? str) + (check who byte? #:or-false err-byte) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + (define len (- end start)) + (define bstr (make-bytes len)) + (let loop ([i len]) + (unless (zero? i) + (let ([i (sub1 i)]) + (define b (char->integer (string-ref str (+ i start)))) + (cond + [(byte? b) (bytes-set! bstr i b)] + [err-byte (bytes-set! bstr i err-byte)] + [else (raise-arguments-error who + "string cannot be encoded in Latin-1" + "string" str)]) + (loop i)))) + bstr) + +(define (do-string->bytes/utf-8 who str err-byte start end #:just-length? [just-length? #f]) + (check who string? str) + (check who byte? #:or-false err-byte) + (check who exact-nonnegative-integer? start) + (check who exact-nonnegative-integer? end) + (check-range who start end (string-length str) str) + ;; Measure result byte string: + (define-values (used-chars got-bytes status) + (utf-8-encode! str start end + #f 0 #f)) + (cond + [just-length? got-bytes] + [else + ;; Create result byte string: + (define bstr (make-bytes got-bytes)) + (utf-8-encode! str start end + bstr 0 #f) + bstr])) + +(define/who (string->bytes/utf-8 str [err-byte #f] [start 0] [end (and (string? str) + (string-length str))]) + (do-string->bytes/utf-8 who str err-byte start end)) + +(define/who (string-utf-8-length str [start 0] [end (and (string? str) + (string-length str))]) + (do-string->bytes/utf-8 who str #f start end #:just-length? #t)) + +;; ---------------------------------------- + +(define (char-utf-8-length c) + (check 'char-utf-8-length char? c) + (define n (char->integer c)) + (cond + [(n . <= . #x7F) 1] + [(n . <= . #x7FF) 2] + [(n . <= . #xFFFF) 3] + [else 4])) diff --git a/racket/src/io/string/integer.rkt b/racket/src/io/string/integer.rkt new file mode 100644 index 0000000000..00bda01422 --- /dev/null +++ b/racket/src/io/string/integer.rkt @@ -0,0 +1,10 @@ +#lang racket/base + +;; Simple string->number conversion, since the geenral one is +;; implemented at the expander level + +(provide string->integer) + +(define (string->integer s) + (for/fold ([v 0]) ([c (in-string s)]) + (+ (* v 10) (- (char->integer c) (char->integer #\0))))) diff --git a/racket/src/io/string/main.rkt b/racket/src/io/string/main.rkt new file mode 100644 index 0000000000..279522454c --- /dev/null +++ b/racket/src/io/string/main.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "convert.rkt" + "number.rkt") + +(provide (all-from-out "convert.rkt") + set-string->number?!) diff --git a/racket/src/io/string/number.rkt b/racket/src/io/string/number.rkt new file mode 100644 index 0000000000..66686810ba --- /dev/null +++ b/racket/src/io/string/number.rkt @@ -0,0 +1,13 @@ +#lang racket/base + +;; The `string->number` function is implemented at the reader+expander +;; level, but the printer needs `string->number` for checking whether +;; to quote a symbol. Tie the knot with `set-string->number?!`. + +(provide string->number? + set-string->number?!) + +(define string->number? (lambda (str) #f)) + +(define (set-string->number?! proc) + (set! string->number? proc)) diff --git a/racket/src/io/string/utf-16-decode.rkt b/racket/src/io/string/utf-16-decode.rkt new file mode 100644 index 0000000000..f9cd2c8302 --- /dev/null +++ b/racket/src/io/string/utf-16-decode.rkt @@ -0,0 +1,39 @@ +#lang racket/base +(require "../common/set-two.rkt") + +(provide utf-16-decode) + +(define big-endian? (system-big-endian?)) + +(define (utf-16-decode bstr) + (define len (bytes-length bstr)) + (define surrogate-count + (for/fold ([n 0]) ([b (in-bytes bstr (if big-endian? 0 1) len 2)]) + (if (= (bitwise-and b #xDC) #xD8) + (add1 n) + n))) + (define str (make-string (- (arithmetic-shift len -1) surrogate-count))) + (let loop ([i 0] [pos 0]) + (unless (= i len) + (define a (bytes-ref bstr i)) + (define b (bytes-ref bstr (add1 i))) + (define v (if big-endian? + (bitwise-ior (arithmetic-shift a 8) b) + (bitwise-ior (arithmetic-shift b 8) a))) + (cond + [(= (bitwise-and v #xDC00) #xDC00) + ;; surrogate pair + (define a (bytes-ref bstr (+ i 2))) + (define b (bytes-ref bstr (+ i 3))) + (define v2 (if big-endian? + (bitwise-ior (arithmetic-shift a 8) b) + (bitwise-ior (arithmetic-shift b 8) a))) + (define all-v (+ #x10000 + (bitwise-ior (arithmetic-shift (bitwise-and v #x3FF) 10) + (bitwise-and v2 #x3FF)))) + (string-set! str pos (integer->char all-v)) + (loop (+ i 4) (add1 pos))] + [else + (string-set! str pos (integer->char v)) + (loop (+ i 2) (add1 pos))]))) + str) diff --git a/racket/src/io/string/utf-16-encode.rkt b/racket/src/io/string/utf-16-encode.rkt new file mode 100644 index 0000000000..0c978b7324 --- /dev/null +++ b/racket/src/io/string/utf-16-encode.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require "../common/set-two.rkt") + +(provide utf-16-encode) + +(define (utf-16-encode s) + (define surrogate-count + (for/fold ([n 0]) ([c (in-string s)]) + (if ((char->integer c) . >= . #x10000) + (add1 n) + n))) + (define bstr (make-bytes (* 2 (+ (string-length s) surrogate-count)))) + (for/fold ([pos 0]) ([c (in-string s)]) + (define v (char->integer c)) + (cond + [(v . >= . #x10000) + (define av (- v #x10000)) + (define hi (bitwise-ior #xD800 (bitwise-and (arithmetic-shift av -10) #x3FF))) + (define lo (bitwise-ior #xDC00 (bitwise-and av #x3FF))) + (bytes-set-two! bstr pos (arithmetic-shift hi -8) (bitwise-and hi #xFF)) + (bytes-set-two! bstr pos (arithmetic-shift lo -8) (bitwise-and lo #xFF)) + (+ pos 4)] + [else + (bytes-set-two! bstr pos (arithmetic-shift v -8) (bitwise-and v #xFF)) + (+ pos 2)])) + bstr) diff --git a/racket/src/io/string/utf-8-decode.rkt b/racket/src/io/string/utf-8-decode.rkt new file mode 100644 index 0000000000..ce4b8ccd63 --- /dev/null +++ b/racket/src/io/string/utf-8-decode.rkt @@ -0,0 +1,188 @@ +#lang racket/base + +(provide utf-8-decode! + utf-8-max-aborts-amt + + utf-8-state? + utf-8-state-pending-amt) + +;; The maximum number of characters that might not be consumed +;; by a conversion at the tail of a byte string, assuming that +;; additional bytes could be added to the tail: +(define utf-8-max-aborts-amt 3) + +(struct utf-8-state (accum ; accumulated value for a partial decoding + remaining ; number of bytes expected to finidh decoding + pending-amt)) ; number of bytes contributing to `accum` + +;; Returns (values bytes-used chars-written (or/c 'complete 'continues 'aborts 'error state-for-aborts)), +;; where the number of bytes used can go negative if a previous abort state is provided +;; and further decoding reveals that earlier bytes were in error. +;; +;; The `abort-mode` argument determines what to do when reaching the end of the input +;; and an encoding needs more ytes: +;; * 'error : treat the bytes as encoding errors +;; * 'aborts : report 'aborts +;; * 'state : return a value that encapsulates the state, so another call can continue +;; +;; The result state is +;; * 'complete : all input read, all output written +;; * 'continues : output full, and input contains more +;; * 'aborts : see `abort-mode` above +;; * 'error : encoding error, but only when `error-ch` is #f +;; * state-for-aborts : see `abort-mode` above +;; +;; Beware that there is a similar copy of this code in "../converter/utf-8.rkt", +;; but that one is different enough to make abstraction difficult. +;; +(define (utf-8-decode! in-bstr in-start in-end + out-str out-start out-end ; `out-str` and `out-end` can be #f no string result needed + #:error-char [error-ch #f] ; replaces an encoding error if non-#f + #:abort-mode [abort-mode 'error] ; 'error, 'aborts, or 'state + #:state [state #f]) ; state that was returned in place of a previous 'aborts result + (define base-i ; start of current encoding sequence + (if state + (- in-start (utf-8-state-pending-amt state)) + in-start)) + (define accum ; accumulated value for encoding + (if state + (utf-8-state-accum state) + 0)) + (define remaining ; number of bytes still needed for the encoding + (if state + (utf-8-state-remaining state) + 0)) + + ;; Iterate through the given byte string + (let loop ([i in-start] [j out-start] [base-i base-i] [accum accum] [remaining remaining]) + + ;; Shared handling for encoding failures: + (define (encoding-failure) + (cond + [error-ch + (when out-str (string-set! out-str j error-ch)) + (define next-j (add1 j)) + (define next-i (add1 base-i)) + (cond + [(and out-end (= next-j out-end)) + (values (- next-i in-start) + (- next-j out-start) + 'continues)] + [else + (loop next-i next-j next-i 0 0)])] + [else + (values (- base-i in-start) + (- j out-start) + 'error)])) + + ;; Shared handling for decoding success: + (define (continue) + (define next-j (add1 j)) + (define next-i (add1 i)) + (cond + [(and out-end (= next-j out-end)) + (values (- next-i in-start) + (- next-j out-start) + (if (= next-i in-end) + 'complete + 'continues))] + [else + (loop next-i next-j next-i 0 0)])) + + ;; Dispatch on byte: + (cond + [(= i in-end) + ;; End of input + (cond + [(zero? remaining) + (values (- base-i in-start) + (- j out-start) + 'complete)] + [(eq? abort-mode 'error) + (encoding-failure)] + [(eq? abort-mode 'state) + (values (- i in-start) ; all bytes used + (- j out-start) + (utf-8-state accum remaining (- i base-i)))] + [else + (values (- base-i in-start) + (- j out-start) + 'aborts)])] + [(i . < . in-start) + ;; Happens only if we resume decoding with some state + ;; and hit a decoding error; treat the byte as another + ;; encoding error + (encoding-failure)] + [else + (define b (bytes-ref in-bstr i)) + (cond + [(b . < . 128) + (cond + [(zero? remaining) + ;; Found ASCII + (when out-str (string-set! out-str j (integer->char b))) + (continue)] + [else + ;; We were accumulating bytes for an encoding, and + ;; the encoding didn't complete + (encoding-failure)])] + [else + ;; Encoding... + (cond + [(= #b10000000 (bitwise-and b #b11000000)) + ;; A continuation byte + (cond + [(zero? remaining) + ;; We weren't continuing + (encoding-failure)] + [else + (define next (bitwise-and b #b00111111)) + (define next-accum (bitwise-ior (arithmetic-shift accum 6) next)) + (cond + [(= 1 remaining) + (cond + [(and (next-accum . > . 127) + (next-accum . <= . #x10FFFF) + (not (and (next-accum . >= . #xD800) + (next-accum . <= . #xDFFF)))) + (when out-str (string-set! out-str j (integer->char next-accum))) + (continue)] + [else + ;; Not a valid character + (encoding-failure)])] + [(and (= 2 remaining) + (next-accum . <= . #b11111)) + ;; A shorter byte sequence would work, so this is an + ;; encoding mistae. + (encoding-failure)] + [(and (= 3 remaining) + (next-accum . <= . #b1111)) + ;; A shorter byte sequence would work + (encoding-failure)] + [else + ;; Continue an encoding. + (loop (add1 i) j base-i next-accum (sub1 remaining))])])] + [(not (zero? remaining)) + ;; Trying to start a new encoding while one is in + ;; progress + (encoding-failure)] + [(= #b11000000 (bitwise-and b #b11100000)) + ;; Start a two-byte encoding + (define accum (bitwise-and b #b11111)) + ;; If `accum` is zero, that's an encoding mistake, + ;; because a shorted byte sequence would work. + (cond + [(zero? accum) (encoding-failure)] + [else (loop (add1 i) j i accum 1)])] + [(= #b11100000 (bitwise-and b #b11110000)) + ;; Start a three-byte encoding + (define accum (bitwise-and b #b1111)) + (loop (add1 i) j i accum 2)] + [(= #b11110000 (bitwise-and b #b11111000)) + ;; Start a four-byte encoding + (define accum (bitwise-and b #b111)) + (loop (add1 i) j i accum 3)] + [else + ;; Five- or six-byte encodings don't produce valid + ;; characters + (encoding-failure)])])]))) diff --git a/racket/src/io/string/utf-8-encode.rkt b/racket/src/io/string/utf-8-encode.rkt new file mode 100644 index 0000000000..ba861164a3 --- /dev/null +++ b/racket/src/io/string/utf-8-encode.rkt @@ -0,0 +1,69 @@ +#lang racket/base + +(provide utf-8-encode! + + utf-8-encode-dispatch) + +;; Returns (values chars-used bytes-written (or/c 'complete 'continues)) +;; where 'continues is the result when the result byte string doesn't +;; have enough room +(define (utf-8-encode! in-str in-start in-end + out-bstr out-start out-end) ; `out-bstr` and `out-end` can be #f no bytes result needed + ;; Iterate through the given string + (let loop ([i in-start] [j out-start]) + (cond + [(= i in-end) + (values (- in-end in-start) (- j out-start) 'complete)] + [else + (define b (char->integer (string-ref in-str i))) + (define (continue next-j) (loop (add1 i) next-j)) + (utf-8-encode-dispatch b + in-start i + out-bstr out-start out-end j + continue)]))) + +(define-syntax-rule (utf-8-encode-dispatch b + in-start i + out-bstr out-start out-end j + continue) + (cond + [(b . <= . #x7F) + (cond + [(and out-end (= j out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr (bytes-set! out-bstr j b)) + (continue (add1 j))])] + [(b . <= . #x7FF) + (cond + [(and out-end ((add1 j) . >= . out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr + (bytes-set! out-bstr j (bitwise-ior #b11000000 (arithmetic-shift b -6))) + (bytes-set! out-bstr (add1 j) (bitwise-ior #b10000000 (bitwise-and b #b111111)))) + (continue (+ j 2))])] + [(b . <= . #xFFFF) + (cond + [(and out-end ((+ j 2) . >= . out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr + (bytes-set! out-bstr j (bitwise-ior #b11100000 (arithmetic-shift b -12))) + (bytes-set! out-bstr (+ j 1) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -6) + #b111111))) + (bytes-set! out-bstr (+ j 2) (bitwise-ior #b10000000 (bitwise-and b #b111111)))) + (continue (+ j 3))])] + [else + (cond + [(and out-end ((+ j 3) . >= . out-end)) + (values (- i in-start) (- j out-start) 'continues)] + [else + (when out-bstr + (bytes-set! out-bstr j (bitwise-ior #b11110000 (arithmetic-shift b -18))) + (bytes-set! out-bstr (+ j 1) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -12) + #b111111))) + (bytes-set! out-bstr (+ j 2) (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift b -6) + #b111111))) + (bytes-set! out-bstr (+ j 3) (bitwise-ior #b10000000 (bitwise-and b #b111111)))) + (continue (+ j 4))])])) diff --git a/racket/src/io/subprocess/main.rkt b/racket/src/io/subprocess/main.rkt new file mode 100644 index 0000000000..4069d57e96 --- /dev/null +++ b/racket/src/io/subprocess/main.rkt @@ -0,0 +1,279 @@ +#lang racket/base +(require "../common/check.rkt" + "../common/bytes-no-nuls.rkt" + "../host/rktio.rkt" + "../host/error.rkt" + "../host/thread.rkt" + "../path/path.rkt" + "../path/parameter.rkt" + "../port/output-port.rkt" + "../port/input-port.rkt" + "../port/fd-port.rkt" + "../port/file-stream.rkt" + "../file/host.rkt" + "../string/convert.rkt" + "../locale/string.rkt" + "../envvar/main.rkt") + +(provide (rename-out [do-subprocess subprocess]) + subprocess? + subprocess-wait + subprocess-status + subprocess-kill + subprocess-pid + current-subprocess-custodian-mode + subprocess-group-enabled + shell-execute) + +(struct subprocess ([process #:mutable] + [cust-ref #:mutable] + is-group?) + #:constructor-name make-subprocess + #:property + prop:evt + (poller (lambda (sp ctx) + (define v (rktio_poll_process_done rktio (subprocess-process sp))) + (if (eqv? v 0) + (values #f sp) + (values (list sp) #f))))) + +(define do-subprocess + (let () + (define/who (subprocess stdout stdin stderr group/command . command/args) + (check who + (lambda (p) (or (not p) (and (output-port? p) (file-stream-port? p)))) + #:contract "(or/c (and/c output-port? file-stream-port?) #f)" + stdout) + (check who + (lambda (p) (or (not p) (and (input-port? p) (file-stream-port? p)))) + #:contract "(or/c (and/c input-port? file-stream-port?) #f)" + stdin) + (check who + (lambda (p) (or (not p) (eq? p 'stdout) (and (output-port? p) (file-stream-port? p)))) + #:contract "(or/c (and/c output-port? file-stream-port?) #f 'stdout)" + stderr) + (define-values (group command exact/args) + (cond + [(path-string? group/command) + (values (and (subprocess-group-enabled) 'new) group/command command/args)] + [(null? command/args) + (raise-argument-error who "path-string?" command)] + [(or (not group/command) + (eq? group/command 'new) + (subprocess? group/command)) + (define command (cadr command/args)) + (check who path-string? command) + (values group/command command (cdr command/args))] + [else + (raise-argument-error who "(or/c path-string? #f 'new subprocess?)" group/command)])) + (define-values (exact? args) + (cond + [(and (pair? exact/args) + (eq? 'exact (car exact/args))) + (values #t (cdr exact/args))] + [else + (values #f exact/args)])) + (for ([arg (in-list args)] + [i (in-naturals)]) + (check who + (lambda (p) (or (path? p) (string-no-nuls? p) (bytes-no-nuls? p))) + #:contract (if (and (not exact?) + (= i 0) + (= (length args) 2)) + "(or/c path? string-no-nuls? bytes-no-nuls? 'exact)" + "(or/c path? string-no-nuls? bytes-no-nuls?)") + arg)) + + (define cust-mode (current-subprocess-custodian-mode)) + (define env-vars (current-environment-variables)) + + (let* ([flags (if (eq? stderr 'stdout) + RKTIO_PROCESS_STDOUT_AS_STDERR + 0)] + [flags (if exact? + (bitwise-ior flags RKTIO_PROCESS_WINDOWS_EXACT_CMDLINE) + flags)] + [flags (if (eq? group 'new) + (bitwise-ior flags RKTIO_PROCESS_NEW_GROUP) + flags)] + [flags (if (and (eq? cust-mode 'kill) + (positive? (bitwise-and (rktio_process_allowed_flags rktio) + RKTIO_PROCESS_WINDOWS_CHAIN_TERMINATION))) + (bitwise-ior flags RKTIO_PROCESS_WINDOWS_CHAIN_TERMINATION) + flags)]) + + (define command-bstr (->host (->path command) who '(execute))) + + (start-atomic) + (poll-subprocess-finalizations) + (check-current-custodian who) + (define envvars (rktio_empty_envvars rktio)) + (for ([name (in-list (environment-variables-names env-vars))]) + (rktio_envvars_set rktio envvars name (environment-variables-ref env-vars name))) + + (define send-args (rktio_from_bytes_list + (cons command-bstr + (for/list ([arg (in-list args)]) + (cond + [(string? arg) + (string->bytes/locale arg (char->integer #\?))] + [(path? arg) + (path-bytes arg)] + [else arg]))))) + + (define r (rktio_process rktio command-bstr (add1 (length args)) send-args + (and stdout (fd-port-fd stdout)) + (and stdin (fd-port-fd stdin)) + (and stderr (not (eq? stderr 'stdout)) (fd-port-fd stderr)) + (and group (subprocess-process group)) + (->host (current-directory) #f null) + envvars flags)) + + (rktio_free_bytes_list send-args (length args)) + (when envvars + (rktio_envvars_free rktio envvars)) + + (when (rktio-error? r) + (end-atomic) + (raise-rktio-error who r "process creation failed")) + + (define in (let ([fd (rktio_process_result_stdout_fd r)]) + (and fd (open-input-fd fd 'subprocess-stdout)))) + (define out (let ([fd (rktio_process_result_stdin_fd r)]) + (and fd (open-output-fd fd 'subprocess-stdin)))) + (define err (let ([fd (rktio_process_result_stderr_fd r)]) + (and fd (open-input-fd fd 'subprocess-stderr)))) + (define sp (make-subprocess (rktio_process_result_process r) + #f + (eq? group 'new))) + + (register-subprocess-finalizer sp) + (when cust-mode + (let ([close (if (eq? cust-mode 'kill) kill-subprocess interrupt-subprocess)]) + (set-subprocess-cust-ref! sp (unsafe-custodian-register (current-custodian) sp close #t #f)))) + + (rktio_free r) + + (end-atomic) + (values sp in out err))) + subprocess)) + +;; ---------------------------------------- + +(define/who (subprocess-wait sp) + (check who subprocess? sp) + (void (sync sp))) + +;; ---------------------------------------- + +(define/who (subprocess-status sp) + (check who subprocess? sp) + (start-atomic) + (define r (rktio_process_status rktio (subprocess-process sp))) + (cond + [(rktio-error? r) + (end-atomic) + (raise-rktio-error who r "status access failed")] + [(rktio_status_running r) + (rktio_free r) + (end-atomic) + 'running] + [else + (define v (rktio_status_result r)) + (rktio_free r) + (end-atomic) + v])) + +(define/who (subprocess-pid sp) + (check who subprocess? sp) + (atomically + (rktio_process_pid rktio (subprocess-process sp)))) + +;; ---------------------------------------- + +;; in atomic mode +(define (kill-subprocess sp) + (define p (subprocess-process sp)) + (when p + (rktio_process_kill rktio p))) + +;; in atomic mode +(define (interrupt-subprocess sp) + (define p (subprocess-process sp)) + (when p + (rktio_process_interrupt rktio p))) + +(define/who (subprocess-kill sp force?) + (check who subprocess? sp) + (atomically (if force? + (interrupt-subprocess sp) + (kill-subprocess sp)))) + +;; ---------------------------------------- + +(define subprocess-will-executor (make-will-executor)) + +(define (register-subprocess-finalizer sp) + (will-register subprocess-will-executor + sp + (lambda (sp) + (when (subprocess-process sp) + (rktio_process_forget rktio (subprocess-process sp)) + (set-subprocess-process! sp #f)) + (when (subprocess-cust-ref sp) + (unsafe-custodian-unregister sp (subprocess-cust-ref sp)) + (set-subprocess-cust-ref! sp #f)) + #t))) + +(define (poll-subprocess-finalizations) + (when (will-try-execute subprocess-will-executor) + (poll-subprocess-finalizations))) + +;; ---------------------------------------- + +(define/who current-subprocess-custodian-mode + (make-parameter #f (lambda (v) + (unless (or (not v) (eq? v 'kill) (eq? v 'interrupt)) + (raise-argument-error who "(or/c #f 'kill 'interrupt)" v)) + v))) + +(define subprocess-group-enabled + (make-parameter #f (lambda (v) (and v #t)))) + +;; ---------------------------------------- + +(define/who (shell-execute verb target parameters dir show-mode) + (check who string? #:or-false verb) + (check who string? target) + (check who string? parameters) + (check who path-string? dir) + (define show_mode + (case show-mode + [(sw_hide SW_HIDE) RKTIO_SW_HIDE] + [(sw_maximize SW_MAXIMIZE) RKTIO_SW_MAXIMIZE] + [(sw_minimize SW_MINIMIZE) RKTIO_SW_MINIMIZE] + [(sw_restore SW_RESTORE) RKTIO_SW_RESTORE] + [(sw_show SW_SHOW) RKTIO_SW_SHOW] + [(sw_showdefault SW_SHOWDEFAULT) RKTIO_SW_SHOWDEFAULT] + [(sw_showmaximized SW_SHOWMAXIMIZED) RKTIO_SW_SHOWMAXIMIZED] + [(sw_showminimized SW_SHOWMINIMIZED) RKTIO_SW_SHOWMINIMIZED] + [(sw_showminnoactive SW_SHOWMINNOACTIVE) RKTIO_SW_SHOWMINNOACTIVE] + [(sw_showna SW_SHOWNA) RKTIO_SW_SHOWNA] + [(sw_shownoactivate SW_SHOWNOACTIVATE) RKTIO_SW_SHOWNOACTIVATE] + [(sw_shownormal SW_SHOWNORMAL) RKTIO_SW_SHOWNORMAL] + [else (raise-argument-error who "(or/c 'sw_hide ....)" show-mode)])) + (define r (rktio_shell_execute rktio + (and verb (string->bytes/utf-8 verb)) + (string->bytes/utf-8 target) + (string->bytes/utf-8 parameters) + (->host (->path dir) who '(exists)) + show_mode)) + (when (rktio-error? r) (raise-rktio-error 'who "failed" r)) + #f) + +;; ---------------------------------------- + +(void + (set-get-subprocesses-time! + (lambda () + (rktio_get_process_children_milliseconds rktio)))) diff --git a/racket/src/io/unsafe/main.rkt b/racket/src/io/unsafe/main.rkt new file mode 100644 index 0000000000..3667f01a71 --- /dev/null +++ b/racket/src/io/unsafe/main.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "schedule.rkt" + "port.rkt") + +(provide (all-from-out "schedule.rkt") + (all-from-out "port.rkt")) diff --git a/racket/src/io/unsafe/port.rkt b/racket/src/io/unsafe/port.rkt new file mode 100644 index 0000000000..01678d5c12 --- /dev/null +++ b/racket/src/io/unsafe/port.rkt @@ -0,0 +1,51 @@ +#lang racket/base +(require "../host/rktio.rkt" + "../string/convert.rkt" + "../port/fd-port.rkt" + "../network/tcp-port.rkt") + +(provide unsafe-file-descriptor->port + unsafe-port->file-descriptor + unsafe-file-descriptor->semaphore + + unsafe-socket->port + unsafe-port->socket + unsafe-socket->semaphore) + +(define (unsafe-file-descriptor->port system-fd name mode) + (define read? (memq 'read mode)) + (define write? (memq 'write mode)) + (define refcount (box (if (and read? write?) 2 1))) + (define fd (rktio_system_fd rktio system-fd + (bitwise-and + (if read? RKTIO_OPEN_READ 0) + (if write? RKTIO_OPEN_WRITE 0) + (if (memq 'test mode) RKTIO_OPEN_TEXT 0) + (if (memq 'regular-file mode) RKTIO_OPEN_REGFILE 0)))) + (define i (and read? + (open-input-fd fd name #:fd-refcount refcount))) + (define o (and write? + (open-output-fd fd name #:fd-refcount refcount))) + (if (and i o) + (values i o) + (or i o))) + +(define (unsafe-socket->port system-fd name mode) + (open-input-output-tcp system-fd (string->symbol (bytes->string/utf-8 name)) + #:close? (not (memq 'no-close mode)))) + + +(define (unsafe-port->file-descriptor p) + (define fd (fd-port-fd p)) + (and fd + (rktio_fd_system_fd rktio fd))) + +(define (unsafe-port->socket p) + (and (tcp-port? p) + (unsafe-port->file-descriptor p))) + +(define (unsafe-file-descriptor->semaphore system-fd mode) + #f) + +(define (unsafe-socket->semaphore system-fd mode) + #f) diff --git a/racket/src/io/unsafe/schedule.rkt b/racket/src/io/unsafe/schedule.rkt new file mode 100644 index 0000000000..299d2c511b --- /dev/null +++ b/racket/src/io/unsafe/schedule.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require "../host/thread.rkt" + "../host/rktio.rkt" + "../sandman/main.rkt") + +(provide unsafe-poller + unsafe-poll-ctx-fd-wakeup + unsafe-poll-ctx-eventmask-wakeup + unsafe-poll-ctx-milliseconds-wakeup + unsafe-signal-received + unsafe-set-sleep-in-thread!) + +(define (unsafe-poller proc) + (poller (lambda (self poll-ctx) + (cond + [(poll-ctx-poll? poll-ctx) + (proc self #f)] + [else + (define-values (vals evt) (proc self #f)) + (cond + [vals (values vals #f)] + [(eq? evt self) + ;; Register wakeups: + (proc self poll-ctx) + (values #f self)] + [else + (values #f evt)])])))) + +(define (unsafe-poll-ctx-fd-wakeup poll-ctx fd mode) + (when poll-ctx + (sandman-poll-ctx-add-poll-set-adder! poll-ctx + (lambda (ps) + (atomically + (define rfd (rktio_system_fd rktio + fd + (case mode + [(read) RKTIO_OPEN_READ] + [else RKTIO_OPEN_WRITE]))) + (rktio_poll_add rktio rfd ps (case mode + [(read) RKTIO_POLL_READ] + [else RKTIO_POLL_WRITE])) + (rktio_forget rktio rfd)))))) + +(define (unsafe-poll-ctx-eventmask-wakeup poll-ctx event-mask) + (when poll-ctx + (sandman-poll-ctx-add-poll-set-adder! poll-ctx + (lambda (ps) + (rktio_poll_set_add_eventmask rktio ps event-mask))))) + +(define (unsafe-poll-ctx-milliseconds-wakeup poll-ctx msecs) + (when poll-ctx + (sandman-poll-ctx-merge-timeout poll-ctx msecs))) + +(define (unsafe-signal-received) + (rktio_signal_received rktio)) + +(define (unsafe-set-sleep-in-thread! do-sleep woke-fd) + (sandman-set-background-sleep! do-sleep woke-fd)) diff --git a/racket/src/mac/osx_appl.rkt b/racket/src/mac/osx_appl.rkt index 4230d0e2c1..114ec77e9d 100644 --- a/racket/src/mac/osx_appl.rkt +++ b/racket/src/mac/osx_appl.rkt @@ -3,7 +3,7 @@ # OS X pre-make script # builds resource files, makes template Starter.app and GRacket.app # -# the script must be run from the gracket build directory, +# The script must be run from the gracket build directory, # and srcdir must be provided as the first argument |# diff --git a/racket/src/mac/rename-app.rkt b/racket/src/mac/rename-app.rkt index eb574ccd7e..8dd4e479d3 100644 --- a/racket/src/mac/rename-app.rkt +++ b/racket/src/mac/rename-app.rkt @@ -1,6 +1,7 @@ #lang racket/base -(current-directory (build-path 'up)) +(unless ((vector-length (current-command-line-arguments)) . > . 3) + (current-directory (build-path 'up))) (define app-path (vector-ref (current-command-line-arguments) 0)) (define old-name (vector-ref (current-command-line-arguments) 1)) diff --git a/racket/src/mzcom/mzcom.cxx b/racket/src/mzcom/mzcom.cxx index d87a5db74f..2c98894929 100644 --- a/racket/src/mzcom/mzcom.cxx +++ b/racket/src/mzcom/mzcom.cxx @@ -119,7 +119,7 @@ int IsFlag(LPCTSTR cmd, LPCTSTR flag) } #define DLL_RELATIVE_PATH L"." -#include "../racket/delayed.inc" +#include "../start/delayed.inc" #define ASSUME_ASCII_COMMAND_LINE #define GC_CAN_IGNORE diff --git a/racket/src/racket/Makefile.in b/racket/src/racket/Makefile.in index cfce453314..e2b68d5690 100644 --- a/racket/src/racket/Makefile.in +++ b/racket/src/racket/Makefile.in @@ -49,6 +49,8 @@ RACKET = racket RUN_THIS_RACKET_CGC = ./racket@CGC@ RUN_THIS_RACKET_MMM = ./racket@MMM@ +SETUP_BOOT = -W "info@compiler/cm error" -l- setup @BOOT_MODE@ $(srcdir)/../setup-go.rkt ../compiled + MZSRC = $(srcdir)/src FOREIGN_DIR = ../foreign @@ -97,10 +99,14 @@ cgc-core: $(MAKE) dynlib $(MAKE) mzlibrary $(MAKE) racket@CGC@ + $(MAKE) cstartup + $(MAKE) mzlibrary + $(MAKE) racket@CGC@ $(MAKE) mzcom@CGC@ 3m: $(MAKE) @CGC_IF_NEEDED_FOR_MMM@ + $(MAKE) cstartup cd gc2; $(MAKE) all cd dynsrc; $(MAKE) dynlib3m cd gc2; $(MAKE) ../racket@MMM@ @@ -137,7 +143,7 @@ sproc-extra-lib: cd @GCDIR@; $(MAKE) sproc.@LTO@ $(MAKE) sproc.@LTO@ -gc.@LIBSFX@: +gc.@LIBSFX@: $(NICEAR) $(AR) $(ARFLAGS) @GCDIR@/gc.@LIBSFX@ @GCDIR@/*.@LTO@ # Compilation of the foreign libraries (this compiles all of them) @@ -264,7 +270,7 @@ DEF_C_DIRS = $(DEF_COLLECTS_DIR) $(DEF_CONFIG_DIR) MAIN_HEADER_DEPS = $(srcdir)/include/scheme.h $(srcdir)/include/schthread.h $(srcdir)/sconfig.h \ $(srcdir)/src/stypes.h $(srcdir)/cmdline.inc $(srcdir)/parse_cmdl.inc \ - $(srcdir)/delayed.inc $(srcdir)/parse_cmdl.inc + $(srcdir)/../start/config.inc $(srcdir)/../start/delayed.inc $(srcdir)/parse_cmdl.inc main.@LTO@: $(srcdir)/main.c $(MAIN_HEADER_DEPS) $(CC) -I$(builddir) -I$(srcdir)/include $(CFLAGS) $(CPPFLAGS) @OPTIONS@ @MZOPTIONS@ $(DEF_C_DIRS) -c $(srcdir)/main.c -o main.@LTO@ @@ -290,27 +296,11 @@ com_glue.@LTO@: $(srcdir)/../mzcom/com_glue.c $(MZCOM_DEPS) $(CC) -I$(builddir) -I$(srcdir)/include $(CFLAGS) $(CPPFLAGS) @OPTIONS@ @MZOPTIONS@ -c $(srcdir)/../mzcom/com_glue.c -o com_glue.@LTO@ exn: - $(MAKE) $(srcdir)/src/schexn.h - $(MAKE) $(collectsdir)/racket/private/kernstruct.rkt + $(RACKET) -um $(srcdir)/src/makeexn > $(srcdir)/src/schexn.h + $(RACKET) -um $(srcdir)/src/makeexn kernstruct $(collectsdir)/racket/private/kernstruct.rkt -STARTUPDEST = startup.inc CSTARTUPDEST = cstartup.inc -startup: - $(MAKE) $(srcdir)/src/$(STARTUPDEST) -cstartup: - $(MAKE) $(srcdir)/src/$(CSTARTUPDEST) - -total_startup: - awk '{ if (match($$0, "#define USE_COMPILED_STARTUP 1")) print "#define USE_COMPILED_STARTUP 0"; else print }' src/schminc.h > src/schminc.newh - mv src/schminc.newh src/schminc.h - $(MAKE) cgc - rm -rf $(srcdir)/src/$(CSTARTUPDEST) - $(MAKE) $(srcdir)/src/$(CSTARTUPDEST) - awk '{ if (match($$0, "#define USE_COMPILED_STARTUP 0")) print "#define USE_COMPILED_STARTUP 1"; else print }' src/schminc.h > src/schminc.newh - mv src/schminc.newh src/schminc.h - $(MAKE) cgc - MZCONFIGDIR@NOT_MINGW@ = . MZCONFIGDIR@MINGW@ = "$(srcdir)/../worksp" @@ -318,22 +308,37 @@ headers: @RUN_RACKET_CGC@ -cqu $(srcdir)/mkincludes.rkt @DIRCVTPRE@"$(DESTDIR)$(includepltdir)"@DIRCVTPOST@ "$(srcdir)" $(MZCONFIGDIR) cd ..; cp racket/system.rktd "$(DESTDIR)$(libpltdir)/system.rktd" -$(srcdir)/src/schexn.h: $(srcdir)/src/makeexn - $(RACKET) -um $(srcdir)/src/makeexn > $(srcdir)/src/schexn.h -$(collectsdir)/racket/private/kernstruct.rkt: $(srcdir)/src/makeexn - $(RACKET) -um $(srcdir)/src/makeexn kernstruct $(collectsdir)/racket/private/kernstruct.rkt +# The `cstartup` target may update "cstartup.inc", either replacing a +# stub "cstartup.inc" that redirects to "startup.inc" or rebuilding +# because "startup.inc" or "schvers.h" changed; so, during a CGC +# build, we try again after building this target to potentially update +# the CGC build to a compiled-startup build. A particular `cstartup` +# target variant is selected by the `configure` script based on whether +# `--{en,dis}able-cify` is specified; for example `STARTUP_AS_AUTO` +# with be the empty string is neither is specified, in which case +# of the the other targets is selected by a recursive `$(MAKE)`. -$(srcdir)/src/$(STARTUPDEST): $(srcdir)/src/startup.rktl $(srcdir)/src/sstoinct.rkt - $(RACKET) -cu $(srcdir)/src/sstoinct.rkt < $(srcdir)/src/startup.rktl > $(srcdir)/src/$(STARTUPDEST) -$(srcdir)/src/$(CSTARTUPDEST): $(srcdir)/src/startup.rktl $(srcdir)/src/schvers.h $(srcdir)/src/schminc.h - $(RUN_THIS_RACKET_CGC) -cu $(srcdir)/src/sstoinc.rkt $(CSTARTUPEXTRA) $(srcdir)/src/$(CSTARTUPDEST) < $(srcdir)/src/startup.rktl +cstartup@STARTUP_AS_AUTO@: + $(MAKE) `@RUN_RACKET_CGC@ -cu $(srcdir)/src/startup-select.rkt` + +# For compiling the startup code to bytecode +cstartup@STARTUP_AS_BYTECODE@: + @RUN_RACKET_CGC@ -cu $(srcdir)/src/compile-startup.rkt $(CSTARTUPDEST) cstartup.zo $(srcdir)/src/startup.inc $(srcdir)/src/schvers.h + +# For compiling the startup code to C +cstartup@STARTUP_AS_C@: + @RUN_RACKET_CGC@ -cu $(srcdir)/src/cify-check.rkt $(CSTARTUPDEST) + $(MAKE) cstartup.inc + +# Running "cify-startup.rkt" through "$(SETUP_BOOT)" generates more +# dependencies in "cstartup.d" for `$(CSTARTUPDEST)` +$(CSTARTUPDEST): $(srcdir)/src/startup.inc $(srcdir)/src/schvers.h + @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) $(SETUP_BOOT) cstartup.inc cstartup.d $(srcdir)/src/cify-startup.rkt $(srcdir)/src/startup.inc $(srcdir)/src/schvers.h +@INCLUDEDEP@ cstartup.d mark: racket -cu $(srcdir)/src/mkmark.rkt $(srcdir)/src < $(srcdir)/src/mzmarksrc.c -cstartup.zo: - $(MAKE) startup CSTARTUPEXTRA='zo' CSTARTUPDEST="../cstartup.zo" - clean@NOT_OSX@: /bin/rm -rf tmp[123456789] tests/tmp[123456789] tests/sub[123] /bin/rm -f tests/*~ @@ -341,6 +346,7 @@ clean@NOT_OSX@: /bin/rm -f mzdyn.o libmzgc.@LIBSFX@ libracket.@LIBSFX@ libracket3m.@LIBSFX@ libdl.a racket racket.multiboot /bin/rm -f include/macosxpre /bin/rm -f include/macosxpre.p + /bin/rm -f $(CSTARTUPDEST) cd gc; $(MAKE) clean cd gc2; $(MAKE) clean cd sgc; $(MAKE) clean @@ -387,7 +393,7 @@ unix-install: cd ..; rm -f "$(DESTDIR)@MZINSTALLBINDIR@/racket@CGC_INSTALLED@" cd ..; rm -f "$(DESTDIR)@MZINSTALLBINDIR@/racket@MMM_INSTALLED@" cd ..; cp racket/starter@EXE_SUFFIX@ "$(DESTDIR)$(libpltdir)/starter@EXE_SUFFIX@" - cp $(srcdir)/dynsrc/starter-sh . + cp $(srcdir)/../start/starter-sh . cd ..; cp racket/starter-sh "$(DESTDIR)$(libpltdir)/starter-sh" cd ..; $(STRIP_DEBUG) "$(DESTDIR)$(libpltdir)/starter@EXE_SUFFIX@" @RUN_RACKET_CGC@ -cu "$(srcdir)/collects-path.rkt" "$(DESTDIR)$(libpltdir)/starter@EXE_SUFFIX@" $(DESTDIR)@COLLECTS_PATH@ $(DESTDIR)@CONFIG_PATH@ diff --git a/racket/src/racket/cmdline.inc b/racket/src/racket/cmdline.inc index 8d687a89a7..4fe14ae4b0 100644 --- a/racket/src/racket/cmdline.inc +++ b/racket/src/racket/cmdline.inc @@ -2,255 +2,20 @@ /* This command-line parser is used by both Racket and GRacket. */ /****************************************************************/ -#pragma GCC diagnostic ignored "-Wwrite-strings" - -#define SDESC "Set! works on undefined identifiers" - -char * volatile scheme_cmdline_exe_hack = (char *) - ("[Replace me for EXE hack " - " ]"); - -#ifdef MZ_PRECISE_GC -# define GC_PRECISION_TYPE "3" -#else -# define GC_PRECISION_TYPE "c" -#endif -char * volatile scheme_binary_type_hack = "bINARy tYPe:" INITIAL_BIN_TYPE GC_PRECISION_TYPE; -/* The format of bINARy tYPe is e?[zr]i[3c]. - e indicates a starter executable - z/r indicates Racket or GRacket - i indicates ??? - 3/c indicates 3m or CGC */ - -#ifndef INITIAL_COLLECTS_DIRECTORY -# ifdef DOS_FILE_SYSTEM -# define INITIAL_COLLECTS_DIRECTORY "collects" -# else -# define INITIAL_COLLECTS_DIRECTORY "../collects" -# endif -#endif - -char * volatile scheme_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */ - INITIAL_COLLECTS_DIRECTORY - "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */ - /* Pad with at least 1024 bytes: */ - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************"; -static int _coldir_offset = 19; /* Skip permanent tag */ - -#ifndef INITIAL_CONFIG_DIRECTORY -# ifdef DOS_FILE_SYSTEM -# define INITIAL_CONFIG_DIRECTORY "etc" -# else -# define INITIAL_CONFIG_DIRECTORY "../etc" -# endif -#endif - -char * volatile scheme_configdir = "coNFIg dIRECTORy:" /* <- this tag stays, so we can find it again */ - INITIAL_CONFIG_DIRECTORY - "\0" - /* Pad with at least 1024 bytes: */ - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************" - "****************************************************************"; -static int _configdir_offset = 17; /* Skip permanent tag */ - - -#ifndef MZ_PRECISE_GC -# define XFORM_OK_PLUS + -#endif - -#ifdef OS_X -# include -# include -# include -#endif - -#ifdef DOS_FILE_SYSTEM -# include - -#ifndef DLL_RELATIVE_PATH -# define DLL_RELATIVE_PATH L"lib" -#endif -#include "delayed.inc" - #ifdef NEED_CONSOLE_PRINTF static void (*console_printf)(char *str, ...); # define PRINTF console_printf #endif -static void record_dll_path(void) -{ - if (_dlldir[_dlldir_offset] != '<') { - scheme_set_dll_path(_dlldir + _dlldir_offset); - } -} - -# ifdef MZ_PRECISE_GC -END_XFORM_SKIP; -# endif -#endif - -#ifdef OS_X -static long get_segment_offset() -{ -# if defined(__x86_64__) || defined(__arm64__) - const struct segment_command_64 *seg; -# else - const struct segment_command *seg; -#endif - seg = getsegbyname("__PLTSCHEME"); - if (seg) - return seg->fileoff; - else - return 0; -} -#endif +#include "../start/config.inc" #ifdef DOS_FILE_SYSTEM -wchar_t *get_self_executable_path() +static void record_dll_path(void) { - wchar_t *path; - DWORD r, sz = 1024; - - while (1) { - path = (wchar_t *)malloc(sz * sizeof(wchar_t)); - r = GetModuleFileNameW(NULL, path, sz); - if ((r == sz) - && (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) { - free(path); - sz = 2 * sz; - } else - break; - } - - return path; -} - -static DWORD find_by_id(HANDLE fd, DWORD rsrcs, DWORD pos, int id) -{ - DWORD got, val; - WORD name_count, id_count; - - SetFilePointer(fd, pos + 12, 0, FILE_BEGIN); - ReadFile(fd, &name_count, 2, &got, NULL); - ReadFile(fd, &id_count, 2, &got, NULL); - - pos += 16 + (name_count * 8); - while (id_count--) { - ReadFile(fd, &val, 4, &got, NULL); - if (val == id) { - ReadFile(fd, &val, 4, &got, NULL); - return rsrcs + (val & 0x7FFFFFF); - } else { - ReadFile(fd, &val, 4, &got, NULL); - } - } - - return 0; -} - -static long get_segment_offset() -{ - /* Find the resource of type 257 */ - wchar_t *path; - HANDLE fd; - - path = get_self_executable_path(); - fd = CreateFileW(path, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE, - NULL, - OPEN_EXISTING, - 0, - NULL); - free(path); - - if (fd == INVALID_HANDLE_VALUE) - return 0; - else { - DWORD val, got, sec_pos, virtual_addr, rsrcs, pos; - WORD num_sections, head_size; - char name[8]; - - SetFilePointer(fd, 60, 0, FILE_BEGIN); - ReadFile(fd, &val, 4, &got, NULL); - SetFilePointer(fd, val+4+2, 0, FILE_BEGIN); /* Skip "PE\0\0" tag and machine */ - ReadFile(fd, &num_sections, 2, &got, NULL); - SetFilePointer(fd, 12, 0, FILE_CURRENT); /* time stamp + symbol table */ - ReadFile(fd, &head_size, 2, &got, NULL); - - sec_pos = val+4+20+head_size; - while (num_sections--) { - SetFilePointer(fd, sec_pos, 0, FILE_BEGIN); - ReadFile(fd, &name, 8, &got, NULL); - if ((name[0] == '.') - && (name[1] == 'r') - && (name[2] == 's') - && (name[3] == 'r') - && (name[4] == 'c') - && (name[5] == 0)) { - SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip virtual size */ - ReadFile(fd, &virtual_addr, 4, &got, NULL); - SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip file size */ - ReadFile(fd, &rsrcs, 4, &got, NULL); - SetFilePointer(fd, rsrcs, 0, FILE_BEGIN); - - /* We're at the resource table; step through 3 layers */ - pos = find_by_id(fd, rsrcs, rsrcs, 257); - if (pos) { - pos = find_by_id(fd, rsrcs, pos, 1); - if (pos) { - pos = find_by_id(fd, rsrcs, pos, 1033); - - if (pos) { - /* pos is the reource data entry */ - SetFilePointer(fd, pos, 0, FILE_BEGIN); - ReadFile(fd, &val, 4, &got, NULL); - pos = val - virtual_addr + rsrcs; - - CloseHandle(fd); - - return pos; - } - } - } - - break; - } - sec_pos += 40; - } - - /* something went wrong */ - CloseHandle(fd); - return 0; - } + GC_CAN_IGNORE wchar_t *dlldir; + dlldir = extract_dlldir(); + if (dlldir) + scheme_set_dll_path(dlldir); } #endif @@ -385,7 +150,7 @@ static void configure_environment(Scheme_Object *mod) submod = scheme_intern_symbol("submod"); cr = scheme_intern_symbol("configure-runtime"); - if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) { + if (scheme_is_module_path_index(mod)) { mpij = scheme_builtin_value("module-path-index-join"); a[0] = scheme_make_pair(submod, scheme_make_pair(scheme_make_utf8_string("."), @@ -548,7 +313,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl) a[0], fa->evals_and_loads[i]); } - /* Use a module path index so that multiple resolutions are no unduly + /* Use a module path index so that multiple resolutions are not unduly sensitive to changes in the current directory or other configurations: */ mpi = scheme_make_modidx(a[0], scheme_make_false(), scheme_make_false()); if (!did_config) @@ -755,10 +520,6 @@ static Scheme_Object *reverse_path_list(Scheme_Object *l, int rel_to_cwd) return r; } -#ifndef MZ_XFORM -# define GC_CAN_IGNORE /**/ -#endif - #include static Scheme_Object *get_log_level(char *prog, char *real_switch, const char *envvar, const char *what, GC_CAN_IGNORE char *str) @@ -859,10 +620,12 @@ static Scheme_Object *adjust_collects_path(Scheme_Object *collects_path, int *_s { /* Setup path for "collects" collection directory: */ if (!collects_path) { - if (!scheme_coldir[_coldir_offset]) + GC_CAN_IGNORE char *coldir; + coldir = extract_coldir(); + if (!coldir[0]) collects_path = scheme_make_false(); else - collects_path = scheme_make_path(scheme_coldir XFORM_OK_PLUS _coldir_offset); + collects_path = scheme_make_path(coldir); } else if (!SAME_OBJ(collects_path, scheme_make_false())) collects_path = scheme_path_to_complete_path(collects_path, NULL); @@ -891,7 +654,7 @@ static Scheme_Object *adjust_config_path(Scheme_Object *config_path) } if (!config_path) - config_path = scheme_make_path(scheme_configdir XFORM_OK_PLUS _configdir_offset); + config_path = scheme_make_path(extract_configdir()); else config_path = scheme_path_to_complete_path(config_path, NULL); @@ -982,181 +745,7 @@ static int run_from_cmd_line(int argc, char *_argv[], console_printf = scheme_get_console_printf(); #endif -#ifdef DOS_FILE_SYSTEM - { - /* For consistency, strip trailing spaces and dots, and make sure the .exe - extension is present. */ - int l = strlen(prog); - if ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { - char *s; - while ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { - l--; - } - s = (char *)scheme_malloc_atomic(l + 1); - memcpy(s, prog, l); - s[l] = 0; - prog = s; - } - if (l <= 4 - || (prog[l - 4] != '.') - || (tolower(((unsigned char *)prog)[l - 3]) != 'e') - || (tolower(((unsigned char *)prog)[l - 2]) != 'x') - || (tolower(((unsigned char *)prog)[l - 1]) != 'e')) { - char *s; - s = (char *)scheme_malloc_atomic(l + 4 + 1); - memcpy(s, prog, l); - memcpy(s + l, ".exe", 5); - prog = s; - } - } -#endif - - /* If scheme_cmdline_exe_hack is changed, then we extract built-in - arguments. */ - if (scheme_cmdline_exe_hack[0] != '[') { - int n, i; - long d; - GC_CAN_IGNORE unsigned char *p; - GC_CAN_IGNORE unsigned char *orig_p; - char **argv2; - - p = NULL; -#ifdef DOS_FILE_SYSTEM - if ((scheme_cmdline_exe_hack[0] == '?') - || (scheme_cmdline_exe_hack[0] == '*')) { - /* This is how we make launchers in Windows. The cmdline is - added as a resource of type 257. The long integer at - scheme_cmdline_exe_hack[4] says where the command line starts - with the source, and scheme_cmdline_exe_hack[8] says how long - the cmdline string is. It might be relative to the - executable. */ - HANDLE fd; - wchar_t *path; - - path = get_self_executable_path(); - fd = CreateFileW(path, GENERIC_READ, - FILE_SHARE_READ | FILE_SHARE_WRITE, - NULL, - OPEN_EXISTING, - 0, - NULL); - if (fd == INVALID_HANDLE_VALUE) - p = (unsigned char *)"\0\0\0"; - else { - long start, len; - DWORD got; - start = *(long *)&scheme_cmdline_exe_hack[4]; - len = *(long *)&scheme_cmdline_exe_hack[8]; - start += get_segment_offset(); - p = (unsigned char *)malloc(len); - SetFilePointer(fd, start, 0, FILE_BEGIN); - ReadFile(fd, p, len, &got, NULL); - CloseHandle(fd); - if (got != len) - p = (unsigned char *)"\0\0\0"; - else if (scheme_cmdline_exe_hack[0] == '*') { - /* "*" means that the first item is argv[0] replacement: */ - sprog = prog; - prog = (char *)p + 4; - - if ((prog[0] == '\\') - || ((((prog[0] >= 'a') && (prog[0] <= 'z')) - || ((prog[0] >= 'A') && (prog[0] <= 'Z'))) - && (prog[1] == ':'))) { - /* Absolute path */ - } else { - /* Make it absolute, relative to this executable */ - int plen = strlen(prog); - int mlen, len; - char *s2, *p2; - - /* UTF-8 encode path: */ - for (len = 0; path[len]; len++) { } - mlen = scheme_utf8_encode((unsigned int *)path, 0, len, - NULL, 0, - 1 /* UTF-16 */); - p2 = (char *)malloc(mlen + 1); - mlen = scheme_utf8_encode((unsigned int *)path, 0, len, - (unsigned char *)p2, 0, - 1 /* UTF-16 */); - - while (mlen && (p2[mlen - 1] != '\\')) { - mlen--; - } - s2 = (char *)malloc(mlen + plen + 1); - memcpy(s2, p2, mlen); - memcpy(s2 + mlen, prog, plen + 1); - prog = s2; - } - - p += (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24) - + 4); - } - } - free(path); - } -#endif -#if defined(OS_X) - if (scheme_cmdline_exe_hack[0] == '?') { - long fileoff, cmdoff, cmdlen; - int fd; - fileoff = get_segment_offset(); - - p = (unsigned char *)scheme_cmdline_exe_hack + 4; - cmdoff = (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24)); - cmdlen = (p[4] - + (((long)p[5]) << 8) - + (((long)p[6]) << 16) - + (((long)p[7]) << 24)); - p = malloc(cmdlen); - - fd = open(_dyld_get_image_name(0), O_RDONLY); - lseek(fd, fileoff + cmdoff, 0); - read(fd, p, cmdlen); - close(fd); - } -#endif - - if (!p) - p = (unsigned char *)scheme_cmdline_exe_hack + 1; - - /* Command line is encoded as a sequence of pascal-style strings; - we use four whole bytes for the length, though, little-endian. */ - - orig_p = p; - - n = 0; - while (p[0] || p[1] || p[2] || p[3]) { - n++; - p += (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24) - + 4); - } - - argv2 = (char **)malloc(sizeof(char *) * (argc + n)); - p = orig_p; - for (i = 0; i < n; i++) { - d = (p[0] - + (((long)p[1]) << 8) - + (((long)p[2]) << 16) - + (((long)p[3]) << 24)); - argv2[i] = (char *)p + 4; - p += d + 4; - } - for (; i < n + argc; i++) { - argv2[i] = argv[i - n]; - } - argv = argv2; - argc += n; - } + extract_built_in_arguments(&prog, &sprog, &argc, &argv); #ifndef DONT_PARSE_COMMAND_LINE evals_and_loads = (char **)malloc(sizeof(char *) * argc); @@ -1664,14 +1253,16 @@ static int run_from_cmd_line(int argc, char *_argv[], { int len, offset; + GC_CAN_IGNORE char *coldir; collects_paths_l = scheme_make_null(); - offset = _coldir_offset; + coldir = extract_coldir(); + offset = 0; while (1) { - len = strlen(scheme_coldir XFORM_OK_PLUS offset); + len = strlen(coldir XFORM_OK_PLUS offset); offset += len + 1; - if (!scheme_coldir[offset]) + if (!coldir[offset]) break; - collects_paths_l = scheme_make_pair(scheme_make_path(scheme_coldir XFORM_OK_PLUS offset), + collects_paths_l = scheme_make_pair(scheme_make_path(coldir XFORM_OK_PLUS offset), collects_paths_l); } collects_paths_l = reverse_path_list(collects_paths_l, 0); diff --git a/racket/src/racket/configure.ac b/racket/src/racket/configure.ac index 8e8ef77320..d3d167c160 100644 --- a/racket/src/racket/configure.ac +++ b/racket/src/racket/configure.ac @@ -73,6 +73,8 @@ AC_ARG_ENABLE(sgc, [ --enable-sgc use Senora GC instead of Boehm AC_ARG_ENABLE(sgcdebug,[ --enable-sgcdebug use Senora GC for debugging (expensive debug mode)]) AC_ARG_ENABLE(backtrace, [ --enable-backtrace 3m: support GC backtrace dumps (expensive debug mode)]) +AC_ARG_ENABLE(backtrace, [ --enable-cify compile startup code to C insteda of bytecode]) + AC_ARG_ENABLE(pthread, [ --enable-pthread link with pthreads (usually auto-enabled if needed)]) AC_ARG_ENABLE(stackup, [ --enable-stackup assume "up" if stack direction cannot be determined]) AC_ARG_ENABLE(bigendian, [ --enable-bigendian assume "big" if endianness cannot be determined]) @@ -323,6 +325,8 @@ show_explicitly_disabled "${enable_futures}" Futures show_explicitly_disabled "${enable_sgc}" SGC show_explicitly_enabled "${enable_sgcdebug}" "SGC debug mode" show_explicitly_enabled "${enable_backtrace}" "3m GC backtraces" "Note that this mode is not intended for normal Racket use" +show_explicitly_enabled "${enable_cify}" "Startup compiled to C" +show_explicitly_disabled "${enable_cify}" "Startup compiled to C" show_explicitly_disabled "${enable_float}" "Single-precision floats" show_explicitly_enabled "${enable_floatinstead}" "Single-precision default floats" "Note that this mode is NOT RECOMMENDED" @@ -479,6 +483,22 @@ skip_iconv_check=no check_page_size=yes try_no_nullability_completeness=no +if test "${enable_cify}" = "yes" ; then + STARTUP_AS_BYTECODE=_bytecode + STARTUP_AS_C= + STARTUP_AS_AUTO=_auto +else + if test "${enable_cify}" = "yes" ; then + STARTUP_AS_BYTECODE= + STARTUP_AS_C=_c + STARTUP_AS_AUTO=_auto + else + STARTUP_AS_BYTECODE=_bytecode + STARTUP_AS_C=_c + STARTUP_AS_AUTO= + fi +fi + MAKE_LOCAL_RACKET=no-local-racket ###### OSKit stuff ####### @@ -1572,11 +1592,13 @@ if test "${enable_racket}" = "" ; then RUN_RACKET_MMM='$(RUN_THIS_RACKET_MMM)' RUN_RACKET_MAIN_VARIANT='$(RUN_THIS_RACKET_MAIN_VARIANT)' CGC_IF_NEEDED_FOR_MMM="cgc" + BOOT_MODE="--boot" else RUN_RACKET_CGC="${enable_racket}" RUN_RACKET_MMM="${enable_racket}" RUN_RACKET_MAIN_VARIANT="${enable_racket}" CGC_IF_NEEDED_FOR_MMM="no-cgc-needed" + BOOT_MODE="--chain" fi ############## libtool ################ @@ -1783,6 +1805,11 @@ AC_SUBST(RUN_RACKET_CGC) AC_SUBST(RUN_RACKET_MMM) AC_SUBST(RUN_RACKET_MAIN_VARIANT) AC_SUBST(CGC_IF_NEEDED_FOR_MMM) +AC_SUBST(BOOT_MODE) + +AC_SUBST(STARTUP_AS_BYTECODE) +AC_SUBST(STARTUP_AS_C) +AC_SUBST(STARTUP_AS_AUTO) AC_SUBST(MAKE_LOCAL_RACKET) diff --git a/racket/src/racket/dynsrc/Makefile.in b/racket/src/racket/dynsrc/Makefile.in index ccaa261257..3780c13303 100644 --- a/racket/src/racket/dynsrc/Makefile.in +++ b/racket/src/racket/dynsrc/Makefile.in @@ -60,13 +60,13 @@ MZDYNDEP = ../mzdyn.o $(srcdir)/../include/ext.exp $(srcdir)/../include/racket.e dynexmpl.o: $(srcdir)/dynexmpl.c $(HEADERS) $(PLAIN_CC) $(ALL_CFLAGS) -c $(srcdir)/dynexmpl.c -o dynexmpl.o -../starter@NOT_MINGW@@EXE_SUFFIX@: $(srcdir)/ustart.c - $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/ustart.c +../starter@NOT_MINGW@@EXE_SUFFIX@: $(srcdir)/../../start/ustart.c + $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/../../start/ustart.c -../starter@MINGW@@EXE_SUFFIX@: $(srcdir)/start.c ../mrstarter@EXE_SUFFIX@ sres.o - $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/start.c sres.o +../starter@MINGW@@EXE_SUFFIX@: $(srcdir)/../../start/start.c ../mrstarter@EXE_SUFFIX@ sres.o + $(PLAIN_CC) $(ALL_CFLAGS) -o ../starter@EXE_SUFFIX@ $(srcdir)/../../start/start.c sres.o ../mrstarter@EXE_SUFFIX@: smrres.o - $(PLAIN_CC) $(ALL_CFLAGS) -mwindows -DMRSTART -o ../mrstarter@EXE_SUFFIX@ $(srcdir)/start.c smrres.o + $(PLAIN_CC) $(ALL_CFLAGS) -mwindows -DMRSTART -o ../mrstarter@EXE_SUFFIX@ $(srcdir)/../../start/start.c smrres.o sres.o: @WINDRES@ -DMZSTART -i $(srcdir)/../../worksp/starters/start.rc -o sres.o diff --git a/racket/src/racket/gc2/Makefile.in b/racket/src/racket/gc2/Makefile.in index 90fbce8809..5d4c18a7a8 100644 --- a/racket/src/racket/gc2/Makefile.in +++ b/racket/src/racket/gc2/Makefile.in @@ -43,8 +43,9 @@ DEF_C_DIRS = $(DEF_COLLECTS_DIR) $(DEF_CONFIG_DIR) # typically redirects to RUN_THIS_RACKET_CGC: RUN_THIS_RACKET_CGC = ../racket@CGC@ -XFORM_SETUP = @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) -cqu $(srcdir)/xform.rkt --setup . --depends -XFORM_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o +SETUP_BOOT = -W "info@compiler/cm error" -l- setup @BOOT_MODE@ $(srcdir)/../../setup-go.rkt ../../compiled +XFORM_SETUP = @RUN_RACKET_CGC@ $(SELF_RACKET_FLAGS) $(SETUP_BOOT) --tag ++out $(srcdir)/xform-mod.rkt --depends +XFORM_NOPRECOMP = $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o ++out XSRCDIR = xsrc XFORM = env XFORM_USE_PRECOMP=$(XSRCDIR)/precomp.h $(XFORM_NOPRECOMP) SRCDIR = $(srcdir)/../src @@ -55,7 +56,6 @@ FOREIGN_NOT_USED_OBJ = $(FOREIGN_USED_OBJ) OBJS = salloc.@LTO@ \ bignum.@LTO@ \ bool.@LTO@ \ - builtin.@LTO@ \ char.@LTO@ \ compenv.@LTO@ \ compile.@LTO@ \ @@ -79,9 +79,9 @@ OBJS = salloc.@LTO@ \ jitstack.@LTO@ \ jitstate.@LTO@ \ letrec_check.@LTO@ \ + linklet.@LTO@ \ list.@LTO@ \ marshal.@LTO@ \ - module.@LTO@ \ mzrt.@LTO@ \ network.@LTO@ \ numarith.@LTO@ \ @@ -100,6 +100,8 @@ OBJS = salloc.@LTO@ \ sema.@LTO@ \ setjmpup.@LTO@ \ sfs.@LTO@ \ + sort.@LTO@ \ + startup.@LTO@ \ string.@LTO@ \ struct.@LTO@ \ symbol.@LTO@ \ @@ -116,7 +118,6 @@ FOREIGN_NOT_USED_C = $(FOREIGN_USED_C) XSRCS = $(XSRCDIR)/salloc.c \ $(XSRCDIR)/bignum.c \ $(XSRCDIR)/bool.c \ - $(XSRCDIR)/builtin.c \ $(XSRCDIR)/char.c \ $(XSRCDIR)/compenv.c \ $(XSRCDIR)/compile.c \ @@ -139,9 +140,9 @@ XSRCS = $(XSRCDIR)/salloc.c \ $(XSRCDIR)/jitstack.c \ $(XSRCDIR)/jitstate.c \ $(XSRCDIR)/letrec_check.c \ + $(XSRCDIR)/linklet.c \ $(XSRCDIR)/list.c \ $(XSRCDIR)/marshal.c \ - $(XSRCDIR)/module.c \ $(XSRCDIR)/network.c \ $(XSRCDIR)/numarith.c \ $(XSRCDIR)/numcomp.c \ @@ -159,6 +160,8 @@ XSRCS = $(XSRCDIR)/salloc.c \ $(XSRCDIR)/sema.c \ $(XSRCDIR)/setjmpup.c \ $(XSRCDIR)/sfs.c \ + $(XSRCDIR)/sort.c \ + $(XSRCDIR)/startup.c \ $(XSRCDIR)/string.c \ $(XSRCDIR)/struct.c \ $(XSRCDIR)/symbol.c \ @@ -187,7 +190,7 @@ xobjects: $(OBJS) main.@LTO@ # picked up in ".sdep": QUIET_DEPS = $(srcdir)/../src/schvers.h $(srcdir)/../sconfig.h ../mzconfig.h -XFORMDEP_NOPRE = $(srcdir)/xform.rkt $(srcdir)/xform-mod.rkt $(QUIET_DEPS) +XFORMDEP_NOPRE = $(srcdir)/xform-mod.rkt $(QUIET_DEPS) XFORMDEP = $(XFORMDEP_NOPRE) $(XSRCDIR)/precomp.h MZRTDEP = $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \ @@ -208,8 +211,6 @@ $(XSRCDIR)/bignum.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/bignum.c $(SRCDIR)/bignum.c $(XSRCDIR)/bool.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/bool.c $(SRCDIR)/bool.c -$(XSRCDIR)/builtin.c: $(XFORMDEP) - $(XFORM) $(XSRCDIR)/builtin.c $(SRCDIR)/builtin.c $(XSRCDIR)/char.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/char.c $(SRCDIR)/char.c $(XSRCDIR)/compenv.c: $(XFORMDEP) @@ -254,10 +255,10 @@ $(XSRCDIR)/jitstate.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/jitstate.c $(SRCDIR)/jitstate.c $(XSRCDIR)/marshal.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/marshal.c $(SRCDIR)/marshal.c -$(XSRCDIR)/module.c: $(XFORMDEP) - $(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c $(XSRCDIR)/letrec_check.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/letrec_check.c $(SRCDIR)/letrec_check.c +$(XSRCDIR)/linklet.c: $(XFORMDEP) + $(XFORM) $(XSRCDIR)/linklet.c $(SRCDIR)/linklet.c $(XSRCDIR)/list.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/list.c $(SRCDIR)/list.c $(XSRCDIR)/network.c: $(XFORMDEP) @@ -294,8 +295,12 @@ $(XSRCDIR)/setjmpup.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/setjmpup.c $(SRCDIR)/setjmpup.c $(XSRCDIR)/sfs.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/sfs.c $(SRCDIR)/sfs.c +$(XSRCDIR)/sort.c: $(XFORMDEP) + $(XFORM) $(XSRCDIR)/sort.c $(SRCDIR)/sort.c +$(XSRCDIR)/startup.c: $(XFORMDEP) ../cstartup.inc $(SRCDIR)/startup-glue.inc + $(XFORM_SETUP) --cpp "$(CPP) -I.. -I$(SRCDIR)/../src $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o ++out $(XSRCDIR)/startup.c $(SRCDIR)/startup.c $(XSRCDIR)/string.c: $(XFORMDEP) $(SRCDIR)/systype.inc - $(XFORM_SETUP) --cpp "$(CPP) -I../src $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o $(XSRCDIR)/string.c $(SRCDIR)/string.c + $(XFORM_SETUP) --cpp "$(CPP) -I../src $(ALL_CPPFLAGS)" @XFORMFLAGS@ -o ++out $(XSRCDIR)/string.c $(SRCDIR)/string.c $(XSRCDIR)/struct.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c $(XSRCDIR)/symbol.c: $(XFORMDEP) @@ -311,10 +316,70 @@ $(XSRCDIR)/validate.c: $(XFORMDEP) $(XSRCDIR)/vector.c: $(XFORMDEP) $(XFORM) $(XSRCDIR)/vector.c $(SRCDIR)/vector.c $(XSRCDIR)/foreign.c: $(XFORMDEP) - $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS) $(LIBFFI_INCLUDE_@OWN_LIBFFI@) -I${SRCDIR}/../../racket/src" @XFORMFLAGS@ -o $(XSRCDIR)/foreign.c $(SRCDIR)/../../foreign/foreign.c + $(XFORM_SETUP) --cpp "$(CPP) $(ALL_CPPFLAGS) $(LIBFFI_INCLUDE_@OWN_LIBFFI@) -I${SRCDIR}/../../racket/src" @XFORMFLAGS@ -o ++out $(XSRCDIR)/foreign.c $(SRCDIR)/../../foreign/foreign.c $(XSRCDIR)/main.c: $(XFORMDEP) $(XFORM_NOPRECOMP) $(XSRCDIR)/main.c $(DEF_C_DIRS) $(srcdir)/../main.c +@INCLUDEDEP@ salloc.d +@INCLUDEDEP@ bignum.d +@INCLUDEDEP@ bool.d +@INCLUDEDEP@ char.d +@INCLUDEDEP@ compenv.d +@INCLUDEDEP@ compile.d +@INCLUDEDEP@ complex.d +@INCLUDEDEP@ dynext.d +@INCLUDEDEP@ env.d +@INCLUDEDEP@ error.d +@INCLUDEDEP@ eval.d +@INCLUDEDEP@ file.d +@INCLUDEDEP@ fun.d +@INCLUDEDEP@ future.d +@INCLUDEDEP@ gmp.d +@INCLUDEDEP@ hash.d +@INCLUDEDEP@ jit.d +@INCLUDEDEP@ jitalloc.d +@INCLUDEDEP@ jitarith.d +@INCLUDEDEP@ jitcall.d +@INCLUDEDEP@ jitcommon.d +@INCLUDEDEP@ jitinline.d +@INCLUDEDEP@ jitprep.d +@INCLUDEDEP@ jitstack.d +@INCLUDEDEP@ jitstate.d +@INCLUDEDEP@ letrec_check.d +@INCLUDEDEP@ linklet.d +@INCLUDEDEP@ list.d +@INCLUDEDEP@ marshal.d +@INCLUDEDEP@ mzrt.d +@INCLUDEDEP@ network.d +@INCLUDEDEP@ numarith.d +@INCLUDEDEP@ number.d +@INCLUDEDEP@ numcomp.d +@INCLUDEDEP@ numstr.d +@INCLUDEDEP@ optimize.d +@INCLUDEDEP@ place.d +@INCLUDEDEP@ port.d +@INCLUDEDEP@ portfun.d +@INCLUDEDEP@ print.d +@INCLUDEDEP@ rational.d +@INCLUDEDEP@ read.d +@INCLUDEDEP@ regexp.d +@INCLUDEDEP@ resolve.d +@INCLUDEDEP@ sema.d +@INCLUDEDEP@ setjmpup.d +@INCLUDEDEP@ sfs.d +@INCLUDEDEP@ sort.d +@INCLUDEDEP@ startup.d +@INCLUDEDEP@ string.d +@INCLUDEDEP@ struct.d +@INCLUDEDEP@ symbol.d +@INCLUDEDEP@ syntax.d +@INCLUDEDEP@ thread.d +@INCLUDEDEP@ type.d +@INCLUDEDEP@ validate.d +@INCLUDEDEP@ vector.d +@INCLUDEDEP@ foreign.d +@INCLUDEDEP@ main.d + $(XSRCDIR)/mzobj.cxx: $(XFORMDEP) $(XFORM_NOPRECOMP) $(XSRCDIR)/mzobj.cxx $(DEF_C_DIRS) $(srcdir)/../../mzcom/mzobj.cxx @@ -324,8 +389,6 @@ bignum.@LTO@: $(XSRCDIR)/bignum.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/bignum.c -o bignum.@LTO@ bool.@LTO@: $(XSRCDIR)/bool.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/bool.c -o bool.@LTO@ -builtin.@LTO@: $(XSRCDIR)/builtin.c - $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/builtin.c -o builtin.@LTO@ char.@LTO@: $(XSRCDIR)/char.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/char.c -o char.@LTO@ compenv.@LTO@: $(XSRCDIR)/compenv.c @@ -373,12 +436,12 @@ jitstate.@LTO@: $(XSRCDIR)/jitstate.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/jitstate.c -o jitstate.@LTO@ letrec_check.@LTO@: $(XSRCDIR)/letrec_check.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/letrec_check.c -o letrec_check.@LTO@ +linklet.@LTO@: $(XSRCDIR)/linklet.c + $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/linklet.c -o linklet.@LTO@ list.@LTO@: $(XSRCDIR)/list.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@ marshal.@LTO@: $(XSRCDIR)/marshal.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/marshal.c -o marshal.@LTO@ -module.@LTO@: $(XSRCDIR)/module.c - $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@ mzrt.@LTO@: $(SRCDIR)/mzrt.c $(XFORMDEP) $(MZRTDEP) $(CC) $(ALL_CFLAGS) -DMZ_PRECISE_GC -c $(SRCDIR)/mzrt.c -o mzrt.@LTO@ network.@LTO@: $(XSRCDIR)/network.c @@ -415,6 +478,10 @@ setjmpup.@LTO@: $(XSRCDIR)/setjmpup.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/setjmpup.c -o setjmpup.@LTO@ sfs.@LTO@: $(XSRCDIR)/sfs.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/sfs.c -o sfs.@LTO@ +sort.@LTO@: $(XSRCDIR)/sort.c + $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/sort.c -o sort.@LTO@ +startup.@LTO@: $(XSRCDIR)/startup.c + $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/startup.c -o startup.@LTO@ string.@LTO@: $(XSRCDIR)/string.c $(CC) $(ALL_CFLAGS) -c $(XSRCDIR)/string.c -o string.@LTO@ struct.@LTO@: $(XSRCDIR)/struct.c @@ -561,9 +628,13 @@ MW_RACKET_LIBS = gc2/libracket3m.dll.a @LDFLAGS@ @LIBS@ -ldelayimp -static-libgc clean: /bin/rm -f ../racket@MMM@ *.@LTO@ $(XSRCDIR)/* - /bin/rm -rf xform-collects /bin/rm -rf Racket.framework +# If "cstartup.inc" hasn't been built, yet, create it as +# a redirect to "startup.inc" +../cstartup.inc: + echo '#include "startup.inc"' > ../cstartup.inc + #-------------------------------------------------- test.@LTO@: $(srcdir)/test.c @@ -571,3 +642,4 @@ test.@LTO@: $(srcdir)/test.c gct: test.@LTO@ gc2.@LTO@ $(CC) -o gct test.@LTO@ gc2.@LTO@ + diff --git a/racket/src/racket/gc2/check-sdep.rkt b/racket/src/racket/gc2/check-sdep.rkt index f4a4a735a9..2a0534f862 100644 --- a/racket/src/racket/gc2/check-sdep.rkt +++ b/racket/src/racket/gc2/check-sdep.rkt @@ -1,6 +1,5 @@ (module xform '#%kernel - (#%require '#%min-stx - '#%utils + (#%require '#%utils '#%paramz) (define-values (loop) @@ -8,35 +7,36 @@ (if (null? paths) (void) (let-values ([(path) (build-path "xsrc" (car paths))]) - (cond - [(regexp-match? #rx"[.][ch]$" path) - (define-values (ts) (file-or-directory-modify-seconds path)) - (define-values (sdep) (path-replace-extension path ".sdep")) - (call-with-escape-continuation - (lambda (esc) - (with-continuation-mark - exception-handler-key - (lambda (exn) - (if (exn:fail? exn) - (begin - (printf "~a\n removing ~a\n" - (exn-message exn) - path) - (delete-file path) - (esc)) - exn)) - (let-values () - (define-values (dloop) - (lambda (paths) - (if (null? paths) - (void) - (let-values () - (define-values (ts2) (file-or-directory-modify-seconds (bytes->path (car paths)))) - (if (ts2 . > . ts) - (error 'changed-dependency "~a" (car paths)) - (dloop (cdr paths))))))) - (dloop (call-with-input-file sdep read))))))]) - (loop (cdr paths)))))) + (if (regexp-match? #rx"[.][ch]$" path) + (let-values () + (define-values (ts) (file-or-directory-modify-seconds path)) + (define-values (sdep) (path-replace-extension path ".sdep")) + (call-with-escape-continuation + (lambda (esc) + (with-continuation-mark + exception-handler-key + (lambda (exn) + (if (exn:fail? exn) + (begin + (printf "~a\n removing ~a\n" + (exn-message exn) + path) + (delete-file path) + (esc)) + exn)) + (let-values () + (define-values (dloop) + (lambda (paths) + (if (null? paths) + (void) + (let-values () + (define-values (ts2) (file-or-directory-modify-seconds (bytes->path (car paths)))) + (if (ts2 . > . ts) + (error 'changed-dependency "~a" (car paths)) + (dloop (cdr paths))))))) + (dloop (call-with-input-file sdep read)))))) + (loop (cdr paths))) + (loop (cdr paths))))))) (if (directory-exists? "xsrc") (loop (directory-list "xsrc")) diff --git a/racket/src/racket/gc2/gc2_dump.h b/racket/src/racket/gc2/gc2_dump.h index 16df257f07..fb451ac2fb 100644 --- a/racket/src/racket/gc2/gc2_dump.h +++ b/racket/src/racket/gc2/gc2_dump.h @@ -8,6 +8,7 @@ typedef char *(*GC_get_type_name_proc)(short t); typedef void (*GC_for_each_found_proc)(void *p); typedef void (*GC_for_each_struct_proc)(void *p, int sz); +typedef int (*GC_record_traced_filter_proc)(void *p); typedef void (*GC_print_tagged_value_proc)(const char *prefix, void *v, uintptr_t diff, int max_w, const char *suffix); @@ -17,6 +18,7 @@ GC2_EXTERN void GC_dump_with_traces(int flags, GC_get_type_name_proc get_type_name, GC_for_each_found_proc for_each_found, short min_trace_for_tag, short max_trace_for_tag, + GC_record_traced_filter_proc record_traced_filter, GC_print_traced_filter_proc print_traced_filter, GC_print_tagged_value_proc print_tagged_value, int path_length_limit, diff --git a/racket/src/racket/gc2/newgc.c b/racket/src/racket/gc2/newgc.c index fc1abf6fec..38efff4c27 100644 --- a/racket/src/racket/gc2/newgc.c +++ b/racket/src/racket/gc2/newgc.c @@ -24,7 +24,7 @@ #define NEWGC_BTC_ACCOUNT /* Configuration of the nursery (a.k.a. generation 0) */ -#define GEN0_INITIAL_SIZE (1 * 1024 * 1024) +#define GEN0_INITIAL_SIZE (4 * 1024 * 1024) #define GEN0_SIZE_FACTOR 0.5 #define GEN0_SIZE_ADDITION (512 * 1024) #define GEN0_MAX_SIZE (32 * 1024 * 1024) @@ -1508,6 +1508,10 @@ static int stress_counter = 0; int scheme_gc_slow_path_started = 1; static int TAKE_SLOW_PATH() { +#ifdef MZ_USE_PLACES + if (!MASTERGC) return 0; +#endif + if (!scheme_gc_slow_path_started) return 0; stress_counter++; if (stress_counter > GC_TRIGGER_COUNT) @@ -6067,6 +6071,7 @@ void GC_dump_with_traces(int flags, GC_get_type_name_proc get_type_name, GC_for_each_found_proc for_each_found, short min_trace_for_tag, short max_trace_for_tag, + GC_record_traced_filter_proc record_traced_filter, GC_print_traced_filter_proc print_traced_filter, GC_print_tagged_value_proc print_tagged_value, int path_length_limit, @@ -6106,7 +6111,8 @@ void GC_dump_with_traces(int flags, for_each_struct(obj_start, gcWORDS_TO_BYTES(info->size)); } if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) { - register_traced_object(obj_start); + if (record_traced_filter(obj_start)) + register_traced_object(obj_start); if (for_each_found) for_each_found(obj_start); } @@ -6131,7 +6137,8 @@ void GC_dump_with_traces(int flags, } if (((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) || ((-tag >= min_trace_for_tag) && (-tag <= max_trace_for_tag))) { - register_traced_object(obj_start); + if (record_traced_filter(obj_start)) + register_traced_object(obj_start); if (for_each_found) for_each_found(obj_start); } @@ -6159,7 +6166,8 @@ void GC_dump_with_traces(int flags, for_each_struct(obj_start, gcWORDS_TO_BYTES(info->size)); } if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) { - register_traced_object(obj_start); + if (record_traced_filter(obj_start)) + register_traced_object(obj_start); if (for_each_found) for_each_found(obj_start); } @@ -6313,7 +6321,7 @@ void GC_dump_with_traces(int flags, void GC_dump(void) { - GC_dump_with_traces(0, NULL, NULL, 0, -1, NULL, NULL, 0, NULL); + GC_dump_with_traces(0, NULL, NULL, 0, -1, NULL, NULL, NULL, 0, NULL); } #ifdef MZ_GC_BACKTRACE @@ -6330,7 +6338,11 @@ int GC_is_tagged(void *p) } #endif return page && ((page->page_type == PAGE_TAGGED) - || (page->page_type == PAGE_PAIR)); + || (page->page_type == PAGE_PAIR) + || ((page->page_type == PAGE_BIG) + && (BIG_PAGE_TO_OBJHEAD(page)->type == PAGE_TAGGED)) + || ((page->page_type == PAGE_MED_NONATOMIC) + && (MED_OBJHEAD(p, page->obj_size)->type == PAGE_TAGGED))); } int GC_is_tagged_start(void *p) diff --git a/racket/src/racket/gc2/setup.rkt b/racket/src/racket/gc2/setup.rkt deleted file mode 100644 index b1939b80fe..0000000000 --- a/racket/src/racket/gc2/setup.rkt +++ /dev/null @@ -1,109 +0,0 @@ - -(when (directory-exists? "xform-collects") - (printf "Removing old xform-collects tree...\n") - (let loop ([dir "xform-collects"]) - (for-each (lambda (x) - (let ([x (build-path dir x)]) - (when (file-exists? x) - (delete-file x)) - (when (directory-exists? x) - (loop x)))) - (directory-list dir)))) - -(printf "Copying tree...\n") - -(use-compiled-file-paths null) - -(unless (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) - (collection-path "racket")) - (let ([p (build-path (current-load-relative-directory) - 'up - 'up - 'up - "lib" - "collects")]) - (printf "Setting collection path: ~s\n" p) - (current-library-collection-paths - (list p)))) - -(require syntax/moddep - compiler/cm) - -(define (go mod-path rel-to target) - (let* ([path (if target - mod-path - (if (module-path-index? mod-path) - (resolve-module-path-index mod-path rel-to) - (resolve-module-path mod-path rel-to)))]) - (unless (symbol? path) - ;; Copy file to here. The filename is from the resolved module - ;; path, so it is ".rkt" even if the source is ".ss". - (let* ([path (if (pair? path) - (cadr path) ; extra from submodule - path)] - [path (if (file-exists? path) - path - (if (regexp-match? #rx#"[.]rkt$" (if (path? path) - (path->bytes path) - path)) - (let ([p2 (path-replace-suffix path #".ss")]) - (if (file-exists? p2) - p2 - path)) - path))] - [target - (or target - (let-values ([(src-base rel-path) - (let loop ([path (simplify-path path)][accum null]) - (let-values ([(base name dir?) (split-path path)]) - (if (string=? (path->string name) "collects") - (values base (cons "xform-collects" accum)) - (loop base (cons name accum)))))]) - (let loop ([place (current-directory)][rel-path rel-path]) - (if (null? (cdr rel-path)) - (build-path place (car rel-path)) - (let ([next (build-path place (car rel-path))]) - (unless (directory-exists? next) - (make-directory next)) - (loop next (cdr rel-path)))))))]) - (unless (file-exists? target) - (printf "Copying ~a to ~a\n" path target) - (copy-file path target) - (let ([code (get-module-code path "no-such-dir")]) - (map (lambda (x) - (go x path #f)) - (apply append (map cdr (module-compiled-imports code)))))))))) - -(unless (directory-exists? "xform-collects") - (make-directory "xform-collects")) -(unless (directory-exists? "xform-collects/xform") - (make-directory "xform-collects/xform")) - -(go (build-path (current-load-relative-directory) "xform-mod.rkt") - #f - "xform-collects/xform/xform-mod.rkt") -;; Readers: -(map (lambda (r) (go r #f #f)) - '(s-exp/lang/reader - racket/base/lang/reader - racket/runtime-config)) - -(current-library-collection-paths - (list (build-path (current-directory) "xform-collects"))) - -(printf "Compiling xform support...\n") - -(let ([mk-cm make-compilation-manager-load/use-compiled-handler] - [old-namespace (current-namespace)]) - (parameterize ([current-namespace (make-empty-namespace)]) - (namespace-attach-module old-namespace ''#%builtin) - (parameterize ([use-compiled-file-paths (list "compiled")]) - (parameterize ([current-load/use-compiled (mk-cm)]) - (namespace-require 'racket/base) - - (dynamic-require 'xform/xform-mod (void)))))) - -(with-output-to-file "xform-collects/version.rkt" - (lambda () (write (version)))) - -(printf "Done making xform-collects.\n") diff --git a/racket/src/racket/gc2/xform.rkt b/racket/src/racket/gc2/xform.rkt deleted file mode 100644 index 93274506d1..0000000000 --- a/racket/src/racket/gc2/xform.rkt +++ /dev/null @@ -1,120 +0,0 @@ -;; This program reads Racket/GRacket C/C++ source and transforms it -;; to work with precise garbage collection or(!) PalmOS. The source -;; is C-pre-processed first, then run though a `lex'-like lexer, -;; ctok.rkt. -;; -;; It probably won't work for other C/C++ code, because it -;; doesn't bother *parsing* the source. Instead, it relies on -;; various heuristics that work for Racket/GRacket code. -;; -;; There are also some input hacks, such as START_XFORM_SKIP. -;; -;; Notable assumptions: -;; No calls of the form (f)(...). -;; For arrays, records, and non-pointers, pass by address only. -;; No gc-triggering code in .h files. -;; No instance vars declared as function pointers without a typedef -;; for the func ptr type. -;; -;; BUGS: Doesn't check for pointer comparisons where one of the -;; comparees is a function call. This doesn't happen in -;; Racket/GRacket (or, because of this bug, shouldn't!). -;; -;; Passing the address of a pointer is dangerous; make sure -;; that the pointer is used afterward, otherwise it pointer -;; might not get updated during GC. -;; -;; A "return;" can get converted to "{ ; return; };", -;; which can break "if (...) return; else ...". - -;; To call for Precise GC: -;; racket -qr xform.rkt [--setup] [--precompile] [--precompiled ] [--notes] [--depends] [--cgc] -;; -;; Or: Set the XFORM_PRECOMP=yes environment variable to imply --precompile -;; Set the XFORM_USE_PRECOMP= to imply --precompiled -;; -;; To call for Palm: -;; racket -qr xform.rkt [--setup] [--notes] [--depends] --palm - -;; General code conventions: -;; e means a list of tokens, often ending in a '|;| token -;; -e means a reversed list of tokens - -(module xform '#%kernel - (#%require '#%min-stx) - - (define-values (rel-dir) - (if (string=? "--setup" (vector-ref (current-command-line-arguments) 0)) - (vector-ref (current-command-line-arguments) 1) - ".")) - - (define-values (here-dir) - (let-values ([(base name dir?) - (split-path - (resolved-module-path-name - (module-path-index-resolve - (syntax-source-module (quote-syntax here)))))]) - (build-path base rel-dir))) - - (if (string=? "--setup" - (vector-ref (current-command-line-arguments) 0)) - - ;; Setup an xform-collects tree for running xform. - ;; Delete existing xform-collects tree if it's for an old version - (let retry () - (parameterize ([current-directory rel-dir]) - (unless (and (file-exists? "xform-collects/version.rkt") - (equal? (version) - (with-input-from-file "xform-collects/version.rkt" read)) - (>= (file-or-directory-modify-seconds (build-path "xform-collects/xform/xform-mod.rkt")) - (file-or-directory-modify-seconds (build-path here-dir "xform-mod.rkt")))) - ;; In case multiple xforms run in parallel, use a lock file - ;; so that only one is building. - (let ([lock-file "XFORM-LOCK"]) - ((call-with-escape-continuation - (lambda (escape) - (parameterize ([uncaught-exception-handler - (lambda (exn) - (escape - (lambda () - (if (exn:fail:filesystem:exists? exn) - (begin - (printf "Lock file exists: ~a\n" - (path->complete-path lock-file)) - (printf " (If this isn't a parallel make, then delete it.)\n") - (printf " Waiting until the lock file disappears...\n") - (let loop () - (flush-output) - (sleep 0.1) - (if (file-exists? lock-file) - (loop) - (printf " ... continuing\n"))) - (retry)) - (raise exn)))))]) - (dynamic-wind - (lambda () - (close-output-port (open-output-file lock-file 'error))) - (lambda () - (namespace-require 'racket/base) - (load (build-path here-dir "setup.rkt")) - void) - (lambda () - (delete-file lock-file)))))))))) - - (use-compiled-file-paths '("compiled")) - - (current-library-collection-paths (list (build-path (build-path (current-directory) rel-dir) "xform-collects"))) - - (let ([ns (make-empty-namespace)]) - (dynamic-require ''#%builtin #f) - (namespace-attach-module (current-namespace) ''#%builtin ns) - (current-namespace ns)) - - (error-print-width 100) - - (dynamic-require 'xform/xform-mod #f)) - - ;; Otherwise, we assume that it's ok to use the collects - (dynamic-require (build-path here-dir - "xform-mod.rkt") - #f))) diff --git a/racket/src/racket/include/mzwin.def b/racket/src/racket/include/mzwin.def index 22673bc4a5..a05005c5b0 100644 --- a/racket/src/racket/include/mzwin.def +++ b/racket/src/racket/include/mzwin.def @@ -195,11 +195,6 @@ EXPORTS scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval - scheme_eval_compiled_stx_string - scheme_load_compiled_stx_string - scheme_compiled_stx_symbol - scheme_eval_compiled_sized_string - scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array scheme_malloc_code scheme_malloc_permanent_code @@ -534,21 +529,16 @@ EXPORTS scheme_make_envunbox scheme_lookup_global scheme_global_bucket - scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket - scheme_install_macro - scheme_save_initial_module_set - scheme_primitive_module - scheme_finish_primitive_module - scheme_set_primitive_module_phaseless - scheme_protect_primitive_provide scheme_make_modidx - scheme_apply_for_syntax_in_env scheme_dynamic_require + scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path + scheme_is_module_path_index + scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff --git a/racket/src/racket/include/mzwin3m.def b/racket/src/racket/include/mzwin3m.def index 888c0ae396..fed09bd969 100644 --- a/racket/src/racket/include/mzwin3m.def +++ b/racket/src/racket/include/mzwin3m.def @@ -195,11 +195,6 @@ EXPORTS scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval - scheme_eval_compiled_stx_string - scheme_load_compiled_stx_string - scheme_compiled_stx_symbol - scheme_eval_compiled_sized_string - scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array GC_malloc GC_malloc_atomic @@ -548,21 +543,16 @@ EXPORTS scheme_make_envunbox scheme_lookup_global scheme_global_bucket - scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket - scheme_install_macro - scheme_save_initial_module_set - scheme_primitive_module - scheme_finish_primitive_module - scheme_set_primitive_module_phaseless - scheme_protect_primitive_provide scheme_make_modidx - scheme_apply_for_syntax_in_env scheme_dynamic_require + scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path + scheme_is_module_path_index + scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff --git a/racket/src/racket/include/racket.exp b/racket/src/racket/include/racket.exp index cc42bcbeee..26c7acb30d 100644 --- a/racket/src/racket/include/racket.exp +++ b/racket/src/racket/include/racket.exp @@ -202,11 +202,6 @@ scheme_current_continuation_marks scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval -scheme_eval_compiled_stx_string -scheme_load_compiled_stx_string -scheme_compiled_stx_symbol -scheme_eval_compiled_sized_string -scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array GC_malloc GC_malloc_atomic @@ -550,21 +545,16 @@ scheme_add_global_symbol scheme_make_envunbox scheme_lookup_global scheme_global_bucket -scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket -scheme_install_macro -scheme_save_initial_module_set -scheme_primitive_module -scheme_finish_primitive_module -scheme_set_primitive_module_phaseless -scheme_protect_primitive_provide scheme_make_modidx -scheme_apply_for_syntax_in_env scheme_dynamic_require +scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path +scheme_is_module_path_index +scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff --git a/racket/src/racket/include/racket3m.exp b/racket/src/racket/include/racket3m.exp index 36d2dcfd82..82d6aa0b5b 100644 --- a/racket/src/racket/include/racket3m.exp +++ b/racket/src/racket/include/racket3m.exp @@ -202,11 +202,6 @@ scheme_current_continuation_marks scheme_extract_one_cc_mark scheme_extract_one_cc_mark_to_tag scheme_do_eval -scheme_eval_compiled_stx_string -scheme_load_compiled_stx_string -scheme_compiled_stx_symbol -scheme_eval_compiled_sized_string -scheme_eval_compiled_sized_string_with_magic scheme_detach_multple_array GC_malloc GC_malloc_atomic @@ -555,21 +550,16 @@ scheme_add_global_symbol scheme_make_envunbox scheme_lookup_global scheme_global_bucket -scheme_global_keyword_bucket scheme_module_bucket scheme_builtin_value scheme_set_global_bucket -scheme_install_macro -scheme_save_initial_module_set -scheme_primitive_module -scheme_finish_primitive_module -scheme_set_primitive_module_phaseless -scheme_protect_primitive_provide scheme_make_modidx -scheme_apply_for_syntax_in_env scheme_dynamic_require +scheme_dynamic_require_reader scheme_namespace_require scheme_is_module_path +scheme_is_module_path_index +scheme_is_resolved_module_path scheme_datum_to_kernel_stx scheme_module_is_declared scheme_intern_symbol diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index a6ac342225..6cc7c07896 100644 --- a/racket/src/racket/include/scheme.h +++ b/racket/src/racket/include/scheme.h @@ -702,13 +702,19 @@ typedef struct Scheme_Offset_Cptr #define scheme_make_character(ch) ((((mzchar)ch) < 256) ? scheme_char_constants[(unsigned char)(ch)] : scheme_make_char(ch)) #define scheme_make_ascii_character(ch) scheme_char_constants[(unsigned char)(ch)] -#define scheme_uchar_find(table, x) (table[(x >> 8) & 0x1FFF][x & 0xFF]) +#define SCHEME_UCHAR_FIND_SHIFT 8 +#define SCHEME_UCHAR_FIND_HI_MASK 0x1FFF +#define SCHEME_UCHAR_FIND_LO_MASK 0xFF + +#define scheme_uchar_find(table, x) (table[(x >> SCHEME_UCHAR_FIND_SHIFT) & SCHEME_UCHAR_FIND_HI_MASK][x & SCHEME_UCHAR_FIND_LO_MASK]) + +#define SCHEME_ISSPACE_BIT 0x10 #define scheme_isblank(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1) #define scheme_issymbol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2) #define scheme_ispunc(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4) #define scheme_iscontrol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8) -#define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x10) +#define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & SCHEME_ISSPACE_BIT) /* #define scheme_isSOMETHING(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x20) - not yet used */ #define scheme_isdigit(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x40) #define scheme_isalpha(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x80) @@ -1168,15 +1174,6 @@ typedef struct Scheme_Thread { struct Scheme_Overflow *overflow; - struct Scheme_Comp_Env *current_local_env; - Scheme_Object *current_local_scope; - Scheme_Object *current_local_use_scope; - Scheme_Object *current_local_name; - Scheme_Object *current_local_modidx; - Scheme_Env *current_local_menv; - Scheme_Object *current_local_bindings; - intptr_t current_phase_shift; - struct Scheme_Marshal_Tables *current_mt; struct Optimize_Info *constant_folding; /* compiler hack */ @@ -1328,31 +1325,14 @@ enum { MZCONFIG_INIT_EXN_HANDLER, - MZCONFIG_EVAL_HANDLER, - MZCONFIG_COMPILE_HANDLER, - MZCONFIG_LOAD_HANDLER, - MZCONFIG_LOAD_COMPILED_HANDLER, - MZCONFIG_PRINT_HANDLER, MZCONFIG_PROMPT_READ_HANDLER, MZCONFIG_READ_HANDLER, MZCONFIG_READ_INPUT_PORT_HANDLER, - MZCONFIG_READTABLE, - MZCONFIG_READER_GUARD, - - MZCONFIG_CAN_READ_GRAPH, - MZCONFIG_CAN_READ_COMPILED, - MZCONFIG_CAN_READ_BOX, + MZCONFIG_CASE_SENS, MZCONFIG_CAN_READ_PIPE_QUOTE, - MZCONFIG_CAN_READ_DOT, - MZCONFIG_CAN_READ_INFIX_DOT, - MZCONFIG_CAN_READ_QUASI, - MZCONFIG_CAN_READ_READER, - MZCONFIG_CAN_READ_LANG, - MZCONFIG_READ_DECIMAL_INEXACT, - MZCONFIG_READ_CDOT, - + MZCONFIG_PRINT_GRAPH, MZCONFIG_PRINT_STRUCT, MZCONFIG_PRINT_BOX, @@ -1366,12 +1346,6 @@ enum { MZCONFIG_PRINT_LONG_BOOLEAN, MZCONFIG_PRINT_AS_QQ, - MZCONFIG_CASE_SENS, - MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, - MZCONFIG_CURLY_BRACES_ARE_PARENS, - MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, - MZCONFIG_CURLY_BRACES_ARE_TAGGED, - MZCONFIG_ERROR_PRINT_WIDTH, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, @@ -1389,18 +1363,9 @@ enum { MZCONFIG_CODE_INSPECTOR, MZCONFIG_PLUMBER, - MZCONFIG_USE_COMPILED_KIND, - MZCONFIG_USE_COMPILED_ROOTS, - MZCONFIG_USE_USER_PATHS, - MZCONFIG_USE_LINK_PATHS, - MZCONFIG_USE_COMPILED_FILE_CHECK, - MZCONFIG_LOAD_DIRECTORY, MZCONFIG_WRITE_DIRECTORY, - MZCONFIG_COLLECTION_PATHS, - MZCONFIG_COLLECTION_LINKS, - MZCONFIG_PORT_PRINT_HANDLER, MZCONFIG_LOAD_EXTENSION_HANDLER, @@ -1413,10 +1378,7 @@ enum { MZCONFIG_RANDOM_STATE, - MZCONFIG_CURRENT_MODULE_RESOLVER, - MZCONFIG_CURRENT_MODULE_NAME, MZCONFIG_CURRENT_MODULE_SRC, - MZCONFIG_CURRENT_MODULE_LOAD_PATH, MZCONFIG_ERROR_PRINT_SRCLOC, @@ -1439,8 +1401,6 @@ enum { MZCONFIG_LOAD_DELAY_ENABLED, MZCONFIG_DELAY_LOAD_INFO, - MZCONFIG_EXPAND_OBSERVE, - MZCONFIG_LOGGER, __MZCONFIG_BUILTIN_COUNT__ @@ -1588,13 +1548,6 @@ typedef struct Scheme_Logger Scheme_Logger; #define SCHEME_GUARD_FILE_DELETE 0x8 #define SCHEME_GUARD_FILE_EXISTS 0x10 -/*========================================================================*/ -/* modules */ -/*========================================================================*/ - -typedef void (*Scheme_Invoke_Proc)(Scheme_Env *env, intptr_t phase_shift, - Scheme_Object *self_modidx, void *data); - /*========================================================================*/ /* evaluation */ /*========================================================================*/ @@ -1932,7 +1885,6 @@ MZ_EXTERN void (*scheme_sleep)(float seconds, void *fds); MZ_EXTERN void (*scheme_notify_multithread)(int on); MZ_EXTERN void (*scheme_wakeup_on_input)(void *fds); MZ_EXTERN int (*scheme_check_for_break)(void); -MZ_EXTERN Scheme_Object *(*scheme_module_demand_hook)(int c, Scheme_Object **a); #ifdef MZ_PRECISE_GC MZ_EXTERN void *(*scheme_get_external_stack_val)(void); MZ_EXTERN void (*scheme_set_external_stack_val)(void *); diff --git a/racket/src/racket/include/schthread.h b/racket/src/racket/include/schthread.h index 35d2217e6a..7069f90c4f 100644 --- a/racket/src/racket/include/schthread.h +++ b/racket/src/racket/include/schthread.h @@ -158,7 +158,6 @@ typedef struct Thread_Local_Variables { void *jit_buffer_cache_; intptr_t jit_buffer_cache_size_; int jit_buffer_cache_registered_; - struct Scheme_Object *quick_stx_; int scheme_continuation_application_count_; int scheme_cont_capture_count_; int scheme_prompt_capture_count_; @@ -167,8 +166,6 @@ typedef struct Thread_Local_Variables { struct Scheme_Prompt *available_regular_prompt_; struct Scheme_Dynamic_Wind *available_prompt_dw_; struct Scheme_Meta_Continuation *available_prompt_mc_; - struct Scheme_Object *cwv_stx_; - int cwv_stx_phase_; struct Scheme_Cont *offstack_cont_; struct Scheme_Overflow *offstack_overflow_; struct Scheme_Overflow_Jmp *scheme_overflow_jmp_; @@ -187,9 +184,6 @@ typedef struct Thread_Local_Variables { mz_long_double scheme_jit_save_extfp2_; #endif struct Scheme_Bucket_Table *starts_table_; - struct Scheme_Bucket_Table *submodule_empty_modidx_table_; - struct Scheme_Modidx *modidx_caching_chain_; - struct Scheme_Object *global_shift_cache_; struct mz_proc_thread *proc_thread_self_; struct Scheme_Object *scheme_orig_stdout_port_; struct Scheme_Object *scheme_orig_stderr_port_; @@ -233,15 +227,8 @@ typedef struct Thread_Local_Variables { void *stack_copy_cache_[STACK_COPY_CACHE_SIZE]; intptr_t stack_copy_size_cache_[STACK_COPY_CACHE_SIZE]; int scc_pos_; - mzlonglong scope_counter_; - struct Scheme_Object *last_phase_shift_; - struct Scheme_Object *nominal_ipair_cache_; - struct Scheme_Bucket_Table *taint_intern_table_; - struct Binding_Cache_Entry *binding_cache_table_; - intptr_t binding_cache_pos_; - intptr_t binding_cache_len_; - struct Scheme_Scope_Set *recent_scope_sets_[2][NUM_RECENT_SCOPE_SETS]; - int recent_scope_sets_pos_[2]; + struct Scheme_Instance *scheme_startup_instance_; + struct startup_instance_top_t *c_startup_instance_top_; struct Scheme_Thread *scheme_current_thread_; struct Scheme_Thread *scheme_main_thread_; struct Scheme_Thread *scheme_first_thread_; @@ -292,16 +279,12 @@ typedef struct Thread_Local_Variables { struct Scheme_Logger *scheme_gc_logger_; struct Scheme_Logger *scheme_future_logger_; struct Scheme_Logger *scheme_place_logger_; - int intdef_counter_; int scheme_overflow_count_; struct Scheme_Object *original_pwd_; void *file_path_wc_buffer_; intptr_t scheme_hash_request_count_; intptr_t scheme_hash_iteration_count_; - struct Scheme_Env *initial_modules_env_; - int num_initial_modules_; - struct Scheme_Object **initial_modules_; - int generate_lifts_count_; + struct Scheme_Bucket_Table *scheme_namespace_to_env_; int special_is_ok_; int scheme_force_port_closed_; int fd_reserved_; @@ -334,7 +317,6 @@ typedef struct Thread_Local_Variables { int gensym_counter_; struct Scheme_Object *dummy_input_port_; struct Scheme_Object *dummy_output_port_; - struct Scheme_Bucket_Table *place_local_modpath_table_; struct Scheme_Hash_Table *opened_libs_; struct mzrt_mutex *jit_lock_; struct free_list_entry *free_list_; @@ -355,8 +337,6 @@ typedef struct Thread_Local_Variables { struct Scheme_Place *all_child_places_; struct Scheme_Place_Bi_Channel_Link *place_channel_links_; struct Scheme_Object **reusable_ifs_stack_; - struct Scheme_Object *empty_self_shift_cache_; - struct Scheme_Bucket_Table *scheme_module_code_cache_; struct Scheme_Object *group_member_cache_; struct Scheme_Prefix *scheme_prefix_finalize_; struct Scheme_Prefix *scheme_inc_prefix_finalize_; @@ -373,17 +353,9 @@ typedef struct Thread_Local_Variables { struct Scheme_Object *configuration_callback_cache_[2]; struct FFI_Orig_Place_Call *cached_orig_place_todo_; struct Scheme_Hash_Table *ffi_lock_ht_; - struct Scheme_Object *scheme_sys_wraps0_; - struct Scheme_Object *scheme_sys_wraps1_; - struct Scheme_Object *scheme_module_stx_; - struct Scheme_Object *scheme_modulestar_stx_; - struct Scheme_Object *scheme_module_begin_stx_; - struct Scheme_Object *scheme_begin_stx_; - struct Scheme_Object *scheme_define_values_stx_; - struct Scheme_Object *scheme_define_syntaxes_stx_; - struct Scheme_Object *scheme_top_stx_; - struct Scheme_Object *scheme_begin_for_syntax_stx_; - struct Scheme_Object *more_constant_stxes_[NUM_MORE_CONSTANT_STXES]; + struct Scheme_Object *is_syntax_proc_; + struct Scheme_Object *expander_syntax_to_datum_proc_; + struct Scheme_Hash_Table *local_primitive_tables_; } Thread_Local_Variables; #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) @@ -391,6 +363,7 @@ typedef struct Thread_Local_Variables { # include MZ_EXTERN pthread_key_t scheme_thread_local_key; # if defined(__APPLE__) && defined(__MACH__) +# define PREFER_TO_CACHE_THREAD_LOCAL MZ_EXTERN int scheme_thread_local_offset; # endif # ifndef INLINE_GETSPECIFIC_ASSEMBLY_CODE @@ -554,7 +527,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define jit_buffer_cache XOA (scheme_get_thread_local_variables()->jit_buffer_cache_) #define jit_buffer_cache_size XOA (scheme_get_thread_local_variables()->jit_buffer_cache_size_) #define jit_buffer_cache_registered XOA (scheme_get_thread_local_variables()->jit_buffer_cache_registered_) -#define quick_stx XOA (scheme_get_thread_local_variables()->quick_stx_) #define scheme_continuation_application_count XOA (scheme_get_thread_local_variables()->scheme_continuation_application_count_) #define scheme_cont_capture_count XOA (scheme_get_thread_local_variables()->scheme_cont_capture_count_) #define scheme_prompt_capture_count XOA (scheme_get_thread_local_variables()->scheme_prompt_capture_count_) @@ -563,8 +535,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define available_regular_prompt XOA (scheme_get_thread_local_variables()->available_regular_prompt_) #define available_prompt_dw XOA (scheme_get_thread_local_variables()->available_prompt_dw_) #define available_prompt_mc XOA (scheme_get_thread_local_variables()->available_prompt_mc_) -#define cwv_stx XOA (scheme_get_thread_local_variables()->cwv_stx_) -#define cwv_stx_phase XOA (scheme_get_thread_local_variables()->cwv_stx_phase_) #define offstack_cont XOA (scheme_get_thread_local_variables()->offstack_cont_) #define offstack_overflow XOA (scheme_get_thread_local_variables()->offstack_overflow_) #define scheme_overflow_jmp XOA (scheme_get_thread_local_variables()->scheme_overflow_jmp_) @@ -584,9 +554,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define scheme_jit_save_extfp2 XOA (scheme_get_thread_local_variables()->scheme_jit_save_extfp2_) #endif #define starts_table XOA (scheme_get_thread_local_variables()->starts_table_) -#define submodule_empty_modidx_table XOA (scheme_get_thread_local_variables()->submodule_empty_modidx_table_) -#define modidx_caching_chain XOA (scheme_get_thread_local_variables()->modidx_caching_chain_) -#define global_shift_cache XOA (scheme_get_thread_local_variables()->global_shift_cache_) #define proc_thread_self XOA (scheme_get_thread_local_variables()->proc_thread_self_) #define scheme_orig_stdout_port XOA (scheme_get_thread_local_variables()->scheme_orig_stdout_port_) #define scheme_orig_stderr_port XOA (scheme_get_thread_local_variables()->scheme_orig_stderr_port_) @@ -630,15 +597,8 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define stack_copy_cache XOA (scheme_get_thread_local_variables()->stack_copy_cache_) #define stack_copy_size_cache XOA (scheme_get_thread_local_variables()->stack_copy_size_cache_) #define scc_pos XOA (scheme_get_thread_local_variables()->scc_pos_) -#define nominal_ipair_cache XOA (scheme_get_thread_local_variables()->nominal_ipair_cache_) -#define scope_counter XOA (scheme_get_thread_local_variables()->scope_counter_) -#define last_phase_shift XOA (scheme_get_thread_local_variables()->last_phase_shift_) -#define taint_intern_table XOA (scheme_get_thread_local_variables()->taint_intern_table_) -#define binding_cache_table XOA (scheme_get_thread_local_variables()->binding_cache_table_) -#define binding_cache_pos XOA (scheme_get_thread_local_variables()->binding_cache_pos_) -#define binding_cache_len XOA (scheme_get_thread_local_variables()->binding_cache_len_) -#define recent_scope_sets XOA (scheme_get_thread_local_variables()->recent_scope_sets_) -#define recent_scope_sets_pos XOA (scheme_get_thread_local_variables()->recent_scope_sets_pos_) +#define scheme_startup_instance XOA (scheme_get_thread_local_variables()->scheme_startup_instance_) +#define c_startup_instance_top XOA (scheme_get_thread_local_variables()->c_startup_instance_top_) #define scheme_current_thread XOA (scheme_get_thread_local_variables()->scheme_current_thread_) #define scheme_main_thread XOA (scheme_get_thread_local_variables()->scheme_main_thread_) #define scheme_first_thread XOA (scheme_get_thread_local_variables()->scheme_first_thread_) @@ -690,16 +650,12 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define scheme_gc_logger XOA (scheme_get_thread_local_variables()->scheme_gc_logger_) #define scheme_future_logger XOA (scheme_get_thread_local_variables()->scheme_future_logger_) #define scheme_place_logger XOA (scheme_get_thread_local_variables()->scheme_place_logger_) -#define intdef_counter XOA (scheme_get_thread_local_variables()->intdef_counter_) #define scheme_overflow_count XOA (scheme_get_thread_local_variables()->scheme_overflow_count_) #define original_pwd XOA (scheme_get_thread_local_variables()->original_pwd_) #define file_path_wc_buffer XOA (scheme_get_thread_local_variables()->file_path_wc_buffer_) #define scheme_hash_request_count XOA (scheme_get_thread_local_variables()->scheme_hash_request_count_) #define scheme_hash_iteration_count XOA (scheme_get_thread_local_variables()->scheme_hash_iteration_count_) -#define initial_modules_env XOA (scheme_get_thread_local_variables()->initial_modules_env_) -#define num_initial_modules XOA (scheme_get_thread_local_variables()->num_initial_modules_) -#define initial_modules XOA (scheme_get_thread_local_variables()->initial_modules_) -#define generate_lifts_count XOA (scheme_get_thread_local_variables()->generate_lifts_count_) +#define scheme_namespace_to_env XOA (scheme_get_thread_local_variables()->scheme_namespace_to_env_) #define special_is_ok XOA (scheme_get_thread_local_variables()->special_is_ok_) #define scheme_force_port_closed XOA (scheme_get_thread_local_variables()->scheme_force_port_closed_) #define fd_reserved XOA (scheme_get_thread_local_variables()->fd_reserved_) @@ -732,7 +688,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define gensym_counter XOA (scheme_get_thread_local_variables()->gensym_counter_) #define dummy_input_port XOA (scheme_get_thread_local_variables()->dummy_input_port_) #define dummy_output_port XOA (scheme_get_thread_local_variables()->dummy_output_port_) -#define place_local_modpath_table XOA (scheme_get_thread_local_variables()->place_local_modpath_table_) #define opened_libs XOA (scheme_get_thread_local_variables()->opened_libs_) #define jit_lock XOA (scheme_get_thread_local_variables()->jit_lock_) #define free_list XOA (scheme_get_thread_local_variables()->free_list_) @@ -753,8 +708,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define all_child_places XOA (scheme_get_thread_local_variables()->all_child_places_) #define place_channel_links XOA (scheme_get_thread_local_variables()->place_channel_links_) #define reusable_ifs_stack XOA (scheme_get_thread_local_variables()->reusable_ifs_stack_) -#define empty_self_shift_cache XOA (scheme_get_thread_local_variables()->empty_self_shift_cache_) -#define scheme_module_code_cache XOA (scheme_get_thread_local_variables()->scheme_module_code_cache_) #define group_member_cache XOA (scheme_get_thread_local_variables()->group_member_cache_) #define scheme_prefix_finalize XOA (scheme_get_thread_local_variables()->scheme_prefix_finalize_) #define scheme_inc_prefix_finalize XOA (scheme_get_thread_local_variables()->scheme_inc_prefix_finalize_) @@ -771,17 +724,9 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define configuration_callback_cache XOA (scheme_get_thread_local_variables()->configuration_callback_cache_) #define cached_orig_place_todo XOA (scheme_get_thread_local_variables()->cached_orig_place_todo_) #define ffi_lock_ht XOA (scheme_get_thread_local_variables()->ffi_lock_ht_) -#define scheme_sys_wraps0 XOA (scheme_get_thread_local_variables()->scheme_sys_wraps0_) -#define scheme_sys_wraps1 XOA (scheme_get_thread_local_variables()->scheme_sys_wraps1_) -#define scheme_module_stx XOA (scheme_get_thread_local_variables()->scheme_module_stx_) -#define scheme_modulestar_stx XOA (scheme_get_thread_local_variables()->scheme_modulestar_stx_) -#define scheme_module_begin_stx XOA (scheme_get_thread_local_variables()->scheme_module_begin_stx_) -#define scheme_begin_stx XOA (scheme_get_thread_local_variables()->scheme_begin_stx_) -#define scheme_define_values_stx XOA (scheme_get_thread_local_variables()->scheme_define_values_stx_) -#define scheme_define_syntaxes_stx XOA (scheme_get_thread_local_variables()->scheme_define_syntaxes_stx_) -#define scheme_top_stx XOA (scheme_get_thread_local_variables()->scheme_top_stx_) -#define scheme_begin_for_syntax_stx XOA (scheme_get_thread_local_variables()->scheme_begin_for_syntax_stx_) -#define more_constant_stxes XOA (scheme_get_thread_local_variables()->more_constant_stxes_) +#define is_syntax_proc XOA (scheme_get_thread_local_variables()->is_syntax_proc_) +#define expander_syntax_to_datum_proc XOA (scheme_get_thread_local_variables()->expander_syntax_to_datum_proc_) +#define local_primitive_tables XOA (scheme_get_thread_local_variables()->local_primitive_tables_) /* **************************************** */ diff --git a/racket/src/racket/make-configure b/racket/src/racket/make-configure index 99aede84ae..ad9f36381f 100755 --- a/racket/src/racket/make-configure +++ b/racket/src/racket/make-configure @@ -15,6 +15,11 @@ tgt="../rktio/configure" echo "Creating $tgt from $src" autoconf "$src" > "$tgt" chmod +x "$tgt" +src="../cs/c/configure.ac" +tgt="../cs/c/configure" +echo "Creating $tgt from $src" +autoconf "$src" > "$tgt" +chmod +x "$tgt" exit 0 |# #lang racket/base diff --git a/racket/src/racket/mksystem.rkt b/racket/src/racket/mksystem.rkt index 67713ba1d6..061873d2dd 100644 --- a/racket/src/racket/mksystem.rkt +++ b/racket/src/racket/mksystem.rkt @@ -1,11 +1,11 @@ (module mkincludes '#%kernel - (#%require '#%min-stx) ;; Arguments are ;; [ <3m-exe-suffix> ] (define-values (args) (current-command-line-arguments)) (define-values (ht) - (if (or (= (vector-length args) 1) + (if (if (= (vector-length args) 1) + #t (equal? (vector-ref args (- (vector-length args) 1)) (vector-ref args (- (vector-length args) 2)))) ;; Not cross-compiling diff --git a/racket/src/racket/src/Makefile.in b/racket/src/racket/src/Makefile.in index 777ec195ae..1e63d8096d 100644 --- a/racket/src/racket/src/Makefile.in +++ b/racket/src/racket/src/Makefile.in @@ -17,7 +17,6 @@ ALL_CFLAGS = $(CFLAGS) -I$(builddir)/.. -I$(srcdir)/../include $(RKTIO_INC) $(C OBJS = salloc.@LTO@ \ bignum.@LTO@ \ bool.@LTO@ \ - builtin.@LTO@ \ char.@LTO@ \ compenv.@LTO@ \ compile.@LTO@ \ @@ -41,9 +40,9 @@ OBJS = salloc.@LTO@ \ jitstack.@LTO@ \ jitstate.@LTO@ \ letrec_check.@LTO@ \ + linklet.@LTO@ \ list.@LTO@ \ marshal.@LTO@ \ - module.@LTO@ \ mzrt.@LTO@ \ network.@LTO@ \ numarith.@LTO@ \ @@ -62,6 +61,8 @@ OBJS = salloc.@LTO@ \ sema.@LTO@ \ setjmpup.@LTO@ \ sfs.@LTO@ \ + sort.@LTO@ \ + startup.@LTO@ \ string.@LTO@ \ struct.@LTO@ \ symbol.@LTO@ \ @@ -75,7 +76,6 @@ OBJS = salloc.@LTO@ \ SRCS = $(srcdir)/salloc.c \ $(srcdir)/bignum.c \ $(srcdir)/bool.c \ - $(srcdir)/builtin.c \ $(srcdir)/char.c \ $(srcdir)/compenv.c \ $(srcdir)/compile.c \ @@ -99,9 +99,9 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/jitstack.c \ $(srcdir)/jitstate.c \ $(srcdir)/letrec_check.c \ + $(srcdir)/linklet.c \ $(srcdir)/list.c \ $(srcdir)/marshal.c \ - $(srcdir)/module.c \ $(srcdir)/mzrt.c \ $(srcdir)/network.c \ $(srcdir)/numarith.c \ @@ -120,6 +120,7 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/sema.c \ $(srcdir)/setjmpup.c \ $(srcdir)/sfs.c \ + $(srcdir)/startup.c \ $(srcdir)/string.c \ $(srcdir)/struct.c \ $(srcdir)/symbol.c \ @@ -185,8 +186,6 @@ bignum.@LTO@: $(srcdir)/bignum.c $(srcdir)/bgnfloat.inc $(CC) $(ALL_CFLAGS) -c $(srcdir)/bignum.c -o bignum.@LTO@ bool.@LTO@: $(srcdir)/bool.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/bool.c -o bool.@LTO@ -builtin.@LTO@: $(srcdir)/builtin.c - $(CC) $(ALL_CFLAGS) -c $(srcdir)/builtin.c -o builtin.@LTO@ char.@LTO@: $(srcdir)/char.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/char.c -o char.@LTO@ compenv.@LTO@: $(srcdir)/compenv.c @@ -234,12 +233,12 @@ jitstate.@LTO@: $(srcdir)/jitstate.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/jitstate.c -o jitstate.@LTO@ letrec_check.@LTO@: $(srcdir)/letrec_check.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/letrec_check.c -o letrec_check.@LTO@ +linklet.@LTO@: $(srcdir)/linklet.c + $(CC) $(ALL_CFLAGS) -c $(srcdir)/linklet.c -o linklet.@LTO@ list.@LTO@: $(srcdir)/list.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/list.c -o list.@LTO@ marshal.@LTO@: $(srcdir)/marshal.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/marshal.c -o marshal.@LTO@ -module.@LTO@: $(srcdir)/module.c - $(CC) $(ALL_CFLAGS) -c $(srcdir)/module.c -o module.@LTO@ mzrt.@LTO@: $(srcdir)/mzrt.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/mzrt.c -o mzrt.@LTO@ network.@LTO@: $(srcdir)/network.c @@ -276,6 +275,10 @@ setjmpup.@LTO@: $(srcdir)/setjmpup.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/setjmpup.c -o setjmpup.@LTO@ sfs.@LTO@: $(srcdir)/sfs.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/sfs.c -o sfs.@LTO@ +sort.@LTO@: $(srcdir)/sort.c + $(CC) $(ALL_CFLAGS) -c $(srcdir)/sort.c -o sort.@LTO@ +startup.@LTO@: $(srcdir)/startup.c + $(CC) $(ALL_CFLAGS) -c $(srcdir)/startup.c -I.. -I$(srcdir) -o startup.@LTO@ string.@LTO@: $(srcdir)/string.c $(CC) $(ALL_CFLAGS) -c $(srcdir)/string.c -I. -o string.@LTO@ struct.@LTO@: $(srcdir)/struct.c @@ -332,8 +335,6 @@ bignum.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h bool.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzeqchk.inc -builtin.@LTO@: $(COMMON_HEADERS) \ - $(srcdir)/stypes.h $(srcdir)/schminc.h $(srcdir)/startup.inc $(srcdir)/cstartup.inc char.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/schuchar.inc compenv.@LTO@: $(COMMON_HEADERS) \ @@ -376,12 +377,12 @@ jitstack.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) $(srcdir)/codetab.inc \ jitstate.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) letrec_check.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h +linklet.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/stypes.h list.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h marshal.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h -module.@LTO@: $(COMMON_HEADERS) \ - $(srcdir)/stypes.h mzrt.@LTO@: $(COMMON_HEADERS) network.@LTO@: $(COMMON_HEADERS) $(RKTIO_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_network.inc @@ -411,8 +412,7 @@ rational.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h read.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/schcpt.h $(srcdir)/schvers.h $(srcdir)/schminc.h \ - $(srcdir)/stypes.h $(srcdir)/mzmark_read.inc \ - $(srcdir)/read_vector.inc + $(srcdir)/stypes.h $(srcdir)/mzmark_read.inc regexp.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_regexp.inc $(srcdir)/schrx.h resolve.@LTO@: $(COMMON_HEADERS) \ @@ -421,6 +421,11 @@ setjmpup.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/schmach.h sfs.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_sfs.inc +sort.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/stypes.h +startup.@LTO@: $(COMMON_HEADERS) $(srcdir)/schvers.h \ + $(srcdir)/stypes.h $(srcdir)/schminc.h $(srcdir)/startup.inc ../cstartup.inc \ + $(srcdir)/startup-glue.inc string.@LTO@: $(COMMON_HEADERS) $(RKTIO_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/schvers.h $(srcdir)/mzmark_string.inc $(srcdir)/strops.inc \ $(srcdir)/schustr.inc $(srcdir)/systype.inc @@ -438,3 +443,8 @@ vector.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h validate.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/stypes.h $(srcdir)/mzmark_validate.inc + +# If "cstartup.inc" hasn't been built, yet, create it as +# a redirect to "startup.inc" +../cstartup.inc: + echo '#include "startup.inc"' > ../cstartup.inc diff --git a/racket/src/racket/src/bool.c b/racket/src/racket/src/bool.c index c6d6679a23..aceb72f0f2 100644 --- a/racket/src/racket/src/bool.c +++ b/racket/src/racket/src/bool.c @@ -64,7 +64,6 @@ typedef struct Equal_Info { Scheme_Object *next, *next_next; Scheme_Object *insp; intptr_t for_chaperone; /* 3 => for impersonator */ - intptr_t eq_for_modidx; } Equal_Info; static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql); @@ -82,7 +81,7 @@ void scheme_init_true_false(void) scheme_void->type = scheme_void_type; } -void scheme_init_bool (Scheme_Env *env) +void scheme_init_bool (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -96,59 +95,68 @@ void scheme_init_bool (Scheme_Env *env) p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1); scheme_not_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("not", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("not", p, env); p = scheme_make_folding_prim(true_object_p_prim, "true-object?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_true_object_p_proc = p; - scheme_add_global_constant("true-object?", p, env); + scheme_addto_prim_instance("true-object?", p, env); p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_boolean_p_proc = p; - scheme_add_global_constant("boolean?", p, env); + scheme_addto_prim_instance("boolean?", p, env); p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_eq_proc = p; - scheme_add_global_constant("eq?", p, env); + scheme_addto_prim_instance("eq?", p, env); p = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_eqv_proc = p; - scheme_add_global_constant("eqv?", scheme_eqv_proc, env); + scheme_addto_prim_instance("eqv?", scheme_eqv_proc, env); p = scheme_make_noncm_prim(equal_prim, "equal?", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); scheme_equal_proc = p; - scheme_add_global_constant("equal?", scheme_equal_proc, env); + scheme_addto_prim_instance("equal?", scheme_equal_proc, env); - scheme_add_global_constant("equal?/recur", + scheme_addto_prim_instance("equal?/recur", scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3), env); p = scheme_make_immed_prim(chaperone_p, "chaperone?", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("chaperone?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("chaperone?", p, env); p = scheme_make_immed_prim(impersonator_p, "impersonator?", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("impersonator?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("impersonator?", p, env); p = scheme_make_immed_prim(procedure_impersonator_star_p, "procedure-impersonator*?", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("procedure-impersonator*?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("procedure-impersonator*?", p, env); - scheme_add_global_constant("chaperone-of?", + scheme_addto_prim_instance("chaperone-of?", scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2), env); - scheme_add_global_constant("impersonator-of?", + scheme_addto_prim_instance("impersonator-of?", scheme_make_prim_w_arity(impersonator_of, "impersonator-of?", 2, 2), env); } @@ -193,7 +201,6 @@ XFORM_NONGCING static void init_equal_info(Equal_Info *eql) eql->next_next = NULL; eql->insp = NULL; eql->for_chaperone = 0; - eql->eq_for_modidx = 0; } static Scheme_Object * @@ -342,7 +349,6 @@ XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2) return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2); case scheme_symbol_type: case scheme_keyword_type: - case scheme_scope_type: /* `eqv?` requires `eq?` */ return 0; default: @@ -451,7 +457,7 @@ int is_slow_equal (Scheme_Object *obj1, Scheme_Object *obj2) return is_equal(obj1, obj2, &eql); } -int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) +int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) XFORM_ASSERT_NO_CONVERSION { int v; @@ -462,16 +468,6 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) return is_slow_equal(obj1, obj2); } -int scheme_equal_modix_eq (Scheme_Object *obj1, Scheme_Object *obj2) -{ - Equal_Info eql; - - init_equal_info(&eql); - eql.eq_for_modidx = 1; - - return is_equal(obj1, obj2, &eql); -} - static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht) { Scheme_Object *v, *prev = obj1, *prev_prev = obj1; @@ -874,41 +870,6 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) (Scheme_Bucket_Table *)obj2, orig_obj2, eql); } - case scheme_wrap_chunk_type: { - return vector_equal(obj1, obj1, obj2, obj2, eql); - } - case scheme_resolved_module_path_type: - { - obj1 = SCHEME_PTR_VAL(obj1); - obj2 = SCHEME_PTR_VAL(obj2); - goto top; - } - case scheme_module_index_type: - { - Scheme_Modidx *midx1, *midx2; -# include "mzeqchk.inc" - midx1 = (Scheme_Modidx *)obj1; - midx2 = (Scheme_Modidx *)obj2; - if (eql->eq_for_modidx - && (SCHEME_FALSEP(midx1->path) - || SCHEME_FALSEP(midx2->path))) - return 0; - else if (is_equal(midx1->path, midx2->path, eql)) { - obj1 = midx1->base; - obj2 = midx2->base; - goto top; - } - } - case scheme_scope_table_type: - { - Scheme_Scope_Table *mt1 = (Scheme_Scope_Table *)obj1; - Scheme_Scope_Table *mt2 = (Scheme_Scope_Table *)obj2; - if (!is_equal((Scheme_Object *)mt1->simple_scopes, (Scheme_Object *)mt2->simple_scopes, eql)) - return 0; - obj1 = mt1->multi_scopes; - obj2 = mt2->multi_scopes; - goto top; - } default: if (!eql->for_chaperone && ((t1 == scheme_chaperone_type) || (t1 == scheme_proc_chaperone_type))) { diff --git a/racket/src/racket/src/builtin.c b/racket/src/racket/src/builtin.c deleted file mode 100644 index 823eddc062..0000000000 --- a/racket/src/racket/src/builtin.c +++ /dev/null @@ -1,78 +0,0 @@ -/* - Racket - Copyright (c) 2004-2018 PLT Design Inc. - Copyright (c) 2000-2001 Matthew Flatt - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library 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 distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301 USA. - - libscheme - Copyright (c) 1994 Brent Benson - All rights reserved. -*/ - -#include "schpriv.h" -#include "schminc.h" - -/* On the Mac, 68K, store the built-in Racket code as pc-relative */ -#if defined(__MWERKS__) -#if !defined(__POWERPC__) -#pragma pcrelstrings on -#endif -#endif - -Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int len, Scheme_Env *env, - Scheme_Object *magic_sym, Scheme_Object *magic_val, - int multi_ok) -{ - Scheme_Object *port, *expr; - - port = scheme_make_sized_byte_string_input_port(str, -len); /* negative means it's constant */ - - if (!env) - env = scheme_get_env(NULL); - - expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, -1, NULL, - magic_sym, magic_val, - NULL); - - if (multi_ok) - return _scheme_eval_compiled_multi(expr, env); - else - return _scheme_eval_compiled(expr, env); -} - -Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env) -{ - return scheme_eval_compiled_sized_string_with_magic(str, len, env, NULL, NULL, 0); -} - -void scheme_add_embedded_builtins(Scheme_Env *env) -{ -#define EVAL_ONE_STR(str) scheme_eval_module_string(str, env) -#define EVAL_ONE_SIZED_STR(str, len) scheme_eval_compiled_sized_string(str, len, env) - -#if USE_COMPILED_STARTUP -# include "cstartup.inc" -#else -# include "startup.inc" -#endif -} - -#if defined(__MWERKS__) -#if !defined(__POWERPC__) -#pragma pcrelstrings reset -#endif -#endif diff --git a/racket/src/racket/src/char.c b/racket/src/racket/src/char.c index a2bdd767b3..7e82900613 100644 --- a/racket/src/racket/src/char.c +++ b/racket/src/racket/src/char.c @@ -98,63 +98,87 @@ void scheme_init_char_constants(void) } } -void scheme_init_char (Scheme_Env *env) +void scheme_init_char (Scheme_Startup_Env *env) { Scheme_Object *p; REGISTER_SO(scheme_char_p_proc); p = scheme_make_folding_prim(char_p, "char?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_char_p_proc = p; - scheme_add_global_constant("char?", p, env); + scheme_addto_prim_instance("char?", p, env); REGISTER_SO(scheme_interned_char_p_proc); p = scheme_make_folding_prim(interned_char_p, "interned-char?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_interned_char_p_proc = p; - scheme_add_global_constant("interned-char?", p, env); + scheme_addto_prim_instance("interned-char?", p, env); p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("char=?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char=?", p, env); - GLOBAL_FOLDING_PRIM("char?", char_gt, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char<=?", char_lt_eq, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char>=?", char_gt_eq, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci?", char_gt_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env); - GLOBAL_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-graphic?", char_graphic, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-whitespace?", char_whitespace, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-blank?", char_blank, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-iso-control?", char_control, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-punctuation?", char_punctuation, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-upper-case?", char_upper_case, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-lower-case?", char_lower_case, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env); + p = scheme_make_folding_prim(char_lt, "char?", 2, -1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char>?", p, env); + + p = scheme_make_folding_prim(char_lt_eq, "char<=?", 2, -1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char<=?", p, env); + + p = scheme_make_folding_prim(char_gt_eq, "char>=?", 2, -1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char>=?", p, env); + + ADD_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-ci?", char_gt_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env); + ADD_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-graphic?", char_graphic, 1, 1, 1, env); + + p = scheme_make_folding_prim(char_whitespace, "char-whitespace?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("char-whitespace?", p, env); + + ADD_FOLDING_PRIM("char-blank?", char_blank, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-iso-control?", char_control, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-punctuation?", char_punctuation, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-upper-case?", char_upper_case, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-lower-case?", char_lower_case, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env); p = scheme_make_folding_prim(scheme_checked_char_to_integer, "char->integer", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("char->integer", p, env); + scheme_addto_prim_instance("char->integer", p, env); p = scheme_make_folding_prim(scheme_checked_integer_to_char, "integer->char", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("integer->char", p, env); + scheme_addto_prim_instance("integer->char", p, env); - GLOBAL_FOLDING_PRIM("char-upcase", char_upcase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-downcase", char_downcase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-titlecase", char_titlecase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-foldcase", char_foldcase, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-general-category", char_general_category, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("char-utf-8-length", char_utf8_length, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env); + ADD_FOLDING_PRIM("char-upcase", char_upcase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-downcase", char_downcase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-titlecase", char_titlecase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-foldcase", char_foldcase, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-general-category", char_general_category, 1, 1, 1, env); + ADD_FOLDING_PRIM("char-utf-8-length", char_utf8_length, 1, 1, 1, env); + ADD_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env); } Scheme_Object *scheme_make_char(mzchar ch) diff --git a/racket/src/racket/src/cify-check.rkt b/racket/src/racket/src/cify-check.rkt new file mode 100644 index 0000000000..d7babe718c --- /dev/null +++ b/racket/src/racket/src/cify-check.rkt @@ -0,0 +1,12 @@ +;; A fast-loading script to delete "cstartup.inc" if it's not cify output +(module compile-startup '#%kernel + (define-values (dest) (vector-ref (current-command-line-arguments) 0)) + (if (file-exists? dest) + (if (call-with-input-file dest (lambda (i) + (let-values ([(line) (read-line i)]) + (if (string? line) + (regexp-match? #rx"^/[*] version" line) + #f)))) + (void) + (delete-file dest)) + (void))) diff --git a/racket/src/racket/src/cify-startup.rkt b/racket/src/racket/src/cify-startup.rkt new file mode 100644 index 0000000000..33c19225f0 --- /dev/null +++ b/racket/src/racket/src/cify-startup.rkt @@ -0,0 +1,98 @@ +#lang racket/base +(require (only-in '#%linklet + primitive-table + primitive-in-category?) + racket/cmdline + "../../schemify/schemify.rkt" + "../../schemify/serialize.rkt" + "../../schemify/known.rkt" + "../../schemify/lift.rkt" + "../../cify/main.rkt" + "help-startup.rkt") + +(define dest "cstartup.inc") +(define version-line (format "/* version: ~a */" (version))) + +(define debug? #f) + +(define-values (src vers deps) + (command-line + #:args (src-file vers-file . dep) + (values src-file vers-file dep))) + +(define content (get-linklet src)) +(define version-comparisons (get-version-comparisons vers)) + +(define l (cdddr content)) + +(define (arity->mask a) + (cond + [(exact-nonnegative-integer? a) + (arithmetic-shift 1 a)] + [(arity-at-least? a) + (bitwise-xor -1 (sub1 (arithmetic-shift 1 (arity-at-least-value a))))] + [(list? a) + (let loop ([mask 0] [l a]) + (cond + [(null? l) mask] + [else + (let ([a (car l)]) + (cond + [(or (exact-nonnegative-integer? a) + (arity-at-least? a)) + (loop (bitwise-ior mask (arity->mask a)) (cdr l))] + [else #f]))]))] + [else #f])) + +(define prim-knowns + (for*/hash ([table-name '(#%linklet #%kernel + #%paramz #%unsafe #%foreign + #%futures #%place + #%flfxnum #%extfl #%network)] + [(name v) (in-hash (primitive-table table-name))]) + (values name + (cond + [(procedure? v) + (define arity-mask (arity->mask (procedure-arity v))) + (cond + [(primitive-in-category? name 'omitable) + (known-procedure/succeeds arity-mask)] + [else + (known-procedure arity-mask)])] + [else + a-known-constant])))) + +(printf "Serializable...\n") +(define-values (bodys/constants-lifted lifted-constants) + (time (convert-for-serialize l #t))) + +(printf "Schemify...\n") +(define body + (time + (schemify-body bodys/constants-lifted (lambda (old-v new-v) new-v) prim-knowns #hasheq() #hasheq() + ;; for cify: + #t + ;; unsafe mode: + #t))) + +(printf "Lift...\n") +(define lifted-body + (time + (lift-in-schemified-body body (lambda (old new) new)))) + +(define converted-body + (append (for/list ([p (in-list lifted-constants)]) + (cons 'define p)) + lifted-body)) + +(cify dest (caddr content) `(begin . ,converted-body) prim-knowns + #:debug? debug? + #:preamble (append (list version-line + (format "#if 0 ~a" version-comparisons) + "#include \"startup.inc\"" + "#else") + (if debug? + (list "# define c_VALIDATE_DEBUG") + (list)) + (list "# include \"startup-glue.inc\"")) + #:postamble (list (format "#endif"))) diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index 211b47fac0..ef6fabd19b 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -24,7 +24,6 @@ */ #include "schpriv.h" -#include "schexpobs.h" #define TABLE_CACHE_MAX_SIZE 2048 @@ -41,8 +40,6 @@ ROSYM static Scheme_Object *undefined_error_name_symbol; THREAD_LOCAL_DECL(static Scheme_Hash_Table *toplevels_ht); THREAD_LOCAL_DECL(static Scheme_Hash_Table *locals_ht[2]); -static void init_compile_data(Scheme_Comp_Env *env); - static void init_scheme_local(); static void init_toplevels(); @@ -82,681 +79,72 @@ void scheme_init_compenv_symbol(void) undefined_error_name_symbol = scheme_intern_symbol("undefined-error-name"); } -/*========================================================================*/ -/* compilation info management */ -/*========================================================================*/ - -void scheme_default_compile_rec(Scheme_Compile_Info *rec, int drec) -{ -} - -void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n) -{ - int i; - - for (i = 0; i < n; i++) { - dest[i].comp = 1; - dest[i].dont_mark_local_use = src[drec].dont_mark_local_use; - dest[i].resolve_module_ids = src[drec].resolve_module_ids; - dest[i].pre_unwrapped = 0; - dest[i].testing_constantness = 0; - dest[i].env_already = 0; - dest[i].comp_flags = src[drec].comp_flags; - } -} - -void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, - Scheme_Expand_Info *dest, int n) -{ - int i; - - for (i = 0; i < n; i++) { - dest[i].comp = 0; - dest[i].depth = src[drec].depth; - dest[i].pre_unwrapped = 0; - dest[i].substitute_bindings = src[drec].substitute_bindings; - dest[i].testing_constantness = 0; - dest[i].env_already = 0; - dest[i].comp_flags = src[drec].comp_flags; - } -} - -void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n) -{ - /* Nothing to do anymore, since we moved max_let_depth to resolve phase */ -} - -void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec) -{ - lam[dlrec].comp = 1; - lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use; - lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids; - lam[dlrec].substitute_bindings = src[dlrec].substitute_bindings; - lam[dlrec].pre_unwrapped = 0; - lam[dlrec].testing_constantness = 0; - lam[dlrec].env_already = 0; - lam[dlrec].comp_flags = src[drec].comp_flags; -} - -void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec) -{ -} - -void scheme_compile_rec_done_local(Scheme_Compile_Info *rec, int drec) -{ -} - -/**********************************************************************/ -/* expansion observer */ -/**********************************************************************/ - -/* RMC - * - Defines #%expobs module - * - current-expand-observe - * - ??? (other syntax observations) - */ - -void scheme_call_expand_observe(Scheme_Object *obs, int tag, Scheme_Object *obj) -{ - if (!SCHEME_PROCP(obs)) { - scheme_signal_error("internal error: expand-observer should never be non-procedure"); - } else { - Scheme_Object *buf[2]; - buf[0] = scheme_make_integer(tag); - if (obj) { - buf[1] = obj; - } else { - buf[1] = scheme_false; - } - scheme_apply(obs, 2, buf); - } -} - -static Scheme_Object * -current_expand_observe(int argc, Scheme_Object **argv) -{ - return scheme_param_config("current-expand-observe", - scheme_make_integer(MZCONFIG_EXPAND_OBSERVE), - argc, argv, - 2, NULL, NULL, 0); -} - -/* always returns either procedure or NULL */ -Scheme_Object *scheme_get_expand_observe() -{ - Scheme_Object *obs; - obs = scheme_get_param(scheme_current_config(), - MZCONFIG_EXPAND_OBSERVE); - if (SCHEME_PROCP(obs)) { - return obs; - } else { - return NULL; - } -} - -void scheme_init_expand_observe(Scheme_Env *env) -{ - Scheme_Env *newenv; - Scheme_Object *modname; - - modname = scheme_intern_symbol("#%expobs"); - newenv = scheme_primitive_module(modname, env); - - scheme_add_global_constant - ("current-expand-observe", - scheme_register_parameter(current_expand_observe, - "current-expand-observe", - MZCONFIG_EXPAND_OBSERVE), - newenv); - scheme_finish_primitive_module(newenv); -} - /*========================================================================*/ /* compile-time env, constructors and simple queries */ /*========================================================================*/ -static void init_compile_data(Scheme_Comp_Env *env) -{ - env->max_use = -1; -} - -Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, Scheme_Object *scopes, Scheme_Comp_Env *base) -{ - Scheme_Comp_Env *frame; - int count; - - count = num_bindings; - - frame = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Comp_Env); -#ifdef MZTAG_REQUIRED - frame->type = scheme_rt_comp_env; -#endif - - frame->scopes = scopes; - - { - Scheme_Object **vals; - vals = MALLOC_N(Scheme_Object *, count); - frame->binders = vals; - vals = MALLOC_N(Scheme_Object *, count); - frame->bindings = vals; - } - - frame->num_bindings = num_bindings; - frame->flags = flags; - frame->next = base; - frame->genv = base->genv; - frame->insp = base->insp; - frame->prefix = base->prefix; - frame->in_modidx = base->in_modidx; - frame->observer = base->observer; - - if (base->next) - frame->skip_depth = base->skip_depth + 1; - else - frame->skip_depth = 0; - - init_compile_data(frame); - - if (flags & SCHEME_USE_SCOPES_TO_NEXT) { - if (base->use_scopes_next) - frame->use_scopes_next = base->use_scopes_next; - else - frame->use_scopes_next = base; - } - - return frame; -} - -Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags) -{ - Scheme_Comp_Env *e; - Comp_Prefix *cp; - - if (!insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - e = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Comp_Env); -#ifdef MZTAG_REQUIRED - e->type = scheme_rt_comp_env; -#endif - e->num_bindings = 0; - e->next = NULL; - e->genv = genv; - e->insp = insp; - e->flags = flags; - init_compile_data(e); - - cp = MALLOC_ONE_RT(Comp_Prefix); -#ifdef MZTAG_REQUIRED - cp->type = scheme_rt_comp_prefix; -#endif - - e->prefix = cp; - - e->scopes = scopes; - - return e; -} - -Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags) -{ - Scheme_Comp_Env *e; - - if (SAME_OBJ(scopes, scheme_true)) { - if (genv->stx_context) - scopes = scheme_module_context_frame_scopes(genv->stx_context, NULL); - else - scopes = NULL; - } - - e = scheme_new_comp_env(genv, insp, scopes, flags); - e->prefix = NULL; - - return e; -} - -int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env) -{ - Scheme_Comp_Env *se; - - for (se = stx_env; NOT_SAME_OBJ(se, env); se = se->next) { - if (!(se->flags & SCHEME_FOR_INTDEF)) - break; - } - return SAME_OBJ(se, env); -} - -void -scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame) -{ - Scheme_Object *binding; - - if ((index >= frame->num_bindings) || (index < 0)) - scheme_signal_error("internal error: scheme_add_binding: " - "index out of range: %d", index); - - if (frame->scopes) { - /* sometimes redundant: */ - val = scheme_stx_adjust_frame_bind_scopes(val, frame->scopes, scheme_env_phase(frame->genv), - SCHEME_STX_ADD); - } - - frame->binders[index] = val; - - if (!frame->bindings[index]) { - if (frame->flags & SCHEME_INTDEF_SHADOW) { - binding = scheme_stx_lookup(val, scheme_env_phase(frame->genv)); - } else { - binding = scheme_gensym(SCHEME_STX_VAL(val)); - scheme_add_local_binding(val, scheme_env_phase(frame->genv), binding); - } - - frame->bindings[index] = binding; - } - - frame->skip_table = NULL; -} - -void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, - Scheme_Object *end_stmts, Scheme_Object *context_key, - Scheme_Object *requires, Scheme_Object *provides, - Scheme_Object *module_lifts) -{ - Scheme_Lift_Capture_Proc *pp; - Scheme_Object *vec; - - pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc)); - *pp = cp; - - vec = scheme_make_vector(9, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_null; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp; - SCHEME_VEC_ELS(vec)[2] = data; - SCHEME_VEC_ELS(vec)[3] = end_stmts; - SCHEME_VEC_ELS(vec)[4] = context_key; - SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false); - SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */ - SCHEME_VEC_ELS(vec)[7] = provides; - SCHEME_VEC_ELS(vec)[8] = module_lifts; /* #f => disallowed; #t or (void) => add to slot 0; (void) => `module*` allowed */ - - env->lifts = vec; -} - -void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env) -{ - while (orig_env) { - if ((orig_env->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(orig_env->lifts)[5])) - break; - orig_env = orig_env->next; - } - - if (orig_env) { - Scheme_Object *vec, *p; - - p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env); - - vec = scheme_make_vector(9, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_false; - SCHEME_VEC_ELS(vec)[1] = scheme_void; - SCHEME_VEC_ELS(vec)[2] = scheme_void; - SCHEME_VEC_ELS(vec)[3] = scheme_false; - SCHEME_VEC_ELS(vec)[4] = scheme_false; - SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */ - SCHEME_VEC_ELS(vec)[6] = scheme_null; - SCHEME_VEC_ELS(vec)[7] = scheme_false; - SCHEME_VEC_ELS(vec)[8] = scheme_false; - - env->lifts = vec; - } -} - -Scheme_Comp_Env *scheme_get_env_for_lifts(Scheme_Comp_Env *env) -{ - while (env && !env->lifts) { - env = env->next; - } - - return env; -} - -Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env) -{ - return scheme_reverse(SCHEME_VEC_ELS(env->lifts)[0]); -} - -Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[3]; -} - -Scheme_Object *scheme_frame_get_modules(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[8]; -} - -Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[6]; -} - -Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(env->lifts)[7]; -} - -void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env) -{ - Scheme_Object **ns, **bs, **vs; - - if (cnt) { - ns = MALLOC_N(Scheme_Object *, cnt); - bs = MALLOC_N(Scheme_Object *, cnt); - vs = MALLOC_N(Scheme_Object *, cnt); - - env->num_bindings = cnt; - env->binders = ns; - env->bindings = bs; - env->vals = vs; - } -} - -void scheme_set_local_syntax(int pos, - Scheme_Object *name, Scheme_Object *val, - Scheme_Comp_Env *env, - int replace_value) -{ - Scheme_Object *binding; - - if (!replace_value) { - if (env->flags & SCHEME_CAPTURE_WITHOUT_RENAME) { - binding = scheme_stx_lookup(name, scheme_env_phase(env->genv)); - } else { - if (env->scopes) - name = scheme_stx_adjust_frame_bind_scopes(name, env->scopes, scheme_env_phase(env->genv), - SCHEME_STX_ADD); - - binding = scheme_gensym(SCHEME_STX_VAL(name)); - - scheme_add_local_binding(name, scheme_env_phase(env->genv), binding); - } - - env->binders[pos] = name; - env->bindings[pos] = binding; - } - env->vals[pos] = val; - env->skip_table = NULL; -} - -Scheme_Comp_Env * -scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Object *scope, Scheme_Comp_Env *env, int flags) -{ - Scheme_Comp_Env *frame; - int len, i, count; - - len = scheme_stx_list_length(vals); - count = len; - - frame = scheme_new_compilation_frame(count, flags, scope, env); - - for (i = 0; i < len ; i++) { - if (SCHEME_STX_SYMBOLP(vals)) { - scheme_add_compilation_binding(i, vals, frame); - } else { - Scheme_Object *a; - a = SCHEME_STX_CAR(vals); - scheme_add_compilation_binding(i, a, frame); - vals = SCHEME_STX_CDR(vals); - } - } - - init_compile_data(frame); - - return frame; -} - -void scheme_add_compilation_frame_use_site_scope(Scheme_Comp_Env *env, Scheme_Object *use_site_scope) -{ - while (env->flags & SCHEME_USE_SCOPES_TO_NEXT) { - env = env->next; - } - - if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { - scheme_module_context_add_use_site_scope(env->genv->stx_context, use_site_scope); - } else { - use_site_scope = scheme_add_frame_use_site_scope(env->scopes, use_site_scope); - env->scopes = use_site_scope; - } -} - -void scheme_add_compilation_frame_intdef_scope(Scheme_Comp_Env *env, Scheme_Object *scope) -{ - while (env->flags & SCHEME_USE_SCOPES_TO_NEXT) { - env = env->next; - } - - if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { - /* we keep intdef scopes, even in this case, for use by get-shadower */ - } - - scope = scheme_add_frame_intdef_scope(env->scopes, scope); - env->scopes = scope; -} - -Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env) -{ - if (scheme_is_toplevel(env) - || scheme_is_module_env(env) - || scheme_is_module_begin_env(env) - || (env->flags & SCHEME_INTDEF_FRAME)) - return scheme_new_compilation_frame(0, 0, NULL, env); - else - return env; -} - -int scheme_is_toplevel(Scheme_Comp_Env *env) -{ - return !env->next || (env->flags & SCHEME_TOPLEVEL_FRAME); -} - -int scheme_is_nested_module(Scheme_Comp_Env *env) -{ - return (env->flags & SCHEME_NESTED_MODULE_FRAME); -} - -int scheme_is_module_env(Scheme_Comp_Env *env) -{ - return !!(env->flags & SCHEME_MODULE_FRAME); -} - -int scheme_is_module_begin_env(Scheme_Comp_Env *env) -{ - return !!(env->flags & SCHEME_MODULE_BEGIN_FRAME); -} - -Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env) -{ - if (scheme_is_toplevel(env)) - return env; - else - return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, NULL, env); -} - -Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, int flags) +Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int flags) { Scheme_Toplevel *tl; Scheme_Object *v, *pr; - /* Important: non-resolved can't be cached, because the ISCONST - field is modified to track mutated module-level variables. But - the value for a specific toplevel is cached in the environment - layer. */ + if ((depth < MAX_CONST_TOPLEVEL_DEPTH) + && (position < MAX_CONST_TOPLEVEL_POS)) + return toplevels[depth][position][flags]; - if (resolved) { - if ((depth < MAX_CONST_TOPLEVEL_DEPTH) - && (position < MAX_CONST_TOPLEVEL_POS)) - return toplevels[depth][position][flags]; - - if ((position < 0xFFFF) && (depth < 0xFF)) { - int ep = position | (depth << 16) | (flags << 24); - pr = scheme_make_integer(ep); - } else { - pr = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(pr)[0] = scheme_make_integer(position); - SCHEME_VEC_ELS(pr)[1] = scheme_make_integer(flags); - SCHEME_VEC_ELS(pr)[2] = scheme_make_integer(depth); - } - v = scheme_hash_get_atomic(toplevels_ht, pr); - if (v) - return v; - } else - pr = NULL; + if ((position < 0xFFFF) && (depth < 0xFF)) { + int ep = position | (depth << 16) | (flags << 24); + pr = scheme_make_integer(ep); + } else { + pr = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(pr)[0] = scheme_make_integer(position); + SCHEME_VEC_ELS(pr)[1] = scheme_make_integer(flags); + SCHEME_VEC_ELS(pr)[2] = scheme_make_integer(depth); + } + v = scheme_hash_get_atomic(toplevels_ht, pr); + if (v) + return v; tl = (Scheme_Toplevel *)scheme_malloc_atomic_tagged(sizeof(Scheme_Toplevel)); - tl->iso.so.type = (resolved ? scheme_toplevel_type : scheme_ir_toplevel_type); + tl->iso.so.type = scheme_toplevel_type; tl->depth = depth; tl->position = position; SCHEME_TOPLEVEL_FLAGS(tl) = flags | HIGH_BIT_TO_DISABLE_HASHING; - if (resolved) { - if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) { - toplevels_ht = scheme_make_hash_table_equal(); - } - scheme_hash_set_atomic(toplevels_ht, pr, (Scheme_Object *)tl); + if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) { + toplevels_ht = scheme_make_hash_table_equal(); } + scheme_hash_set_atomic(toplevels_ht, pr, (Scheme_Object *)tl); return (Scheme_Object *)tl; } -Scheme_Object *scheme_register_toplevel_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp, - int imported, Scheme_Object *inline_variant) -{ - Scheme_Hash_Table *ht; - Scheme_Object *o; - - ht = cp->toplevels; - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->toplevels = ht; - } - - o = scheme_hash_get(ht, var); - if (o) - return o; - - o = scheme_make_toplevel(0, cp->num_toplevels, 0, - (imported - ? ((SCHEME_MODVAR_FLAGS(var) & SCHEME_MODVAR_CONST) - ? SCHEME_TOPLEVEL_CONST - : ((SCHEME_MODVAR_FLAGS(var) & SCHEME_MODVAR_FIXED) - ? SCHEME_TOPLEVEL_FIXED - : SCHEME_TOPLEVEL_READY)) - : 0)); - - scheme_hash_set(ht, var, o); - - if (inline_variant) { - ht = cp->inline_variants; - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->inline_variants = ht; - } - scheme_hash_set(ht, scheme_make_integer(cp->num_toplevels), inline_variant); - } - - cp->num_toplevels++; - - return o; -} - -Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int imported, Scheme_Object *inline_variant) -{ - Comp_Prefix *cp = env->prefix; - - if (rec && rec[drec].dont_mark_local_use) { - /* Make up anything; it's going to be ignored. */ - return scheme_make_toplevel(0, 0, 0, 0); - } - - return scheme_register_toplevel_in_comp_prefix(var, cp, imported, inline_variant); -} - -void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id) -{ - Comp_Prefix *cp = env->prefix; - - if (cp) { - if (!cp->unbound) cp->unbound = scheme_null; - - id = scheme_make_pair(id, cp->unbound); - cp->unbound = id; - } -} - -void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env) -{ - if (exp_env->prefix->unbound && (env->genv->disallow_unbound < 0)) { - /* adding a list to env->prefix->unbound indicates a - phase-1 shift for the identifiers in the list: */ - scheme_register_unbound_toplevel(env, exp_env->prefix->unbound); - } -} - Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags) { Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl; - return scheme_make_toplevel(tl->depth, tl->position, 0, flags); + return scheme_make_toplevel(tl->depth, tl->position, flags); } -Scheme_Object *scheme_register_stx_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp) +Scheme_IR_Toplevel *scheme_make_ir_toplevel(int instance_pos, int variable_pos, int flags) { - Scheme_Local *l; - Scheme_Object *o; - int pos; + Scheme_IR_Toplevel *tl; - if (!cp->stxes) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->stxes = ht; - } + tl = MALLOC_ONE_TAGGED(Scheme_IR_Toplevel); + tl->iso.so.type = scheme_ir_toplevel_type; + SCHEME_TOPLEVEL_FLAGS(tl) = flags | HIGH_BIT_TO_DISABLE_HASHING; - pos = cp->num_stxes; + tl->instance_pos = instance_pos; + tl->variable_pos = variable_pos; - l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - l->iso.so.type = scheme_ir_quote_syntax_type; - l->position = pos; - - cp->num_stxes++; - o = (Scheme_Object *)l; - - scheme_hash_set(cp->stxes, var, o); - - return o; + return tl; } -Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +Scheme_Object *scheme_ir_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags) { - Scheme_Local *l; - Comp_Prefix *cp = env->prefix; - - if (rec && rec[drec].dont_mark_local_use) { - /* Make up anything; it's going to be ignored. */ - l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - l->iso.so.type = scheme_ir_quote_syntax_type; - l->position = 0; - - return (Scheme_Object *)l; - } - - return scheme_register_stx_in_comp_prefix(var, cp); + Scheme_IR_Toplevel *tl = (Scheme_IR_Toplevel *)_tl; + tl = scheme_make_ir_toplevel(tl->instance_pos, tl->variable_pos, + (SCHEME_TOPLEVEL_FLAGS(tl) & ~SCHEME_TOPLEVEL_FLAGS_MASK) | flags); + return (Scheme_Object *)tl; } /*========================================================================*/ @@ -894,258 +282,8 @@ Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags) return v; } -static Scheme_Object *get_local_name(Scheme_Object *id) -{ - Scheme_Object *name; - - name = scheme_stx_property(id, undefined_error_name_symbol, NULL); - if (name && SCHEME_SYMBOLP(name)) - return name; - else - return SCHEME_STX_VAL(id); -} - -static Scheme_IR_Local *make_variable(Scheme_Object *id) -{ - Scheme_IR_Local *var; - - var = MALLOC_ONE_TAGGED(Scheme_IR_Local); - var->so.type = scheme_ir_local_type; - if (id) { - id = get_local_name(id); - var->name = id; - } - - return var; -} - -static Scheme_IR_Local *get_frame_loc(Scheme_Comp_Env *frame, - int i, int j, int p, int flags) -/* Generates a Scheme_IR_Local record as needed, and also - marks the variable as used for closures. */ -{ - if (!frame->vars) { - Scheme_IR_Local **vars; - vars = MALLOC_N(Scheme_IR_Local*, frame->num_bindings); - frame->vars = vars; - } - - if (!frame->vars[i]) { - Scheme_IR_Local *var; - var = make_variable(frame->binders ? frame->binders[i] : NULL); - frame->vars[i] = var; - } - - if (frame->vars[i]->use_count < SCHEME_USE_COUNT_INF) - frame->vars[i]->use_count++; - if (flags & (SCHEME_SETTING | SCHEME_LINKING_REF)) - frame->vars[i]->mutated = 1; - if (!(flags & (SCHEME_APP_POS | SCHEME_SETTING))) - if (frame->vars[i]->non_app_count < SCHEME_USE_COUNT_INF) - frame->vars[i]->non_app_count++; - - if (i > frame->max_use) - frame->max_use = i; - frame->any_use = 1; - - return frame->vars[i]; -} - -void scheme_env_make_variables(Scheme_Comp_Env *frame) -{ - Scheme_IR_Local *var, **vars; - int i; - - if (!frame->num_bindings) - return; - - if (!frame->vars) { - vars = MALLOC_N(Scheme_IR_Local*, frame->num_bindings); - frame->vars = vars; - } - - for (i = 0; i < frame->num_bindings; i++) { - if (!frame->vars[i]) { - var = make_variable(frame->binders ? frame->binders[i] : NULL); - frame->vars[i] = var; - } - } -} - -void scheme_set_compilation_variables(Scheme_Comp_Env *frame, Scheme_IR_Local **vars, - int pos, int count) -{ - int i; - - MZ_ASSERT((pos + count) <= frame->num_bindings); - - if (!frame->vars) { - Scheme_IR_Local **fvars; - fvars = MALLOC_N(Scheme_IR_Local*, frame->num_bindings); - frame->vars = fvars; - } - - for (i = 0; i < count; i++) { - MZ_ASSERT(!frame->vars[i+pos]); - frame->vars[i+pos] = vars[count - i - 1]; - } -} - -Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, - Scheme_Object *stxsym, Scheme_Object *insp, - int pos, intptr_t mod_phase, int is_constant, - Scheme_Object *shape) -/* is_constant == 2 => constant over all instantiations and phases */ -{ - Scheme_Object *val; - Scheme_Hash_Table *ht; - - if (!env->modvars) { - ht = scheme_make_hash_table_equal_modix_eq(); - env->modvars = ht; - } - - stxsym = SCHEME_STX_SYM(stxsym); - - ht = (Scheme_Hash_Table *)scheme_hash_get(env->modvars, modidx); - - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(env->modvars, modidx, (Scheme_Object *)ht); - } - - /* Loop for inspector-specific hash table, maybe: */ - while (1) { - - val = scheme_hash_get(ht, stxsym); - - if (!val) { - Module_Variable *mv; - - mv = MALLOC_ONE_TAGGED(Module_Variable); - mv->iso.so.type = scheme_module_variable_type; - - mv->modidx = modidx; - mv->sym = stxsym; - mv->insp = insp; - mv->pos = pos; - mv->mod_phase = (int)mod_phase; - mv->shape = shape; - - if (is_constant > 1) - SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_CONST; - else if (is_constant) - SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_FIXED; - - val = (Scheme_Object *)mv; - - scheme_hash_set(ht, stxsym, val); - - break; - } else { - /* Check that inspector is the same. */ - Module_Variable *mv = (Module_Variable *)val; - - if (!SAME_OBJ(mv->insp, insp)) { - /* Need binding for a different inspector. Try again. */ - val = scheme_hash_get(ht, insp); - if (!val) { - Scheme_Hash_Table *ht2; - /* Make a table for this specific inspector */ - ht2 = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(ht, insp, (Scheme_Object *)ht2); - ht = ht2; - /* loop... */ - } else - ht = (Scheme_Hash_Table *)val; - } else - break; - } - } - - return val; -} - /*********************************************************************/ -#define IS_SKIPPING_DEPTH(n) (n && !(n & 31)) - -void create_skip_table(Scheme_Comp_Env *start_frame) -{ - Scheme_Comp_Env *end_frame, *frame, *other_frame; - int depth, dj = 0, dp = 0, i; - Scheme_Hash_Tree *table; - int stride = 0, past_binding_frame = 0, past_stops_frame = 0; - - i = start_frame->skip_depth; - depth = 0; - while (!(i & 1)) { - depth = (depth << 1) | 1; - i >>= 1; - } - - /* Find frames to be covered by the skip table. */ - for (end_frame = start_frame->next; - end_frame && (depth & end_frame->skip_depth); - end_frame = end_frame->next) { - stride++; - } - - table = NULL; - - for (frame = start_frame; frame != end_frame; frame = frame->next) { - if (frame->skip_table) { - other_frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - if (other_frame == end_frame) { - end_frame = frame; - table = frame->skip_table; - dj = SCHEME_INT_VAL(scheme_eq_hash_tree_get(table, scheme_make_integer(1))); - dp = SCHEME_INT_VAL(scheme_eq_hash_tree_get(table, scheme_make_integer(2))); - past_binding_frame = SCHEME_TRUEP(scheme_eq_hash_tree_get(table, scheme_make_integer(3))); - past_stops_frame = SCHEME_TRUEP(scheme_eq_hash_tree_get(table, scheme_make_integer(4))); - break; - } - } - } - - if (!table) { - table = scheme_make_hash_tree(SCHEME_hashtr_eq); - table = scheme_hash_tree_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame); - } - - for (frame = start_frame; frame != end_frame; frame = frame->next) { - if (!(frame->flags & SCHEME_REC_BINDING_FRAME) - && frame->scopes) - past_binding_frame = 1; - if (frame->flags & SCHEME_FOR_STOPS) - past_stops_frame = 1; - if (frame->flags & SCHEME_LAMBDA_FRAME) - dj++; - if (!frame->vals) - dp += frame->num_bindings; - for (i = frame->num_bindings; i--; ) { - if (frame->bindings[i]) - table = scheme_hash_tree_set(table, frame->bindings[i], scheme_true); - if (frame->binders[i]) - table = scheme_hash_tree_set(table, SCHEME_STX_VAL(frame->binders[i]), scheme_true); - } - } - - table = scheme_hash_tree_set(table, scheme_make_integer(1), scheme_make_integer(dj)); - table = scheme_hash_tree_set(table, scheme_make_integer(2), scheme_make_integer(dp)); - table = scheme_hash_tree_set(table, scheme_make_integer(3), past_binding_frame ? scheme_true : scheme_false); - table = scheme_hash_tree_set(table, scheme_make_integer(4), past_stops_frame ? scheme_true : scheme_false); - - start_frame->skip_table = table; -} - -static void check_taint(Scheme_Object *find_id) -{ - if (scheme_stx_is_tainted(find_id)) - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "cannot use identifier tainted by macro transformation"); -} - Scheme_Object *scheme_intern_struct_proc_shape(int shape) { char buf[20]; @@ -1160,1251 +298,157 @@ Scheme_Object *scheme_intern_struct_prop_proc_shape(int shape) return scheme_intern_symbol(buf); } -void scheme_dump_env(Scheme_Comp_Env *env) -{ - Scheme_Comp_Env *frame; - - printf("Environment:\n"); - - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - for (i = frame->num_bindings; i--; ) { - printf(" %s -> %s\n %s\n", - scheme_write_to_string(frame->binders[i], NULL), - scheme_write_to_string(frame->bindings[i], NULL), - scheme_write_to_string((Scheme_Object *)((Scheme_Stx *)frame->binders[i])->scopes, NULL)); - } - } -} - -static int same_binding(Scheme_Object *a, Scheme_Object *b) -{ - if (SCHEME_VECTORP(a) && SCHEME_VECTORP(b)) { - if (SAME_OBJ(SCHEME_VEC_ELS(a)[1], SCHEME_VEC_ELS(b)[1]) - && SAME_OBJ(SCHEME_VEC_ELS(a)[2], SCHEME_VEC_ELS(b)[2]) - && (SAME_OBJ(SCHEME_VEC_ELS(a)[0], SCHEME_VEC_ELS(b)[0]) - || (SCHEME_TRUEP(SCHEME_VEC_ELS(a)[0]) - && SCHEME_TRUEP(SCHEME_VEC_ELS(b)[0]) - && scheme_equal(scheme_module_resolve(SCHEME_VEC_ELS(a)[0], 0), - scheme_module_resolve(SCHEME_VEC_ELS(b)[0], 0))))) - return 1; - else - return 0; - } else - return scheme_equal(a, b); -} - -static void set_binder(Scheme_Object **_binder, Scheme_Object *ref, Scheme_Object *bind) -{ - if (SAME_OBJ(SCHEME_STX_VAL(ref), SCHEME_STX_VAL(bind))) - ref = scheme_datum_to_syntax(SCHEME_STX_VAL(ref), ref, bind, 0, 2); - else { - /* rename transformer => treat like an expansion */ - ref = scheme_stx_track(scheme_datum_to_syntax(SCHEME_STX_VAL(bind), ref, bind, 0, 2), - ref, - ref); - } - - *_binder = ref; -} - /*********************************************************************/ -/* - scheme_compile_lookup() is the main resolver of lexical, module, - and top-level bindings. Depending on the value of `flags', it can - return a value whose type tag is: - - scheme_macro_type (id was bound to syntax), - - scheme_macro_set_type (id was bound to a set!-transformer), - - scheme_macro_id_type (id was bound to a rename-transformer), - - scheme_ir_local_type (id was lexical), - - scheme_variable_type (id is a global or module-bound variable), - or - - scheme_module_variable_type (id is a module-bound variable). - -*/ - -Scheme_Object * -scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, - Scheme_Object *in_modidx, - Scheme_Env **_menv, int *_protected, - Scheme_Object **_binder, int *_need_macro_scope, - Scheme_Object **_inline_variant) +Scheme_Comp_Env *scheme_new_comp_env(Scheme_Linklet *linklet, int flags) { - Scheme_Comp_Env *frame; - int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0, is_constant, ambiguous; - Scheme_Bucket *b; - Scheme_Object *binding, *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; - Scheme_Object *rename_insp = NULL, *mod_constant = NULL, *shape; - Scheme_Env *genv; + Scheme_Comp_Env *env; + Scheme_Hash_Tree *vars; - if (_binder) *_binder = NULL; - if (_need_macro_scope) *_need_macro_scope = 1; + env = MALLOC_ONE_RT(Scheme_Comp_Env); + SET_REQUIRED_TAG(env->type = scheme_rt_comp_env); + env->flags = flags; - binding = scheme_stx_lookup_w_nominal(find_id, scheme_env_phase(env->genv), - (flags & SCHEME_STOP_AT_FREE_EQ), - NULL, &ambiguous, NULL, - &rename_insp, - NULL, NULL, NULL, NULL); + vars = scheme_make_hash_tree(0); + env->vars = vars; -#if 0 - if (!strcmp("cons", SCHEME_SYM_VAL(SCHEME_STX_VAL(find_id)))) { - printf("%s\n", scheme_write_to_string(find_id, 0)); - scheme_stx_debug_print(find_id, scheme_env_phase(env->genv), 1); - printf("%s\n", scheme_write_to_string(binding, NULL)); - } -#endif + env->linklet = linklet; - if (ambiguous) { - if (SAME_OBJ(scheme_env_phase(env->genv), scheme_make_integer(0))) - scheme_wrong_syntax(NULL, NULL, find_id, - "identifier's binding is ambiguous%s", - scheme_stx_describe_context(find_id, scheme_make_integer(0), 1)); - else - scheme_wrong_syntax(NULL, NULL, find_id, - "identifier's binding is ambiguous\n" - " at phase: %V", - scheme_env_phase(env->genv), - scheme_stx_describe_context(find_id, scheme_env_phase(env->genv), 1)); - return NULL; - } - - /* If binding is a symbol, then it must be in the environment, or else - the identifier is out of context. - If binding is a vector, then it most likely refers to a module-level - binding, but we may have a "fluid" binding for in the environment - to implement stops. */ - - if (SCHEME_SYMBOLP(binding)) { - /* Walk through the compilation frames */ - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - - while (1) { - if (frame->skip_table) { - if (!scheme_eq_hash_tree_get(frame->skip_table, binding)) { - /* Skip ahead. 0 maps to frame, 1 maps to j delta, 2 maps to p delta, - 3 maps to binding-frameness, and 4 maps to stops-or-not (unneeded here) */ - val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(1)); - j += (int)SCHEME_INT_VAL(val); - val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(2)); - p += (int)SCHEME_INT_VAL(val); - val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(3)); - if (SCHEME_TRUEP(val)) - if (_need_macro_scope) - *_need_macro_scope = 0; - frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - } else - break; - } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { - create_skip_table(frame); - /* try again... */ - } else - break; - } - - if (!(env->flags & SCHEME_REC_BINDING_FRAME) && env->scopes) - if (_need_macro_scope) - *_need_macro_scope = 0; - - if (frame->flags & SCHEME_LAMBDA_FRAME) - j++; - - if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) { - if (frame->flags & SCHEME_FOR_STOPS) - skip_stops = 1; - - for (i = frame->num_bindings; i--; ) { - if (frame->bindings[i] && SAME_OBJ(binding, frame->bindings[i])) { - /* Found a lambda-, let-, etc. bound variable: */ - check_taint(find_id); - if (_binder) - set_binder(_binder, find_id, frame->binders[i]); - - if (!frame->vals) { - if (flags & SCHEME_DONT_MARK_USE) - return (Scheme_Object *)make_variable(NULL); - else - return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags); - } else { - val = frame->vals[i]; - - if (!val) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); - return NULL; - } - - if (SCHEME_FALSEP(val)) { - /* Corresponds to a run-time binding (but will be replaced later - through a renaming to a different binding) */ - if (flags & (SCHEME_OUT_OF_CONTEXT_LOCAL | SCHEME_SETTING)) - return (Scheme_Object *)make_variable(NULL); - return NULL; - } - - if (!(flags & SCHEME_ENV_CONSTANTS_OK)) { - if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) - return val; - else - scheme_wrong_syntax(scheme_set_stx_string, NULL, find_id, - "local syntax identifier cannot be mutated"); - return NULL; - } - - return val; - } - } - } - } - - if (!frame->vals) - p += frame->num_bindings; - - if (!frame->next->next && frame->next->intdef_next) { - frame = frame->next->intdef_next; - continue; - } - } - - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context%s", - scheme_stx_describe_context(find_id, scheme_env_phase(env->genv), 1)); - } - - if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) - return (Scheme_Object *)make_variable(NULL); - - return NULL; - } else { - /* First, check for a "stop" */ - for (frame = env; frame->next != NULL; frame = frame->next) { - while (1) { - if (frame->skip_table) { - /* skip if we won't jump over stops: */ - if (SCHEME_FALSEP(scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(4)))) - frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - else - break; - } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { - create_skip_table(frame); - /* try again */ - } else - break; - } - - if (frame->flags & SCHEME_FOR_STOPS) { - int i; - for (i = frame->num_bindings; i--; ) { - if (same_binding(frame->bindings[i], binding) - && (SCHEME_TRUEP(binding) - || SAME_OBJ(SCHEME_STX_VAL(frame->binders[i]), - SCHEME_STX_VAL(find_id)))) { - check_taint(find_id); - - return frame->vals[i]; - } - } - /* ignore any further stop frames: */ - break; - } - } - - if (SCHEME_FALSEP(binding)) { - src_find_id = find_id; - modidx = NULL; - mod_defn_phase = NULL; - } else { - src_find_id = find_id; - modidx = SCHEME_VEC_ELS(binding)[0]; - if (SCHEME_FALSEP(modidx)) modidx = NULL; - find_id = SCHEME_VEC_ELS(binding)[1]; - mod_defn_phase = SCHEME_VEC_ELS(binding)[2]; - } - } - - if (modidx) { - /* If it's an access path, resolve it: */ - modname = scheme_module_resolve(modidx, 1); - - if (env->genv->module && SAME_OBJ(modname, env->genv->module->modname)) { - modidx = NULL; - modname = NULL; - genv = env->genv; - /* So we can distinguish between unbound identifiers in a module - and references to top-level definitions: */ - module_self_reference = 1; - - if (_need_macro_scope) { - for (frame = env; frame->next != NULL; frame = frame->next) { - if (!(frame->flags & (SCHEME_TOPLEVEL_FRAME - | SCHEME_MODULE_FRAME)) - && frame->scopes) { - *_need_macro_scope = 0; - break; - } - } - } - } else { - if (_need_macro_scope) - *_need_macro_scope = 0; - - genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase)); - - if (!genv) { - scheme_wrong_syntax("require", NULL, src_find_id, - "namespace mismatch;\n" - " reference to a module that is not available\n" - " reference phase: %d\n" - " referenced module: %D\n" - " referenced phase level: %d", - env->genv->phase, modname, SCHEME_INT_VAL(mod_defn_phase)); - } - } - } else { - genv = env->genv; - modname = NULL; - - if (genv->module && genv->disallow_unbound) { - if (genv->disallow_unbound > 0) { - /* Free identifier. Maybe don't continue. */ - if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { - scheme_unbound_syntax(((flags & SCHEME_SETTING) - ? scheme_set_stx_string - : scheme_var_ref_string), - NULL, src_find_id, "unbound identifier in module", - scheme_stx_describe_context(src_find_id, scheme_env_phase(genv), 0)); - return NULL; - } - if (flags & SCHEME_NULL_FOR_UNBOUND) - return NULL; - } else { - if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { - scheme_register_unbound_toplevel(env, src_find_id); - } - /* continue, for now */ - } - } - } - - if (_menv && genv->module) - *_menv = genv; - - if (SCHEME_STXP(find_id)) { - find_global_id = scheme_future_global_binding(find_id, env->genv); - if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id)) - && SCHEME_FALSEP(binding)) { - /* Since we got a symbol back, there's at least a "temporary" - top-level binding for the identifier in the current namespace */ - binding = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(binding)[0] = find_global_id; - SCHEME_VEC_ELS(binding)[1] = (env->genv->module ? env->genv->module->modname : scheme_false); - SCHEME_VEC_ELS(binding)[2] = scheme_env_phase(env->genv); - } else if (flags & SCHEME_NULL_FOR_UNBOUND) - return NULL; - } else - find_global_id = find_id; - - /* Try syntax table: */ - if (modname) { - val = scheme_module_syntax(modname, env->genv, find_id, SCHEME_INT_VAL(mod_defn_phase)); - if (val && !(flags & SCHEME_NO_CERT_CHECKS)) - scheme_check_accessible_in_module_instance(genv, - find_id, src_find_id, - env->insp, rename_insp, - -2, 0, - NULL, NULL, - env->genv, NULL, NULL); - } else { - /* Only try syntax table if there's not an explicit (later) - variable mapping: */ - if (genv->shadowed_syntax - && scheme_hash_get(genv->shadowed_syntax, find_global_id)) - val = NULL; - else - val = scheme_lookup_in_table(genv->syntax, (const char *)find_global_id); - } - - if (val) { - check_taint(src_find_id); - return val; - } - - if (modname) { - Scheme_Object *pos; - if (flags & SCHEME_NO_CERT_CHECKS) - pos = 0; - else - pos = scheme_check_accessible_in_module_instance(genv, - find_id, src_find_id, - env->insp, rename_insp, - -1, 1, - _protected, NULL, - env->genv, NULL, &mod_constant); - modpos = (int)SCHEME_INT_VAL(pos); - } else - modpos = -1; - - if (modname && (flags & SCHEME_SETTING)) { - if (SAME_OBJ(src_find_id, find_id) || SAME_OBJ(SCHEME_STX_SYM(src_find_id), find_id)) - find_id = NULL; - scheme_wrong_syntax(scheme_set_stx_string, find_id, src_find_id, "cannot mutate module-required identifier"); - return NULL; - } - - if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) - && (genv->module && (genv->disallow_unbound > 0))) { - /* Check for set! of unbound identifier: */ - if (!scheme_lookup_in_table(genv->toplevel, (const char *)find_global_id)) { - scheme_unbound_syntax(((flags & SCHEME_SETTING) - ? scheme_set_stx_string - : scheme_var_ref_string), - NULL, src_find_id, "unbound identifier in module", - scheme_stx_describe_context(src_find_id, scheme_env_phase(genv), 0)); - return NULL; - } - } - - if (!modname && (flags & SCHEME_NULL_FOR_UNBOUND)) { - if (module_self_reference) { - /* Since the module has a rename for this id, it's certainly defined. */ - if (!(flags & SCHEME_RESOLVE_MODIDS)) { - /* This is the same thing as #%top handling in compile mode. But - for expand mode, it prevents wrapping the identifier with #%top. */ - /* Don't need a pos, because the symbol's gensym-ness (if any) will be - preserved within the module. */ - check_taint(src_find_id); - return scheme_hash_module_variable(genv, genv->module->self_modidx, find_id, - genv->module->insp, - -1, genv->mod_phase, 0, - NULL); - } - } else if (SCHEME_VECTORP(binding) && !genv->module) { - /* The identifier is specifically bound as a top-level definition. */ - return (Scheme_Object *)scheme_global_bucket(find_global_id, genv); - } else - return NULL; - } - - check_taint(src_find_id); - - shape = NULL; - if (mod_constant) { - if (SAME_OBJ(mod_constant, scheme_constant_key)) - is_constant = 2; - else if (SAME_OBJ(mod_constant, scheme_fixed_key)) - is_constant = 1; - else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_proc_shape_type)) { - is_constant = 2; - shape = SCHEME_PTR_VAL(mod_constant); - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { - if (_inline_variant) - *_inline_variant = mod_constant; - is_constant = 2; - shape = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_prop_proc_shape_type)) { - if (_inline_variant) - *_inline_variant = mod_constant; - is_constant = 2; - shape = scheme_intern_struct_prop_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { - if (_inline_variant) { - /* In case the inline variant includes references to module - variables, we'll need to shift the references: */ - Scheme_Object *shiftable; - shiftable = scheme_make_vector(4, scheme_false); - SCHEME_VEC_ELS(shiftable)[0] = mod_constant; - SCHEME_VEC_ELS(shiftable)[1] = genv->module->me->src_modidx; - SCHEME_VEC_ELS(shiftable)[2] = modidx; - SCHEME_VEC_ELS(shiftable)[3] = mod_defn_phase; - *_inline_variant = shiftable; - } - is_constant = 2; - shape = scheme_get_or_check_procedure_shape(mod_constant, NULL); - } else { - if (flags & SCHEME_ELIM_CONST) - return mod_constant; - is_constant = 2; - } - } else - is_constant = 0; - - /* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad - idea, because it causes module instances to be preserved. */ - if (modname && !(flags & SCHEME_RESOLVE_MODIDS) - && (!(scheme_is_kernel_modname(modname) - || scheme_is_unsafe_modname(modname) - || scheme_is_flfxnum_modname(modname) - || scheme_is_extfl_modname(modname) - || scheme_is_futures_modname(modname) - || scheme_is_foreign_modname(modname)) - || (flags & SCHEME_REFERENCING))) { - /* Create a module variable reference, so that idx is preserved: */ - return scheme_hash_module_variable(env->genv, modidx, find_id, - (rename_insp ? rename_insp : genv->module->insp), - modpos, SCHEME_INT_VAL(mod_defn_phase), - is_constant, shape); - } - - if (!modname - && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) - && genv->module - && !(flags & SCHEME_RESOLVE_MODIDS)) { - /* Need to return a variable reference in this case, too. */ - return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, - genv->module->insp, - modpos, genv->mod_phase, - is_constant, shape); - } - - b = scheme_bucket_from_table(genv->toplevel, (char *)find_global_id); - - if ((flags & SCHEME_ELIM_CONST) && b && b->val - && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST) - && !(flags & SCHEME_GLOB_ALWAYS_REFERENCE) - && (!modname || scheme_is_kernel_modname(modname))) - return (Scheme_Object *)b->val; - - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, genv); - - return (Scheme_Object *)b; + return env; } -static Scheme_Comp_Env *find_first_relevant(Scheme_Object *stx, Scheme_Comp_Env *frame) +Scheme_Comp_Env *scheme_extend_comp_env(Scheme_Comp_Env *env, Scheme_Object *id, Scheme_Object *var, + int mutate, int check_dups) { - int i; + Scheme_Comp_Env *env2; + Scheme_Hash_Tree *vars; - for (; frame->next != NULL; frame = frame->next) { - while (1) { - if (frame->skip_table) { - if (!scheme_eq_hash_tree_get(frame->skip_table, SCHEME_STX_VAL(stx))) { - frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); - } else - break; - } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { - create_skip_table(frame); - /* try again... */ - } else - break; - } + MZ_ASSERT(SCHEME_STX_SYMBOLP(id)); + id = SCHEME_STX_SYM(id); - for (i = frame->num_bindings; i--; ) { - if (frame->binders[i] && SAME_OBJ(SCHEME_STX_VAL(stx), SCHEME_STX_VAL(frame->binders[i]))) - return frame; - } + if (mutate) + env2 = env; + else { + env2 = MALLOC_ONE_RT(Scheme_Comp_Env); + memcpy(env2, env, sizeof(Scheme_Comp_Env)); } - return frame; + if (check_dups) { + if (scheme_hash_tree_get(env2->vars, id)) + return NULL; + } + + vars = scheme_hash_tree_set(env2->vars, id, var); + env2->vars = vars; + + return env2; } -static Scheme_Object *add_all_context(Scheme_Object *id, Scheme_Comp_Env *env) +Scheme_Comp_Env *scheme_set_comp_env_flags(Scheme_Comp_Env *env, int flags) { Scheme_Comp_Env *env2; - for (env2 = env; env2; env2 = env2->next) { - if (env2->scopes) { - id = scheme_stx_adjust_frame_scopes(id, env2->scopes, scheme_env_phase(env2->genv), - SCHEME_STX_ADD); - } + if ((env->flags & flags) == flags) + return env; + + env2 = MALLOC_ONE_RT(Scheme_Comp_Env); + memcpy(env2, env, sizeof(Scheme_Comp_Env)); + env2->flags |= flags; + + return env2; +} + +Scheme_Comp_Env *scheme_set_comp_env_name(Scheme_Comp_Env *env, Scheme_Object *name) +{ + Scheme_Comp_Env *env2; + + if (SAME_OBJ(env->value_name, name)) + return env; + + env2 = MALLOC_ONE_RT(Scheme_Comp_Env); + memcpy(env2, env, sizeof(Scheme_Comp_Env)); + env2->value_name = name; + + return env2; +} + +/*********************************************************************/ + +static Scheme_Object *get_local_name(Scheme_Object *id) +{ + Scheme_Object *name; + + name = scheme_stx_property(id, undefined_error_name_symbol, NULL); + if (name && SCHEME_SYMBOLP(name)) + return name; + else + return SCHEME_STX_SYM(id); +} + +Scheme_IR_Local *scheme_make_ir_local(Scheme_Object *id) +{ + Scheme_IR_Local *var; + + var = MALLOC_ONE_TAGGED(Scheme_IR_Local); + var->so.type = scheme_ir_local_type; + if (id) { + id = get_local_name(id); + var->name = id; } - if (env->genv->module && env->genv->module->ii_src) - id = scheme_stx_binding_union(id, env->genv->module->ii_src, scheme_env_phase(env->genv)); - else - id = scheme_stx_add_module_context(id, env->genv->stx_context); - id = scheme_stx_adjust_module_use_site_context(id, env->genv->stx_context, SCHEME_STX_ADD); - - return id; + return var; } -static Scheme_Object *find_local_binder(Scheme_Object *sym, Scheme_Comp_Env *env) +static void record_local_use(Scheme_IR_Local *var, int flags) { - Scheme_Comp_Env *frame; - Scheme_Object *id, **sds, *sd; + if (var->use_count < SCHEME_USE_COUNT_INF) + var->use_count++; + if (flags & SCHEME_SETTING) + var->mutated = 1; + if (!(flags & (SCHEME_APP_POS | SCHEME_SETTING))) + if (var->non_app_count < SCHEME_USE_COUNT_INF) + var->non_app_count++; - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - - for (i = frame->num_bindings; i--; ) { - id = frame->binders[i]; - if (id && SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->binders[i]))) { - if (!frame->shadower_deltas) { - sds = MALLOC_N(Scheme_Object*,frame->num_bindings); - frame->shadower_deltas = sds; - } - sd = frame->shadower_deltas[i]; - if (!sd) { - sd = add_all_context(scheme_datum_to_syntax(SCHEME_STX_VAL(id), scheme_false, scheme_false, 0, 0), - frame); - sd = scheme_stx_binding_subtract(id, sd, scheme_env_phase(env->genv)); - frame->shadower_deltas[i] = sd; - } - if (scheme_stx_could_bind(sd, sym, scheme_env_phase(env->genv))) - return id; - } - } + if (var->mode == SCHEME_VAR_MODE_COMPILE) { + if ((*var->compile.use_box) < var->compile.use_position) + (*var->compile.use_box) = var->compile.use_position; } - - return NULL; } -Scheme_Object *scheme_get_shadower(Scheme_Object *sym, Scheme_Comp_Env *env, int only_generated) +Scheme_Object * +scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags) { - Scheme_Comp_Env *start_env; - Scheme_Object *binder, *orig_sym; + Scheme_Object *v; - orig_sym = sym; + v = scheme_hash_tree_get(env->vars, SCHEME_STX_SYM(find_id)); - start_env = find_first_relevant(sym, env); - if (start_env->next) - binder = find_local_binder(sym, start_env); - else - binder = NULL; + if (!v) { + v = scheme_hash_get(scheme_startup_env->all_primitives_table, SCHEME_STX_SYM(find_id)); - if (binder) - sym = scheme_stx_binding_union(binder, sym, scheme_env_phase(env->genv)); - else if (only_generated) - sym = scheme_stx_introduce_to_module_context(sym, env->genv->stx_context); - else if (env->genv->module && env->genv->module->ii_src) - sym = scheme_stx_binding_union(sym, env->genv->module->ii_src, scheme_env_phase(env->genv)); - else if (env->genv->stx_context) - sym = scheme_stx_add_module_context(sym, env->genv->stx_context); - - if (!scheme_stx_is_clean(orig_sym)) - sym = scheme_stx_taint(sym); - - return sym; -} - -Scheme_Hash_Table *scheme_get_binding_names_table(Scheme_Env *env) -{ - Scheme_Hash_Table *binding_names; - - scheme_binding_names_from_module(env); - - if (env->binding_names - && SCHEME_HASHTRP(env->binding_names)) { - /* convert to a mutable hash table */ - binding_names = (Scheme_Hash_Table *)scheme_hash_tree_copy(env->binding_names); - env->binding_names = (Scheme_Object *)binding_names; - if (env->binding_names_need_shift) { + if (v && (flags & SCHEME_REFERENCING)) { + /* Which primitive table is it? */ int i; - for (i = binding_names->size; i--; ) { - if (binding_names->vals[i]) { - Scheme_Object *id; - id = binding_names->vals[i]; - if (!SAME_OBJ(id, scheme_true)) - id = scheme_stx_shift(id, scheme_make_integer(env->phase - env->mod_phase), - env->module->self_modidx, env->link_midx, - env->module_registry->exports, - env->module->prefix->src_insp_desc, env->access_insp); - binding_names->vals[i] = id; + for (i = 0; i < scheme_startup_env->primitive_tables->size; i++) { + if (scheme_startup_env->primitive_tables->vals[i]) { + if (scheme_hash_get((Scheme_Hash_Table *)scheme_startup_env->primitive_tables->vals[i], SCHEME_STX_SYM(find_id))) + return scheme_startup_env->primitive_tables->keys[i]; /* symbol => kernel primitive */ } } + scheme_signal_error("internal error: could not find instance for a primitive"); } } - binding_names = (Scheme_Hash_Table *)env->binding_names; - if (!binding_names) { - binding_names = scheme_make_hash_table(SCHEME_hash_ptr); - env->binding_names = (Scheme_Object *)binding_names; - env->binding_names_need_shift = 0; + if (!v) { + if (flags & SCHEME_NULL_FOR_UNBOUND) + return NULL; + scheme_wrong_syntax(NULL, NULL, find_id, "free identifier found in linklet"); } - return binding_names; -} - -static int binding_name_available(Scheme_Hash_Table *binding_names, Scheme_Object *sym, - Scheme_Object *id, Scheme_Object *phase) -{ - sym = scheme_eq_hash_get(binding_names, sym); - if (!sym || (SCHEME_STXP(sym) && scheme_stx_bound_eq(sym, id, phase))) - return 1; - return 0; -} - -static Scheme_Object *select_binding_name(Scheme_Object *sym, Scheme_Env *env, - Scheme_Object *id, Scheme_Object *orig_id) -{ - int i; - char onstack[50], *buf; - intptr_t len; - Scheme_Hash_Table *binding_names; - - binding_names = scheme_get_binding_names_table(env); - - /* Use a plain symbol only if the binding has no extra scopes: */ - if (SCHEME_SYM_WEIRDP(sym) - || scheme_stx_equal_module_context(orig_id, ((env->module && env->module->ii_src) - ? env->module->ii_src - : env->stx_context))) { - if (binding_name_available(binding_names, sym, orig_id, scheme_env_phase(env))) { - scheme_hash_set(binding_names, sym, orig_id); - return sym; - } - } - - len = SCHEME_SYM_LEN(sym); - if (len <= 35) - buf = onstack; - else - buf = scheme_malloc_atomic(len + 15); - memcpy(buf, SCHEME_SYM_VAL(sym), len); - - i = 0; - while (1) { - sprintf(buf XFORM_OK_PLUS len, ".%d", i); - sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); - - if (binding_name_available(binding_names, sym, id, scheme_env_phase(env))) { - scheme_hash_set(binding_names, sym, orig_id); - return sym; - } - - i++; - } -} - -static int binding_matches_env(Scheme_Object *binding, Scheme_Env *env, Scheme_Object *phase) -{ - return (SCHEME_VECTORP(binding) - && (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], - (env->module - ? env->module->self_modidx - : scheme_false)) - || SAME_OBJ(SCHEME_VEC_ELS(binding)[0], - env->link_midx)) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], phase)); -} - -Scheme_Object *scheme_global_binding(Scheme_Object *id, Scheme_Env *env, int for_top_level) -{ - Scheme_Object *sym, *binding, *phase, *orig_id = id; - int exact_match; - - phase = scheme_env_phase(env); - - if (for_top_level) { - /* While compiling, we want to avoid binding in the top-level namespace. - Adding an extra scope avoids that while still letting us have some binding - to generate names for top-level definitions. */ - if (!env->tmp_bind_scope) { - sym = scheme_new_scope(SCHEME_STX_MODULE_SCOPE); - env->tmp_bind_scope = sym; - } - id = scheme_stx_add_scope(id, env->tmp_bind_scope, phase); - } - - binding = scheme_stx_lookup_stop_at_free_eq(id, phase, &exact_match); - - if (!SCHEME_FALSEP(binding)) { - if (exact_match) { - if (binding_matches_env(binding, env, phase)) { - sym = SCHEME_VEC_ELS(binding)[1]; - /* Make sure name is in binding_names and with a specific `id`: */ - scheme_hash_set(scheme_get_binding_names_table(env), sym, orig_id); - return sym; - } - /* Since the binding didn't match, we'll "shadow" the binding - by replacing it below. */ - } - } - - sym = select_binding_name(SCHEME_STX_VAL(id), env, id, orig_id); - - scheme_add_module_binding(id, phase, - (env->module ? env->module->self_modidx : scheme_false), - (env->module - ? (env->module->prefix - ? env->module->prefix->src_insp_desc - : env->module->insp) - : env->guard_insp), - sym, - phase); - - return sym; -} - -Scheme_Object *scheme_future_global_binding(Scheme_Object *id, Scheme_Env *env) -/* The identifier id is being referenced before it has a binding. We - want to allow it, anyway, perhaps because it's outside of a module - context or because it's phase-1 code. So, we assume that it's going to - have no extra scopes and get the base name. - - Then again, if `id` has a binding after adding the environment's temporary - binding scope, then map the identifier to that temporary binding's name. - That special case allows compiling a `define` to create a binding that - can be referenced in the same compilation. */ -{ - if (env->tmp_bind_scope) { - Scheme_Object *binding, *phase; - - phase = scheme_env_phase(env); - id = scheme_stx_add_scope(id, env->tmp_bind_scope, phase); - binding = scheme_stx_lookup_stop_at_free_eq(id, phase, NULL); - - if (binding_matches_env(binding, env, phase)) - return SCHEME_VEC_ELS(binding)[1]; + if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) { + if (!(env->flags & COMP_ENV_DONT_COUNT_AS_USE)) + record_local_use((Scheme_IR_Local *)v, flags); } - return SCHEME_STX_VAL(id); -} - -int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env) -{ - if (env->genv->module) { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - if (!SAME_OBJ(((Module_Variable *)var)->modidx, env->genv->module->self_modidx)) - return 1; - } else - return 1; - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) { - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)var); - if (!SAME_OBJ(home, env->genv)) - return 1; - } else - return 1; - } - return 0; -} - -Scheme_Object *scheme_extract_unsafe(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_unsafe_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_flfxnum_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -Scheme_Object *scheme_extract_extfl(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_extfl_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -Scheme_Object *scheme_extract_futures(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_futures_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -Scheme_Object *scheme_extract_foreign(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_foreign_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame) -{ - int any_use; - - any_use = frame->any_use; - frame->any_use = 0; - - return any_use; -} - -int scheme_env_max_use_above(Scheme_Comp_Env *frame, int pos) -{ - return frame->max_use >= pos; -} - -void scheme_mark_all_use(Scheme_Comp_Env *frame) -{ - /* Mark all variables as used for the purposes of `letrec-syntaxes+values` - splitting */ - while (frame && (frame->max_use < frame->num_bindings)) { - frame->max_use = frame->num_bindings; - frame = frame->next; - } -} - -/*========================================================================*/ -/* macro hooks */ -/*========================================================================*/ - - -Scheme_Object * -scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env, *orig_env; - Scheme_Object *id, *ids, *rev_ids, *local_scope, *expr, *data, *vec, *id_sym; - Scheme_Lift_Capture_Proc cp; - Scheme_Object *orig_expr; - int count; - char buf[24]; - - if (stx_pos) { - if (SCHEME_INTP(argv[0])) { - count = (int)SCHEME_INT_VAL(argv[0]); - } else if (SCHEME_BIGNUMP(argv[0])) { - if (SCHEME_BIGPOS(argv[0])) - scheme_raise_out_of_memory(NULL, NULL); - count = -1; - } else - count = -1; - - if (count < 0) - scheme_wrong_contract(who, "exact-nonnegative-integer?", 0, argc, argv); - } else - count = 1; - - expr = argv[stx_pos]; - if (!SCHEME_STXP(expr)) - scheme_wrong_contract(who, "syntax?", stx_pos, argc, argv); - - env = orig_env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - scheme_contract_error(who, - "not currently transforming", - NULL); - - env = scheme_get_env_for_lifts(env); - - if (env) - if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) - env = NULL; - - if (!env) - scheme_contract_error("syntax-local-lift-expression", - "no lift target", - NULL); - - if (local_scope) - expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); - - /* We don't really need a new symbol each time, since the scope - will generate new bindings, but things may work better or faster - when different bindings have different symbols. Use env->genv->id_counter - to help keep name generation deterministic within a module. */ - rev_ids = scheme_null; - while (count--) { - sprintf(buf, "lifted.%d", env->genv->id_counter++); - id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); - - id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0); - id = scheme_stx_add_scope(id, scheme_new_scope(SCHEME_STX_MACRO_SCOPE), scheme_env_phase(env->genv)); - - if (env->genv->stx_context) - id = scheme_stx_introduce_to_module_context(id, env->genv->stx_context); - if (env->flags & SCHEME_TMP_TL_BIND_FRAME) { - /* When the lifetd definition is compiled, `tmp_bind_scope` will - be added to the defined name so that a fresh binding is not - created. We have added a fresh scope that would keep it - distinct, anyway, but add the tmp scope here to keep the - definition and reference in sync. */ - if (!env->genv->tmp_bind_scope) { - id_sym = scheme_new_scope(SCHEME_STX_MODULE_SCOPE); - env->genv->tmp_bind_scope = id_sym; - } - id = scheme_stx_add_scope(id, env->genv->tmp_bind_scope, scheme_env_phase(env->genv)); - } - - rev_ids = scheme_make_pair(id, rev_ids); - } - ids = scheme_reverse(rev_ids); - - vec = env->lifts; - cp = *(Scheme_Lift_Capture_Proc *)SCHEME_VEC_ELS(vec)[1]; - data = SCHEME_VEC_ELS(vec)[2]; - - orig_expr = expr; - - expr = cp(data, &ids, expr, orig_env); - - expr = scheme_make_pair(expr, SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = expr; - - SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(scheme_get_expand_observe(), ids, orig_expr); - - rev_ids = scheme_null; - for (; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - if (local_scope) - id = scheme_stx_flip_scope(id, local_scope, scheme_env_phase(env->genv)); - rev_ids = scheme_make_pair(id, rev_ids); - } - ids = scheme_reverse(rev_ids); - - return ids; -} - -Scheme_Object * -scheme_local_lift_context(Scheme_Comp_Env *env) -{ - env = scheme_get_env_for_lifts(env); - - if (!env) - return scheme_false; - - return SCHEME_VEC_ELS(env->lifts)[4]; -} - -Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env) -{ - while (env) { - if ((env->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[3])) - break; - env = env->next; - } - - return env; -} - -static Scheme_Comp_Env *get_lift_env_for_module(Scheme_Comp_Env *env) -{ - while (env) { - if ((env->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[8])) - break; - env = env->next; - } - - return env; -} - -Scheme_Object * -scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env) -{ - Scheme_Object *pr; - Scheme_Object *orig_expr; - - env = scheme_get_module_lift_env(env); - - if (!env) - scheme_contract_error("syntax-local-lift-module-end-declaration", - "not currently transforming" - " an expression within a module declaration", - NULL); - - if (local_scope) - expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); - orig_expr = expr; - - pr = scheme_make_pair(expr, SCHEME_VEC_ELS(env->lifts)[3]); - SCHEME_VEC_ELS(env->lifts)[3] = pr; - - SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr); - - return scheme_void; -} - -Scheme_Object * -scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env) -{ - Scheme_Object *pr; - Scheme_Object *orig_expr; - int star_ok, slot; - - env = get_lift_env_for_module(env); - - if (!env) - scheme_contract_error("syntax-local-lift-module", - "not currently transforming within a module declaration or top level", - NULL); - - if (local_scope) - expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); - orig_expr = expr; - - star_ok = !SAME_OBJ(scheme_true, SCHEME_VEC_ELS(env->lifts)[8]); - - if (SCHEME_STX_PAIRP(expr)) { - pr = SCHEME_STX_CAR(expr); - if (scheme_stx_free_eq3(pr, scheme_module_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) { - /* ok */ - } else if (scheme_stx_free_eq3(pr, scheme_modulestar_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) { - if (!star_ok) - scheme_contract_error("syntax-local-lift-module", - "cannot lift `module*' to a top-level context", - "syntax", 1, expr, - NULL); - /* otherwise, ok */ - } else - pr = NULL; - } else - pr = NULL; - - if (!pr) - scheme_contract_error("syntax-local-lift-module", - "not a module declaration", - "syntax", 1, expr, - NULL); - - /* Add to separate list or mingle with definitions? */ - if (SCHEME_NULLP(SCHEME_VEC_ELS(env->lifts)[8]) - || SCHEME_PAIRP(SCHEME_VEC_ELS(env->lifts)[8])) - slot = 8; - else - slot = 0; - - pr = scheme_make_pair(expr, SCHEME_VEC_ELS(env->lifts)[slot]); - SCHEME_VEC_ELS(env->lifts)[slot] = pr; - - SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr); - - return scheme_void; -} - -Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, - intptr_t phase, Scheme_Object *local_scope, Scheme_Comp_Env *cenv) -{ - Scheme_Object *scope, *data, *pr; - Scheme_Object *req_form; - int need_prepare = 0; - Scheme_Comp_Env *env; - - data = NULL; - - env = cenv; - while (env) { - if (env->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[5])) { - data = SCHEME_VEC_ELS(env->lifts)[5]; - if (SCHEME_RPAIRP(data) - && !SCHEME_CAR(data)) { - env = (Scheme_Comp_Env *)SCHEME_CDR(data); - } else - break; - } else - env = env->next; - } - - if (!env) - scheme_contract_error("syntax-local-lift-requires", - "could not find target context", - NULL); - - - scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - - if (SCHEME_RPAIRP(data)) - form = scheme_parse_lifted_require(form, phase, scope, SCHEME_CAR(data), &orig_form, cenv); - else { - form = scheme_toplevel_require_for_expand(form, phase, cenv, scope); - need_prepare = 1; - } - - pr = scheme_make_pair(form, SCHEME_VEC_ELS(env->lifts)[6]); - SCHEME_VEC_ELS(env->lifts)[6] = pr; - - req_form = form; - - form = orig_form; - form = scheme_stx_flip_scope(form, scope, scheme_env_phase(env->genv)); - - SCHEME_EXPAND_OBSERVE_LIFT_REQUIRE(scheme_get_expand_observe(), req_form, orig_form, form); - - /* In a top-level context, may need to force compile-time evaluation: */ - if (need_prepare) - scheme_prepare_compile_env(env->genv); - - return form; -} - -Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_scope, - Scheme_Comp_Env *env) -{ - Scheme_Object *pr; - - while (env) { - if (env->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[7])) { - break; - } else - env = env->next; - } - - if (!env) - scheme_contract_error("syntax-local-lift-provide", - "not expanding in a module run-time body", - NULL); - - if (local_scope) - form = scheme_stx_flip_scope(form, local_scope, scheme_env_phase(env->genv)); - form = scheme_datum_to_syntax(scheme_make_pair(scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), - scheme_false, scheme_sys_wraps(env), - 0, 0), - scheme_make_pair(form, scheme_null)), - form, scheme_false, 0, 0); - - SCHEME_EXPAND_OBSERVE_LIFT_PROVIDE(scheme_get_expand_observe(), form); - - pr = scheme_make_pair(form, SCHEME_VEC_ELS(env->lifts)[7]); - SCHEME_VEC_ELS(env->lifts)[7] = pr; - - return scheme_void; -} - -Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, - Scheme_Object **_id, int *_use_map) -{ - Scheme_Object *id = NULL, *v; - Scheme_Comp_Env inlined_e; - - scheme_prepare_env_stx_context(genv); - scheme_prepare_compile_env(genv); - - id = scheme_datum_to_syntax(sym, scheme_false, scheme_false, 0, 0); - id = scheme_stx_add_module_context(id, genv->stx_context); - - inlined_e.num_bindings = 0; - inlined_e.next = NULL; - inlined_e.genv = genv; - inlined_e.flags = SCHEME_TOPLEVEL_FRAME; - init_compile_data(&inlined_e); - inlined_e.prefix = NULL; - - v = scheme_compile_lookup(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, - NULL, - NULL, NULL, - NULL, NULL, NULL); - if (v) { - if (!SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) { - *_use_map = -1; - v = NULL; - } else - v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; - } - - *_id = id; return v; } @@ -2413,8 +457,7 @@ Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *gen /*========================================================================*/ void scheme_check_identifier(const char *formname, Scheme_Object *id, - const char *where, Scheme_Comp_Env *env, - Scheme_Object *form) + const char *where, Scheme_Object *form) { if (!where) where = ""; @@ -2423,16 +466,10 @@ void scheme_check_identifier(const char *formname, Scheme_Object *id, scheme_wrong_syntax(formname, form ? id : NULL, form ? form : id, "not an identifier%s", where); - - if (scheme_stx_is_tainted(id)) - scheme_wrong_syntax(formname, form ? id : NULL, - form ? form : id, - "cannot bind identifier tainted by macro expansion%s", where); } -void scheme_begin_dup_symbol_check(DupCheckRecord *r, Scheme_Comp_Env *env) +void scheme_begin_dup_symbol_check(DupCheckRecord *r) { - r->phase = env->genv->phase; r->count = 0; } @@ -2441,11 +478,10 @@ void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, Scheme_Object *form) { int i; - Scheme_Object *l; if (r->count <= 5) { for (i = 0; i < r->count; i++) { - if (scheme_stx_bound_eq(symbol, r->syms[i], scheme_make_integer(r->phase))) + if (SAME_OBJ(SCHEME_STX_SYM(symbol), SCHEME_STX_SYM(r->syms[i]))) scheme_wrong_syntax(where, symbol, form, "duplicate %s name", what); } @@ -2458,27 +494,19 @@ void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, ht = scheme_make_hash_table(SCHEME_hash_ptr); r->ht = ht; for (i = 0; i < r->count; i++) { - l = scheme_hash_get(ht, SCHEME_STX_VAL(r->syms[i])); - if (!l) l = scheme_null; - l = scheme_make_pair(r->syms[i], l); - scheme_hash_set(ht, SCHEME_STX_VAL(r->syms[i]), l); + scheme_hash_set(ht, SCHEME_STX_SYM(r->syms[i]), r->syms[i]); } r->count++; } } - l = scheme_hash_get(r->ht, SCHEME_STX_VAL(symbol)); - if (!l) l = scheme_null; - scheme_hash_set(r->ht, SCHEME_STX_VAL(symbol), scheme_make_pair(symbol, l)); - - while (!SCHEME_NULLP(l)) { - if (scheme_stx_bound_eq(symbol, SCHEME_CAR(l), scheme_make_integer(r->phase))) { - scheme_wrong_syntax(where, symbol, form, - "duplicate %s name", what); - return; - } - l = SCHEME_CDR(l); + if (scheme_hash_get(r->ht, SCHEME_STX_SYM(symbol))) { + scheme_wrong_syntax(where, symbol, form, + "duplicate %s name", what); + return; } + + scheme_hash_set(r->ht, SCHEME_STX_SYM(symbol), symbol); } diff --git a/racket/src/racket/src/compile-startup.rkt b/racket/src/racket/src/compile-startup.rkt new file mode 100644 index 0000000000..f83089e9de --- /dev/null +++ b/racket/src/racket/src/compile-startup.rkt @@ -0,0 +1,126 @@ +(module compile-startup '#%kernel + (#%require '#%linklet + "help-startup.rkt") + + ;; Decode a linklet S-expression from "startup.inc" (in the source + ;; directory), compile it, and write it back as "cstartup.inc" (in + ;; the build directory) + + (define-values (dest) (vector-ref (current-command-line-arguments) 0)) + (define-values (zo-dest) (vector-ref (current-command-line-arguments) 1)) + (define-values (src) (vector-ref (current-command-line-arguments) 2)) + (define-values (vers) (vector-ref (current-command-line-arguments) 3)) + (define-values (other-files) (list-tail (vector->list (current-command-line-arguments)) 4)) + + (define-values (version-comparisons) (get-version-comparisons vers)) + + ;; Bail out if we don't need to do anything: + (if (file-exists? dest) + (if (call-with-input-file dest (lambda (i) + (begin + (read-line i 'any) + (not (eof-object? (read-line i 'any)))))) + (if (andmap (lambda (f) + ((file-or-directory-modify-seconds dest) + . > . + (file-or-directory-modify-seconds f))) + (list* src vers other-files)) + (exit 0) + (void)) + (void)) + (void)) + + ;; Startup code as an S-expression uses the pattern + ;; (lambda (begin ' )) + ;; or + ;; (case-lambda [ (begin ' )] ...) + ;; to record a name for a function. Detect that pattern and + ;; shift to an 'inferred-name property. We rely on the fact + ;; that the names `lambda`, `case-lambda`, and `quote` are + ;; never shadowed, so we don't have to parse expression forms + ;; in general. + (define-values (rename-functions) + (lambda (e) + (if (if (pair? e) + (eq? 'quote (car e)) + #f) + e + (let-values ([(name) + (if (pair? e) + (let-values ([(begin-name) + (lambda (b) + (if (pair? b) + (if (eq? 'begin (car b)) + (if (pair? (cdr b)) + (if (pair? (cddr b)) + (let-values ([(a) (cadr b)]) + (if (pair? a) + (if (eq? 'quote (car a)) + (cadr a) + #f) + #f)) + #f) + #f) + #f) + #f))]) + (if (eq? 'lambda (car e)) + (let-values ([(b) (caddr e)]) + (begin-name b)) + (if (eq? 'case-lambda (car e)) + (if (pair? (cdr e)) + (let-values ([(clause) (cadr e)]) + (begin-name (cadr clause))) + #f) + #f))) + #f)]) + (if name + (correlated-property (datum->correlated #f (cons (car e) (rename-functions (cdr e)))) + 'inferred-name + name) + (if (pair? e) + (cons (rename-functions (car e)) + (rename-functions (cdr e))) + e)))))) + (define-values (datum->correlated) (hash-ref (primitive-table '#%kernel) 'datum->syntax)) + (define-values (correlated-property) (hash-ref (primitive-table '#%kernel) 'syntax-property)) + + (define-values (linklet) (compile-linklet (rename-functions (get-linklet src)) + #f #f #f #f + ;; Unsafe mode: + #t)) + + (define-values (DIGS-PER-LINE) 20) + + ;; In case someone wants to inspect the output with `raco decompile`: + (call-with-output-file + zo-dest + (lambda (outfile) (write (hash->linklet-bundle (hasheq 'startup linklet)) outfile)) + 'truncate) + + (call-with-output-file + dest + (lambda (outfile) + (let-values ([(p) (open-output-bytes)]) + (write (hash->linklet-bundle (hasheq 'startup linklet)) p) + (let-values ([(s) (get-output-bytes p)]) + (fprintf outfile "#if 0 ~a\n" version-comparisons) + (fprintf outfile "# include \"startup.inc\"\n") + (fprintf outfile "#else\n") + (fprintf outfile "static unsigned char expr[] = {\n") + (letrec-values ([(loop) + (lambda (chars pos) + (if (null? chars) + (void) + (begin + (fprintf outfile "~a," (car chars)) + (loop (cdr chars) + (if (= pos DIGS-PER-LINE) + (begin + (newline outfile) + 0) + (add1 pos))))))]) + (loop (bytes->list s) 0)) + (fprintf outfile "0};\n") + (fprintf outfile "# define EVAL_STARTUP EVAL_ONE_SIZED_STR((char *)expr, ~a)\n" (bytes-length s)) + (fprintf outfile "#endif\n")))) + 'truncate)) diff --git a/racket/src/racket/src/compile.c b/racket/src/racket/src/compile.c index 2a70e20192..31e57a4a1a 100644 --- a/racket/src/racket/src/compile.c +++ b/racket/src/racket/src/compile.c @@ -34,121 +34,53 @@ #include "schpriv.h" #include "schmach.h" -#include "schexpobs.h" /* globals */ -READ_ONLY Scheme_Object *scheme_define_values_syntax; -READ_ONLY Scheme_Object *scheme_define_syntaxes_syntax; -READ_ONLY Scheme_Object *scheme_ref_syntax; -READ_ONLY Scheme_Object *scheme_begin_syntax; -READ_ONLY Scheme_Object *scheme_lambda_syntax; READ_ONLY Scheme_Object scheme_undefined[1]; -/* read-only globals */ -READ_ONLY static Scheme_Object *app_expander; -READ_ONLY static Scheme_Object *datum_expander; -READ_ONLY static Scheme_Object *top_expander; -READ_ONLY static Scheme_Object *stop_expander; - /* symbols */ ROSYM static Scheme_Object *lambda_symbol; -ROSYM static Scheme_Object *letrec_values_symbol; -ROSYM static Scheme_Object *let_star_values_symbol; -ROSYM static Scheme_Object *let_values_symbol; -ROSYM static Scheme_Object *begin_symbol; -ROSYM static Scheme_Object *disappeared_binding_symbol; -ROSYM static Scheme_Object *compiler_inline_hint_symbol; -ROSYM static Scheme_Object *app_symbol; -ROSYM static Scheme_Object *expression_symbol; -ROSYM static Scheme_Object *datum_symbol; -ROSYM static Scheme_Object *top_symbol; -ROSYM static Scheme_Object *protected_symbol; +ROSYM static Scheme_Object *case_lambda_symbol; +ROSYM static Scheme_Object *ref_symbol; ROSYM static Scheme_Object *quote_symbol; -ROSYM static Scheme_Object *letrec_syntaxes_symbol; +ROSYM static Scheme_Object *if_symbol; +ROSYM static Scheme_Object *set_symbol; +ROSYM static Scheme_Object *let_values_symbol; +ROSYM static Scheme_Object *letrec_values_symbol; +ROSYM static Scheme_Object *begin_symbol; +ROSYM static Scheme_Object *begin0_symbol; +ROSYM static Scheme_Object *with_cont_mark_symbol; +ROSYM static Scheme_Object *define_values_symbol; + +ROSYM static Scheme_Object *compiler_inline_hint_symbol; +ROSYM static Scheme_Object *protected_symbol; ROSYM static Scheme_Object *values_symbol; ROSYM static Scheme_Object *call_with_values_symbol; ROSYM static Scheme_Object *inferred_name_symbol; -ROSYM static Scheme_Object *local_keyword; -ROSYM static Scheme_Object *existing_variables_symbol; - -THREAD_LOCAL_DECL(static Scheme_Object *quick_stx); - -THREAD_LOCAL_DECL(struct Scheme_Object *cwv_stx); -THREAD_LOCAL_DECL(int cwv_stx_phase); +ROSYM static Scheme_Object *source_name_symbol; /* locals */ -static Scheme_Object *lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_values_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *ref_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *quote_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *if_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *set_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *case_lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_values_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *stratified_body_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *stratified_body_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *expression_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *case_lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *ref_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *quote_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *if_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *set_compile(Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env); +static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env); -static Scheme_Object *unquote_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, int app_position); +static Scheme_Object *compile_list(Scheme_Object *form, + Scheme_Comp_Env *first_env, Scheme_Comp_Env *env, Scheme_Comp_Env *last_env, + int start_app_position); +static Scheme_Object *compile_app(Scheme_Object *form, Scheme_Comp_Env *env); -static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *quote_syntax_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *begin_for_syntax_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_for_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *letrec_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *app_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *datum_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *top_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *stop_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *expand_lam(int argc, Scheme_Object **argv); - -static Scheme_Object *compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position); - -static Scheme_Object *compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -static Scheme_Object *compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -static Scheme_Object *expand_block(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); -static Scheme_Object *expand_stratified_block(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); -static Scheme_Object *compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int as_intdef); -static Scheme_Object *compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -static Scheme_Object *expand_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); +static Scheme_Object *generate_defn_name(Scheme_Object *base_sym, + Scheme_Hash_Tree *used_names, + Scheme_Hash_Tree *also_used_names, + int search_start); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -161,204 +93,62 @@ static void register_traversers(void); /* initialization */ /**********************************************************************/ -void scheme_init_compile (Scheme_Env *env) +void scheme_init_compile (Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); #endif - REGISTER_SO(scheme_define_values_syntax); - REGISTER_SO(scheme_define_syntaxes_syntax); - REGISTER_SO(scheme_lambda_syntax); - REGISTER_SO(scheme_begin_syntax); - REGISTER_SO(lambda_symbol); - REGISTER_SO(letrec_values_symbol); - REGISTER_SO(let_star_values_symbol); + REGISTER_SO(case_lambda_symbol); + REGISTER_SO(ref_symbol); + REGISTER_SO(quote_symbol); + REGISTER_SO(if_symbol); + REGISTER_SO(set_symbol); REGISTER_SO(let_values_symbol); + REGISTER_SO(letrec_values_symbol); REGISTER_SO(begin_symbol); - REGISTER_SO(disappeared_binding_symbol); + REGISTER_SO(begin0_symbol); + REGISTER_SO(with_cont_mark_symbol); + REGISTER_SO(define_values_symbol); + + lambda_symbol = scheme_intern_symbol("lambda"); + case_lambda_symbol = scheme_intern_symbol("case-lambda"); + ref_symbol = scheme_intern_symbol("#%variable-reference"); + quote_symbol = scheme_intern_symbol("quote"); + if_symbol = scheme_intern_symbol("if"); + set_symbol = scheme_intern_symbol("set!"); + let_values_symbol = scheme_intern_symbol("let-values"); + letrec_values_symbol = scheme_intern_symbol("letrec-values"); + begin_symbol = scheme_intern_symbol("begin"); + begin0_symbol = scheme_intern_symbol("begin0"); + with_cont_mark_symbol = scheme_intern_symbol("with-continuation-mark"); + define_values_symbol = scheme_intern_symbol("define-values"); + REGISTER_SO(compiler_inline_hint_symbol); - REGISTER_SO(inferred_name_symbol); - - REGISTER_SO(local_keyword); - - REGISTER_SO(existing_variables_symbol); + REGISTER_SO(source_name_symbol); scheme_undefined->type = scheme_undefined_type; - lambda_symbol = scheme_intern_symbol("lambda"); - - letrec_values_symbol = scheme_intern_symbol("letrec-values"); - let_values_symbol = scheme_intern_symbol("let-values"); - - begin_symbol = scheme_intern_symbol("begin"); - - disappeared_binding_symbol = scheme_intern_symbol("disappeared-binding"); compiler_inline_hint_symbol = scheme_intern_symbol("compiler-hint:cross-module-inline"); inferred_name_symbol = scheme_intern_symbol("inferred-name"); + source_name_symbol = scheme_intern_symbol("source-name"); - local_keyword = scheme_intern_exact_keyword("local", 5); - - existing_variables_symbol = scheme_make_symbol("existing-variables"); - - scheme_define_values_syntax = scheme_make_primitive_syntax(define_values_compile, - define_values_expand); - scheme_define_syntaxes_syntax = scheme_make_primitive_syntax(define_syntaxes_compile, - define_syntaxes_expand); - scheme_lambda_syntax = scheme_make_primitive_syntax(lambda_compile, - lambda_expand); - scheme_begin_syntax = scheme_make_primitive_syntax(begin_compile, - begin_expand); - - scheme_add_global_keyword("lambda", - scheme_lambda_syntax, - env); - { - /* Greek lambda binding: */ - Scheme_Object *macro, *fn; - - fn = scheme_make_prim_w_arity(expand_lam, "\316\273", 1, 1); - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = fn; - - scheme_add_global_keyword("\316\273", macro, env); - } - scheme_add_global_keyword("define-values", scheme_define_values_syntax, env); - scheme_add_global_keyword("quote", - scheme_make_primitive_syntax(quote_compile, - quote_expand), - env); - scheme_add_global_keyword("if", - scheme_make_primitive_syntax(if_compile, - if_expand), - env); - scheme_add_global_keyword("set!", - scheme_make_primitive_syntax(set_compile, - set_expand), - env); - scheme_add_global_keyword("#%variable-reference", - scheme_make_primitive_syntax(ref_compile, - ref_expand), - env); - - scheme_add_global_keyword("#%expression", - scheme_make_primitive_syntax(expression_compile, - expression_expand), - env); - - scheme_add_global_keyword("case-lambda", - scheme_make_primitive_syntax(case_lambda_compile, - case_lambda_expand), - env); - - scheme_add_global_keyword("let-values", - scheme_make_primitive_syntax(let_values_compile, - let_values_expand), - env); - scheme_add_global_keyword("letrec-values", - scheme_make_primitive_syntax(letrec_values_compile, - letrec_values_expand), - env); - - scheme_add_global_keyword("begin", - scheme_begin_syntax, - env); - scheme_add_global_keyword("#%stratified-body", - scheme_make_primitive_syntax(stratified_body_compile, - stratified_body_expand), - env); - - scheme_add_global_keyword("begin0", - scheme_make_primitive_syntax(begin0_compile, - begin0_expand), - env); - - scheme_add_global_keyword("unquote", - scheme_make_primitive_syntax(unquote_compile, - unquote_expand), - env); - scheme_add_global_keyword("unquote-splicing", - scheme_make_primitive_syntax(unquote_compile, - unquote_expand), - env); - - scheme_add_global_keyword("with-continuation-mark", - scheme_make_primitive_syntax(with_cont_mark_compile, - with_cont_mark_expand), - env); - - scheme_add_global_keyword("quote-syntax", - scheme_make_primitive_syntax(quote_syntax_compile, - quote_syntax_expand), - env); - scheme_add_global_keyword("define-syntaxes", scheme_define_syntaxes_syntax, env); - scheme_add_global_keyword("begin-for-syntax", - scheme_make_primitive_syntax(begin_for_syntax_compile, - begin_for_syntax_expand), - env); - scheme_add_global_keyword("letrec-syntaxes+values", - scheme_make_primitive_syntax(letrec_syntaxes_compile, - letrec_syntaxes_expand), - env); - - REGISTER_SO(app_symbol); - REGISTER_SO(expression_symbol); - REGISTER_SO(datum_symbol); - REGISTER_SO(top_symbol); REGISTER_SO(protected_symbol); - REGISTER_SO(quote_symbol); - REGISTER_SO(letrec_syntaxes_symbol); REGISTER_SO(values_symbol); REGISTER_SO(call_with_values_symbol); - app_symbol = scheme_intern_symbol("#%app"); - expression_symbol = scheme_intern_symbol("#%expression"); - datum_symbol = scheme_intern_symbol("#%datum"); - top_symbol = scheme_intern_symbol("#%top"); protected_symbol = scheme_intern_symbol("protected"); - quote_symbol = scheme_intern_symbol("quote"); - letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values"); values_symbol = scheme_intern_symbol("values"); call_with_values_symbol = scheme_intern_symbol("call-with-values"); - REGISTER_SO(app_expander); - REGISTER_SO(datum_expander); - REGISTER_SO(top_expander); - REGISTER_SO(stop_expander); - - app_expander = scheme_make_primitive_syntax(app_compile, app_expand); - datum_expander = scheme_make_primitive_syntax(datum_compile, datum_expand); - top_expander = scheme_make_primitive_syntax(top_compile, top_expand); - stop_expander = scheme_make_primitive_syntax(stop_compile, stop_expand); - scheme_add_global_keyword("#%app", app_expander, env); - scheme_add_global_keyword("#%datum", datum_expander, env); - scheme_add_global_keyword("#%top", top_expander, env); - scheme_init_marshal(env); } void scheme_init_compile_places() { - REGISTER_SO(quick_stx); - REGISTER_SO(cwv_stx); -} - -Scheme_Object * -scheme_make_primitive_syntax(Scheme_Syntax *proc, - Scheme_Syntax_Expander *eproc) -{ - Scheme_Object *syntax; - - syntax = scheme_alloc_eternal_object(); - syntax->type = scheme_primitive_syntax_type; - SCHEME_SYNTAX(syntax) = (Scheme_Object *)proc; - SCHEME_SYNTAX_EXP(syntax) = (Scheme_Object *)eproc; - - return syntax; } /**********************************************************************/ @@ -387,53 +177,15 @@ static void bad_form(Scheme_Object *form, int l) l - 1, (l != 2) ? "s" : ""); } -static Scheme_Object *simplify_inferred_name(Scheme_Object *name); - -static Scheme_Object *simplify_inferred_name_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *name = (Scheme_Object *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - return (void *)simplify_inferred_name(name); -} - - -static Scheme_Object *simplify_inferred_name(Scheme_Object *name) -{ - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)name; - - return scheme_handle_stack_overflow(simplify_inferred_name_k); - } - } - - if (SCHEME_PAIRP(name)) { - Scheme_Object *name_car = SCHEME_CAR(name), *name_cdr = SCHEME_CDR(name); - name_car = simplify_inferred_name(name_car); - name_cdr = simplify_inferred_name(name_cdr); - if (SAME_OBJ(name_car, name_cdr)) - return name_car; - } - - return name; -} - -Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *current_val) +static Scheme_Comp_Env *check_name_property(Scheme_Object *code, Scheme_Comp_Env *env) { Scheme_Object *name; name = scheme_stx_property(code, inferred_name_symbol, NULL); - name = simplify_inferred_name(name); if (name && SCHEME_SYMBOLP(name)) - return name; + return scheme_set_comp_env_name(env, name); else - return current_val; + return env; } /**********************************************************************/ @@ -442,14 +194,18 @@ Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *cu static Scheme_Object *lambda_check(Scheme_Object *form) { - form = scheme_stx_taint_disarm(form, NULL); - if (SCHEME_STX_PAIRP(form) && SCHEME_STX_PAIRP(SCHEME_STX_CDR(form))) { Scheme_Object *rest; rest = SCHEME_STX_CDR(form); - if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) + if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) { + int len; + len = check_form(form, form); + if (len != 3) + bad_form(form, len); + return form; + } } scheme_wrong_syntax(NULL, NULL, form, NULL); @@ -464,17 +220,17 @@ static void lambda_check_args(Scheme_Object *args, Scheme_Object *form, Scheme_C if (!SCHEME_STX_SYMBOLP(args)) { for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { a = SCHEME_STX_CAR(v); - scheme_check_identifier(NULL, a, NULL, env, form); + scheme_check_identifier(NULL, a, NULL, form); } if (!SCHEME_STX_NULLP(v)) { if (!SCHEME_STX_SYMBOLP(v)) { - scheme_check_identifier(NULL, v, NULL, env, form); + scheme_check_identifier(NULL, v, NULL, form); } } /* Check for duplicate names: */ - scheme_begin_dup_symbol_check(&r, env); + scheme_begin_dup_symbol_check(&r); for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { Scheme_Object *name; @@ -491,6 +247,10 @@ Scheme_Object *scheme_source_to_name(Scheme_Object *code) /* Makes up a procedure name when there's not a good one in the source */ { Scheme_Stx *cstx = (Scheme_Stx *)code; + + if (!SCHEME_STXP(code)) + return NULL; + if ((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) { char buf[50], src[20]; Scheme_Object *name, *bstr; @@ -548,6 +308,9 @@ Scheme_Object *combine_name_with_srcloc(Scheme_Object *name, Scheme_Object *code { Scheme_Stx *cstx = (Scheme_Stx *)code; + if (!SCHEME_STXP(code)) + return name; + if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) && cstx->srcloc->src) { Scheme_Object *vec; @@ -582,7 +345,6 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *e Scheme_Object *name; name = scheme_stx_property(code, inferred_name_symbol, NULL); - name = simplify_inferred_name(name); if (name && SCHEME_SYMBOLP(name)) { name = combine_name_with_srcloc(name, code, 0); } else if (name && SCHEME_VOIDP(name)) { @@ -591,6 +353,8 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *e name = combine_name_with_srcloc(name, code, 1); } else { name = env->value_name; + if (name) + name = SCHEME_STX_SYM(name); if (!name || SCHEME_FALSEP(name)) { name = scheme_source_to_name(code); if (name) @@ -599,21 +363,32 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *e name = combine_name_with_srcloc(name, code, 0); } } + +#if RECORD_ALLOCATION_COUNTS + if (!name) { + /* Try harder to synthesize a name */ + char *s; + int len; + s = scheme_write_to_string(scheme_syntax_to_datum(code), + NULL); + len = strlen(s); + if (len > 100) s[100] = 0; + name = scheme_make_symbol(s); + } +#endif + return name; } -static Scheme_Object * -make_lambda(Scheme_Comp_Env *env, Scheme_Object *code, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *make_lambda(Scheme_Comp_Env *env, Scheme_Object *code) /* Compiles a `lambda' expression */ { - Scheme_Object *allparams, *params, *forms, *param, *name, *scope; + Scheme_Object *allparams, *params, *forms, *param, *name; Scheme_Lambda *lam; - Scheme_Compile_Info lrec; - Scheme_Comp_Env *frame; - int i; intptr_t num_params; + Scheme_IR_Local *var, **vars; Scheme_IR_Lambda_Info *cl; + int i; lam = MALLOC_ONE_TAGGED(Scheme_Lambda); @@ -639,56 +414,45 @@ make_lambda(Scheme_Comp_Env *env, Scheme_Object *code, forms = SCHEME_STX_CDR(code); forms = SCHEME_STX_CDR(forms); - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + env = check_name_property(code, env); + name = scheme_build_closure_name(code, env); + lam->name = name; + + env = scheme_set_comp_env_name(env, NULL); + + vars = MALLOC_N(Scheme_IR_Local*, num_params); - frame = scheme_new_compilation_frame(lam->num_params, SCHEME_LAMBDA_FRAME, scope, env); params = allparams; - for (i = 0; i < lam->num_params; i++) { + for (i = 0; i < num_params; i++) { if (!SCHEME_STX_PAIRP(params)) param = params; else param = SCHEME_STX_CAR(params); - scheme_add_compilation_binding(i, param, frame); + var = scheme_make_ir_local(param); + vars[i] = var; + env = scheme_extend_comp_env(env, param, (Scheme_Object *)var, i > 0, 0); if (SCHEME_STX_PAIRP(params)) params = SCHEME_STX_CDR (params); } - scheme_env_make_variables(frame); - if (SCHEME_STX_NULLP(forms)) scheme_wrong_syntax(NULL, NULL, code, "empty body not allowed"); - forms = scheme_datum_to_syntax(forms, code, code, 0, 0); - forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); - - name = scheme_build_closure_name(code, env); - lam->name = name; - - scheme_compile_rec_done_local(rec, drec); - - scheme_init_lambda_rec(rec, drec, &lrec, 0); - { Scheme_Object *body; - body = compile_sequence(forms, - scheme_no_defines(frame), - &lrec, 0, - 1); + body = compile_expr(SCHEME_STX_CAR(forms), env, 0); lam->body = body; } - scheme_merge_lambda_rec(rec, drec, &lrec, 0); - cl = MALLOC_ONE_RT(Scheme_IR_Lambda_Info); SET_REQUIRED_TAG(cl->type = scheme_rt_ir_lambda_info); - cl->vars = frame->vars; + cl->vars = vars; lam->ir_info = cl; return (Scheme_Object *)lam; } -static Scheme_Object * -lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Object *args; @@ -698,71 +462,7 @@ lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info * args = SCHEME_STX_CAR(args); lambda_check_args(args, form, env); - return make_lambda(env, form, rec, drec); -} - -static Scheme_Object * -lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *args, *body, *fn, *form, *scope; - Scheme_Comp_Env *newenv; - Scheme_Expand_Info erec1; - - SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(env->observer); - - form = lambda_check(orig_form); - - args = SCHEME_STX_CDR(form); - args = SCHEME_STX_CAR(args); - - lambda_check_args(args, form, env); - - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - - newenv = scheme_add_compilation_frame(args, scope, env, 0); - - body = SCHEME_STX_CDR(form); - body = SCHEME_STX_CDR(body); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); - args = scheme_stx_add_scope(args, scope, scheme_env_phase(env->genv)); /* for re-expansion */ - - SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(env->observer, args, body); - - fn = SCHEME_STX_CAR(form); - - scheme_init_expand_recs(erec, drec, &erec1, 1); - - return scheme_datum_to_syntax(cons(fn, - cons(args, - expand_block(body, - newenv, - &erec1, - 0))), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object *expand_lam(int argc, Scheme_Object **argv) -{ - Scheme_Object *form = argv[0], *args, *fn; - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - - lambda_check(form); - - args = SCHEME_STX_CDR(form); - args = SCHEME_STX_CAR(args); - - lambda_check_args(args, form, env); - - fn = SCHEME_STX_CAR(form); - fn = scheme_datum_to_syntax(lambda_symbol, fn, scheme_sys_wraps(env), 0, 0); - - args = SCHEME_STX_CDR(form); - return scheme_datum_to_syntax(cons(fn, args), form, form, 0, 2); + return make_lambda(env, form); } Scheme_Object *scheme_clone_vector(Scheme_Object *lam, int skip, int set_type) @@ -782,216 +482,11 @@ Scheme_Object *scheme_clone_vector(Scheme_Object *lam, int skip, int set_type) return naya; } -Scheme_Object *scheme_revert_use_site_scopes(Scheme_Object *o, Scheme_Comp_Env *env) -{ - while (1) { - if (env->scopes) { - o = scheme_stx_adjust_frame_use_site_scopes(o, - env->scopes, - scheme_env_phase(env->genv), - SCHEME_STX_REMOVE); - } - if (env->flags & (SCHEME_FOR_INTDEF | SCHEME_INTDEF_FRAME | SCHEME_INTDEF_SHADOW)) { - if (env->use_scopes_next) - env = env->use_scopes_next; - else { - env = env->next; - if (!env) - break; - } - } else - break; - } - - if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { - o = scheme_stx_adjust_module_use_site_context(o, - env->genv->stx_context, - SCHEME_STX_REMOVE); - } - - return o; -} - -void scheme_define_parse(Scheme_Object *form, - Scheme_Object **var, Scheme_Object **_stk_val, - int defmacro, - Scheme_Comp_Env *env, - int no_toplevel_check) -{ - Scheme_Object *vars, *rest; - int len; - DupCheckRecord r; - - if (!no_toplevel_check && !scheme_is_toplevel(env)) - scheme_wrong_syntax(NULL, NULL, form, "not in a definition context"); - - len = check_form(form, form); - if (len != 3) - bad_form(form, len); - - rest = SCHEME_STX_CDR(form); - vars = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - *_stk_val = SCHEME_STX_CAR(rest); - - vars = scheme_revert_use_site_scopes(vars, env); - - *var = vars; - - scheme_begin_dup_symbol_check(&r, env); - - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *name; - - name = SCHEME_STX_CAR(vars); - scheme_check_identifier(NULL, name, NULL, env, form); - - vars = SCHEME_STX_CDR(vars); - - scheme_dup_symbol_check(&r, NULL, name, "binding", form); - } - - if (!SCHEME_STX_NULLP(vars)) - scheme_wrong_syntax(NULL, *var, form, "bad variable list"); -} - -static Scheme_Object *global_binding(Scheme_Object *id, Scheme_Comp_Env *env) -{ - Scheme_Object *sym; - - sym = scheme_global_binding(id, env->genv, env->flags & SCHEME_TMP_TL_BIND_FRAME); - - if (env->binding_namess && !SAME_OBJ(sym, SCHEME_STX_VAL(id))) { - /* Record the new binding */ - Scheme_Hash_Tree *binds; - binds = (Scheme_Hash_Tree *)scheme_hash_get(env->binding_namess, scheme_env_phase(env->genv)); - if (!binds) - binds = scheme_make_hash_tree(SCHEME_hashtr_eq); - binds = scheme_hash_tree_set(binds, sym, id); - scheme_hash_set(env->binding_namess, scheme_env_phase(env->genv), (Scheme_Object *)binds); - } - - return sym; -} - -static Scheme_Object * -defn_targets_compile (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *first = scheme_null, *last = NULL; - - while (SCHEME_STX_PAIRP(var)) { - Scheme_Object *name, *pr, *bucket; - - name = SCHEME_STX_CAR(var); - name = global_binding(name, env); - - if (rec[drec].resolve_module_ids || !env->genv->module) { - bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); - } else { - /* Create a module variable reference, so that idx is preserved: */ - bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, - name, env->genv->module->insp, - -1, env->genv->mod_phase, 0, - NULL); - } - /* Get indirection through the prefix: */ - bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec, 0, NULL); - - pr = cons(bucket, scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - var = SCHEME_STX_CDR(var); - } - - return first; -} - -static Scheme_Object * -define_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *var, *val, *targets, *variables, *vec, *value_name; - - scheme_define_parse(form, &var, &val, 0, env, 0); - variables = var; - - targets = defn_targets_compile(var, env, rec, drec); - - scheme_compile_rec_done_local(rec, drec); - if (SCHEME_STX_PAIRP(targets) && SCHEME_STX_NULLP(SCHEME_STX_CDR(targets))) { - var = SCHEME_STX_CAR(variables); - value_name = SCHEME_STX_SYM(var); - } else - value_name = NULL; - -#if 0 - if (env->scopes) - val = scheme_stx_adjust_frame_use_site_scopes(val, - env->scopes, - scheme_env_phase(env->genv), - SCHEME_STX_ADD); -#endif - - env = scheme_no_defines(env); - env->value_name = value_name; - - val = scheme_compile_expr(val, env, rec, drec); - - env->value_name = NULL; - - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = targets; - SCHEME_VEC_ELS(vec)[1] = val; - vec->type = scheme_define_values_type; - - if (SCHEME_TRUEP(scheme_stx_property(form, compiler_inline_hint_symbol, NULL))) { - /* use "immutable" bit to mark compiler-inline hint: */ - SCHEME_SET_IMMUTABLE(vec); - } - - return vec; -} - -static Scheme_Object * -define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *var, *val, *fn, *boundname; - - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(env->observer); - - scheme_define_parse(form, &var, &val, 0, env, 0); - - env = scheme_no_defines(env); - - if (SCHEME_STX_PAIRP(var) && SCHEME_STX_NULLP(SCHEME_STX_CDR(var))) - boundname = SCHEME_STX_CAR(var); - else - boundname = scheme_false; - env->value_name = boundname; - - fn = SCHEME_STX_CAR(form); - form = scheme_datum_to_syntax(cons(fn, - cons(var, - cons(scheme_expand_expr(val, env, erec, drec), - scheme_null))), - form, - form, - 0, 2); - - env->value_name = NULL; - - return form; -} - /**********************************************************************/ /* quote */ /**********************************************************************/ -static Scheme_Object * -quote_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *quote_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Object *v, *rest; @@ -999,30 +494,9 @@ quote_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *r if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) scheme_wrong_syntax(NULL, NULL, form, "wrong number of parts"); - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - v = SCHEME_STX_CAR(rest); - if (SCHEME_STXP(v)) - return scheme_syntax_to_datum(v, 0, NULL); - else - return v; -} - -static Scheme_Object * -quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *rest; - - SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(env->observer); - - rest = SCHEME_STX_CDR(form); - - if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) - scheme_wrong_syntax(NULL, NULL, form, "wrong number of parts"); - - return form; + return scheme_syntax_to_datum(v); } /**********************************************************************/ @@ -1041,9 +515,8 @@ static void check_if_len(Scheme_Object *form, int len) } } -Scheme_Object * -scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp, - Scheme_Object *elsep) +Scheme_Object *scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp, + Scheme_Object *elsep) { Scheme_Branch_Rec *b; @@ -1064,23 +537,15 @@ scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp, return (Scheme_Object *)b; } -static Scheme_Object * -if_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *if_compile (Scheme_Object *form, Scheme_Comp_Env *env) { int len, opt; - Scheme_Object *test, *thenp, *elsep, *name, *rest; - Scheme_Compile_Info recs[3]; - - form = scheme_stx_taint_disarm(form, NULL); + Scheme_Object *test, *thenp, *elsep, *rest; len = check_form(form, form); check_if_len(form, len); - name = env->value_name; - env->value_name = NULL; - scheme_compile_rec_done_local(rec, drec); - - name = scheme_check_name_property(form, name); + env = check_name_property(form, env); rest = SCHEME_STX_CDR(form); test = SCHEME_STX_CAR(rest); @@ -1092,48 +557,33 @@ if_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, } else elsep = scheme_compiled_void(); - scheme_init_compile_recs(rec, drec, recs, 3); - - env = scheme_no_defines(env); - - test = scheme_compile_expr(test, env, recs, 0); + test = compile_expr(test, scheme_set_comp_env_name(env, NULL), 0); if (SCHEME_TYPE(test) > _scheme_ir_values_types_) { opt = 1; if (SCHEME_FALSEP(test)) { /* compile other branch only to get syntax checking: */ - recs[2].dont_mark_local_use = 1; - env->value_name = name; - scheme_compile_expr(thenp, env, recs, 2); + compile_expr(thenp, scheme_set_comp_env_flags(env, COMP_ENV_DONT_COUNT_AS_USE), 0); - if (len == 4) { - env->value_name = name; - test = scheme_compile_expr(elsep, env, recs, 1); - } else + if (len == 4) + test = compile_expr(elsep, env, 0); + else test = elsep; } else { if (len == 4) { /* compile other branch only to get syntax checking: */ - recs[2].dont_mark_local_use = 1; - env->value_name = name; - scheme_compile_expr(elsep, env, recs, 2); + compile_expr(elsep, scheme_set_comp_env_flags(env, COMP_ENV_DONT_COUNT_AS_USE), 0); } - env->value_name = name; - test = scheme_compile_expr(thenp, env, recs, 1); + test = compile_expr(thenp, env, 0); } } else { opt = 0; - env->value_name = name; - thenp = scheme_compile_expr(thenp, env, recs, 1); - if (len == 4) { - env->value_name = name; - elsep = scheme_compile_expr(elsep, env, recs, 2); - } + thenp = compile_expr(thenp, env, 0); + if (len == 4) + elsep = compile_expr(elsep, env, 0); } - - scheme_merge_compile_recs(rec, drec, recs, (opt || (len == 3)) ? 2 : 3); if (opt) return test; @@ -1141,84 +591,22 @@ if_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, return scheme_make_branch(test, thenp, elsep); } -static Scheme_Object * -if_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *form, *test, *rest, *thenp, *elsep, *fn, *boundname; - int len; - Scheme_Expand_Info recs[3]; - - SCHEME_EXPAND_OBSERVE_PRIM_IF(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - len = check_form(form, form); - - check_if_len(form, len); - - if (len == 3) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(env->observer); - } - - boundname = scheme_check_name_property(form, env->value_name); - - env = scheme_no_defines(env); - env->value_name = NULL; - - scheme_init_expand_recs(erec, drec, recs, 3); - - rest = SCHEME_STX_CDR(form); - test = SCHEME_STX_CAR(rest); - test = scheme_expand_expr(test, env, recs, 0); - - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - rest = SCHEME_STX_CDR(rest); - thenp = SCHEME_STX_CAR(rest); - env->value_name = boundname; - thenp = scheme_expand_expr(thenp, env, recs, 1); - - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - elsep = SCHEME_STX_CAR(rest); - env->value_name = boundname; - elsep = scheme_expand_expr(elsep, env, recs, 2); - rest = cons(elsep, scheme_null); - } else { - rest = scheme_null; - } - - rest = cons(thenp, rest); - - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, cons(test, rest)), - orig_form, orig_form, - 0, 2); -} - /**********************************************************************/ /* with-continuation-mark */ /**********************************************************************/ -static Scheme_Object * -with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env) { - Scheme_Object *key, *val, *expr, *value_name; - Scheme_Compile_Info recs[3]; + Scheme_Object *key, *val, *expr; + Scheme_Comp_Env *k_env; Scheme_With_Continuation_Mark *wcm; int len; - form = scheme_stx_taint_disarm(form, NULL); - len = check_form(form, form); if (len != 4) bad_form(form, len); - value_name = env->value_name; - env = scheme_no_defines(env); - env->value_name = NULL; - form = SCHEME_STX_CDR(form); key = SCHEME_STX_CAR(form); form = SCHEME_STX_CDR(form); @@ -1226,17 +614,11 @@ with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile form = SCHEME_STX_CDR(form); expr = SCHEME_STX_CAR(form); - scheme_compile_rec_done_local(rec, drec); + k_env = scheme_set_comp_env_name(env, NULL); - scheme_init_compile_recs(rec, drec, recs, 3); - - key = scheme_compile_expr(key, env, recs, 0); - val = scheme_compile_expr(val, env, recs, 1); - - env->value_name = value_name; - expr = scheme_compile_expr(expr, env, recs, 2); - - scheme_merge_compile_recs(rec, drec, recs, 3); + key = compile_expr(key, k_env, 0); + val = compile_expr(val, k_env, 0); + expr = compile_expr(expr, env, 0); wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); wcm->so.type = scheme_with_cont_mark_type; @@ -1247,67 +629,16 @@ with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile return (Scheme_Object *)wcm; } -static Scheme_Object * -with_cont_mark_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *key, *val, *expr, *form, *fn, *boundname; - int len; - Scheme_Expand_Info recs[3]; - - SCHEME_EXPAND_OBSERVE_PRIM_WCM(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - len = check_form(form, form); - if (len != 4) - bad_form(form, len); - - fn = SCHEME_STX_CAR(form); - - boundname = scheme_check_name_property(form, env->value_name); - - env = scheme_no_defines(env); - env->value_name = NULL; - - scheme_init_expand_recs(erec, drec, recs, 3); - - form = SCHEME_STX_CDR(form); - key = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - val = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - expr = SCHEME_STX_CAR(form); - - key = scheme_expand_expr(key, env, recs, 0); - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - val = scheme_expand_expr(val, env, recs, 1); - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - env->value_name = boundname; - expr = scheme_expand_expr(expr, env, recs, 2); - - return scheme_datum_to_syntax(cons(fn, - cons(key, - cons(val, - cons(expr, scheme_null)))), - orig_form, - orig_form, - 0, 2); -} - /**********************************************************************/ /* set! */ /**********************************************************************/ -static Scheme_Object * -set_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *set_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Set_Bang *sb; - Scheme_Env *menv = NULL; - Scheme_Object *var, *val, *name, *body, *rest, *find_name; + Scheme_Object *var, *val, *name, *body, *rest; int l, set_undef; - form = scheme_stx_taint_disarm(form, NULL); - l = check_form(form, form); if (l != 3) bad_form(form, l); @@ -1317,65 +648,21 @@ set_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec rest = SCHEME_STX_CDR(rest); body = SCHEME_STX_CAR(rest); - scheme_check_identifier("set!", name, NULL, env, form); + scheme_check_identifier("set!", name, NULL, form); - find_name = name; + var = scheme_compile_lookup(name, env, SCHEME_SETTING); - while (1) { - var = scheme_compile_lookup(find_name, env, - SCHEME_SETTING - + SCHEME_GLOB_ALWAYS_REFERENCE - + (rec[drec].dont_mark_local_use - ? SCHEME_DONT_MARK_USE - : 0) - + (rec[drec].resolve_module_ids - ? SCHEME_RESOLVE_MODIDS - : 0), - env->in_modidx, - &menv, NULL, - NULL, NULL, - NULL); - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - /* Redirect to a macro? */ - if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1, 0); - - return scheme_compile_expr(form, env, rec, drec); - } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } else - break; + if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)) { + if (((Scheme_IR_Toplevel *)var)->instance_pos != -1) + scheme_wrong_syntax(NULL, form, name, "cannot mutate imported variable"); + SCHEME_IR_TOPLEVEL_FLAGS(((Scheme_IR_Toplevel *)var)) |= SCHEME_IR_TOPLEVEL_MUTATED; } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); - return NULL; - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0, NULL); - if (env->genv->module) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; - env->prefix->non_phaseless = 1; - } - - scheme_compile_rec_done_local(rec, drec); - - env = scheme_no_defines(env); - env->value_name = SCHEME_STX_SYM(name); - - val = scheme_compile_expr(body, env, rec, drec); - - env->value_name = NULL; - set_undef = (rec[drec].comp_flags & COMP_ALLOW_SET_UNDEFINED); + env = scheme_set_comp_env_name(env, SCHEME_STX_SYM(name)); + + val = compile_expr(body, env, 0); + + set_undef = (env->flags & COMP_ENV_ALLOW_SET_UNDEFINED); sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); sb->so.type = scheme_set_bang_type; @@ -1386,237 +673,64 @@ set_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec return (Scheme_Object *)sb; } -static Scheme_Object * -set_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Env *menv = NULL; - Scheme_Object *name, *var, *fn, *rhs, *find_name, *form, *binding_id; - int l; - - SCHEME_EXPAND_OBSERVE_PRIM_SET(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - l = check_form(form, form); - if (l != 3) - bad_form(form, l); - - env = scheme_no_defines(env); - - name = SCHEME_STX_CDR(form); - name = SCHEME_STX_CAR(name); - - scheme_check_identifier("set!", name, NULL, env, form); - - find_name = name; - - while (1) { - /* Make sure it's mutable, and check for redirects: */ - var = scheme_compile_lookup(find_name, env, - SCHEME_SETTING + SCHEME_STOP_AT_FREE_EQ, - env->in_modidx, - &menv, NULL, - &binding_id, NULL, - NULL); - - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name); - - if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - /* Redirect to a macro? */ - if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { - - SCHEME_EXPAND_OBSERVE_ENTER_MACRO(env->observer, form); - - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1, 0); - - SCHEME_EXPAND_OBSERVE_EXIT_MACRO(env->observer, form); - - if (erec[drec].depth > 0) - erec[drec].depth--; - - env->value_name = name; - - return scheme_expand_expr(form, env, erec, drec); - } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - new_name = scheme_stx_track(new_name, find_name, find_name); - find_name = new_name; - menv = NULL; - } else - break; - } else { - if (binding_id) - find_name = binding_id; - break; - } - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); - } - - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - - - fn = SCHEME_STX_CAR(form); - rhs = SCHEME_STX_CDR(form); - rhs = SCHEME_STX_CDR(rhs); - rhs = SCHEME_STX_CAR(rhs); - - env->value_name = name; - - rhs = scheme_expand_expr(rhs, env, erec, drec); - - form = scheme_datum_to_syntax(cons(fn, - cons(find_name, - cons(rhs, scheme_null))), - orig_form, - orig_form, - 0, 2); - - env->value_name = NULL; - - return form; -} - /**********************************************************************/ /* #%variable-reference */ /**********************************************************************/ -static Scheme_Object * -ref_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *ref_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - Scheme_Env *menv = NULL; - Scheme_Object *var, *name, *rest, *dummy, *bind_id; + Scheme_Object *var, *name, *rest, *pseudo_var; int l, ok; - if (rec[drec].comp) - env->prefix->non_phaseless = 1; - - form = scheme_stx_taint_disarm(form, NULL); - l = check_form(form, form); - /* retaining `dummy' ensures that the environment stays + /* retaining `pseudo-var' ensures that the environment stays linked from the actual variable */ - if (rec[drec].comp && ((l == 1) || !rec[drec].testing_constantness)) - dummy = scheme_make_environment_dummy(env); - else - dummy = NULL; + if ((l == 1) || !(env->flags & COMP_ENV_CHECKING_CONSTANT)) + pseudo_var = (Scheme_Object *)scheme_make_ir_toplevel(-1, -1, 0); + else { + /* If the variable reference will be used only for + `variable-reference-constant?`, then we don't want a string + reference to the enclsoing instance. */ + pseudo_var = scheme_false; + } if (l == 1) { - if (rec[drec].comp) - var = dummy; - else - var = scheme_void; - bind_id = NULL; + var = scheme_false; } else { if (l != 2) bad_form(form, l); rest = SCHEME_STX_CDR(form); name = SCHEME_STX_CAR(rest); - name = scheme_stx_taint_disarm(name, NULL); - - if (SCHEME_STX_PAIRP(name)) { - rest = SCHEME_STX_CAR(name); - if (env->genv->phase == 0) { - var = scheme_top_stx; - } else { - var = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_top_stx), scheme_false, scheme_sys_wraps(env), 0, 0); - } - ok = scheme_stx_free_eq(rest, var, env->genv->phase); - } else - ok = SCHEME_STX_SYMBOLP(name); + ok = SCHEME_STX_SYMBOLP(name); if (!ok) { scheme_wrong_syntax("#%variable-reference", name, form, - "not an identifier or #%%top form"); + "not an identifier"); return NULL; } - if (SCHEME_STX_PAIRP(name)) { - /* FIXME: when using #%top, need to set mutated flag */ - env->value_name = NULL; - if (rec[drec].comp) - var = scheme_compile_expr(name, env, rec, drec); - else - var = scheme_expand_expr(name, env, rec, drec); - } else { - var = scheme_compile_lookup(name, env, - SCHEME_REFERENCING - + SCHEME_GLOB_ALWAYS_REFERENCE - + (rec[drec].dont_mark_local_use - ? SCHEME_DONT_MARK_USE - : 0) - + (rec[drec].resolve_module_ids - ? SCHEME_RESOLVE_MODIDS - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - &bind_id, NULL, NULL); + var = scheme_compile_lookup(name, env, SCHEME_REFERENCING); - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - int imported = 0; - imported = scheme_is_imported(var, env); - - if (rec[drec].comp) { - var = scheme_register_toplevel_in_prefix(var, env, rec, drec, imported, NULL); - if (!imported && env->genv->module && !rec[drec].testing_constantness) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; - } - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { - /* ok */ - } else { - scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a variable"); - } - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); + if (!SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type) + && !SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type) + && !SCHEME_SYMBOLP(var)) { /* symbol means primitive instance */ + scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a variable"); } } - if (rec[drec].comp) { + { Scheme_Object *o; o = scheme_alloc_object(); o->type = scheme_varref_form_type; - SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; - if (!dummy) dummy = scheme_false; - SCHEME_PTR2_VAL(o) = (Scheme_Object *)dummy; + SCHEME_PTR1_VAL(o) = var; + SCHEME_PTR2_VAL(o) = pseudo_var; return o; - } else { - if (bind_id) { - form = SCHEME_STX_CAR(form); - return scheme_make_pair(form, scheme_make_pair(bind_id, scheme_null)); - } - return NULL; } } -static Scheme_Object * -ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *naya; - - SCHEME_EXPAND_OBSERVE_PRIM_VARREF(env->observer); - - /* Error checking, and lexical variable update: */ - naya = ref_compile(form, env, erec, drec); - - if (!naya) - /* No change: */ - return form; - - return scheme_datum_to_syntax(naya, form, form, 0, 2); -} - /**********************************************************************/ /* case-lambda */ /**********************************************************************/ @@ -1682,19 +796,15 @@ static void case_lambda_check_line(Scheme_Object *line, Scheme_Object *form, Sch SCHEME_STX_NULLP(body) ? "empty body not allowed" : IMPROPER_LIST_FORM); } -static Scheme_Object * -case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Object *list, *last, *c, *orig_form = form, *name; Scheme_Case_Lambda *cl; int i, count = 0; - Scheme_Compile_Info *recs; - form = scheme_stx_taint_disarm(form, NULL); - form = SCHEME_STX_CDR(form); + env = check_name_property(orig_form, env); name = scheme_build_closure_name(orig_form, env); if (SCHEME_STX_NULLP(form)) { @@ -1706,9 +816,6 @@ case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, ((Scheme_Case_Lambda *)form)->count = 0; ((Scheme_Case_Lambda *)form)->name = name; - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - if (scheme_has_method_property(orig_form)) { /* See note in schpriv.h about the IS_METHOD hack */ if (!name) @@ -1727,15 +834,12 @@ case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, case_lambda_check_line(c, orig_form, env); - c = cons(scheme_datum_to_syntax(lambda_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - c); - c = scheme_datum_to_syntax(c, orig_form, orig_form, 0, 2); + c = cons(lambda_symbol, c); + c = scheme_datum_to_syntax(c, orig_form, DTS_COPY_PROPS); - return lambda_compile(c, env, rec, drec); + return lambda_compile(c, env); } - scheme_compile_rec_done_local(rec, drec); - list = last = NULL; while (SCHEME_STX_PAIRP(form)) { Scheme_Object *clause; @@ -1744,7 +848,7 @@ case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, c = cons(lambda_symbol, clause); - c = scheme_datum_to_syntax(c, clause, scheme_sys_wraps(env), 0, 0); + c = scheme_datum_to_syntax(c, clause, 0); c = cons(c, scheme_null); @@ -1769,22 +873,16 @@ case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, cl->count = count; cl->name = SCHEME_TRUEP(name) ? name : NULL; - scheme_compile_rec_done_local(rec, drec); - recs = MALLOC_N_ATOMIC(Scheme_Compile_Info, count); - scheme_init_compile_recs(rec, drec, recs, count); - - env->value_name = NULL; + env = scheme_set_comp_env_name(env, NULL); for (i = 0; i < count; i++) { Scheme_Object *ce; ce = SCHEME_CAR(list); - ce = scheme_compile_expr(ce, env, recs, i); + ce = compile_expr(ce, env, 0); cl->array[i] = ce; list = SCHEME_CDR(list); } - scheme_merge_compile_recs(rec, drec, recs, count); - if (scheme_has_method_property(orig_form)) { Scheme_Lambda *lam; /* Make sure no branch has 0 arguments: */ @@ -1802,65 +900,6 @@ case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env, return (Scheme_Object *)cl; } -static Scheme_Object * -case_lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *first, *last, *args, *body, *c, *new_line, *form; - - SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - first = SCHEME_STX_CAR(form); - first = cons(first, scheme_null); - last = first; - form = SCHEME_STX_CDR(form); - - while (SCHEME_STX_PAIRP(form)) { - Scheme_Object *line_form, *scope; - Scheme_Comp_Env *newenv; - - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - - line_form = SCHEME_STX_CAR(form); - - case_lambda_check_line(line_form, orig_form, env); - - body = SCHEME_STX_CDR(line_form); - args = SCHEME_STX_CAR(line_form); - - body = scheme_datum_to_syntax(body, line_form, line_form, 0, 0); - - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - - newenv = scheme_add_compilation_frame(args, scope, env, 0); - - body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); - args = scheme_stx_add_scope(args, scope, scheme_env_phase(env->genv)); - - SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(env->observer, args, body); - - { - Scheme_Expand_Info erec1; - scheme_init_expand_recs(erec, drec, &erec1, 1); - new_line = cons(args, expand_block(body, newenv, &erec1, 0)); - } - new_line = scheme_datum_to_syntax(new_line, line_form, line_form, 0, 1); - - c = cons(new_line, scheme_null); - - SCHEME_CDR(last) = c; - last = c; - - form = SCHEME_STX_CDR(form); - } - - if (!SCHEME_STX_NULLP(form)) - scheme_wrong_syntax(NULL, form, orig_form, NULL); - - return scheme_datum_to_syntax(first, orig_form, orig_form, 0, 2); -} - /**********************************************************************/ /* let, let-values, letrec, etc. */ /**********************************************************************/ @@ -1880,174 +919,21 @@ static Scheme_IR_Let_Header *make_header(Scheme_Object *first, int num_bindings, return head; } -static Scheme_Object *force_traditional_letrec(Scheme_Object *result, Scheme_Comp_Env *env) +static Scheme_Object *do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, + int recursive) { - /* Force `letrec'-style binding by adding a forward - reference to the last binding as a first binding: - (letrec-values+syntaxes ([() (if #f (#%app values))] ....) ....). - To avoid affecting performance, this hack is reverted in - the `letrec' compiler and expander. */ - Scheme_Object *sbh, *vbh, *vb, *v, *last_name = NULL, *values, *app; - - sbh = SCHEME_STX_CDR(result); - vbh = SCHEME_STX_CDR(sbh); - vb = SCHEME_STX_CAR(vbh); - - while (!SCHEME_STX_NULLP(vb)) { - v = SCHEME_STX_CAR(vb); - v = SCHEME_STX_CAR(v); - if (!SCHEME_STX_NULLP(v)) { - last_name = SCHEME_STX_CAR(v); - } - vb = SCHEME_STX_CDR(vb); - } - - if (last_name) { - vb = SCHEME_STX_CAR(vbh); - v = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, - scheme_sys_wraps(env), 0, 0); - app = scheme_datum_to_syntax(app_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - values = scheme_datum_to_syntax(values_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - vb = icons(icons(scheme_null, - icons(icons(v, - icons(scheme_false, - icons(last_name, - icons(icons(app, icons(values, scheme_null)), - scheme_null)))), - scheme_null)), - vb); - vbh = SCHEME_STX_CDR(vbh); - sbh = SCHEME_STX_CAR(sbh); - v = SCHEME_STX_CAR(result); - v = icons(v, icons(sbh, icons(vb, vbh))); - result = scheme_datum_to_syntax(v, result, result, 0, 2); - } - - return result; -} - -static Scheme_Object *detect_traditional_letrec(Scheme_Object *form, Scheme_Comp_Env *env) -/* See force_traditional_letrec() */ -{ - Scheme_Object *v, *v2, *v3, *id; - - v = SCHEME_STX_CDR(form); - v = SCHEME_STX_CAR(v); - if (SCHEME_STX_NULLP(v)) return form; - - v = SCHEME_STX_CAR(v); - /* is v `[() ...]' ? */ - v2 = SCHEME_STX_CAR(v); - if (!SCHEME_STX_NULLP(v2)) return form; - - v2 = SCHEME_STX_CDR(v); - v2 = SCHEME_STX_CAR(v2); - - /* is v2 `(if #f ... (values))' ? */ - if (!SCHEME_STX_PAIRP(v2)) return form; - v = SCHEME_STX_CDR(v2); - if (!SCHEME_STX_PAIRP(v)) return form; - v = SCHEME_STX_CAR(v); - v = SCHEME_STX_VAL(v); - - if (!SCHEME_FALSEP(v)) { - /* try '#f: */ - if (!SCHEME_PAIRP(v)) return form; - v3 = SCHEME_CDR(v); - if (!SCHEME_STX_PAIRP(v3)) return form; - v3 = SCHEME_STX_CAR(v3); - v3 = SCHEME_STX_VAL(v3); - if (!SCHEME_FALSEP(v3)) return form; - - v3 = SCHEME_CDR(v); - v3 = SCHEME_STX_CDR(v3); - if (!SCHEME_STX_NULLP(v3)) return form; - } - - /* found #f; look for `if' and `(#%app values)': */ - v = SCHEME_STX_CAR(v2); - if (!SCHEME_STX_SYMBOLP(v)) return form; - - id = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, - scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_free_eq(v, id, env->genv->phase)) return form; - - /* found `if'; look for `(#%app values)' */ - v = SCHEME_STX_CDR(v2); - v = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v2 = SCHEME_STX_CDR(v); - if (!SCHEME_STX_NULLP(v2)) return form; - - v = SCHEME_STX_CAR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v2 = SCHEME_STX_CAR(v); - if (!SCHEME_STX_SYMBOLP(v2)) return form; - id = scheme_datum_to_syntax(app_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_free_eq(v2, id, env->genv->phase)) return form; - - v = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(v)) return form; - v2 = SCHEME_STX_CDR(v); - if (!SCHEME_STX_NULLP(v2)) return form; - - v = SCHEME_STX_CAR(v); - if (!SCHEME_STX_SYMBOLP(v)) return form; - id = scheme_datum_to_syntax(values_symbol, scheme_false, - scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_free_eq(v, id, env->genv->phase)) return form; - - /* pattern matched; drop the first clause */ - v = SCHEME_STX_CDR(form); - v2 = SCHEME_STX_CAR(v); - v2 = SCHEME_STX_CDR(v2); - - v = SCHEME_STX_CDR(v); - v = scheme_datum_to_syntax(v, scheme_false, scheme_false, 0, 0); - v2 = icons(v2, v); - - v = SCHEME_STX_CAR(form); - v2 = icons(v, v2); - - return scheme_datum_to_syntax(v2, form, form, 0, 2); -} - -static Scheme_Object * -do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, - int recursive, int multi, Scheme_Compile_Info *rec, int drec, - Scheme_Comp_Env *frame_already) -{ - Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname, *scope; - int num_clauses, num_bindings, i, j, k, m, pre_k; - Scheme_Comp_Env *frame, *env, *rhs_env; - Scheme_Compile_Info *recs; - Scheme_Object *first = NULL, *existing_vars; + Scheme_Object *bindings, *l, *binding, *name, **names, *forms; + int num_clauses, num_bindings, i, k, m, pre_k, mutate_frame = 0, *use_box; + Scheme_Comp_Env *frame, *rhs_env; + Scheme_Object *first = NULL; Scheme_IR_Let_Value *last = NULL, *lv; + Scheme_IR_Local *var, **vars; DupCheckRecord r; - int rec_env_already = rec[drec].env_already, body_block; Scheme_IR_Let_Header *head; - form = scheme_stx_taint_disarm(form, NULL); - - if (rec_env_already >= 2) { - body_block = (rec_env_already > 2); - l = detect_traditional_letrec(form, origenv); - if (!SAME_OBJ(l, form)) { - rec_env_already = 1; - form = l; - } else - rec_env_already = 2; - } else - body_block = !rec_env_already; - - i = scheme_stx_proper_list_length(form); - if (i < 3) - scheme_wrong_syntax(NULL, NULL, form, (!i ? "empty body not allowed" : NULL)); + i = check_form(form, form); + if (i != 3) + bad_form(form, i); bindings = SCHEME_STX_CDR(form); bindings = SCHEME_STX_CAR(bindings); @@ -2059,94 +945,58 @@ do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, /* forms ends up being the let body */ forms = SCHEME_STX_CDR(form); forms = SCHEME_STX_CDR(forms); - forms = scheme_datum_to_syntax(forms, form, form, 0, 0); + forms = SCHEME_STX_CAR(forms); - if (!num_clauses) { - if (!body_block) - scheme_signal_error("internal error: no local bindings, but body is not in a block"); + origenv = check_name_property(form, origenv); - /* Even though there are no bindings, we need a scope to - indicate a nested binding context */ - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - env = scheme_new_compilation_frame(0, 0, scope, origenv); - forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); - - name = scheme_check_name_property(form, origenv->value_name); - env->value_name = name; - - return compile_sequence(forms, env, rec, drec, body_block); - } + if (!num_clauses) + return compile_expr(forms, origenv, 0); - if (multi) { - num_bindings = 0; - l = bindings; - while (!SCHEME_STX_NULLP(l)) { - Scheme_Object *clause, *names, *rest; - int num_names; + num_bindings = 0; + l = bindings; + while (!SCHEME_STX_NULLP(l)) { + Scheme_Object *clause, *names, *rest; + int num_names; - clause = SCHEME_STX_CAR(l); + clause = SCHEME_STX_CAR(l); - if (!SCHEME_STX_PAIRP(clause)) - rest = NULL; + if (!SCHEME_STX_PAIRP(clause)) + rest = NULL; + else { + rest = SCHEME_STX_CDR(clause); + if (!SCHEME_STX_PAIRP(rest)) + rest = NULL; else { - rest = SCHEME_STX_CDR(clause); - if (!SCHEME_STX_PAIRP(rest)) - rest = NULL; - else { - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - rest = NULL; - } + rest = SCHEME_STX_CDR(rest); + if (!SCHEME_STX_NULLP(rest)) + rest = NULL; } - if (!rest) - scheme_wrong_syntax(NULL, clause, form, NULL); - - names = SCHEME_STX_CAR(clause); - - num_names = scheme_stx_proper_list_length(names); - if (num_names < 0) - scheme_wrong_syntax(NULL, names, form, NULL); - - num_bindings += num_names; - - l = SCHEME_STX_CDR(l); } - } else - num_bindings = num_clauses; + if (!rest) + scheme_wrong_syntax(NULL, clause, form, NULL); + + names = SCHEME_STX_CAR(clause); - if (rec_env_already) - scope = NULL; - else - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + num_names = scheme_stx_proper_list_length(names); + if (num_names < 0) + scheme_wrong_syntax(NULL, names, form, NULL); + + num_bindings += num_names; + + l = SCHEME_STX_CDR(l); + } names = MALLOC_N(Scheme_Object *, num_bindings); - if (frame_already) - frame = frame_already; - else { - frame = scheme_new_compilation_frame(num_bindings, - (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), - scope, - origenv); - if (rec_env_already) - frame_already = frame; - } - env = frame; - if (!recursive) - rhs_env = scheme_no_defines(origenv); - else - rhs_env = env; - recs = MALLOC_N_ATOMIC(Scheme_Compile_Info, (num_clauses + 1)); + frame = scheme_set_comp_env_name(origenv, NULL); - defname = origenv->value_name; - scheme_compile_rec_done_local(rec, drec); - scheme_init_compile_recs(rec, drec, recs, num_clauses + 1); - - defname = scheme_check_name_property(form, defname); + if (recursive) { + use_box = MALLOC_N_ATOMIC(int, 1); + *use_box = -1; + } else + use_box = 0; - if (!frame_already) { - scheme_begin_dup_symbol_check(&r, env); - } + scheme_begin_dup_symbol_check(&r); k = 0; @@ -2166,37 +1016,18 @@ do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, pre_k = k; - existing_vars = scheme_stx_property(binding, existing_variables_symbol, NULL); - name = SCHEME_STX_CAR(binding); - if (multi) { - while (!SCHEME_STX_NULLP(name)) { - Scheme_Object *n; - n = SCHEME_STX_CAR(name); - names[k] = n; - scheme_check_identifier(NULL, names[k], NULL, env, form); - k++; - name = SCHEME_STX_CDR(name); - } - - for (j = pre_k; j < k; j++) { - for (m = j + 1; m < k; m++) { - if (scheme_stx_bound_eq(names[m], names[j], scheme_make_integer(env->genv->phase))) - scheme_wrong_syntax(NULL, NULL, form, - "multiple bindings of `%S' in the same clause", - SCHEME_STX_SYM(names[m])); - } - } - } else { - scheme_check_identifier(NULL, name, NULL, env, form); - names[k++] = name; - } - - if (!frame_already) { - for (m = pre_k; m < k; m++) { - scheme_dup_symbol_check(&r, NULL, names[m], "binding", form); - } + while (!SCHEME_STX_NULLP(name)) { + Scheme_Object *n; + n = SCHEME_STX_CAR(name); + names[k] = n; + scheme_check_identifier(NULL, names[k], NULL, form); + scheme_dup_symbol_check(&r, NULL, names[k], "binding", form); + k++; + name = SCHEME_STX_CDR(name); } + + vars = MALLOC_N(Scheme_IR_Local*, k-pre_k); lv = MALLOC_ONE_TAGGED(Scheme_IR_Let_Value); lv->iso.so.type = scheme_ir_let_value_type; @@ -2206,62 +1037,38 @@ do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, last->body = (Scheme_Object *)lv; last = lv; lv->count = (k - pre_k); + lv->vars = vars; - if (lv->count == 1) - rhs_env->value_name = SCHEME_STX_SYM(names[pre_k]); - - if (!recursive) { - Scheme_Object *ce, *rhs; - rhs = SCHEME_STX_CDR(binding); - rhs = SCHEME_STX_CAR(rhs); - ce = scheme_compile_expr(rhs, rhs_env, recs, i); - lv->value = ce; - } else { + { Scheme_Object *rhs; rhs = SCHEME_STX_CDR(binding); rhs = SCHEME_STX_CAR(rhs); + if (!recursive) { + if (lv->count == 1) + rhs_env = scheme_set_comp_env_name(origenv, names[pre_k]); + else + rhs_env = scheme_set_comp_env_name(origenv, NULL); + rhs = SCHEME_STX_CDR(binding); + rhs = SCHEME_STX_CAR(rhs); + rhs = compile_expr(rhs, rhs_env, 0); + } lv->value = rhs; } - rhs_env->value_name = NULL; - - if (recursive) { - for (m = pre_k; m < k; m++) { - scheme_add_compilation_binding(m, names[m], frame); + for (m = pre_k; m < k; m++) { + var = scheme_make_ir_local(names[m]); + if (recursive) { + var->mode = SCHEME_VAR_MODE_COMPILE; + var->compile.use_box = use_box; + var->compile.use_position = m; } - } - - if (SCHEME_TRUEP(existing_vars)) { - /* Install variables already generated by a lift: */ - scheme_set_compilation_variables(frame, (Scheme_IR_Local **)SCHEME_CDR(existing_vars), - pre_k, k - pre_k); + vars[m-pre_k] = var; + frame = scheme_extend_comp_env(frame, names[m], (Scheme_Object *)var, mutate_frame, 0); + mutate_frame = 1; } bindings = SCHEME_STX_CDR(bindings); } - - if (!recursive) { - for (i = 0; i < num_bindings; i++) { - scheme_add_compilation_binding(i, names[i], frame); - } - } - - scheme_env_make_variables(env); - - k = 0; - lv = (Scheme_IR_Let_Value *)first; - for (i = 0; i < num_clauses; i++) { - Scheme_IR_Local **vars; - - vars = MALLOC_N(Scheme_IR_Local*, lv->count); - lv->vars = vars; - for (j = lv->count; j--; ) { - vars[j] = env->vars[k+j]; - } - - k += lv->count; - lv = (Scheme_IR_Let_Value *)lv->body; - } head = make_header(first, num_bindings, num_clauses, (recursive ? SCHEME_LET_RECURSIVE : 0)); @@ -2269,38 +1076,32 @@ do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, if (recursive) { int prev_might_invoke = 0; int group_clauses = 0; + Scheme_Object *rhs; k = 0; lv = (Scheme_IR_Let_Value *)first; for (i = 0; i < num_clauses; i++, lv = (Scheme_IR_Let_Value *)lv->body) { - Scheme_Object *ce, *rhs; rhs = lv->value; - if (scope) - rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv)); if (lv->count == 1) - env->value_name = lv->vars[0]->name; + rhs_env = scheme_set_comp_env_name(frame, names[k]); else - env->value_name = NULL; - ce = scheme_compile_expr(rhs, env, recs, i); - env->value_name = NULL; - lv->value = ce; + rhs_env = scheme_set_comp_env_name(frame, NULL); + rhs = compile_expr(rhs, rhs_env, 0); + lv->value = rhs; - /* Record when this binding doesn't use any or later - bindings in the same set. In internal-definition mode, - always break bindings into smaller sets based on this - information; otherwise, we have to be more conservative as reflected - by scheme_might_invoke_call_cc(), so record with - SCHEME_IRLV_NO_GROUP_LATER_USES and check again at the end. */ - if ((rec_env_already == 2) /* int def: semantics is `let' */ - || (!prev_might_invoke - && !scheme_might_invoke_call_cc(ce))) { + /* Record when this binding doesn't use any or later bindings in + the same set. Break bindings into smaller sets based on this + information, we have to be conservative as reflected by + scheme_might_invoke_call_cc(). Implement splitting by + recording with SCHEME_IRLV_NO_GROUP_LATER_USES and check + again at the end. */ + if (!prev_might_invoke && !scheme_might_invoke_call_cc(rhs)) { group_clauses++; - if ((group_clauses == 1) - && !scheme_env_max_use_above(env, k)) { + if ((group_clauses == 1) && (*use_box < k)) { /* A clause that should be in its own `let' */ SCHEME_IRLV_FLAGS(lv) |= SCHEME_IRLV_NO_GROUP_USES; group_clauses = 0; - } else if (!scheme_env_max_use_above(env, k + lv->count)) { + } else if (*use_box < (k + lv->count)) { /* End a recursive `letrec' group */ SCHEME_IRLV_FLAGS(lv) |= SCHEME_IRLV_NO_GROUP_LATER_USES; group_clauses = 0; @@ -2347,350 +1148,44 @@ do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, } } - env->value_name = defname ? SCHEME_STX_SYM(defname) : NULL; - { - Scheme_Object *cs; - if (scope) forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); - cs = compile_sequence(forms, env, recs, num_clauses, body_block); - last->body = cs; - } - env->value_name = NULL; + frame = scheme_set_comp_env_name(frame, origenv->value_name); - scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1); + forms = compile_expr(forms, frame, 0); + last->body = forms; return (Scheme_Object *)head; } -static Scheme_Object * -do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_Info *erec, int drec, - const char *formname, int letrec, int multi, - Scheme_Comp_Env *env_already) +static Scheme_Object *let_values_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *boundname, *form, *pre_set, *scope; - Scheme_Object *vlist_first, *vlist_last; - Scheme_Comp_Env *use_env, *env; - Scheme_Expand_Info erec1; - DupCheckRecord r; - int rec_env_already = erec[drec].env_already, forward_ref_boundary, body_block; - /* If env_already == 2, then it's not a true `letrec': - it's from `letrec-values+syntax' and should be - expanded into `let' plus `letrec'. */ - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (rec_env_already >= 2) { - body_block = (rec_env_already > 2); - rec_env_already = 2; - v = detect_traditional_letrec(form, origenv); - if (!SAME_OBJ(v, form)) { - rec_env_already = 1; - form = v; - } - } else - body_block = !rec_env_already; - - vars = SCHEME_STX_CDR(form); - - if (!SCHEME_STX_PAIRP(vars)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - - body = SCHEME_STX_CDR(vars); - vars = SCHEME_STX_CAR(vars); - - if (!SCHEME_STX_PAIRP(body)) - scheme_wrong_syntax(NULL, NULL, form, (SCHEME_STX_NULLP(body) - ? "empty body not allowed" - : NULL)); - - boundname = scheme_check_name_property(form, origenv->value_name); - - if (!env_already && !rec_env_already) - scheme_begin_dup_symbol_check(&r, origenv); - - vlist_first = scheme_null; - vlist_last = NULL; - vs = vars; - while (SCHEME_STX_PAIRP(vs)) { - Scheme_Object *v2; - v = SCHEME_STX_CAR(vs); - if (SCHEME_STX_PAIRP(v)) - v2 = SCHEME_STX_CDR(v); - else - v2 = scheme_false; - if (!SCHEME_STX_PAIRP(v2) || !SCHEME_STX_NULLP(SCHEME_STX_CDR(v2))) - scheme_wrong_syntax(NULL, v, form, NULL); - - name = SCHEME_STX_CAR(v); - - { - DupCheckRecord r2; - Scheme_Object *names = name; - if (!env_already && !rec_env_already) - scheme_begin_dup_symbol_check(&r2, origenv); - while (SCHEME_STX_PAIRP(names)) { - name = SCHEME_STX_CAR(names); - - scheme_check_identifier(NULL, name, NULL, origenv, form); - - v = scheme_make_pair(name, scheme_null); - if (vlist_last) - SCHEME_CDR(vlist_last) = v; - else - vlist_first = v; - vlist_last = v; - - if (!env_already && !rec_env_already) { - scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form); - scheme_dup_symbol_check(&r, NULL, name, "binding", form); - } - - names = SCHEME_STX_CDR(names); - } - if (!SCHEME_STX_NULLP(names)) - scheme_wrong_syntax(NULL, names, form, NULL); - } - - vs = SCHEME_STX_CDR(vs); - } - - if (!SCHEME_STX_NULLP(vs)) - scheme_wrong_syntax(NULL, vs, form, NULL); - - if (env_already) { - env = env_already; - scope = NULL; - } else { - if (rec_env_already) - scope = NULL; - else - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - env = scheme_add_compilation_frame(vlist_first, - scope, - origenv, - (rec_env_already ? SCHEME_INTDEF_SHADOW : 0)); - } - - if (letrec) - use_env = env; - else - use_env = scheme_no_defines(origenv); - - /* Pass 1: Rename */ - - first = last = NULL; - vs = vars; - forward_ref_boundary = 0; - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *rhs; - - v = SCHEME_STX_CAR(vars); - - /* Make sure names gets their own renames: */ - name = SCHEME_STX_CAR(v); - if (scope) name = scheme_stx_add_scope(name, scope, scheme_env_phase(env->genv)); - - rhs = SCHEME_STX_CDR(v); - rhs = SCHEME_STX_CAR(rhs); - if (scope && letrec) rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv)); - - v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); - v = cons(v, scheme_null); - - if (!first) - first = v; - else - SCHEME_CDR(last) = v; - - last = v; - vars = SCHEME_STX_CDR(vars); - } - if (!first) { - first = scheme_null; - } - vars = first; - - body = scheme_datum_to_syntax(body, form, form, 0, 0); - if (scope) body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_LET_RENAMES(env->observer, vars, body); - } - - /* Pass 2: Expand */ - - first = last = NULL; - pre_set = scheme_null; - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *rhs, *rhs_name; - - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - - v = SCHEME_STX_CAR(vars); - - name = SCHEME_STX_CAR(v); - rhs = SCHEME_STX_CDR(v); - rhs = SCHEME_STX_CAR(rhs); - - if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) { - rhs_name = SCHEME_STX_CAR(name); - } else { - rhs_name = scheme_false; - } - - scheme_init_expand_recs(erec, drec, &erec1, 1); - use_env->value_name = rhs_name; - rhs = scheme_expand_expr(rhs, use_env, &erec1, 0); - use_env->value_name = NULL; - - v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); - v = cons(v, scheme_null); - - if (!first) - first = v; - else - SCHEME_CDR(last) = v; - - last = v; - - if (rec_env_already == 2) { - /* Expansion for internal definitions: break into `let' and - `letrec' groups based on references among definitions: */ - int cnt; - cnt = scheme_stx_proper_list_length(name); - if (SCHEME_NULLP(SCHEME_CDR(first)) - && !scheme_env_max_use_above(use_env, forward_ref_boundary)) { - /* no self or forward references */ - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - pre_set = cons(cons(let_values_symbol, first), pre_set); - first = NULL; - } else if (!scheme_env_max_use_above(use_env, forward_ref_boundary + cnt)) { - /* no (further) forward references */ - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - pre_set = cons(cons(letrec_values_symbol, first), pre_set); - first = NULL; - } - forward_ref_boundary += cnt; - } - - vars = SCHEME_STX_CDR(vars); - } - - /* End Pass 2 */ - - if (!SCHEME_STX_NULLP(vars)) - scheme_wrong_syntax(NULL, vars, form, NULL); - - if (SCHEME_NULLP(pre_set) || first) { - if (!first) - first = scheme_null; - - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - } - - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(env->observer); - } - scheme_init_expand_recs(erec, drec, &erec1, 1); - env->value_name = boundname; - if (!body_block) - body = expand_list(body, env, &erec1, 0); - else - body = expand_block(body, env, &erec1, 0); - env->value_name = NULL; - - if (SCHEME_PAIRP(pre_set)) { - if (first) - pre_set = cons(cons(letrec_values_symbol, first), pre_set); - - while (!SCHEME_NULLP(pre_set)) { - v = scheme_datum_to_syntax(SCHEME_CAR(SCHEME_CAR(pre_set)), orig_form, scheme_sys_wraps(origenv), 0, 0); - body = cons(v, cons(SCHEME_CDR(SCHEME_CAR(pre_set)), body)); - body = scheme_datum_to_syntax(body, orig_form, orig_form, 0, 2); - body = cons(body, scheme_null); - pre_set = SCHEME_CDR(pre_set); - } - - return SCHEME_CAR(body); - } else { - v = SCHEME_STX_CAR(form); - v = cons(v, cons(first, body)); - v = scheme_datum_to_syntax(v, orig_form, orig_form, 0, 2); - } - - return v; + return do_let_compile(form, env, "let-values", 0); } -static Scheme_Object * -let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(env->observer); - return do_let_expand(form, env, erec, drec, "let-values", 0, 1, NULL); -} - -static Scheme_Object * -letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(env->observer); - return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, NULL); -} - - -static Scheme_Object * -let_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_let_compile(form, env, "let-values", 0, 1, rec, drec, NULL); -} - -static Scheme_Object * -letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_let_compile(form, env, "letrec-values", 1, 1, rec, drec, NULL); + return do_let_compile(form, env, "letrec-values", 1); } /**********************************************************************/ /* begin, begin0, implicit begins */ /**********************************************************************/ -static Scheme_Object *compile_sequence(Scheme_Object *forms, - Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int as_intdef) -{ - if (scheme_stx_proper_list_length(forms) < 0) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, - scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), - IMPROPER_LIST_FORM); - return NULL; - } else { - Scheme_Object *body; - if (as_intdef) - body = compile_block(forms, env, rec, drec); - else - body = compile_list(forms, env, rec, drec); - return scheme_make_sequence_compilation(body, 1, 0); - } -} - Scheme_Object *scheme_compiled_void() { return scheme_void; } -static Scheme_Object * -do_begin_compile(char *name, - Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, - int zero) +static Scheme_Object *do_begin_compile(char *name, + Scheme_Object *form, Scheme_Comp_Env *env, + int zero) { - Scheme_Object *forms, *body, *vname; - - form = scheme_stx_taint_disarm(form, NULL); + Scheme_Comp_Env *nontail_env; + Scheme_Object *forms, *body; forms = SCHEME_STX_CDR(form); if (SCHEME_STX_NULLP(forms)) { - if (!zero && scheme_is_toplevel(env)) + if (!zero) return scheme_compiled_void(); scheme_wrong_syntax(NULL, NULL, form, "empty form not allowed"); return NULL; @@ -2698,79 +1193,44 @@ do_begin_compile(char *name, check_form(form, form); - if (zero) { - vname = env->value_name; - env = scheme_no_defines(env); - env->value_name = vname; - } + env = check_name_property(form, env); + nontail_env = scheme_set_comp_env_name(env, NULL); - /* if the begin has only one expression inside, drop the begin - TODO: is this right */ + /* if the `begin` has only one expression inside, drop the `begin`; + this is allowed even for `begin0`, where the initial expression + is considered in tail position if it's syntactically the only + expression */ if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { forms = SCHEME_STX_CAR(forms); - return scheme_compile_expr(forms, env, rec, drec); + return compile_expr(forms, env, 0); } - if (!scheme_is_toplevel(env)) { - /* Not at top-level */ - if (zero) { - /* First expression is not part of the block: */ - Scheme_Compile_Info recs[2]; - Scheme_Object *first, *rest, *vname; + if (zero) { + Scheme_Object *first, *rest; - vname = env->value_name; - scheme_compile_rec_done_local(rec, drec); + first = SCHEME_STX_CAR(forms); + first = compile_expr(first, env, 0); + rest = SCHEME_STX_CDR(forms); + rest = compile_list(rest, nontail_env, nontail_env, nontail_env, 0); - vname = scheme_check_name_property(form, vname); - - scheme_init_compile_recs(rec, drec, recs, 2); - - first = SCHEME_STX_CAR(forms); - env->value_name = vname; - first = scheme_compile_expr(first, env, recs, 0); - env->value_name = NULL; - rest = SCHEME_STX_CDR(forms); - rest = compile_list(rest, env, recs, 1); - - scheme_merge_compile_recs(rec, drec, recs, 2); - - body = cons(first, rest); - } else { - Scheme_Object *v; - v = scheme_check_name_property(form, env->value_name); - env->value_name = v; - - body = compile_list(forms, env, rec, drec); - - env->value_name = NULL; - } + body = cons(first, rest); } else { - /* Top level */ - body = compile_list(forms, env, rec, drec); + body = compile_list(forms, nontail_env, nontail_env, env, 0); } forms = scheme_make_sequence_compilation(body, zero ? -1 : 1, 0); - if (!zero - && SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type) - && scheme_is_toplevel(env)) { - forms->type = scheme_splice_sequence_type; - return forms; - } - return forms; } -static Scheme_Object * -begin_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - return do_begin_compile("begin", form, env, rec, drec, 0); + return do_begin_compile("begin", form, env, 0); } -static Scheme_Object * -begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env) { - return do_begin_compile("begin0", form, env, rec, drec, 1); + return do_begin_compile("begin0", form, env, 1); } Scheme_Sequence *scheme_malloc_sequence(int count) @@ -2880,1067 +1340,6 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt, int return (Scheme_Object *)o; } -static Scheme_Object * -stratified_body_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *body; - - check_form(form, form); - - body = SCHEME_STX_CDR(form); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = compile_stratified_block(body, env, rec, drec); - - if (SCHEME_NULLP(SCHEME_CDR(body))) - return SCHEME_CAR(body); - else - return scheme_make_sequence_compilation(body, 1, 0); -} - -static Scheme_Object * -do_begin_expand(char *name, - Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, - int zero) -{ - Scheme_Object *form_name; - Scheme_Object *rest; - Scheme_Object *form; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - check_form(form, form); - - form_name = SCHEME_STX_CAR(form); - - rest = SCHEME_STX_CDR(form); - - if (SCHEME_STX_NULLP(rest)) { - if (!zero && scheme_is_toplevel(env)) { - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, form); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form); - } - return orig_form; - } - scheme_wrong_syntax(NULL, NULL, form, "empty form not allowed"); - return NULL; - } - - if (zero) - env = scheme_no_defines(env); - - if (!scheme_is_toplevel(env)) { - /* Not at top-level: */ - if (zero) { - Scheme_Object *fst, *boundname; - Scheme_Expand_Info erec1; - scheme_init_expand_recs(erec, drec, &erec1, 1); - boundname = scheme_check_name_property(form, env->value_name); - fst = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - env->value_name = boundname; - fst = scheme_expand_expr(fst, env, &erec1, 0); - env->value_name = NULL; - rest = scheme_datum_to_syntax(rest, form, form, 0, 0); - if (!erec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - rest = expand_list(rest, env, erec, drec); - - form = cons(fst, rest); - } else { - Scheme_Object *boundname; - boundname = scheme_check_name_property(form, env->value_name); - env->value_name = boundname; - - form = expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); -#if 0 - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) - return scheme_stx_taint_rearm(SCHEME_STX_CAR(form), orig_form); -#endif - } - } else { - /* Top level */ - form = expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); - } - - return scheme_datum_to_syntax(cons(form_name, form), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object * -begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer); - return do_begin_expand("begin", form, env, erec, drec, 0); -} - -static Scheme_Object * -begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(env->observer); - return do_begin_expand("begin0", form, env, erec, drec, 1); -} - -static Scheme_Object * -stratified_body_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *body, *form; - - SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - check_form(form, form); - - body = SCHEME_STX_CDR(form); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = expand_stratified_block(body, env, erec, drec); - - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(body))) { - body = SCHEME_STX_CAR(body); - return scheme_stx_taint_rearm(body, orig_form); - } else { - body = cons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - body); - return scheme_datum_to_syntax(body, orig_form, orig_form, 0, 0); - } -} - -/**********************************************************************/ -/* #%non-module and #%expression */ -/**********************************************************************/ - -static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_only) -{ - Scheme_Object *rest; - - form = scheme_stx_taint_disarm(form, NULL); - - check_form(form, form); - - rest = SCHEME_STX_CDR(form); - if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) - scheme_wrong_syntax(NULL, NULL, form, "wrong number of parts"); - - if (top_only && !scheme_is_toplevel(top_only)) - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); - - return SCHEME_STX_CAR(rest); -} - -static Scheme_Object * -single_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only) -{ - return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec); -} - -static Scheme_Object * -single_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, - int top_only, int simplify) -{ - Scheme_Object *expr, *form_name, *form; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - expr = check_single(form, top_only ? env : NULL); - expr = scheme_expand_expr(expr, env, erec, drec); - - form_name = SCHEME_STX_CAR(form); - - if (simplify && (erec[drec].depth == -1)) { - expr = scheme_stx_track(expr, form, form_name); - SCHEME_EXPAND_OBSERVE_TAG(env->observer,expr); - return expr; - } - - return scheme_datum_to_syntax(cons(form_name, cons(expr, scheme_null)), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object *expression_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return single_compile(form, scheme_no_defines(env), rec, drec, 0); -} - -static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(env->observer); - return single_expand(form, scheme_no_defines(env), erec, drec, 0, - !(env->flags & SCHEME_TOPLEVEL_FRAME)); -} - - -/**********************************************************************/ -/* unquote, unquote-splicing */ -/**********************************************************************/ - -static Scheme_Object * -unquote_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - int len; - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); - - len = check_form(form, form); - if (len != 2) - bad_form(form, len); - - scheme_wrong_syntax(NULL, NULL, form, "not in quasiquote"); - return NULL; -} - -static Scheme_Object * -unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return unquote_compile(form, env, erec, drec); -} - -/**********************************************************************/ -/* quote-syntax */ -/**********************************************************************/ - -static Scheme_Object * -quote_syntax_compile(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - int len, local; - Scheme_Object *stx, *form; - Scheme_Comp_Env *frame; - - if (rec[drec].comp) - env->prefix->non_phaseless = 1; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); - - len = check_form(form, form); - if ((len != 2) && (len != 3)) - bad_form(form, len); - - if (len == 3) { - stx = SCHEME_STX_CDR(form); - stx = SCHEME_STX_CDR(stx); - stx = SCHEME_STX_CAR(stx); - if (!SAME_OBJ(SCHEME_STX_VAL(stx), local_keyword)) { - scheme_wrong_syntax(NULL, stx, form, "second subform is not `#:local'"); - return NULL; - } - local = 1; - if (!rec[drec].comp) { - /* A `(quote-syntax _ #:local)` counts as a reference at all levels */ - scheme_mark_all_use(env); - } - } else - local = 0; - - if (!local) { - stx = SCHEME_STX_CDR(form); - stx = SCHEME_STX_CAR(stx); - - /* Remove scopes for all enclosing local binding contexts. */ - for (frame = env; frame; frame = frame->next) { - if ((frame->scopes) && !(frame->flags & SCHEME_KEEP_SCOPES_FRAME)) { - stx = scheme_stx_adjust_frame_scopes(stx, frame->scopes, - scheme_env_phase(frame->genv), SCHEME_STX_REMOVE); - } - } - - if (rec[drec].comp) - return scheme_register_stx_in_prefix(stx, env, rec, drec); - else { - form = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(scheme_make_pair(form, - scheme_make_pair(stx, scheme_null)), - orig_form, orig_form, 0, 2); - } - } else { - if (rec[drec].comp) { - stx = SCHEME_STX_CDR(form); - stx = SCHEME_STX_CAR(stx); - return scheme_register_stx_in_prefix(stx, env, rec, drec); - } else - return orig_form; - } -} - -static Scheme_Object * -quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(env->observer); - return quote_syntax_compile(form, env, erec, drec); -} - - -/**********************************************************************/ -/* define-syntaxes */ -/**********************************************************************/ - -static void prep_exp_env_compile_rec(Scheme_Compile_Info *rec, int drec) -{ - rec[0].comp = 1; - rec[0].dont_mark_local_use = 0; - rec[0].resolve_module_ids = 0; - rec[0].substitute_bindings = 1; - rec[0].pre_unwrapped = 0; - rec[0].testing_constantness = 0; - rec[0].env_already = 0; - rec[0].comp_flags = rec[drec].comp_flags; -} - -static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) -{ - return global_binding(name, (Scheme_Comp_Env *)_env); -} - -static Scheme_Object * -do_define_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *names, *code, *dummy; - Scheme_Object *val, *vec; - Scheme_Comp_Env *exp_env; - Scheme_Compile_Info rec1; - - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - - scheme_define_parse(form, &names, &code, 1, env, 0); - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - - names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env); - - exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, NULL, 0); - exp_env->observer = env->observer; - - dummy = scheme_make_environment_dummy(env); - - prep_exp_env_compile_rec(&rec1, 0); - - if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) - exp_env->value_name = SCHEME_STX_VAL(SCHEME_CAR(names)); - - val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0); - - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)exp_env->prefix; - SCHEME_VEC_ELS(vec)[1] = dummy; - SCHEME_VEC_ELS(vec)[2] = names; - SCHEME_VEC_ELS(vec)[3] = val; - - vec->type = scheme_define_syntaxes_type; - - scheme_merge_undefineds(exp_env, env); - - return vec; -} - -static Scheme_Object * -define_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_define_syntaxes_compile(form, env, rec, drec); -} - -static Scheme_Object * -define_syntaxes_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *names, *code, *fpart, *fn, *form, *observer; - - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(env->observer); - - form = orig_form; - - scheme_define_parse(form, &names, &code, 1, env, 0); - - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer); - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - observer = env->observer; - - env = scheme_new_expand_env(env->genv->exp_env, env->insp, NULL, 0); - env->observer = observer; - - env->value_name = names; - fpart = scheme_expand_expr_lift_to_let(code, env, erec, drec); - - code = cons(fpart, scheme_null); - code = cons(names, code); - - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, code), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object * -begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Scheme_Expand_Info *rec, int drec) -{ - Scheme_Expand_Info recs[1]; - Scheme_Object *form, *l, *fn, *vec, *dummy; - Scheme_Comp_Env *env; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(in_env->observer); - } - - form = orig_form; - - if (!scheme_is_toplevel(in_env)) - scheme_wrong_syntax(NULL, NULL, form, "not in a definition context"); - - (void)check_form(form, form); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(in_env->observer); - } - - scheme_prepare_exp_env(in_env->genv); - scheme_prepare_compile_env(in_env->genv->exp_env); - - if (rec[drec].comp) { - env = scheme_new_comp_env(in_env->genv->exp_env, in_env->insp, NULL, - (in_env->flags & SCHEME_TMP_TL_BIND_FRAME)); - env->bindings = in_env->bindings; - } else - env = scheme_new_expand_env(in_env->genv->exp_env, in_env->insp, NULL, 0); - - env->observer = in_env->observer; - - if (rec[drec].comp) - dummy = scheme_make_environment_dummy(in_env); - else - dummy = NULL; - - l = SCHEME_STX_CDR(form); - form = scheme_null; - - while (1) { - scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), - scheme_false, scheme_top_level_lifts_key(env), scheme_null, - scheme_false, scheme_true); - - if (rec[drec].comp) { - scheme_init_compile_recs(rec, drec, recs, 1); - prep_exp_env_compile_rec(recs, 0); - l = compile_list(l, env, recs, 0); - } else { - scheme_init_expand_recs(rec, drec, recs, 1); - l = expand_list(l, env, recs, 0); - } - - if (SCHEME_NULLP(form)) - form = l; - else - form = scheme_append(l, form); - - l = scheme_frame_get_lifts(env); - if (SCHEME_NULLP(l)) { - /* No lifts */ - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, NULL, 1); /* fix this if merge changes to do something */ - break; - } else { - /* We have lifts: */ - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(env->observer, l); - } - } - - if (rec[drec].comp) { - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->prefix; - SCHEME_VEC_ELS(vec)[1] = dummy; - SCHEME_VEC_ELS(vec)[2] = form; - vec->type = scheme_begin_for_syntax_type; - - return vec; - } else { - fn = SCHEME_STX_CAR(orig_form); - return scheme_datum_to_syntax(cons(fn, form), - orig_form, orig_form, - 0, 2); - } -} - -static Scheme_Object * -begin_for_syntax_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return begin_for_syntax_expand(form, env, rec, drec); -} - -Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env) -{ - /* Get a prefixed-based accessor for a dummy top-level bucket. It's - used to "link" to the right environment at run time. The #f as - a toplevel is handled in the prefix linker specially. */ - return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0, 0, NULL); -} - -Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy) -{ - Scheme_Prefix *toplevels; - Scheme_Bucket *b; - - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(dummy)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(dummy)]; - return scheme_get_bucket_home(b); -} - -/**********************************************************************/ -/* letrec-syntaxes */ -/**********************************************************************/ - -static void *eval_letmacro_rhs_k(void); - -static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Env *genv, Scheme_Comp_Env *rhs_env, - int max_let_depth, Resolve_Prefix *rp, - int phase) -{ - Scheme_Object **save_runstack; - int depth; - - depth = max_let_depth + scheme_prefix_depth(rp); - if (!scheme_check_runstack(depth)) { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = a; - p->ku.k.p2 = rhs_env; - p->ku.k.p3 = rp; - p->ku.k.p4 = genv; - p->ku.k.i1 = max_let_depth; - p->ku.k.i2 = phase; - return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k); - } - - save_runstack = scheme_push_prefix(genv, 1, rp, NULL, NULL, phase, phase, rhs_env->genv, NULL); - - if (scheme_omittable_expr(a, 1, -1, OMITTABLE_RESOLVED, NULL, NULL)) { - /* short cut */ - a = _scheme_eval_linked_expr_multi(a); - } else { - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - Scheme_Dynamic_State dyn_state; - - scheme_prepare_exp_env(rhs_env->genv); - scheme_prepare_compile_env(rhs_env->genv->exp_env); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)rhs_env->genv->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, - rhs_env->genv, rhs_env->genv->link_midx); - a = scheme_eval_linked_expr_multi_with_dynamic_state(a, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - } - - scheme_pop_prefix(save_runstack); - - return a; -} - -static void *eval_letmacro_rhs_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *a; - Scheme_Comp_Env *rhs_env; - int max_let_depth, phase; - Resolve_Prefix *rp; - Scheme_Env *genv; - - a = (Scheme_Object *)p->ku.k.p1; - rhs_env = (Scheme_Comp_Env *)p->ku.k.p2; - rp = (Resolve_Prefix *)p->ku.k.p3; - genv = (Scheme_Env *)p->ku.k.p4; - max_let_depth = p->ku.k.i1; - phase = p->ku.k.i2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return (void *)eval_letmacro_rhs(a, genv, rhs_env, max_let_depth, rp, phase); -} - -void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, - Scheme_Env *exp_env, Scheme_Object *insp, - Scheme_Compile_Expand_Info *rec, int drec, Scheme_Object *observer, - Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos, Scheme_Object *rename_rib, - int replace_value) -{ - Scheme_Object **results, *l, *a_expr; - Scheme_Comp_Env *eenv; - Resolve_Prefix *rp; - Resolve_Info *ri; - Optimize_Info *oi; - int vc, nc, j, i; - Scheme_Compile_Expand_Info mrec; - - eenv = scheme_new_comp_env(exp_env, insp, NULL, 0); - eenv->observer = observer; - - /* First expand for expansion-observation */ - if (!rec[drec].comp) { - scheme_init_expand_recs(rec, drec, &mrec, 1); - SCHEME_EXPAND_OBSERVE_ENTER_BIND(eenv->observer); - a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0); - } - - /* Then compile */ - mrec.comp = 1; - mrec.dont_mark_local_use = 0; - mrec.resolve_module_ids = 1; - mrec.substitute_bindings = 1; - mrec.pre_unwrapped = 0; - mrec.testing_constantness = 0; - mrec.env_already = 0; - mrec.comp_flags = rec[drec].comp_flags; - - if (SCHEME_STX_PAIRP(names)) { - l = SCHEME_STX_CDR(names); - if (SCHEME_STX_NULLP(l)) { - l = SCHEME_STX_CAR(names); - eenv->value_name = SCHEME_STX_VAL(l); - } - } - - a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0); - - a = scheme_letrec_check_expr(a); - - oi = scheme_optimize_info_create(eenv->prefix, eenv->genv, insp, 1); - if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - a = scheme_optimize_expr(a, oi, 0); - - rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, insp); - - ri = scheme_resolve_info_create(rp); - a = scheme_resolve_expr(a, ri); - - rp = scheme_remap_prefix(rp, ri); - - /* To JIT: - if (ri->use_jit) a = scheme_jit_expr(a); - but it's not likely that a let-syntax-bound macro is going - to run lots of times, so JITting is probably not worth it. */ - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(eenv->observer); - } - - a_expr = a; - a = eval_letmacro_rhs(a_expr, eenv->genv, rhs_env, - scheme_resolve_info_max_let_depth(ri), - rp, eenv->genv->phase); - - if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) { - vc = scheme_current_thread->ku.multiple.count; - results = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; - if (SAME_OBJ(results, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - } else { - vc = 1; - results = NULL; - } - - for (nc = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - nc++; - } - - if (vc != nc) { - Scheme_Object *name; - const char *symname; - - if (nc >= 1) { - name = SCHEME_STX_CAR(names); - name = SCHEME_STX_VAL(name); - } else - name = NULL; - symname = (name ? scheme_symbol_name(name) : ""); - - scheme_wrong_return_arity(where, - nc, vc, - (vc == 1) ? (Scheme_Object **)a : results, - "%s%s%s", - name ? "defining \"" : "0 names", - symname, - name ? ((nc == 1) ? "\"" : "\", ...") : ""); - } - - i = *_pos; - for (j = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l), j++) { - Scheme_Object *name, *macro; - name = SCHEME_STX_CAR(l); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - if (vc == 1) - SCHEME_PTR_VAL(macro) = a; - else - SCHEME_PTR_VAL(macro) = results[j]; - - scheme_set_local_syntax(i++, name, macro, stx_env, replace_value); - - if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { - /* Rebind to the target identifier's binding */ - scheme_add_binding_copy(name, - scheme_rename_transformer_id(SCHEME_PTR_VAL(macro), rhs_env), - scheme_make_integer(stx_env->genv->phase)); - } - } - *_pos = i; - - scheme_merge_undefineds(eenv, rhs_env); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_BIND(observer); - } -} - -static Scheme_Object * -do_letrec_syntaxes(const char *where, - Scheme_Object *orig_forms, Scheme_Comp_Env *origenv, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *forms, *form, *bindings, *var_bindings, *body, *v, *scope; - Scheme_Object *names_to_disappear, *orig_vname; - Scheme_Comp_Env *stx_env, *var_env, *rhs_env; - int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already, restore; - DupCheckRecord r; - - forms = scheme_stx_taint_disarm(orig_forms, NULL); - - env_already = rec[drec].env_already; - - form = SCHEME_STX_CDR(forms); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - bindings = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - var_bindings = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - body = scheme_datum_to_syntax(form, forms, forms, 0, 0); - - orig_vname = origenv->value_name; - - if (env_already) { - stx_env = origenv; - scope = NULL; - } else { - scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); - stx_env = scheme_new_compilation_frame(0, 0, scope, origenv); - } - - rhs_env = stx_env; - - if (!SCHEME_STX_NULLP(bindings) && !SCHEME_STX_PAIRP(bindings)) { - scheme_wrong_syntax(NULL, bindings, forms, "not a binding sequence"); - } else - check_form(bindings, forms); - if (!SCHEME_STX_NULLP(var_bindings) && !SCHEME_STX_PAIRP(var_bindings)) { - scheme_wrong_syntax(NULL, var_bindings, forms, "not a binding sequence"); - } else - check_form(var_bindings, forms); - - cnt = stx_cnt = var_cnt = 0; - saw_var = 0; - - depth = rec[drec].depth; - restore = (depth >= 0); - - if (!rec[drec].comp && !restore) - names_to_disappear = scheme_null; - else - names_to_disappear = NULL; - - if (!env_already) - scheme_begin_dup_symbol_check(&r, stx_env); - - /* Pass 1: Check and Rename */ - - for (i = 0; i < 2 ; i++) { - for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *l; - - a = SCHEME_STX_CAR(v); - if (!SCHEME_STX_PAIRP(a) - || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(a))) - v = NULL; - else { - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l))) - break; - } - if (!SCHEME_STX_NULLP(l)) - v = NULL; - } - - if (v) { - Scheme_Object *rest; - rest = SCHEME_STX_CDR(a); - if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) - v = NULL; - } - - if (!v) - scheme_wrong_syntax(NULL, a, forms, - "binding clause not an identifier sequence and expression"); - - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (!env_already) { - scheme_check_identifier(where, a, NULL, stx_env, forms); - scheme_dup_symbol_check(&r, where, a, "binding", forms); - } - cnt++; - } - if (i) - saw_var = 1; - } - - if (!i) - stx_cnt = cnt; - else - var_cnt = cnt - stx_cnt; - } - - if (!env_already) - scheme_add_local_syntax(stx_cnt, stx_env); - - if (saw_var) { - var_env = scheme_new_compilation_frame(var_cnt, - (env_already ? SCHEME_INTDEF_SHADOW : 0), - scope, - stx_env); - } else - var_env = NULL; - - for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) { - cnt = (i ? var_cnt : stx_cnt); - if (cnt > 0) { - /* Add new syntax/variable names to the environment: */ - j = 0; - for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *l; - a = SCHEME_STX_CAR(v); - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (i) { - /* In compile mode, this will get re-written by the letrec compiler. - But that's ok. We need it now for env_renames. */ - scheme_add_compilation_binding(j++, a, var_env); - } else - scheme_set_local_syntax(j++, a, NULL, stx_env, 0); - } - } - } - } - - if (scope) { - bindings = scheme_stx_add_scope(bindings, scope, scheme_env_phase(stx_env->genv)); - var_bindings = scheme_stx_add_scope(var_bindings, scope, scheme_env_phase(stx_env->genv)); - body = scheme_stx_add_scope(body, scope, scheme_env_phase(stx_env->genv)); - } - - if (names_to_disappear) { - for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *names; - - a = SCHEME_STX_CAR(v); - names = SCHEME_STX_CAR(a); - while (!SCHEME_STX_NULLP(names)) { - a = SCHEME_STX_CAR(names); - names_to_disappear = cons(a, names_to_disappear); - names = SCHEME_STX_CDR(names); - } - } - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(stx_env->observer, bindings, var_bindings, body); - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(stx_env->observer); - } - scheme_prepare_exp_env(stx_env->genv); - scheme_prepare_compile_env(stx_env->genv->exp_env); - - if (!env_already) { - i = 0; - - for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *names; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(stx_env->observer); - } - - a = SCHEME_STX_CAR(v); - names = SCHEME_STX_CAR(a); - a = SCHEME_STX_CDR(a); - a = SCHEME_STX_CAR(a); - - scheme_bind_syntaxes(where, names, a, - stx_env->genv->exp_env, - stx_env->insp, - rec, drec, stx_env->observer, - stx_env, rhs_env, - &i, NULL, 1); - } - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(stx_env->observer); - } - - if (!env_already && names_to_disappear) { - /* Need to add renaming for disappeared bindings. If they - originated for internal definitions, then we need both - pre-renamed and renamed, since some might have been - expanded to determine definitions. */ - Scheme_Object *l, *a, *pf = NULL, *pl = NULL; - - if (origenv->flags & SCHEME_FOR_INTDEF) { - for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - a = cons(a, scheme_null); - if (pl) - SCHEME_CDR(pl) = a; - else - pf = a; - pl = a; - } - } - - for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (scope) a = scheme_stx_add_scope(a, scope, scheme_env_phase(stx_env->genv)); - SCHEME_CAR(l) = a; - } - - if (pf) { - SCHEME_CDR(pl) = names_to_disappear; - names_to_disappear = pf; - } - } - - if (!var_env) { - var_env = stx_env; - v = scheme_check_name_property(forms, orig_vname); - var_env->value_name = v; - if (rec[drec].comp) { - if (env_already) - v = compile_list(body, var_env, rec, drec); - else - v = compile_block(body, var_env, rec, drec); - v = scheme_make_sequence_compilation(v, 1, 0); - } else { - if (env_already) - v = expand_list(body, var_env, rec, drec); - else - v = expand_block(body, var_env, rec, drec); - if (restore) { - Scheme_Object *formname; - formname = SCHEME_STX_CAR(forms); - v = cons(formname, cons(bindings, cons(var_bindings, v))); - } else { - v = cons(let_values_symbol, cons(scheme_null, v)); - } - - if (SCHEME_PAIRP(v)) - v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), - 0, 2); - else - v = scheme_stx_taint_rearm(v, orig_forms); - - if (!restore) { - SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v); /* in "expand" branch */ - } - } - var_env->value_name = NULL; - } else { - /* Construct letrec-values expression: */ - v = cons(letrec_values_symbol, cons(var_bindings, body)); - v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2); - - if (!env_already) { /* i.e., not internal defn */ - /* We want non-`letrec' semantics for value bindings (i.e., sort - out the bindings into `letrec' and `let'), but also treat the - body as a block. */ - rec[drec].env_already = 3; - } - - if (rec[drec].comp) { - v = do_let_compile(v, stx_env, "letrec-values", 1, 1, rec, drec, var_env); - } else { - if (restore && (rec[drec].env_already == 2)) { - /* don't sort out after all, because we're keeping `letrec-values+syntaxes' */ - rec[drec].env_already = 1; - } - - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(stx_env->observer); /* in "expand" branch */ - v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, var_env); - - if (restore) { - /* Add back out the pieces we want: */ - Scheme_Object *formname; - formname = SCHEME_STX_CAR(forms); - v = scheme_stx_taint_disarm(v, NULL); - v = SCHEME_STX_CDR(v); - v = cons(formname, cons(bindings, v)); - v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2); - } else { - SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v); /* in "expand" branch */ - } - } - } - - /* Add the 'disappeared-binding property */ - if (names_to_disappear) - v = scheme_stx_property(v, disappeared_binding_symbol, names_to_disappear); - - return v; -} - -static Scheme_Object * -letrec_syntaxes_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_letrec_syntaxes("letrec-syntaxes+values", form, env, rec, drec); -} - -static Scheme_Object * -letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(env->observer); - - return do_letrec_syntaxes("letrec-syntaxes+values", form, env, erec, drec); -} - /*========================================================================*/ /* applications */ /*========================================================================*/ @@ -4141,34 +1540,23 @@ void scheme_finish_application(Scheme_App_Rec *app) } /*========================================================================*/ -/* compilation dispatcher */ +/* application */ /*========================================================================*/ static Scheme_Object * -inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, int start_app_position) +compile_list(Scheme_Object *form, + Scheme_Comp_Env *first_env, Scheme_Comp_Env *env, Scheme_Comp_Env *last_env, + int start_app_position) { int len; len = scheme_stx_proper_list_length(form); if (!len) { - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); return scheme_null; } else if (len > 0) { - Scheme_Compile_Info *recs, quick[5]; int i; - Scheme_Object *c, *p, *comp_first, *comp_last, *name, *first, *rest; - - name = env->value_name; - scheme_compile_rec_done_local(rec, drec); - - if (len <= 5) - recs = quick; - else - recs = MALLOC_N_ATOMIC(Scheme_Compile_Info, len); - scheme_init_compile_recs(rec, drec, recs, len); + Scheme_Object *c, *p, *comp_first, *comp_last, *first, *rest; comp_first = comp_last = NULL; @@ -4176,12 +1564,9 @@ inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, first = SCHEME_STX_CAR(rest); rest = SCHEME_STX_CDR(rest); - if (SCHEME_STX_NULLP(rest)) - env->value_name = name; - - c = compile_expand_expr(first, env, recs, i, - !i && start_app_position); - env->value_name = NULL; + c = compile_expr(first, + (!i ? first_env : ((i == (len-1)) ? last_env : env)), + !i && start_app_position); p = scheme_make_pair(c, scheme_null); if (comp_last) @@ -4191,13 +1576,10 @@ inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, comp_last = p; if (!i && start_app_position && (len == 2) - && SAME_OBJ(c, scheme_varref_const_p_proc)) { - recs[1].testing_constantness = 1; - } + && SAME_OBJ(c, scheme_varref_const_p_proc)) + last_env = scheme_set_comp_env_flags(last_env, COMP_ENV_CHECKING_CONSTANT); } - scheme_merge_compile_recs(rec, drec, recs, len); - return comp_first; } else { scheme_signal_error("internal error: compile-list on non-list"); @@ -4205,23 +1587,19 @@ inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, } } -static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *compile_plain_app(Scheme_Object *form, Scheme_Comp_Env *env) { Scheme_Object *result, *rator; int len; - form = scheme_stx_taint_disarm(form, NULL); - len = scheme_stx_proper_list_length(form); if (len < 0) - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, NULL); + scheme_wrong_syntax("application", NULL, form, NULL); - env->value_name = NULL; + env = scheme_set_comp_env_name(env, NULL); - scheme_compile_rec_done_local(rec, drec); - form = inner_compile_list(form, scheme_no_defines(env), rec, drec, 1); + form = compile_list(form, env, env, env, 1); result = scheme_make_application(form, NULL); @@ -4252,712 +1630,12 @@ static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env * return result; } -Scheme_Object *compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return inner_compile_list(form, env, rec, drec, 0); -} - -static Scheme_Object *adjust_for_other_context(Scheme_Object *form, Scheme_Object *var, Scheme_Comp_Env *env) -{ - /* Macro doesn't expand in this context. In a module-begin context, - just don't expand. If it's not an expression - context and expression context is ok, then wrap as an - expression. Otherwise, we just have to complain. */ - if (env->flags & SCHEME_MODULE_BEGIN_FRAME) { - /* wrap in `begin` to trigger `#%module-begin` wrapper */ - var = scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - var = scheme_make_pair(var, scheme_make_pair(form, scheme_null)); - form = scheme_datum_to_syntax(var, form, scheme_false, 0, 0); - } else if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(0))) { - /* expression is ok, so we must not be in an expression context */ - var = scheme_datum_to_syntax(expression_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - var = scheme_make_pair(var, scheme_make_pair(form, scheme_null)); - form = scheme_datum_to_syntax(var, form, scheme_false, 0, 0); - } else { - Scheme_Object *csym; - csym = scheme_frame_to_expansion_context_symbol(env->flags); - scheme_wrong_syntax(NULL, NULL, form, - "not allowed in context\n expansion context: %S", - csym); - return NULL; - } - - return form; -} - -static Scheme_Object *install_alt_from_rename(Scheme_Object *first, Scheme_Object *alt_first) -{ - if (alt_first) { - if (SCHEME_STX_PAIRP(first)) { - Scheme_Object *tail; - tail = scheme_stx_taint_disarm(first, NULL); - tail = SCHEME_STX_CDR(tail); - return scheme_datum_to_syntax(scheme_make_pair(alt_first, tail), - first, first, 0, 1); - } else - return alt_first; - } else - return first; -} - -Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, - Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object **current_val, - int keep_name) -{ - Scheme_Object *name, *val, *alt_first = NULL; - Scheme_Expand_Info erec1; - Scheme_Env *menv = NULL; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_CHECK(env->observer, first); - } - - while (1) { - *current_val = NULL; - - if (SCHEME_STX_PAIRP(first)) { - name = scheme_stx_taint_disarm(first, NULL); - name = SCHEME_STX_CAR(name); - } else { - name = first; - } - - if (!SCHEME_STX_SYMBOLP(name)) { - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first); - } - return first; - } - - while (1) { - val = scheme_compile_lookup(name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? SCHEME_OUT_OF_CONTEXT_OK - : 0) - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - NULL, NULL, - NULL); - - if (SCHEME_STX_PAIRP(first)) - *current_val = val; - - if (!val) { - first = install_alt_from_rename(first, alt_first); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first); - } - return first; - } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(val), - scheme_frame_to_expansion_context_symbol(env->flags))) { - if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(val), env); - if (!rec[drec].comp) - new_name = scheme_stx_track(new_name, name, name); - name = scheme_transfer_srcloc(new_name, name); - alt_first = name; - menv = NULL; - SCHEME_USE_FUEL(1); - } else { - alt_first = NULL; - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.depth = 1; - name = env->value_name; - if (!keep_name) - env->value_name = name; - first = scheme_expand_expr(first, env, &erec1, 0); - env->value_name = name; - break; /* break to outer loop */ - } - } else { - first = install_alt_from_rename(first, alt_first); - alt_first = NULL; - first = adjust_for_other_context(first, val, env); - break; /* break to outer loop */ - } - } else { - first = install_alt_from_rename(first, alt_first); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first); - } - return first; - } - } - } -} - -static Scheme_Object * -compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *macro, - Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int scope_macro_use) -{ - Scheme_Object *xformer, *boundname; - - xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro); - - if (scheme_is_set_transformer(xformer)) { - /* scheme_apply_macro unwraps it */ - } else { - if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) { - scheme_wrong_syntax(NULL, NULL, form, "illegal use of syntax"); - return NULL; - } - } - - boundname = env->value_name; - if (!boundname) - boundname = scheme_false; - - return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0, - scope_macro_use); - - /* caller expects rec[drec] to be used to compile the result... */ -} - -static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e) -{ - while (1) { - if (orig == e) - return 1; - if ((e && e->flags & SCHEME_FOR_STOPS) - || (!(e->flags & (~SCHEME_INTDEF_FRAME)) - && !e->num_bindings)) - e = e->next; - else - return 0; - } -} - -static Scheme_Object *compile_expand_expr_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; - Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return compile_expand_expr(form, - env, - rec, - p->ku.k.i3, - p->ku.k.i2); -} - -Scheme_Object * -compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position) -{ - Scheme_Object *name, *var, *stx, *normal, *can_recycle_stx = NULL, *orig_unbound_name = NULL; - Scheme_Env *menv = NULL; - GC_CAN_IGNORE char *not_allowed; - int has_orig_unbound = 0, need_macro_scope = 0; - - top: - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - Scheme_Compile_Expand_Info *recx; - - recx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); - - p->ku.k.p1 = (void *)form; - p->ku.k.p2 = (void *)env; - p->ku.k.p3 = (void *)recx; - p->ku.k.i3 = 0; - p->ku.k.i2 = app_position; - - var = scheme_handle_stack_overflow(compile_expand_expr_k); - - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - return var; - } - } -#endif - - DO_CHECK_FOR_BREAK(scheme_current_thread, ;); - - MZ_ASSERT(SCHEME_STXP(form)); - - if (rec[drec].comp) { - scheme_default_compile_rec(rec, drec); - } else { - SCHEME_EXPAND_OBSERVE_VISIT(env->observer,form); /* in "expand" branch */ - } - - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) { - var = SCHEME_STX_VAL(form); - if (scheme_stx_has_empty_wraps(form, scheme_env_phase(env->genv)) - && same_effective_env(SCHEME_PTR2_VAL(var), env)) { - /* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks. */ - form = scheme_stx_track(SCHEME_PTR1_VAL(var), form, NULL); - if (!rec[drec].comp) { - /* Already fully expanded. */ - SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(env->observer, form); - return form; - } - } else { - scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), - "expanded syntax not in its original lexical context" - " (extra bindings or scopes in the current context)"); - } - } - - if (SCHEME_STX_NULLP(form)) { - stx = app_symbol; - not_allowed = "function application"; - normal = app_expander; - } else if (!SCHEME_STX_PAIRP(form)) { - if (SCHEME_STX_SYMBOLP(form)) { - Scheme_Object *find_name = form, *inline_variant, *bind_id; - int protected = 0; - - while (1) { - inline_variant = NULL; - var = scheme_compile_lookup(find_name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_ENV_CONSTANTS_OK - + (rec[drec].comp - ? SCHEME_ELIM_CONST - : 0) - + (app_position - ? SCHEME_APP_POS - : 0) - + ((rec[drec].comp && rec[drec].dont_mark_local_use) ? - SCHEME_DONT_MARK_USE - : 0) - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, &protected, - &bind_id, &need_macro_scope, - &inline_variant); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer,find_name); - } - - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - protected = 0; - } else - break; - } else - break; - } - - if (!var) { - /* Top variable */ - stx = top_symbol; - if (env->genv->module) - not_allowed = "reference to an unbound identifier"; - else - not_allowed = "reference to a top-level identifier"; - normal = top_expander; - has_orig_unbound = 1; - form = find_name; /* in case it was re-mapped */ - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - if (var == stop_expander) { - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer,form); - SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer,form); - } - return form; - } else { - scheme_wrong_syntax(NULL, NULL, form, "bad syntax"); - return NULL; - } - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - name = form; - goto macro; - } - - if (rec[drec].comp) { - scheme_compile_rec_done_local(rec, drec); - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) { - if (scheme_extract_unsafe(var)) { - return scheme_extract_unsafe(var); - } else if (scheme_extract_flfxnum(var)) { - return scheme_extract_flfxnum(var); - } else if (scheme_extract_extfl(var)) { - return scheme_extract_extfl(var); - } else if (scheme_extract_futures(var)) { - return scheme_extract_futures(var); - } else if (scheme_extract_foreign(var)) { - return scheme_extract_foreign(var); - } - } - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) - return scheme_register_toplevel_in_prefix(var, env, rec, drec, - scheme_is_imported(var, env), - inline_variant); - else - return var; - } else { - SCHEME_EXPAND_OBSERVE_VARIABLE(env->observer, form, find_name); /* in "expand" branch */ - if (bind_id && rec[drec].substitute_bindings) - find_name = bind_id; - if (protected) { - /* Add a property to indicate that the name is protected */ - find_name = scheme_stx_property(find_name, protected_symbol, scheme_true); - } - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, find_name); /* in "expand" branch */ - return find_name; /* which is usually == form */ - } - } - } else { - /* A hack for handling lifted expressions. See compile_expand_lift_to_let. */ - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_already_comp_type)) { - form = SCHEME_STX_VAL(form); - return SCHEME_IPTR_VAL(form); - } - - stx = datum_symbol; - not_allowed = "literal data"; - normal = datum_expander; - } - } else { - name = scheme_stx_taint_disarm(form, NULL); - name = SCHEME_STX_CAR(name); - if (SCHEME_STX_SYMBOLP(name)) { - /* Check for macros: */ - Scheme_Object *find_name = name; - Scheme_Expand_Info erec1; - - /* While resolving name, we used to need taints from `form' */ - scheme_init_expand_recs(rec, drec, &erec1, 1); - - while (1) { - var = scheme_compile_lookup(find_name, env, - SCHEME_APP_POS - + SCHEME_NULL_FOR_UNBOUND - + SCHEME_ENV_CONSTANTS_OK - + (rec[drec].comp - ? SCHEME_ELIM_CONST - : 0) - + SCHEME_DONT_MARK_USE - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - NULL, &need_macro_scope, - NULL); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name); - } - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } else - break; - } - - if (!var) { - /* apply to global variable: compile it normally */ - orig_unbound_name = find_name; - has_orig_unbound = 1; - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { - /* apply to local variable: compile it normally */ - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - goto macro; - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - if (rec[drec].comp) { - Scheme_Syntax *f; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - return f(form, env, rec, drec); - } else { - Scheme_Syntax_Expander *f; - f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form); - form = f(form, env, rec, drec); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - return form; - } - } - - /* Else: unknown global - must be a function: compile as application */ - } - - if (!SAME_OBJ(name, find_name)) { - /* the rator position was mapped */ - Scheme_Object *code; - code = scheme_stx_taint_disarm(form, NULL); - code = SCHEME_STX_CDR(code); - code = scheme_make_pair(find_name, code); - form = scheme_datum_to_syntax(code, form, form, 0, 2); - } - } - - stx = app_symbol; - not_allowed = "function application"; - normal = app_expander; - } - - /* Compile/expand as application, datum, or top: */ - if (scheme_stx_is_tainted(form)) { - stx = scheme_datum_to_syntax(stx, form, form, 0, 1); - stx = scheme_stx_taint_rearm(stx, form); - } else if (quick_stx && rec[drec].comp) { - scheme_stx_set(quick_stx, stx, form); - stx = quick_stx; - quick_stx = NULL; - } else - stx = scheme_datum_to_syntax(stx, scheme_false, form, 0, 0); - - if (rec[drec].comp) - can_recycle_stx = stx; - - { - Scheme_Object *find_name = stx; - - while (1) { - var = scheme_compile_lookup(find_name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0) - + (!rec[drec].comp - ? SCHEME_STOP_AT_FREE_EQ - : 0), - env->in_modidx, - &menv, NULL, - NULL, &need_macro_scope, - NULL); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name); - } - - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - /* It's a rename. Look up the target name and try again. */ - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } else - break; - } - } - - if (!SAME_OBJ(var, normal)) { - /* Someone might keep the stx: */ - can_recycle_stx = NULL; - } - - if (var && (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type))) { - if (SAME_OBJ(var, stop_expander)) { - /* Return original: */ - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - } - return form; - } else if (rec[drec].comp && SAME_OBJ(var, normal) && !env->observer) { - /* Skip creation of intermediate form */ - Scheme_Syntax *f; - rec[drec].pre_unwrapped = 1; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - if (can_recycle_stx && !quick_stx) { - quick_stx = can_recycle_stx; - scheme_stx_set(quick_stx, NULL, NULL); - } - return f(form, env, rec, drec); - } else { - if (!rec[drec].comp - && (rec[drec].depth == -2) /* local-expand */ - && SAME_OBJ(var, normal) - && SAME_OBJ(SCHEME_STX_VAL(stx), top_symbol)) { - rec[drec].pre_unwrapped = 1; - } else { - name = scheme_stx_taint_disarm(form, NULL); - form = scheme_datum_to_syntax(scheme_make_pair(stx, name), form, form, 0, 2); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_TAG(env->observer, form); - } - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_primitive_syntax_type)) { - if (rec[drec].comp) { - Scheme_Syntax *f; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - return f(form, env, rec, drec); - } else { - Scheme_Syntax_Expander *f; - f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form); /* in "expand" branch */ - form = f(form, env, rec, drec); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - return form; - } - } else { - name = stx; - goto macro; - } - } - } else { - /* Not allowed this context! */ - char *phase, buf[30]; - if (env->genv->phase == 0) - phase = ""; - else if (env->genv->phase == 1) - phase = " in the transformer environment"; - else { - phase = buf; - sprintf(buf, " at phase %" PRIdPTR, env->genv->phase); - } - if (has_orig_unbound) { - scheme_wrong_syntax(scheme_compile_stx_string, - orig_unbound_name, form, - "unbound identifier%s;\n" - " also, no %S syntax transformer is bound%s", - phase, - SCHEME_STX_VAL(stx), - scheme_stx_describe_context(orig_unbound_name, - scheme_env_phase(env->genv), - 0)); - } else { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, form, - "%s is not allowed;\n" - " no %S syntax transformer is bound%s", - not_allowed, - SCHEME_STX_VAL(stx), - phase, - scheme_stx_describe_context(orig_unbound_name, - scheme_env_phase(env->genv), - 0)); - } - return NULL; - } - - macro: - if (!rec[drec].comp && !rec[drec].depth) { - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); - return form; /* We've gone as deep as requested */ - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_MACRO(env->observer, form); - } - if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), - scheme_frame_to_expansion_context_symbol(env->flags))) { - form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope); - - if (env->expand_result_adjust) { - Scheme_Expand_Result_Adjust_Proc adjust; - adjust = env->expand_result_adjust; - form = adjust(form, env->expand_result_adjust_arg); - } - } else - form = adjust_for_other_context(form, var, env); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_MACRO(env->observer, form); - } - - if (rec[drec].comp) - goto top; - else { - if (rec[drec].depth > 0) - --rec[drec].depth; - if (rec[drec].depth) - goto top; - else { - SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); /* in "expand" branch */ - return form; - } - } -} - -static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env) +static int arg_count(Scheme_Object *lam) { Scheme_Object *l, *id, *form = lam; int cnt = 0; DupCheckRecord r; - lam = scheme_stx_taint_disarm(lam, NULL); - lam = SCHEME_STX_CDR(lam); if (!SCHEME_STX_PAIRP(lam)) return -1; @@ -4968,13 +1646,12 @@ static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env) while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); } if (!SCHEME_STX_NULLP(lam)) return -1; - - scheme_begin_dup_symbol_check(&r, env); + scheme_begin_dup_symbol_check(&r); while (SCHEME_STX_PAIRP(l)) { id = SCHEME_STX_CAR(l); - scheme_check_identifier("lambda", id, NULL, env, form); + scheme_check_identifier("lambda", id, "argument", form); scheme_dup_symbol_check(&r, NULL, id, "argument", form); l = SCHEME_STX_CDR(l); cnt++; @@ -4984,62 +1661,29 @@ static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env) return cnt; } -static Scheme_Object * -compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) +static Scheme_Object *compile_app(Scheme_Object *orig_form, Scheme_Comp_Env *env) { - Scheme_Object *form, *naya, *forms, *orig_vname = env->value_name; - int tsc; + Scheme_Object *form, *forms, *orig_vname = env->value_name; - forms = scheme_stx_taint_disarm(orig_form, NULL); - - tsc = rec[drec].pre_unwrapped; - rec[drec].pre_unwrapped = 0; - - if (tsc) { - form = forms; - } else { - form = SCHEME_STX_CDR(forms); - form = scheme_datum_to_syntax(form, forms, forms, 0, 0); - } + forms = orig_form; + form = forms; if (SCHEME_STX_NULLP(form)) { /* Compile/expand empty application to null list: */ - if (rec[drec].comp) - return scheme_null; - else - return scheme_datum_to_syntax(icons(quote_symbol, - icons(form, scheme_null)), - orig_form, - scheme_sys_wraps(env), - 0, 2); + return scheme_null; } else if (!SCHEME_STX_PAIRP(form)) { /* will end in error */ - if (rec[drec].comp) - return compile_application(form, env, rec, drec); - else { - env->value_name = NULL; - naya = expand_list(form, scheme_no_defines(env), rec, drec); - /* naya will be prefixed and returned... */ - } - } else if (rec[drec].comp) { - Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form; + return compile_plain_app(form, env); + } else { + Scheme_Object *name, *origname, *orig_rest_form, *rest_form; name = SCHEME_STX_CAR(form); origname = name; - gval = env->value_name; - env->value_name = NULL; - - name = scheme_check_immediate_macro(name, env, rec, drec, &gval, 0); - - env->value_name = gval; - /* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */ - if (SAME_OBJ(gval, scheme_lambda_syntax)) { - Scheme_Object *argsnbody, *d_name; + if (SAME_OBJ(SCHEME_STX_SYM(name), lambda_symbol)) { + Scheme_Object *argsnbody; - d_name = scheme_stx_taint_disarm(name, NULL); - argsnbody = SCHEME_STX_CDR(d_name); + argsnbody = SCHEME_STX_CDR(name); if (SCHEME_STX_PAIRP(argsnbody)) { Scheme_Object *args, *body; @@ -5060,7 +1704,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, if ((pl < 0) || (al == pl)) { DupCheckRecord r; - scheme_begin_dup_symbol_check(&r, env); + scheme_begin_dup_symbol_check(&r); while (!SCHEME_STX_NULLP(args)) { Scheme_Object *v, *n; @@ -5069,14 +1713,13 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, n = args; else n = SCHEME_STX_CAR(args); - scheme_check_identifier("lambda", n, NULL, env, name); + scheme_check_identifier("lambda", n, NULL, name); /* If we don't check here, the error is in terms of `let': */ scheme_dup_symbol_check(&r, NULL, n, "argument", name); if (pl < 0) { v = scheme_intern_symbol("list"); - v = scheme_datum_to_syntax(v, scheme_false, scheme_sys_wraps(env), 0, 0); v = cons(v, rest); } else v = SCHEME_STX_CAR(rest); @@ -5095,29 +1738,15 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, rest = SCHEME_STX_CDR(rest); } } - - body = scheme_datum_to_syntax(icons(begin_symbol, body), form, - scheme_sys_wraps(env), - 0, 2); body = scheme_datum_to_syntax(cons(let_values_symbol, - cons(bindings, - cons(body, scheme_null))), - form, - scheme_sys_wraps(env), - 0, 2); + cons(bindings, body)), + form, + DTS_COPY_PROPS); - body = scheme_syntax_taint_rearm(body, orig_form); + env = scheme_set_comp_env_name(env, orig_vname); - env->value_name = orig_vname; - - return compile_expand_expr(body, env, rec, drec, 0); - } else { -#if 0 - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, - "procedure application: bad ((lambda (...) ...) ...) syntax"); - return NULL; -#endif + return compile_expr(body, env, 0); } } } @@ -5127,7 +1756,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, orig_rest_form = SCHEME_STX_CDR(form); /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ - if (SCHEME_STX_SYMBOLP(name)) { + if (SAME_OBJ(SCHEME_STX_SYM(name), call_with_values_symbol)) { Scheme_Object *at_first, *at_second, *the_end; at_first = SCHEME_STX_CDR(form); if (SCHEME_STX_PAIRP(at_first)) { @@ -5135,58 +1764,35 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, if (SCHEME_STX_PAIRP(at_second)) { the_end = SCHEME_STX_CDR(at_second); if (SCHEME_STX_NULLP(the_end)) { - Scheme_Object *orig_at_second = at_second; - - if (!cwv_stx || (env->genv->phase != cwv_stx_phase)) { - cwv_stx_phase = env->genv->phase; - cwv_stx = scheme_datum_to_syntax(call_with_values_symbol, - scheme_false, scheme_sys_wraps(env), 0, 0); - } - - if (scheme_stx_free_eq(name, cwv_stx, 0)) { - Scheme_Object *first, *orig_first; - orig_first = SCHEME_STX_CAR(at_first); - first = scheme_check_immediate_macro(orig_first, env, rec, drec, &gval, 0); - if (SAME_OBJ(gval, scheme_lambda_syntax) - && SCHEME_STX_PAIRP(first) - && (arg_count(first, env) == 0)) { - Scheme_Object *second, *orig_second; - orig_second = SCHEME_STX_CAR(at_second); - second = scheme_check_immediate_macro(orig_second, env, rec, drec, &gval, 0); - if (SAME_OBJ(gval, scheme_lambda_syntax) - && SCHEME_STX_PAIRP(second) - && (arg_count(second, env) >= 0)) { - Scheme_Object *lhs, *orig_post_first, *orig_post_second; - orig_post_first = first; - orig_post_second = second; - first = scheme_stx_taint_disarm(first, NULL); - second = scheme_stx_taint_disarm(second, NULL); - second = SCHEME_STX_CDR(second); - lhs = SCHEME_STX_CAR(second); - second = SCHEME_STX_CDR(second); - first = SCHEME_STX_CDR(first); - first = SCHEME_STX_CDR(first); - first = icons(begin_symbol, first); - first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1); - second = icons(begin_symbol, second); - second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1); - /* Convert to let-values: */ - name = icons(let_values_symbol, - icons(icons(icons(lhs, icons(first, scheme_null)), - scheme_null), - icons(second, scheme_null))); - form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2); - env->value_name = orig_vname; - return compile_expand_expr(form, env, rec, drec, 0); - } - if (!SAME_OBJ(second, orig_second)) { - at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2); - } - } - if (!SAME_OBJ(first, orig_first) - || !SAME_OBJ(at_second, orig_at_second)) { - at_first = scheme_datum_to_syntax(icons(first, at_second), at_first, at_first, 0, 2); - } + Scheme_Object *first; + first = SCHEME_STX_CAR(at_first); + if (SCHEME_STX_PAIRP(first) + && SAME_OBJ(SCHEME_STX_SYM(SCHEME_STX_CAR(first)), lambda_symbol) + && (arg_count(first) == 0)) { + Scheme_Object *second; + second = SCHEME_STX_CAR(at_second); + if (SCHEME_STX_PAIRP(second) + && SAME_OBJ(SCHEME_STX_SYM(SCHEME_STX_CAR(second)), lambda_symbol) + && (arg_count(second) >= 0)) { + Scheme_Object *lhs; + second = SCHEME_STX_CDR(second); + lhs = SCHEME_STX_CAR(second); + second = SCHEME_STX_CDR(second); + first = SCHEME_STX_CDR(first); + first = SCHEME_STX_CDR(first); + first = icons(begin_symbol, first); + first = scheme_datum_to_syntax(first, at_first, DTS_COPY_PROPS); + second = icons(begin_symbol, second); + second = scheme_datum_to_syntax(second, at_second, DTS_COPY_PROPS); + /* Convert to let-values: */ + name = icons(let_values_symbol, + icons(icons(icons(lhs, icons(first, scheme_null)), + scheme_null), + icons(second, scheme_null))); + form = scheme_datum_to_syntax(name, forms, DTS_COPY_PROPS); + env->value_name = orig_vname; + return compile_expr(form, env, 0); + } } } } @@ -5198,1023 +1804,407 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, if (NOT_SAME_OBJ(name, origname) || NOT_SAME_OBJ(rest_form, orig_rest_form)) { - form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, forms, 0, 2); + form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, DTS_COPY_PROPS); } - return compile_application(form, env, rec, drec); - } else { - env->value_name = NULL; - naya = expand_list(form, scheme_no_defines(env), rec, drec); - /* naya will be prefixed returned... */ - } - - if (SAME_OBJ(form, naya)) - return orig_form; - - /* Add #%app prefix back: */ - { - Scheme_Object *first; - - first = SCHEME_STX_CAR(forms); - return scheme_datum_to_syntax(scheme_make_pair(first, naya), orig_form, orig_form, 0, 2); + return compile_plain_app(form, env); } } -static Scheme_Object * -app_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +/*========================================================================*/ +/* expression compilation dispatcher */ +/*========================================================================*/ + +static Scheme_Object *compile_expr_k(void) { - return compile_expand_app(form, env, rec, drec); + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; + Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + return compile_expr(form, env, p->ku.k.i1); } -static Scheme_Object * -app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +Scheme_Object *compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, int app_position) { - SCHEME_EXPAND_OBSERVE_PRIM_APP(env->observer); - return compile_expand_app(form, env, erec, drec); -} - -static Scheme_Object * -datum_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *c, *v; - - if (rec[drec].pre_unwrapped) { - c = form; - rec[drec].pre_unwrapped = 0; - } else { - c = SCHEME_STX_CDR(form); - /* Need datum->syntax, in case c is a list: */ - c = scheme_datum_to_syntax(c, form, form, 0, 2); - } - - v = SCHEME_STX_VAL(c); - if (SCHEME_KEYWORDP(v)) { - scheme_wrong_syntax("#%datum", NULL, c, "keyword used as an expression"); - return NULL; - } - - return scheme_syntax_to_datum(c, 0, NULL); -} - -static Scheme_Object * -datum_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *rest, *v, *form; - - SCHEME_EXPAND_OBSERVE_PRIM_DATUM(env->observer); - - form = scheme_stx_taint_disarm(orig_form, NULL); - - rest = SCHEME_STX_CDR(form); - - v = SCHEME_STX_VAL(rest); - if (SCHEME_KEYWORDP(v)) { - scheme_wrong_syntax("#%datum", NULL, rest, "keyword used as an expression"); - return NULL; - } - - return scheme_datum_to_syntax(icons(quote_symbol, - icons(rest, scheme_null)), - orig_form, - scheme_sys_wraps(env), - 0, 2); -} - -int scheme_check_top_identifier_bound(Scheme_Object *c, Scheme_Env *genv, int disallow_unbound) -{ - Scheme_Object *symbol, *binding; - Scheme_Object *modidx; - int bad; - - binding = scheme_stx_lookup(c, scheme_make_integer(genv->phase)); - - if (SCHEME_VECTORP(binding)) { - modidx = SCHEME_VEC_ELS(binding)[0]; - if (SCHEME_FALSEP(modidx)) modidx = NULL; - symbol = SCHEME_VEC_ELS(binding)[1]; - if (modidx) { - /* If it's an access path, resolve it: */ - if (genv->module - && SAME_OBJ(scheme_module_resolve(modidx, 1), genv->module->modname)) - bad = 0; - else - bad = 1; - } else - bad = 1; - } else - bad = 1; - - if (disallow_unbound) { - if (bad || !scheme_lookup_in_table(genv->toplevel, (const char *)symbol)) { - GC_CAN_IGNORE const char *reason; - int need_phase = 0; - - if (genv->phase == 1) { - reason = "unbound identifier in module (in phase 1, transformer environment)%s"; - /* Check in the run-time environment */ - if (scheme_lookup_in_table(genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the run-time definition)%s"); - } else if (genv->template_env->syntax - && scheme_lookup_in_table(genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the macro definition that is visible to run-time expressions)%s"); - } - } else if (genv->phase == 0) - reason = "unbound identifier in module%s"; - else { - reason = "unbound identifier in module (in phase %d)%s"; - need_phase = 1; - } - - if (need_phase) - scheme_unbound_syntax(scheme_expand_stx_string, NULL, c, reason, genv->phase, - scheme_stx_describe_context(c, scheme_env_phase(genv), 0)); - else - scheme_unbound_syntax(scheme_expand_stx_string, NULL, c, reason, - scheme_stx_describe_context(c, scheme_env_phase(genv), 0)); - } - } - - return !bad; -} - -static Scheme_Object *check_top(Scheme_Object *orig_form, - Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, - int *_need_bound_check) -{ - Scheme_Object *c, *form; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (rec[drec].pre_unwrapped) { - c = form; - rec[drec].pre_unwrapped = 0; - } else - c = SCHEME_STX_CDR(form); - - if (!SCHEME_STX_SYMBOLP(c)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - - if (env->genv->module) { - int bad; - bad = !scheme_check_top_identifier_bound(c, env->genv, env->genv->disallow_unbound > 0); - if (_need_bound_check) - *_need_bound_check = bad; - } - - return c; -} - -static Scheme_Object * -top_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *c, *b; - int need_bound_check = 0; - - c = check_top(form, env, rec, drec, &need_bound_check); - - if (need_bound_check) - scheme_register_unbound_toplevel(env, c); - - b = scheme_stx_lookup(c, scheme_make_integer(env->genv->phase)); - if (SCHEME_VECTORP(b)) - c = SCHEME_VEC_ELS(b)[1]; - else - c = scheme_future_global_binding(c, env->genv); - - if (env->genv->module && !rec[drec].resolve_module_ids) { - /* Self-reference in a module; need to remember the modidx. Don't - need a pos, because the symbol's gensym-ness (if any) will be - preserved within the module. */ - c = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, - c, env->genv->module->insp, - -1, env->genv->mod_phase, 0, - NULL); - } else { - c = (Scheme_Object *)scheme_global_bucket(c, env->genv); - } - - return scheme_register_toplevel_in_prefix(c, env, rec, drec, 0, NULL); -} - -static Scheme_Object * -top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *c; - int need_bound_check = 0; - - SCHEME_EXPAND_OBSERVE_PRIM_TOP(env->observer); - c = check_top(form, env, erec, drec, &need_bound_check); - - if (env->genv->module) - return c; /* strip `#%top' prefix */ - - return form; -} - -Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_expr(form, env, rec, drec, 0); -} - -Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_expr(form, env, erec, drec, 0); -} - -Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) -{ - Scheme_Comp_Env **ip = (Scheme_Comp_Env **)_ip, *naya; - Scheme_Object *ids, *id; - int pos; - - /* We don't add a scope for this frame, because the lifted identifier - already has a scope. */ - - pos = scheme_list_length(*_ids); - naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, NULL, (*ip)->next); - (*ip)->next = naya; - *ip = naya; - - for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - scheme_add_compilation_binding(--pos, id, naya); - } - - return icons(*_ids, icons(expr, scheme_null)); -} - -Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, - Scheme_Object *orig_form, int comp) -{ - Scheme_Object *revl, *reve, *a; - - if (SCHEME_NULLP(l)) return obj; - - revl = scheme_reverse(l); - - reve = NULL; - if (comp) { - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - reve = scheme_make_raw_pair((Scheme_Object *)env, reve); - env = env->next; - } - } - - for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) { - a = SCHEME_CAR(revl); - if (comp) { - /* propagate previously generated variables for re-compile */ - a = scheme_datum_to_syntax(a, scheme_false, scheme_false, 0, 0); - env = (Scheme_Comp_Env *)SCHEME_CAR(reve); - reve = SCHEME_CDR(reve); - MZ_ASSERT(env->flags & SCHEME_CAPTURE_LIFTED); - if (env->vars) - a = scheme_stx_property(a, existing_variables_symbol, - scheme_make_raw_pair(scheme_make_integer(env->num_bindings), - (Scheme_Object *)env->vars)); - } - obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - icons(icons(a, scheme_null), - icons(obj, scheme_null))); - } - - obj = scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0); - - return obj; -} - -static Scheme_Object *compile_expand_expr_lift_to_let_k(void); - -static Scheme_Object * -compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *rec, int drec) -{ - Scheme_Expand_Info recs[2]; - Scheme_Object *l, *orig_form = form, *context_key; - Scheme_Comp_Env *inserted, **ip; - #ifdef DO_STACK_CHECK { # include "mzstkchk.h" { Scheme_Thread *p = scheme_current_thread; - Scheme_Compile_Expand_Info *recx; - - recx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); p->ku.k.p1 = (void *)form; p->ku.k.p2 = (void *)env; - p->ku.k.p3 = (void *)recx; + p->ku.k.i1 = app_position; - form = scheme_handle_stack_overflow(compile_expand_expr_lift_to_let_k); - - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - return form; + return scheme_handle_stack_overflow(compile_expr_k); } } #endif - inserted = scheme_new_compilation_frame(0, 0, NULL, env); + DO_CHECK_FOR_BREAK(scheme_current_thread, ;); - ip = MALLOC_N(Scheme_Comp_Env *, 1); - *ip = inserted; - - context_key = scheme_generate_lifts_key(); - - scheme_frame_captures_lifts(inserted, scheme_pair_lifted, (Scheme_Object *)ip, scheme_false, - context_key, NULL, scheme_false, scheme_false); - - if (rec[drec].comp) { - scheme_init_compile_recs(rec, drec, recs, 2); - form = scheme_compile_expr(form, inserted, recs, 0); + if (!SCHEME_STX_PAIRP(form)) { + Scheme_Object *val = SCHEME_STX_SYM(form); + if (SCHEME_SYMBOLP(val)) + return scheme_compile_lookup(form, env, (app_position ? SCHEME_APP_POS : 0)); + else if (SCHEME_NUMBERP(val) + || SCHEME_CHAR_STRINGP(val) + || SCHEME_BYTE_STRINGP(val) + || SAME_OBJ(val, scheme_true) + || SAME_OBJ(val, scheme_false)) + return val; + else + scheme_wrong_syntax("compile", form, NULL, "unrecognized form"); } else { - scheme_init_expand_recs(rec, drec, recs, 2); - form = scheme_expand_expr(form, inserted, recs, 0); - } - - l = scheme_frame_get_lifts(inserted); - if (SCHEME_NULLP(l)) { - /* No lifts */ - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, recs, 1); - return form; - } else { - /* We have lifts, so add let* wrapper and go again */ - Scheme_Object *o; - if (rec[drec].comp) { - /* Wrap compiled part so the compiler recognizes it later: */ - o = scheme_alloc_object(); - o->type = scheme_already_comp_type; - SCHEME_IPTR_VAL(o) = form; - } else - o = form; - form = scheme_add_lifts_as_let(o, l, inserted->next, orig_form, rec[drec].comp); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(env->observer, form); + Scheme_Object *name = SCHEME_STX_CAR(form); + if (SCHEME_STX_SYMBOLP(name)) { + /* check for primitive expression forms */ + name = SCHEME_STX_SYM(name); + if (SAME_OBJ(name, quote_symbol)) + return quote_compile(form, env); + else if (SAME_OBJ(name, let_values_symbol)) + return let_values_compile(form, env); + else if (SAME_OBJ(name, letrec_values_symbol)) + return letrec_values_compile(form, env); + else if (SAME_OBJ(name, lambda_symbol)) + return lambda_compile(form, env); + else if (SAME_OBJ(name, case_lambda_symbol)) + return case_lambda_compile(form, env); + else if (SAME_OBJ(name, set_symbol)) + return set_compile(form, env); + else if (SAME_OBJ(name, if_symbol)) + return if_compile(form, env); + else if (SAME_OBJ(name, begin_symbol)) + return begin_compile(form, env); + else if (SAME_OBJ(name, begin0_symbol)) + return begin0_compile(form, env); + else if (SAME_OBJ(name, with_cont_mark_symbol)) + return with_cont_mark_compile(form, env); + else if (SAME_OBJ(name, ref_symbol)) + return ref_compile(form, env); + else if (SAME_OBJ(name, ref_symbol)) + return ref_compile(form, env); } - form = compile_expand_expr_lift_to_let(form, env, recs, 1); - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, recs, 2); - return form; } + + return compile_app(form, env); } -static Scheme_Object *compile_expand_expr_lift_to_let_k(void) +/*========================================================================*/ +/* linklet compilation */ +/*========================================================================*/ + +static int is_define_values(Scheme_Object *form) { - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; - Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; + Scheme_Object *rest; + + if (!SCHEME_STX_PAIRP(form)) + return 0; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; + rest = SCHEME_STX_CAR(form); + if (!SAME_OBJ(SCHEME_STX_SYM(rest), define_values_symbol)) + return 0; - return compile_expand_expr_lift_to_let(form, env, rec, 0); + return 1; } -Scheme_Object * -scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *define_parse(Scheme_Object *form, + Scheme_Object **_vars, Scheme_Object **_val, + Scheme_Comp_Env **_env, + DupCheckRecord *r, + int *_extra_vars_pos) { - return compile_expand_expr_lift_to_let(form, env, rec, drec); + Scheme_Object *vars, *rest, *name, *v, *extra_vars = scheme_null; + Scheme_Comp_Env *env; + int len; + + len = check_form(form, form); + if (len != 3) + bad_form(form, len); + + rest = SCHEME_STX_CDR(form); + vars = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); + *_val = SCHEME_STX_CAR(rest); + + *_vars = vars; + + while (SCHEME_STX_PAIRP(vars)) { + name = SCHEME_STX_CAR(vars); + scheme_check_identifier(NULL, name, NULL, form); + + vars = SCHEME_STX_CDR(vars); + + scheme_dup_symbol_check(r, NULL, name, "binding", form); + + v = scheme_compile_lookup(name, *_env, SCHEME_NULL_FOR_UNBOUND); + if (v && (!SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type) + || ((Scheme_IR_Toplevel *)v)->instance_pos != -1)) + scheme_wrong_syntax(NULL, name, form, "not a definable variable"); + + if (!v) { + v = (Scheme_Object *)scheme_make_ir_toplevel(-1, *_extra_vars_pos, 0); + env = scheme_extend_comp_env(*_env, name, v, 1, 0); + *_env = env; + extra_vars = scheme_make_pair(name, extra_vars); + (*_extra_vars_pos)++; + } + } + + if (!SCHEME_STX_NULLP(vars)) + scheme_wrong_syntax(NULL, vars, form, "bad variable list"); + + return extra_vars; } -Scheme_Object * -scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) +static void check_import_export_clause(Scheme_Object *e, Scheme_Object *orig_form) { - return compile_expand_expr_lift_to_let(form, env, erec, drec); + if (SCHEME_STX_SYMBOLP(e)) + return; + + if (SCHEME_STX_PAIRP(e)) { + if (SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(e))) { + e = SCHEME_STX_CDR(e); + if (SCHEME_STX_PAIRP(e)) { + if (SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(e))) { + e = SCHEME_STX_CDR(e); + if (SCHEME_STX_NULLP(e)) + return; + } + } + } + } + + scheme_wrong_syntax(NULL, e, orig_form, "bad import/export clause"); } -static Scheme_Object *beginify(Scheme_Comp_Env *env, Scheme_Object *lst) +Scheme_Object *extract_source_name(Scheme_Object *e) { - return scheme_datum_to_syntax(scheme_make_pair(begin_symbol, lst), - lst, - scheme_sys_wraps(env), - 0, 0); + Scheme_Object *a; + + a = scheme_stx_property(e, source_name_symbol, NULL); + if (!a || !SCHEME_SYMBOLP(a)) + a = SCHEME_STX_SYM(e); + + return a; } -static Scheme_Object *add_scope_at_arbitrary_phase(Scheme_Object *stx, Scheme_Object *rib) +Scheme_Linklet *scheme_compile_linklet(Scheme_Object *form, int set_undef, Scheme_Object *import_keys) { - return scheme_stx_add_scope(stx, rib, scheme_make_integer(0)); -} - -static Scheme_Object * -compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int mixed) -/* This ugly code parses a block of code, transforming embedded - define-values and define-syntax into letrec and letrec-syntax. - It is espcailly ugly because we have to expand macros - before deciding what we have. */ -{ - Scheme_Object *first, *orig = forms, *pre_exprs = scheme_null, *old, *orig_vname = env->value_name; - Scheme_Object *rib, *ectx, *frame_scopes; - Scheme_Compile_Info recs[2]; + Scheme_Linklet *linklet; + Scheme_Object *orig_form = form, *imports, *exports; + Scheme_Object *defn_syms, *a, *e, *extra_vars, *vec, *v; + Scheme_Object *import_syms, *import_symss, *bodies, *all_extra_vars; + Scheme_Hash_Tree *source_names, *also_used_names; + Scheme_IR_Toplevel *tl; + int body_len, len, islen, i, j, extra_vars_pos; + Scheme_Comp_Env *env, *d_env; DupCheckRecord r; - if (rec[drec].comp) { - scheme_default_compile_rec(rec, drec); - } else { - SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(env->observer, forms); - } - - if (SCHEME_STX_NULLP(forms)) { - if (rec[drec].comp) { - scheme_compile_rec_done_local(rec, drec); - return scheme_null; - } else { - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(env->observer, forms); - SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, forms); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, forms); - return forms; - } - } - - rib = scheme_new_scope(SCHEME_STX_INTDEF_SCOPE); - ectx = scheme_make_pair(scheme_make_struct_instance(scheme_liberal_def_ctx_type, 0, NULL), - scheme_null); - - scheme_begin_dup_symbol_check(&r, env); - - frame_scopes = scheme_make_frame_scopes(rib); - - env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, - frame_scopes, - env); - env->intdef_name = ectx; - - env->expand_result_adjust = add_scope_at_arbitrary_phase; - env->expand_result_adjust_arg = rib; - - forms = scheme_datum_to_syntax(forms, scheme_false, scheme_false, 0, 0); - - old = forms; - forms = add_scope_at_arbitrary_phase(forms, rib); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(env->observer, forms, old); - } - - try_again: - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - - if (!SCHEME_STX_PAIRP(forms)) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, forms), "bad syntax"); - return NULL; - } - - first = SCHEME_STX_CAR(forms); - - { - Scheme_Object *gval, *result; - int more = 1, is_last; - - is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(forms)); - if (is_last) - env->value_name = orig_vname; - - result = forms; - - /* Check for macro expansion, which could mask the real - define-values, define-syntax, etc.: */ - first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last); - - if (is_last) - env->value_name = NULL; - - if (SAME_OBJ(gval, scheme_begin_syntax)) { - /* Inline content */ - Scheme_Object *orig_forms = forms; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer); - } - - /* FIXME: Redundant with check done by scheme_flatten_begin below? */ - if (scheme_stx_proper_list_length(first) < 0) - scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, - IMPROPER_LIST_FORM); - - forms = SCHEME_STX_CDR(forms); - - if (SCHEME_STX_NULLP(forms)) { - /* A `begin' that ends the block. An `inferred-name' property - attached to this begin should apply to the ultimate last - thing in the block. */ - Scheme_Object *v; - v = scheme_check_name_property(first, env->value_name); - env->value_name = v; - } - - forms = scheme_flatten_begin(first, forms); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_SPLICE(env->observer, forms); - } - - if (SCHEME_STX_NULLP(forms)) { - if (!SCHEME_PAIRP(pre_exprs)) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, - "empty form is not allowed"); - return NULL; - } else { - /* fall through to handle expressions without definitions */ - } - } else { - forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); - - goto try_again; - } - - forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); - } else if (SAME_OBJ(gval, scheme_define_values_syntax) - || SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { - /* Turn defines into a letrec: */ - Scheme_Object *var, *vars, *v, *link; - Scheme_Object *l = scheme_null, *start = NULL; - Scheme_Object *stx_l = scheme_null, *stx_start = NULL; - int is_val; - - while (1) { - int cnt; - - if (!SCHEME_NULLP(pre_exprs)) { - Scheme_Object *begin_stx, *values_app_stx; - - pre_exprs = scheme_reverse(pre_exprs); - - begin_stx = scheme_datum_to_syntax(begin_symbol, - scheme_false, - scheme_sys_wraps(env), - 0, 0); - values_app_stx = scheme_datum_to_syntax(scheme_make_pair(values_symbol, scheme_null), - scheme_false, - scheme_sys_wraps(env), - 0, 0); - - while (SCHEME_PAIRP(pre_exprs)) { - v = scheme_make_pair(scheme_null, - scheme_make_pair(scheme_make_pair(begin_stx, - scheme_make_pair(SCHEME_CAR(pre_exprs), - scheme_make_pair(values_app_stx, - scheme_null))), - scheme_null)); - v = scheme_datum_to_syntax(v, SCHEME_CAR(pre_exprs), SCHEME_CAR(pre_exprs), 0, 0); - - link = scheme_make_pair(v, scheme_null); - if (!start) - start = link; - else - SCHEME_CDR(l) = link; - l = link; - - pre_exprs = SCHEME_CDR(pre_exprs); - } - } - - is_val = SAME_OBJ(gval, scheme_define_values_syntax); - - v = SCHEME_STX_CDR(first); - - if (!rec[drec].comp) { - if (is_val) { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(env->observer); - } else { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(env->observer); - } - } - - if (!SCHEME_STX_PAIRP(v)) - scheme_wrong_syntax(NULL, NULL, first, - IMPROPER_LIST_FORM); - - var = NULL; - vars = SCHEME_STX_CAR(v); - cnt = 0; - while (SCHEME_STX_PAIRP(vars)) { - var = SCHEME_STX_CAR(vars); - if (!SCHEME_STX_SYMBOLP(var)) - scheme_wrong_syntax(NULL, var, first, - "name must be an identifier"); - /* scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); */ - vars = SCHEME_STX_CDR(vars); - cnt++; - } - if (!SCHEME_STX_NULLP(vars)) { - vars = SCHEME_STX_CAR(v); - scheme_wrong_syntax(NULL, vars, first, - "not a sequence of identifiers"); - } - - /* Preserve properties and track at the clause level: */ - v = scheme_datum_to_syntax(v, first, first, 0, 0); - var = SCHEME_STX_CAR(first); - v = scheme_stx_track(v, first, var); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer,v); - } - - link = scheme_make_pair(v, scheme_null); - if (is_val) { - if (!start) - start = link; - else - SCHEME_CDR(l) = link; - l = link; - } else { - if (!stx_start) - stx_start = link; - else - SCHEME_CDR(stx_l) = link; - stx_l = link; - } - - result = SCHEME_STX_CDR(result); - if (!SCHEME_STX_NULLP(result) && !SCHEME_STX_PAIRP(result)) - scheme_wrong_syntax(NULL, NULL, first, NULL); - - { - /* Execute internal macro definition and register non-macros */ - Scheme_Comp_Env *new_env; - Scheme_Object *names, *expr, *l, *a; - int pos; - - new_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, NULL, env); - new_env->intdef_name = ectx; - - names = SCHEME_STX_CAR(v); - expr = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(expr)) { - if (SCHEME_STX_NULLP(expr)) - scheme_wrong_syntax(NULL, NULL, first, - "missing expression"); - else - scheme_wrong_syntax(NULL, NULL, first, - IMPROPER_LIST_FORM); - } - link = SCHEME_STX_CDR(expr); - if (!SCHEME_STX_NULLP(link)) { - scheme_wrong_syntax(NULL, NULL, first, - "extra data after expression"); - } - expr = SCHEME_STX_CAR(expr); - - scheme_add_local_syntax(cnt, new_env); - - names = scheme_revert_use_site_scopes(names, env); - - /* Initialize environment slots to #f, which means "not syntax". */ - cnt = 0; - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - scheme_set_local_syntax(cnt++, a, scheme_false, new_env, 0); - } - - /* Check for duplicates: */ - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - scheme_dup_symbol_check(&r, "internal definition", a, "binding", first); - } - - if (!is_val) { - /* Evaluate and bind syntaxes */ - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer); - } - scheme_prepare_exp_env(new_env->genv); - scheme_prepare_compile_env(new_env->genv->exp_env); - pos = 0; - scheme_bind_syntaxes("local syntax definition", - names, expr, - new_env->genv->exp_env, new_env->insp, - rec, drec, new_env->observer, - new_env, new_env, - &pos, rib, 1); - } - - /* Remember extended environment */ - env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, frame_scopes, new_env); - env->intdef_name = ectx; - env->expand_result_adjust = add_scope_at_arbitrary_phase; - env->expand_result_adjust_arg = rib; - } - - define_try_again: - if (!SCHEME_STX_NULLP(result)) { - first = SCHEME_STX_CAR(result); - first = scheme_datum_to_syntax(first, forms, forms, 0, 0); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - } - is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(result)); - if (is_last) - env->value_name = orig_vname; - first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last); - if (is_last) - env->value_name = NULL; - more = 1; - if (NOT_SAME_OBJ(gval, scheme_define_values_syntax) - && NOT_SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { - if (SAME_OBJ(gval, scheme_begin_syntax)) { - /* Inline content */ - result = SCHEME_STX_CDR(result); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer); - } - result = scheme_flatten_begin(first, result); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_SPLICE(env->observer,result); - } - goto define_try_again; - } else if (mixed) { - /* accumulate expr for either sequence after definitions - or made-up empty bindings before the next definition */ - pre_exprs = scheme_make_pair(first, pre_exprs); - result = SCHEME_STX_CDR(result); - goto define_try_again; - } else { - /* Keep partially expanded `first': */ - result = SCHEME_STX_CDR(result); - result = scheme_make_pair(first, result); - break; - } - } - } else - break; - } - - if (SCHEME_STX_PAIRP(result) || SCHEME_PAIRP(pre_exprs)) { - if (!start) - start = scheme_null; - - if (SCHEME_PAIRP(pre_exprs)) - result = scheme_reverse(pre_exprs); /* from mixed mode */ - - if (!mixed) { - result = scheme_make_pair(scheme_make_pair(scheme_intern_symbol("#%stratified-body"), - result), - scheme_null); - } - - if (stx_start || (mixed && !rec[drec].comp && (rec[drec].depth != -1))) { - result = scheme_make_pair(letrec_syntaxes_symbol, - scheme_make_pair((stx_start ? stx_start : scheme_null), - scheme_make_pair(start, result))); - } else { - result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result)); - } - result = scheme_datum_to_syntax(result, forms, scheme_sys_wraps(env), 0, 2); - - more = 0; - } else { - /* Empty body: illegal. */ - scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, orig), - "no expression after a sequence of internal definitions"); - } - } else if (mixed) { - /* accumulate expr for either an expr-only sequence or made-up - empty bindings before a definition that appears later */ - pre_exprs = scheme_make_pair(first, pre_exprs); - first = SCHEME_STX_CDR(forms); - forms = scheme_datum_to_syntax(first, forms, forms, 0, 0); - if (SCHEME_STX_NULLP(forms)) { - /* fall through to handle expressions without definitions */ - } else { - goto try_again; - } - } else { - /* fall through to handle just expressions in non-mixed mode */ - } - - if (!more) { - /* We've converted to a letrec or letrec-values+syntaxes */ - rec[drec].env_already = (mixed ? 2 : 1); - - if (rec[drec].comp) { - env = scheme_no_defines(env); - env->value_name = orig_vname; - result = scheme_compile_expr(result, env, rec, drec); - return scheme_make_pair(result, scheme_null); - } else { - if (!mixed && ((rec[drec].depth == -2) || (rec[drec].depth > 0))) { - if (SAME_OBJ(letrec_syntaxes_symbol, SCHEME_STX_VAL(SCHEME_CAR(SCHEME_STX_VAL(result))))) - result = force_traditional_letrec(result, env); - } - if (rec[drec].depth > 0) - --rec[drec].depth; - if (rec[drec].depth) { - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(env->observer, - scheme_make_pair(result, scheme_null)); - } - env = scheme_no_defines(env); - env->value_name = orig_vname; - result = scheme_expand_expr(result, env, rec, drec); - } - result = scheme_make_pair(result, scheme_null); - return scheme_datum_to_syntax(result, forms, forms, 0, 0); - } - } - } - - if (SCHEME_PAIRP(pre_exprs)) - pre_exprs = scheme_reverse(pre_exprs); - - env = scheme_no_defines(env); - - if (rec[drec].comp) { - Scheme_Object *rest; - - scheme_compile_rec_done_local(rec, drec); - scheme_init_compile_recs(rec, drec, recs, 2); - - if (SCHEME_NULLP(pre_exprs)) - rest = SCHEME_STX_CDR(forms); - else { - first = SCHEME_CAR(pre_exprs); - rest = SCHEME_CDR(pre_exprs); - } - - rest = scheme_datum_to_syntax(rest, orig, orig, 0, 0); - - if (SCHEME_STX_NULLP(rest)) - env->value_name = orig_vname; - else - env->value_name = NULL; - - first = scheme_compile_expr(first, env, recs, 0); - - if (!SCHEME_STX_NULLP(rest)) - env->value_name = orig_vname; - else - env->value_name = NULL; - - forms = compile_list(rest, env, recs, 1); - - scheme_merge_compile_recs(rec, drec, recs, 2); - return scheme_make_pair(first, forms); - } else { - Scheme_Object *newforms; - - scheme_init_expand_recs(rec, drec, recs, 2); - - if (SCHEME_PAIRP(pre_exprs)) - newforms = pre_exprs; - else { - newforms = SCHEME_STX_CDR(forms); - newforms = scheme_make_pair(first, newforms); - } - - forms = scheme_datum_to_syntax(newforms, orig, orig, 0, -1); - - if (scheme_stx_proper_list_length(forms) < 0) - scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, forms), "bad syntax"); - - env->value_name = orig_vname; - - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(env->observer, forms); /* in "expand" branch */ - forms = expand_list(forms, env, recs, 0); - return forms; - } -} - -static Scheme_Object * -compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_block(forms, env, rec, drec, 1); -} - -static Scheme_Object * -expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_block(forms, env, erec, drec, 1); -} - -static Scheme_Object * -compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_block(forms, env, rec, drec, 0); -} - -static Scheme_Object * -expand_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_block(forms, env, erec, drec, 0); -} - -static Scheme_Object *expand_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *first = NULL, *last = NULL, *fm, *vname; - - SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, form); - - if (SCHEME_STX_NULLP(form)) { - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form); - return scheme_null; - } - - if (scheme_stx_proper_list_length(form) < 0) { - /* This is already checked for anything but application */ - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, - IMPROPER_LIST_FORM); - } - - fm = form; - vname = env->value_name; - while (SCHEME_STX_PAIRP(fm)) { - Scheme_Object *r, *p; - Scheme_Expand_Info erec1; - - SCHEME_EXPAND_OBSERVE_NEXT(env->observer); - - p = SCHEME_STX_CDR(fm); - - scheme_init_expand_recs(erec, drec, &erec1, 1); - env->value_name = (SCHEME_STX_NULLP(p) ? vname : NULL); - - r = SCHEME_STX_CAR(fm); - r = scheme_expand_expr(r, env, &erec1, 0); - p = scheme_make_pair(r, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - - env->value_name = NULL; - - fm = SCHEME_STX_CDR(fm); - } - - form = scheme_datum_to_syntax(first, form, form, 0, 0); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form); - return form; -} - - -Scheme_Object * -scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto) -{ - Scheme_Object *l, *ll, *a, *name, *body; + body_len = check_form(form, form); + if (body_len < 3) + bad_form(form, body_len); + + linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + linklet->so.type = scheme_linklet_type; + + env = scheme_new_comp_env(linklet, set_undef ? COMP_ENV_ALLOW_SET_UNDEFINED : 0); + + form = SCHEME_STX_CDR(form); + imports = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + exports = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + body_len -= 3; + + /* Parse imports, filling in `ilens` and `import_syms`, and also + extending `env`. */ + islen = scheme_stx_proper_list_length(imports); + if (islen < 0) + scheme_wrong_syntax(NULL, imports, orig_form, IMPROPER_LIST_FORM); + + if (import_keys && (SCHEME_VEC_SIZE(import_keys) != islen)) + scheme_contract_error("compile-linklet", + "import count of linklet form does not match given number of import keys", + "linklet", 1, linklet, + "linklet form imports", 1, scheme_make_integer(islen), + "given keys", 1, scheme_make_integer(SCHEME_VEC_SIZE(import_keys)), + NULL); - if (scheme_stx_proper_list_length(expr) < 0) - scheme_wrong_syntax(NULL, NULL, expr, IMPROPER_LIST_FORM); + import_symss = scheme_make_vector(islen, scheme_false); - name = SCHEME_STX_CAR(expr); - body = SCHEME_STX_CDR(expr); + for (i = 0; i < islen; i++, imports = SCHEME_STX_CDR(imports)) { + a = SCHEME_STX_CAR(imports); + len = scheme_stx_proper_list_length(a); + + import_syms = scheme_make_vector(len, NULL); + SCHEME_VEC_ELS(import_symss)[i] = import_syms; - /* Extract body of `begin' and add tracking information */ - l = scheme_copy_list(scheme_flatten_syntax_list(body, NULL)); - for (ll = l; !SCHEME_NULLP(ll); ll = SCHEME_CDR(ll)) { - a = SCHEME_CAR(ll); - a = scheme_stx_track(a, expr, name); - SCHEME_CAR(ll) = a; + for (j = 0; j < len; j++, a = SCHEME_STX_CDR(a)) { + e = SCHEME_STX_CAR(a); + check_import_export_clause(e, orig_form); + if (SCHEME_STX_SYMBOLP(e)) { + SCHEME_VEC_ELS(import_syms)[j] = SCHEME_STX_SYM(e); + } else { + SCHEME_VEC_ELS(import_syms)[j] = SCHEME_STX_SYM(SCHEME_STX_CAR(e)); + e = SCHEME_STX_CADR(e); + } + tl = scheme_make_ir_toplevel(i, j, SCHEME_TOPLEVEL_READY); + env = scheme_extend_comp_env(env, e, (Scheme_Object *)tl, 1, 1); + if (!env) + scheme_wrong_syntax("linklet", e, NULL, "duplicate import"); + } + + linklet->num_total_imports += len; } + + /* Parse exports, filling in `defn_syms` and extending `env`. */ + len = scheme_stx_proper_list_length(exports); + if (len < 0) + scheme_wrong_syntax(NULL, exports, orig_form, IMPROPER_LIST_FORM); + + linklet->num_exports = len; + + scheme_begin_dup_symbol_check(&r); + + defn_syms = scheme_make_vector(len, NULL); + source_names = scheme_make_hash_tree(0); + also_used_names = scheme_make_hash_tree(0); + + for (j = 0; j < len; j++, exports = SCHEME_STX_CDR(exports)) { + e = SCHEME_STX_CAR(exports); + check_import_export_clause(e, orig_form); + if (SCHEME_STX_SYMBOLP(e)) { + SCHEME_VEC_ELS(defn_syms)[j] = SCHEME_STX_SYM(e); + } else { + SCHEME_VEC_ELS(defn_syms)[j] = SCHEME_STX_SYM(SCHEME_STX_CADR(e)); + e = SCHEME_STX_CAR(e); + } + a = extract_source_name(e); + if (scheme_hash_tree_get(source_names, a) || scheme_hash_tree_get(also_used_names, a)) { + scheme_wrong_syntax("linklet", a, NULL, "duplicate export"); + } + if (!SAME_OBJ(a, SCHEME_VEC_ELS(defn_syms)[j])) + source_names = scheme_hash_tree_set(source_names, SCHEME_VEC_ELS(defn_syms)[j], a); + else + also_used_names = scheme_hash_tree_set(also_used_names, a, scheme_true); + tl = scheme_make_ir_toplevel(-1, j, 0); + env = scheme_extend_comp_env(env, e, (Scheme_Object *)tl, 1, 1); + if (!env) + scheme_wrong_syntax("linklet", e, NULL, "export duplicates import"); + } + + /* Looks for `define-values` forms to detect variables that are defined but + not exported */ + extra_vars_pos = len; + all_extra_vars = scheme_null; - return scheme_append(l, append_onto); + for (i = 0, a = form; i < body_len; i++, a = SCHEME_STX_CDR(a)) { + e = SCHEME_STX_CAR(a); + if (is_define_values(e)) { + Scheme_Object *vars, *vals; + extra_vars = define_parse(e, &vars, &vals, &env, &r, &extra_vars_pos); + if (extra_vars) { + all_extra_vars = scheme_append(extra_vars, all_extra_vars); + } + } + } + + if (extra_vars_pos) { + a = defn_syms; + defn_syms = scheme_make_vector(extra_vars_pos, NULL); + for (i = 0; i < len; i++) { + SCHEME_VEC_ELS(defn_syms)[i] = SCHEME_VEC_ELS(a)[i]; + } + + all_extra_vars = scheme_reverse(all_extra_vars); + for (i = len; i < extra_vars_pos; i++, all_extra_vars = SCHEME_CDR(all_extra_vars)) { + e = SCHEME_CAR(all_extra_vars); + a = SCHEME_STX_SYM(e); + if (scheme_hash_tree_get(source_names, a) || scheme_hash_tree_get(also_used_names, a)) { + /* Internal name conflicts with an exported name --- which is allowed, but means + that we need to pick a different name for the bucket */ + a = generate_defn_name(a, source_names, also_used_names, extra_vars_pos); + } + SCHEME_VEC_ELS(defn_syms)[i] = a; + a = extract_source_name(e); + if (!SAME_OBJ(a, SCHEME_VEC_ELS(defn_syms)[i])) + source_names = scheme_hash_tree_set(source_names, SCHEME_VEC_ELS(defn_syms)[i], a); + else + also_used_names = scheme_hash_tree_set(also_used_names, a, scheme_true); + } + } + + /* Prepare linklet record */ + + linklet->importss = import_symss; + linklet->defns = defn_syms; + linklet->source_names = source_names; + + /* Compile body forms */ + bodies = scheme_make_vector(body_len, scheme_false); + + linklet->bodies = bodies; + + for (i = 0; i < body_len; i++, form = SCHEME_STX_CDR(form)) { + e = SCHEME_STX_CAR(form); + if (is_define_values(e)) { + a = SCHEME_STX_CADR(e); + len = scheme_stx_proper_list_length(a); + vec = scheme_make_vector(len+1, NULL); + + if (len == 1) + d_env = scheme_set_comp_env_name(env, SCHEME_STX_CAR(a)); + else + d_env = env; + + for (j = 0; j < len; j++, a = SCHEME_STX_CDR(a)) { + v = scheme_compile_lookup(SCHEME_STX_CAR(a), env, 0); + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)); + MZ_ASSERT(((Scheme_IR_Toplevel *)v)->instance_pos == -1); + SCHEME_DEFN_VAR_(vec, j) = v; + } + + a = compile_expr(SCHEME_STX_CADR(SCHEME_STX_CDR(e)), d_env, 0); + SCHEME_DEFN_RHS(vec) = a; + + if (SCHEME_TRUEP(scheme_stx_property(e, compiler_inline_hint_symbol, NULL))) { + /* mark compiler-inline hint: */ + SCHEME_SET_DEFN_ALWAYS_INLINE(vec); + } + + e = vec; + e->type = scheme_define_values_type; + } else { + e = compile_expr(e, env, 0); + } + + SCHEME_VEC_ELS(bodies)[i] = e; + } + + return linklet; } -/**********************************************************************/ -/* stop expander */ -/**********************************************************************/ - -static Scheme_Object *stop_compile(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +static Scheme_Object *generate_defn_name(Scheme_Object *base_sym, + Scheme_Hash_Tree *used_names, + Scheme_Hash_Tree *also_used_names, + int search_start) { - scheme_signal_error("internal error: shouldn't get to stop syntax"); - return NULL; + char buf[32]; + Scheme_Object *n; + + while (1) { + sprintf(buf, ".%d", search_start); + n = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + n = scheme_symbol_append(base_sym, n); + if (!scheme_hash_tree_get(used_names, n) && !scheme_hash_tree_get(also_used_names, n)) + return n; + } } -static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer); - return form; -} - -Scheme_Object *scheme_get_stop_expander(void) -{ - return stop_expander; -} - -void scheme_add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env) -{ - Scheme_Object *stx; - stx = scheme_datum_to_syntax(sym, scheme_false, scheme_sys_wraps(env), 0, 0); - scheme_set_local_syntax(pos, stx, stop_expander, env, 0); -} /**********************************************************************/ /* precise GC */ diff --git a/racket/src/racket/src/cstartup.inc b/racket/src/racket/src/cstartup.inc deleted file mode 100644 index cab3ccb911..0000000000 --- a/racket/src/racket/src/cstartup.inc +++ /dev/null @@ -1,1569 +0,0 @@ - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,50,46,48,46,52,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0,18, -0,22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0,82,0, -89,0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0,173, -0,180,0,202,0,204,0,218,0,246,0,251,0,255,0,72,1,79,1,90,1, -128,1,135,1,144,1,177,1,210,1,16,2,21,2,102,2,107,2,112,2,133, -2,30,3,51,3,104,3,173,3,242,3,132,4,24,5,35,5,118,5,0,0, -148,7,0,0,3,1,5,105,110,115,112,48,71,35,37,109,105,110,45,115,116, -120,29,11,11,11,65,97,110,100,66,99,111,110,100,68,100,101,102,105,110,101, -65,108,101,116,66,108,101,116,42,73,108,101,116,42,45,118,97,108,117,101,115, -68,108,101,116,114,101,99,64,111,114,74,112,97,114,97,109,101,116,101,114,105, -122,101,68,117,110,108,101,115,115,66,119,104,101,110,70,104,101,114,101,45,115, -116,120,67,113,117,111,116,101,29,94,2,16,70,35,37,107,101,114,110,101,108, -11,29,94,2,16,70,35,37,112,97,114,97,109,122,11,64,105,102,67,98,101, -103,105,110,72,108,101,116,45,118,97,108,117,101,115,63,120,75,108,101,116,114, -101,99,45,118,97,108,117,101,115,68,108,97,109,98,100,97,1,20,112,97,114, -97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,63,118,75,100, -101,102,105,110,101,45,118,97,108,117,101,115,38,28,16,3,93,16,2,29,11, -11,11,2,3,2,29,93,143,16,5,39,2,31,40,2,34,2,2,39,38,29, -93,2,30,36,30,0,39,36,31,1,145,40,143,2,32,16,4,2,17,39,39, -2,1,143,2,32,16,4,2,18,39,39,2,1,16,22,2,4,2,33,2,5, -2,33,2,6,2,33,2,7,2,33,2,8,2,33,2,9,2,33,2,10,2, -33,2,11,2,33,2,12,2,33,2,13,2,33,2,14,2,33,38,32,143,2, -31,2,29,38,33,93,143,2,32,143,2,1,2,3,36,34,2,144,40,143,2, -35,16,4,2,17,40,39,2,1,16,2,2,15,93,143,2,35,147,2,1,2, -3,40,2,15,143,2,3,40,2,15,38,35,143,2,34,2,29,18,143,66,104, -101,114,101,2,28,27,248,22,170,4,195,249,22,163,4,80,143,42,39,251,22, -92,2,19,248,22,105,199,12,249,22,82,2,20,248,22,107,201,27,248,22,170, -4,195,249,22,163,4,80,143,42,39,251,22,92,2,19,248,22,105,199,249,22, -82,2,20,248,22,107,201,12,27,248,22,84,248,22,170,4,196,28,248,22,90, -193,20,14,144,40,39,40,28,248,22,90,248,22,84,194,248,22,191,20,193,249, -22,163,4,80,143,42,39,251,22,92,2,19,248,22,191,20,199,249,22,82,2, -4,248,22,128,21,201,11,18,143,10,2,28,27,248,22,84,248,22,170,4,196, -28,248,22,90,193,20,14,144,40,39,40,28,248,22,90,248,22,84,194,248,22, -191,20,193,249,22,163,4,80,143,42,39,250,22,92,2,21,248,22,92,249,22, -92,248,22,92,2,22,248,22,191,20,201,251,22,92,2,19,2,22,2,22,249, -22,82,2,11,248,22,128,21,204,18,143,11,2,28,248,22,170,4,193,27,248, -22,170,4,194,249,22,82,248,22,92,248,22,83,196,248,22,128,21,195,27,248, -22,84,248,22,170,4,23,197,1,249,22,163,4,80,143,42,39,28,248,22,66, -248,22,164,4,248,22,83,23,198,2,27,249,22,2,32,0,88,148,8,36,40, -46,11,9,222,33,43,248,22,170,4,248,22,105,23,200,2,250,22,92,2,23, -248,22,92,249,22,92,248,22,92,248,22,191,20,23,204,2,250,22,93,2,24, -249,22,2,22,83,23,204,2,248,22,107,23,206,2,249,22,82,248,22,191,20, -23,202,1,249,22,2,22,105,23,200,1,250,22,93,2,21,249,22,2,32,0, -88,148,8,36,40,50,11,9,222,33,44,248,22,170,4,248,22,191,20,201,248, -22,128,21,198,27,248,22,170,4,194,249,22,82,248,22,92,248,22,83,196,248, -22,128,21,195,27,248,22,84,248,22,170,4,23,197,1,249,22,163,4,80,143, -42,39,250,22,93,2,23,249,22,2,32,0,88,148,8,36,40,50,11,9,222, -33,46,248,22,170,4,248,22,83,201,248,22,128,21,198,27,248,22,84,248,22, -170,4,196,27,248,22,170,4,248,22,83,195,249,22,163,4,80,143,43,39,28, -248,22,90,195,250,22,93,2,21,9,248,22,128,21,199,250,22,92,2,7,248, -22,92,248,22,83,199,250,22,93,2,8,248,22,128,21,201,248,22,128,21,202, -27,248,22,84,248,22,170,4,196,27,248,22,170,4,248,22,83,195,249,22,163, -4,80,143,43,39,28,248,22,90,195,250,22,93,2,21,9,248,22,128,21,199, -250,22,92,2,21,248,22,92,248,22,83,199,250,22,93,2,9,248,22,128,21, -201,248,22,128,21,202,27,248,22,84,248,22,170,4,23,197,1,27,249,22,1, -22,97,249,22,2,22,170,4,248,22,170,4,248,22,83,199,248,22,128,5,249, -22,163,4,80,143,44,39,251,22,92,1,22,119,105,116,104,45,99,111,110,116, -105,110,117,97,116,105,111,110,45,109,97,114,107,2,25,250,22,93,1,23,101, -120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111, -110,21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114, -107,45,115,101,116,45,102,105,114,115,116,11,2,25,202,250,22,93,2,21,9, -248,22,128,21,204,27,248,22,84,248,22,170,4,196,28,248,22,90,193,20,14, -144,40,39,40,249,22,163,4,80,143,42,39,27,248,22,170,4,248,22,83,197, -28,249,22,182,9,64,61,62,248,22,164,4,248,22,105,196,250,22,92,2,21, -248,22,92,249,22,92,21,93,2,26,248,22,191,20,199,250,22,93,2,5,249, -22,92,2,26,249,22,92,248,22,114,203,2,26,248,22,128,21,202,251,22,92, -2,19,28,249,22,182,9,248,22,164,4,248,22,191,20,200,66,101,108,115,101, -10,248,22,191,20,197,250,22,93,2,21,9,248,22,128,21,200,249,22,82,2, -5,248,22,128,21,202,18,143,94,10,66,118,111,105,100,2,28,27,248,22,84, -248,22,170,4,196,249,22,163,4,80,143,42,39,28,248,22,66,248,22,164,4, -248,22,83,197,250,22,92,2,27,248,22,92,248,22,191,20,199,248,22,105,198, -27,248,22,164,4,248,22,191,20,197,250,22,92,2,27,248,22,92,248,22,83, -197,250,22,93,2,24,248,22,128,21,199,248,22,128,21,202,145,40,9,20,122, -145,2,1,39,16,1,11,16,0,20,27,15,61,9,2,2,2,2,2,3,11, -11,11,11,9,9,11,11,11,10,40,80,143,39,39,20,122,145,2,1,39,16, -0,16,0,41,42,39,16,0,39,16,0,39,11,11,11,16,11,2,4,2,5, -2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,16,11,11, -11,11,11,11,11,11,11,11,11,11,16,11,2,4,2,5,2,6,2,7,2, -8,2,9,2,10,2,11,2,12,2,13,2,14,39,50,40,16,0,39,16,1, -2,15,40,11,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16, -0,16,0,39,39,16,12,16,5,11,20,15,16,2,20,14,144,39,39,40,80, -143,39,39,40,20,122,145,2,1,39,16,1,2,15,16,1,33,36,10,16,5, -2,13,88,148,8,36,40,56,40,9,223,0,33,37,40,20,122,145,2,1,39, -16,1,2,15,16,0,11,16,5,2,14,88,148,8,36,40,56,40,9,223,0, -33,38,40,20,122,145,2,1,39,16,1,2,15,16,0,11,16,5,2,4,88, -148,8,36,40,56,42,9,223,0,33,39,40,20,122,145,2,1,39,16,1,2, -15,16,1,33,40,11,16,5,2,11,88,148,8,36,40,59,42,9,223,0,33, -41,40,20,122,145,2,1,39,16,1,2,15,16,1,33,42,11,16,5,2,7, -88,148,8,36,40,61,40,9,223,0,33,45,40,20,122,145,2,1,39,16,1, -2,15,16,0,11,16,5,2,10,88,148,8,36,40,56,40,9,223,0,33,47, -40,20,122,145,2,1,39,16,1,2,15,16,0,11,16,5,2,8,88,148,8, -36,40,57,40,9,223,0,33,48,40,20,122,145,2,1,39,16,1,2,15,16, -0,11,16,5,2,9,88,148,8,36,40,57,40,9,223,0,33,49,40,20,122, -145,2,1,39,16,1,2,15,16,0,11,16,5,2,12,88,148,8,36,40,59, -40,9,223,0,33,50,40,20,122,145,2,1,39,16,1,2,15,16,0,11,16, -5,2,5,88,148,8,36,40,61,42,9,223,0,33,51,40,20,122,145,2,1, -39,16,1,2,15,16,1,33,52,11,16,5,2,6,88,148,8,36,40,57,40, -9,223,0,33,53,40,20,122,145,2,1,39,16,1,2,15,16,0,11,16,0, -94,2,17,2,18,93,2,17,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2091); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,50,46,48,46,52,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,183,0,0,0,1,0,0,8,0,16, -0,29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0,193,0, -211,0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130,1,145, -1,184,1,202,1,233,1,245,1,6,2,18,2,33,2,57,2,89,2,118,2, -138,2,160,2,183,2,207,2,225,2,0,3,14,3,31,3,75,3,83,3,88, -3,132,3,139,3,149,3,164,3,173,3,178,3,180,3,213,3,237,3,2,4, -15,4,25,4,34,4,45,4,63,4,76,4,86,4,96,4,102,4,107,4,119, -4,122,4,126,4,131,4,134,4,158,4,201,4,214,4,236,4,247,4,19,5, -42,5,50,5,74,5,95,5,39,6,69,6,155,9,178,9,195,9,163,11,7, -12,21,12,210,12,251,14,4,15,13,15,27,15,37,15,57,16,160,16,29,17, -102,17,175,17,21,18,50,18,121,18,255,18,70,19,21,20,139,20,152,20,14, -21,27,21,134,21,201,21,214,21,225,21,106,22,224,22,7,23,118,23,213,25, -237,25,99,26,166,27,173,27,220,27,233,27,223,28,237,28,91,29,249,29,0, -30,152,31,224,31,235,31,246,31,151,32,171,32,231,32,238,32,94,33,148,33, -167,33,118,34,134,34,91,35,87,36,124,36,133,36,220,37,81,40,97,40,164, -40,185,40,205,40,225,40,26,41,6,44,228,44,244,44,119,45,177,45,210,45, -81,46,245,46,6,47,68,49,139,51,155,51,39,52,227,52,243,52,143,53,75, -54,84,54,91,54,167,55,243,56,105,57,186,60,60,61,192,61,157,63,107,64, -139,64,253,64,0,0,175,72,0,0,3,1,5,105,110,115,112,48,69,35,37, -117,116,105,108,115,74,112,97,116,104,45,115,116,114,105,110,103,63,66,98,115, -98,115,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,73,114, -101,114,111,111,116,45,112,97,116,104,1,20,102,105,110,100,45,101,120,101,99, -117,116,97,98,108,101,45,112,97,116,104,1,27,112,97,116,104,45,108,105,115, -116,45,115,116,114,105,110,103,45,62,112,97,116,104,45,108,105,115,116,1,42, -99,97,108,108,45,119,105,116,104,45,100,101,102,97,117,108,116,45,114,101,97, -100,105,110,103,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, -67,113,117,111,116,101,29,94,2,10,70,35,37,112,97,114,97,109,122,11,76, -45,99,104,101,99,107,45,114,101,108,112,97,116,104,79,45,99,104,101,99,107, -45,99,111,108,108,101,99,116,105,111,110,73,45,99,104,101,99,107,45,102,97, -105,108,77,99,111,108,108,101,99,116,105,111,110,45,112,97,116,104,75,102,105, -110,100,45,99,111,108,45,102,105,108,101,1,20,99,111,108,108,101,99,116,105, -111,110,45,102,105,108,101,45,112,97,116,104,1,18,102,105,110,100,45,109,97, -105,110,45,99,111,108,108,101,99,116,115,1,32,101,120,101,45,114,101,108,97, -116,105,118,101,45,112,97,116,104,45,62,99,111,109,112,108,101,116,101,45,112, -97,116,104,78,102,105,110,100,45,109,97,105,110,45,99,111,110,102,105,103,78, -103,101,116,45,99,111,110,102,105,103,45,116,97,98,108,101,1,21,103,101,116, -45,105,110,115,116,97,108,108,97,116,105,111,110,45,110,97,109,101,76,99,111, -101,114,99,101,45,116,111,45,112,97,116,104,1,37,99,111,108,108,101,99,116, -115,45,114,101,108,97,116,105,118,101,45,112,97,116,104,45,62,99,111,109,112, -108,101,116,101,45,112,97,116,104,79,97,100,100,45,99,111,110,102,105,103,45, -115,101,97,114,99,104,1,29,102,105,110,100,45,108,105,98,114,97,114,121,45, -99,111,108,108,101,99,116,105,111,110,45,108,105,110,107,115,73,108,105,110,107, -115,45,99,97,99,104,101,78,115,116,97,109,112,45,112,114,111,109,112,116,45, -116,97,103,73,102,105,108,101,45,62,115,116,97,109,112,76,110,111,45,102,105, -108,101,45,115,116,97,109,112,63,1,22,103,101,116,45,108,105,110,107,101,100, -45,99,111,108,108,101,99,116,105,111,110,115,1,30,110,111,114,109,97,108,105, -122,101,45,99,111,108,108,101,99,116,105,111,110,45,114,101,102,101,114,101,110, -99,101,1,27,102,105,108,101,45,101,120,105,115,116,115,63,47,109,97,121,98, -101,45,99,111,109,112,105,108,101,100,1,18,112,97,116,104,45,97,100,100,45, -101,120,116,101,110,115,105,111,110,1,20,99,104,101,99,107,45,101,120,116,101, -110,115,105,111,110,45,99,97,108,108,1,21,112,97,116,104,45,97,100,106,117, -115,116,45,101,120,116,101,110,115,105,111,110,1,22,112,97,116,104,45,114,101, -112,108,97,99,101,45,101,120,116,101,110,115,105,111,110,79,108,111,97,100,47, -117,115,101,45,99,111,109,112,105,108,101,100,1,29,102,105,110,100,45,108,105, -98,114,97,114,121,45,99,111,108,108,101,99,116,105,111,110,45,112,97,116,104, -115,75,101,109,98,101,100,100,101,100,45,108,111,97,100,78,110,111,114,109,97, -108,45,112,97,116,104,45,99,97,115,101,6,41,41,40,111,114,47,99,32,112, -97,116,104,45,102,111,114,45,115,111,109,101,45,115,121,115,116,101,109,63,32, -112,97,116,104,45,115,116,114,105,110,103,63,41,69,119,105,110,100,111,119,115, -6,2,2,92,49,6,41,41,40,111,114,47,99,32,112,97,116,104,45,115,116, -114,105,110,103,63,32,112,97,116,104,45,102,111,114,45,115,111,109,101,45,115, -121,115,116,101,109,63,41,6,4,4,112,97,116,104,5,8,92,92,63,92,82, -69,76,92,6,12,12,112,97,116,104,45,115,116,114,105,110,103,63,70,114,101, -108,97,116,105,118,101,66,108,111,111,112,5,0,6,30,30,40,112,114,111,99, -101,100,117,114,101,45,97,114,105,116,121,45,105,110,99,108,117,100,101,115,47, -99,32,48,41,6,21,21,105,110,118,97,108,105,100,32,114,101,108,97,116,105, -118,101,32,112,97,116,104,6,18,18,40,97,110,121,47,99,32,46,32,45,62, -32,46,32,97,110,121,41,74,99,111,108,108,101,99,116,115,45,100,105,114,71, -101,120,101,99,45,102,105,108,101,70,111,114,105,103,45,100,105,114,72,99,111, -110,102,105,103,45,100,105,114,79,105,110,115,116,97,108,108,97,116,105,111,110, -45,110,97,109,101,6,10,10,108,105,110,107,115,46,114,107,116,100,71,97,100, -100,111,110,45,100,105,114,71,102,115,45,99,104,97,110,103,101,67,101,114,114, -111,114,66,114,111,111,116,73,115,116,97,116,105,99,45,114,111,111,116,6,0, -0,6,1,1,47,5,3,46,122,111,5,1,95,6,21,21,40,111,114,47,99, -32,115,116,114,105,110,103,63,32,98,121,116,101,115,63,41,6,40,40,99,97, -110,110,111,116,32,97,100,100,32,97,110,32,101,120,116,101,110,115,105,111,110, -32,116,111,32,97,32,114,111,111,116,32,112,97,116,104,58,32,5,11,80,76, -84,67,79,76,76,69,67,84,83,1,20,99,111,108,108,101,99,116,115,45,115, -101,97,114,99,104,45,100,105,114,115,6,8,8,99,111,108,108,101,99,116,115, -28,248,22,134,16,193,10,28,248,22,162,7,193,27,248,22,157,16,194,28,192, -192,248,22,158,16,194,11,0,21,35,114,120,34,94,91,92,92,93,91,92,92, -93,91,63,93,91,92,92,93,34,0,6,35,114,120,34,47,34,0,22,35,114, -120,34,91,47,92,92,93,91,46,32,93,43,91,47,92,92,93,42,36,34,0, -19,35,114,120,34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,86, -94,28,248,22,135,16,23,195,2,11,28,248,22,134,16,23,195,2,11,28,28, -248,22,162,7,23,195,2,28,248,22,157,16,23,195,2,10,248,22,158,16,23, -195,2,11,11,250,22,134,12,2,41,2,42,23,197,2,28,28,248,22,135,16, -23,195,2,249,22,182,9,248,22,136,16,23,197,2,2,43,249,22,182,9,247, -22,189,8,2,43,27,28,248,22,162,7,23,196,2,23,195,2,248,22,174,8, -248,22,139,16,23,197,2,28,249,22,132,17,2,76,23,195,2,28,248,22,162, -7,195,248,22,142,16,195,194,27,248,22,137,8,23,195,1,249,22,143,16,248, -22,177,8,250,22,140,17,2,77,28,249,22,132,17,2,78,23,201,2,23,199, -1,250,22,140,17,2,79,23,202,1,2,44,80,144,47,40,41,2,43,28,248, -22,162,7,194,248,22,142,16,194,193,0,28,35,114,120,34,94,92,92,92,92, -92,92,92,92,91,63,93,92,92,92,92,85,78,67,92,92,92,92,34,86,95, -28,248,22,134,16,23,195,2,11,28,28,248,22,162,7,23,195,2,28,248,22, -157,16,23,195,2,10,248,22,158,16,23,195,2,11,11,28,248,22,135,16,23, -195,2,11,252,22,134,12,2,6,2,45,39,23,199,2,23,200,2,28,248,22, -134,16,23,196,2,11,28,28,248,22,162,7,23,196,2,28,248,22,157,16,23, -196,2,10,248,22,158,16,23,196,2,11,11,28,248,22,135,16,23,196,2,11, -252,22,134,12,2,6,2,45,40,23,199,2,23,200,2,27,28,248,22,135,16, -23,196,2,248,22,136,16,23,196,2,247,22,137,16,86,95,28,248,22,159,16, -23,196,2,11,28,249,22,182,9,247,22,137,16,23,195,2,11,253,22,136,12, -2,6,6,54,54,112,97,116,104,32,105,115,32,110,111,116,32,99,111,109,112, -108,101,116,101,32,97,110,100,32,110,111,116,32,116,104,101,32,112,108,97,116, -102,111,114,109,39,115,32,99,111,110,118,101,110,116,105,111,110,2,46,23,201, -2,6,24,24,112,108,97,116,102,111,114,109,32,99,111,110,118,101,110,116,105, -111,110,32,116,121,112,101,247,22,137,16,28,249,22,182,9,28,248,22,135,16, -23,199,2,248,22,136,16,23,199,2,247,22,137,16,23,195,2,11,253,22,136, -12,2,6,6,37,37,103,105,118,101,110,32,112,97,116,104,115,32,117,115,101, -32,100,105,102,102,101,114,101,110,116,32,99,111,110,118,101,110,116,105,111,110, -115,2,46,23,201,2,6,9,9,114,111,111,116,32,112,97,116,104,23,202,2, -27,27,248,22,163,16,28,248,22,159,16,23,199,2,23,198,1,248,22,160,16, -23,199,1,86,94,28,248,22,135,16,23,194,2,11,28,248,22,134,16,23,194, -2,11,28,28,248,22,162,7,23,194,2,28,248,22,157,16,23,194,2,10,248, -22,158,16,23,194,2,11,11,250,22,134,12,2,41,2,42,23,196,2,28,28, -248,22,135,16,23,194,2,249,22,182,9,248,22,136,16,23,196,2,2,43,249, -22,182,9,247,22,189,8,2,43,27,28,248,22,162,7,23,195,2,23,194,2, -248,22,174,8,248,22,139,16,23,196,2,28,249,22,132,17,2,76,23,195,2, -86,94,23,193,1,28,248,22,162,7,194,248,22,142,16,194,193,27,248,22,137, -8,23,195,1,249,22,143,16,248,22,177,8,250,22,140,17,2,77,28,249,22, -132,17,2,78,23,201,2,23,199,1,250,22,140,17,2,79,23,202,1,2,44, -80,144,50,40,41,2,43,28,248,22,162,7,193,248,22,142,16,193,192,27,248, -22,139,16,23,195,2,28,249,22,182,9,23,197,2,66,117,110,105,120,28,249, -22,159,8,194,5,1,47,28,248,22,135,16,198,197,248,22,142,16,198,249,22, -152,16,199,249,22,143,16,249,22,162,8,248,22,139,16,200,40,198,28,249,22, -182,9,23,197,2,2,43,249,22,152,16,23,200,1,249,22,143,16,28,249,22, -132,17,0,27,35,114,120,34,94,92,92,92,92,92,92,92,92,91,63,93,92, -92,92,92,91,97,45,122,93,58,34,23,199,2,251,22,163,8,2,47,250,22, -162,8,203,43,44,5,1,92,249,22,162,8,202,45,28,249,22,132,17,2,81, -23,199,2,249,22,163,8,2,47,249,22,162,8,200,43,28,249,22,132,17,2, -81,23,199,2,249,22,163,8,2,47,249,22,162,8,200,43,28,249,22,132,17, -0,14,35,114,120,34,94,92,92,92,92,92,92,92,92,34,23,199,2,249,22, -163,8,5,4,85,78,67,92,249,22,162,8,200,41,28,249,22,132,17,0,12, -35,114,120,34,94,91,97,45,122,93,58,34,198,249,22,163,8,250,22,162,8, -201,39,40,249,22,162,8,200,41,12,198,12,32,83,88,148,8,36,42,56,11, -72,102,111,117,110,100,45,101,120,101,99,222,33,86,32,84,88,148,8,36,43, -61,11,66,110,101,120,116,222,33,85,27,248,22,161,16,23,197,2,28,249,22, -184,9,23,195,2,23,198,1,11,28,248,22,157,16,23,194,2,27,249,22,152, -16,23,200,1,23,196,1,28,23,196,2,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,197,2,86,95,23,195,1,23,194,1,27,28,23,199,2,27,248, -22,161,16,23,199,2,28,249,22,184,9,23,195,2,23,200,2,86,94,23,193, -1,11,28,248,22,157,16,23,194,2,250,2,83,23,203,2,23,204,2,249,22, -152,16,23,200,2,23,198,1,250,2,83,23,203,2,23,204,2,23,196,1,11, -28,23,193,2,86,97,23,200,1,23,199,1,23,197,1,23,194,1,192,27,28, -248,22,134,16,23,196,2,27,249,22,152,16,23,198,2,23,204,2,28,248,22, -147,16,23,194,2,192,28,248,22,146,16,193,192,11,11,28,23,193,2,86,97, -23,201,1,23,200,1,23,198,1,23,195,1,192,28,23,200,2,86,97,23,201, -1,23,200,1,23,198,1,23,195,1,11,27,248,22,161,16,23,200,2,28,249, -22,184,9,194,23,201,1,11,28,248,22,157,16,193,250,2,83,203,204,249,22, -152,16,200,197,250,2,83,203,204,195,86,95,23,196,1,23,195,1,192,86,94, -23,197,1,28,23,195,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -197,2,86,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,161,16,23, -199,2,28,249,22,184,9,23,195,2,23,200,2,86,94,23,193,1,11,28,248, -22,157,16,23,194,2,250,2,83,23,202,2,23,203,2,249,22,152,16,23,200, -2,23,198,1,250,2,83,23,202,2,23,203,2,23,196,1,11,28,23,193,2, -192,27,28,248,22,134,16,23,196,2,27,249,22,152,16,23,198,2,23,203,2, -28,248,22,147,16,23,194,2,192,28,248,22,146,16,193,192,11,11,28,23,193, -2,192,28,23,199,2,11,27,248,22,161,16,23,200,2,28,249,22,184,9,194, -23,201,1,11,28,248,22,157,16,193,250,2,83,202,203,249,22,152,16,200,197, -250,2,83,202,203,195,192,28,23,194,2,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,199,2,86,95,23,195,1,23,194,1,27,28,23,197,2,251,2, -84,23,201,2,23,202,2,23,203,2,23,198,2,11,28,23,193,2,192,27,28, -248,22,134,16,195,27,249,22,152,16,197,201,28,248,22,147,16,23,194,2,192, -28,248,22,146,16,193,192,11,11,28,192,192,28,197,11,251,2,84,201,202,203, -198,194,32,87,88,148,8,36,43,60,11,2,50,222,33,88,28,248,22,90,23, -197,2,11,27,249,22,152,16,248,22,160,16,248,22,83,23,201,2,23,198,2, -28,248,22,146,16,23,194,2,250,2,83,196,197,195,27,248,22,128,21,23,199, -1,28,248,22,90,23,194,2,11,27,249,22,152,16,248,22,160,16,248,22,83, -23,198,2,23,200,2,28,248,22,146,16,23,194,2,250,2,83,198,199,195,27, -248,22,128,21,23,196,1,28,248,22,90,23,194,2,11,27,249,22,152,16,248, -22,160,16,248,22,83,23,198,2,23,202,2,28,248,22,146,16,23,194,2,250, -2,83,200,201,195,27,248,22,128,21,23,196,1,28,248,22,90,23,194,2,11, -27,249,22,152,16,248,22,160,16,248,22,83,197,203,28,248,22,146,16,193,250, -2,83,202,203,195,251,2,87,203,204,205,248,22,128,21,198,86,95,28,248,22, -134,16,23,195,2,11,28,28,248,22,162,7,23,195,2,28,248,22,157,16,23, -195,2,10,248,22,158,16,23,195,2,11,11,250,22,134,12,2,7,2,48,23, -197,2,28,23,195,2,28,28,28,248,22,134,16,23,196,2,10,28,248,22,162, -7,23,196,2,28,248,22,157,16,23,196,2,10,248,22,158,16,23,196,2,11, -248,22,157,16,23,196,2,11,11,250,22,134,12,2,7,6,45,45,40,111,114, -47,99,32,35,102,32,40,97,110,100,47,99,32,112,97,116,104,45,115,116,114, -105,110,103,63,32,114,101,108,97,116,105,118,101,45,112,97,116,104,63,41,41, -23,198,2,11,28,28,248,22,157,16,23,195,2,90,144,42,11,89,146,42,39, -11,248,22,155,16,23,198,2,249,22,182,9,194,2,49,11,27,249,22,184,8, -247,22,183,8,5,4,80,65,84,72,27,28,23,194,2,249,80,143,43,44,249, -22,174,8,23,198,1,7,63,9,86,94,23,194,1,9,27,28,249,22,182,9, -247,22,189,8,2,43,249,22,82,248,22,143,16,5,1,46,23,196,1,23,194, -1,28,248,22,90,23,194,2,86,97,23,199,1,23,198,1,23,197,1,23,193, -1,11,27,249,22,152,16,248,22,160,16,248,22,83,23,198,2,23,200,2,28, -248,22,146,16,23,194,2,86,95,23,198,1,23,194,1,250,2,83,202,201,195, -27,248,22,128,21,23,196,1,28,248,22,90,23,194,2,86,97,23,201,1,23, -200,1,23,199,1,23,193,1,11,27,249,22,152,16,248,22,160,16,248,22,83, -23,198,2,23,202,2,28,248,22,146,16,23,194,2,86,95,23,200,1,23,194, -1,250,2,83,204,203,195,27,248,22,128,21,23,196,1,28,248,22,90,23,194, -2,86,97,23,203,1,23,202,1,23,201,1,23,193,1,11,27,249,22,152,16, -248,22,160,16,248,22,83,23,198,2,23,204,2,28,248,22,146,16,23,194,2, -86,95,23,202,1,23,194,1,250,2,83,206,205,195,27,248,22,128,21,23,196, -1,28,248,22,90,23,194,2,86,97,23,205,1,23,204,1,23,203,1,23,193, -1,11,27,249,22,152,16,248,22,160,16,248,22,83,197,205,28,248,22,146,16, -193,250,2,83,23,16,23,15,195,251,2,87,23,17,23,16,23,15,248,22,128, -21,198,27,248,22,160,16,23,196,1,28,248,22,146,16,193,250,2,83,199,198, -195,11,250,80,144,42,43,42,196,197,11,250,80,144,42,43,42,196,11,11,32, -92,88,148,8,36,42,58,11,2,50,222,33,94,0,8,35,114,120,35,34,92, -34,34,27,249,22,128,17,23,196,2,23,198,2,28,23,193,2,86,94,23,196, -1,27,248,22,105,23,195,2,27,27,248,22,114,23,197,1,27,249,22,128,17, -23,200,2,23,196,2,28,23,193,2,86,94,23,194,1,27,248,22,105,23,195, -2,27,250,2,92,23,203,1,203,248,22,114,23,199,1,27,28,249,22,182,9, -247,22,189,8,2,43,250,22,140,17,2,93,23,198,1,2,51,194,28,249,22, -159,8,194,2,51,249,22,97,203,195,249,22,82,248,22,143,16,195,195,86,95, -23,198,1,23,193,1,27,28,249,22,182,9,247,22,189,8,2,43,250,22,140, -17,2,93,23,198,1,2,51,194,28,249,22,159,8,194,2,51,249,22,97,201, -9,249,22,82,248,22,143,16,195,9,27,28,249,22,182,9,247,22,189,8,2, -43,250,22,140,17,2,93,23,198,1,2,51,194,28,249,22,159,8,194,2,51, -249,22,97,199,195,249,22,82,248,22,143,16,195,195,86,95,23,194,1,23,193, -1,27,28,249,22,182,9,247,22,189,8,2,43,250,22,140,17,2,93,23,200, -1,2,51,196,28,249,22,159,8,194,2,51,249,22,97,197,9,249,22,82,248, -22,143,16,195,9,86,95,28,248,22,151,8,194,11,28,248,22,162,7,194,11, -250,22,134,12,2,8,6,21,21,40,111,114,47,99,32,98,121,116,101,115,63, -32,115,116,114,105,110,103,63,41,196,28,28,248,22,91,195,249,22,4,22,134, -16,196,11,11,250,22,134,12,2,8,6,14,14,40,108,105,115,116,111,102,32, -112,97,116,104,63,41,197,250,2,92,195,197,28,248,22,162,7,197,248,22,176, -8,197,196,28,28,248,22,0,23,195,2,249,22,48,23,196,2,39,11,20,13, -144,80,144,39,46,40,26,35,80,144,8,35,47,40,249,22,31,11,80,144,8, -37,46,40,22,165,15,10,22,166,15,10,22,167,15,10,22,168,15,11,22,169, -15,11,22,173,15,10,22,172,15,11,22,174,15,10,22,171,15,10,22,175,15, -10,22,170,15,11,22,176,15,10,22,177,15,10,22,178,15,10,22,179,15,11, -22,180,15,10,22,163,15,11,247,23,194,1,250,22,134,12,2,9,2,52,23, -197,1,86,94,28,248,22,134,16,23,195,2,11,28,28,248,22,162,7,23,195, -2,28,248,22,157,16,23,195,2,10,248,22,158,16,23,195,2,11,11,250,22, -134,12,23,196,2,2,48,23,197,2,28,248,22,157,16,23,195,2,12,251,22, -136,12,23,197,1,2,53,2,46,23,198,1,86,94,28,248,22,134,16,23,195, -2,11,28,28,248,22,162,7,23,195,2,28,248,22,157,16,23,195,2,10,248, -22,158,16,23,195,2,11,11,250,22,134,12,23,196,2,2,48,23,197,2,28, -248,22,157,16,23,195,2,12,251,22,136,12,23,197,1,2,53,2,46,23,198, -1,86,95,28,248,22,134,16,23,195,2,11,28,28,248,22,162,7,23,195,2, -28,248,22,157,16,23,195,2,10,248,22,158,16,23,195,2,11,11,250,22,134, -12,23,196,2,2,48,23,197,2,28,248,22,157,16,23,195,2,86,94,23,194, -1,11,251,22,136,12,23,197,2,2,53,2,46,23,198,1,249,22,3,20,20, -94,88,148,8,36,40,50,11,9,223,2,33,98,23,195,1,23,197,1,28,28, -248,22,0,23,195,2,249,22,48,23,196,2,40,11,12,250,22,134,12,23,196, -1,2,54,23,197,1,86,94,28,248,22,134,16,23,194,2,11,28,28,248,22, -162,7,23,194,2,28,248,22,157,16,23,194,2,10,248,22,158,16,23,194,2, -11,11,250,22,134,12,2,15,2,48,23,196,2,28,248,22,157,16,23,194,2, -12,251,22,136,12,2,15,2,53,2,46,23,197,1,86,97,28,248,22,134,16, -23,196,2,11,28,28,248,22,162,7,23,196,2,28,248,22,157,16,23,196,2, -10,248,22,158,16,23,196,2,11,11,250,22,134,12,2,15,2,48,23,198,2, -28,248,22,157,16,23,196,2,11,251,22,136,12,2,15,2,53,2,46,23,199, -2,249,22,3,32,0,88,148,8,36,40,49,11,9,222,33,101,23,198,2,28, -28,248,22,0,23,195,2,249,22,48,23,196,2,40,11,11,250,22,134,12,2, -15,2,54,23,197,2,252,80,143,44,52,23,199,1,23,200,1,23,201,1,11, -11,86,94,28,248,22,134,16,23,194,2,11,28,28,248,22,162,7,23,194,2, -28,248,22,157,16,23,194,2,10,248,22,158,16,23,194,2,11,11,250,22,134, -12,2,17,2,48,23,196,2,28,248,22,157,16,23,194,2,12,251,22,136,12, -2,17,2,53,2,46,23,197,1,86,99,28,248,22,134,16,23,197,2,11,28, -28,248,22,162,7,23,197,2,28,248,22,157,16,23,197,2,10,248,22,158,16, -23,197,2,11,11,250,22,134,12,2,17,2,48,23,199,2,28,248,22,157,16, -23,197,2,11,251,22,136,12,2,17,2,53,2,46,23,200,2,28,248,22,134, -16,23,198,2,11,28,28,248,22,162,7,23,198,2,28,248,22,157,16,23,198, -2,10,248,22,158,16,23,198,2,11,11,250,22,134,12,2,17,2,48,23,200, -2,28,248,22,157,16,23,198,2,11,251,22,136,12,2,17,2,53,2,46,23, -201,2,249,22,3,32,0,88,148,8,36,40,49,11,9,222,33,103,23,200,2, -28,28,248,22,0,23,195,2,249,22,48,23,196,2,40,11,11,250,22,134,12, -2,17,2,54,23,197,2,252,80,143,44,52,23,199,1,23,202,1,23,203,1, -23,201,1,23,200,1,27,248,22,175,16,2,55,28,248,22,159,16,23,194,2, -248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90,144,42,11,89,146, -42,39,11,248,22,155,16,249,22,160,16,250,80,144,49,43,42,248,22,175,16, -2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23,194,1,248,22,162, -16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,44,43,42,248,22,175, -16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23,194,1,11,249,80, -144,41,55,40,39,80,144,41,8,40,42,27,248,22,175,16,2,58,28,248,22, -159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90, -144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,49,43, -42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23, -194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,44, -43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23, -194,1,11,249,80,144,41,55,40,40,80,144,41,8,41,42,27,20,13,144,80, -144,40,46,40,26,35,80,144,8,36,47,40,249,22,31,11,80,144,8,38,46, -40,22,165,15,10,22,166,15,10,22,167,15,10,22,168,15,11,22,169,15,11, -22,173,15,10,22,172,15,11,22,174,15,10,22,171,15,10,22,175,15,10,22, -170,15,11,22,176,15,10,22,177,15,10,22,178,15,10,22,179,15,11,22,180, -15,10,22,163,15,11,247,22,157,6,28,248,22,152,2,193,192,11,27,28,23, -195,2,249,22,152,16,23,197,1,6,11,11,99,111,110,102,105,103,46,114,107, -116,100,86,94,23,195,1,11,27,28,23,194,2,28,248,22,146,16,23,195,2, -249,22,149,6,23,196,1,80,144,43,8,42,42,11,11,28,192,192,21,17,1, -0,250,22,161,2,23,196,1,2,59,247,22,180,8,250,22,161,2,195,2,59, -247,22,180,8,28,248,22,162,7,23,195,2,27,248,22,142,16,23,196,1,28, -248,22,159,16,23,194,2,192,249,22,160,16,23,195,1,27,247,80,144,43,54, -42,28,23,193,2,192,247,22,176,16,28,248,22,151,8,23,195,2,27,248,22, -143,16,23,196,1,28,248,22,159,16,23,194,2,192,249,22,160,16,23,195,1, -27,247,80,144,43,54,42,28,23,193,2,192,247,22,176,16,28,248,22,134,16, -23,195,2,28,248,22,159,16,23,195,2,193,249,22,160,16,23,196,1,27,247, -80,144,42,54,42,28,23,193,2,192,247,22,176,16,193,27,248,22,175,16,2, -55,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16, -23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250, -80,144,49,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95, -23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27, -250,80,144,44,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248, -22,162,16,23,194,1,11,28,248,22,159,16,23,195,2,193,249,22,160,16,23, -196,1,27,249,80,144,44,55,40,39,80,144,44,8,43,42,28,23,193,2,192, -247,22,176,16,28,248,22,159,16,23,195,2,248,22,162,16,23,195,1,28,248, -22,158,16,23,195,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22, -160,16,250,80,144,48,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2, -57,86,95,23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,200,1,23, -196,1,27,250,80,144,43,43,42,248,22,175,16,2,56,23,198,1,10,28,23, -193,2,248,22,162,16,23,194,1,11,28,248,22,90,23,196,2,9,28,248,22, -83,23,196,2,249,22,82,27,248,22,191,20,23,199,2,28,248,22,162,7,23, -194,2,27,248,22,142,16,23,195,1,28,248,22,159,16,23,194,2,192,249,22, -160,16,23,195,1,27,247,80,144,46,54,42,28,23,193,2,192,247,22,176,16, -28,248,22,151,8,23,194,2,27,248,22,143,16,23,195,1,28,248,22,159,16, -23,194,2,192,249,22,160,16,23,195,1,27,247,80,144,46,54,42,28,23,193, -2,192,247,22,176,16,28,248,22,134,16,23,194,2,28,248,22,159,16,23,194, -2,192,249,22,160,16,23,195,1,27,247,80,144,45,54,42,28,23,193,2,192, -247,22,176,16,192,27,248,22,128,21,23,199,1,28,248,22,90,23,194,2,86, -95,23,197,1,23,193,1,9,28,248,22,83,23,194,2,249,22,82,248,80,144, -45,60,42,248,22,191,20,23,197,2,27,248,22,128,21,23,197,1,28,248,22, -90,23,194,2,86,95,23,200,1,23,193,1,9,28,248,22,83,23,194,2,249, -22,82,248,80,144,48,60,42,248,22,191,20,23,197,2,249,80,144,49,8,44, -42,23,204,1,248,22,128,21,23,198,1,249,22,97,23,202,2,249,80,144,49, -8,44,42,23,204,1,248,22,128,21,23,198,1,249,22,97,23,199,2,27,248, -22,128,21,23,197,1,28,248,22,90,23,194,2,86,95,23,200,1,23,193,1, -9,28,248,22,83,23,194,2,249,22,82,248,80,144,48,60,42,248,22,191,20, -23,197,2,249,80,144,49,8,44,42,23,204,1,248,22,128,21,23,198,1,249, -22,97,23,202,2,249,80,144,49,8,44,42,23,204,1,248,22,128,21,23,198, -1,249,22,97,23,196,2,27,248,22,128,21,23,199,1,28,248,22,90,23,194, -2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45,60,42,248,22,191, -20,23,197,2,27,248,22,128,21,23,197,1,28,248,22,90,23,194,2,86,95, -23,200,1,23,193,1,9,28,248,22,83,23,194,2,249,22,82,248,80,144,48, -60,42,248,22,191,20,23,197,2,249,80,144,49,8,44,42,23,204,1,248,22, -128,21,23,198,1,249,22,97,23,202,2,249,80,144,49,8,44,42,23,204,1, -248,22,128,21,23,198,1,249,22,97,23,199,2,27,248,22,128,21,23,197,1, -28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144, -48,60,42,248,22,191,20,23,197,2,249,80,144,49,8,44,42,23,204,1,248, -22,128,21,23,198,1,249,22,97,23,202,2,249,80,144,49,8,44,42,23,204, -1,248,22,128,21,23,198,1,27,250,22,161,2,23,198,1,23,199,1,11,28, -192,249,80,144,42,8,44,42,198,194,196,27,248,22,175,16,2,58,28,248,22, -159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90, -144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,49,43, -42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23, -194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,44, -43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23, -194,1,11,27,248,80,144,41,58,42,249,80,144,43,55,40,40,80,144,43,8, -45,42,27,27,250,22,161,2,23,198,2,72,108,105,110,107,115,45,102,105,108, -101,11,27,28,23,194,2,23,194,1,86,94,23,194,1,249,22,152,16,27,250, -22,161,2,23,202,2,71,115,104,97,114,101,45,100,105,114,11,28,192,192,249, -22,152,16,64,117,112,6,5,5,115,104,97,114,101,2,60,28,248,22,162,7, -23,194,2,27,248,22,142,16,23,195,1,28,248,22,159,16,23,194,2,192,249, -22,160,16,23,195,1,27,247,80,144,47,54,42,28,23,193,2,192,247,22,176, -16,28,248,22,151,8,23,194,2,27,248,22,143,16,23,195,1,28,248,22,159, -16,23,194,2,192,249,22,160,16,23,195,1,27,247,80,144,47,54,42,28,23, -193,2,192,247,22,176,16,28,248,22,134,16,23,194,2,28,248,22,159,16,23, -194,2,192,249,22,160,16,23,195,1,27,247,80,144,46,54,42,28,23,193,2, -192,247,22,176,16,192,250,22,97,248,22,92,11,28,247,22,183,16,28,247,22, -184,16,248,22,92,250,22,152,16,248,22,175,16,2,61,250,22,161,2,23,204, -2,2,59,247,22,180,8,2,60,9,9,28,247,22,184,16,250,80,144,47,8, -23,42,23,200,1,1,18,108,105,110,107,115,45,115,101,97,114,99,104,45,102, -105,108,101,115,248,22,92,23,200,1,9,248,22,129,14,23,194,1,249,22,14, -80,144,41,8,26,41,28,248,22,149,13,23,197,2,32,0,88,148,8,36,39, -44,11,9,222,11,20,20,94,88,148,8,36,39,46,11,9,223,3,33,121,23, -196,1,32,123,88,148,39,40,59,11,2,50,222,33,124,90,144,42,11,89,146, -42,39,11,248,22,155,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22, -134,16,23,194,2,28,248,22,147,16,23,194,2,249,22,154,6,23,195,1,32, -0,88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194, -2,28,248,22,147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8, -36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22, -147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11, -9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22,147,16,23,194, -2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,248, -2,123,23,194,1,11,11,11,11,32,125,88,148,8,36,40,58,11,2,50,222, -33,126,27,249,22,172,6,8,128,128,23,196,2,28,248,22,157,7,23,194,2, -9,249,22,82,23,195,1,27,249,22,172,6,8,128,128,23,199,2,28,248,22, -157,7,23,194,2,9,249,22,82,23,195,1,27,249,22,172,6,8,128,128,23, -202,2,28,248,22,157,7,23,194,2,9,249,22,82,23,195,1,27,249,22,172, -6,8,128,128,23,205,2,28,248,22,157,7,23,194,2,9,249,22,82,23,195, -1,248,2,125,23,206,1,27,249,22,172,6,8,128,128,23,196,2,28,248,22, -151,8,23,194,2,28,249,22,180,20,248,22,173,21,23,196,2,8,128,128,249, -22,1,22,163,8,249,22,82,23,197,1,27,249,22,172,6,8,128,128,23,201, -2,28,248,22,157,7,23,194,2,9,249,22,82,23,195,1,27,249,22,172,6, -8,128,128,23,204,2,28,248,22,157,7,23,194,2,9,249,22,82,23,195,1, -27,249,22,172,6,8,128,128,23,207,2,28,248,22,157,7,23,194,2,9,249, -22,82,23,195,1,27,249,22,172,6,8,128,128,23,210,2,28,248,22,157,7, -23,194,2,9,249,22,82,23,195,1,248,2,125,23,211,1,192,192,248,22,142, -6,23,194,1,20,13,144,80,144,40,8,28,40,80,144,40,8,46,42,27,28, -249,22,134,9,248,22,189,8,2,62,41,90,144,42,11,89,146,42,39,11,248, -22,155,16,23,198,2,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194, -2,28,248,22,147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8, -36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22, -147,16,23,194,2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11, -9,222,11,90,144,42,11,89,146,42,39,11,248,22,155,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,134,16,23,194,2,28,248,22,147,16,23,194, -2,249,22,154,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,90, -144,42,11,89,146,42,39,11,248,22,155,16,23,197,1,86,95,23,195,1,23, -194,1,28,248,22,134,16,23,194,2,28,248,22,147,16,23,194,2,249,22,154, -6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,248,2,123,23,194, -1,86,94,23,193,1,11,86,94,23,193,1,11,86,94,23,193,1,11,86,94, -23,193,1,11,11,28,248,22,146,16,23,195,2,27,28,249,22,134,9,248,22, -189,8,2,62,41,249,22,154,6,23,197,2,32,0,88,148,8,36,39,44,11, -9,222,11,11,86,94,28,23,194,2,248,22,156,6,23,195,1,86,94,23,194, -1,11,249,22,82,27,248,22,133,6,23,199,1,250,22,44,22,35,88,148,39, -39,8,24,11,9,223,3,33,127,20,20,94,88,148,8,36,39,46,11,9,223, -3,33,128,2,23,196,1,194,249,22,82,11,194,28,28,23,195,2,28,248,22, -84,23,196,2,248,22,179,9,249,22,132,15,39,248,22,128,21,23,199,2,11, -11,194,249,22,12,20,20,94,88,148,8,32,39,61,16,4,39,8,128,80,8, -240,0,64,0,0,39,9,224,2,3,33,129,2,23,196,1,80,144,41,8,26, -41,28,192,248,22,179,9,248,22,83,194,10,28,192,248,22,179,9,248,22,83, -194,10,86,95,28,248,22,170,12,23,198,2,27,247,22,159,12,28,249,22,149, -12,23,195,2,2,63,251,22,155,12,23,197,1,2,63,250,22,146,8,6,42, -42,101,114,114,111,114,32,114,101,97,100,105,110,103,32,99,111,108,108,101,99, -116,105,111,110,32,108,105,110,107,115,32,102,105,108,101,32,126,115,58,32,126, -97,23,201,2,248,22,166,12,23,206,2,247,22,27,86,94,23,193,1,11,11, -28,23,195,2,250,22,159,2,80,144,45,8,25,41,23,196,1,249,22,82,23, -200,1,21,17,0,0,86,95,23,195,1,23,193,1,11,28,248,22,170,12,23, -198,2,86,94,23,197,1,248,23,195,1,247,22,141,2,196,88,148,39,40,58, -8,240,0,0,0,2,9,226,0,3,2,1,33,133,2,20,20,94,248,22,157, -6,23,194,2,28,248,22,157,7,248,22,157,6,23,195,1,11,248,22,130,12, -6,30,30,101,120,112,101,99,116,101,100,32,97,32,115,105,110,103,108,101,32, -83,45,101,120,112,114,101,115,115,105,111,110,248,22,142,6,23,194,1,28,248, -22,91,193,28,28,249,22,176,20,41,248,22,96,195,10,249,22,176,20,42,248, -22,96,195,28,28,248,22,162,7,248,22,83,194,10,28,249,22,182,9,2,64, -248,22,83,195,10,249,22,182,9,2,65,248,22,83,195,28,27,248,22,105,194, -28,248,22,134,16,193,10,28,248,22,162,7,193,28,248,22,157,16,193,10,248, -22,158,16,193,11,28,248,22,90,248,22,107,194,10,248,22,141,17,248,22,114, -194,11,11,11,11,28,248,22,147,16,249,22,152,16,23,197,2,23,198,2,27, -248,22,70,248,22,138,16,23,198,1,250,22,159,2,23,197,2,23,196,2,249, -22,82,23,200,1,250,22,161,2,23,202,1,23,201,1,9,12,250,22,159,2, -23,196,1,23,198,1,249,22,82,23,199,1,23,201,1,28,28,248,22,90,248, -22,107,23,197,2,10,249,22,132,17,248,22,114,23,198,2,247,22,180,8,27, -248,22,162,16,249,22,160,16,248,22,105,23,200,2,23,198,1,28,249,22,182, -9,248,22,191,20,23,199,2,2,65,86,94,23,196,1,249,22,3,20,20,94, -88,148,8,36,40,56,11,9,224,2,3,33,138,2,23,196,1,248,22,165,16, -23,196,1,28,249,22,182,9,248,22,191,20,23,199,2,2,64,86,94,23,196, -1,86,94,28,250,22,161,2,23,197,2,11,11,11,250,22,159,2,23,197,2, -11,9,249,22,167,2,23,196,2,20,20,95,88,148,8,36,41,53,11,9,224, -2,3,33,139,2,23,196,1,23,195,1,27,248,22,70,248,22,191,20,23,199, -1,250,22,159,2,23,198,2,23,196,2,249,22,82,248,22,132,2,23,200,1, -250,22,161,2,23,203,1,23,201,1,9,12,250,22,159,2,23,196,1,23,197, -1,248,22,98,23,199,1,27,28,23,195,2,28,248,22,83,23,196,2,27,249, -22,133,6,23,197,2,68,98,105,110,97,114,121,250,22,44,22,35,88,148,8, -36,39,47,11,9,223,3,33,135,2,20,20,94,88,148,8,36,39,46,11,9, -223,3,33,136,2,23,196,1,9,9,86,94,28,28,248,22,91,23,194,2,249, -22,4,32,0,88,148,8,36,40,48,11,9,222,33,137,2,23,195,2,11,11, -248,22,130,12,6,18,18,105,108,108,45,102,111,114,109,101,100,32,99,111,110, -116,101,110,116,27,247,22,141,2,27,90,144,42,11,89,146,42,39,11,248,22, -155,16,23,200,2,192,86,96,249,22,3,20,20,94,88,148,8,36,40,57,11, -9,224,2,3,33,140,2,23,195,1,23,197,1,249,22,167,2,195,88,148,8, -36,41,51,11,9,223,3,33,141,2,250,22,159,2,80,144,47,8,25,41,23, -199,1,249,22,82,23,202,1,198,193,20,13,144,80,144,40,8,28,40,250,80, -144,43,8,47,42,23,196,2,23,198,2,11,27,250,22,161,2,80,144,44,8, -25,41,23,197,2,21,143,11,17,0,0,27,248,22,83,23,195,2,27,249,80, -144,45,8,27,42,23,198,2,23,196,2,28,249,22,184,9,23,195,2,23,196, -1,248,22,128,21,195,20,13,144,80,144,43,8,28,40,250,80,144,46,8,47, -42,23,199,2,23,201,1,23,196,2,27,20,20,95,88,148,8,36,39,55,8, -240,0,0,0,2,9,225,5,1,4,33,142,2,23,197,1,23,194,1,28,249, -22,48,23,195,2,39,20,13,144,80,144,44,46,40,26,35,80,144,8,40,47, -40,249,22,31,11,80,144,8,42,46,40,22,165,15,10,22,166,15,10,22,167, -15,10,22,168,15,11,22,169,15,11,22,173,15,10,22,172,15,11,22,174,15, -10,22,171,15,10,22,175,15,10,22,170,15,11,22,176,15,10,22,177,15,10, -22,178,15,10,22,179,15,11,22,180,15,10,22,163,15,11,247,23,193,1,250, -22,134,12,2,9,2,52,23,196,1,248,22,8,20,20,94,88,148,39,40,8, -49,16,4,8,128,6,8,128,104,8,240,0,128,0,0,39,9,224,1,2,33, -143,2,23,195,1,0,7,35,114,120,34,47,43,34,28,248,22,162,7,23,195, -2,27,249,22,130,17,2,145,2,23,197,2,28,23,193,2,28,249,22,134,4, -248,22,104,23,196,2,248,22,188,3,248,22,170,21,23,199,2,249,22,7,250, -22,184,7,23,200,1,39,248,22,104,23,199,1,23,198,1,249,22,7,250,22, -184,7,23,200,2,39,248,22,104,23,199,2,249,22,82,249,22,184,7,23,201, -1,248,22,106,23,200,1,23,200,1,86,94,23,193,1,249,22,7,23,197,1, -23,198,1,90,144,42,11,89,146,42,39,11,248,22,155,16,23,198,1,86,94, -23,195,1,28,249,22,182,9,23,195,2,2,49,86,94,23,193,1,249,22,7, -23,196,1,23,200,1,27,249,22,82,23,197,1,23,201,1,28,248,22,162,7, -23,195,2,27,249,22,130,17,2,145,2,23,197,2,28,23,193,2,28,249,22, -134,4,248,22,104,23,196,2,248,22,188,3,248,22,170,21,23,199,2,249,22, -7,250,22,184,7,23,200,1,39,248,22,104,23,199,1,23,196,1,249,22,7, -250,22,184,7,23,200,2,39,248,22,104,23,199,2,249,22,82,249,22,184,7, -23,201,1,248,22,106,23,200,1,23,198,1,86,94,23,193,1,249,22,7,23, -197,1,23,196,1,90,144,42,11,89,146,42,39,11,248,22,155,16,23,198,1, -86,94,23,195,1,28,249,22,182,9,23,195,2,2,49,86,94,23,193,1,249, -22,7,23,196,1,23,198,1,249,80,144,48,8,31,42,194,249,22,82,197,199, -28,248,22,90,23,196,2,9,28,248,22,83,23,196,2,28,248,22,152,2,248, -22,191,20,23,197,2,250,22,97,249,22,2,22,132,2,250,22,161,2,248,22, -191,20,23,204,2,23,202,2,9,250,22,161,2,248,22,191,20,23,202,2,11, -9,27,248,22,128,21,23,200,1,28,248,22,90,23,194,2,86,95,23,198,1, -23,193,1,9,28,248,22,83,23,194,2,28,248,22,152,2,248,22,191,20,23, -195,2,250,22,97,249,22,2,22,132,2,250,22,161,2,248,22,191,20,23,202, -2,23,206,2,9,250,22,161,2,248,22,191,20,23,200,2,11,9,249,80,144, -48,8,48,42,23,203,1,248,22,128,21,23,199,1,27,248,80,144,45,8,30, -42,248,22,191,20,23,196,2,250,22,97,250,22,161,2,23,199,2,23,205,2, -9,250,22,161,2,23,199,1,11,9,249,80,144,49,8,48,42,23,204,1,248, -22,128,21,23,200,1,249,22,97,247,22,179,16,249,80,144,47,8,48,42,23, -202,1,248,22,128,21,23,198,1,27,248,80,144,41,8,30,42,248,22,191,20, -23,198,2,250,22,97,250,22,161,2,23,199,2,23,201,2,9,250,22,161,2, -23,199,1,11,9,27,248,22,128,21,23,201,1,28,248,22,90,23,194,2,86, -95,23,199,1,23,193,1,9,28,248,22,83,23,194,2,28,248,22,152,2,248, -22,191,20,23,195,2,250,22,97,249,22,2,22,132,2,250,22,161,2,248,22, -191,20,23,202,2,23,207,2,9,250,22,161,2,248,22,191,20,23,200,2,11, -9,249,80,144,49,8,48,42,23,204,1,248,22,128,21,23,199,1,27,248,80, -144,46,8,30,42,248,22,191,20,23,196,2,250,22,97,250,22,161,2,23,199, -2,23,206,2,9,250,22,161,2,23,199,1,11,9,249,80,144,50,8,48,42, -23,205,1,248,22,128,21,23,200,1,249,22,97,247,22,179,16,249,80,144,48, -8,48,42,23,203,1,248,22,128,21,23,198,1,249,22,97,247,22,179,16,27, -248,22,128,21,23,199,1,28,248,22,90,23,194,2,9,28,248,22,83,23,194, -2,28,248,22,152,2,248,22,191,20,23,195,2,250,22,97,249,22,2,22,132, -2,250,22,161,2,248,22,191,20,23,202,2,23,205,2,9,250,22,161,2,248, -22,191,20,23,200,2,11,9,249,80,144,47,8,48,42,23,202,1,248,22,128, -21,23,199,1,27,248,80,144,44,8,30,42,248,22,191,20,23,196,2,250,22, -97,250,22,161,2,23,199,2,23,204,2,9,250,22,161,2,23,199,1,11,9, -249,80,144,48,8,48,42,23,203,1,248,22,128,21,23,200,1,249,22,97,247, -22,179,16,249,80,144,46,8,48,42,23,201,1,248,22,128,21,23,198,1,32, -148,2,88,148,8,36,40,50,11,2,50,222,33,149,2,28,248,22,90,248,22, -84,23,195,2,248,22,92,27,248,22,191,20,195,28,248,22,134,16,193,248,22, -138,16,193,192,250,22,93,27,248,22,191,20,23,198,2,28,248,22,134,16,193, -248,22,138,16,193,192,2,67,248,2,148,2,248,22,128,21,23,198,1,250,22, -146,8,6,7,7,10,32,126,97,32,126,97,6,1,1,32,23,196,1,249,22, -146,8,6,6,6,10,32,32,32,126,97,248,22,135,2,23,196,1,32,152,2, -88,148,39,41,51,11,68,102,105,108,116,101,114,222,33,153,2,28,248,22,90, -23,195,2,9,28,248,23,194,2,248,22,83,23,196,2,249,22,82,248,22,191, -20,23,197,2,249,2,152,2,23,197,1,248,22,128,21,23,199,1,249,2,152, -2,23,195,1,248,22,128,21,23,197,1,28,248,22,90,23,201,2,86,95,23, -200,1,23,194,1,28,23,201,2,86,97,23,199,1,23,198,1,23,197,1,23, -196,1,28,194,249,22,152,16,202,196,200,27,28,248,22,90,23,199,2,2,66, -249,22,1,22,185,7,248,2,148,2,23,201,2,248,23,198,1,251,22,146,8, -6,70,70,99,111,108,108,101,99,116,105,111,110,32,110,111,116,32,102,111,117, -110,100,10,32,32,99,111,108,108,101,99,116,105,111,110,58,32,126,115,10,32, -32,105,110,32,99,111,108,108,101,99,116,105,111,110,32,100,105,114,101,99,116, -111,114,105,101,115,58,126,97,126,97,28,248,22,90,23,204,1,28,248,22,134, -16,23,205,2,248,22,138,16,23,205,1,23,204,1,250,22,185,7,28,248,22, -134,16,23,208,2,248,22,138,16,23,208,1,23,207,1,2,67,23,201,2,249, -22,1,22,185,7,249,22,2,32,0,88,148,8,36,40,48,11,9,222,33,150, -2,19,248,22,96,23,211,2,19,248,22,96,247,22,179,16,28,249,22,135,4, -249,22,190,3,23,198,4,23,197,4,44,23,211,2,249,22,97,247,22,179,16, -248,22,92,249,22,146,8,6,50,50,46,46,46,32,91,126,97,32,97,100,100, -105,116,105,111,110,97,108,32,108,105,110,107,101,100,32,97,110,100,32,112,97, -99,107,97,103,101,32,100,105,114,101,99,116,111,114,105,101,115,93,249,22,190, -3,23,201,4,23,200,4,2,2,28,249,22,5,22,134,2,23,207,2,250,22, -146,8,6,49,49,10,32,32,32,115,117,98,45,99,111,108,108,101,99,116,105, -111,110,58,32,126,115,10,32,32,105,110,32,112,97,114,101,110,116,32,100,105, -114,101,99,116,111,114,105,101,115,58,126,97,23,201,1,249,22,1,22,185,7, -249,22,2,32,0,88,148,8,36,40,48,11,9,222,33,151,2,249,2,152,2, -22,134,2,23,214,1,86,95,23,205,1,23,198,1,2,66,27,248,22,83,23, -202,2,27,28,248,22,134,16,23,195,2,249,22,152,16,23,196,1,23,202,2, -248,22,135,2,23,195,1,28,28,248,22,134,16,248,22,191,20,23,204,2,248, -22,147,16,23,194,2,10,27,250,22,1,22,152,16,23,197,1,23,203,2,28, -28,248,22,90,23,201,2,10,248,22,147,16,23,194,2,28,23,198,2,28,28, -250,80,144,45,8,32,42,195,200,199,10,27,28,248,22,134,16,199,248,22,138, -16,199,198,19,248,22,165,7,23,195,2,27,28,249,22,180,20,23,196,4,43, -28,249,22,168,7,6,4,4,46,114,107,116,249,22,184,7,23,199,2,249,22, -190,3,23,200,4,43,249,22,185,7,250,22,184,7,23,200,1,39,249,22,190, -3,23,201,4,43,6,3,3,46,115,115,86,94,23,195,1,11,86,94,23,195, -1,11,28,23,193,2,250,80,144,48,8,32,42,198,23,196,1,202,11,2,28, -197,249,22,152,16,194,199,192,26,8,80,144,50,8,49,42,204,205,206,23,15, -23,16,23,17,248,22,128,21,23,19,28,23,19,23,19,200,192,26,8,80,144, -50,8,49,42,204,205,206,23,15,23,16,23,17,248,22,128,21,23,19,23,19, -26,8,80,144,49,8,49,42,203,204,205,206,23,15,23,16,248,22,128,21,23, -18,23,18,90,144,41,11,89,146,41,39,11,249,80,144,43,8,31,42,23,199, -1,23,200,1,27,248,22,70,28,248,22,134,16,195,248,22,138,16,195,194,27, -27,247,22,180,16,28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,28, -248,22,152,2,248,22,191,20,23,195,2,250,22,97,249,22,2,22,132,2,250, -22,161,2,248,22,191,20,23,202,2,23,203,2,9,250,22,161,2,248,22,191, -20,23,200,2,11,9,249,80,144,49,8,48,42,23,200,1,248,22,128,21,23, -199,1,27,248,80,144,46,8,30,42,248,22,191,20,23,196,2,250,22,97,250, -22,161,2,23,199,2,23,202,2,9,250,22,161,2,23,199,1,11,9,249,80, -144,50,8,48,42,23,201,1,248,22,128,21,23,200,1,249,22,97,247,22,179, -16,249,80,144,48,8,48,42,23,199,1,248,22,128,21,23,198,1,26,8,80, -144,51,8,49,42,23,17,23,16,205,203,202,200,200,11,32,156,2,88,148,8, -36,42,57,11,2,50,222,33,157,2,28,248,22,139,4,195,249,22,144,16,251, -22,163,8,250,22,162,8,202,39,248,22,156,8,203,2,51,249,22,162,8,201, -248,22,173,21,202,2,68,28,248,22,135,16,195,248,22,136,16,195,247,22,137, -16,27,248,22,188,3,196,28,28,248,22,139,4,193,11,249,22,182,9,8,46, -249,22,157,8,198,196,249,22,144,16,251,22,163,8,250,22,162,8,203,39,201, -2,69,249,22,162,8,202,248,22,187,3,201,2,68,28,248,22,135,16,196,248, -22,136,16,196,247,22,137,16,250,2,156,2,196,197,195,248,22,146,16,27,250, -22,152,16,23,198,1,23,202,1,23,199,1,28,249,22,182,9,23,199,2,66, -115,97,109,101,192,28,248,22,157,16,23,198,2,249,22,152,16,194,198,249,80, -144,46,42,42,23,195,1,23,199,1,249,22,5,20,20,96,88,148,39,40,54, -47,9,226,5,6,3,2,33,158,2,23,195,1,23,196,1,23,199,1,23,197, -1,27,248,22,146,16,249,22,152,16,23,198,2,23,199,2,28,23,193,2,192, -28,23,197,1,27,90,144,41,11,89,146,41,39,11,250,80,144,46,8,34,42, -23,202,2,2,68,2,34,27,248,22,140,16,23,196,1,27,250,2,156,2,23, -204,1,23,197,2,248,22,156,8,23,198,1,28,248,22,135,16,195,249,22,152, -16,196,194,192,27,247,22,181,16,249,22,5,20,20,96,88,148,39,40,51,47, -9,226,5,2,3,6,33,159,2,23,199,1,23,196,1,23,195,1,247,22,182, -16,11,86,95,28,248,22,135,16,23,194,2,11,28,248,22,134,16,23,194,2, -11,28,28,248,22,162,7,23,194,2,28,248,22,157,16,23,194,2,10,248,22, -158,16,23,194,2,11,11,252,22,134,12,23,200,2,2,42,39,23,198,2,23, -199,2,28,248,22,162,7,23,195,2,86,94,23,194,1,11,28,248,22,151,8, -23,195,2,86,94,23,194,1,11,252,22,134,12,23,200,2,2,70,40,23,198, -2,23,199,1,90,144,42,11,89,146,42,39,11,248,22,155,16,23,197,2,86, -94,23,195,1,86,94,28,23,193,2,86,95,23,198,1,23,196,1,11,250,22, -137,12,23,201,1,2,71,23,199,1,249,22,7,23,195,1,23,196,1,32,162, -2,88,148,8,36,45,8,23,11,2,50,222,33,163,2,28,248,22,139,4,23, -199,2,86,95,23,198,1,23,196,1,19,248,22,156,8,23,199,2,249,22,144, -16,251,22,163,8,250,22,162,8,23,207,2,39,23,202,4,2,51,249,23,204, -1,23,206,2,248,22,173,21,23,207,1,28,248,22,162,7,200,249,22,177,8, -201,8,63,199,28,248,22,135,16,197,248,22,136,16,197,247,22,137,16,2,27, -248,22,188,3,23,200,1,28,28,248,22,139,4,23,194,2,11,249,22,182,9, -8,46,249,22,157,8,23,202,2,23,197,2,249,22,144,16,251,22,163,8,250, -22,162,8,23,207,2,39,23,202,2,23,203,1,249,23,204,1,23,206,1,248, -22,187,3,23,202,1,28,248,22,162,7,200,249,22,177,8,201,8,63,199,28, -248,22,135,16,197,248,22,136,16,197,247,22,137,16,28,248,22,139,4,23,194, -2,86,95,23,197,1,23,193,1,19,248,22,156,8,23,200,2,249,22,144,16, -251,22,163,8,250,22,162,8,23,208,2,39,23,202,4,2,51,249,23,205,1, -23,207,2,248,22,173,21,23,208,1,28,248,22,162,7,201,249,22,177,8,202, -8,63,200,28,248,22,135,16,198,248,22,136,16,198,247,22,137,16,2,27,248, -22,188,3,23,195,1,28,28,248,22,139,4,23,194,2,11,249,22,182,9,8, -46,249,22,157,8,23,203,2,23,197,2,249,22,144,16,251,22,163,8,250,22, -162,8,23,208,2,39,23,202,2,23,204,1,249,23,205,1,23,207,1,248,22, -187,3,23,202,1,28,248,22,162,7,201,249,22,177,8,202,8,63,200,28,248, -22,135,16,198,248,22,136,16,198,247,22,137,16,28,248,22,139,4,23,194,2, -86,95,23,198,1,23,193,1,19,248,22,156,8,23,201,2,249,22,144,16,251, -22,163,8,250,22,162,8,23,209,2,39,23,202,4,2,51,249,23,206,1,23, -208,2,248,22,173,21,23,209,1,28,248,22,162,7,202,249,22,177,8,203,8, -63,201,28,248,22,135,16,199,248,22,136,16,199,247,22,137,16,2,27,248,22, -188,3,23,195,1,28,28,248,22,139,4,23,194,2,11,249,22,182,9,8,46, -249,22,157,8,23,204,2,23,197,2,249,22,144,16,251,22,163,8,250,22,162, -8,23,209,2,39,23,202,2,23,205,1,249,23,206,1,23,208,1,248,22,187, -3,23,202,1,28,248,22,162,7,202,249,22,177,8,203,8,63,201,28,248,22, -135,16,199,248,22,136,16,199,247,22,137,16,253,2,162,2,201,202,203,204,205, -198,90,144,41,11,89,146,41,39,11,86,95,28,248,22,135,16,23,199,2,11, -28,248,22,134,16,23,199,2,11,28,28,248,22,162,7,23,199,2,28,248,22, -157,16,23,199,2,10,248,22,158,16,23,199,2,11,11,252,22,134,12,23,200, -2,2,42,39,23,203,2,23,204,2,28,248,22,162,7,23,200,2,11,28,248, -22,151,8,23,200,2,11,252,22,134,12,23,200,2,2,70,40,23,203,2,23, -204,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23,202,2,86,94,23, -195,1,86,94,28,192,86,94,23,198,1,11,250,22,137,12,23,201,1,2,71, -23,204,2,249,22,7,194,195,27,248,22,140,16,23,196,1,27,19,248,22,156, -8,23,196,2,28,249,22,176,20,23,195,4,39,86,94,23,199,1,249,22,144, -16,251,22,163,8,250,22,162,8,23,204,2,39,248,22,173,21,23,205,2,2, -51,249,23,208,1,23,203,2,248,22,173,21,23,204,1,28,248,22,162,7,23, -16,249,22,177,8,23,17,8,63,23,15,28,248,22,135,16,203,248,22,136,16, -203,247,22,137,16,27,248,22,188,3,23,195,4,28,28,248,22,139,4,23,194, -2,11,249,22,182,9,8,46,249,22,157,8,23,200,2,23,197,2,249,22,144, -16,251,22,163,8,250,22,162,8,23,205,2,39,23,202,2,23,206,1,249,23, -209,1,23,204,1,248,22,187,3,23,202,1,28,248,22,162,7,23,17,249,22, -177,8,23,18,8,63,23,16,28,248,22,135,16,204,248,22,136,16,204,247,22, -137,16,28,248,22,139,4,23,194,2,86,95,23,200,1,23,193,1,249,22,144, -16,251,22,163,8,250,22,162,8,23,205,2,39,248,22,173,21,23,206,2,2, -51,249,23,209,1,23,204,2,248,22,173,21,23,205,1,28,248,22,162,7,23, -17,249,22,177,8,23,18,8,63,23,16,28,248,22,135,16,204,248,22,136,16, -204,247,22,137,16,27,248,22,188,3,23,195,1,28,28,248,22,139,4,23,194, -2,11,249,22,182,9,8,46,249,22,157,8,23,201,2,23,197,2,249,22,144, -16,251,22,163,8,250,22,162,8,23,206,2,39,23,202,2,23,207,1,249,23, -210,1,23,205,1,248,22,187,3,23,202,1,28,248,22,162,7,23,18,249,22, -177,8,23,19,8,63,23,17,28,248,22,135,16,205,248,22,136,16,205,247,22, -137,16,253,2,162,2,23,210,1,23,209,1,23,208,1,23,207,1,23,203,1, -23,199,1,2,28,248,22,135,16,195,249,22,152,16,196,194,192,32,165,2,88, -148,8,36,43,58,11,2,50,222,33,166,2,28,248,22,139,4,196,249,22,144, -16,251,22,163,8,250,22,162,8,203,39,248,22,156,8,204,2,51,2,51,28, -248,22,162,7,199,249,22,177,8,200,8,63,198,28,248,22,135,16,196,248,22, -136,16,196,247,22,137,16,27,248,22,188,3,197,28,28,248,22,139,4,193,11, -249,22,182,9,8,46,249,22,157,8,199,196,249,22,144,16,251,22,163,8,250, -22,162,8,204,39,201,2,51,2,51,28,248,22,162,7,200,249,22,177,8,201, -8,63,199,28,248,22,135,16,197,248,22,136,16,197,247,22,137,16,251,2,165, -2,197,198,199,196,90,144,41,11,89,146,41,39,11,86,95,28,248,22,135,16, -23,196,2,11,28,248,22,134,16,23,196,2,11,28,28,248,22,162,7,23,196, -2,28,248,22,157,16,23,196,2,10,248,22,158,16,23,196,2,11,11,252,22, -134,12,2,37,2,42,39,23,200,2,23,201,2,28,248,22,162,7,23,197,2, -11,28,248,22,151,8,23,197,2,11,252,22,134,12,2,37,2,70,40,23,200, -2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23,199,2,86, -94,23,195,1,86,94,28,192,11,250,22,137,12,2,37,2,71,23,201,2,249, -22,7,194,195,27,248,22,140,16,23,196,1,27,251,2,165,2,23,202,1,23, -201,1,23,198,2,248,22,156,8,23,199,1,28,248,22,135,16,195,249,22,152, -16,196,194,192,32,168,2,88,148,8,36,43,58,11,2,50,222,33,169,2,28, -248,22,139,4,196,249,22,144,16,251,22,163,8,250,22,162,8,203,39,248,22, -156,8,204,2,51,249,22,162,8,202,248,22,173,21,203,28,248,22,162,7,199, -249,22,177,8,200,8,63,198,28,248,22,135,16,196,248,22,136,16,196,247,22, -137,16,27,248,22,188,3,197,28,28,248,22,139,4,193,11,249,22,182,9,8, -46,249,22,157,8,199,196,249,22,144,16,251,22,163,8,250,22,162,8,204,39, -201,2,69,249,22,162,8,203,248,22,187,3,201,28,248,22,162,7,200,249,22, -177,8,201,8,63,199,28,248,22,135,16,197,248,22,136,16,197,247,22,137,16, -251,2,168,2,197,198,199,196,90,144,41,11,89,146,41,39,11,86,95,28,248, -22,135,16,23,196,2,11,28,248,22,134,16,23,196,2,11,28,28,248,22,162, -7,23,196,2,28,248,22,157,16,23,196,2,10,248,22,158,16,23,196,2,11, -11,252,22,134,12,2,34,2,42,39,23,200,2,23,201,2,28,248,22,162,7, -23,197,2,11,28,248,22,151,8,23,197,2,11,252,22,134,12,2,34,2,70, -40,23,200,2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23, -199,2,86,94,23,195,1,86,94,28,192,11,250,22,137,12,2,34,2,71,23, -201,2,249,22,7,194,195,27,248,22,140,16,23,196,1,27,251,2,168,2,23, -202,1,23,201,1,23,198,2,248,22,156,8,23,199,1,28,248,22,135,16,195, -249,22,152,16,196,194,192,249,247,22,185,5,23,195,1,11,249,247,22,185,5, -194,11,28,248,22,90,23,195,2,9,27,27,248,22,83,23,197,2,28,248,22, -159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90, -144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,50,43, -42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23, -194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,45, -43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23, -194,1,86,94,23,193,1,11,28,23,193,2,249,22,82,248,22,162,16,249,22, -160,16,23,198,1,247,22,176,16,27,248,22,128,21,23,199,1,28,248,22,90, -23,194,2,86,94,23,193,1,9,27,248,80,144,45,56,42,248,22,83,23,196, -2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22, -176,16,248,80,144,47,8,50,42,248,22,128,21,23,198,1,86,94,23,193,1, -248,80,144,45,8,50,42,248,22,128,21,23,196,1,86,94,23,193,1,27,248, -22,128,21,23,197,1,28,248,22,90,23,194,2,9,27,248,80,144,43,56,42, -248,22,83,23,196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16, -23,198,1,247,22,176,16,248,80,144,45,8,50,42,248,22,128,21,23,198,1, -86,94,23,193,1,248,80,144,43,8,50,42,248,22,128,21,23,196,1,28,248, -22,90,23,195,2,9,27,27,248,22,83,23,197,2,28,248,22,159,16,23,194, -2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90,144,42,11,89, -146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,50,43,42,248,22,175, -16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23,194,1,248,22, -162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,45,43,42,248,22, -175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23,194,1,86,94, -23,193,1,11,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198, -1,247,22,176,16,27,248,22,128,21,23,199,1,28,248,22,90,23,194,2,86, -94,23,193,1,9,27,248,80,144,45,56,42,248,22,83,23,196,2,28,23,193, -2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,248,80, -144,47,8,51,42,248,22,128,21,23,198,1,86,94,23,193,1,248,80,144,45, -8,51,42,248,22,128,21,23,196,1,86,94,23,193,1,27,248,22,128,21,23, -197,1,28,248,22,90,23,194,2,9,27,248,80,144,43,56,42,248,22,83,23, -196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247, -22,176,16,248,80,144,45,8,51,42,248,22,128,21,23,198,1,86,94,23,193, -1,248,80,144,43,8,51,42,248,22,128,21,23,196,1,27,248,22,175,16,2, -58,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16, -23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250, -80,144,49,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95, -23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27, -250,80,144,44,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248, -22,162,16,23,194,1,11,28,248,22,90,23,195,2,9,27,27,248,22,83,23, -197,2,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158, -16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16, -250,80,144,50,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86, -95,23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1, -27,250,80,144,45,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2, -248,22,162,16,23,194,1,86,94,23,193,1,11,28,23,193,2,249,22,82,248, -22,162,16,249,22,160,16,23,198,1,247,22,176,16,27,248,22,128,21,23,199, -1,28,248,22,90,23,194,2,86,94,23,193,1,9,27,27,248,22,83,23,196, -2,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1,28,248,22,158,16, -23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16,249,22,160,16,250, -80,144,54,43,42,248,22,175,16,2,56,11,11,248,22,175,16,2,57,86,95, -23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199,1,23,196,1,27, -250,80,144,49,43,42,248,22,175,16,2,56,23,197,1,10,28,23,193,2,248, -22,162,16,23,194,1,86,94,23,193,1,11,28,23,193,2,249,22,82,248,22, -162,16,249,22,160,16,23,198,1,247,22,176,16,27,248,22,128,21,23,198,1, -28,248,22,90,23,194,2,86,94,23,193,1,9,27,248,80,144,49,56,42,248, -22,83,23,196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23, -198,1,247,22,176,16,248,80,144,51,8,53,42,248,22,128,21,23,198,1,86, -94,23,193,1,248,80,144,49,8,53,42,248,22,128,21,23,196,1,86,94,23, -193,1,27,248,22,128,21,23,196,1,28,248,22,90,23,194,2,86,94,23,193, -1,9,27,248,80,144,47,56,42,248,22,83,23,196,2,28,23,193,2,249,22, -82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,248,80,144,49,8, -53,42,248,22,128,21,23,198,1,86,94,23,193,1,248,80,144,47,8,53,42, -248,22,128,21,23,196,1,86,94,23,193,1,27,248,22,128,21,23,197,1,28, -248,22,90,23,194,2,9,27,27,248,22,83,23,196,2,28,248,22,159,16,23, -194,2,248,22,162,16,23,194,1,28,248,22,158,16,23,194,2,90,144,42,11, -89,146,42,39,11,248,22,155,16,249,22,160,16,250,80,144,52,43,42,248,22, -175,16,2,56,11,11,248,22,175,16,2,57,86,95,23,195,1,23,194,1,248, -22,162,16,249,22,160,16,23,199,1,23,196,1,27,250,80,144,47,43,42,248, -22,175,16,2,56,23,197,1,10,28,23,193,2,248,22,162,16,23,194,1,86, -94,23,193,1,11,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23, -198,1,247,22,176,16,27,248,22,128,21,23,198,1,28,248,22,90,23,194,2, -86,94,23,193,1,9,27,248,80,144,47,56,42,248,22,83,23,196,2,28,23, -193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,248, -80,144,49,8,53,42,248,22,128,21,23,198,1,86,94,23,193,1,248,80,144, -47,8,53,42,248,22,128,21,23,196,1,86,94,23,193,1,27,248,22,128,21, -23,196,1,28,248,22,90,23,194,2,9,27,248,80,144,45,56,42,248,22,83, -23,196,2,28,23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1, -247,22,176,16,248,80,144,47,8,53,42,248,22,128,21,23,198,1,86,94,23, -193,1,248,80,144,45,8,53,42,248,22,128,21,23,196,1,27,247,22,183,16, -27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43,44,41,28,23, -196,2,27,249,22,184,8,247,22,183,8,2,72,28,192,249,22,174,8,194,7, -63,2,66,2,66,250,80,144,46,8,23,42,23,198,2,2,73,27,28,23,200, -1,250,22,152,16,248,22,175,16,2,61,250,22,161,2,23,205,1,2,59,247, -22,180,8,2,74,86,94,23,199,1,11,27,248,80,144,49,8,50,42,250,22, -97,9,248,22,92,248,22,175,16,2,55,9,28,193,249,22,82,195,194,192,27, -247,22,183,16,27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43, -44,41,28,23,196,2,27,249,22,184,8,247,22,183,8,2,72,28,192,249,22, -174,8,194,7,63,2,66,2,66,250,80,144,46,8,23,42,23,198,2,2,73, -27,28,23,200,1,250,22,152,16,248,22,175,16,2,61,250,22,161,2,23,205, -1,2,59,247,22,180,8,2,74,86,94,23,199,1,11,27,248,80,144,49,8, -51,42,250,22,97,23,207,1,248,22,92,248,22,175,16,2,55,9,28,193,249, -22,82,195,194,192,27,247,22,183,16,27,248,80,144,42,58,42,249,80,144,44, -55,40,40,80,144,44,8,52,42,249,80,144,43,44,41,28,23,196,2,27,249, -22,184,8,247,22,183,8,2,72,28,192,249,22,174,8,194,7,63,2,66,2, -66,250,80,144,46,8,23,42,23,198,2,2,73,27,28,23,200,1,250,22,152, -16,248,22,175,16,2,61,250,22,161,2,23,205,1,2,59,247,22,180,8,2, -74,86,94,23,199,1,11,27,27,250,22,97,23,207,1,248,22,92,248,22,175, -16,2,55,23,208,1,28,248,22,90,23,194,2,86,94,23,193,1,9,27,27, -248,22,83,23,196,2,28,248,22,159,16,23,194,2,248,22,162,16,23,194,1, -28,248,22,158,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,155,16, -249,22,160,16,250,80,144,60,43,42,248,22,175,16,2,56,11,11,248,22,175, -16,2,57,86,95,23,195,1,23,194,1,248,22,162,16,249,22,160,16,23,199, -1,23,196,1,27,250,80,144,55,43,42,248,22,175,16,2,56,23,197,1,10, -28,23,193,2,248,22,162,16,23,194,1,86,94,23,193,1,11,28,23,193,2, -249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16,27,248,22, -128,21,23,198,1,28,248,22,90,23,194,2,86,94,23,193,1,9,27,248,80, -144,55,56,42,248,22,83,23,196,2,28,23,193,2,249,22,82,248,22,162,16, -249,22,160,16,23,198,1,247,22,176,16,248,80,144,57,8,53,42,248,22,128, -21,23,198,1,86,94,23,193,1,248,80,144,55,8,53,42,248,22,128,21,23, -196,1,86,94,23,193,1,27,248,22,128,21,23,196,1,28,248,22,90,23,194, -2,86,94,23,193,1,9,27,248,80,144,53,56,42,248,22,83,23,196,2,28, -23,193,2,249,22,82,248,22,162,16,249,22,160,16,23,198,1,247,22,176,16, -248,80,144,55,8,53,42,248,22,128,21,23,198,1,86,94,23,193,1,248,80, -144,53,8,53,42,248,22,128,21,23,196,1,28,193,249,22,82,195,194,192,27, -20,13,144,80,144,40,46,40,26,9,80,144,49,47,40,249,22,31,11,80,144, -51,46,40,22,172,15,10,22,179,15,10,22,180,15,10,22,181,15,10,248,22, -157,6,23,196,2,28,248,22,157,7,23,194,2,12,86,94,248,22,191,9,23, -194,1,27,20,13,144,80,144,41,46,40,26,9,80,144,50,47,40,249,22,31, -11,80,144,52,46,40,22,172,15,10,22,179,15,10,22,180,15,10,22,181,15, -10,248,22,157,6,23,197,2,28,248,22,157,7,23,194,2,12,86,94,248,22, -191,9,23,194,1,27,20,13,144,80,144,42,46,40,26,9,80,144,51,47,40, -249,22,31,11,80,144,53,46,40,22,172,15,10,22,179,15,10,22,180,15,10, -22,181,15,10,248,22,157,6,23,198,2,28,248,22,157,7,23,194,2,12,86, -94,248,22,191,9,23,194,1,248,80,144,43,8,54,42,197,86,94,249,22,148, -7,247,22,181,5,23,195,2,248,22,172,6,249,22,142,4,39,249,22,190,3, -23,199,1,23,198,1,27,248,22,134,6,28,23,198,2,23,198,1,86,94,23, -198,1,27,250,80,144,45,43,42,248,22,175,16,2,56,11,11,27,248,22,145, -4,23,199,1,27,28,23,194,2,23,194,1,86,94,23,194,1,39,27,248,22, -145,4,23,202,1,27,28,23,194,2,23,194,1,86,94,23,194,1,39,249,22, -149,6,23,199,1,20,20,95,88,148,8,36,39,51,11,9,224,2,4,33,181, -2,23,197,1,23,195,1,248,80,144,41,8,54,42,193,145,40,9,20,122,145, -2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11, -11,11,11,11,9,9,11,11,11,10,47,80,143,39,39,20,122,145,2,1,54, -16,40,2,3,2,4,2,5,2,6,2,7,2,8,2,9,30,2,11,1,20, -112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11, -5,30,2,11,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101, -114,105,122,97,116,105,111,110,11,4,2,12,2,13,2,14,2,15,2,16,2, -17,2,18,30,2,11,1,19,99,97,99,104,101,45,99,111,110,102,105,103,117, -114,97,116,105,111,110,11,1,2,19,2,20,2,21,2,22,2,23,2,24,2, -25,2,26,2,27,2,28,2,29,30,2,11,1,21,101,120,99,101,112,116,105, -111,110,45,104,97,110,100,108,101,114,45,107,101,121,11,3,2,30,2,31,2, -32,2,33,2,34,2,35,2,36,2,37,2,38,2,39,2,40,16,0,40,42, -39,16,0,39,16,19,2,13,2,14,2,12,2,25,2,4,2,35,2,23,2, -24,2,19,2,29,2,33,2,21,2,22,2,31,2,27,2,30,2,32,2,36, -2,28,58,11,11,11,16,17,2,9,2,17,2,15,2,40,2,16,2,7,2, -26,2,39,2,18,2,20,2,38,2,5,2,34,2,8,2,37,2,3,2,6, -16,17,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,16,17, -2,9,2,17,2,15,2,40,2,16,2,7,2,26,2,39,2,18,2,20,2, -38,2,5,2,34,2,8,2,37,2,3,2,6,56,56,40,12,11,11,16,0, -16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16,51,20, -15,16,2,32,0,88,148,8,36,40,47,11,2,3,222,33,75,80,144,39,39, -40,20,15,16,2,249,22,164,7,7,92,7,92,80,144,39,40,40,20,15,16, -2,88,148,8,36,40,57,41,2,5,223,0,33,80,80,144,39,41,40,20,15, -16,2,88,148,8,36,41,61,41,2,6,223,0,33,82,80,144,39,42,40,20, -15,16,2,20,26,96,2,7,88,148,8,36,42,8,24,8,32,9,223,0,33, -89,88,148,8,36,41,50,55,9,223,0,33,90,88,148,8,36,40,49,55,9, -223,0,33,91,80,144,39,43,40,20,15,16,2,27,248,22,188,16,248,22,176, -8,27,28,249,22,182,9,247,22,189,8,2,43,6,1,1,59,6,1,1,58, -250,22,146,8,6,14,14,40,91,94,126,97,93,42,41,126,97,40,46,42,41, -23,196,2,23,196,1,88,148,8,36,41,51,11,2,8,223,0,33,95,80,144, -39,44,40,20,15,16,2,88,148,39,40,8,44,8,128,6,2,9,223,0,33, -96,80,144,39,45,40,20,15,16,2,32,0,88,148,8,36,41,50,11,2,12, -222,33,97,80,144,39,48,40,20,15,16,2,32,0,88,148,8,36,42,51,11, -2,13,222,33,99,80,144,39,49,40,20,15,16,2,32,0,88,148,8,36,41, -49,11,2,14,222,33,100,80,144,39,50,40,20,15,16,2,88,148,39,42,53, -8,128,128,2,15,223,0,33,102,80,144,39,51,40,20,15,16,2,88,148,39, -44,55,8,128,128,2,17,223,0,33,104,80,144,39,53,40,20,15,16,2,88, -148,39,39,56,55,9,223,0,33,105,80,144,39,8,40,42,20,15,16,2,88, -148,39,39,47,16,4,39,40,8,128,4,39,2,18,223,0,33,106,80,144,39, -54,40,20,15,16,2,88,148,39,39,56,55,9,223,0,33,107,80,144,39,8, -41,42,20,15,16,2,88,148,39,39,47,16,4,39,40,8,128,8,39,2,20, -223,0,33,108,80,144,39,57,40,20,15,16,2,88,148,8,36,39,8,44,8, -128,6,9,223,0,33,109,80,144,39,8,42,42,20,15,16,2,88,148,8,36, -40,50,16,4,39,39,8,128,16,39,2,21,223,0,33,110,80,144,39,58,40, -20,15,16,2,20,28,143,32,0,88,148,39,40,48,11,2,22,222,33,111,32, -0,88,148,39,40,48,11,2,22,222,33,112,80,144,39,59,40,20,15,16,2, -88,148,8,36,40,50,8,240,0,128,0,0,2,23,223,0,33,113,80,144,39, -60,40,20,15,16,2,88,148,39,39,56,55,9,223,0,33,114,80,144,39,8, -43,42,20,15,16,2,88,148,8,36,40,51,16,4,39,40,8,128,32,39,2, -24,223,0,33,115,80,144,39,61,40,20,15,16,2,88,148,39,40,56,55,2, -19,223,0,33,116,80,144,39,56,40,20,15,16,2,88,148,8,36,41,58,16, -4,8,240,0,128,0,0,8,32,8,128,64,39,2,50,223,0,33,117,80,144, -39,8,44,42,20,15,16,2,88,148,8,36,42,52,16,4,39,39,8,128,64, -39,2,25,223,0,33,118,80,144,39,8,23,40,20,15,16,2,88,148,39,39, -56,55,9,223,0,33,119,80,144,39,8,45,42,20,15,16,2,88,148,8,36, -39,57,16,4,8,240,0,128,0,0,8,137,2,8,128,128,39,2,26,223,0, -33,120,80,144,39,8,24,40,20,15,16,2,247,22,143,2,80,144,39,8,25, -40,20,15,16,2,248,22,16,67,115,116,97,109,112,80,144,39,8,26,40,20, -15,16,2,88,148,39,40,49,8,240,0,0,0,4,9,223,0,33,122,80,144, -39,8,46,42,20,15,16,2,88,148,39,41,51,16,4,39,8,128,80,8,240, -0,64,0,0,39,2,29,223,0,33,130,2,80,144,39,8,27,40,20,15,16, -2,20,28,143,32,0,88,148,8,36,40,47,11,2,30,222,33,131,2,32,0, -88,148,8,36,40,47,11,2,30,222,33,132,2,80,144,39,8,29,40,20,15, -16,2,88,148,8,36,42,48,8,240,0,0,0,2,74,109,97,107,101,45,104, -97,110,100,108,101,114,223,0,33,134,2,80,144,39,8,47,42,20,15,16,2, -88,148,39,40,47,16,4,8,128,6,8,128,104,8,240,0,128,0,0,39,2, -31,223,0,33,144,2,80,144,39,8,30,40,20,15,16,2,88,148,39,41,59, -16,2,39,8,240,0,128,0,0,2,32,223,0,33,146,2,80,144,39,8,31, -40,20,15,16,2,88,148,8,36,41,61,16,4,39,8,240,0,64,0,0,39, -40,2,50,223,0,33,147,2,80,144,39,8,48,42,20,15,16,2,88,148,39, -47,8,33,16,4,39,39,40,41,67,99,108,111,111,112,223,0,33,154,2,80, -144,39,8,49,42,20,15,16,2,88,148,39,44,8,25,16,4,39,8,240,0, -192,0,0,39,42,2,16,223,0,33,155,2,80,144,39,52,40,20,15,16,2, -88,148,39,42,58,16,4,47,39,43,39,2,33,223,0,33,160,2,80,144,39, -8,32,40,20,15,16,2,32,0,88,148,39,42,53,11,2,35,222,33,161,2, -80,144,39,8,34,40,20,15,16,2,32,0,88,148,8,36,44,8,26,11,2, -36,222,33,164,2,80,144,39,8,35,40,20,15,16,2,32,0,88,148,8,36, -41,55,11,2,37,222,33,167,2,80,144,39,8,36,40,20,15,16,2,32,0, -88,148,8,36,41,55,11,2,34,222,33,170,2,80,144,39,8,33,40,20,15, -16,2,20,28,143,32,0,88,148,39,40,47,11,2,38,222,33,171,2,32,0, -88,148,39,40,47,11,2,38,222,33,172,2,80,144,39,8,37,40,20,15,16, -2,88,148,8,36,40,58,16,4,55,41,39,43,2,50,223,0,33,173,2,80, -144,39,8,50,42,20,15,16,2,88,148,8,36,40,58,16,4,55,41,39,47, -2,50,223,0,33,174,2,80,144,39,8,51,42,20,15,16,2,88,148,39,39, -56,55,9,223,0,33,175,2,80,144,39,8,52,42,20,15,16,2,88,148,8, -36,40,8,23,16,4,55,41,39,8,32,2,50,223,0,33,176,2,80,144,39, -8,53,42,20,15,16,2,20,26,96,2,39,88,148,39,39,60,16,4,8,32, -8,140,2,39,43,9,223,0,33,177,2,88,148,39,40,61,16,4,8,32,8, -140,2,39,47,9,223,0,33,178,2,88,148,39,41,8,30,16,4,8,48,8, -139,2,39,8,48,9,223,0,33,179,2,80,144,39,8,38,40,20,15,16,2, -88,148,8,36,40,60,16,4,8,128,6,39,39,8,64,2,50,223,0,33,180, -2,80,144,39,8,54,42,20,15,16,2,88,148,8,36,42,57,16,4,55,39, -39,8,64,2,40,223,0,33,182,2,80,144,39,8,39,40,95,29,94,2,10, -70,35,37,107,101,114,110,101,108,11,29,94,2,10,71,35,37,109,105,110,45, -115,116,120,11,2,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 19016); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,50,46,48,46,52,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0,23, -0,48,0,65,0,83,0,105,0,128,0,149,0,171,0,181,0,191,0,199,0, -209,0,217,0,0,0,253,1,0,0,3,1,5,105,110,115,112,48,76,35,37, -112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116,114,117,99,116,58, -84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,78,84,72,45,112, -108,97,99,101,45,99,104,97,110,110,101,108,79,84,72,45,112,108,97,99,101, -45,99,104,97,110,110,101,108,63,1,20,84,72,45,112,108,97,99,101,45,99, -104,97,110,110,101,108,45,114,101,102,1,21,84,72,45,112,108,97,99,101,45, -99,104,97,110,110,101,108,45,115,101,116,33,1,19,84,72,45,112,108,97,99, -101,45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45,112,108,97,99, -101,45,99,104,97,110,110,101,108,45,111,117,116,249,80,144,41,42,42,23,196, -1,39,249,80,144,41,42,42,23,196,1,39,249,80,144,41,42,42,195,39,249, -80,144,41,42,42,23,196,1,40,249,80,144,41,42,42,195,40,145,40,9,20, -122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11, -11,11,11,11,11,11,9,9,11,11,11,10,49,80,143,39,39,20,122,145,2, -1,39,16,7,2,3,2,4,2,5,2,6,2,7,2,8,2,9,16,0,40, -42,39,16,0,39,16,2,2,6,2,7,41,11,11,11,16,5,2,4,2,8, -2,9,2,5,2,3,16,5,11,11,11,11,11,16,5,2,4,2,8,2,9, -2,5,2,3,44,44,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11, -11,16,0,16,0,16,0,39,39,16,3,20,15,16,6,253,22,141,11,2,4, -11,41,39,11,248,22,92,249,22,82,22,189,10,88,148,39,40,48,47,9,223, -9,33,10,80,144,39,39,40,80,144,39,40,40,80,144,39,41,40,80,144,39, -42,40,80,144,39,43,40,20,15,16,2,20,28,143,88,148,39,40,48,47,9, -223,0,33,11,88,148,39,40,48,47,9,223,0,33,12,80,144,39,44,40,20, -15,16,2,20,28,143,88,148,39,40,48,47,9,223,0,33,13,88,148,39,40, -48,47,9,223,0,33,14,80,144,39,45,40,93,29,94,67,113,117,111,116,101, -70,35,37,107,101,114,110,101,108,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 582); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,50,46,48,46,52,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,102,0,0,0,1,0,0,8,0,15, -0,26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0,171,0, -186,0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103,1,108, -1,113,1,131,1,137,1,142,1,147,1,156,1,162,1,167,1,171,1,186,1, -191,1,198,1,202,1,207,1,214,1,221,1,232,1,240,1,50,2,116,2,191, -2,10,3,116,3,159,3,9,4,52,4,149,4,192,4,33,5,76,5,9,13, -39,13,90,13,165,13,181,13,197,13,211,13,227,13,46,14,62,14,78,14,94, -14,169,14,76,15,92,15,167,15,162,16,42,17,117,17,24,18,37,18,190,18, -118,19,161,19,243,19,115,20,176,20,184,20,195,20,229,21,76,22,89,22,10, -23,17,23,177,23,21,24,43,24,53,24,67,24,105,24,204,24,208,24,215,24, -165,25,187,34,240,34,8,35,32,35,0,0,113,39,0,0,3,1,5,105,110, -115,112,48,68,35,37,98,111,111,116,72,100,108,108,45,115,117,102,102,105,120, -1,25,100,101,102,97,117,108,116,45,108,111,97,100,47,117,115,101,45,99,111, -109,112,105,108,101,100,67,113,117,111,116,101,29,94,2,5,70,35,37,112,97, -114,97,109,122,11,29,94,2,5,69,35,37,117,116,105,108,115,11,1,24,45, -109,111,100,117,108,101,45,104,97,115,104,45,116,97,98,108,101,45,116,97,98, -108,101,78,114,101,103,105,115,116,101,114,45,122,111,45,112,97,116,104,1,20, -100,101,102,97,117,108,116,45,114,101,97,100,101,114,45,103,117,97,114,100,69, -67,65,67,72,69,45,78,73,45,112,97,116,104,45,99,97,99,104,101,76,112, -97,116,104,45,99,97,99,104,101,45,103,101,116,77,112,97,116,104,45,99,97, -99,104,101,45,115,101,116,33,79,45,108,111,97,100,105,110,103,45,102,105,108, -101,110,97,109,101,1,19,45,108,111,97,100,105,110,103,45,112,114,111,109,112, -116,45,116,97,103,73,45,112,114,101,118,45,114,101,108,116,111,77,45,112,114, -101,118,45,114,101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114, -101,108,97,116,105,118,101,45,115,116,114,105,110,103,1,22,102,111,114,109,97, -116,45,115,111,117,114,99,101,45,108,111,99,97,116,105,111,110,73,111,114,105, -103,45,112,97,114,97,109,122,1,29,115,116,97,110,100,97,114,100,45,109,111, -100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,66,98,111, -111,116,66,115,101,97,108,79,108,111,97,100,47,117,115,101,45,99,111,109,112, -105,108,101,100,5,4,46,114,107,116,66,115,97,109,101,5,3,46,122,111,6, -6,6,110,97,116,105,118,101,67,105,108,111,111,112,66,108,111,111,112,65,108, -105,98,6,12,12,109,111,100,117,108,101,45,112,97,116,104,63,6,2,2,46, -46,68,115,117,98,109,111,100,6,1,1,46,66,102,105,108,101,68,112,108,97, -110,101,116,6,4,4,46,114,107,116,6,8,8,109,97,105,110,46,114,107,116, -69,105,103,110,111,114,101,100,250,22,152,16,28,249,22,182,9,23,201,2,2, -27,86,94,23,199,1,23,197,1,28,248,22,157,16,23,200,2,249,22,152,16, -23,199,1,23,201,1,249,80,144,46,45,42,23,199,1,23,201,1,23,200,1, -249,80,144,46,46,42,23,198,1,2,28,250,22,152,16,28,249,22,182,9,23, -201,2,2,27,86,94,23,199,1,23,197,1,28,248,22,157,16,23,200,2,249, -22,152,16,23,199,1,23,201,1,249,80,144,46,45,42,23,199,1,23,201,1, -23,200,1,249,80,144,46,46,42,23,198,1,2,28,252,22,152,16,28,249,22, -182,9,23,203,2,2,27,86,94,23,201,1,23,199,1,28,248,22,157,16,23, -202,2,249,22,152,16,23,201,1,23,203,1,249,80,144,48,45,42,23,201,1, -23,203,1,23,202,1,2,29,247,22,190,8,249,80,144,48,46,42,23,200,1, -80,144,48,39,41,252,22,152,16,28,249,22,182,9,23,203,2,2,27,86,94, -23,201,1,23,199,1,28,248,22,157,16,23,202,2,249,22,152,16,23,201,1, -23,203,1,249,80,144,48,45,42,23,201,1,23,203,1,23,202,1,2,29,247, -22,190,8,249,80,144,48,46,42,23,200,1,80,144,48,39,41,27,252,22,152, -16,28,249,22,182,9,23,205,2,2,27,86,94,23,203,1,23,201,1,28,248, -22,157,16,23,204,2,249,22,152,16,23,203,1,23,205,1,249,80,144,52,45, -42,23,203,1,23,205,1,23,205,1,2,29,247,22,190,8,249,80,144,52,46, -42,23,202,1,80,144,52,39,41,27,250,22,170,16,196,11,32,0,88,148,8, -36,39,44,11,9,222,11,28,192,249,22,82,195,28,196,194,39,11,249,22,5, -20,20,98,88,148,8,36,40,59,8,129,3,9,228,7,8,6,4,3,2,33, -46,23,195,1,23,196,1,23,197,1,23,199,1,23,201,1,23,198,1,27,252, -22,152,16,28,249,22,182,9,23,205,2,2,27,86,94,23,203,1,23,201,1, -28,248,22,157,16,23,204,2,249,22,152,16,23,203,1,23,205,1,249,80,144, -52,45,42,23,203,1,23,205,1,23,205,1,2,29,247,22,190,8,249,80,144, -52,46,42,23,202,1,80,144,52,39,41,27,250,22,170,16,196,11,32,0,88, -148,8,36,39,44,11,9,222,11,28,192,249,22,82,195,28,196,194,39,11,249, -22,5,20,20,98,88,148,8,36,40,59,8,129,3,9,228,7,8,6,4,3, -2,33,48,23,195,1,23,196,1,23,197,1,23,199,1,23,201,1,23,198,1, -27,250,22,152,16,28,249,22,182,9,23,203,2,2,27,86,94,23,201,1,23, -199,1,28,248,22,157,16,23,202,2,249,22,152,16,23,201,1,23,203,1,249, -80,144,50,45,42,23,201,1,23,203,1,23,203,1,249,80,144,50,46,42,23, -200,1,2,28,27,250,22,170,16,196,11,32,0,88,148,8,36,39,44,11,9, -222,11,28,192,249,22,82,195,28,196,194,39,11,249,22,5,20,20,98,88,148, -8,36,40,57,8,128,3,9,228,7,8,6,4,3,2,33,50,23,195,1,23, -196,1,23,197,1,23,199,1,23,201,1,23,198,1,27,250,22,152,16,28,249, -22,182,9,23,203,2,2,27,86,94,23,201,1,23,199,1,28,248,22,157,16, -23,202,2,249,22,152,16,23,201,1,23,203,1,249,80,144,50,45,42,23,201, -1,23,203,1,23,203,1,249,80,144,50,46,42,23,200,1,2,28,27,250,22, -170,16,196,11,32,0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,82, -195,28,196,194,39,11,249,22,5,20,20,98,88,148,8,36,40,57,8,128,3, -9,228,7,8,6,4,3,2,33,52,23,195,1,23,196,1,23,197,1,23,199, -1,23,201,1,23,198,1,86,95,28,248,80,144,41,43,42,23,196,2,11,250, -22,134,12,2,25,6,12,12,112,97,116,104,45,115,116,114,105,110,103,63,23, -198,2,28,23,196,2,28,28,248,22,66,23,197,2,10,28,248,22,91,23,197, -2,28,249,22,178,20,248,22,96,23,199,2,40,28,28,248,22,66,248,22,83, -23,198,2,10,248,22,179,9,248,22,83,23,198,2,249,22,4,22,66,248,22, -84,23,199,2,11,11,11,11,250,22,134,12,2,25,6,71,71,40,111,114,47, -99,32,35,102,32,115,121,109,98,111,108,63,32,40,99,111,110,115,47,99,32, -40,111,114,47,99,32,35,102,32,115,121,109,98,111,108,63,41,32,40,110,111, -110,45,101,109,112,116,121,45,108,105,115,116,111,102,32,115,121,109,98,111,108, -63,41,41,41,23,198,2,11,27,28,23,197,2,247,22,134,5,11,27,28,23, -194,2,250,22,161,2,80,143,45,44,248,22,153,17,247,22,165,14,11,11,27, -28,23,194,2,250,22,161,2,248,22,84,23,198,2,23,198,2,11,11,28,23, -193,2,86,97,23,198,1,23,196,1,23,195,1,23,194,1,20,13,144,80,144, -43,41,40,250,80,144,46,42,40,249,22,31,11,80,144,48,41,40,22,135,5, -248,22,105,23,197,2,27,248,22,114,23,195,2,20,13,144,80,144,44,41,40, -250,80,144,47,42,40,249,22,31,11,80,144,49,41,40,22,186,5,28,248,22, -134,16,23,197,2,23,196,1,86,94,23,196,1,247,22,176,16,249,247,22,184, -5,248,22,191,20,23,197,1,23,202,1,86,94,23,193,1,27,28,248,22,159, -16,23,200,2,23,199,2,27,247,22,186,5,28,192,249,22,160,16,23,202,2, -194,23,200,2,90,144,42,11,89,146,42,39,11,248,22,155,16,23,203,1,86, -94,23,195,1,90,144,41,11,89,146,41,39,11,28,23,205,2,27,248,22,139, -16,23,198,2,19,248,22,156,8,194,28,28,249,22,180,20,23,195,4,43,249, -22,159,8,2,26,249,22,162,8,197,249,22,190,3,23,199,4,43,11,249,22, -7,23,200,2,248,22,143,16,249,22,163,8,250,22,162,8,201,39,249,22,190, -3,23,203,4,43,5,3,46,115,115,249,22,7,23,200,2,11,2,249,22,7, -23,198,2,11,27,28,249,22,182,9,23,196,2,23,199,2,23,199,2,249,22, -152,16,23,198,2,23,196,2,27,28,23,196,2,28,249,22,182,9,23,198,2, -23,200,1,23,200,1,86,94,23,200,1,249,22,152,16,23,199,2,23,198,2, -86,95,23,200,1,23,198,1,11,27,28,249,22,182,9,23,200,2,70,114,101, -108,97,116,105,118,101,86,94,23,198,1,2,27,23,198,1,27,247,22,181,16, -27,247,22,182,16,27,27,250,22,170,16,23,202,2,11,32,0,88,148,8,36, -39,44,11,9,222,11,28,192,249,22,82,23,201,2,28,23,211,2,194,39,11, -27,28,23,198,2,28,23,194,2,11,27,250,22,170,16,23,202,2,11,32,0, -88,148,8,36,39,44,11,9,222,11,28,192,249,22,82,23,201,2,28,23,212, -2,194,39,11,11,27,28,23,195,2,23,195,2,23,194,2,27,88,148,8,36, -41,54,8,128,3,64,122,111,225,19,6,9,33,42,27,88,148,8,36,41,54, -8,128,3,68,97,108,116,45,122,111,225,20,7,11,33,43,27,88,148,8,36, -41,56,8,129,3,9,225,21,8,11,33,44,27,88,148,8,36,41,56,8,129, -3,9,225,22,9,13,33,45,27,28,23,200,2,23,200,2,248,22,179,9,23, -200,2,27,28,23,208,2,28,23,200,2,86,94,23,201,1,23,200,2,248,22, -179,9,23,202,1,86,94,23,201,1,11,27,28,23,195,2,27,249,22,5,20, -20,94,88,148,39,40,53,8,129,3,9,228,28,7,14,15,18,27,33,47,23, -200,1,23,206,2,27,28,23,202,2,11,193,28,192,192,28,193,28,23,202,2, -28,249,22,138,4,248,22,84,196,248,22,84,23,205,2,193,11,11,11,86,94, -23,197,1,11,28,23,193,2,86,109,23,217,1,23,216,1,23,215,1,23,209, -1,23,208,1,23,207,1,23,206,1,23,204,1,23,203,1,23,201,1,23,200, -1,23,199,1,23,198,1,23,196,1,23,195,1,23,194,1,20,13,144,80,144, -8,25,41,40,250,80,144,8,28,42,40,249,22,31,11,80,144,8,30,41,40, -22,135,5,11,20,13,144,80,144,8,25,41,40,250,80,144,8,28,42,40,249, -22,31,11,80,144,8,30,41,40,22,186,5,28,248,22,134,16,23,209,2,23, -208,1,86,94,23,208,1,247,22,176,16,249,247,22,187,16,248,22,83,23,196, -1,23,222,1,86,94,23,193,1,27,28,23,195,2,27,249,22,5,20,20,94, -88,148,39,40,53,8,129,3,9,228,29,7,15,16,20,28,33,49,23,200,1, -23,207,2,27,28,23,204,2,11,193,28,192,86,94,23,204,1,192,28,193,28, -203,28,249,22,138,4,248,22,84,196,248,22,84,206,193,11,11,11,86,94,23, -197,1,11,28,23,193,2,86,106,23,218,1,23,217,1,23,216,1,23,210,1, -23,209,1,23,208,1,23,205,1,23,204,1,23,201,1,23,200,1,23,199,1, -23,196,1,23,195,1,20,13,144,80,144,8,26,41,40,250,80,144,8,29,42, -40,249,22,31,11,80,144,8,31,41,40,22,135,5,23,210,1,20,13,144,80, -144,8,26,41,40,250,80,144,8,29,42,40,249,22,31,11,80,144,8,31,41, -40,22,186,5,28,248,22,134,16,23,210,2,23,209,1,86,94,23,209,1,247, -22,176,16,249,247,22,187,16,248,22,83,23,196,1,23,223,1,86,94,23,193, -1,27,28,23,197,2,27,249,22,5,20,20,95,88,148,39,40,53,8,128,3, -9,228,30,11,16,17,20,29,33,51,23,213,1,23,204,1,23,208,2,27,28, -23,204,2,11,193,28,192,192,28,193,28,23,204,2,28,249,22,138,4,248,22, -84,196,248,22,84,23,207,2,193,11,11,11,86,95,23,210,1,23,201,1,11, -28,23,193,2,86,103,23,219,1,23,211,1,23,209,1,23,208,1,23,206,1, -23,205,1,23,202,1,23,200,1,23,197,1,23,196,1,86,94,252,80,143,8, -32,47,23,223,1,23,222,1,248,22,83,23,199,2,11,23,212,2,20,13,144, -80,144,8,27,41,40,250,80,144,8,30,42,40,249,22,31,11,80,144,8,32, -41,40,22,135,5,11,20,13,144,80,144,8,27,41,40,250,80,144,8,30,42, -40,249,22,31,11,80,144,8,32,41,40,22,186,5,28,248,22,134,16,23,211, -2,23,210,1,86,94,23,210,1,247,22,176,16,249,247,22,184,5,248,22,191, -20,23,196,1,23,224,32,0,0,0,1,86,94,23,193,1,27,28,23,197,1, -27,249,22,5,20,20,97,88,148,39,40,53,8,128,3,9,228,31,11,17,18, -22,30,33,53,23,223,1,23,215,1,23,210,1,23,204,1,23,209,1,27,28, -23,205,2,11,193,28,192,86,94,23,205,1,192,28,193,28,204,28,249,22,138, -4,248,22,84,196,248,22,84,23,15,193,11,11,11,86,98,23,220,1,23,212, -1,23,207,1,23,206,1,23,201,1,11,28,23,193,2,86,95,23,210,1,23, -198,1,86,94,252,80,143,8,33,47,23,224,32,0,0,0,1,23,223,1,248, -22,83,23,199,2,23,214,2,23,213,2,20,13,144,80,144,8,28,41,40,250, -80,144,8,31,42,40,249,22,31,11,80,144,8,33,41,40,22,135,5,23,212, -1,20,13,144,80,144,8,28,41,40,250,80,144,8,31,42,40,249,22,31,11, -80,144,8,33,41,40,22,186,5,28,248,22,134,16,23,212,2,23,211,1,86, -94,23,211,1,247,22,176,16,249,247,22,184,5,248,22,191,20,23,196,1,23, -224,33,0,0,0,1,86,96,23,219,1,23,218,1,23,193,1,28,28,248,22, -80,23,224,32,0,0,0,2,248,22,191,20,23,224,32,0,0,0,2,10,27, -28,23,199,2,86,94,23,210,1,23,211,1,86,94,23,211,1,23,210,1,28, -28,248,22,80,23,224,33,0,0,0,2,248,22,179,9,248,22,146,16,23,195, -2,11,12,20,13,144,80,144,8,29,41,40,250,80,144,8,32,42,40,249,22, -31,11,80,144,8,34,41,40,22,135,5,28,23,224,35,0,0,0,2,28,23, -202,1,11,23,196,2,86,94,23,202,1,11,20,13,144,80,144,8,29,41,40, -250,80,144,8,32,42,40,249,22,31,11,80,144,8,34,41,40,22,186,5,28, -248,22,134,16,23,213,2,23,212,1,86,94,23,212,1,247,22,176,16,249,247, -22,184,5,23,195,1,23,224,34,0,0,0,1,12,28,23,194,2,250,22,159, -2,248,22,84,23,198,1,23,196,1,250,22,92,23,201,1,23,202,1,23,203, -1,12,27,249,22,134,9,80,144,42,50,41,249,22,133,4,248,22,129,4,248, -22,179,2,200,8,128,8,27,28,193,248,22,182,2,194,11,28,192,27,249,22, -103,198,195,28,192,248,22,84,193,11,11,27,249,22,133,4,248,22,129,4,248, -22,179,2,23,199,2,8,128,8,27,249,22,134,9,80,144,43,50,41,23,196, -2,250,22,135,9,80,144,44,50,41,23,197,1,248,22,181,2,249,22,82,249, -22,82,23,204,1,23,205,1,27,28,23,200,2,248,22,182,2,200,11,28,192, -192,9,32,58,88,149,8,38,42,54,11,2,30,39,223,48,33,73,32,59,88, -149,8,38,42,53,11,2,30,39,223,48,33,72,32,60,88,148,8,36,40,53, -11,2,31,222,33,71,32,61,88,149,8,38,42,53,11,2,30,39,223,48,33, -62,28,249,22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9, -7,47,249,22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198, -2,39,23,200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201, -1,250,2,61,195,23,197,4,248,22,187,3,198,32,63,88,149,8,38,42,55, -11,2,30,39,223,48,33,70,32,64,88,149,8,38,42,54,11,2,30,39,223, -48,33,67,32,65,88,149,8,38,42,53,11,2,30,39,223,48,33,66,28,249, -22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9,7,47,249, -22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198,2,39,23, -200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201,1,250,2, -65,195,23,197,4,248,22,187,3,198,28,249,22,134,4,23,197,2,23,196,4, -248,22,92,193,28,249,22,149,9,7,47,249,22,166,7,23,197,2,23,199,2, -249,22,82,250,22,184,7,23,198,2,39,23,200,2,27,249,22,184,7,23,198, -1,248,22,187,3,23,201,1,19,248,22,165,7,23,195,2,250,2,65,23,197, -1,23,196,4,39,2,27,248,22,187,3,23,197,1,28,249,22,134,4,23,195, -2,23,197,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166,7,23,198, -2,23,197,2,249,22,82,250,22,184,7,23,199,2,39,23,198,2,248,2,60, -249,22,184,7,23,199,1,248,22,187,3,23,199,1,250,2,64,196,23,198,4, -248,22,187,3,196,32,68,88,149,8,38,42,53,11,2,30,39,223,48,33,69, -28,249,22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9,7, -47,249,22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198,2, -39,23,200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201,1, -250,2,68,195,23,197,4,248,22,187,3,198,28,249,22,134,4,23,197,2,23, -196,4,248,22,92,193,28,249,22,149,9,7,47,249,22,166,7,23,197,2,23, -199,2,249,22,82,250,22,184,7,23,198,2,39,23,200,2,27,249,22,184,7, -23,198,1,248,22,187,3,23,201,1,19,248,22,165,7,23,195,2,250,2,64, -23,197,1,23,196,4,39,2,27,248,22,187,3,23,197,1,28,249,22,134,4, -23,195,2,23,197,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166,7, -23,198,2,23,197,2,249,22,82,250,22,184,7,23,199,2,39,23,198,2,27, -249,22,184,7,23,199,1,248,22,187,3,23,199,1,19,248,22,165,7,23,195, -2,250,2,68,23,197,1,23,196,4,39,2,27,248,22,187,3,23,195,1,28, -249,22,134,4,23,195,2,23,198,4,248,22,92,195,28,249,22,149,9,7,47, -249,22,166,7,23,199,2,23,197,2,249,22,82,250,22,184,7,23,200,2,39, -23,198,2,248,2,60,249,22,184,7,23,200,1,248,22,187,3,23,199,1,250, -2,63,197,23,199,4,248,22,187,3,196,19,248,22,165,7,23,195,2,28,249, -22,176,20,39,23,195,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166, -7,23,198,2,39,249,22,82,250,22,184,7,23,199,2,39,39,27,249,22,184, -7,23,199,1,40,19,248,22,165,7,23,195,2,250,2,61,23,197,1,23,196, -4,39,2,28,249,22,176,20,40,23,195,4,248,22,92,194,28,249,22,149,9, -7,47,249,22,166,7,23,198,2,40,249,22,82,250,22,184,7,23,199,2,39, -40,248,2,60,249,22,184,7,23,199,1,41,250,2,63,196,23,196,4,41,2, -28,249,22,134,4,23,197,2,23,196,4,248,22,92,193,28,249,22,149,9,7, -47,249,22,166,7,23,197,2,23,199,2,249,22,82,250,22,184,7,23,198,2, -39,23,200,2,248,2,60,249,22,184,7,23,198,1,248,22,187,3,23,201,1, -250,2,59,195,23,197,4,248,22,187,3,198,28,249,22,134,4,23,197,2,23, -196,4,248,22,92,193,28,249,22,149,9,7,47,249,22,166,7,23,197,2,23, -199,2,249,22,82,250,22,184,7,23,198,2,39,23,200,2,27,249,22,184,7, -23,198,1,248,22,187,3,23,201,1,19,248,22,165,7,23,195,2,250,2,59, -23,197,1,23,196,4,39,2,27,248,22,187,3,23,197,1,28,249,22,134,4, -23,195,2,23,197,4,248,22,92,194,28,249,22,149,9,7,47,249,22,166,7, -23,198,2,23,197,2,249,22,82,250,22,184,7,23,199,2,39,23,198,2,248, -2,60,249,22,184,7,23,199,1,248,22,187,3,23,199,1,250,2,58,196,23, -198,4,248,22,187,3,196,32,74,88,148,39,40,58,11,2,31,222,33,75,28, -248,22,90,248,22,84,23,195,2,249,22,7,9,248,22,191,20,23,196,1,90, -144,41,11,89,146,41,39,11,27,248,22,128,21,23,197,2,28,248,22,90,248, -22,84,23,195,2,249,22,7,9,248,22,191,20,195,90,144,41,11,89,146,41, -39,11,27,248,22,128,21,196,28,248,22,90,248,22,84,23,195,2,249,22,7, -9,248,22,191,20,195,90,144,41,11,89,146,41,39,11,248,2,74,248,22,128, -21,196,249,22,7,249,22,82,248,22,191,20,199,196,195,249,22,7,249,22,82, -248,22,191,20,199,196,195,249,22,7,249,22,82,248,22,191,20,23,200,1,23, -197,1,23,196,1,27,19,248,22,165,7,23,196,2,250,2,58,23,198,1,23, -196,4,39,2,28,23,195,1,192,28,248,22,90,248,22,84,23,195,2,249,22, -7,9,248,22,191,20,23,196,1,27,248,22,128,21,23,195,2,90,144,41,11, -89,146,41,39,11,28,248,22,90,248,22,84,23,197,2,249,22,7,9,248,22, -191,20,23,198,1,27,248,22,128,21,23,197,2,90,144,41,11,89,146,41,39, -11,28,248,22,90,248,22,84,23,197,2,249,22,7,9,248,22,191,20,197,90, -144,41,11,89,146,41,39,11,248,2,74,248,22,128,21,198,249,22,7,249,22, -82,248,22,191,20,201,196,195,249,22,7,249,22,82,248,22,191,20,23,203,1, -196,195,249,22,7,249,22,82,248,22,191,20,23,201,1,23,197,1,23,196,1, -248,22,160,12,252,22,176,10,248,22,169,4,23,200,2,248,22,165,4,23,200, -2,248,22,166,4,23,200,2,248,22,167,4,23,200,2,248,22,168,4,23,200, -1,28,24,194,2,12,20,13,144,80,144,39,41,40,80,143,39,59,89,146,40, -40,10,249,22,137,5,21,94,2,32,6,19,19,112,108,97,110,101,116,47,114, -101,115,111,108,118,101,114,46,114,107,116,1,27,112,108,97,110,101,116,45,109, -111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,27, -28,23,195,2,28,249,22,182,9,23,197,2,80,143,42,55,86,94,23,195,1, -80,143,40,56,27,248,22,161,5,23,197,2,27,28,248,22,80,23,195,2,248, -22,191,20,23,195,1,23,194,1,28,248,22,134,16,23,194,2,90,144,42,11, -89,146,42,39,11,248,22,155,16,23,197,1,86,95,20,18,144,11,80,143,45, -55,199,20,18,144,11,80,143,45,56,192,192,86,94,23,193,1,11,86,94,23, -195,1,11,28,23,193,2,192,27,247,22,186,5,28,23,193,2,192,247,22,176, -16,90,144,42,11,89,146,42,39,11,248,22,155,16,23,198,2,86,95,23,195, -1,23,193,1,28,249,22,128,17,0,11,35,114,120,34,91,46,93,115,115,36, -34,248,22,139,16,23,197,1,249,80,144,44,61,42,23,199,1,2,26,196,249, -80,144,41,57,42,195,10,249,22,12,23,196,1,80,144,41,54,41,86,96,28, -248,22,159,5,23,196,2,11,250,22,134,12,2,22,6,21,21,114,101,115,111, -108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,63,23,198,2,28, -23,196,2,28,248,22,166,14,23,197,2,11,250,22,134,12,2,22,6,20,20, -40,111,114,47,99,32,35,102,32,110,97,109,101,115,112,97,99,101,63,41,23, -199,2,11,28,24,193,2,248,24,194,1,23,196,2,86,94,23,193,1,11,27, -250,22,161,2,80,144,44,44,41,248,22,153,17,247,22,165,14,11,27,28,23, -194,2,23,194,1,86,94,23,194,1,27,249,22,82,247,22,141,2,247,22,141, -2,86,94,250,22,159,2,80,144,46,44,41,248,22,153,17,247,22,165,14,195, -192,86,94,250,22,159,2,248,22,83,23,197,2,23,200,2,70,100,101,99,108, -97,114,101,100,28,23,198,2,27,28,248,22,80,248,22,161,5,23,200,2,248, -22,160,5,248,22,83,248,22,161,5,23,201,1,23,198,1,27,250,22,161,2, -80,144,47,44,41,248,22,153,17,23,204,1,11,28,23,193,2,27,250,22,161, -2,248,22,84,23,198,1,23,198,2,11,28,23,193,2,250,22,159,2,248,22, -128,21,23,200,1,23,198,1,23,196,1,12,12,12,86,94,251,22,155,12,247, -22,159,12,67,101,114,114,111,114,6,69,69,100,101,102,97,117,108,116,32,109, -111,100,117,108,101,32,110,97,109,101,32,114,101,115,111,108,118,101,114,32,99, -97,108,108,101,100,32,119,105,116,104,32,116,104,114,101,101,32,97,114,103,117, -109,101,110,116,115,32,40,100,101,112,114,101,99,97,116,101,100,41,11,251,24, -197,1,23,198,1,23,199,1,23,200,1,10,32,85,88,148,39,43,57,11,2, -31,222,33,86,28,248,22,90,23,197,2,28,248,22,90,195,193,249,22,82,195, -248,22,98,197,28,249,22,184,9,248,22,83,23,199,2,2,34,28,248,22,90, -23,196,2,86,95,23,196,1,23,195,1,250,22,130,12,2,22,6,37,37,116, -111,111,32,109,97,110,121,32,34,46,46,34,115,32,105,110,32,115,117,98,109, -111,100,117,108,101,32,112,97,116,104,58,32,126,46,115,250,22,93,2,35,28, -249,22,184,9,23,202,2,2,36,23,200,1,28,248,22,134,16,23,201,2,23, -200,1,249,22,92,28,248,22,66,23,203,2,2,5,2,37,23,202,1,23,199, -1,251,2,85,196,197,248,22,84,199,248,22,128,21,200,251,2,85,196,197,249, -22,82,248,22,191,20,202,200,248,22,128,21,200,251,2,85,197,196,9,197,27, -250,22,185,7,27,28,23,198,2,28,247,22,147,12,248,80,144,47,58,42,23, -199,2,11,11,28,192,192,6,29,29,115,116,97,110,100,97,114,100,45,109,111, -100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,6,2,2, -58,32,250,22,139,17,0,7,35,114,120,34,92,110,34,23,203,1,249,22,146, -8,6,23,23,10,32,32,102,111,114,32,109,111,100,117,108,101,32,112,97,116, -104,58,32,126,115,10,23,203,2,248,22,129,14,28,23,195,2,251,22,137,13, -23,198,1,247,22,27,248,22,92,23,200,1,23,200,1,86,94,23,195,1,250, -22,164,13,23,197,1,247,22,27,23,199,1,19,248,22,165,7,194,28,249,22, -180,20,23,195,4,42,28,249,22,182,9,7,46,249,22,166,7,197,249,22,190, -3,23,199,4,42,28,28,249,22,182,9,7,115,249,22,166,7,197,249,22,190, -3,23,199,4,41,249,22,182,9,7,115,249,22,166,7,197,249,22,190,3,23, -199,4,40,11,249,22,185,7,250,22,184,7,198,39,249,22,190,3,23,200,4, -42,2,39,193,193,193,2,28,249,22,168,7,194,2,36,2,27,28,249,22,168, -7,194,2,34,64,117,112,192,0,8,35,114,120,34,91,46,93,34,32,92,88, -148,8,36,40,50,11,2,31,222,33,93,28,248,22,90,23,194,2,9,250,22, -93,6,4,4,10,32,32,32,248,22,138,16,248,22,106,23,198,2,248,2,92, -248,22,128,21,23,198,1,28,249,22,184,9,248,22,84,23,200,2,23,196,1, -28,249,22,182,9,248,22,191,20,23,200,1,23,198,1,251,22,130,12,2,22, -6,41,41,99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,10,32, -32,97,116,32,112,97,116,104,58,32,126,97,10,32,32,112,97,116,104,115,58, -126,97,23,197,1,249,22,1,22,185,7,248,2,92,248,22,98,23,203,1,12, -12,247,23,193,1,250,22,163,4,11,196,195,20,13,144,80,144,49,53,41,249, -22,82,249,22,82,23,206,1,23,201,1,23,203,1,20,13,144,80,144,49,41, -40,252,80,144,54,42,40,249,22,31,11,80,144,56,41,40,22,134,5,23,204, -2,22,136,5,248,28,23,199,2,20,20,94,88,148,8,36,40,49,11,9,223, -6,33,96,23,199,1,86,94,23,199,1,22,7,28,248,22,66,23,201,2,23, -200,1,28,28,248,22,80,23,201,2,249,22,182,9,248,22,191,20,23,203,2, -2,32,11,23,200,1,86,94,23,200,1,28,248,22,159,5,23,206,2,27,248, -22,161,5,23,207,2,28,248,22,66,193,249,22,92,2,5,194,192,23,205,2, -249,247,22,185,5,23,198,1,27,248,22,70,248,22,138,16,23,203,1,28,23, -198,2,28,250,22,161,2,248,22,191,20,23,207,1,23,205,1,11,249,22,82, -11,199,249,22,82,194,199,192,86,96,28,248,22,170,5,23,196,2,11,28,248, -22,161,4,23,198,2,250,22,132,12,11,6,15,15,98,97,100,32,109,111,100, -117,108,101,32,112,97,116,104,23,200,2,250,22,134,12,2,22,2,33,23,198, -2,28,23,196,2,28,248,22,159,5,23,197,2,11,250,22,134,12,2,22,6, -31,31,40,111,114,47,99,32,35,102,32,114,101,115,111,108,118,101,100,45,109, -111,100,117,108,101,45,112,97,116,104,63,41,23,199,2,11,28,23,197,2,28, -248,22,161,4,23,198,2,11,250,22,134,12,2,22,6,17,17,40,111,114,47, -99,32,35,102,32,115,121,110,116,97,120,63,41,23,200,2,11,27,32,0,88, -148,39,41,50,11,78,102,108,97,116,116,101,110,45,115,117,98,45,112,97,116, -104,222,33,87,28,28,248,22,80,23,197,2,249,22,182,9,248,22,191,20,23, -199,2,2,5,11,86,98,23,199,1,23,198,1,23,197,1,23,194,1,23,193, -1,248,22,160,5,248,22,105,23,198,1,28,28,248,22,80,23,197,2,28,249, -22,182,9,248,22,191,20,23,199,2,2,35,28,248,22,80,248,22,105,23,198, -2,249,22,182,9,248,22,109,23,199,2,2,5,11,11,11,86,97,23,199,1, -23,198,1,23,197,1,23,194,1,248,22,160,5,249,23,196,1,248,22,122,23, -200,2,248,22,107,23,200,1,28,28,248,22,80,23,197,2,28,249,22,182,9, -248,22,191,20,23,199,2,2,35,28,28,249,22,184,9,248,22,105,23,199,2, -2,36,10,249,22,184,9,248,22,105,23,199,2,2,34,28,23,197,2,27,248, -22,161,5,23,199,2,28,248,22,66,193,10,28,248,22,80,193,248,22,66,248, -22,191,20,194,11,11,11,11,11,86,96,23,199,1,23,198,1,23,194,1,27, -248,22,161,5,23,199,1,248,22,160,5,249,23,197,1,28,248,22,80,23,197, -2,248,22,191,20,23,197,2,23,196,2,27,28,249,22,184,9,248,22,105,23, -204,2,2,34,248,22,128,21,201,248,22,107,201,28,248,22,80,23,198,2,249, -22,97,248,22,128,21,199,194,192,28,28,248,22,80,23,197,2,249,22,182,9, -248,22,191,20,23,199,2,2,38,11,86,94,23,193,1,86,94,248,80,144,42, -8,28,42,23,195,2,253,24,200,1,23,202,1,23,203,1,23,204,1,23,205, -1,11,80,143,47,59,28,28,248,22,80,23,197,2,28,249,22,182,9,248,22, -191,20,23,199,2,2,35,28,248,22,80,248,22,105,23,198,2,249,22,182,9, -248,22,109,23,199,2,2,38,11,11,11,86,94,23,193,1,86,94,248,80,144, -42,8,28,42,23,195,2,253,24,200,1,248,22,105,23,203,2,23,203,1,23, -204,1,23,205,1,248,22,107,23,203,1,80,143,47,59,86,94,23,194,1,27, -88,148,8,36,40,57,8,240,0,0,8,0,1,19,115,104,111,119,45,99,111, -108,108,101,99,116,105,111,110,45,101,114,114,225,3,4,6,33,88,27,32,0, -88,148,8,36,40,53,11,69,115,115,45,62,114,107,116,222,33,89,27,28,248, -22,80,23,200,2,28,249,22,182,9,2,35,248,22,191,20,23,202,2,27,248, -22,105,23,201,2,28,28,249,22,184,9,23,195,2,2,36,10,249,22,184,9, -23,195,2,2,34,86,94,23,193,1,28,23,201,2,27,248,22,161,5,23,203, -2,28,248,22,80,193,248,22,191,20,193,192,250,22,130,12,2,22,6,45,45, -110,111,32,98,97,115,101,32,112,97,116,104,32,102,111,114,32,114,101,108,97, -116,105,118,101,32,115,117,98,109,111,100,117,108,101,32,112,97,116,104,58,32, -126,46,115,23,203,2,192,23,199,2,23,199,2,27,28,248,22,80,23,201,2, -28,249,22,182,9,2,35,248,22,191,20,23,203,2,27,28,28,249,22,184,9, -248,22,105,23,204,2,2,36,23,202,2,28,249,22,184,9,248,22,105,23,204, -2,2,34,23,202,2,11,27,248,22,161,5,23,204,2,27,28,249,22,184,9, -248,22,105,23,206,2,2,34,248,22,128,21,23,204,1,248,22,107,23,204,1, -28,248,22,80,23,195,2,249,23,202,1,248,22,191,20,23,197,2,249,22,97, -248,22,128,21,23,199,1,23,197,1,249,23,202,1,23,196,1,23,195,1,249, -23,200,1,2,36,28,249,22,184,9,248,22,105,23,206,2,2,34,248,22,128, -21,23,204,1,248,22,107,23,204,1,28,248,22,80,193,248,22,128,21,193,11, -86,95,23,200,1,23,197,1,11,86,95,23,200,1,23,197,1,11,27,28,248, -22,66,23,196,2,86,94,23,196,1,27,248,80,144,48,51,42,249,22,82,23, -199,2,248,22,153,17,247,22,165,14,28,23,193,2,86,94,23,198,1,192,90, -144,41,11,89,146,41,39,11,249,80,144,51,57,42,248,22,73,23,201,2,11, -27,28,248,22,90,23,195,2,2,40,249,22,185,7,23,197,2,2,39,252,80, -144,55,8,23,42,23,206,1,28,248,22,90,23,200,2,23,200,1,86,94,23, -200,1,248,22,83,23,200,2,28,248,22,90,23,200,2,86,94,23,199,1,9, -248,22,84,23,200,1,23,198,1,10,28,248,22,162,7,23,196,2,86,94,23, -197,1,27,248,80,144,48,8,29,42,23,204,2,27,248,80,144,49,51,42,249, -22,82,23,200,2,23,197,2,28,23,193,2,86,95,23,198,1,23,194,1,192, -90,144,41,11,89,146,41,39,11,249,80,144,52,57,42,23,201,2,11,28,248, -22,90,23,194,2,86,94,23,193,1,249,22,152,16,23,198,1,248,23,203,1, -23,197,1,250,22,1,22,152,16,23,199,1,249,22,97,249,22,2,32,0,88, -148,8,36,40,47,11,9,222,33,90,23,200,1,248,22,92,248,23,207,1,23, -201,1,28,248,22,134,16,23,196,2,86,95,23,197,1,23,196,1,248,80,144, -47,8,30,42,248,22,162,16,28,248,22,159,16,23,198,2,23,197,2,249,22, -160,16,23,199,2,248,80,144,51,8,29,42,23,207,2,28,249,22,182,9,248, -22,83,23,198,2,2,32,27,248,80,144,48,51,42,249,22,82,23,199,2,248, -22,153,17,247,22,165,14,28,23,193,2,86,95,23,198,1,23,197,1,192,90, -144,41,11,89,146,41,39,11,249,80,144,51,57,42,248,22,105,23,201,2,11, -27,28,248,22,90,248,22,107,23,201,2,28,248,22,90,23,195,2,249,22,132, -17,2,91,23,197,2,11,10,27,28,23,194,2,248,23,202,1,23,197,2,28, -248,22,90,23,196,2,86,94,23,201,1,2,40,28,249,22,132,17,2,91,23, -198,2,248,23,202,1,23,197,2,86,94,23,201,1,249,22,185,7,23,198,2, -2,39,27,28,23,195,1,86,94,23,197,1,249,22,97,28,248,22,90,248,22, -107,23,205,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,97,249,22, -2,80,144,58,8,31,42,248,22,107,23,208,2,23,198,1,28,248,22,90,23, -197,2,86,94,23,196,1,248,22,92,23,198,1,86,94,23,197,1,23,196,1, -252,80,144,57,8,23,42,23,208,1,248,22,83,23,199,2,248,22,128,21,23, -199,1,23,199,1,10,86,95,23,197,1,23,196,1,28,249,22,182,9,248,22, -191,20,23,198,2,2,37,248,80,144,47,8,30,42,248,22,162,16,249,22,160, -16,248,22,164,16,248,22,105,23,201,2,248,80,144,51,8,29,42,23,207,2, -12,86,94,28,248,22,134,16,23,194,2,11,28,248,22,129,9,23,194,2,11, -28,23,203,2,250,22,132,12,69,114,101,113,117,105,114,101,249,22,146,8,6, -17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23, -198,2,248,22,83,23,199,2,6,0,0,23,206,2,250,22,134,12,2,22,2, -33,23,198,2,27,28,248,22,129,9,23,195,2,249,22,134,9,23,196,2,39, -249,22,162,16,248,22,163,16,23,197,2,11,27,28,248,22,129,9,23,196,2, -249,22,134,9,23,197,2,40,248,80,144,49,8,24,42,23,195,2,90,144,42, -11,89,146,42,39,11,28,248,22,129,9,23,199,2,250,22,7,2,41,249,22, -134,9,23,203,2,41,2,41,248,22,155,16,23,198,2,86,95,23,195,1,23, -193,1,27,28,248,22,129,9,23,200,2,249,22,134,9,23,201,2,42,249,80, -144,54,61,42,23,197,2,5,0,27,28,248,22,129,9,23,201,2,249,22,134, -9,23,202,2,43,248,22,160,5,23,200,2,27,250,22,161,2,80,144,57,44, -41,248,22,153,17,247,22,165,14,11,27,28,23,194,2,23,194,1,86,94,23, -194,1,27,249,22,82,247,22,141,2,247,22,141,2,86,94,250,22,159,2,80, -144,59,44,41,248,22,153,17,247,22,165,14,195,192,27,28,23,204,2,248,22, -160,5,249,22,82,248,22,161,5,23,200,2,23,207,2,23,196,2,86,95,28, -23,214,2,28,250,22,161,2,248,22,83,23,198,2,195,11,86,96,23,213,1, -23,204,1,23,194,1,11,27,251,22,31,11,80,144,61,53,41,9,28,248,22, -15,80,144,8,23,54,41,80,144,61,54,41,247,22,17,27,248,22,153,17,247, -22,165,14,86,94,249,22,3,88,148,8,36,40,57,11,9,226,2,3,12,13, -33,94,23,196,2,248,28,248,22,15,80,144,60,54,41,32,0,88,148,39,40, -45,11,9,222,33,95,80,144,59,8,32,42,20,20,98,88,148,39,39,8,25, -8,240,12,64,0,0,9,233,20,1,2,4,6,7,11,12,14,15,23,33,97, -23,216,1,23,207,1,23,197,1,23,195,1,23,194,1,86,96,23,213,1,23, -204,1,23,194,1,11,28,248,22,129,9,23,204,1,11,28,23,214,1,28,28, -248,22,162,7,23,206,2,10,28,248,22,66,23,206,2,10,28,248,22,80,23, -206,2,249,22,182,9,248,22,191,20,23,208,2,2,32,11,249,80,144,58,52, -42,28,248,22,162,7,23,208,2,249,22,82,23,209,1,248,80,144,61,8,29, -42,23,217,1,86,94,23,214,1,249,22,82,23,209,1,248,22,153,17,247,22, -165,14,252,22,131,9,23,209,1,23,208,1,23,206,1,23,204,1,23,203,1, -11,11,192,86,96,20,18,144,11,80,143,39,59,248,80,144,40,8,27,40,249, -22,31,11,80,144,42,41,40,248,22,133,5,80,144,40,60,41,248,22,185,5, -80,144,40,40,41,248,22,164,15,80,144,40,48,42,20,18,144,11,80,143,39, -59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,20,18,144,11, -80,143,39,59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,145, -40,9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2, -2,29,11,11,11,11,11,11,11,9,9,11,11,11,10,43,80,143,39,39,20, -122,145,2,1,44,16,28,2,3,2,4,30,2,6,1,20,112,97,114,97,109, -101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,5,30,2,6,1, -23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116, -105,111,110,11,4,30,2,7,74,112,97,116,104,45,115,116,114,105,110,103,63, -42,196,15,2,8,30,2,7,73,114,101,114,111,111,116,45,112,97,116,104,44, -196,16,30,2,7,1,18,112,97,116,104,45,97,100,100,45,101,120,116,101,110, -115,105,111,110,44,196,12,2,9,2,10,2,11,2,12,2,13,2,14,2,15, -2,16,2,17,2,18,2,19,2,20,2,21,2,22,30,2,7,1,22,112,97, -116,104,45,114,101,112,108,97,99,101,45,101,120,116,101,110,115,105,111,110,44, -196,14,30,2,7,75,102,105,110,100,45,99,111,108,45,102,105,108,101,49,196, -4,30,2,7,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104, -42,196,11,2,23,2,24,30,2,6,76,114,101,112,97,114,97,109,101,116,101, -114,105,122,101,11,6,16,0,40,42,39,16,0,39,16,16,2,15,2,16,2, -8,2,12,2,17,2,18,2,11,2,4,2,10,2,3,2,20,2,13,2,14, -2,9,2,19,2,22,55,11,11,11,16,3,2,23,2,21,2,24,16,3,11, -11,11,16,3,2,23,2,21,2,24,42,42,40,12,11,11,16,0,16,0,16, -0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16,24,20,15,16,2, -248,22,189,8,71,115,111,45,115,117,102,102,105,120,80,144,39,39,40,20,15, -16,2,27,249,22,182,9,247,22,185,16,76,109,111,100,105,102,121,45,115,101, -99,111,110,100,115,88,148,39,41,8,42,8,189,7,2,4,224,1,0,33,54, -80,144,39,40,40,20,15,16,2,32,0,88,148,8,36,44,55,11,2,9,222, -33,55,80,144,39,47,40,20,15,16,2,20,28,143,32,0,88,148,8,36,40, -45,11,2,10,222,192,32,0,88,148,8,36,40,45,11,2,10,222,192,80,144, -39,48,40,20,15,16,2,247,22,144,2,80,144,39,44,40,20,15,16,2,8, -128,8,80,144,39,49,40,20,15,16,2,249,22,130,9,8,128,8,11,80,144, -39,50,40,20,15,16,2,88,148,8,36,40,53,8,128,32,2,13,223,0,33, -56,80,144,39,51,40,20,15,16,2,88,148,8,36,41,57,8,128,32,2,14, -223,0,33,57,80,144,39,52,40,20,15,16,2,247,22,78,80,144,39,53,40, -20,15,16,2,248,22,16,76,109,111,100,117,108,101,45,108,111,97,100,105,110, -103,80,144,39,54,40,20,15,16,2,11,80,143,39,55,20,15,16,2,11,80, -143,39,56,20,15,16,2,32,0,88,148,39,41,60,11,2,19,222,33,76,80, -144,39,57,40,20,15,16,2,32,0,88,148,8,36,40,52,11,2,20,222,33, -77,80,144,39,58,40,20,15,16,2,11,80,143,39,59,20,15,16,2,88,149, -8,34,40,48,8,240,4,0,16,0,1,21,112,114,101,112,45,112,108,97,110, -101,116,45,114,101,115,111,108,118,101,114,33,40,224,1,0,33,78,80,144,39, -8,28,42,20,15,16,2,88,148,39,40,53,8,240,0,0,3,0,69,103,101, -116,45,100,105,114,223,0,33,79,80,144,39,8,29,42,20,15,16,2,88,148, -39,40,52,8,240,0,0,64,0,74,112,97,116,104,45,115,115,45,62,114,107, -116,223,0,33,80,80,144,39,8,30,42,20,15,16,2,88,148,8,36,40,48, -8,240,0,0,4,0,9,223,0,33,81,80,144,39,8,31,42,20,15,16,2, -88,148,39,40,48,8,240,0,128,0,0,9,223,0,33,82,80,144,39,8,32, -42,20,15,16,2,27,11,20,19,143,39,90,144,40,10,89,146,40,39,10,20, -26,96,2,22,88,148,8,36,41,57,8,32,9,224,2,1,33,83,88,148,39, -42,52,11,9,223,0,33,84,88,148,39,43,8,34,16,4,8,240,44,240,0, -0,8,240,220,241,0,0,40,39,9,224,2,1,33,98,207,80,144,39,60,40, -20,15,16,2,88,148,39,39,48,16,2,8,134,8,8,176,32,2,23,223,0, -33,99,80,144,39,8,25,40,20,15,16,2,20,28,143,88,148,8,36,39,48, -16,2,43,8,144,32,2,24,223,0,33,100,88,148,8,36,39,48,16,2,43, -8,144,32,2,24,223,0,33,101,80,144,39,8,26,40,96,29,94,2,5,70, -35,37,107,101,114,110,101,108,11,29,94,2,5,71,35,37,109,105,110,45,115, -116,120,11,2,7,2,6,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 10344); - } - { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,49,50,46,48,46,52,84,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,18,0,0,0,1,0,0,8,0,18, -0,22,0,28,0,42,0,56,0,68,0,88,0,102,0,117,0,130,0,135,0, -139,0,151,0,235,0,242,0,20,1,0,0,224,1,0,0,3,1,5,105,110, -115,112,48,71,35,37,98,117,105,108,116,105,110,29,11,11,11,67,113,117,111, -116,101,29,94,2,4,70,35,37,107,101,114,110,101,108,11,29,94,2,4,70, -35,37,101,120,112,111,98,115,11,29,94,2,4,68,35,37,98,111,111,116,11, -29,94,2,4,76,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29, -94,2,4,70,35,37,112,97,114,97,109,122,11,29,94,2,4,71,35,37,110, -101,116,119,111,114,107,11,29,94,2,4,69,35,37,117,116,105,108,115,11,38, -12,93,2,13,36,13,0,39,38,14,93,143,16,3,39,2,15,2,2,39,36, -15,1,150,40,143,2,16,16,4,2,5,39,39,2,1,143,2,16,16,4,2, -6,39,39,2,1,143,2,16,16,4,2,7,39,39,2,1,143,2,16,16,4, -2,8,39,39,2,1,143,2,16,16,4,2,9,39,39,2,1,143,2,16,16, -4,2,10,39,39,2,1,143,2,16,16,4,2,11,39,39,2,1,16,0,38, -16,143,2,15,2,12,18,143,16,2,143,10,16,3,93,16,2,29,11,11,11, -2,3,2,12,2,14,143,11,16,3,9,9,2,14,16,3,9,9,9,145,40, -9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2, -2,3,11,11,11,11,9,9,11,11,11,33,17,40,80,143,39,39,20,122,145, -2,1,39,16,0,16,0,40,42,39,16,0,39,16,0,39,11,11,11,16,0, -16,0,16,0,39,39,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11, -11,16,0,16,0,16,0,39,39,16,0,105,2,5,2,6,29,94,2,4,71, -35,37,102,111,114,101,105,103,110,11,29,94,2,4,70,35,37,117,110,115,97, -102,101,11,29,94,2,4,71,35,37,102,108,102,120,110,117,109,11,2,7,2, -8,2,9,2,10,2,11,29,94,2,4,69,35,37,112,108,97,99,101,11,29, -94,2,4,71,35,37,102,117,116,117,114,101,115,11,29,94,2,4,71,35,37, -108,105,110,107,108,101,116,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 559); - } diff --git a/racket/src/racket/src/dynext.c b/racket/src/racket/src/dynext.c index 461e43c996..a00378847a 100644 --- a/racket/src/racket/src/dynext.c +++ b/racket/src/racket/src/dynext.c @@ -85,7 +85,6 @@ static char *dlerror(void) { # include "schemex.h" #endif -static Scheme_Object *load_extension(int argc, Scheme_Object **argv); static Scheme_Object *current_load_extension(int argc, Scheme_Object *argv[]); #ifdef LINK_EXTENSIONS_BY_TABLE @@ -122,7 +121,7 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *fullpath_loaded_extensions;) /* hash #define BAD_VERSION_STR "found version does not match the expected version" -void scheme_init_dynamic_extension(Scheme_Env *env) +void scheme_init_dynamic_extension(Scheme_Startup_Env *env) { if (scheme_starting_up) { #ifdef LINK_EXTENSIONS_BY_TABLE @@ -134,8 +133,7 @@ void scheme_init_dynamic_extension(Scheme_Env *env) #endif } - GLOBAL_PRIM_W_ARITY2("load-extension", load_extension, 1, 1, 0, -1, env); - GLOBAL_PARAMETER("current-load-extension", current_load_extension, MZCONFIG_LOAD_EXTENSION_HANDLER, env); + ADD_PARAMETER("current-load-extension", current_load_extension, MZCONFIG_LOAD_EXTENSION_HANDLER, env); } static Scheme_Object * @@ -496,9 +494,28 @@ void scheme_register_extension_global(void *ptr, intptr_t size) GC_add_roots((char *)ptr, (char *)(((char *)ptr) + size + 1)); } -static Scheme_Object *load_extension(int argc, Scheme_Object **argv) +static int submodule_spec_p(Scheme_Object *expected_module) { - return scheme_load_with_clrd(argc, argv, "load-extension", MZCONFIG_LOAD_EXTENSION_HANDLER); + Scheme_Object *a; + + if (SCHEME_PAIRP(expected_module)) { + a = SCHEME_CAR(expected_module); + if (!SCHEME_FALSEP(a) && !SCHEME_SYMBOLP(a)) + return 0; + expected_module = SCHEME_CDR(expected_module); + if (!SCHEME_PAIRP(expected_module)) + return 0; + while (SCHEME_PAIRP(expected_module)) { + a = SCHEME_CAR(expected_module); + if (!SCHEME_SYMBOLP(a)) + return 0; + expected_module = SCHEME_CDR(expected_module); + } + if (SCHEME_NULLP(expected_module)) + return 1; + } + + return 0; } Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv) @@ -509,8 +526,17 @@ Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv) if (!SCHEME_PATH_STRINGP(argv[0])) scheme_wrong_contract("default-load-extension-handler", "path-string?", 0, argc, argv); expected_module = argv[1]; - if (!SCHEME_FALSEP(expected_module) && !SCHEME_SYMBOLP(expected_module)) - scheme_wrong_contract("default-load-extension-handler", "(or/c symbol? #f)", 1, argc, argv); + if (!SCHEME_FALSEP(expected_module) + && !SCHEME_SYMBOLP(expected_module) + && !submodule_spec_p(expected_module)) + scheme_wrong_contract("default-load-extension-handler", + "(or/c symbol? #f (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))", + 1, argc, argv); + + if (SCHEME_PAIRP(expected_module) && SCHEME_FALSEP(SCHEME_CAR(expected_module))) { + /* caller requests quiet failure for separate loading of submodule */ + return scheme_void; + } filename = scheme_expand_string_filename(argv[0], "default-load-extension-handler", @@ -522,10 +548,10 @@ Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv) Scheme_Object *scheme_load_extension(const char *filename, Scheme_Env *env) { - Scheme_Object *a[1]; - + Scheme_Object *load_ext_proc, *a[1]; + load_ext_proc = scheme_get_startup_export("load-extension"); a[0] = scheme_make_byte_string(filename); - return load_extension(1, a); + return scheme_apply_multi(load_ext_proc, 1, a); } void scheme_free_dynamic_extensions() diff --git a/racket/src/racket/src/dynext.inc b/racket/src/racket/src/dynext.inc index 9984e80684..cc6b5375f3 100644 --- a/racket/src/racket/src/dynext.inc +++ b/racket/src/racket/src/dynext.inc @@ -119,7 +119,7 @@ scheme_extension_table->scheme_get_string_output = scheme_get_string_output; scheme_extension_table->scheme_pipe = scheme_pipe; scheme_extension_table->scheme_add_global = scheme_add_global; - scheme_extension_table->scheme_add_global_constant = scheme_add_global_constant; + scheme_extension_table->scheme_addto_prim_instance = scheme_addto_prim_instance; scheme_extension_table->scheme_remove_global = scheme_remove_global; scheme_extension_table->scheme_constant = scheme_constant; scheme_extension_table->scheme_new_special_frame = scheme_new_special_frame; diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index 7b71457836..3338cb2ea9 100644 --- a/racket/src/racket/src/env.c +++ b/racket/src/racket/src/env.c @@ -23,14 +23,9 @@ All rights reserved. */ -/* This file implements environments (both compile-time and top-level - envionments, a.k.a. namespaces), and also implements much of the - initialization sequence (filling the initial namespace). */ - #include "schpriv.h" #include "schminc.h" #include "schmach.h" -#include "schexpobs.h" #include "schrktio.h" #ifdef MZ_USE_FUTURES # include "future.h" @@ -47,127 +42,67 @@ int scheme_get_allow_set_undefined() { return scheme_allow_set_undefined; } THREAD_LOCAL_DECL(int scheme_starting_up); /* globals READ-ONLY SHARED */ -Scheme_Object *scheme_varref_const_p_proc; -Scheme_Object *scheme_varref_from_unsafe_p_proc; -READ_ONLY static Scheme_Env *kernel_env; -READ_ONLY static Scheme_Env *unsafe_env; -READ_ONLY static Scheme_Env *flfxnum_env; -READ_ONLY static Scheme_Env *extfl_env; -READ_ONLY static Scheme_Env *futures_env; READ_ONLY static Scheme_Object *kernel_symbol; -READ_ONLY static Scheme_Object *flip_symbol; -READ_ONLY static Scheme_Object *add_symbol; -READ_ONLY static Scheme_Object *remove_symbol; -THREAD_LOCAL_DECL(static int intdef_counter); +READ_ONLY Scheme_Startup_Env *scheme_startup_env; static int builtin_ref_counter; static int builtin_unsafe_start; +THREAD_LOCAL_DECL(static Scheme_Instance *scheme_startup_instance); + THREAD_LOCAL_DECL(static Scheme_Bucket_Table *literal_string_table); THREAD_LOCAL_DECL(static Scheme_Bucket_Table *literal_number_table); /* local functions */ -static void make_kernel_env(void); +static void init_startup_env(void); +static Scheme_Startup_Env *make_startup_env(); -static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size); -static Scheme_Env *make_empty_inited_env(int toplevel_size); -static Scheme_Env *make_empty_not_inited_env(int toplevel_size); - -static Scheme_Object *namespace_identifier(int, Scheme_Object *[]); -static Scheme_Object *namespace_module_identifier(int, Scheme_Object *[]); -static Scheme_Object *namespace_base_phase(int, Scheme_Object *[]); -static Scheme_Object *namespace_variable_value(int, Scheme_Object *[]); -static Scheme_Object *namespace_set_variable_value(int, Scheme_Object *[]); -static Scheme_Object *namespace_undefine_variable(int, Scheme_Object *[]); -static Scheme_Object *namespace_mapped_symbols(int, Scheme_Object *[]); -static Scheme_Object *namespace_module_registry(int, Scheme_Object *[]); -static Scheme_Object *variable_p(int, Scheme_Object *[]); -static Scheme_Object *variable_modidx(int, Scheme_Object *[]); -static Scheme_Object *variable_module_path(int, Scheme_Object *[]); -static Scheme_Object *variable_module_source(int, Scheme_Object *[]); -static Scheme_Object *variable_namespace(int, Scheme_Object *[]); -static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]); -static Scheme_Object *variable_phase(int, Scheme_Object *[]); -static Scheme_Object *variable_base_phase(int, Scheme_Object *[]); -static Scheme_Object *variable_inspector(int, Scheme_Object *[]); -static Scheme_Object *variable_const_p(int, Scheme_Object *[]); -static Scheme_Object *variable_unsafe_p(int, Scheme_Object *[]); -static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]); -static Scheme_Object *now_transforming_with_lifts(int argc, Scheme_Object *argv[]); -static Scheme_Object *now_transforming_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_context(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[]); -static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_definitions(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_submodules(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_imports(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_module_expanding_provides(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_exprs(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]); -static Scheme_Object *local_binding_id(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]); -static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *set_transformer_proc(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_rename_transformer(int argc, Scheme_Object *argv[]); -static Scheme_Object *rename_transformer_target(int argc, Scheme_Object *argv[]); -static Scheme_Object *rename_transformer_p(int argc, Scheme_Object *argv[]); +static void init_unsafe(Scheme_Startup_Env *env); +static void init_flfxnum(Scheme_Startup_Env *env); +static void init_extfl(Scheme_Startup_Env *env); +static void init_futures(Scheme_Startup_Env *env); +static void init_foreign(Scheme_Startup_Env *env); static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data); -Scheme_Env *scheme_engine_instance_init(); static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread); #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -typedef Scheme_Object *(*Lazy_Macro_Fun)(Scheme_Object *, int); - - /*========================================================================*/ /* initialization */ /*========================================================================*/ +Scheme_Object *scheme_get_startup_export(const char *s) +{ + Scheme_Object *sym; + Scheme_Bucket *b; + + sym = scheme_intern_symbol(s); + b = scheme_instance_variable_bucket_or_null(sym, scheme_startup_instance); + + if (b) + return (Scheme_Object *)b->val; + + return NULL; +} + static void boot_module_resolver() { - Scheme_Object *boot, *a[2]; - a[0] = scheme_make_pair(scheme_intern_symbol("quote"), - scheme_make_pair(scheme_intern_symbol("#%boot"), - scheme_null)); - a[1] = scheme_intern_symbol("boot"); - boot = scheme_dynamic_require(2, a); + Scheme_Object *boot; + boot = scheme_get_startup_export("boot"); scheme_apply(boot, 0, NULL); } void scheme_seal_parameters() { - Scheme_Object *seal, *a[2]; - a[0] = scheme_make_pair(scheme_intern_symbol("quote"), - scheme_make_pair(scheme_intern_symbol("#%boot"), - scheme_null)); - a[1] = scheme_intern_symbol("seal"); - seal = scheme_dynamic_require(2, a); - scheme_apply(seal, 0, NULL); + Scheme_Object *seal; + seal = scheme_get_startup_export("seal"); + (void)scheme_apply_multi(seal, 0, NULL); } void os_platform_init() { @@ -182,7 +117,8 @@ void os_platform_init() { #endif } -Scheme_Env *scheme_restart_instance() { +Scheme_Env *scheme_restart_instance() +{ Scheme_Env *env; void *stack_base; stack_base = (void *) scheme_get_current_os_thread_stack_base(); @@ -200,11 +136,9 @@ Scheme_Env *scheme_restart_instance() { scheme_make_thread(stack_base); scheme_init_error_escape_proc(NULL); - scheme_init_module_resolver(); + scheme_namespace_to_env = scheme_make_bucket_table(5, SCHEME_hash_weak_ptr); env = scheme_make_empty_env(); - scheme_install_initial_module_set(env); - scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); scheme_init_port_config(); scheme_init_port_fun_config(); @@ -214,27 +148,20 @@ Scheme_Env *scheme_restart_instance() { boot_module_resolver(); + scheme_init_resolver_config(); + return env; } Scheme_Env *scheme_basic_env() { Scheme_Env *env; + void *stack_base; if (scheme_main_thread) { return scheme_restart_instance(); } - env = scheme_engine_instance_init(); - - return env; -} - -Scheme_Env *scheme_engine_instance_init() -/* READ-ONLY GLOBAL structures, ONE-TIME initialization */ -{ - Scheme_Env *env; - void *stack_base; stack_base = (void *) scheme_get_current_os_thread_stack_base(); os_platform_init(); @@ -285,13 +212,12 @@ Scheme_Env *scheme_engine_instance_init() /* These calls must be made here so that they allocate out of the master GC */ scheme_init_symbol_table(); - scheme_init_module_path_table(); scheme_init_type(); scheme_init_custodian_extractors(); #ifndef DONT_USE_FOREIGN scheme_init_foreign_globals(); #endif - make_kernel_env(); + init_startup_env(); scheme_init_logging_once(); @@ -304,6 +230,8 @@ Scheme_Env *scheme_engine_instance_init() scheme_spawn_master_place(); #endif + /* Create the initial place with its initial namespace */ + env = place_instance_init(stack_base, 1); #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) @@ -320,171 +248,182 @@ Scheme_Env *scheme_engine_instance_init() return env; } -static void init_unsafe(Scheme_Env *env) +static void init_startup_env(void) { - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(unsafe_env); + Scheme_Startup_Env *env; +#ifdef TIME_STARTUP_PROCESS + intptr_t startt; +#endif - unsafe_env = scheme_primitive_module(scheme_intern_symbol("#%unsafe"), env); + REGISTER_SO(kernel_symbol); + kernel_symbol = scheme_intern_symbol("#%kernel"); - scheme_init_unsafe_number(unsafe_env); - scheme_init_unsafe_numarith(unsafe_env); - scheme_init_unsafe_numcomp(unsafe_env); - scheme_init_unsafe_list(unsafe_env); - scheme_init_unsafe_hash(unsafe_env); - scheme_init_unsafe_vector(unsafe_env); - scheme_init_unsafe_fun(unsafe_env); - scheme_init_unsafe_thread(unsafe_env); - scheme_init_unsafe_port(unsafe_env); + env = make_startup_env(); - scheme_init_extfl_unsafe_number(unsafe_env); - scheme_init_extfl_unsafe_numarith(unsafe_env); - scheme_init_extfl_unsafe_numcomp(unsafe_env); + REGISTER_SO(scheme_startup_env); + scheme_startup_env = env; + + scheme_defining_primitives = 1; + builtin_ref_counter = 0; - scheme_finish_primitive_module(unsafe_env); - pt = unsafe_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(unsafe_env, NULL); - unsafe_env->attached = 1; +#ifdef TIME_STARTUP_PROCESS + printf("init @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); +# define MZTIMEIT(n, f) (MARK_START_TIME(), f, DONE_TIME(n)) +# define MARK_START_TIME() startt = scheme_get_process_milliseconds() +# define DONE_TIME(n) (printf(#n ": %" PRIdPTR "\n", (intptr_t)(scheme_get_process_milliseconds() - startt))) +#else +# define MZTIMEIT(n, f) f +# define MARK_START_TIME() /**/ +# define DONE_TIME(n) /**/ +#endif + /* The ordering of the first few init calls is important, so add to + the end of the list, not the beginning. */ + MZTIMEIT(symbol-type, scheme_init_symbol_type(env)); + MZTIMEIT(fun, scheme_init_fun(env)); + MZTIMEIT(symbol, scheme_init_symbol(env)); + MZTIMEIT(list, scheme_init_list(env)); + MZTIMEIT(number, scheme_init_number(env)); + MZTIMEIT(numarith, scheme_init_numarith(env)); + MZTIMEIT(numcomp, scheme_init_numcomp(env)); + MZTIMEIT(numstr, scheme_init_numstr(env)); + MZTIMEIT(bignum, scheme_init_bignum()); + MZTIMEIT(char-const, scheme_init_char_constants()); + MZTIMEIT(stx, scheme_init_stx(env)); + MZTIMEIT(port, scheme_init_port(env)); + MZTIMEIT(portfun, scheme_init_port_fun(env)); + MZTIMEIT(string, scheme_init_string(env)); + MZTIMEIT(vector, scheme_init_vector(env)); + MZTIMEIT(char, scheme_init_char(env)); + MZTIMEIT(bool, scheme_init_bool(env)); + MZTIMEIT(syntax, scheme_init_compile(env)); + MZTIMEIT(eval, scheme_init_eval(env)); + MZTIMEIT(struct, scheme_init_struct(env)); + MZTIMEIT(error, scheme_init_error(env)); +#ifndef NO_SCHEME_EXNS + MZTIMEIT(exn, scheme_init_exn(env)); +#endif + MZTIMEIT(process, scheme_init_thread(env)); + scheme_init_port_wait(); + scheme_init_inspector(); + scheme_init_logger_wait(); + scheme_init_struct_wait(); + MZTIMEIT(reduced, scheme_init_reduced_proc_struct(env)); +#ifndef NO_SCHEME_THREADS + MZTIMEIT(sema, scheme_init_sema(env)); +#endif + MZTIMEIT(read, scheme_init_read(env)); + MZTIMEIT(print, scheme_init_print(env)); + MZTIMEIT(file, scheme_init_file(env)); + MZTIMEIT(dynamic-extension, scheme_init_dynamic_extension(env)); +#ifndef NO_REGEXP_UTILS + MZTIMEIT(regexp, scheme_regexp_initialize(env)); +#endif + MZTIMEIT(params, scheme_init_parameterization()); + MZTIMEIT(futures, scheme_init_futures_once()); + MZTIMEIT(places, scheme_init_places_once()); + MZTIMEIT(linklet, scheme_init_linklet(env)); +#ifndef NO_TCP_SUPPORT + MZTIMEIT(network, scheme_init_network(env)); +#endif + MZTIMEIT(paramz, scheme_init_paramz(env)); + MZTIMEIT(place, scheme_init_place(env)); + + scheme_register_network_evts(); + + MARK_START_TIME(); + + init_flfxnum(env); + init_extfl(env); + init_futures(env); + + builtin_unsafe_start = builtin_ref_counter; + scheme_init_unsafe_linklet(env); + init_unsafe(env); + init_foreign(env); + #if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT - + EXPECTED_UNSAFE_COUNT)) { - printf("Unsafe count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - - EXPECTED_FLFXNUM_COUNT - EXPECTED_EXTFL_COUNT - - EXPECTED_FUTURES_COUNT, EXPECTED_UNSAFE_COUNT); + if (builtin_ref_counter != EXPECTED_PRIM_COUNT) { + printf("Primitive count %d doesn't match expected count %d\n" + "Turn off USE_COMPILED_STARTUP in src/schminc.h\n", + builtin_ref_counter, EXPECTED_PRIM_COUNT); abort(); } #endif + + scheme_init_variable_references_constants(); + + scheme_init_longdouble_fixup(); + + scheme_init_startup(); + + scheme_defining_primitives = 0; } -static void init_flfxnum(Scheme_Env *env) +static void init_unsafe(Scheme_Startup_Env *env) { - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(flfxnum_env); + scheme_switch_prim_instance(env, "#%unsafe"); - flfxnum_env = scheme_primitive_module(scheme_intern_symbol("#%flfxnum"), env); + scheme_init_unsafe_number(env); + scheme_init_unsafe_numarith(env); + scheme_init_unsafe_numcomp(env); + scheme_init_unsafe_list(env); + scheme_init_unsafe_hash(env); + scheme_init_unsafe_vector(env); + scheme_init_unsafe_fun(env); + scheme_init_unsafe_thread(env); + scheme_init_unsafe_port(env); - scheme_init_flfxnum_number(flfxnum_env); - scheme_init_flfxnum_numarith(flfxnum_env); - scheme_init_flfxnum_numcomp(flfxnum_env); + scheme_init_extfl_unsafe_number(env); + scheme_init_extfl_unsafe_numarith(env); + scheme_init_extfl_unsafe_numcomp(env); - scheme_finish_primitive_module(flfxnum_env); - pt = flfxnum_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(flfxnum_env, NULL); - flfxnum_env->attached = 1; - -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT)) { - printf("Flfxnum count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT, - EXPECTED_FLFXNUM_COUNT); - abort(); - } -#endif + scheme_restore_prim_instance(env); } -static void init_extfl(Scheme_Env *env) +static void init_flfxnum(Scheme_Startup_Env *env) { - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(extfl_env); + scheme_switch_prim_instance(env, "#%flfxnum"); + + scheme_init_flfxnum_number(env); + scheme_init_flfxnum_numarith(env); + scheme_init_flfxnum_numcomp(env); - extfl_env = scheme_primitive_module(scheme_intern_symbol("#%extfl"), env); - - scheme_init_extfl_number(extfl_env); - scheme_init_extfl_numarith(extfl_env); - scheme_init_extfl_numcomp(extfl_env); - scheme_init_extfl_numstr(extfl_env); - - scheme_finish_primitive_module(extfl_env); - pt = extfl_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(extfl_env, NULL); - extfl_env->attached = 1; - -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT)) { - printf("extfl count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_FLFXNUM_COUNT, - EXPECTED_EXTFL_COUNT); - abort(); - } -#endif + scheme_restore_prim_instance(env); } -static void init_futures(Scheme_Env *env) +static void init_extfl(Scheme_Startup_Env *env) { - Scheme_Module_Phase_Exports *pt; - REGISTER_SO(futures_env); + scheme_switch_prim_instance(env, "#%extfl"); - futures_env = scheme_primitive_module(scheme_intern_symbol("#%futures"), env); + scheme_init_extfl_number(env); + scheme_init_extfl_numarith(env); + scheme_init_extfl_numcomp(env); + scheme_init_extfl_numstr(env); - scheme_init_futures(futures_env); - - scheme_finish_primitive_module(futures_env); - pt = futures_env->module->me->rt; - scheme_populate_pt_ht(pt); - scheme_protect_primitive_provide(futures_env, NULL); - futures_env->attached = 1; - -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT)) { - printf("Futures count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_FLFXNUM_COUNT - - EXPECTED_EXTFL_COUNT, - EXPECTED_FUTURES_COUNT); - abort(); - } -#endif + scheme_restore_prim_instance(env); } -static void init_foreign(Scheme_Env *env) +static void init_futures(Scheme_Startup_Env *env) { - Scheme_Env *ffi_env; + scheme_switch_prim_instance(env, "#%futures"); + scheme_init_futures(env); + + scheme_restore_prim_instance(env); +} + +static void init_foreign(Scheme_Startup_Env *env) +{ scheme_init_foreign(env); - - ffi_env = scheme_get_foreign_env(); - scheme_populate_pt_ht(ffi_env->module->me->rt); - ffi_env->attached = 1; - -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT - + EXPECTED_UNSAFE_COUNT + EXPECTED_FOREIGN_COUNT)) { - printf("Foreign count %d doesn't match expected count %d\n", - builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_FLFXNUM_COUNT - - EXPECTED_EXTFL_COUNT - EXPECTED_FUTURES_COUNT - - EXPECTED_UNSAFE_COUNT, - EXPECTED_FOREIGN_COUNT); - abort(); - } -#endif } -Scheme_Env *scheme_get_unsafe_env() { - return unsafe_env; -} +/*========================================================================*/ +/* place-specific intialization */ +/*========================================================================*/ -Scheme_Env *scheme_get_flfxnum_env() { - return flfxnum_env; -} - -Scheme_Env *scheme_get_extfl_env() { - return extfl_env; -} - -Scheme_Env *scheme_get_futures_env() { - return futures_env; -} - - -static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread) { +static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread) +{ Scheme_Env *env; #ifdef TIME_STARTUP_PROCESS @@ -524,10 +463,6 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr scheme_init_stx_places(initial_main_os_thread); - scheme_init_syntax_bindings(); - - scheme_init_module_resolver(); - #ifdef TIME_STARTUP_PROCESS printf("process @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); #endif @@ -544,6 +479,7 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr scheme_init_string_places(); scheme_init_logger(); scheme_init_eval_places(); + scheme_init_linklet_places(); scheme_init_compile_places(); scheme_init_regexp_places(); scheme_init_sema_places(); @@ -552,9 +488,6 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr scheme_init_foreign_places(); #endif - env = scheme_make_empty_env(); - scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); - /*initialize config */ scheme_init_port_config(); scheme_init_port_fun_config(); @@ -564,14 +497,8 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr scheme_init_exn_config(); #endif scheme_init_error_config(); + scheme_init_place_per_place(); -/* BEGIN PRIMITIVE MODULES */ - scheme_init_linklet(env); - scheme_init_network(env); - scheme_init_paramz(env); - scheme_init_expand_observe(env); - scheme_init_place(env); -/* END PRIMITIVE MODULES */ #if defined(MZ_USE_PLACES) && defined(MZ_USE_JIT) scheme_jit_fill_threadlocal_table(); #endif @@ -588,11 +515,17 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr printf("pre-embedded @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); #endif - scheme_add_embedded_builtins(env); + REGISTER_SO(scheme_startup_instance); + scheme_startup_instance = scheme_make_instance(scheme_intern_symbol("startup"), scheme_false); + scheme_init_startup_instance(scheme_startup_instance); + REGISTER_SO(scheme_namespace_to_env); + scheme_namespace_to_env = scheme_make_bucket_table(5, SCHEME_hash_weak_ptr); + env = scheme_make_empty_env(); + boot_module_resolver(); - scheme_save_initial_module_set(env); + scheme_init_resolver_config(); scheme_starting_up = 0; @@ -610,7 +543,8 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr } #ifdef MZ_USE_PLACES -Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) { +Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) +{ Scheme_Env *env; # if defined(MZ_PRECISE_GC) int *signal_fd; @@ -669,205 +603,6 @@ void scheme_place_instance_destroy(int force) rktio_destroy(scheme_rktio); } -static void make_kernel_env(void) -{ - Scheme_Env *env; -#ifdef TIME_STARTUP_PROCESS - intptr_t startt; -#endif - - env = make_empty_inited_env(GLOBAL_TABLE_SIZE); - - REGISTER_SO(kernel_env); - kernel_env = env; - - scheme_defining_primitives = 1; - builtin_ref_counter = 0; - -#ifdef TIME_STARTUP_PROCESS - printf("init @ %" PRIdPTR "\n", scheme_get_process_milliseconds()); -# define MZTIMEIT(n, f) (MARK_START_TIME(), f, DONE_TIME(n)) -# define MARK_START_TIME() startt = scheme_get_process_milliseconds() -# define DONE_TIME(n) (printf(#n ": %" PRIdPTR "\n", (intptr_t)(scheme_get_process_milliseconds() - startt))) -#else -# define MZTIMEIT(n, f) f -# define MARK_START_TIME() /**/ -# define DONE_TIME(n) /**/ -#endif - - /* The ordering of the first few init calls is important, so add to - the end of the list, not the beginning. */ - MZTIMEIT(symbol-type, scheme_init_symbol_type(env)); - MZTIMEIT(fun, scheme_init_fun(env)); - MZTIMEIT(symbol, scheme_init_symbol(env)); - MZTIMEIT(list, scheme_init_list(env)); - MZTIMEIT(number, scheme_init_number(env)); - MZTIMEIT(numarith, scheme_init_numarith(env)); - MZTIMEIT(numcomp, scheme_init_numcomp(env)); - MZTIMEIT(numstr, scheme_init_numstr(env)); - MZTIMEIT(bignum, scheme_init_bignum()); - MZTIMEIT(char-const, scheme_init_char_constants()); - MZTIMEIT(stx, scheme_init_stx(env)); - MZTIMEIT(module, scheme_init_module(env)); - MZTIMEIT(port, scheme_init_port(env)); - MZTIMEIT(portfun, scheme_init_port_fun(env)); - MZTIMEIT(string, scheme_init_string(env)); - MZTIMEIT(vector, scheme_init_vector(env)); - MZTIMEIT(char, scheme_init_char(env)); - MZTIMEIT(bool, scheme_init_bool(env)); - MZTIMEIT(syntax, scheme_init_compile(env)); - MZTIMEIT(eval, scheme_init_eval(env)); - MZTIMEIT(struct, scheme_init_struct(env)); - MZTIMEIT(error, scheme_init_error(env)); -#ifndef NO_SCHEME_EXNS - MZTIMEIT(exn, scheme_init_exn(env)); -#endif - MZTIMEIT(process, scheme_init_thread(env)); - scheme_init_port_wait(); - scheme_init_inspector(); - scheme_init_logger_wait(); - scheme_init_struct_wait(); - MZTIMEIT(reduced, scheme_init_reduced_proc_struct(env)); -#ifndef NO_SCHEME_THREADS - MZTIMEIT(sema, scheme_init_sema(env)); -#endif - MZTIMEIT(read, scheme_init_read(env)); - MZTIMEIT(print, scheme_init_print(env)); - MZTIMEIT(file, scheme_init_file(env)); - MZTIMEIT(dynamic-extension, scheme_init_dynamic_extension(env)); -#ifndef NO_REGEXP_UTILS - MZTIMEIT(regexp, scheme_regexp_initialize(env)); -#endif - MZTIMEIT(params, scheme_init_parameterization()); - MZTIMEIT(futures, scheme_init_futures_once()); - MZTIMEIT(places, scheme_init_places_once()); - - MARK_START_TIME(); - - GLOBAL_PRIM_W_ARITY("namespace-symbol->identifier", namespace_identifier, 1, 2, env); - GLOBAL_PRIM_W_ARITY("namespace-module-identifier", namespace_module_identifier, 0, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-base-phase", namespace_base_phase, 0, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-variable-value", namespace_variable_value, 1, 4, env); - GLOBAL_PRIM_W_ARITY("namespace-set-variable-value!", namespace_set_variable_value, 2, 4, env); - GLOBAL_PRIM_W_ARITY("namespace-undefine-variable!", namespace_undefine_variable, 1, 2, env); - GLOBAL_PRIM_W_ARITY("namespace-mapped-symbols", namespace_mapped_symbols, 0, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-module-registry", namespace_module_registry, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("variable-reference?", variable_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-path-index", variable_modidx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->resolved-module-path", variable_module_path, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-source", variable_module_source, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-base-phase", variable_base_phase, 1, 1, env); - GLOBAL_PRIM_W_ARITY("variable-reference->module-declaration-inspector", variable_inspector, 1, 1, env); - - REGISTER_SO(scheme_varref_const_p_proc); - scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p, - "variable-reference-constant?", - 1, 1); - scheme_add_global_constant("variable-reference-constant?", scheme_varref_const_p_proc, env); - - REGISTER_SO(scheme_varref_from_unsafe_p_proc); - scheme_varref_from_unsafe_p_proc = scheme_make_prim_w_arity(variable_unsafe_p, - "variable-reference-from-unsafe?", - 1, 1); - scheme_add_global_constant("variable-reference-from-unsafe?", scheme_varref_from_unsafe_p_proc, env); - - GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-transforming-with-lifts?", now_transforming_with_lifts, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-transforming-module-expression?", now_transforming_module, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); - GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env); - GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 2, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context-introduce", intdef_context_intro, 2, 3, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("internal-definition-context-binding-identifiers", intdef_context_ids, 1, 1, env); - GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-identifier-as-binding", local_binding_id, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-make-delta-introducer", local_make_delta_introduce, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-submodules", local_submodules, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-transforming-module-provides?", local_module_expanding_provides, 0, 0, env); - - GLOBAL_PRIM_W_ARITY("make-set!-transformer", make_set_transformer, 1, 1, env); - GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 1, env); - GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-values-expression", local_lift_exprs, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-module", local_lift_module, 1, 1, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env); - - DONE_TIME(env); - - scheme_register_network_evts(); - - REGISTER_SO(kernel_symbol); - kernel_symbol = scheme_intern_symbol("#%kernel"); - - REGISTER_SO(flip_symbol); - REGISTER_SO(add_symbol); - REGISTER_SO(remove_symbol); - flip_symbol = scheme_intern_symbol("flip"); - add_symbol = scheme_intern_symbol("add"); - remove_symbol = scheme_intern_symbol("remove"); - - MARK_START_TIME(); - - scheme_finish_kernel(env); - -#if USE_COMPILED_STARTUP - if (builtin_ref_counter != EXPECTED_PRIM_COUNT) { - printf("Primitive count %d doesn't match expected count %d\n" - "Turn off USE_COMPILED_STARTUP in src/schminc.h\n", - builtin_ref_counter, EXPECTED_PRIM_COUNT); - abort(); - } -#endif - - init_flfxnum(env); - init_extfl(env); - init_futures(env); - - builtin_unsafe_start = builtin_ref_counter; - init_unsafe(env); - init_foreign(env); - - scheme_init_print_global_constants(); - scheme_init_variable_references_constants(); - - scheme_init_longdouble_fixup(); - - scheme_defining_primitives = 0; -} - -int scheme_is_kernel_env(Scheme_Env *env) { - return (env == kernel_env); -} - -Scheme_Env *scheme_get_kernel_env() { - return kernel_env; -} - /* Shutdown procedure for resetting a namespace: */ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data) { @@ -882,855 +617,90 @@ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client } /*========================================================================*/ -/* namespace constructors */ +/* instances and startup env */ /*========================================================================*/ -void scheme_prepare_env_stx_context(Scheme_Env *env) +static Scheme_Startup_Env *make_startup_env(void) { - Scheme_Object *mc, *shift, *insp; + Scheme_Startup_Env *e; + Scheme_Hash_Table *table; + Scheme_Hash_Table *primitive_tables; - if (env->stx_context) return; + e = MALLOC_ONE_TAGGED(Scheme_Startup_Env); + e->so.type = scheme_startup_env_type; - insp = env->access_insp; - if (!insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + primitive_tables = scheme_make_hash_table(SCHEME_hash_ptr); + e->primitive_tables = primitive_tables; - if (env->module) { - shift = scheme_make_shift(scheme_make_integer(0), - NULL, NULL, - env->module_registry->exports, - (env->module->prefix - ? env->module->prefix->src_insp_desc - : env->module->insp), - insp); + table = scheme_make_hash_table(SCHEME_hash_ptr); + e->current_table = table; + scheme_hash_set(e->primitive_tables, kernel_symbol, (Scheme_Object *)table); - mc = scheme_make_module_context(insp, shift, env->module->modname); - } else - mc = scheme_make_module_context(insp, NULL, scheme_false); + table = scheme_make_hash_table(SCHEME_hash_ptr); + e->all_primitives_table = table; - env->stx_context = mc; -} - -Scheme_Env *scheme_make_empty_env(void) -{ - Scheme_Env *e; - - e = make_empty_inited_env(7); + table = scheme_make_hash_table(SCHEME_hash_ptr); + e->primitive_ids_table = table; return e; } -Scheme_Env *make_empty_inited_env(int toplevel_size) +void scheme_switch_prim_instance(Scheme_Startup_Env *env, const char *name) { - Scheme_Env *env; - Scheme_Object *vector; - Scheme_Hash_Table* hash_table; - Scheme_Module_Registry *reg; + Scheme_Hash_Table *table; + Scheme_Object *sym; - env = make_env(NULL, toplevel_size); - - vector = scheme_make_vector(5, scheme_false); - hash_table = scheme_make_hash_table(SCHEME_hash_ptr); - SCHEME_VEC_ELS(vector)[0] = (Scheme_Object *)hash_table; - env->modchain = vector; - - reg = MALLOC_ONE_TAGGED(Scheme_Module_Registry); - reg->so.type = scheme_module_registry_type; - env->module_registry = reg; - - hash_table = scheme_make_hash_table(SCHEME_hash_ptr); - reg->loaded = hash_table; - hash_table = scheme_make_hash_table(SCHEME_hash_ptr); - MZ_OPT_HASH_KEY(&(hash_table->iso)) |= 0x1; /* print (for debugging) as opqaue */ - reg->exports = hash_table; - - env->label_env = NULL; - - return env; -} - -Scheme_Env *make_empty_not_inited_env(int toplevel_size) -{ - Scheme_Env *e; - - e = make_env(NULL, toplevel_size); - - return e; -} - -static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size) -{ - Scheme_Env *env; - Scheme_Bucket_Table *bucket_table; - - env = MALLOC_ONE_TAGGED(Scheme_Env); - env->so.type = scheme_namespace_type; - - bucket_table = scheme_make_bucket_table(toplevel_size, SCHEME_hash_ptr); - env->toplevel = bucket_table; - env->toplevel->with_home = 1; - - bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); - env->syntax = bucket_table; - - if (base) { - env->modchain = base->modchain; - env->module_registry = base->module_registry; - env->module_pre_registry = base->module_pre_registry; - env->label_env = base->label_env; - } else { - env->modchain = NULL; - env->module_registry = NULL; - env->module_pre_registry = NULL; - env->label_env = NULL; - } - - return env; -} - -Scheme_Env *scheme_make_env_like(Scheme_Env *base) -{ - return make_env(base, 10); -} - -Scheme_Env * -scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, - int new_exp_module_tree, int new_pre_registry) -{ - Scheme_Env *menv; - Scheme_Module_Registry *reg; - - menv = make_env(env, 7); - - if (new_pre_registry) { - /* pre_registry is for declarations to be used by submodules */ - reg = MALLOC_ONE_TAGGED(Scheme_Module_Registry); - reg->so.type = scheme_module_registry_type; - menv->module_pre_registry = reg; - } - - menv->module = m; - menv->instance_env = env; - menv->reader_env = (env->reader_env ? env->reader_env : env); - - if (new_exp_module_tree) { - /* It would be nice to share the label env with `env`, but we need - to set `module_pre_registry` in `menv->label_env` and not shared - it with `env->label_env`: */ - menv->label_env = NULL; - scheme_prepare_label_env(menv); - menv->instance_env = menv; - } else { - scheme_prepare_label_env(env); - menv->label_env = env->label_env; - } - - if (new_exp_module_tree) { - Scheme_Object *p; - Scheme_Hash_Table *modules; - - modules = scheme_make_hash_table(SCHEME_hash_ptr); - p = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(p)[0] = (Scheme_Object *)modules; - menv->modchain = p; - } - - if (SAME_OBJ(env, env->exp_env)) { - /* label phase */ - menv->exp_env = menv; - menv->template_env = menv; - } - - return menv; -} - -void scheme_prepare_exp_env(Scheme_Env *env) -{ - if (!env->exp_env) { - Scheme_Env *eenv; - Scheme_Object *modchain, *mc; - - scheme_prepare_label_env(env); - - eenv = make_empty_not_inited_env(7); - eenv->phase = env->phase + 1; - eenv->mod_phase = env->mod_phase + 1; - - eenv->module = env->module; - eenv->module_registry = env->module_registry; - eenv->module_pre_registry = env->module_pre_registry; - eenv->access_insp = env->access_insp; - eenv->guard_insp = env->guard_insp; - - modchain = SCHEME_VEC_ELS(env->modchain)[1]; - if (SCHEME_FALSEP(modchain)) { - Scheme_Hash_Table *next_modules; - - next_modules = scheme_make_hash_table(SCHEME_hash_ptr); - modchain = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)next_modules; - SCHEME_VEC_ELS(env->modchain)[1] = modchain; - SCHEME_VEC_ELS(modchain)[2] = env->modchain; - } - eenv->modchain = modchain; - - env->exp_env = eenv; - eenv->template_env = env; - eenv->label_env = env->label_env; - eenv->instance_env = env->instance_env; - eenv->reader_env = (env->reader_env ? env->reader_env : env); - - scheme_prepare_env_stx_context(env); - mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv)); - eenv->stx_context = mc; - - if (env->disallow_unbound) - eenv->disallow_unbound = env->disallow_unbound; - } -} - -void scheme_prepare_template_env(Scheme_Env *env) -{ - if (!env->template_env) { - Scheme_Env *eenv; - Scheme_Object *modchain, *mc; - - scheme_prepare_label_env(env); - - eenv = make_empty_not_inited_env(7); - eenv->phase = env->phase - 1; - eenv->mod_phase = env->mod_phase - 1; - - eenv->module = env->module; - eenv->module_registry = env->module_registry; - eenv->module_pre_registry = env->module_pre_registry; - eenv->guard_insp = env->guard_insp; - eenv->access_insp = env->access_insp; - - modchain = SCHEME_VEC_ELS(env->modchain)[2]; - if (SCHEME_FALSEP(modchain)) { - Scheme_Hash_Table *prev_modules; - - prev_modules = scheme_make_hash_table(SCHEME_hash_ptr); - modchain = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)prev_modules; - SCHEME_VEC_ELS(env->modchain)[2] = modchain; - SCHEME_VEC_ELS(modchain)[1] = env->modchain; - } - eenv->modchain = modchain; - - scheme_prepare_env_stx_context(env); - mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv)); - eenv->stx_context = mc; - - env->template_env = eenv; - eenv->exp_env = env; - eenv->label_env = env->label_env; - eenv->instance_env = env->instance_env; - eenv->reader_env = (env->reader_env ? env->reader_env : env); - - if (env->disallow_unbound) - eenv->disallow_unbound = env->disallow_unbound; - } -} - -void scheme_prepare_label_env(Scheme_Env *env) -{ - if (!env->label_env) { - Scheme_Env *lenv; - Scheme_Object *modchain; - Scheme_Hash_Table *prev_modules; - - lenv = make_empty_not_inited_env(7); - lenv->phase = 0; - lenv->mod_phase = 0; - - lenv->module = env->module; - lenv->module_registry = env->module_registry; - lenv->module_pre_registry = env->module_pre_registry; - lenv->guard_insp = env->guard_insp; - lenv->access_insp = env->access_insp; - - modchain = scheme_make_vector(5, scheme_false); - prev_modules = scheme_make_hash_table(SCHEME_hash_ptr); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)prev_modules; - SCHEME_VEC_ELS(modchain)[2] = modchain; - SCHEME_VEC_ELS(modchain)[1] = modchain; - lenv->modchain = modchain; - - env->label_env = lenv; - - lenv->exp_env = lenv; - lenv->label_env = lenv; - lenv->template_env = lenv; - lenv->instance_env = env->instance_env; - lenv->reader_env = (env->reader_env ? env->reader_env : env); - } -} - -Scheme_Object *scheme_env_phase(Scheme_Env *env) -{ - if (env == env->label_env) - return scheme_false; - else - return scheme_make_integer(env->phase); -} - -Scheme_Env *scheme_find_env_at_phase(Scheme_Env *env, Scheme_Object *phase) -{ - if (SCHEME_FALSEP(phase)) { - scheme_prepare_label_env(env); - env = env->label_env; - } else { - intptr_t ph = SCHEME_INT_VAL(phase) - env->phase; - intptr_t j; - - if (ph > 0) { - for (j = 0; j < ph; j++) { - scheme_prepare_exp_env(env); - env = env->exp_env; - } - } else if (ph < 0) { - for (j = 0; j > ph; j--) { - scheme_prepare_template_env(env); - env = env->template_env; - } - } - } - - return env; -} - -Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Object *modchain, int clone_phase) -{ - /* New env should have the same syntax and globals table, but it lives in - a different namespace. */ - Scheme_Env *menv2; - Scheme_Bucket_Table *bucket_table; - - scheme_prepare_label_env(ns); - - menv2 = MALLOC_ONE_TAGGED(Scheme_Env); - menv2->so.type = scheme_namespace_type; - - menv2->module = menv->module; - menv2->module_registry = ns->module_registry; - menv2->module_pre_registry = ns->module_pre_registry; - menv2->guard_insp = menv->guard_insp; - menv2->access_insp = menv->access_insp; - - menv2->instance_env = menv2; - - if (menv->phase < clone_phase) - menv2->syntax = menv->syntax; - else { - bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); - menv2->syntax = bucket_table; - } - - menv2->phase = menv->phase; - menv2->mod_phase = menv->mod_phase; - menv2->link_midx = menv->link_midx; - if (menv->phase <= clone_phase) { - menv2->ran = menv->ran; - } - if (menv->mod_phase == 0) { - char *running; - int amt; - running = (char *)scheme_malloc_atomic(menv->module->num_phases); - menv2->running = running; - memset(running, 0, menv->module->num_phases); - amt = (clone_phase - menv->phase) + 1; - if (amt > 0) { - if (amt > menv->module->num_phases) - amt = menv->module->num_phases; - memcpy(running, menv->running, amt); - } - } - - menv2->require_names = menv->require_names; - menv2->et_require_names = menv->et_require_names; - menv2->tt_require_names = menv->tt_require_names; - menv2->dt_require_names = menv->dt_require_names; - menv2->other_require_names = menv->other_require_names; - - if (menv->phase <= clone_phase) { - menv2->toplevel = menv->toplevel; - } else { - bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); - menv2->toplevel = bucket_table; - menv2->toplevel->with_home = 1; - } + sym = scheme_intern_symbol(name); - menv2->modchain = modchain; - - if (SAME_OBJ(menv->exp_env, menv)) { - /* label phase */ - menv2->exp_env = menv2; - menv2->template_env = menv2; - } else if (menv->phase < clone_phase) { - if (!SCHEME_NULLP(menv2->module->et_requires)) { - /* We'll need the next link in the modchain: */ - modchain = SCHEME_VEC_ELS(modchain)[1]; - if (SCHEME_FALSEP(modchain)) { - Scheme_Hash_Table *next_modules; - - next_modules = scheme_make_hash_table(SCHEME_hash_ptr); - modchain = scheme_make_vector(5, scheme_false); - SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)next_modules; - SCHEME_VEC_ELS(menv2->modchain)[1] = modchain; - SCHEME_VEC_ELS(modchain)[2] = menv2->modchain; - } - } - - if (menv->exp_env) { - /* Share for-syntax bindings, too: */ - scheme_prepare_exp_env(menv2); - menv2->exp_env->toplevel = menv->exp_env->toplevel; - } - } - - scheme_prepare_label_env(ns); - menv2->label_env = ns->label_env; - menv2->reader_env = (ns->reader_env ? ns->reader_env : ns); - - return menv2; -} - -Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home) -{ - Scheme_Bucket_Table *r; - Scheme_Bucket **bs; - intptr_t i; - - r = scheme_make_bucket_table(ht->size, SCHEME_hash_ptr); - if (home) - r->with_home = 1; - - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) { - Scheme_Object *name = (Scheme_Object *)b->key; - Scheme_Object *val = (Scheme_Object *)b->val; - - b = scheme_bucket_from_table(r, (const char *)name); - b->val = val; - if (home) { - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, home); - } - } + table = (Scheme_Hash_Table *)scheme_hash_get(env->primitive_tables, sym); + if (!table) { + table = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(env->primitive_tables, sym, (Scheme_Object *)table); } - return r; + env->current_table = table; } -Scheme_Object *scheme_get_home_weak_link(Scheme_Env *e) +void scheme_restore_prim_instance(Scheme_Startup_Env *env) { - if (!e->weak_self_link) { - Scheme_Object *wb; - if (scheme_starting_up) - wb = scheme_box((Scheme_Object *)e); - else - wb = scheme_make_weak_box((Scheme_Object *)e); - e->weak_self_link = wb; - } - - return e->weak_self_link; + Scheme_Hash_Table *table; + table = (Scheme_Hash_Table *)scheme_hash_get(env->primitive_tables, kernel_symbol); + env->current_table = table; } -Scheme_Env *scheme_get_bucket_home(Scheme_Bucket *b) +void scheme_addto_prim_instance(const char *name, Scheme_Object *obj, Scheme_Startup_Env *env) { - Scheme_Object *l; - - l = ((Scheme_Bucket_With_Home *)b)->home_link; - if (l) { - if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) - return (Scheme_Env *)l; - else - return (Scheme_Env *)SCHEME_WEAK_BOX_VAL(l); - } else - return NULL; -} - -void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Env *e) -{ - if (!((Scheme_Bucket_With_Home *)b)->home_link) { - if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) - ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)e; - else { - Scheme_Object *link; - link = scheme_get_home_weak_link(e); - ((Scheme_Bucket_With_Home *)b)->home_link = link; - } - } -} - -/*========================================================================*/ -/* namespace bindings */ -/*========================================================================*/ - -/********** Lookup **********/ - -Scheme_Object * -scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env) -{ - Scheme_Bucket *b; - - b = scheme_bucket_or_null_from_table(env->toplevel, (char *)symbol, 0); - if (b) { - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, env); - return (Scheme_Object *)b->val; - } - - return NULL; -} - -Scheme_Bucket * -scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env) -{ - Scheme_Bucket *b; - - b = scheme_bucket_from_table(env->toplevel, (char *)symbol); - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, env); - - return b; -} - -Scheme_Bucket * -scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env) -{ - Scheme_Bucket *b; - - b = scheme_bucket_from_table(env->syntax, (char *)symbol); - - return b; -} - -/********** Set **********/ - -void -scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, - Scheme_Object *obj, - int valvar, int constant) -{ - if (valvar) { - Scheme_Bucket *b; - b = scheme_bucket_from_table(env->toplevel, (const char *)sym); - b->val = obj; - ASSERT_IS_VARIABLE_BUCKET(b); - if (constant && scheme_defining_primitives) { - ((Scheme_Bucket_With_Flags *)b)->id = builtin_ref_counter++; - ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST | GLOB_STRONG_HOME_LINK); - } else if (constant) - ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_CONST | GLOB_STRONG_HOME_LINK); - scheme_set_bucket_home(b, env); - } else - scheme_add_to_table(env->syntax, (const char *)sym, obj, constant); + scheme_addto_primitive_instance_by_symbol(scheme_intern_symbol(name), obj, env); } void -scheme_add_global(const char *name, Scheme_Object *obj, Scheme_Env *env) +scheme_addto_primitive_instance_by_symbol(Scheme_Object *name, Scheme_Object *obj, Scheme_Startup_Env *env) { - scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 1, 0); + scheme_hash_set(env->current_table, name, obj); + scheme_hash_set(env->all_primitives_table, name, obj); + + scheme_hash_set(env->primitive_ids_table, obj, scheme_make_integer(builtin_ref_counter)); + builtin_ref_counter++; } -void -scheme_add_global_symbol(Scheme_Object *sym, Scheme_Object *obj, Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, sym, obj, 1, 0); -} - -void -scheme_add_global_constant(const char *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 1, 1); -} - -void -scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, name, obj, 1, 1); -} - -void -scheme_add_global_keyword(const char *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 0, 0); -} - -void -scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *obj, - Scheme_Env *env) -{ - scheme_do_add_global_symbol(env, name, obj, 0, 0); -} - -static Scheme_Object *vector_to_ht(Scheme_Object *vec, int kind) -{ - Scheme_Hash_Tree *ht; - Scheme_Object *key, *val, *orig_val; - intptr_t i; - - ht = scheme_make_hash_tree(kind); - - i = SCHEME_VEC_SIZE(vec); - if (i & 1) return (Scheme_Object *)ht; /* defend against bad bytecode */ - - while (i -= 2) { - key = SCHEME_VEC_ELS(vec)[i]; - orig_val = SCHEME_VEC_ELS(vec)[i+1]; - - val = scheme_stx_force_delayed(orig_val); - if (val != orig_val) - SCHEME_VEC_ELS(vec)[i+1] = val; - - /* defend against bad bytecode here, too: */ - if (kind) { - if (!SCHEME_INTP(key) - || !SCHEME_VECTORP(val)) - key = NULL; - } else { - if (!SCHEME_SYMBOLP(key) - || ((!SCHEME_STXP(val) - || !SCHEME_SYMBOLP(SCHEME_STX_VAL(val))) - && !SAME_OBJ(val, scheme_true))) - key = NULL; - } - - if (key) { - if (kind) - val = vector_to_ht(val, 0); - else if (!SAME_OBJ(val, scheme_true)) - val = scheme_stx_force_delayed(val); - - ht = scheme_hash_tree_set(ht, key, val); - } - } - - return (Scheme_Object *)ht; -} - -void scheme_binding_names_from_module(Scheme_Env *menv) -{ - Scheme_Module *m; - Scheme_Object *binding_names; - - if (menv->binding_names - || !menv->module - || menv->binding_names_need_shift) - return; - - m = menv->module; - - if (menv->phase == 0) { - binding_names = m->binding_names; - if (binding_names && SCHEME_VECTORP(binding_names)) { - binding_names = vector_to_ht(binding_names, 0); - m->binding_names = binding_names; - } - } else if (menv->phase == 1) { - binding_names = m->et_binding_names; - if (binding_names && SCHEME_VECTORP(binding_names)) { - binding_names = vector_to_ht(binding_names, 0); - m->et_binding_names = binding_names; - } - } else if (m->other_binding_names) { - binding_names = m->other_binding_names; - if (binding_names && SCHEME_VECTORP(binding_names)) { - binding_names = vector_to_ht(binding_names, 1); - m->other_binding_names = binding_names; - } - if (SCHEME_HASHTP(binding_names)) - binding_names = scheme_hash_get((Scheme_Hash_Table *)binding_names, scheme_env_phase(menv)); - else - binding_names = scheme_hash_tree_get((Scheme_Hash_Tree *)binding_names, scheme_env_phase(menv)); - } else - binding_names = NULL; - - menv->binding_names = binding_names; - menv->binding_names_need_shift = 1; -} - -void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as_var) -{ - Scheme_Object *id; - - if (!as_var) - val = SCHEME_PTR_VAL(val); /* remove "is a compile-time binding" wrapper */ - - if (!env - || (env->module - && !env->interactive_bindings - && !scheme_is_binding_rename_transformer(val))) - return; - - if (as_var) { - if (!env->shadowed_syntax) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - env->shadowed_syntax = ht; - } - - scheme_hash_set(env->shadowed_syntax, n, scheme_true); - } else { - if (env->shadowed_syntax) - scheme_hash_set(env->shadowed_syntax, n, NULL); - } - - scheme_binding_names_from_module(env); - - if (env->binding_names) { - if (SCHEME_HASHTP(env->binding_names)) - id = scheme_eq_hash_get((Scheme_Hash_Table *)env->binding_names, n); - else - id = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)env->binding_names, n); - if (id && !SCHEME_STXP(id)) - id = NULL; - } else - id = NULL; - - if (!id) { - if (env->module) - return; - scheme_prepare_env_stx_context(env); - id = scheme_datum_to_syntax(n, scheme_false, scheme_false, 0, 0); - id = scheme_stx_add_module_context(id, env->stx_context); - } - - if (env->binding_names_need_shift) { - id = scheme_stx_shift(id, scheme_make_integer(env->phase - env->mod_phase), - env->module->self_modidx, env->link_midx, - env->module_registry->exports, - env->module->prefix->src_insp_desc, env->access_insp); - } - - scheme_add_module_binding(id, scheme_env_phase(env), - (env->module - ? (env->link_midx - ? env->link_midx - : env->module->self_modidx) - : scheme_false), - ((env->module && env->module->prefix) - ? env->module->prefix->src_insp_desc - : env->guard_insp), - n, - scheme_env_phase(env)); - - /* If the binding is a rename transformer, also install - a mapping */ - if (scheme_is_binding_rename_transformer(val)) - scheme_add_binding_copy(id, scheme_rename_transformer_id(val, NULL), scheme_env_phase(env)); -} - -static void install_one_binding_name(Scheme_Hash_Table *bt, Scheme_Object *name, Scheme_Object *id, Scheme_Env *benv) -{ - if (SCHEME_SYMBOLP(name) && SCHEME_STX_SYMBOLP(id)) { - if (benv->stx_context) - id = scheme_stx_push_introduce_module_context(id, benv->stx_context); - scheme_hash_set(bt, name, id); - } -} - -void scheme_install_binding_names(Scheme_Object *binding_namess, Scheme_Env *env) -/* binding_namess has a per-phase mapping of symbosl to identifier, recorded - when `define` and `define-syntaxes` forms were compiled at the top level; - install the symbol-to-identifier mapping that was recorded during compilation - into the current namespace */ -{ - Scheme_Env *benv; - Scheme_Object *sym, *id, *table; - Scheme_Hash_Tree *ht; - Scheme_Hash_Table *bt; - intptr_t i, phase; - - if (!binding_namess) return; - - while (SCHEME_PAIRP(binding_namess)) { - table = SCHEME_CAR(binding_namess); - if (!SCHEME_PAIRP(table)) - return; - phase = SCHEME_INT_VAL(SCHEME_CAR(table)); - table = SCHEME_CDR(table); - - if (phase < 0) - return; - - benv = env; - while (phase > 0) { - scheme_prepare_exp_env(benv); - benv = benv->exp_env; - phase--; - } - - bt = scheme_get_binding_names_table(benv); - - if (SCHEME_HASHTRP(table)) { - ht = (Scheme_Hash_Tree *)table; - i = -1; - while ((i = scheme_hash_tree_next(ht, i)) != -1) { - scheme_hash_tree_index(ht, i, &sym, &id); - install_one_binding_name(bt, sym, id, benv); - } - } else if (SCHEME_VECTORP(table)) { - for (i = SCHEME_VEC_SIZE(table) >> 1; i--; ) { - install_one_binding_name(bt, SCHEME_VEC_ELS(table)[2*i], SCHEME_VEC_ELS(table)[2*i+1], benv); - } - } - - binding_namess = SCHEME_CDR(binding_namess); - } -} - -/********** Auxilliary tables **********/ - Scheme_Object **scheme_make_builtin_references_table(int *_unsafe_start) { - Scheme_Bucket_Table *ht; - Scheme_Object **t; - Scheme_Bucket **bs; - Scheme_Env *kenv; - intptr_t i; - int j; + Scheme_Object **t, *v; + int i; t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1)); #ifdef MEMORY_COUNTING_ON scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1); #endif - for (j = builtin_ref_counter + 1; j--; ) { - t[j] = scheme_false; + for (i = builtin_ref_counter + 1; i--; ) { + t[i] = scheme_false; } - for (j = 0; j < 6; j++) { - if (!j) - kenv = kernel_env; - else if (j == 1) - kenv = unsafe_env; - else if (j == 2) - kenv = flfxnum_env; - else if (j == 3) - kenv = extfl_env; - else if (j == 4) - kenv = futures_env; - else - kenv = scheme_get_foreign_env(); - - ht = kenv->toplevel; - - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_HAS_REF_ID)) - t[((Scheme_Bucket_With_Ref_Id *)b)->id] = (Scheme_Object *)b->val; + for (i = scheme_startup_env->primitive_ids_table->size; i--; ) { + v = scheme_startup_env->primitive_ids_table->vals[i]; + if (v) { + t[SCHEME_INT_VAL(v)] = scheme_startup_env->primitive_ids_table->keys[i]; } } @@ -1739,84 +709,76 @@ Scheme_Object **scheme_make_builtin_references_table(int *_unsafe_start) return t; } -Scheme_Hash_Table *scheme_map_constants_to_globals(void) -{ - Scheme_Bucket_Table *ht; - Scheme_Hash_Table*result; - Scheme_Bucket **bs; - Scheme_Env *kenv; - intptr_t i; - int j; - - result = scheme_make_hash_table(SCHEME_hash_ptr); - - for (j = 0; j < 6; j++) { - if (!j) - kenv = kernel_env; - else if (j == 1) - kenv = unsafe_env; - else if (j == 2) - kenv = flfxnum_env; - else if (j == 3) - kenv = extfl_env; - else if (j == 4) - kenv = futures_env; - else - kenv = scheme_get_foreign_env(); - - ht = kenv->toplevel; - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)) { - scheme_hash_set(result, b->val, (Scheme_Object *)b); - } - } - } - - return result; -} - const char *scheme_look_for_primitive(void *code) { - Scheme_Bucket_Table *ht; - Scheme_Bucket **bs; - Scheme_Env *kenv; intptr_t i; - int j; + Scheme_Object *val; - for (j = 0; j < 6; j++) { - if (!j) - kenv = kernel_env; - else if (j == 1) - kenv = unsafe_env; - else if (j == 2) - kenv = flfxnum_env; - else if (j == 3) - kenv = extfl_env; - else if (j == 4) - kenv = futures_env; - else - kenv = scheme_get_foreign_env(); - - ht = kenv->toplevel; - bs = ht->buckets; - - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) { - if (SCHEME_PRIMP(b->val)) { - if (SCHEME_PRIM(b->val) == code) - return ((Scheme_Primitive_Proc *)b->val)->name; - } - } + for (i = scheme_startup_env->all_primitives_table->size; i--; ) { + val = scheme_startup_env->all_primitives_table->vals[i]; + if (val && SCHEME_PRIMP(val)) { + if (SCHEME_PRIM(val) == code) + return ((Scheme_Primitive_Proc *)val)->name; } } return NULL; } +Scheme_Object *scheme_builtin_value(const char *name) +{ + Scheme_Object *sym, *v; + Scheme_Bucket *b; + + sym = scheme_intern_symbol(name); + v = scheme_hash_get(scheme_startup_env->all_primitives_table, sym); + if (!v) { + b = scheme_instance_variable_bucket_or_null(sym, scheme_startup_instance); + if (b) + return b->val; + } + + return v; +} + +/*========================================================================*/ +/* namespace bindings */ +/*========================================================================*/ + +Scheme_Object *scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env) +{ + Scheme_Bucket *b; + b = scheme_instance_variable_bucket_or_null(symbol, env->instance); + if (b) + return b->val; + else + return NULL; +} + +Scheme_Bucket *scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env) +{ + return scheme_instance_variable_bucket(symbol, env->instance); +} + +void scheme_add_global(const char *name, Scheme_Object *obj, Scheme_Env *env) +{ + scheme_add_global_symbol(scheme_intern_symbol(name), obj, env); +} + +void scheme_add_global_symbol(Scheme_Object *sym, Scheme_Object *obj, Scheme_Env *env) +{ + Scheme_Bucket *b; + b = scheme_global_bucket(sym, env); + b->val = obj; +} + +Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *proc; + proc = scheme_get_startup_export("make-namespace"); + return scheme_apply(proc, argc, argv); +} + /*========================================================================*/ /* intern literal strings and numbers */ /*========================================================================*/ @@ -1847,1175 +809,6 @@ Scheme_Object *scheme_intern_literal_number(Scheme_Object *num) return(Scheme_Object *)HT_EXTRACT_WEAK(b->key); } -/*========================================================================*/ -/* run-time and expansion-time Racket interface */ -/*========================================================================*/ - -static Scheme_Object * -namespace_identifier(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *obj; - Scheme_Env *genv; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-symbol->identifier", "symbol?", 0, argc, argv); - if ((argc > 1) && !SCHEME_NAMESPACEP(argv[1])) - scheme_wrong_contract("namespace-symbol->identifier", "namespace?", 1, argc, argv); - - if (argc > 1) - genv = (Scheme_Env *)argv[1]; - else - genv = scheme_get_env(NULL); - - obj = argv[0]; - obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0); - - scheme_prepare_env_stx_context(genv); - obj = scheme_stx_add_module_context(obj, genv->stx_context); - - return obj; -} - -static Scheme_Object * -namespace_module_identifier(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *genv; - Scheme_Object *phase; - - if (argc > 0) { - if (SCHEME_NAMESPACEP(argv[0])) { - genv = (Scheme_Env *)argv[0]; - phase = scheme_env_phase(genv); - } else if (SCHEME_FALSEP(argv[0])) { - phase = scheme_false; - } else if (SCHEME_INTP(argv[0]) || SCHEME_BIGNUMP(argv[0])) { - phase = argv[0]; - } else { - scheme_wrong_contract("namespace-module-identifier", "(or/c namespace? #f exact-integer?)", 0, argc, argv); - return NULL; - } - } else { - genv = scheme_get_env(NULL); - phase = scheme_env_phase(genv); - } - - return scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, - scheme_sys_wraps_phase(phase), 0, 0); -} - -static Scheme_Object * -namespace_base_phase(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *genv; - - if ((argc > 0) && !SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract("namespace-base-phase", "namespace?", 0, argc, argv); - - if (argc) - genv = (Scheme_Env *)argv[0]; - else - genv = scheme_get_env(NULL); - - return scheme_env_phase(genv); -} - -static Scheme_Object * -namespace_variable_value(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v, *id = NULL; - Scheme_Env *genv; - int use_map; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-variable-value", "symbol?", 0, argc, argv); - use_map = ((argc > 1) ? SCHEME_TRUEP(argv[1]) : 1); - if ((argc > 2) && SCHEME_TRUEP(argv[2]) - && !scheme_check_proc_arity(NULL, 0, 2, argc, argv)) - scheme_wrong_contract("namespace-variable-value", "(or/c (-> any) #f)", 2, argc, argv); - if ((argc > 3) && !SCHEME_NAMESPACEP(argv[3])) - scheme_wrong_contract("namespace-variable-value", "namespace?", 3, argc, argv); - - if (argc > 3) - genv = (Scheme_Env *)argv[3]; - else - genv = scheme_get_env(NULL); - - if (!use_map) - v = scheme_lookup_global(argv[0], genv); - else - v = scheme_namespace_lookup_value(argv[0], genv, &id, &use_map); - - if (!v) { - if ((argc > 2) && SCHEME_TRUEP(argv[2])) - return _scheme_tail_apply(argv[2], 0, NULL); - else if (use_map == -1) { - scheme_wrong_syntax("namespace-variable-value", NULL, id, "bound to syntax"); - return NULL; - } else { - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0], - "namespace-variable-value: given name is not defined\n" - " name: %S", - argv[0]); - return NULL; - } - } - - return v; -} - -static Scheme_Object * -namespace_set_variable_value(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - Scheme_Bucket *bucket; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-set-variable-value!", "symbol?", 0, argc, argv); - if ((argc > 3) && !SCHEME_NAMESPACEP(argv[3])) - scheme_wrong_contract("namespace-set-variable-value!", "namespace?", 3, argc, argv); - - if (argc > 3) - env = (Scheme_Env *)argv[3]; - else - env = scheme_get_env(NULL); - - bucket = scheme_global_bucket(argv[0], env); - - scheme_set_global_bucket("namespace-set-variable-value!", bucket, argv[1], 1); - - if ((argc > 2) && SCHEME_TRUEP(argv[2])) { - scheme_binding_names_from_module(env); - if (!env->binding_names - || (SCHEME_HASHTRP(env->binding_names) - && !scheme_hash_tree_get((Scheme_Hash_Tree *)env->binding_names, argv[0])) - || (SCHEME_HASHTP(env->binding_names) - && !scheme_hash_get((Scheme_Hash_Table *)env->binding_names, argv[0]))) { - Scheme_Object *id; - id = scheme_datum_to_syntax(argv[0], scheme_false, scheme_false, 0, 0); - scheme_prepare_env_stx_context(env); - id = scheme_stx_add_module_context(id, env->stx_context); - (void)scheme_global_binding(id, env, 0); - } - scheme_shadow(env, argv[0], argv[1], 1); - } - - return scheme_void; -} - -static Scheme_Object * -namespace_undefine_variable(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - Scheme_Bucket *bucket; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("namespace-undefine-variable!", "symbol?", 0, argc, argv); - if ((argc > 1) && !SCHEME_NAMESPACEP(argv[1])) - scheme_wrong_contract("namespace-undefine-variable!", "namespace?", 1, argc, argv); - - if (argc > 1) - env = (Scheme_Env *)argv[1]; - else - env = scheme_get_env(NULL); - - if (scheme_lookup_global(argv[0], env)) { - bucket = scheme_global_bucket(argv[0], env); - scheme_set_global_bucket("namespace-undefine-variable!", - bucket, - NULL, - 0); - bucket->val = NULL; - } else { - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0], - "namespace-undefine-variable!: given name is not defined\n" - " name: %S", - argv[0]); - } - - return scheme_void; -} - -static Scheme_Object * -namespace_mapped_symbols(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *l; - Scheme_Env *env; - Scheme_Hash_Table *mapped; - Scheme_Bucket_Table *ht; - Scheme_Bucket **bs; - intptr_t i, j; - - if ((argc > 0) && !SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract("namespace-mapped-symbols", "namespace?", 0, argc, argv); - - if (argc) - env = (Scheme_Env *)argv[0]; - else - env = scheme_get_env(NULL); - - mapped = scheme_make_hash_table(SCHEME_hash_ptr); - - for (j = 0; j < 2; j++) { - if (j) - ht = env->syntax; - else - ht = env->toplevel; - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) { - scheme_hash_set(mapped, (Scheme_Object *)b->key, scheme_true); - } - } - } - - if (env->stx_context) - scheme_module_context_add_mapped_symbols(env->stx_context, mapped); - - l = scheme_null; - for (i = mapped->size; i--; ) { - if (mapped->vals[i]) - l = scheme_make_pair(mapped->keys[i], l); - } - - return l; -} - -static Scheme_Object *namespace_module_registry(int argc, Scheme_Object **argv) -{ - if (!SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract("namespace-module-registry", "namespace?", 0, argc, argv); - - return (Scheme_Object *)((Scheme_Env *)argv[0])->module_registry; -} - -static Scheme_Object *do_variable_namespace(const char *who, int tl, int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - Scheme_Env *env; - intptr_t ph; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) { - v = NULL; - env = NULL; - } - else { - v = SCHEME_PTR1_VAL(argv[0]); - env = scheme_get_bucket_home((Scheme_Bucket *)v); - } - - if (!env) - scheme_wrong_contract(who, "variable-reference?", 0, argc, argv); - - ph = env->phase; - if (tl == 2) { - return scheme_make_integer(ph); - } else if (tl == 3) { - return scheme_make_integer(ph - env->mod_phase); - } else if (tl == 4) { - if (((Scheme_Object *)((Scheme_Bucket *)v)->key != scheme_stack_dump_key) - || !env->module) { - scheme_contract_error(who, - "variable reference does not refer to an anonymous module variable", - "variable reference", 1, argv[0], - NULL); - } - return env->access_insp; - } else if (tl) { - /* return env directly; need to set up */ - if (!env->mod_phase && env->module) - scheme_prep_namespace_rename(env); - env->interactive_bindings = 1; - } else { - /* new namespace: */ - Scheme_Env *new_env; - new_env = make_env(env, 0); - new_env->phase = env->phase; - env = new_env; - } - - return (Scheme_Object *)env; -} - -static Scheme_Object *variable_namespace(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->empty-namespace", 0, argc, argv); -} - -static Scheme_Object *variable_top_level_namespace(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->namespace", 1, argc, argv); -} - -static Scheme_Object *variable_phase(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->phase", 2, argc, argv); -} - -static Scheme_Object *variable_base_phase(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->base-phase", 3, argc, argv); -} - -static Scheme_Object *variable_inspector(int argc, Scheme_Object *argv[]) -{ - return do_variable_namespace("variable-reference->module-declaration-inspector", 4, argc, argv); -} - -static Scheme_Object *variable_const_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - v = argv[0]; - - if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) - scheme_wrong_contract("variable-reference-constant?", "variable-reference?", 0, argc, argv); - - if (SCHEME_VARREF_FLAGS(v) & 0x1) - return scheme_true; - - v = SCHEME_PTR1_VAL(v); - if (((Scheme_Bucket_With_Flags *)v)->flags & GLOB_IS_IMMUTATED) - return scheme_true; - - return scheme_false; -} - -static Scheme_Object *variable_unsafe_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - v = argv[0]; - - if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) - scheme_wrong_contract("variable-reference-from-unsafe?", "variable-reference?", 0, argc, argv); - - return scheme_false; -} - -static Scheme_Object *variable_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - return env ? scheme_true : scheme_false; -} - -static Scheme_Object *variable_module_path(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - if (!env) - scheme_wrong_contract("variable-reference->resolved-module-path", "variable-reference?", 0, argc, argv); - - if (env->module) - return env->module->modname; - else - return scheme_false; -} - -static Scheme_Object *variable_modidx(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - if (!env) - scheme_wrong_contract("variable-reference->module-path-index", "variable-reference?", 0, argc, argv); - - if (env->module) { - if (!env->link_midx) { - if (env->module->self_modidx - && SCHEME_TRUEP(((Scheme_Modidx *)env->module->self_modidx)->path)) - return env->module->self_modidx; - else - return scheme_resolved_module_path_to_modidx(env->module->modname); - } else - return env->link_midx; - } else - return scheme_false; -} - -static Scheme_Object *variable_module_source(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type)) - env = NULL; - else - env = scheme_get_bucket_home((Scheme_Bucket *)SCHEME_PTR1_VAL(argv[0])); - - if (!env) - scheme_wrong_contract("variable-reference->module-source", "variable-reference?", 0, argc, argv); - - if (env->module) - return scheme_resolved_module_path_value(env->module->modsrc); - else - return scheme_false; -} - -static Scheme_Object * -now_transforming(int argc, Scheme_Object *argv[]) -{ - return (scheme_current_thread->current_local_env - ? scheme_true - : scheme_false); -} - -static Scheme_Object * -now_transforming_with_lifts(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env = scheme_current_thread->current_local_env; - - env = scheme_get_env_for_lifts(env); - - if (env) - if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) - env = NULL; - - return (env - ? scheme_true - : scheme_false); -} - -static Scheme_Object * -now_transforming_module(int argc, Scheme_Object *argv[]) -{ - if (scheme_get_module_lift_env(scheme_current_thread->current_local_env)) - return scheme_true; - return scheme_false; -} - -static void not_currently_transforming(const char *name) -{ - scheme_contract_error(name, - "not currently transforming", - NULL); -} - -static Scheme_Object * -do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur) -{ - Scheme_Object *v, *sym, *a[2], *observer; - Scheme_Env *menv; - Scheme_Comp_Env *env; - int renamed = 0; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming(name); - - sym = argv[0]; - - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE(observer, sym); - - if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) - scheme_wrong_contract(name, "identifier?", 0, argc, argv); - - if (argc > 1) { - scheme_check_proc_arity2(name, 0, 1, argc, argv, 1); - if ((argc > 2) - && SCHEME_TRUEP(argv[2])) { - Scheme_Comp_Env *stx_env; - if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2]))) - scheme_wrong_contract(name, "(or/c internal-definition-context? #f)", 2, argc, argv); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0]; - if (!scheme_is_sub_env(stx_env, env)) { - scheme_contract_error(name, - "transforming context does not match given internal-definition context", - NULL); - } - env = stx_env; - } - } - - if (scheme_current_thread->current_local_scope) - sym = scheme_stx_flip_scope(sym, scheme_current_thread->current_local_scope, - scheme_env_phase(env->genv)); - - menv = NULL; - - while (1) { - v = scheme_compile_lookup(sym, env, - (SCHEME_NULL_FOR_UNBOUND - + SCHEME_RESOLVE_MODIDS - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST - + (!recur ? SCHEME_STOP_AT_FREE_EQ : 0)), - scheme_current_thread->current_local_modidx, - &menv, NULL, - NULL, NULL, - NULL); - - SCHEME_EXPAND_OBSERVE_RESOLVE(observer, sym); - - /* Deref globals */ - if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) - v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; - - if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_false); - if ((argc > 1) && SCHEME_TRUEP(argv[1])) - return _scheme_tail_apply(argv[1], 0, NULL); - else - scheme_contract_error(name, - (renamed - ? "not defined as syntax (after renaming)" - : "not defined as syntax"), - "identifier", 1, argv[0], - NULL); - } - - v = SCHEME_PTR_VAL(v); - if (scheme_is_rename_transformer(v)) { - sym = scheme_transfer_srcloc(scheme_rename_transformer_id(v, NULL), sym); - renamed = 1; - menv = NULL; - SCHEME_USE_FUEL(1); - if (!recur) { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); - a[0] = v; - a[1] = sym; - return scheme_values(2, a); - } - } else if (!recur) { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); - a[0] = v; - a[1] = scheme_false; - return scheme_values(2, a); - } else { - SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); - return v; - } - } -} - -static Scheme_Object * -local_exp_time_value(int argc, Scheme_Object *argv[]) -{ - return do_local_exp_time_value("syntax-local-value", argc, argv, 1); -} - -static Scheme_Object * -local_exp_time_value_one(int argc, Scheme_Object *argv[]) -{ - return do_local_exp_time_value("syntax-local-value/immediate", argc, argv, 0); -} - -static Scheme_Object * -local_exp_time_name(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *sym; - - sym = scheme_current_thread->current_local_name; - if (!sym) - not_currently_transforming("syntax-local-name"); - - return sym; -} - -static Scheme_Object * -local_context(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-context"); - - if (env->flags & SCHEME_INTDEF_FRAME) { - if (!env->intdef_name) { - Scheme_Object *sym, *pr, *prev = NULL; - Scheme_Comp_Env *lenv = env; - char buf[22]; - while (1) { - if (env->flags & SCHEME_FOR_INTDEF) - lenv = lenv->next; - else { - sprintf(buf, "internal-define%d", intdef_counter++); - sym = scheme_make_symbol(buf); /* uninterned! */ - pr = scheme_make_pair(sym, scheme_null); - lenv->intdef_name = pr; - if (prev) - SCHEME_CDR(prev) = pr; - if (lenv->next->flags & SCHEME_INTDEF_FRAME) { - if (lenv->next->intdef_name) { - SCHEME_CDR(pr) = lenv->next->intdef_name; - break; - } else { - prev = pr; - lenv = lenv->next; - /* Go again to continue building the list */ - } - } else - break; - } - } - } - return env->intdef_name; - } else if (scheme_is_module_env(env)) - return scheme_intern_symbol("module"); - else if (scheme_is_module_begin_env(env)) - return scheme_intern_symbol("module-begin"); - else if (scheme_is_toplevel(env)) - return scheme_intern_symbol("top-level"); - else - return scheme_intern_symbol("expression"); -} - -static Scheme_Object * -local_phase_level(int argc, Scheme_Object *argv[]) -{ - Scheme_Thread *p = scheme_current_thread; - intptr_t phase; - - phase = (p->current_local_env - ? p->current_local_env->genv->phase - : 0); - - return scheme_make_integer(phase); -} - -static Scheme_Object * -local_make_intdef_context(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env, *senv; - Scheme_Object *c, *rib; - void **d; - - d = MALLOC_N(void*, 4); - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-make-definition-context"); - - if (argc && SCHEME_TRUEP(argv[0])) { - if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[0]))) - scheme_wrong_contract("syntax-local-make-definition-context", "(or/c internal-definition-context? #f)", 0, argc, argv); - senv = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[0]))[0]; - if (!scheme_is_sub_env(senv, env)) { - scheme_contract_error("syntax-local-make-definition-context", - "transforming context does " - "not match given internal-definition context", - NULL); - } - env = senv; - d[1] = argv[0]; - } - d[0] = env; - d[3] = env; - - rib = scheme_new_scope(SCHEME_STX_INTDEF_SCOPE); - scheme_add_compilation_frame_intdef_scope(env, rib); - if ((argc > 1) && SCHEME_FALSEP(argv[1])) - rib = scheme_box(rib); /* box means "don't add context" for `local-expand` */ - - c = scheme_alloc_object(); - c->type = scheme_intdef_context_type; - SCHEME_PTR1_VAL(c) = d; - SCHEME_PTR2_VAL(c) = rib; - - return c; -} - -static Scheme_Object * -intdef_context_p(int argc, Scheme_Object *argv[]) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) - scheme_wrong_contract("internal-definition-context-seal", - "internal-definition-context?", 0, argc, argv); - - return scheme_void; -} - -static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *res, *phase, *scope; - int mode = SCHEME_STX_FLIP; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) - scheme_wrong_contract("internal-definition-context-introduce", - "internal-definition-context?", 0, argc, argv); - - res = argv[1]; - if (!SCHEME_STXP(res)) - scheme_wrong_contract("internal-definition-context-introduce", - "syntax?", 1, argc, argv); - - if (argc > 2) - mode = scheme_get_introducer_mode("internal-definition-context-introduce", 2, argc, argv); - - phase = scheme_env_phase((Scheme_Env *)((Scheme_Object **)SCHEME_PTR1_VAL(argv[0]))[0]); - - scope = SCHEME_PTR2_VAL(argv[0]); - if (SCHEME_BOXP(scope)) scope = SCHEME_BOX_VAL(scope); - res = scheme_stx_adjust_scope(res, scope, phase, mode); - - return res; -} - -static Scheme_Object * -id_intdef_remove(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *l, *res, *scope, *phase; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_contract("identifier-remove-from-definition-context", - "identifier?", 0, argc, argv); - - l = argv[1]; - if (!SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type)) { - while (SCHEME_PAIRP(l)) { - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_intdef_context_type)) - break; - l = SCHEME_CDR(l); - } - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("identifier-remove-from-definition-context", - "(or/c internal-definition-context? (listof internal-definition-context?))", - 1, argc, argv); - } - - l = argv[1]; - if (SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type)) - l = scheme_make_pair(l, scheme_null); - - res = argv[0]; - - phase = scheme_env_phase((Scheme_Env *)((Scheme_Object **)SCHEME_PTR1_VAL(SCHEME_CAR(l)))[0]); - - while (SCHEME_PAIRP(l)) { - scope = SCHEME_PTR2_VAL(SCHEME_CAR(l)); - if (SCHEME_BOXP(scope)) scope = SCHEME_BOX_VAL(scope); - res = scheme_stx_remove_scope(res, scope, phase); - l = SCHEME_CDR(l); - } - - return res; -} - -static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) - scheme_wrong_contract("internal-definition-context-binding-identifiers", - "internal-definition-context?", - 0, argc, argv); - - return scheme_intdef_bind_identifiers(argv[0]); -} - -static Scheme_Object * -local_introduce(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *s; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-introduce"); - - s = argv[0]; - if (!SCHEME_STXP(s)) - scheme_wrong_contract("syntax-local-introduce", "syntax?", 0, argc, argv); - - if (scheme_current_thread->current_local_scope) - s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_scope, scheme_env_phase(env->genv)); - if (scheme_current_thread->current_local_use_scope) - s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_use_scope, scheme_env_phase(env->genv)); - - return s; -} - -static Scheme_Object * -local_get_shadower(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *sym; - int only_generated = 0; - - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-get-shadower"); - - sym = argv[0]; - if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) - scheme_wrong_contract("syntax-local-get-shadower", "identifier?", 0, argc, argv); - - if ((argc > 1) && SCHEME_TRUEP(argv[1])) - only_generated = 1; - - return scheme_get_shadower(sym, env, only_generated); -} - -int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv) -{ - int mode = SCHEME_STX_FLIP; - - if (SAME_OBJ(argv[which], flip_symbol)) - mode = SCHEME_STX_FLIP; - else if (SAME_OBJ(argv[which], add_symbol)) - mode = SCHEME_STX_ADD; - else if (SAME_OBJ(argv[which], remove_symbol)) - mode = SCHEME_STX_REMOVE; - else - scheme_wrong_contract(who, "(or/c 'flip 'add 'remove)", which, argc, argv); - - return mode; -} - -static Scheme_Object * -introducer_proc(void *info, int argc, Scheme_Object *argv[]) -{ - Scheme_Object *s; - int mode = SCHEME_STX_FLIP; - - s = argv[0]; - if (!SCHEME_STXP(s)) { - scheme_wrong_contract("syntax-introducer", "syntax?", 0, argc, argv); - return NULL; - } - if (argc > 1) - mode = scheme_get_introducer_mode("syntax-introducer", 1, argc, argv); - - return scheme_stx_adjust_scope(s, ((Scheme_Object **)info)[0], ((Scheme_Object **)info)[1], mode); -} - -static Scheme_Object * -make_introducer(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *scope, **info; - Scheme_Env *genv; - int kind; - - if ((argc > 0) && SCHEME_TRUEP(argv[0])) - kind = SCHEME_STX_USE_SITE_SCOPE; - else - kind = SCHEME_STX_MACRO_SCOPE; - - scope = scheme_new_scope(kind); - info = MALLOC_N(Scheme_Object*, 2); - - info[0] = scope; - if (scheme_current_thread->current_local_env) - info[1] = scheme_env_phase(scheme_current_thread->current_local_env->genv); - else { - genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV); - info[1] = scheme_env_phase(genv); - } - - return scheme_make_closed_prim_w_arity(introducer_proc, info, - "syntax-introducer", 1, 2); -} - -static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]) -{ - scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "syntax-local-make-delta-introducer: " NOT_SUPPORTED_STR); - ESCAPED_BEFORE_HERE; -} - -static Scheme_Object *local_binding_id(int argc, Scheme_Object **argv) -{ - Scheme_Object *a = argv[0]; - - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_contract("syntax-local-identifier-as-binding", "identifier?", 0, argc, argv); - - if (scheme_current_thread->current_local_env) - return scheme_revert_use_site_scopes(a, scheme_current_thread->current_local_env); - else - return a; -} - -Scheme_Object *scheme_get_local_inspector() -{ - Scheme_Thread *p = scheme_current_thread; - - if (p->current_local_menv) - return p->current_local_menv->access_insp; - else - return scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); -} - -static Scheme_Object * -local_module_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - - if (!env) - not_currently_transforming("syntax-local-module-exports"); - - return scheme_module_exported_list(argv[0], env->genv); -} - -static Scheme_Object *local_submodules(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *l, *r = scheme_null, *n; - - env = scheme_current_thread->current_local_env; - - if (!env) - not_currently_transforming("syntax-local-submodules"); - - if (env->genv->module) { - l = env->genv->module->pre_submodule_names; - if (!l) - l = env->genv->module->pre_submodules; - if (l) { - while (!SCHEME_NULLP(l)) { - n = SCHEME_CAR(l); - if (!SCHEME_SYMBOLP(n)) { - n = scheme_resolved_module_path_value(((Scheme_Module *)n)->modname); - while (SCHEME_PAIRP(SCHEME_CDR(n))) { - n = SCHEME_CDR(n); - } - n = SCHEME_CAR(n); - } - r = scheme_make_pair(n, r); - l = SCHEME_CDR(l); - } - } - } - - return r; -} - -static Scheme_Object * -local_module_definitions(int argc, Scheme_Object *argv[]) -{ - if (!scheme_current_thread->current_local_env - || !scheme_current_thread->current_local_bindings) - scheme_contract_error("syntax-local-module-defined-identifiers", - "not currently transforming module provides", - NULL); - - return SCHEME_CDR(scheme_current_thread->current_local_bindings); -} - -static Scheme_Object * -local_module_imports(int argc, Scheme_Object *argv[]) -{ - if (!scheme_current_thread->current_local_env - || !scheme_current_thread->current_local_bindings) - scheme_contract_error("syntax-local-module-required-identifiers", - "not currently transforming module provides", - NULL); - - if (SCHEME_TRUEP(argv[0]) && !scheme_is_module_path(argv[0])) - scheme_wrong_contract("syntax-local-module-required-identifiers", "(or/c module-path? #f)", 0, argc, argv); - - if (!SCHEME_FALSEP(argv[1]) - && !SAME_OBJ(scheme_true, argv[1]) - && !SCHEME_INTP(argv[1]) - && !SCHEME_BIGNUMP(argv[1])) - scheme_wrong_contract("syntax-local-module-required-identifiers", "(or/c exact-integer? #f #t)", 1, argc, argv); - - return scheme_module_imported_list(scheme_current_thread->current_local_env->genv, - scheme_current_thread->current_local_bindings, - argv[0], - argv[1]); -} - -static Scheme_Object * -local_module_expanding_provides(int argc, Scheme_Object *argv[]) -{ - if (scheme_current_thread->current_local_env - && scheme_current_thread->current_local_bindings) - return scheme_true; - else - return scheme_false; -} - -static Scheme_Object * -local_lift_expr(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *ids; - ids = scheme_do_local_lift_expr("syntax-local-lift-expression", 0, argc, argv); - return SCHEME_CAR(ids); -} - -static Scheme_Object * -local_lift_exprs(int argc, Scheme_Object *argv[]) -{ - return scheme_do_local_lift_expr("syntax-local-lift-values-expression", 1, argc, argv); -} - -static Scheme_Object * -local_lift_context(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - - if (!env) - not_currently_transforming("syntax-local-lift-context"); - - return scheme_local_lift_context(env); -} - -static Scheme_Object * -local_lift_end_statement(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *local_scope, *expr; - - expr = argv[0]; - if (!SCHEME_STXP(expr)) - scheme_wrong_contract("syntax-local-lift-module-end-declaration", "syntax?", 0, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-module-end-declaration"); - - return scheme_local_lift_end_statement(expr, local_scope, env); -} - -static Scheme_Object * -local_lift_module(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *local_scope, *expr; - - expr = argv[0]; - if (!SCHEME_STXP(expr)) - scheme_wrong_contract("syntax-local-lift-module", "syntax?", 0, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-module"); - - return scheme_local_lift_module(expr, local_scope, env); -} - -static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *local_scope; - intptr_t phase; - - if (!SCHEME_STXP(argv[1])) - scheme_wrong_contract("syntax-local-lift-require", "syntax?", 1, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-require"); - - phase = env->genv->phase; - - return scheme_local_lift_require(argv[0], argv[1], phase, local_scope, env); -} - -static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]) -{ - Scheme_Comp_Env *env; - Scheme_Object *form, *local_scope; - - form = argv[0]; - if (!SCHEME_STXP(form)) - scheme_wrong_contract("syntax-local-lift-provide", "syntax?", 1, argc, argv); - - env = scheme_current_thread->current_local_env; - local_scope = scheme_current_thread->current_local_scope; - - if (!env) - not_currently_transforming("syntax-local-lift-provide"); - - return scheme_local_lift_provide(form, local_scope, env); -} - -static Scheme_Object * -make_set_transformer(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - scheme_check_proc_arity("make-set!-transformer", 1, 0, argc, argv); - - v = scheme_alloc_small_object(); - v->type = scheme_set_macro_type; - SCHEME_PTR_VAL(v) = argv[0]; - - return v; -} - -static Scheme_Object * -set_transformer_p(int argc, Scheme_Object *argv[]) -{ - return (scheme_is_set_transformer(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object * -set_transformer_proc(int argc, Scheme_Object *argv[]) -{ - if (!scheme_is_set_transformer(argv[0])) - scheme_wrong_contract("set!-transformer-procedure", "set!-transformer?", 0, argc, argv); - - return scheme_set_transformer_proc(argv[0]); -} - -static Scheme_Object * -make_rename_transformer(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_contract("make-rename-transformer", "identifier?", 0, argc, argv); - - v = scheme_alloc_object(); - v->type = scheme_id_macro_type; - SCHEME_PTR1_VAL(v) = argv[0]; - SCHEME_PTR2_VAL(v) = scheme_false; /* used to be an introducer procedure */ - - return v; -} - -static Scheme_Object * -rename_transformer_target(int argc, Scheme_Object *argv[]) -{ - if (!scheme_is_rename_transformer(argv[0])) - scheme_wrong_contract("rename-transformer-target", "rename-transformer?", 0, argc, argv); - - return scheme_rename_transformer_id(argv[0], NULL); -} - -static Scheme_Object * -rename_transformer_p(int argc, Scheme_Object *argv[]) -{ - return (scheme_is_rename_transformer(argv[0]) - ? scheme_true - : scheme_false); -} - /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff --git a/racket/src/racket/src/error.c b/racket/src/racket/src/error.c index b2fdb0ffde..e6aeb71913 100644 --- a/racket/src/racket/src/error.c +++ b/racket/src/racket/src/error.c @@ -60,12 +60,6 @@ THREAD_LOCAL_DECL(static Scheme_Logger *scheme_future_logger); THREAD_LOCAL_DECL(static Scheme_Logger *scheme_place_logger); /* readonly globals */ -READ_ONLY const char *scheme_compile_stx_string = "compile"; -READ_ONLY const char *scheme_expand_stx_string = "expand"; -READ_ONLY const char *scheme_application_stx_string = "application"; -READ_ONLY const char *scheme_set_stx_string = "set!"; -READ_ONLY const char *scheme_var_ref_string = "#%variable-reference"; -READ_ONLY const char *scheme_begin_stx_string = "begin"; ROSYM static Scheme_Object *none_symbol; ROSYM static Scheme_Object *fatal_symbol; ROSYM static Scheme_Object *error_symbol; @@ -103,7 +97,6 @@ static void *glib_log_signal_handle; /* locals */ static Scheme_Object *error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]); -static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_argument_error(int argc, Scheme_Object *argv[]); static Scheme_Object *raise_result_error(int argc, Scheme_Object *argv[]); @@ -755,7 +748,7 @@ static intptr_t sch_vsprintf(char *s, intptr_t maxlen, const char *msg, va_list return i; } -static intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...) +intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...) { intptr_t len; GC_CAN_IGNORE va_list args; @@ -776,9 +769,9 @@ int scheme_last_error_is_racket(int errid) #define ESCAPING_NONCM_PRIM(name, func, a1, a2, env) \ p = scheme_make_noncm_prim(func, name, a1, a2); \ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_ALWAYS_ESCAPES); \ - scheme_add_global_constant(name, p, env); + scheme_addto_prim_instance(name, p, env); -void scheme_init_error(Scheme_Env *env) +void scheme_init_error(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -792,7 +785,6 @@ void scheme_init_error(Scheme_Env *env) /* errors */ ESCAPING_NONCM_PRIM("error", error, 1, -1, env); ESCAPING_NONCM_PRIM("raise-user-error", raise_user_error, 1, -1, env); - ESCAPING_NONCM_PRIM("raise-syntax-error", raise_syntax_error, 2, 5, env); ESCAPING_NONCM_PRIM("raise-type-error", raise_type_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-argument-error", raise_argument_error, 3, -1, env); ESCAPING_NONCM_PRIM("raise-result-error", raise_result_error, 3, -1, env); @@ -801,39 +793,39 @@ void scheme_init_error(Scheme_Env *env) ESCAPING_NONCM_PRIM("raise-range-error", raise_range_error, 7, 8, env); scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1); - scheme_add_global_constant("raise-arity-error", scheme_raise_arity_error_proc, env); + scheme_addto_prim_instance("raise-arity-error", scheme_raise_arity_error_proc, env); - GLOBAL_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env); - GLOBAL_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env); - GLOBAL_PARAMETER("error-escape-handler", error_escape_handler, MZCONFIG_ERROR_ESCAPE_HANDLER, env); - GLOBAL_PARAMETER("exit-handler", exit_handler, MZCONFIG_EXIT_HANDLER, env); - GLOBAL_PARAMETER("executable-yield-handler", exe_yield_handler, MZCONFIG_EXE_YIELD_HANDLER, env); - GLOBAL_PARAMETER("error-print-width", error_print_width, MZCONFIG_ERROR_PRINT_WIDTH, env); - GLOBAL_PARAMETER("error-print-context-length", error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, env); - GLOBAL_PARAMETER("error-print-source-location", error_print_srcloc, MZCONFIG_ERROR_PRINT_SRCLOC, env); + ADD_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env); + ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env); + ADD_PARAMETER("error-escape-handler", error_escape_handler, MZCONFIG_ERROR_ESCAPE_HANDLER, env); + ADD_PARAMETER("exit-handler", exit_handler, MZCONFIG_EXIT_HANDLER, env); + ADD_PARAMETER("executable-yield-handler", exe_yield_handler, MZCONFIG_EXE_YIELD_HANDLER, env); + ADD_PARAMETER("error-print-width", error_print_width, MZCONFIG_ERROR_PRINT_WIDTH, env); + ADD_PARAMETER("error-print-context-length", error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, env); + ADD_PARAMETER("error-print-source-location", error_print_srcloc, MZCONFIG_ERROR_PRINT_SRCLOC, env); - GLOBAL_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env); + ADD_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env); /* logging */ - GLOBAL_NONCM_PRIM("log-level?", log_level_p, 2, 3, env); - GLOBAL_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env); - GLOBAL_NONCM_PRIM("log-all-levels", log_all_levels, 1, 1, env); - GLOBAL_NONCM_PRIM("log-level-evt", log_level_evt, 1, 1, env); - GLOBAL_NONCM_PRIM("make-logger", make_logger, 0, -1, env); - GLOBAL_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env); + ADD_NONCM_PRIM("log-level?", log_level_p, 2, 3, env); + ADD_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env); + ADD_NONCM_PRIM("log-all-levels", log_all_levels, 1, 1, env); + ADD_NONCM_PRIM("log-level-evt", log_level_evt, 1, 1, env); + ADD_NONCM_PRIM("make-logger", make_logger, 0, -1, env); + ADD_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env); - GLOBAL_PRIM_W_ARITY("log-message", log_message, 4, 6, env); - GLOBAL_FOLDING_PRIM("logger?", logger_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("logger-name", logger_name, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("log-receiver?", log_reader_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("log-message", log_message, 4, 6, env); + ADD_FOLDING_PRIM("logger?", logger_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("logger-name", logger_name, 1, 1, 1, env); + ADD_FOLDING_PRIM("log-receiver?", log_reader_p, 1, 1, 1, env); - GLOBAL_PARAMETER("current-logger", current_logger, MZCONFIG_LOGGER, env); + ADD_PARAMETER("current-logger", current_logger, MZCONFIG_LOGGER, env); - GLOBAL_NONCM_PRIM("srcloc->string", srcloc_to_string, 1, 1, env); + ADD_NONCM_PRIM("srcloc->string", srcloc_to_string, 1, 1, env); - GLOBAL_NONCM_PRIM("unquoted-printing-string", unquoted_printing_string, 1, 1, env); - GLOBAL_FOLDING_PRIM("unquoted-printing-string?", unquoted_printing_string_p, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("unquoted-printing-string-value", unquoted_printing_string_value, 1, 1, env); + ADD_NONCM_PRIM("unquoted-printing-string", unquoted_printing_string, 1, 1, env); + ADD_FOLDING_PRIM("unquoted-printing-string?", unquoted_printing_string_p, 1, 1, 1, env); + ADD_IMMED_PRIM("unquoted-printing-string-value", unquoted_printing_string_value, 1, 1, env); REGISTER_SO(scheme_def_exit_proc); REGISTER_SO(default_display_handler); @@ -874,7 +866,7 @@ void scheme_init_error(Scheme_Env *env) arity_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("arity-string"), guard); } - scheme_add_global_constant("prop:arity-string", arity_property, env); + scheme_addto_prim_instance("prop:arity-string", arity_property, env); REGISTER_SO(def_exe_yield_proc); def_exe_yield_proc = scheme_make_prim_w_arity(default_yield_handler, @@ -1084,12 +1076,6 @@ scheme_signal_error (const char *msg, ...) len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL); HIDE_FROM_XFORM(va_end(args)); - if (scheme_current_thread->current_local_env) { - char *s2 = " [during expansion]"; - strcpy(buffer + len, s2); - len += strlen(s2); - } - buffer[len] = 0; if (scheme_starting_up) { @@ -2252,108 +2238,34 @@ static Scheme_Object *unquoted_printing_string_value(int argc, Scheme_Object **a } void scheme_read_err(Scheme_Object *port, - Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - int gotc, Scheme_Object *indentation, const char *detail, ...) { GC_CAN_IGNORE va_list args; - char *s, *ls, lbuf[30], *fn, *suggests; - intptr_t slen, fnlen; - int show_loc; - Scheme_Object *loc; + Scheme_Object *pn; + char *s, *fn; + intptr_t slen; HIDE_FROM_XFORM(va_start(args, detail)); slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL); HIDE_FROM_XFORM(va_end(args)); - ls = ""; - fnlen = 0; - - show_loc = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)); - - /* Via read/recursive, it's possible that the reader will try to - complain about a character that precedes the start of a port. - In that case, pos can be 0. */ - if (!pos) line = col = pos = -1; - - if (stxsrc) { - Scheme_Object *xsrc; - - xsrc = scheme_make_stx_w_offset(scheme_false, line, col, pos, span, stxsrc, STX_SRCTAG); - - stxsrc = ((Scheme_Stx *)xsrc)->srcloc->src; - line = ((Scheme_Stx *)xsrc)->srcloc->line; - col = ((Scheme_Stx *)xsrc)->srcloc->col; - pos = ((Scheme_Stx *)xsrc)->srcloc->pos; - - if (show_loc) - fn = make_stx_srcloc_string(((Scheme_Stx *)xsrc)->srcloc, &fnlen); - else + if (port) { + pn = scheme_input_port_record(port)->name; + if (SCHEME_PATHP(pn)) { + pn = scheme_remove_current_directory_prefix(pn); + fn = SCHEME_PATH_VAL(pn); + } else fn = NULL; } else fn = NULL; - if (!fn && show_loc) { - intptr_t column; - - if (col < 0) - column = pos; - else - column = col; - - if (port) { - Scheme_Object *pn; - pn = scheme_input_port_record(port)->name; - if (SCHEME_PATHP(pn)) { - pn = scheme_remove_current_directory_prefix(pn); - fn = SCHEME_PATH_VAL(pn); - } else - fn = "UNKNOWN"; - } else - fn = "UNKNOWN"; - - fnlen = strlen(fn); - - if (column >= 0) { - scheme_sprintf(lbuf, 30, ":%L%ld", line, column-1); - ls = lbuf; - } else - ls = ": "; - } else if (!show_loc) { - fn = ""; - fnlen = 0; - } - - if (indentation) - suggests = scheme_extract_indentation_suggestions(indentation); + if (fn) + scheme_raise_exn(MZEXN_FAIL_READ, scheme_null, "%t\n in: %s", s, slen, fn); else - suggests = ""; - - loc = scheme_make_location(stxsrc ? stxsrc : scheme_false, - (line < 0) ? scheme_false : scheme_make_integer(line), - (col < 0) ? scheme_false : scheme_make_integer(col-1), - (pos < 0) ? scheme_false : scheme_make_integer(pos), - (span < 0) ? scheme_false : scheme_make_integer(span)); - - scheme_raise_exn(((gotc == EOF) - ? MZEXN_FAIL_READ_EOF - : ((gotc == SCHEME_SPECIAL) - ? MZEXN_FAIL_READ_NON_CHAR - : MZEXN_FAIL_READ)), - scheme_make_pair(loc, scheme_null), - "%t%s%s%t%s%s", - fn, fnlen, ls, - fnlen ? ": " : "", - s, slen, - (*suggests ? "\n possible cause: " : ""), suggests); + scheme_raise_exn(MZEXN_FAIL_READ, scheme_null, "%t", s, slen); } -Scheme_Object *scheme_numr_err(Scheme_Object *complain, - Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *indentation, - const char *detail, ...) +Scheme_Object *scheme_numr_err(Scheme_Object *complain, const char *detail, ...) { GC_CAN_IGNORE va_list args; char *s; @@ -2366,20 +2278,14 @@ Scheme_Object *scheme_numr_err(Scheme_Object *complain, if (SCHEME_FALSEP(complain)) return scheme_make_sized_utf8_string(s, slen); - scheme_read_err(complain, - stxsrc, - line, col, pos, span, - 0, indentation, - "read: %s", s); + scheme_read_err(complain, "read: %s", s); ESCAPED_BEFORE_HERE; } static void do_wrong_syntax(const char *where, Scheme_Object *detail_form, Scheme_Object *form, - char *s, intptr_t slen, - Scheme_Object *extra_sources, - int exn_kind) + char *s, intptr_t slen) { intptr_t len, vlen, dvlen, blen, plen; char *buffer; @@ -2394,21 +2300,6 @@ static void do_wrong_syntax(const char *where, slen = strlen(s); } - /* Check for special strings that indicate `form' doesn't have a - good name: */ - if ((where == scheme_compile_stx_string) - || (where == scheme_expand_stx_string)) { - where = NULL; - } else if (where == scheme_application_stx_string) { - who = scheme_intern_symbol("#%app"); - } else if ((where == scheme_set_stx_string) - || (where == scheme_var_ref_string) - || (where == scheme_begin_stx_string)) { - who = scheme_intern_symbol(where); - if (where == scheme_begin_stx_string) - where = "begin (possibly implicit)"; - } - buffer = init_buf(&len, &blen); p = NULL; @@ -2420,22 +2311,20 @@ static void do_wrong_syntax(const char *where, Scheme_Object *pform; if (SCHEME_STXP(form)) { p = make_stx_srcloc_string(((Scheme_Stx *)form)->srcloc, &plen); - pform = scheme_syntax_to_datum(form, 0, NULL); + pform = scheme_syntax_to_datum(form); /* Try to extract syntax name from syntax */ - if (!who && (SCHEME_SYMBOLP(SCHEME_STX_VAL(form)) || SCHEME_STX_PAIRP(form))) { + if (!who && (SCHEME_STX_SYMBOLP(form) || SCHEME_STX_PAIRP(form))) { Scheme_Object *first; if (SCHEME_STX_PAIRP(form)) first = SCHEME_STX_CAR(form); else first = form; - if (SCHEME_SYMBOLP(SCHEME_STX_VAL(first))) - who = SCHEME_STX_VAL(first); /* printed name is local name */ + if (SCHEME_STX_SYMBOLP(first)) + who = SCHEME_STX_SYM(first); /* printed name is local name */ } } else { pform = form; - if (!detail_form) - form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); } /* don't use error_write_to_string_w_max since this is code */ if (show_src) @@ -2455,17 +2344,8 @@ static void do_wrong_syntax(const char *where, if (SCHEME_STXP(detail_form)) { if (((Scheme_Stx *)detail_form)->srcloc->line >= 0) p = make_stx_srcloc_string(((Scheme_Stx *)detail_form)->srcloc, &plen); - pform = scheme_syntax_to_datum(detail_form, 0, NULL); - /* To go in exn record: */ - form = detail_form; - } else { - pform = detail_form; - /* To go in exn record: */ - form = scheme_datum_to_syntax(detail_form, - /* Use source location of `form': */ - SCHEME_STXP(form) ? form : scheme_false, - scheme_false, 1, 0); } + pform = scheme_syntax_to_datum(detail_form); /* don't use error_write_to_string_w_max since this is code */ if (show_src) @@ -2528,16 +2408,7 @@ static void do_wrong_syntax(const char *where, where, s, slen); - if (SCHEME_FALSEP(form)) - form = extra_sources; - else { - if (SCHEME_STXP(form)) - form = scheme_stx_taint(form); - form = scheme_make_pair(form, extra_sources); - } - - scheme_raise_exn(exn_kind, - form, + scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%t", buffer, blen); } @@ -2560,46 +2431,7 @@ void scheme_wrong_syntax(const char *where, HIDE_FROM_XFORM(va_end(args)); } - do_wrong_syntax(where, detail_form, form, s, slen, scheme_null, MZEXN_FAIL_SYNTAX); -} - -void scheme_unbound_syntax(const char *where, - Scheme_Object *detail_form, - Scheme_Object *form, - const char *detail, ...) -{ - char *s; - intptr_t slen; - GC_CAN_IGNORE va_list args; - - HIDE_FROM_XFORM(va_start(args, detail)); - slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL); - HIDE_FROM_XFORM(va_end(args)); - - do_wrong_syntax(where, detail_form, form, s, slen, scheme_null, MZEXN_FAIL_SYNTAX_UNBOUND); -} - -void scheme_wrong_syntax_with_more_sources(const char *where, - Scheme_Object *detail_form, - Scheme_Object *form, - Scheme_Object *extra_sources, - const char *detail, ...) -{ - char *s; - intptr_t slen; - - if (!detail) { - s = NULL; - slen = 0; - } else { - GC_CAN_IGNORE va_list args; - - HIDE_FROM_XFORM(va_start(args, detail)); - slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL); - HIDE_FROM_XFORM(va_end(args)); - } - - do_wrong_syntax(where, detail_form, form, s, slen, extra_sources, MZEXN_FAIL_SYNTAX); + do_wrong_syntax(where, detail_form, form, s, slen); } void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv) @@ -2713,42 +2545,33 @@ void scheme_raise_out_of_memory(const char *where, const char *msg, ...) void scheme_unbound_global(Scheme_Bucket *b) { Scheme_Object *name = (Scheme_Object *)b->key; - Scheme_Env *home; + Scheme_Instance *home; home = scheme_get_bucket_home(b); - if (home && home->module) { + if (home) { + Scheme_Object *src_name; const char *errmsg; - char *phase, phase_buf[20], *phase_note = ""; - + if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) errmsg = ("%S: undefined;\n" " cannot reference an identifier before its definition\n" - " in module: %D%s%s"); + " in module: %D\n" + " internal name: %S"); else errmsg = ("%S: undefined;\n" - " cannot reference an identifier before its definition%_%s%s"); + " cannot reference an identifier before its definition%_%_"); - if (home->phase) { - sprintf(phase_buf, "\n phase: %" PRIdPTR "", home->phase); - phase = phase_buf; - if ((home->phase == 1) && (home->template_env)) { - if (scheme_lookup_in_table(home->template_env->toplevel, (const char *)name)) - phase_note = "\n explanation: cannot access the run-time definition"; - else if (home->template_env->syntax - && scheme_lookup_in_table(home->template_env->syntax, (const char *)name)) - phase_note = "\n explanation cannot access the syntax binding for run-time expressions"; - } - } else - phase = ""; + src_name = scheme_hash_tree_get(home->source_names, name); + if (!src_name) + src_name = name; scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, - name, + src_name, errmsg, name, - scheme_get_modsrc(home->module), - phase, - phase_note); + home->name, + name); } else { scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, name, @@ -2901,51 +2724,6 @@ static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]) return do_error("raise-user-error", MZEXN_FAIL_USER, argc, argv); } -static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]) -{ - const char *who; - Scheme_Object *str, *extra_sources = scheme_null; - - if (!SCHEME_FALSEP(argv[0]) && !SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("raise-syntax-error", "(or/c symbol? #f)", 0, argc, argv); - if (!SCHEME_CHAR_STRINGP(argv[1])) - scheme_wrong_contract("raise-syntax-error", "string?", 1, argc, argv); - - if (SCHEME_SYMBOLP(argv[0])) - who = scheme_symbol_val(argv[0]); - else - who = NULL; - - str = argv[1]; - if (SCHEME_MUTABLEP(str)) { - str = scheme_make_immutable_sized_char_string(SCHEME_CHAR_STR_VAL(str), - SCHEME_CHAR_STRLEN_VAL(str), - 1); - } - - if (argc > 4) { - extra_sources = argv[4]; - while (SCHEME_PAIRP(extra_sources)) { - if (!SCHEME_STXP(SCHEME_CAR(extra_sources))) - break; - extra_sources = SCHEME_CDR(extra_sources); - } - if (!SCHEME_NULLP(extra_sources)) { - scheme_wrong_contract("raise-syntax-error", "(listof syntax?)", 4, argc, argv); - return NULL; - } - extra_sources = argv[4]; - } - - scheme_wrong_syntax_with_more_sources(who, - ((argc > 3) && !SCHEME_FALSEP(argv[3])) ? argv[3] : NULL, - ((argc > 2) && !SCHEME_FALSEP(argv[2])) ? argv[2] : NULL, - extra_sources, - "%T", str); - - return NULL; -} - typedef void (*wrong_proc_t)(const char *name, const char *expected, int which, int argc, Scheme_Object **argv); @@ -3354,7 +3132,6 @@ def_error_display_proc(int argc, Scheme_Object *argv[]) /* Some exns include srcloc in the msg, so skip the first srcloc of those when needed */ if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)) && (scheme_is_struct_instance(exn_table[MZEXN_FAIL_READ].type, argv[1]) - || scheme_is_struct_instance(exn_table[MZEXN_FAIL_SYNTAX].type, argv[1]) || scheme_is_struct_instance(exn_table[MZEXN_FAIL_CONTRACT_VARIABLE].type, argv[1]))) l = SCHEME_CDR(l); @@ -4809,23 +4586,6 @@ static Scheme_Object *variable_field_check(int argc, Scheme_Object **argv) return scheme_values(3, argv); } -static Scheme_Object *syntax_field_check(int argc, Scheme_Object **argv) -{ - Scheme_Object *l; - - l = argv[2]; - while (SCHEME_PAIRP(l)) { - if (!SCHEME_STXP(SCHEME_CAR(l))) - break; - l = SCHEME_CDR(l); - } - - if (!SCHEME_NULLP(l)) - scheme_wrong_field_contract(argv[3], "(listof syntax?)", argv[2]); - - return scheme_values(3, argv); -} - static Scheme_Object *read_field_check(int argc, Scheme_Object **argv) { Scheme_Object *l; @@ -4863,52 +4623,6 @@ static Scheme_Object *errno_field_check(int argc, Scheme_Object **argv) return scheme_values (3, argv); } -static Scheme_Object *module_path_field_check(int pos, int argc, Scheme_Object **argv) -{ - if (!scheme_is_module_path(argv[pos])) - scheme_wrong_field_contract(argv[pos+1], "(or/c #f module-path?)", argv[pos]); - - return scheme_values (pos+1, argv); -} - -static Scheme_Object *module_path_field_check_2(int argc, Scheme_Object **argv) -{ - return module_path_field_check(2, argc, argv); -} - -static Scheme_Object *module_path_field_check_3(int argc, Scheme_Object **argv) -{ - return module_path_field_check(3, argc, argv); -} - -static Scheme_Object *extract_syntax_locations(int argc, Scheme_Object **argv) -{ - if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_SYNTAX].type, argv[0])) { - Scheme_Object *stxs, *stx, *first = scheme_null, *last = NULL, *loco, *p; - Scheme_Stx_Srcloc *loc; - stxs = scheme_struct_ref(argv[0], 2); - while (SCHEME_PAIRP(stxs)) { - stx = SCHEME_CAR(stxs); - loc = ((Scheme_Stx *)stx)->srcloc; - loco = scheme_make_location(loc->src ? loc->src : scheme_false, - (loc->line >= 0) ? scheme_make_integer(loc->line) : scheme_false, - (loc->col >= 0) ? scheme_make_integer(loc->col-1) : scheme_false, - (loc->pos >= 0) ? scheme_make_integer(loc->pos) : scheme_false, - (loc->span >= 0) ? scheme_make_integer(loc->span) : scheme_false); - p = scheme_make_pair(loco, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - stxs = SCHEME_CDR(stxs); - } - return first; - } - scheme_wrong_contract("exn:fail:syntax-locations-accessor", "exn:fail:syntax?", 0, argc, argv); - return NULL; -} - static Scheme_Object *extract_read_locations(int argc, Scheme_Object **argv) { if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_READ].type, argv[0])) @@ -4917,33 +4631,7 @@ static Scheme_Object *extract_read_locations(int argc, Scheme_Object **argv) return NULL; } -static Scheme_Object *extract_module_path(int pos, int argc, Scheme_Object **argv, - int exn_kind, const - char *accessor_name, const char *contract) -{ - if (scheme_is_struct_instance(exn_table[exn_kind].type, argv[0])) - return scheme_struct_ref(argv[0], pos); - scheme_wrong_contract(accessor_name, contract, 0, argc, argv); - return NULL; -} - -static Scheme_Object *extract_module_path_2(int argc, Scheme_Object **argv) -{ - return extract_module_path(2, argc, argv, - MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, - "exn:fail:filesystem:missing-module:path-accessor", - "exn:fail:filesystem:missing-module?"); -} - -static Scheme_Object *extract_module_path_3(int argc, Scheme_Object **argv) -{ - return extract_module_path(3, argc, argv, - MZEXN_FAIL_SYNTAX_MISSING_MODULE, - "exn:fail:syntax:missing-module:path-accessor", - "exn:fail:syntax:missing-module?"); -} - -void scheme_init_exn(Scheme_Env *env) +void scheme_init_exn(Scheme_Startup_Env *env) { int i, j; Scheme_Object *tmpo, **tmpop; @@ -4991,20 +4679,20 @@ void scheme_init_exn(Scheme_Env *env) exn_table[i].count, EXN_FLAGS); for (j = exn_table[i].count - 1; j--; ) { - scheme_add_global_constant_symbol(exn_table[i].names[j], - values[j], - env); + scheme_addto_primitive_instance_by_symbol(exn_table[i].names[j], + values[j], + env); } } } - scheme_add_global_constant("uncaught-exception-handler", + scheme_addto_prim_instance("uncaught-exception-handler", scheme_register_parameter(init_exn_handler, "uncaught-exception-handler", MZCONFIG_INIT_EXN_HANDLER), env); - scheme_add_global_constant("raise", + scheme_addto_prim_instance("raise", scheme_make_noncm_prim(sch_raise, "raise", 1, 2), diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index 5fee1537fa..7c8e8e0243 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -68,23 +68,21 @@ Bytecodes are not linear. They're actually trees of expression nodes. - Top-level variables (global or module) are referenced through the - Scheme stack, so that the variables can be "re-linked" each time a - module is instantiated. Syntax constants are similarly accessed - through the Scheme stack. The global variables and syntax objects - are sometimes called the "prefix", and scheme_push_prefix() - initializes the prefix portion of the stack. This prefix is - captured in a continuation that refers to global or module-level - variables (which is why the closure is not entirely flat). Special - GC support allows a prefix to be pruned to just the globals that - are used by live closures. + Top-level variables (imported or defined in a linklet) are + referenced through the Scheme stack, so that the variables can be + re-linked each time a linklet is instantiated. The top-level are + sometimes called the "prefix", and push_prefix() initializes the + prefix portion of the stack. This prefix is captured in a + continuation that refers to top-level variables (which is why the + closure is not entirely flat). Special GC support allows a prefix + to be pruned to just the globals that are used by live closures. Bytecode compilation: Compilation works in five passes. The first pass, called "compile", is the expander and compiler - front-end. See "compile.c", along with "compenv.c" and "module.c". + front-end. See "compile.c" along with "compenv.c". The second pass, called "letrec_check", determines which references to `letrec'-bound variables need to be guarded with a run-time @@ -141,7 +139,6 @@ #include "schpriv.h" #include "schrunst.h" -#include "schexpobs.h" #ifdef MZ_USE_FUTURES # include "future.h" #endif @@ -186,9 +183,6 @@ SHARED_OK int scheme_startup_use_jit = INIT_JIT_ON; void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; } -SHARED_OK static int validate_compile_result = 0; -SHARED_OK static int recompile_every_compile = 0; - /* THREAD LOCAL SHARED */ THREAD_LOCAL_DECL(volatile int scheme_fuel_counter); #ifdef USE_STACK_BOUNDARY_VAR @@ -196,10 +190,12 @@ THREAD_LOCAL_DECL(uintptr_t scheme_stack_boundary); THREAD_LOCAL_DECL(uintptr_t volatile scheme_jit_stack_boundary); #endif THREAD_LOCAL_DECL(int scheme_continuation_application_count); -THREAD_LOCAL_DECL(static int generate_lifts_count); THREAD_LOCAL_DECL(int scheme_overflow_count); THREAD_LOCAL_DECL(Scheme_Prefix *scheme_prefix_finalize); THREAD_LOCAL_DECL(Scheme_Prefix *scheme_inc_prefix_finalize); +THREAD_LOCAL_DECL(Scheme_Object *is_syntax_proc); +THREAD_LOCAL_DECL(Scheme_Object *expander_syntax_to_datum_proc); +THREAD_LOCAL_DECL(Scheme_Bucket_Table *scheme_namespace_to_env); int scheme_get_overflow_count() { return scheme_overflow_count; } /* read-only globals */ @@ -207,67 +203,19 @@ READ_ONLY Scheme_Object *scheme_eval_waiting; READ_ONLY Scheme_Object *scheme_multiple_values; /* symbols */ -ROSYM static Scheme_Object *app_symbol; -ROSYM static Scheme_Object *datum_symbol; -ROSYM static Scheme_Object *top_symbol; -ROSYM static Scheme_Object *top_level_symbol; -ROSYM static Scheme_Object *define_values_symbol; -ROSYM static Scheme_Object *letrec_values_symbol; -ROSYM static Scheme_Object *lambda_symbol; -ROSYM static Scheme_Object *unknown_symbol; -ROSYM static Scheme_Object *void_link_symbol; -ROSYM static Scheme_Object *quote_symbol; -ROSYM static Scheme_Object *letrec_syntaxes_symbol; -ROSYM static Scheme_Object *begin_symbol; -ROSYM static Scheme_Object *let_values_symbol; -ROSYM static Scheme_Object *module_symbol; -ROSYM static Scheme_Object *module_begin_symbol; -ROSYM static Scheme_Object *expression_symbol; -ROSYM static Scheme_Object *definition_context_symbol; ROSYM Scheme_Object *scheme_stack_dump_key; READ_ONLY static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rands pointer */ /* locals */ -static Scheme_Object *eval(int argc, Scheme_Object *argv[]); -static Scheme_Object *compile(int argc, Scheme_Object *argv[]); -static Scheme_Object *compiled_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *recompile(int argc, Scheme_Object *argv[]); -static Scheme_Object *expand(int argc, Scheme_Object **argv); -static Scheme_Object *local_expand(int argc, Scheme_Object **argv); -static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv); -static Scheme_Object *local_expand_catch_lifts(int argc, Scheme_Object **argv); -static Scheme_Object *local_transformer_expand(int argc, Scheme_Object **argv); -static Scheme_Object *local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv); -static Scheme_Object *local_eval(int argc, Scheme_Object **argv); -static Scheme_Object *expand_once(int argc, Scheme_Object **argv); -static Scheme_Object *expand_to_top_form(int argc, Scheme_Object **argv); static Scheme_Object *enable_break(int, Scheme_Object *[]); -static Scheme_Object *current_eval(int argc, Scheme_Object *[]); -static Scheme_Object *current_compile(int argc, Scheme_Object *[]); - -static Scheme_Object *eval_stx(int argc, Scheme_Object *argv[]); -static Scheme_Object *compile_stx(int argc, Scheme_Object *argv[]); -static Scheme_Object *expand_stx(int argc, Scheme_Object **argv); -static Scheme_Object *expand_stx_once(int argc, Scheme_Object **argv); -static Scheme_Object *expand_stx_to_top_form(int argc, Scheme_Object **argv); -static Scheme_Object *top_introduce_stx(int argc, Scheme_Object **argv); static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv); static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv); static Scheme_Object *use_jit(int argc, Scheme_Object **argv); static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv); -static Scheme_Object *recompile_top(Scheme_Object *top, int comp_flags); - -static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env); - void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full); -#ifdef MZ_PRECISE_GC -static void mark_pruned_prefixes(struct NewGC *gc); -static int check_pruned_prefix(void *p); -#endif - #define cons(x,y) scheme_make_pair(x,y) typedef void (*DW_PrePost_Proc)(void *); @@ -283,7 +231,7 @@ static void register_traversers(void); /*========================================================================*/ void -scheme_init_eval (Scheme_Env *env) +scheme_init_eval (Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -305,111 +253,19 @@ scheme_init_eval (Scheme_Env *env) scheme_multiple_values->type = scheme_multiple_values_type; #endif - REGISTER_SO(define_values_symbol); - REGISTER_SO(letrec_values_symbol); - REGISTER_SO(lambda_symbol); - REGISTER_SO(unknown_symbol); - REGISTER_SO(void_link_symbol); - REGISTER_SO(quote_symbol); - REGISTER_SO(letrec_syntaxes_symbol); - REGISTER_SO(begin_symbol); - REGISTER_SO(let_values_symbol); - - define_values_symbol = scheme_intern_symbol("define-values"); - letrec_values_symbol = scheme_intern_symbol("letrec-values"); - let_values_symbol = scheme_intern_symbol("let-values"); - lambda_symbol = scheme_intern_symbol("lambda"); - unknown_symbol = scheme_intern_symbol("unknown"); - void_link_symbol = scheme_intern_symbol("-v"); - quote_symbol = scheme_intern_symbol("quote"); - letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values"); - begin_symbol = scheme_intern_symbol("begin"); - - REGISTER_SO(module_symbol); - REGISTER_SO(module_begin_symbol); - REGISTER_SO(expression_symbol); - REGISTER_SO(top_level_symbol); - REGISTER_SO(definition_context_symbol); - - module_symbol = scheme_intern_symbol("module"); - module_begin_symbol = scheme_intern_symbol("module-begin"); - expression_symbol = scheme_intern_symbol("expression"); - top_level_symbol = scheme_intern_symbol("top-level"); - definition_context_symbol = scheme_intern_symbol("definition-context"); - - REGISTER_SO(app_symbol); - REGISTER_SO(datum_symbol); - REGISTER_SO(top_symbol); - - app_symbol = scheme_intern_symbol("#%app"); - datum_symbol = scheme_intern_symbol("#%datum"); - top_symbol = scheme_intern_symbol("#%top"); - REGISTER_SO(scheme_stack_dump_key); scheme_stack_dump_key = scheme_make_symbol("stk"); /* uninterned! */ - GLOBAL_PRIM_W_ARITY2("eval", eval, 1, 2, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("eval-syntax", eval_stx, 1, 2, 0, -1, env); + ADD_PRIM_W_ARITY("break-enabled", enable_break, 0, 1, env); - GLOBAL_PRIM_W_ARITY("compile", compile, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compiled-expression-recompile", recompile, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compile-syntax", compile_stx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compiled-expression?", compiled_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand", expand, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-syntax", expand_stx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("local-expand", local_expand, 3, 4, env); - GLOBAL_PRIM_W_ARITY2("syntax-local-expand-expression", local_expand_expr, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("syntax-local-bind-syntaxes", local_eval, 3, 3, env); - GLOBAL_PRIM_W_ARITY("local-expand/capture-lifts", local_expand_catch_lifts, 3, 5, env); - GLOBAL_PRIM_W_ARITY("local-transformer-expand", local_transformer_expand, 3, 4, env); - GLOBAL_PRIM_W_ARITY("local-transformer-expand/capture-lifts", local_transformer_expand_catch_lifts, 3, 5, env); - GLOBAL_PRIM_W_ARITY("expand-once", expand_once, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-syntax-once", expand_stx_once, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-to-top-form", expand_to_top_form, 1, 1, env); - GLOBAL_PRIM_W_ARITY("expand-syntax-to-top-form", expand_stx_to_top_form, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-syntax-introduce", top_introduce_stx, 1, 1, env); - GLOBAL_PRIM_W_ARITY("break-enabled", enable_break, 0, 1, env); - - GLOBAL_PARAMETER("current-eval", current_eval, MZCONFIG_EVAL_HANDLER, env); - GLOBAL_PARAMETER("current-compile", current_compile, MZCONFIG_COMPILE_HANDLER, env); - GLOBAL_PARAMETER("compile-allow-set!-undefined", allow_set_undefined, MZCONFIG_ALLOW_SET_UNDEFINED, env); - GLOBAL_PARAMETER("compile-enforce-module-constants", compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env); - GLOBAL_PARAMETER("eval-jit-enabled", use_jit, MZCONFIG_USE_JIT, env); - GLOBAL_PARAMETER("compile-context-preservation-enabled", disallow_inline, MZCONFIG_DISALLOW_INLINE, env); - - if (scheme_getenv("PLT_VALIDATE_COMPILE")) { - /* Enables validation of bytecode as it is generated, - to double-check that the compiler is producing - valid bytecode as it should. */ - validate_compile_result = 1; - } - - { - /* Enables re-running the optimizer N times on every compilation. */ - const char *s; - s = scheme_getenv("PLT_RECOMPILE_COMPILE"); - if (s) { - int i = 0; - while ((s[i] >= '0') && (s[i] <= '9')) { - recompile_every_compile = (recompile_every_compile * 10) + (s[i]-'0'); - i++; - } - if (recompile_every_compile <= 0) - recompile_every_compile = 1; - else if (recompile_every_compile > 32) - recompile_every_compile = 32; - } - } + ADD_PARAMETER("compile-allow-set!-undefined", allow_set_undefined, MZCONFIG_ALLOW_SET_UNDEFINED, env); + ADD_PARAMETER("compile-enforce-module-constants", compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env); + ADD_PARAMETER("eval-jit-enabled", use_jit, MZCONFIG_USE_JIT, env); + ADD_PARAMETER("compile-context-preservation-enabled", disallow_inline, MZCONFIG_DISALLOW_INLINE, env); } void scheme_init_eval_places() { -#ifdef MZ_PRECISE_GC - scheme_prefix_finalize = (Scheme_Prefix *)0x1; /* 0x1 acts as a sentenel */ - scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; - GC_set_post_propagate_hook(mark_pruned_prefixes); - GC_set_treat_as_incremental_mark(scheme_prefix_type, check_pruned_prefix); -#endif #ifdef DEBUG_CHECK_STACK_FRAME_SIZE (void)scheme_do_eval(SCHEME_TAIL_CALL_WAITING, 0, NULL, 0); #endif @@ -835,227 +691,6 @@ void *scheme_enlarge_runstack(intptr_t size, void *(*k)()) return v; } -/*========================================================================*/ -/* linking variables */ -/*========================================================================*/ - -static Scheme_Object *link_module_variable(Scheme_Object *modidx, - Scheme_Object *varname, - int check_access, Scheme_Object *insp, - int pos, int mod_phase, - Scheme_Env *env, - Scheme_Object **exprs, int which, - int flags, Scheme_Object *shape) -{ - Scheme_Object *modname; - Scheme_Env *menv; - Scheme_Bucket *bkt; - int self = 0; - - /* If it's a name id, resolve the name. */ - modname = scheme_module_resolve(modidx, 1); - - if (env->module && SAME_OBJ(env->module->modname, modname) - && (env->mod_phase == mod_phase)) { - self = 1; - menv = env; - } else { - menv = scheme_module_access(modname, env, mod_phase); - - if (!menv) { - Scheme_Object *modsrc; - modsrc = (env->module - ? scheme_get_modsrc(env->module) - : scheme_false); - scheme_wrong_syntax("link", NULL, varname, - "namespace mismatch;\n" - " reference to a module that is not available\n" - " reference phase: %d\n" - " referenced module: %D\n" - " referenced phase level: %d\n" - " reference in module: %D", - env->phase, - modname, - mod_phase, - modsrc); - return NULL; - } - - if (check_access && !SAME_OBJ(menv, env)) { - varname = scheme_check_accessible_in_module_instance(menv, varname, NULL, - NULL, insp, - pos, 0, - NULL, NULL, - env, NULL, NULL); - } - } - - if (exprs) { - Scheme_Object *simplified; - if (self) { - simplified = varname; - } else { - if (flags & SCHEME_MODVAR_CONST) { - Scheme_Object *v; - v = scheme_make_vector((mod_phase != 0) ? 4 : 3, modname); - SCHEME_VEC_ELS(v)[1] = varname; - SCHEME_VEC_ELS(v)[2] = (shape ? shape : scheme_false); - if (mod_phase != 0) - SCHEME_VEC_ELS(v)[3] = scheme_make_integer(mod_phase); - simplified = v; - } else { - Scheme_Object *v = modname; - if (mod_phase != 0) - v = scheme_make_pair(v, scheme_make_integer(mod_phase)); - v = scheme_make_pair(varname, v); - simplified = v; - } - simplified = scheme_make_mutable_pair(simplified, exprs[which]); - } - exprs[which] = simplified; - } - - bkt = scheme_global_bucket(varname, menv); - if (!self) { - const char *bad_reason = NULL; - - if (!bkt->val) { - bad_reason = "is uninitialized"; - } else if (flags) { - if (flags & SCHEME_MODVAR_CONST) { - if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_CONSISTENT)) - bad_reason = "is not a procedure or structure-type constant across all instantiations"; - else if (shape && SCHEME_TRUEP(shape)) { - if (!scheme_get_or_check_procedure_shape(bkt->val, shape)) - bad_reason = "has the wrong procedure or structure-type shape"; - } - } else { - if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_CONST | GLOB_IS_IMMUTATED))) - bad_reason = "is not constant"; - } - } - - if (bad_reason) { - Scheme_Object *modsrc; - modsrc = (env->module - ? scheme_get_modsrc(env->module) - : scheme_false); - scheme_wrong_syntax("link", NULL, varname, - "bad variable linkage;\n" - " reference to a variable that %s\n" - " reference phase level: %d\n" - " variable module: %D\n" - " variable phase: %d\n" - " reference in module: %D", - bad_reason, - env->phase, - modname, - mod_phase, - modsrc); - } - - if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_IMMUTATED | GLOB_IS_LINKED))) - ((Scheme_Bucket_With_Flags *)bkt)->flags |= GLOB_IS_LINKED; - } - - return (Scheme_Object *)bkt; -} - -static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env, - Scheme_Object *src_modidx, - Scheme_Object *dest_modidx, - Scheme_Object *insp) -{ - Scheme_Object *expr = exprs[which]; - - if (SCHEME_MPAIRP(expr)) { - /* Simplified reference was installed by link_module_variable; - simplified is in CAR, and original is in CDR */ - expr = SCHEME_CAR(expr); - } - - if (SCHEME_FALSEP(expr)) { - /* See scheme_make_environment_dummy */ - Scheme_Bucket *b; - b = scheme_global_bucket(scheme_stack_dump_key, env); - if (!(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK)) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_STRONG_HOME_LINK; - ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)env; - } - return (Scheme_Object *)b; - } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr) || SCHEME_VECTORP(expr)) { - /* Simplified module reference (as installed by link_module_variable) */ - Scheme_Object *modname, *varname, *shape; - int mod_phase = 0, flags = 0; - if (SCHEME_SYMBOLP(expr)) { - if (!env->module) { - /* compiled as a module variable, but instantiated in a non-module - namespace; grab a bucket */ - return (Scheme_Object *)scheme_global_bucket(expr, env); - } else { - varname = expr; - modname = env->module->modname; - mod_phase = env->mod_phase; - } - shape = NULL; - } else if (SCHEME_PAIRP(expr)) { - varname = SCHEME_CAR(expr); - modname = SCHEME_CDR(expr); - if (SCHEME_PAIRP(modname)) { - mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname)); - modname = SCHEME_CAR(modname); - } - shape = NULL; - } else { - modname = SCHEME_VEC_ELS(expr)[0]; - varname = SCHEME_VEC_ELS(expr)[1]; - flags = SCHEME_MODVAR_CONST; - shape = SCHEME_VEC_ELS(expr)[2]; - if (SCHEME_VEC_SIZE(expr) > 3) - mod_phase = SCHEME_INT_VAL(SCHEME_VEC_ELS(expr)[3]); - } - return link_module_variable(modname, - varname, - 0, NULL, - -1, mod_phase, - env, - NULL, 0, - flags, shape); - } else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) { - Scheme_Bucket *b = (Scheme_Bucket *)expr; - Scheme_Env *home; - - home = scheme_get_bucket_home(b); - - if (!env) - return (Scheme_Object *)b; - else if (!home || !home->module) - return (Scheme_Object *)scheme_global_bucket((Scheme_Object *)b->key, env); - else - return link_module_variable(home->module->modname, - (Scheme_Object *)b->key, - 1, home->access_insp, - -1, home->mod_phase, - env, - exprs, which, - 0, NULL); - } else { - Module_Variable *mv = (Module_Variable *)expr; - - if ((!insp || SCHEME_FALSEP(insp)) && !mv->insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - return link_module_variable(scheme_modidx_shift(mv->modidx, - src_modidx, - dest_modidx), - mv->sym, 1, (mv->insp ? mv->insp : insp), - mv->pos, mv->mod_phase, - env, - exprs, which, - SCHEME_MODVAR_FLAGS(mv) & 0x3, mv->shape); - } -} - /*========================================================================*/ /* continuation marks */ /*========================================================================*/ @@ -1243,9 +878,6 @@ MZ_DO_NOT_INLINE(static Scheme_Object *ref_execute (Scheme_Object *data)); MZ_DO_NOT_INLINE(static Scheme_Object *apply_values_execute(Scheme_Object *data)); MZ_DO_NOT_INLINE(static Scheme_Object *bangboxenv_execute(Scheme_Object *data)); MZ_DO_NOT_INLINE(static Scheme_Object *begin0_execute(Scheme_Object *obj)); -MZ_DO_NOT_INLINE(static Scheme_Object *splice_execute(Scheme_Object *data)); -MZ_DO_NOT_INLINE(static Scheme_Object *define_syntaxes_execute(Scheme_Object *form)); -MZ_DO_NOT_INLINE(static Scheme_Object *begin_for_syntax_execute(Scheme_Object *form)); /* called in schapp.h */ static Scheme_Object *do_apply_known_k(void) @@ -1926,9 +1558,9 @@ void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val, && (val || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_LINKED))) b->val = val; else { - Scheme_Env *home; + Scheme_Instance *home; home = scheme_get_bucket_home(b); - if (home && home->module) { + if (home) { const char *msg; int is_set; @@ -1960,7 +1592,7 @@ void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val, : "constant") : "variable"), (Scheme_Object *)b->key, - scheme_get_modsrc(home->module)); + home->name); } else { scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key, "%s: " CANNOT_SET_ERROR_STR ";\n" @@ -1989,28 +1621,16 @@ void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v) b->val = macro; } -static Scheme_Object * -define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, - Resolve_Prefix *rp, Scheme_Env *dm_env, - Scheme_Dynamic_State *dyn_state) +static Scheme_Object *define_values_execute(Scheme_Object *vec) { - Scheme_Object *name, *macro, *vals_expr, *vals, *var; + Scheme_Object *name, *vals_expr, *vals, *var; + int delta = 1; int i, g, show_any; Scheme_Bucket *b; - Scheme_Object **save_runstack = NULL; vals_expr = SCHEME_VEC_ELS(vec)[0]; - if (dm_env) { - scheme_prepare_exp_env(dm_env); - - save_runstack = scheme_push_prefix(dm_env->exp_env, 0, rp, NULL, NULL, 1, 1, NULL, scheme_false); - vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); - scheme_pop_prefix(save_runstack); - } else { - vals = _scheme_eval_linked_expr_multi(vals_expr); - dm_env = NULL; - } + vals = _scheme_eval_linked_expr_multi(vals_expr); if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { Scheme_Object **values; @@ -2026,49 +1646,31 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, scheme_current_thread->values_buffer = NULL; scheme_current_thread->ku.multiple.array = NULL; - if (dm_env) - is_st = 0; - else if (scheme_is_simple_make_struct_type(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, - NULL, NULL, NULL, NULL, - NULL, NULL, MZ_RUNSTACK, 0, - NULL, NULL, NULL, 5)) - is_st = 1; - else if (scheme_is_simple_make_struct_type_property(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, - NULL, NULL, NULL, NULL, MZ_RUNSTACK, 0, - NULL, NULL, 5)) - is_st = 1; - else - is_st = 0; + is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, + NULL, NULL, NULL, NULL, + NULL, MZ_RUNSTACK, 0, + NULL, NULL, 5); + if (!is_st) + is_st = scheme_is_simple_make_struct_type_property(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED, + NULL, NULL, NULL, MZ_RUNSTACK, 0, + NULL, 5); for (i = 0; i < g; i++) { + Scheme_Prefix *toplevels; + var = SCHEME_VEC_ELS(vec)[i+delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = values[i]; - - scheme_set_global_bucket("define-syntaxes", b, macro, 1); - scheme_shadow(dm_env, (Scheme_Object *)b->key, macro, 0); - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - - scheme_set_global_bucket("define-values", b, values[i], 1); - scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, values[i], 1); - - if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { - if (is_st) - ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT); - else - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; - } + scheme_set_global_bucket("define-values", b, values[i], 1); + + if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { + if (is_st) + ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT); + else + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; } } - if (defmacro) - scheme_pop_prefix(save_runstack); return scheme_void; } else { @@ -2076,67 +1678,36 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, scheme_current_thread->values_buffer = NULL; } } else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */ + Scheme_Prefix *toplevels; + var = SCHEME_VEC_ELS(vec)[delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = vals; + scheme_set_global_bucket("define-values", b, vals, 1); - scheme_set_global_bucket("define-syntaxes", b, macro, 1); - scheme_shadow(dm_env, (Scheme_Object *)b->key, macro, 0); - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - - scheme_set_global_bucket("define-values", b, vals, 1); - scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, vals, 1); - - if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { - int flags = GLOB_IS_IMMUTATED; - if (scheme_is_statically_proc(vals_expr, NULL, OMITTABLE_RESOLVED) - || (SCHEME_TYPE(vals_expr) >= _scheme_values_types_)) - flags |= GLOB_IS_CONSISTENT; - ((Scheme_Bucket_With_Flags *)b)->flags |= flags; - } - - if (defmacro) - scheme_pop_prefix(save_runstack); + if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { + int flags = GLOB_IS_IMMUTATED; + if (scheme_is_statically_proc(vals_expr, NULL, OMITTABLE_RESOLVED) + || (SCHEME_TYPE(vals_expr) >= _scheme_values_types_)) + flags |= GLOB_IS_CONSISTENT; + ((Scheme_Bucket_With_Flags *)b)->flags |= flags; } return scheme_void; } else g = 1; - - /* Special handling of 0 values for define-syntaxes: - just create binding. This makes (define-values (a b c) (values)) - a kind of declaration form, which is useful is - a, b, or c is introduced by a macro. */ - if (dm_env && !g) { - for (i = SCHEME_VEC_SIZE(vec) - delta; i--; ) { - b = scheme_global_keyword_bucket(SCHEME_VEC_ELS(vec)[i+delta], dm_env); - scheme_shadow(dm_env, (Scheme_Object *)b->key, scheme_false, 1); - } - return scheme_void; - } i = SCHEME_VEC_SIZE(vec) - delta; show_any = i; if (show_any) { + Scheme_Prefix *toplevels; var = SCHEME_VEC_ELS(vec)[delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); - name = (Scheme_Object *)b->key; - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - name = (Scheme_Object *)b->key; - } + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + name = (Scheme_Object *)b->key; } else name = NULL; @@ -2145,9 +1716,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, symname = (show_any ? scheme_symbol_name(name) : ""); - scheme_wrong_return_arity((defmacro - ? "define-syntaxes" - : "define-values"), + scheme_wrong_return_arity("define-values", i, g, (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, "\n in: %s%s%s", @@ -2159,11 +1728,6 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, return NULL; } -static Scheme_Object *define_values_execute(Scheme_Object *data) -{ - return define_execute_with_dynamic_state(data, 1, 0, NULL, NULL, NULL); -} - static Scheme_Object *set_execute (Scheme_Object *data) { Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; @@ -2186,23 +1750,35 @@ static Scheme_Object *ref_execute (Scheme_Object *data) Scheme_Prefix *toplevels; Scheme_Object *o; Scheme_Object *var; - Scheme_Object *tl = SCHEME_PTR1_VAL(data); - Scheme_Env *env; + Scheme_Object *tl; + Scheme_Instance *home; + tl = SCHEME_PTR1_VAL(data); + if (SCHEME_FALSEP(tl)) + var = NULL; + else if (SCHEME_SYMBOLP(tl) || SAME_OBJ(tl, scheme_true)) + var = tl; + else { + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; + var = toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; + } + + tl = SCHEME_PTR2_VAL(data); toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; - var = toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; - if (SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) - env = NULL; - else - env = scheme_environment_from_dummy(SCHEME_PTR2_VAL(data)); + if (SCHEME_FALSEP(tl)) + home = NULL; + else { + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; + o = toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; + home = scheme_get_bucket_home((Scheme_Bucket *)o); + } o = scheme_alloc_object(); o->type = scheme_global_ref_type; - SCHEME_PTR1_VAL(o) = var; - SCHEME_PTR2_VAL(o) = (env ? (Scheme_Object *)env : scheme_false); + SCHEME_PTR1_VAL(o) = (var ? var : scheme_false); + SCHEME_PTR2_VAL(o) = (home ? (Scheme_Object *)home : scheme_false); - if (SCHEME_VARREF_FLAGS(data) & 0x1) - SCHEME_VARREF_FLAGS(o) |= 0x1; + SCHEME_VARREF_FLAGS(data) |= (SCHEME_VARREF_FLAGS(o) & VARREF_FLAGS_MASK); return o; } @@ -2366,123 +1942,6 @@ static Scheme_Object *begin0_execute(Scheme_Object *obj) return v; } -static Scheme_Object *splice_one_expr(void *expr, int argc, Scheme_Object **argv) -{ - return _scheme_eval_linked_expr_multi((Scheme_Object *)expr); -} - -static Scheme_Object *splice_execute(Scheme_Object *data) -{ - if (SAME_TYPE(SCHEME_TYPE(data), scheme_splice_sequence_type)) { - Scheme_Sequence *seq = (Scheme_Sequence *)data; - int i, cnt = seq->count - 1; - - for (i = 0; i < cnt; i++) { - ignore_result(_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i])); - } - - return _scheme_eval_linked_expr_multi(seq->array[cnt]); - } else { - /* sequence was optimized on read? */ - return _scheme_eval_linked_expr_multi(data); - } -} - -static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env); - -static void *define_syntaxes_execute_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = p->ku.k.p1; - Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - return do_define_syntaxes_execute(form, dm_env); -} - -static Scheme_Object * -do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env) -{ - Scheme_Thread *p = scheme_current_thread; - Resolve_Prefix *rp; - Scheme_Object *base_stack_depth, *dummy; - int depth; - Scheme_Comp_Env *rhs_env; - - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(form)[1]; - base_stack_depth = SCHEME_VEC_ELS(form)[2]; - - depth = SCHEME_INT_VAL(base_stack_depth) + rp->num_stxes + 1; - if (!scheme_check_runstack(depth)) { - p->ku.k.p1 = form; - - if (!dm_env) { - /* Need to get env before we enlarge the runstack: */ - dummy = SCHEME_VEC_ELS(form)[3]; - dm_env = scheme_environment_from_dummy(dummy); - } - p->ku.k.p2 = (Scheme_Object *)dm_env; - - return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k); - } - - dummy = SCHEME_VEC_ELS(form)[3]; - - rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, NULL, - SCHEME_TOPLEVEL_FRAME); - - if (!dm_env) - dm_env = scheme_environment_from_dummy(dummy); - - { - Scheme_Dynamic_State dyn_state; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - scheme_prepare_exp_env(dm_env); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)dm_env->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, - dm_env, dm_env->link_midx); - - if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_syntaxes_type)) { - (void)define_execute_with_dynamic_state(form, 4, 1, rp, dm_env, &dyn_state); - } else { - Scheme_Object **save_runstack; - - form = SCHEME_VEC_ELS(form)[0]; - - save_runstack = scheme_push_prefix(dm_env->exp_env, 0, rp, NULL, NULL, 1, 1, NULL, scheme_false); - - while (!SCHEME_NULLP(form)) { - ignore_result(scheme_eval_linked_expr_multi_with_dynamic_state(SCHEME_CAR(form), &dyn_state)); - form = SCHEME_CDR(form); - } - - scheme_pop_prefix(save_runstack); - } - - scheme_pop_continuation_frame(&cframe); - - return scheme_void; - } -} - -static Scheme_Object *define_syntaxes_execute(Scheme_Object *form) -{ - return do_define_syntaxes_execute(form, NULL); -} - -static Scheme_Object *begin_for_syntax_execute(Scheme_Object *form) -{ - return do_define_syntaxes_execute(form, NULL); -} - /*========================================================================*/ /* closures */ /*========================================================================*/ @@ -2583,7 +2042,6 @@ void scheme_delay_load_closure(Scheme_Lambda *data) (char *)SCHEME_VEC_ELS(vinfo)[1], (Validate_TLS)SCHEME_VEC_ELS(vinfo)[2], SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[3]), - SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[4]), SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[5]), (SCHEME_TRUEP(SCHEME_VEC_ELS(vinfo)[8]) ? (void *)SCHEME_VEC_ELS(vinfo)[8] @@ -3812,27 +3270,6 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, goto eval_top; } - case scheme_quote_syntax_type: - { - GC_CAN_IGNORE Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; - Scheme_Prefix *globs; - int i, c, pos; - - i = qs->position; - c = qs->depth; - pos = qs->midpoint; - - globs = (Scheme_Prefix *)RUNSTACK[c]; - v = globs->a[i+pos+1]; - if (!v) { - v = globs->a[pos]; - v = scheme_delayed_shift((Scheme_Object **)v, i); - globs->a[i+pos+1] = v; - } - - goto returnv_never_multi; - } - case scheme_define_values_type: { UPDATE_THREAD_RSPTR(); @@ -3844,18 +3281,6 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, obj = SCHEME_VEC_ELS(obj)[0]; goto eval_top; } - case scheme_define_syntaxes_type: - { - UPDATE_THREAD_RSPTR(); - v = define_syntaxes_execute(obj); - break; - } - case scheme_begin_for_syntax_type: - { - UPDATE_THREAD_RSPTR(); - v = begin_for_syntax_execute(obj); - break; - } case scheme_set_bang_type: { UPDATE_THREAD_RSPTR(); @@ -3874,18 +3299,6 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = begin0_execute(obj); break; } - case scheme_splice_sequence_type: - { - UPDATE_THREAD_RSPTR(); - v = splice_execute(obj); - break; - } - case scheme_require_form_type: - { - UPDATE_THREAD_RSPTR(); - v = scheme_top_level_require_execute(obj); - break; - } case scheme_varref_form_type: { UPDATE_THREAD_RSPTR(); @@ -3933,12 +3346,6 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = scheme_case_lambda_execute(obj); break; } - case scheme_module_type: - { - UPDATE_THREAD_RSPTR(); - v = scheme_module_execute(obj, NULL); - break; - } default: v = obj; goto returnv_never_multi; @@ -4005,410 +3412,140 @@ Scheme_Object **scheme_current_argument_stack() /* eval/compile/expand starting points */ /*========================================================================*/ -Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv) +Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]) { - scheme_prepare_env_stx_context(genv); - - if (SCHEME_STX_PAIRP(form)) { - Scheme_Object *a, *d, *module_stx; - - a = SCHEME_STX_CAR(form); - if (SCHEME_STX_SYMBOLP(a)) { - a = scheme_stx_push_module_context(a, genv->stx_context); - module_stx = scheme_datum_to_syntax(module_symbol, - scheme_false, - scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), - 0, 0); - if (scheme_stx_free_eq(a, module_stx, genv->phase)) { - /* Don't add context to the whole module, since the - `module` form will just discard it: */ - d = SCHEME_STX_CDR(form); - a = scheme_make_pair(a, d); - form = scheme_datum_to_syntax(a, form, form, 0, 1); - return form; - } - } - } - - form = scheme_stx_push_module_context(form, genv->stx_context); - - return form; + Scheme_Object *proc; + proc = scheme_get_startup_export("dynamic-require"); + return scheme_apply(proc, argc, argv); } -static Scheme_Object *call_compile_handler(Scheme_Object *form, int immediate_eval) +int scheme_is_syntax(Scheme_Object *v) { - Scheme_Object *argv[2], *o; + Scheme_Object *a[1]; + if (!is_syntax_proc) { + REGISTER_SO(is_syntax_proc); + is_syntax_proc = scheme_get_startup_export("syntax?"); + } + a[0] = v; + return SCHEME_TRUEP(scheme_apply(is_syntax_proc, 1, a)); +} - argv[0] = form; - argv[1] = (immediate_eval ? scheme_true : scheme_false); - o = scheme_get_param(scheme_current_config(), MZCONFIG_COMPILE_HANDLER); - o = scheme_apply(o, 2, argv); +Scheme_Object *scheme_expander_syntax_to_datum(Scheme_Object *v) +{ + Scheme_Object *a[1]; + if (scheme_starting_up) + return v; + else { + if (!expander_syntax_to_datum_proc) { + REGISTER_SO(expander_syntax_to_datum_proc); + expander_syntax_to_datum_proc = scheme_get_startup_export("maybe-syntax->datum"); + } + a[0] = v; + return scheme_apply(expander_syntax_to_datum_proc, 1, a); + } +} + +Scheme_Object *scheme_namespace_require(Scheme_Object *mod_path) +{ + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("namespace-require"); + a[0] = mod_path; + return scheme_apply(proc, 1, a); +} + +static Scheme_Env *namespace_to_env(Scheme_Object *ns) +{ + Scheme_Env *env; + + env = scheme_lookup_in_table(scheme_namespace_to_env, (char *)ns); + + if (!env) { + env = MALLOC_ONE_TAGGED(Scheme_Env); + env->so.type = scheme_env_type; + env->namespace = ns; + scheme_add_to_table(scheme_namespace_to_env, (char *)ns, (void *)env, 0); + } + + return env; +} + +Scheme_Env *scheme_make_empty_env(void) +{ + Scheme_Object *proc, *ns, *inst, *a[2]; + Scheme_Env *env; - if (!SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) { - argv[0] = o; - scheme_wrong_contract("compile-handler", "compiled-expression?", 0, -1, argv); - return NULL; - } + proc = scheme_get_startup_export("current-namespace"); + ns = scheme_apply(proc, 0, NULL); - return o; + env = namespace_to_env(ns); + + proc = scheme_get_startup_export("namespace->instance"); + a[0] = ns; + a[1] = scheme_make_integer(0); + inst = scheme_apply(proc, 2, a); + + env->instance = (Scheme_Instance *)inst; + + return env; } -static int get_comp_flags(Scheme_Config *config) +Scheme_Env *scheme_get_current_namespace_as_env() { - int comp_flags = 0; - - if (!config) - config = scheme_current_config(); - - if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), - MZCONFIG_ALLOW_SET_UNDEFINED))) - comp_flags |= COMP_ALLOW_SET_UNDEFINED; - if (SCHEME_FALSEP(scheme_get_param(scheme_current_config(), - MZCONFIG_DISALLOW_INLINE))) - comp_flags |= COMP_CAN_INLINE; - - return comp_flags; + Scheme_Object *proc, *ns; + + proc = scheme_get_startup_export("current-namespace"); + ns = scheme_apply(proc, 0, NULL); + + return namespace_to_env(ns); } -static void create_binding_namess(Scheme_Comp_Env *cenv) +void scheme_set_current_namespace_as_env(Scheme_Env *env) { - Scheme_Hash_Table *binding_namess; - binding_namess= scheme_make_hash_table(SCHEME_hash_ptr); - cenv->binding_namess = binding_namess; + Scheme_Object *proc, *a[1]; + + proc = scheme_get_startup_export("current-namespace"); + + a[0] = env->namespace; + (void)scheme_apply(proc, 1, a); } - -static Scheme_Object *binding_namess_as_list(Scheme_Hash_Table *binding_namess) -{ - int i; - Scheme_Object *l = scheme_null, **sorted_keys; - - if (!binding_namess->count) - return scheme_null; - - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)binding_namess); - - for (i = binding_namess->count; i--; ) { - l = scheme_make_pair(scheme_make_pair(sorted_keys[i], - scheme_hash_get(binding_namess, sorted_keys[i])), - l); - } - - return l; -} - -static Scheme_Object *optimize_resolve_expr(Scheme_Object* o, - Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, - Scheme_Object *src_insp_desc, - Scheme_Object *binding_namess, - int comp_flags) -{ - Optimize_Info *oi; - Resolve_Prefix *rp; - Resolve_Info *ri; - Scheme_Compilation_Top *top; - int enforce_consts, max_let_depth; - Scheme_Config *config; - - config = scheme_current_config(); - enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); - if (enforce_consts) - comp_flags |= COMP_ENFORCE_CONSTS; - oi = scheme_optimize_info_create(cp, env, insp, 1); - scheme_optimize_info_enforce_const(oi, enforce_consts); - if (!(comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - o = scheme_optimize_expr(o, oi, 0); - - rp = scheme_resolve_prefix(0, cp, src_insp_desc); - ri = scheme_resolve_info_create(rp); - scheme_resolve_info_enforce_const(ri, enforce_consts); - scheme_enable_expression_resolve_lifts(ri); - - o = scheme_resolve_expr(o, ri); - max_let_depth = scheme_resolve_info_max_let_depth(ri); - o = scheme_sfs(o, NULL, max_let_depth); - - o = scheme_merge_expression_resolve_lifts(o, rp, ri); - - rp = scheme_remap_prefix(rp, ri); - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->max_let_depth = max_let_depth; - top->code = o; - top->prefix = rp; - top->binding_namess = binding_namess; - return (Scheme_Object *)top; -} - -static void *compile_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form, *frame_scopes; - int writeable, for_eval, top_intro, enforce_consts, comp_flags; - Scheme_Env *genv; - Scheme_Compile_Info rec, rec2; - Scheme_Object *o, *rl, *tl_queue; - Scheme_Compilation_Top *top; - Resolve_Prefix *rp; - Resolve_Info *ri; - Optimize_Info *oi; - Scheme_Object *gval, *insp; - Scheme_Comp_Env *cenv; - - form = (Scheme_Object *)p->ku.k.p1; - genv = (Scheme_Env *)p->ku.k.p2; - writeable = p->ku.k.i1; - for_eval = p->ku.k.i2; - top_intro = p->ku.k.i3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - if (!SCHEME_STXP(form)) { - form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); - top_intro = 1; - } - - if (top_intro) - form = scheme_top_introduce(form, genv); - - tl_queue = scheme_null; - - { - Scheme_Config *config; - config = scheme_current_config(); - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); - enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); - comp_flags = get_comp_flags(config); - if (enforce_consts) - comp_flags |= COMP_ENFORCE_CONSTS; - } - - scheme_prepare_env_stx_context(genv); - - if (genv->stx_context) - frame_scopes = scheme_module_context_frame_scopes(genv->stx_context, NULL); - else - frame_scopes = NULL; - - while (1) { - scheme_prepare_compile_env(genv); - - rec.comp = 1; - rec.dont_mark_local_use = 0; - rec.resolve_module_ids = !writeable && !genv->module; - rec.substitute_bindings = 1; - rec.pre_unwrapped = 0; - rec.env_already = 0; - rec.comp_flags = comp_flags; - - cenv = scheme_new_comp_env(genv, insp, frame_scopes, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME); - create_binding_namess(cenv); - - cenv->expand_result_adjust = scheme_stx_push_introduce_module_context; - cenv->expand_result_adjust_arg = genv->stx_context; - - if (for_eval) { - /* Need to look for top-level `begin', and if we - find one, break it up to eval first expression - before the rest. */ - while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false, - /* lifted modules like definitions: */ - scheme_true); - form = scheme_check_immediate_macro(form, - cenv, &rec, 0, - &gval, - 1); - if (SAME_OBJ(gval, scheme_begin_syntax)) { - if (scheme_stx_proper_list_length(form) > 1) { - form = SCHEME_STX_CDR(form); - tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL), - tl_queue); - tl_queue = scheme_append(scheme_frame_get_lifts(cenv), - tl_queue); - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } else - break; - } else { - rl = scheme_frame_get_require_lifts(cenv); - o = scheme_frame_get_lifts(cenv); - if (!SCHEME_NULLP(o) - || !SCHEME_NULLP(rl)) { - o = scheme_named_map_1(NULL, scheme_stx_push_introduce_module_context, o, genv->stx_context); - rl = scheme_named_map_1(NULL, scheme_stx_push_introduce_module_context, rl, genv->stx_context); - tl_queue = scheme_make_pair(form, tl_queue); - tl_queue = scheme_append(o, tl_queue); - tl_queue = scheme_append(rl, tl_queue); - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } - break; - } - } - } - - if (for_eval) { - o = call_compile_handler(form, 1); - top = (Scheme_Compilation_Top *)o; - } else { - /* We want to simply compile `form', but we have to loop in case - an expression is lifted in the process of compiling: */ - Scheme_Object *l, *prev_o = NULL, *binding_namess; - int max_let_depth; - - while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false, - /* lifted modules like definitions: */ - scheme_true); - - scheme_init_compile_recs(&rec, 0, &rec2, 1); - - o = scheme_compile_expr(form, cenv, &rec2, 0); - - /* If we had compiled an expression in a previous iteration, - combine it in a sequence: */ - if (prev_o) { - Scheme_Sequence *seq; - seq = scheme_malloc_sequence(2); - seq->so.type = scheme_sequence_type; - seq->count = 2; - seq->array[0] = o; - seq->array[1] = prev_o; - o = (Scheme_Object *)seq; - } - - /* If any definitions were lifted in the process of compiling o, - we need to fold them in. */ - l = scheme_frame_get_lifts(cenv); - rl = scheme_frame_get_require_lifts(cenv); - if (!SCHEME_NULLP(l) - || !SCHEME_NULLP(rl)) { - rl = scheme_append(rl, l); - rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0), - rl); - form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0); - prev_o = o; - } else - break; - } - - o = scheme_letrec_check_expr(o); - - oi = scheme_optimize_info_create(cenv->prefix, genv, insp, 1); - scheme_optimize_info_enforce_const(oi, enforce_consts); - if (!(comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - o = scheme_optimize_expr(o, oi, 0); - - rp = scheme_resolve_prefix(0, cenv->prefix, insp); - ri = scheme_resolve_info_create(rp); - scheme_resolve_info_enforce_const(ri, enforce_consts); - scheme_enable_expression_resolve_lifts(ri); - - o = scheme_resolve_expr(o, ri); - max_let_depth = scheme_resolve_info_max_let_depth(ri); - o = scheme_sfs(o, NULL, max_let_depth); - - o = scheme_merge_expression_resolve_lifts(o, rp, ri); - - rp = scheme_remap_prefix(rp, ri); - - binding_namess = binding_namess_as_list(cenv->binding_namess); - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->max_let_depth = max_let_depth; - top->code = o; - top->prefix = rp; - top->binding_namess = binding_namess; - - if (recompile_every_compile) { - int i; - for (i = recompile_every_compile; i--; ) { - top = (Scheme_Compilation_Top *)recompile_top((Scheme_Object *)top, comp_flags); - } - } - - if (validate_compile_result) { - scheme_validate_code(NULL, top->code, - top->max_let_depth, - top->prefix->num_toplevels, - top->prefix->num_stxes, - top->prefix->num_lifts, - NULL, - NULL, - 0); - } - } - - if (SCHEME_PAIRP(tl_queue)) { - /* This compile is interleaved with evaluation, - and we need to eval now before compiling more. */ - _eval_compiled_multi_with_prompt((Scheme_Object *)top, genv); - - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } else - break; - } - - return (void *)top; -} - -static Scheme_Object *_compile(Scheme_Object *form, Scheme_Env *env, int writeable, int for_eval, int eb, int top_intro) -{ - Scheme_Thread *p = scheme_current_thread; - - if (SAME_TYPE(SCHEME_TYPE(form), scheme_compilation_top_type)) - return form; - - if (SCHEME_STXP(form)) { - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) - return SCHEME_STX_VAL(form); - } - - p->ku.k.p1 = form; - p->ku.k.p2 = env; - p->ku.k.i1 = writeable; - p->ku.k.i2 = for_eval; - p->ku.k.i3 = top_intro; - - return (Scheme_Object *)scheme_top_level_do(compile_k, eb); -} - Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable) { - return _compile(form, env, writeable, 0, 1, 1); + Scheme_Object *compile_proc, *a[3]; + compile_proc = scheme_get_startup_export("compile"); + a[0] = form; + a[1] = env->namespace; + a[2] = (writeable ? scheme_true : scheme_false); + return scheme_apply(compile_proc, 3, a); } Scheme_Object *scheme_compile_for_eval(Scheme_Object *form, Scheme_Env *env) { - return _compile(form, env, 0, 1, 1, 1); + return scheme_compile(form, env, 0); } Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env) { - return scheme_eval_compiled(scheme_compile_for_eval(obj, env), env); + Scheme_Object *eval_proc, *a[2]; + eval_proc = scheme_get_startup_export("eval"); + a[0] = obj; + a[1] = env->namespace; + return scheme_apply(eval_proc, 2, a); } Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env) { - return scheme_eval_compiled_multi(scheme_compile_for_eval(obj, env), env); + Scheme_Object *eval_proc, *a[2]; + eval_proc = scheme_get_startup_export("eval"); + a[0] = obj; + a[1] = env->namespace; + return scheme_apply_multi(eval_proc, 2, a); } static Scheme_Object *finish_eval_with_prompt(void *_data, int argc, Scheme_Object **argv) { Scheme_Object *data = (Scheme_Object *)_data; - return _scheme_eval_compiled(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); + return scheme_eval(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); } Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env) @@ -4422,7 +3559,7 @@ Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env) static Scheme_Object *finish_eval_multi_with_prompt(void *_data, int argc, Scheme_Object **argv) { Scheme_Object *data = (Scheme_Object *)_data; - return _scheme_eval_compiled_multi(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); + return scheme_eval_multi(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data)); } Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env) @@ -4433,374 +3570,14 @@ Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env scheme_make_pair(expr, (Scheme_Object *)env)); } -static void *eval_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *v, **save_runstack; - Resolve_Prefix *rp; - Scheme_Env *env; - int isexpr, multi, use_jit, as_tail; - - v = (Scheme_Object *)p->ku.k.p1; - env = (Scheme_Env *)p->ku.k.p2; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - multi = p->ku.k.i1; - isexpr = p->ku.k.i2; - as_tail = p->ku.k.i3; - - { - Scheme_Object *b; - b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); - use_jit = SCHEME_TRUEP(b); - } - - if (isexpr) { - if (multi) - v = _scheme_eval_linked_expr_multi_wp(v, p); - else - v = _scheme_eval_linked_expr_wp(v, p); - } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_compilation_top_type)) { - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)v; - int depth; - - if (!top->prefix) - depth = 0; - else - depth = top->max_let_depth + scheme_prefix_depth(top->prefix); - - if (!scheme_check_runstack(depth)) { - p->ku.k.p1 = top; - p->ku.k.p2 = env; - p->ku.k.i1 = multi; - p->ku.k.i2 = 0; - return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_k); - } - - v = top->code; - - if (!top->prefix) { - /* top->code is shared module code */ - scheme_module_execute(top->code, env); - v = scheme_void; - } else { - if (use_jit) - v = scheme_jit_expr(v); - else - v = scheme_eval_clone(v); - rp = scheme_prefix_eval_clone(top->prefix); - - scheme_install_binding_names(top->binding_namess, env); - - save_runstack = scheme_push_prefix(env, 0, rp, NULL, NULL, 0, env->phase, NULL, scheme_false); - - if (as_tail) { - /* Cons up a closure to capture the prefix */ - Scheme_Lambda *data; - mzshort *map; - int i, sz; - - sz = (save_runstack XFORM_OK_MINUS MZ_RUNSTACK); - map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * sz); - for (i = 0; i < sz; i++) { - map[i] = i; - } - - data = MALLOC_ONE_TAGGED(Scheme_Lambda); - data->iso.so.type = scheme_ir_lambda_type; - data->num_params = 0; - data->max_let_depth = top->max_let_depth + sz; - data->closure_size = sz; - data->closure_map = map; - data->body = v; - - v = scheme_make_closure(p, (Scheme_Object *)data, 1); - - v = _scheme_tail_apply(v, 0, NULL); - } else if (multi) - v = _scheme_eval_linked_expr_multi_wp(v, p); - else - v = _scheme_eval_linked_expr_wp(v, p); - - scheme_pop_prefix(save_runstack); - } - } else { - v = scheme_void; - } - - return (void *)v; -} - -static Scheme_Object *_eval(Scheme_Object *obj, Scheme_Env *env, - int isexpr, int multi, int top, int as_tail) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = obj; - p->ku.k.p2 = env; - p->ku.k.i1 = multi; - p->ku.k.i2 = isexpr; - p->ku.k.i3 = as_tail; - - if (top) - return (Scheme_Object *)scheme_top_level_do(eval_k, 1); - else - return (Scheme_Object *)eval_k(); -} - -Scheme_Object *scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env) -{ - return _eval(obj, env, 0, 0, 1, 0); -} - -Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env) -{ - return _eval(obj, env, 0, 1, 1, 0); -} - Scheme_Object *_scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env) { - return _eval(obj, env, 0, 0, 0, 0); + return _scheme_eval_linked_expr(obj); } Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env) { - return _eval(obj, env, 0, 1, 0, 0); -} - -static Scheme_Object *finish_compiled_multi_with_prompt(void *_data, int argc, Scheme_Object **argv) -{ - Scheme_Object *data = (Scheme_Object *)_data; - return _eval(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data), 0, 1, 0, 0); -} - -Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env) -{ - return _scheme_call_with_prompt_multi(finish_compiled_multi_with_prompt, - scheme_make_pair(obj, (Scheme_Object *)env)); -} - -Scheme_Object *scheme_eval_linked_expr(Scheme_Object *obj) -{ - return _eval(obj, NULL, 1, 0, 1, 0); -} - -Scheme_Object *scheme_eval_linked_expr_multi(Scheme_Object *obj) -{ - return _eval(obj, NULL, 1, 1, 1, 0); -} - -Scheme_Object *scheme_eval_linked_expr_multi_with_dynamic_state(Scheme_Object *obj, Scheme_Dynamic_State *dyn_state) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = obj; - p->ku.k.p2 = NULL; - p->ku.k.i1 = 1; - p->ku.k.i2 = 1; - p->ku.k.i3 = 0; - - return (Scheme_Object *)scheme_top_level_do_worker(eval_k, 1, 0, dyn_state); -} - -/* for mzc: */ -Scheme_Object *scheme_load_compiled_stx_string(const char *str, intptr_t len) -{ - Scheme_Object *port, *expr; - - port = scheme_make_sized_byte_string_input_port(str, -len); - - expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); - - expr = _scheme_eval_compiled(expr, scheme_get_env(NULL)); - - /* Unwrap syntax once; */ - expr = SCHEME_STX_VAL(expr); - - return expr; -} - -/* for mzc: */ -Scheme_Object *scheme_compiled_stx_symbol(Scheme_Object *stx) -{ - return SCHEME_STX_VAL(stx); -} - -/* for mzc: */ -Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *env, - intptr_t shift, Scheme_Object *modidx) -{ - /* If modidx, then last element is a module index; shift the rest. */ - if (modidx) { - int i, len = SCHEME_VEC_SIZE(expr); - Scheme_Object *orig = SCHEME_VEC_ELS(expr)[len - 1], *s, *result; - - orig = SCHEME_STX_VAL(orig); - result = scheme_make_vector(len - 1, NULL); - - for (i = 0; i < len - 1; i++) { - s = SCHEME_VEC_ELS(expr)[i]; - s = scheme_stx_shift(s, - scheme_make_integer(shift), - orig, modidx, - env->module_registry->exports, - NULL, NULL); - SCHEME_VEC_ELS(result)[i] = s; - } - - return result; - } else - return expr; -} - -static Scheme_Object *add_lifts_as_begin(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env) -{ - obj = scheme_append(l, scheme_make_pair(obj, scheme_null)); - obj = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - obj); - obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0); - return obj; -} - -static void *expand_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *obj, *observer, *catch_lifts_key; - Scheme_Comp_Env *env, **ip; - Scheme_Expand_Info erec1; - int depth, top_intro, just_to_top, as_local, comp_flags; - - obj = (Scheme_Object *)p->ku.k.p1; - env = (Scheme_Comp_Env *)p->ku.k.p2; - depth = p->ku.k.i1; - top_intro = p->ku.k.i2; - just_to_top = p->ku.k.i3; - catch_lifts_key = p->ku.k.p4; - as_local = p->ku.k.i4; /* < 0 => catch lifts to let; 2 => catch lifts to optional `begin` */ - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - if (SCHEME_FALSEP(catch_lifts_key)) - catch_lifts_key = scheme_top_level_lifts_key(env); - - if (!SCHEME_STXP(obj)) - obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0); - - if (top_intro) - obj = scheme_top_introduce(obj, env->genv); - - if (!as_local) { - env->expand_result_adjust = scheme_stx_push_introduce_module_context; - env->expand_result_adjust_arg = env->genv->stx_context; - } - - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_START_EXPAND(observer); - - env->observer = observer; - - comp_flags = get_comp_flags(NULL); - - if (as_local < 0) { - /* Insert a dummy frame so that `pair_lifted' can add more. */ - env = scheme_new_compilation_frame(0, 0, NULL, env); - ip = MALLOC_N(Scheme_Comp_Env *, 1); - *ip = env; - } else - ip = NULL; - - scheme_prepare_compile_env(env->genv); - - /* Loop for lifted expressions: */ - while (1) { - erec1.comp = 0; - erec1.depth = ((depth == -3) ? -2 : depth); - erec1.pre_unwrapped = 0; - erec1.env_already = 0; - erec1.comp_flags = comp_flags; - erec1.substitute_bindings = (depth != -3); - - if (catch_lifts_key) { - Scheme_Object *data; - data = (as_local < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env); - scheme_frame_captures_lifts(env, - (as_local < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, - data, - scheme_false, catch_lifts_key, - (!as_local && catch_lifts_key) ? scheme_null : NULL, - scheme_false, - /* lifted modules like definitions: */ - ((env->flags & SCHEME_TOPLEVEL_FRAME) - ? scheme_true /* lifted `module` like definition */ - : ((env->flags & SCHEME_MODULE_FRAME) - ? scheme_void /* lifted `module[*]` like definition */ - : scheme_false))); - } - - if (just_to_top) { - Scheme_Object *gval; - obj = scheme_check_immediate_macro(obj, env, &erec1, 0, &gval, 1); - } else - obj = scheme_expand_expr(obj, env, &erec1, 0); - - if (catch_lifts_key) { - Scheme_Object *l, *rl; - l = scheme_frame_get_lifts(env); - rl = scheme_frame_get_require_lifts(env); - if (SCHEME_PAIRP(l) - || SCHEME_PAIRP(rl)) { - l = scheme_append(rl, l); - if (as_local < 0) - obj = scheme_add_lifts_as_let(obj, l, env, scheme_false, 0); - else - obj = add_lifts_as_begin(obj, l, env); - SCHEME_EXPAND_OBSERVE_LIFT_LOOP(env->observer, obj); - if ((depth >= 0) || as_local) - break; - } else { - if ((as_local > 0) && (as_local < 2)) { - obj = add_lifts_as_begin(obj, scheme_null, env); - SCHEME_EXPAND_OBSERVE_LIFT_LOOP(env->observer,obj); - } - break; - } - } else - break; - } - - return obj; -} - -static Scheme_Object *r_expand(Scheme_Object *obj, Scheme_Comp_Env *env, - int depth, int top_intro, int just_to_top, - Scheme_Object *catch_lifts_key, int eb, - int as_local) - /* as_local < 0 => catch lifts to let; - depth = -3 => depth = -2, and no substituion of references with bindings */ -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = obj; - p->ku.k.p2 = env; - p->ku.k.i1 = depth; - p->ku.k.i2 = top_intro; - p->ku.k.i3 = just_to_top; - p->ku.k.p4 = catch_lifts_key; - p->ku.k.i4 = as_local; - - return (Scheme_Object *)scheme_top_level_do(expand_k, eb); -} - -Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env) -{ - return r_expand(obj, scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME), - -1, 1, 0, scheme_false, -1, 0); + return _scheme_eval_linked_expr_multi(obj); } Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj) @@ -4808,766 +3585,68 @@ Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj) return scheme_tail_eval(obj); } +Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) +{ + Scheme_Env *env; + Scheme_Instance *inst; + Scheme_Hash_Tree *protected; + + /* An environment wrapper just for filling in the instance: */ + env = MALLOC_ONE_TAGGED(Scheme_Env); + env->so.type = scheme_env_type; + env->namespace = for_env->namespace; /* records target namespace, not instance's namespace! */ + + inst = scheme_make_instance(name, NULL); + env->instance = (Scheme_Instance *)inst; + + protected = scheme_make_hash_tree(0); + env->protected = protected; + + return env; +} + +void scheme_finish_primitive_module(Scheme_Env *env) +{ + Scheme_Object *proc, *a[5]; + + proc = scheme_get_startup_export("declare-primitive-module!"); + a[0] = env->instance->name; + a[1] = (Scheme_Object *)env->instance; + a[2] = env->namespace; /* target namespace */ + a[3] = (Scheme_Object *)env->protected; + a[4] = (env->cross_phase ? scheme_true : scheme_false); + scheme_apply(proc, 5, a); +} + +void scheme_set_primitive_module_phaseless(Scheme_Env *env, int phaseless) +{ + env->cross_phase = phaseless; +} + +void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) +{ + Scheme_Hash_Tree *protected; + protected = scheme_hash_tree_set(env->protected, name, scheme_true); + env->protected = protected; +} + /* local functions */ -static Scheme_Object * -sch_eval(const char *who, int argc, Scheme_Object *argv[]) +static Scheme_Object *read_syntax(Scheme_Object *port, Scheme_Object *src) { - if (argc == 1) { - return _scheme_tail_apply(scheme_get_param(scheme_current_config(), MZCONFIG_EVAL_HANDLER), - 1, argv); - } else { - Scheme_Config *config; - - if (SCHEME_TYPE(argv[1]) != scheme_namespace_type) - scheme_wrong_contract(who, "namespace?", 1, argc, argv); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - argv[1]); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - return _scheme_tail_apply(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), - 1, argv); - } + Scheme_Object *proc, *a[2]; + proc = scheme_get_startup_export("read-syntax"); + a[0] = src; + a[1] = port; + return scheme_apply(proc, 2, a); } -static Scheme_Object * -eval(int argc, Scheme_Object *argv[]) +static Scheme_Object *namespace_introduce(Scheme_Object *stx) { - Scheme_Object *a[2], *form; - - form = argv[0]; - if (SCHEME_STXP(form) - && !SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) { - Scheme_Env *genv; - if (argc > 1) { - if (SCHEME_TYPE(argv[1]) != scheme_namespace_type) - scheme_wrong_contract("eval", "namespace?", 1, argc, argv); - genv = (Scheme_Env *)argv[1]; - } else - genv = scheme_get_env(NULL); - form = scheme_top_introduce(form, genv); - } - - a[0] = form; - if (argc > 1) - a[1] = argv[1]; - return sch_eval("eval", argc, a); -} - -static Scheme_Object * -eval_stx(int argc, Scheme_Object *argv[]) -{ - if (!SCHEME_STXP(argv[0])) { - scheme_wrong_contract("eval-syntax", "syntax?", 0, argc, argv); - return NULL; - } - - return sch_eval("eval-syntax", argc, argv); -} - -Scheme_Object * -scheme_default_eval_handler(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - Scheme_Object *v; - - env = scheme_get_env(NULL); - - v = _compile(argv[0], env, 0, 1, 0, 0); - - /* Returns a tail apply: */ - return _eval(v, env, 0, 1, 0, 1); -} - -Scheme_Object * -scheme_default_compile_handler(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return _compile(argv[0], env, SCHEME_FALSEP(argv[1]), 0, 0, 0); -} - -static Scheme_Object * -current_eval(int argc, Scheme_Object **argv) -{ - return scheme_param_config("current-eval", - scheme_make_integer(MZCONFIG_EVAL_HANDLER), - argc, argv, - 1, NULL, NULL, 0); -} - -static Scheme_Object * -current_compile(int argc, Scheme_Object **argv) -{ - return scheme_param_config("current-compile", - scheme_make_integer(MZCONFIG_COMPILE_HANDLER), - argc, argv, - 2, NULL, NULL, 0); -} - -static Scheme_Object * -top_introduce_stx(int argc, Scheme_Object **argv) -{ - Scheme_Object *form; - - if (!SCHEME_STXP(argv[0])) { - scheme_wrong_contract("namespace-syntax-introduce", "syntax?", 0, argc, argv); - return NULL; - } - - form = argv[0]; - - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) { - Scheme_Env *genv; - genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV); - form = scheme_top_introduce(form, genv); - } - - return form; -} - -Scheme_Object *scheme_datum_to_kernel_stx(Scheme_Object *e) -{ - return scheme_datum_to_syntax(e, scheme_false, scheme_sys_wraps(NULL), 0, 0); -} - -static Scheme_Object * -compile(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *form = argv[0]; - Scheme_Env *genv; - - if (!SCHEME_STXP(form)) - form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); - - genv = scheme_get_env(NULL); - form = scheme_top_introduce(form, genv); - - return call_compile_handler(form, 0); -} - -static Scheme_Object * -compile_stx(int argc, Scheme_Object *argv[]) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("compile-syntax", "syntax?", 0, argc, argv); - - return call_compile_handler(argv[0], 0); -} - -static Scheme_Object * -compiled_p(int argc, Scheme_Object *argv[]) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *recompile_top(Scheme_Object *top, int comp_flags) -{ - Comp_Prefix *cp; - Scheme_Object *code; - -#if 0 - printf("Resolved Code:\n%s\n\n", scheme_print_to_string(((Scheme_Compilation_Top *)top)->code, NULL)); -#endif - - code = scheme_unresolve_top(top, &cp, comp_flags); - -#if 0 - printf("Unresolved Prefix:\n"); - printf("%s\n\n", scheme_print_to_string(cp, NULL)); - printf("Unresolved Code:\n"); - printf("%s\n\n", scheme_print_to_string(code, NULL)); -#endif - - top = optimize_resolve_expr(code, cp, scheme_get_env(NULL), - scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR), - ((Scheme_Compilation_Top*)top)->prefix->src_insp_desc, - ((Scheme_Compilation_Top*)top)->binding_namess, - comp_flags); - - return top; -} - -static Scheme_Object * -recompile(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type)) { - scheme_wrong_contract("compiled-expression-recompile", "compiled-expression?", 0, argc, argv); - } - - return recompile_top(argv[0], get_comp_flags(NULL)); -} - -static Scheme_Object *expand(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME), - -1, 1, 0, scheme_false, 0, 0); -} - -static Scheme_Object *expand_stx(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("expand-syntax", "syntax?", 0, argc, argv); - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME - | SCHEME_TMP_TL_BIND_FRAME), - -1, 0, 0, scheme_false, 0, 0); -} - -int scheme_is_expansion_context_symbol(Scheme_Object *v) -{ - return (SAME_OBJ(v, module_symbol) - || SAME_OBJ(v, module_begin_symbol) - || SAME_OBJ(v, expression_symbol) - || SAME_OBJ(v, top_level_symbol) - || SAME_OBJ(v, definition_context_symbol)); -} - -Scheme_Object *scheme_frame_to_expansion_context_symbol(int flags) -{ - if (flags & SCHEME_TOPLEVEL_FRAME) - return top_level_symbol; - else if (flags & SCHEME_MODULE_FRAME) - return module_symbol; - else if (flags & SCHEME_MODULE_BEGIN_FRAME) - return module_begin_symbol; - else if (flags & SCHEME_INTDEF_FRAME) - return definition_context_symbol; - else - return expression_symbol; -} - -Scheme_Object *scheme_generate_lifts_key(void) -{ - char buf[20]; - sprintf(buf, "lifts%d", generate_lifts_count++); - return scheme_make_symbol(buf); /* uninterned */ -} - -Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env) -{ - if (!env->genv->lift_key) { - Scheme_Object *o; - o = scheme_generate_lifts_key(); - env->genv->lift_key = o; - } - return env->genv->lift_key; -} - -Scheme_Object * -scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) -{ - Scheme_Object *l, *ids, *id; - - /* Registers scoped ids: */ - for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - (void)scheme_global_binding(id, env->genv, 0); - } - - l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0), - icons(*_ids, - icons(expr, - scheme_null))); - - return scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0); -} - -static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming) -{ - Scheme_Object *rl = renaming, *phase = scheme_make_integer(0); - - if (SCHEME_PAIRP(renaming)) { - while (!SCHEME_NULLP(rl)) { - l = scheme_stx_add_scope(l, SCHEME_CAR(rl), phase); - rl = SCHEME_CDR(rl); - } - } else { - l = scheme_stx_add_scope(l, renaming, phase); - } - - return l; -} - -static void update_intdef_chain(Scheme_Object *intdef) -{ - Scheme_Comp_Env *orig, *current_next; - Scheme_Object *base; - - /* If this intdef chains to another, and if the other has been - extended, then fix up the chain. */ - - while (1) { - base = (Scheme_Object *)((void **)SCHEME_PTR1_VAL(intdef))[1]; - if (base) { - current_next = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(base))[0]; - orig = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[2]; - if (orig) { - orig->next = current_next; - } else { - ((void **)SCHEME_PTR1_VAL(base))[0] = current_next; - } - intdef = base; - } else { - break; - } - } -} - -static Scheme_Object * -do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv) -/* catch_lifts == -1 => wrap as `let-values`; - catch_lifts == 1 => `begin`; - catch_lifts == 2 => `begin`, if any */ -{ - Scheme_Comp_Env *env, *orig_env, *adjust_env = NULL, **ip; - Scheme_Object *l, *local_scope, *renaming = NULL, *orig_l, *exp_expr = NULL; - int cnt, pos, kind, is_modstar; - int bad_sub_env = 0, bad_intdef = 0, keep_ref_ids = 0; - Scheme_Object *observer, *catch_lifts_key = NULL; - - env = scheme_current_thread->current_local_env; - orig_env = env; - - if (!env) - scheme_contract_error(name, - "not currently transforming", - NULL); - - if (for_stx) { - scheme_prepare_exp_env(env->genv); - env = scheme_new_comp_env(env->genv->exp_env, env->insp, NULL, 0); - scheme_propagate_require_lift_capture(orig_env, env); - } - scheme_prepare_compile_env(env->genv); - - if (for_expr) - kind = 0; /* expression */ - else if (!for_stx && SAME_OBJ(argv[1], module_symbol)) { - kind = SCHEME_MODULE_FRAME | SCHEME_USE_SCOPES_TO_NEXT; /* module body */ - if (orig_env->flags & SCHEME_MODULE_FRAME) - adjust_env = orig_env; - } else if (!for_stx && SAME_OBJ(argv[1], module_begin_symbol)) - kind = SCHEME_MODULE_BEGIN_FRAME; /* just inside module for expanding to `#%module-begin` */ - else if (SAME_OBJ(argv[1], top_level_symbol)) { - kind = SCHEME_TOPLEVEL_FRAME; - if (catch_lifts < 0) catch_lifts = (for_stx ? 2 : 0); - if (orig_env->flags & SCHEME_TOPLEVEL_FRAME) - adjust_env = orig_env; - } else if (SAME_OBJ(argv[1], expression_symbol)) - kind = 0; - else if (scheme_proper_list_length(argv[1]) > 0) - kind = SCHEME_INTDEF_FRAME | SCHEME_USE_SCOPES_TO_NEXT; - else { - scheme_wrong_contract(name, - (for_stx - ? "(or/c 'expression 'top-level (and/c pair? list?))" - : "(or/c 'expression 'module 'module-begin 'top-level (and/c pair? list?))"), - 1, argc, argv); - return NULL; - } - - if (argc > 3) { - if (SCHEME_TRUEP(argv[3])) { - if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) { - Scheme_Comp_Env *stx_env; - update_intdef_chain(argv[3]); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0]; - renaming = SCHEME_PTR2_VAL(argv[3]); - if (SCHEME_BOXP(renaming)) /* box means "don't add" */ - renaming = NULL; - if (!scheme_is_sub_env(stx_env, env)) - bad_sub_env = 1; - env = stx_env; - } else if (SCHEME_PAIRP(argv[3])) { - Scheme_Object *rl = argv[3]; - while (SCHEME_PAIRP(rl)) { - if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(SCHEME_CAR(rl)))) { - Scheme_Comp_Env *stx_env; - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0]; - if (!scheme_is_sub_env(stx_env, env)) - bad_sub_env = 1; - } else - break; - rl = SCHEME_CDR(rl); - } - if (!SCHEME_NULLP(rl)) - bad_intdef = 1; - else { - rl = argv[3]; - update_intdef_chain(SCHEME_CAR(rl)); - env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0]; - if (SCHEME_NULLP(SCHEME_CDR(rl))) { - renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl)); - if (SCHEME_BOXP(renaming)) - renaming = NULL; - } else { - /* reverse and extract: */ - renaming = scheme_null; - while (!SCHEME_NULLP(rl)) { - l = SCHEME_PTR2_VAL(SCHEME_CAR(rl)); - if (!SCHEME_BOXP(l)) - renaming = cons(l, renaming); - rl = SCHEME_CDR(rl); - } - } - } - } else - bad_intdef = 1; - } - - if (argc > 4) { - /* catch_lifts */ - catch_lifts_key = argv[4]; - } - } - - if (catch_lifts && !catch_lifts_key) - catch_lifts_key = scheme_generate_lifts_key(); - - /* For each given stop-point identifier, shadow any potential syntax - in the environment with an identity-expanding syntax expander. */ - - (void)scheme_get_stop_expander(); - - env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_FOR_STOPS - | kind), - NULL, - env); - - if (adjust_env && adjust_env->expand_result_adjust) { - env->expand_result_adjust = adjust_env->expand_result_adjust; - env->expand_result_adjust_arg = adjust_env->expand_result_adjust_arg; - } - - if (catch_lifts < 0) { - /* Note: extra frames can get inserted after env by pair_lifted */ - ip = MALLOC_N(Scheme_Comp_Env *, 1); - *ip = env; - } else - ip = NULL; - - if (kind & SCHEME_INTDEF_FRAME) - env->intdef_name = argv[1]; - env->in_modidx = scheme_current_thread->current_local_modidx; - - local_scope = scheme_current_thread->current_local_scope; - - if (for_expr) { - } else if (SCHEME_TRUEP(argv[2])) { -# define NUM_CORE_EXPR_STOP_FORMS 15 - cnt = scheme_proper_list_length(argv[2]); - - if ((cnt == 1) - && SCHEME_STXP(SCHEME_CAR(argv[2])) - && SCHEME_SYMBOLP(SCHEME_STX_VAL(SCHEME_CAR(argv[2])))) - is_modstar = scheme_stx_free_eq_x(scheme_modulestar_stx, SCHEME_CAR(argv[2]), env->genv->phase); - else - is_modstar = 0; - - if (cnt > 0) { - if (!is_modstar) - cnt += NUM_CORE_EXPR_STOP_FORMS; - scheme_add_local_syntax(cnt, env); - } - pos = 0; - - for (l = argv[2]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - Scheme_Object *i; - - i = SCHEME_CAR(l); - if (!SCHEME_STXP(i) || !SCHEME_STX_SYMBOLP(i)) { - scheme_wrong_contract(name, "(or/c #f (listof identifier?))", 2, argc, argv); - return NULL; - } - - if (cnt > 0) - scheme_set_local_syntax(pos++, i, scheme_get_stop_expander(), env, 0); - } - if (!SCHEME_NULLP(l)) { - scheme_wrong_contract(name, "(or/c #f (listof identifier?))", 2, argc, argv); - return NULL; - } - - if ((cnt > 0) && !is_modstar) { - scheme_add_core_stop_form(pos++, begin_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("set!"), env); - scheme_add_core_stop_form(pos++, app_symbol, env); - scheme_add_core_stop_form(pos++, top_symbol, env); - scheme_add_core_stop_form(pos++, lambda_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("case-lambda"), env); - scheme_add_core_stop_form(pos++, let_values_symbol, env); - scheme_add_core_stop_form(pos++, letrec_values_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("if"), env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("begin0"), env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("with-continuation-mark"), env); - scheme_add_core_stop_form(pos++, letrec_syntaxes_symbol, env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%variable-reference"), env); - scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env); - scheme_add_core_stop_form(pos++, quote_symbol, env); - keep_ref_ids = 1; - } - } - - /* Report errors related to 3rd argument, finally */ - if (argc > 3) { - if (bad_intdef) { - scheme_wrong_contract(name, "(or/c internal-definition-context? (non-empty-listof internal-definition-context?) #f)", - 3, argc, argv); - return NULL; - } else if (bad_sub_env) { - scheme_contract_error(name, - "transforming context does not match internal-definition context", - NULL); - return NULL; - } - } - - l = argv[0]; - - if (!SCHEME_STXP(l)) - l = scheme_datum_to_syntax(l, scheme_false, scheme_false, 1, 0); - - orig_l = l; - - observer = scheme_get_expand_observe(); - if (observer) { - SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l); - if (for_stx) { - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - } - } - - env->observer = observer; - - if (local_scope) { - /* Since we have an expression from local context, - we need to remove the temporary scope... */ - l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv)); - } - - if (renaming) { - l = add_intdef_renamings(l, renaming); - env->expand_result_adjust = add_intdef_renamings; - env->expand_result_adjust_arg = renaming; - } - - SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l); - - if (SCHEME_FALSEP(argv[2])) { - Scheme_Object *xl, *gval; - Scheme_Compile_Expand_Info drec[1]; - - if (catch_lifts_key) { - Scheme_Object *data; - data = (catch_lifts < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env); - scheme_frame_captures_lifts(env, - (catch_lifts < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, - data, - scheme_top_level_lifts_key(env), - catch_lifts_key, NULL, - scheme_false, - ((kind & SCHEME_TOPLEVEL_FRAME) - ? scheme_true /* lifted `module` like definition */ - : ((kind & SCHEME_MODULE_FRAME) - ? scheme_void /* lifted `module[*]` like definition */ - : scheme_false))); /* no lifted modules */ - } - - memset(drec, 0, sizeof(drec)); - drec[0].depth = -2; - { - int comp_flags; - comp_flags = get_comp_flags(NULL); - drec[0].comp_flags = comp_flags; - } - - if (!(env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME))) - env->value_name = scheme_current_thread->current_local_name; - - xl = scheme_check_immediate_macro(l, env, drec, 0, &gval, 1); - - if (SAME_OBJ(xl, l) && !for_expr) { - SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, xl); - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, orig_l); - return orig_l; - } - - if (catch_lifts_key) { - int observe = 1; - if (catch_lifts < 0) - xl = scheme_add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l, 0); - else { - l = scheme_frame_get_lifts(env); - if (SCHEME_PAIRP(l) || (catch_lifts < 2)) - xl = add_lifts_as_begin(xl, l, env); - else - observe = 0; - } - if (observe) { - SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl); - } - } - - l = xl; - } else { - /* Expand the expression. depth = -2 means expand all the way, but - preserve letrec-syntax, while -3 is -2 but also avoid replacing reference ids - with binding ids. */ - l = r_expand(l, env, (keep_ref_ids ? -3 : -2), 0, 0, catch_lifts_key, 0, - catch_lifts ? catch_lifts : 1); - } - - SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l); - - if (renaming) - l = add_intdef_renamings(l, renaming); - - if (for_expr) { - /* Package up expanded expr with the environment. */ - while (1) { - if (orig_env->flags & SCHEME_FOR_STOPS) - orig_env = orig_env->next; - else if ((orig_env->flags & SCHEME_INTDEF_FRAME) - && !orig_env->num_bindings) - orig_env = orig_env->next; - else - break; - } - exp_expr = scheme_alloc_object(); - exp_expr->type = scheme_expanded_syntax_type; - SCHEME_PTR1_VAL(exp_expr) = l; - SCHEME_PTR2_VAL(exp_expr) = orig_env; - exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0); - if (local_scope) - exp_expr = scheme_stx_flip_scope(exp_expr, local_scope, scheme_env_phase(env->genv)); - } - - if (local_scope) { - /* Put the temporary scope back: */ - l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv)); - } - - if (for_expr) { - Scheme_Object *a[2]; - SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(observer, exp_expr); - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l); - a[0] = l; - a[1] = exp_expr; - return scheme_values(2, a); - } else { - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l); - return l; - } -} - - -static Scheme_Object * -local_expand(int argc, Scheme_Object **argv) -{ - return do_local_expand("local-expand", 0, 0, 0, argc, argv); -} - -static Scheme_Object * -local_expand_expr(int argc, Scheme_Object **argv) -{ - return do_local_expand("syntax-local-expand-expression", 0, 0, 1, argc, argv); -} - -static Scheme_Object * -local_transformer_expand(int argc, Scheme_Object **argv) -{ - return do_local_expand("local-transformer-expand", 1, -1, 0, argc, argv); -} - -static Scheme_Object * -local_expand_catch_lifts(int argc, Scheme_Object **argv) -{ - return do_local_expand("local-expand/capture-lifts", 0, 1, 0, argc, argv); -} - -static Scheme_Object * -local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv) -{ - return do_local_expand("local-transformer-expand/capture-lifts", 1, 1, 0, argc, argv); -} - -static Scheme_Object * -expand_once(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 1, 0, scheme_false, 0, 0); -} - -static Scheme_Object * -expand_stx_once(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("expand-syntax-once", "syntax?", 0, argc, argv); - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 0, 0, scheme_false, 0, 0); -} - -static Scheme_Object * -expand_to_top_form(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 1, 1, scheme_false, 0, 0); -} - -static Scheme_Object * -expand_stx_to_top_form(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("expand-syntax-to-top", "syntax?", 0, argc, argv); - - env = scheme_get_env(NULL); - - return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, - SCHEME_TOPLEVEL_FRAME - | SCHEME_KEEP_SCOPES_FRAME), - 1, 0, 1, scheme_false, 0, 0); + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("namespace-introduce"); + a[0] = stx; + return scheme_apply(proc, 1, a); } static Scheme_Object *do_eval_string_all(Scheme_Object *port, const char *str, Scheme_Env *env, @@ -5583,21 +3662,10 @@ static Scheme_Object *do_eval_string_all(Scheme_Object *port, const char *str, S port = scheme_make_byte_string_input_port(str); do { - expr = scheme_read_syntax(port, scheme_false); + expr = read_syntax(port, scheme_false); - if (cont == -2) { - if (SCHEME_STXP(expr)) { - Scheme_Object *m; - m = SCHEME_STX_VAL(expr); - if (SCHEME_PAIRP(m)) { - m = scheme_make_pair(scheme_datum_to_syntax(module_symbol, - SCHEME_CAR(m), - scheme_sys_wraps(NULL), - 0, 0), - SCHEME_CDR(m)); - expr = scheme_datum_to_syntax(m, expr, expr, 0, 1); - } - } + if ((cont == -2) && !SAME_OBJ(expr, scheme_eof)) { + expr = namespace_introduce(expr); } if (SAME_OBJ(expr, scheme_eof)) @@ -5689,8 +3757,8 @@ Scheme_Object *scheme_eval_string_multi_with_prompt(const char *str, Scheme_Env void scheme_embedded_load(intptr_t len, const char *desc, int predefined) { - Scheme_Object *s, *e, *a[3], *eload; - eload = scheme_builtin_value("embedded-load"); + Scheme_Object *s, *e, *a[4], *eload; + eload = scheme_get_startup_export("embedded-load"); if (len < 0) { /* description mode */ s = scheme_make_utf8_string(desc); @@ -5705,15 +3773,21 @@ void scheme_embedded_load(intptr_t len, const char *desc, int predefined) s = scheme_make_sized_byte_string((char *)desc, len, 0); a[2] = s; } - if (predefined) - scheme_starting_up = 1; - (void)scheme_apply(eload, 3, a); - if (predefined) - scheme_starting_up = 0; + a[3] = (predefined ? scheme_true : scheme_false); + (void)scheme_apply(eload, 4, a); } -void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *post_dirs) -{ +int scheme_is_predefined_module_path(Scheme_Object *m) +{ + Scheme_Object *is_predef, *a[1], *r; + is_predef = scheme_get_startup_export("embedded-load"); + a[0] = m; + r = scheme_apply(is_predef, 1, a); + return SCHEME_TRUEP(r); +} + +void scheme_init_collection_paths_post(Scheme_Env *env, Scheme_Object *extra_dirs, Scheme_Object *post_dirs) +{ mz_jmp_buf * volatile save, newbuf; Scheme_Thread * volatile p; p = scheme_get_current_thread(); @@ -5745,9 +3819,9 @@ void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *ex p->error_buf = save; } -void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs) +void scheme_init_collection_paths(Scheme_Env *env, Scheme_Object *extra_dirs) { - scheme_init_collection_paths_post(global_env, extra_dirs, scheme_null); + scheme_init_collection_paths_post(env, extra_dirs, scheme_null); } void scheme_init_compiled_roots(Scheme_Env *global_env, const char *paths) @@ -5833,428 +3907,59 @@ enable_break(int argc, Scheme_Object *argv[]) } } -static Scheme_Object *flip_scope_at_phase_and_revert_expr(Scheme_Object *a, Scheme_Object *m_p) +Scheme_Object *scheme_make_modidx(Scheme_Object *path, + Scheme_Object *base, + Scheme_Object *resolved) { - Scheme_Comp_Env *env = (Scheme_Comp_Env *)SCHEME_CDR(m_p); - - a = scheme_revert_use_site_scopes(a, env); - - return scheme_stx_flip_scope(a, SCHEME_CAR(m_p), scheme_env_phase(env->genv)); + Scheme_Object *proc, *a[2]; + proc = scheme_get_startup_export("module-path-index-join"); + a[0] = path; + a[1] = base; + return scheme_apply(proc, 2, a); + } -static Scheme_Object *add_scope_at_phase(Scheme_Object *a, Scheme_Object *m_p) +int scheme_is_module_path_index(Scheme_Object *v) { - return scheme_stx_add_scope(a, SCHEME_CAR(m_p), SCHEME_CDR(m_p)); + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("module-path-index?"); + a[0] = v; + return SCHEME_TRUEP(scheme_apply(proc, 1, a)); } -static Scheme_Object *revert_expr_scopes(Scheme_Object *a, Scheme_Object *env) +int scheme_is_resolved_module_path(Scheme_Object *v) { - return scheme_revert_use_site_scopes(a, (Scheme_Comp_Env *)env); + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("resolved-module-path?"); + a[0] = v; + return SCHEME_TRUEP(scheme_apply(proc, 1, a)); } -static Scheme_Object * -local_eval(int argc, Scheme_Object **argv) +int scheme_is_module_path(Scheme_Object *v) { - Scheme_Comp_Env *env, *stx_env, *init_env; - Scheme_Object *l, *a, *rib, *expr, *names, *rn_names, *observer; - int cnt = 0, pos; - - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_LOCAL_BIND(observer, argv[0]); - - names = argv[0]; - for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - break; - cnt++; - } - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("syntax-local-bind-syntaxes", "(listof identifier?)", 0, argc, argv); - - expr = argv[1]; - if (!SCHEME_FALSEP(expr) && !SCHEME_STXP(expr)) - scheme_wrong_contract("syntax-local-bind-syntaxes", "(or/c syntax? #f)", 1, argc, argv); - if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2]))) - scheme_wrong_contract("syntax-local-bind-syntaxes", "internal-definition-context?", 2, argc, argv); - - env = scheme_current_thread->current_local_env; - if (!env) - scheme_contract_error("syntax-local-bind-syntaxes", - "not currently transforming", - NULL); - - update_intdef_chain(argv[2]); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0]; - init_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[3]; - rib = SCHEME_PTR2_VAL(argv[2]); - if (SCHEME_BOXP(rib)) rib = SCHEME_BOX_VAL(rib); - - if (!scheme_is_sub_env(stx_env, env)) { - scheme_contract_error("syntax-local-bind-syntaxes", - "transforming context does not match given internal-definition context", - NULL); - } - - stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF | SCHEME_USE_SCOPES_TO_NEXT, rib, stx_env); - scheme_add_local_syntax(cnt, stx_env); - env->observer = observer; - - /* Scope names */ - if (scheme_current_thread->current_local_scope) - names = scheme_named_map_1(NULL, flip_scope_at_phase_and_revert_expr, names, - scheme_make_raw_pair(scheme_current_thread->current_local_scope, - (Scheme_Object *)stx_env)); - - SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer,names); - - /* Initialize environment slots to #f, which means "not syntax". */ - cnt = 0; - for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - a = scheme_revert_use_site_scopes(a, init_env); - scheme_set_local_syntax(cnt++, a, scheme_false, stx_env, 0); - } - - stx_env->in_modidx = scheme_current_thread->current_local_modidx; - if (!SCHEME_FALSEP(expr)) { - Scheme_Compile_Expand_Info rec; - rec.comp = 0; - rec.depth = -1; - rec.pre_unwrapped = 0; - rec.env_already = 0; - rec.substitute_bindings = 1; - rec.comp_flags = get_comp_flags(NULL); - - /* Evaluate and bind syntaxes */ - if (scheme_current_thread->current_local_scope) - expr = scheme_stx_flip_scope(expr, scheme_current_thread->current_local_scope, - scheme_env_phase(env->genv)); - - scheme_prepare_exp_env(stx_env->genv); - scheme_prepare_compile_env(stx_env->genv->exp_env); - pos = 0; - expr = scheme_stx_add_scope(expr, rib, scheme_env_phase(stx_env->genv)); - rn_names = scheme_named_map_1(NULL, add_scope_at_phase, names, - scheme_make_pair(rib, scheme_env_phase(stx_env->genv))); - rn_names = scheme_named_map_1(NULL, revert_expr_scopes, rn_names, (Scheme_Object *)init_env); - scheme_bind_syntaxes("local syntax definition", rn_names, expr, - stx_env->genv->exp_env, stx_env->insp, - &rec, 0, stx_env->observer, - stx_env, stx_env, - &pos, rib, 1); - } - - /* Remember extended environment */ - ((void **)SCHEME_PTR1_VAL(argv[2]))[0] = stx_env; - if (!((void **)SCHEME_PTR1_VAL(argv[2]))[2]) - ((void **)SCHEME_PTR1_VAL(argv[2]))[2] = stx_env; - - SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_BIND(observer); - - return scheme_void; + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("module-path?"); + a[0] = v; + return SCHEME_TRUEP(scheme_apply(proc, 1, a)); } -Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef) +int scheme_module_is_declared(Scheme_Object *name, int try_load) { - Scheme_Comp_Env *stx_env, *init_env; - Scheme_Object *l = scheme_null; - int i; - - update_intdef_chain(intdef); - stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[0]; - init_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[3]; - - while (stx_env != init_env) { - for (i = stx_env->num_bindings; i--; ) { - l = scheme_make_pair(stx_env->binders[i], l); - } - stx_env = stx_env->next; - } - - return l; + Scheme_Object *proc, *a[2]; + proc = scheme_get_startup_export("module-declared?"); + a[0] = name; + a[1] = (try_load ? scheme_true : scheme_false); + return SCHEME_TRUEP(scheme_apply(proc, 2, a)); } -/*========================================================================*/ -/* cloning prefix information */ -/*========================================================================*/ - -Scheme_Object *scheme_eval_clone(Scheme_Object *expr) +Scheme_Object *scheme_datum_to_kernel_stx(Scheme_Object *v) { - /* Clone as much as necessary of `expr' so that prefixes are - cloned. Cloned prefixes, in turn, can be updated by linking to - reduce the overhead of cross-module references. */ - switch (SCHEME_TYPE(expr)) { - case scheme_module_type: - if (scheme_startup_use_jit) - return scheme_module_jit(expr); - else - return scheme_module_eval_clone(expr); - break; - case scheme_define_syntaxes_type: - case scheme_begin_for_syntax_type: - return scheme_syntaxes_eval_clone(expr); - default: - return expr; - } + Scheme_Object *proc, *a[1]; + proc = scheme_get_startup_export("datum->kernel-syntax"); + a[0] = v; + return scheme_apply(proc, 1, a); } -Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp) -{ - Resolve_Prefix *naya; - Scheme_Object **tls; - - if (!rp->num_toplevels) - return rp; - - naya = MALLOC_ONE_TAGGED(Resolve_Prefix); - memcpy(naya, rp, sizeof(Resolve_Prefix)); - - tls = MALLOC_N(Scheme_Object*, rp->num_toplevels); - memcpy(tls, rp->toplevels, sizeof(Scheme_Object *) * rp->num_toplevels); - naya->toplevels = tls; - - return naya; -} - -/*========================================================================*/ -/* creating/pushing prefix for top-levels and syntax objects */ -/*========================================================================*/ - -int scheme_prefix_depth(Resolve_Prefix *rp) -{ - if (rp->num_toplevels || rp->num_stxes || rp->num_lifts) - return 1; - else - return 0; -} - -Scheme_Object **scheme_push_prefix(Scheme_Env *genv, int already_linked, Resolve_Prefix *rp, - Scheme_Object *src_modidx, Scheme_Object *now_modidx, - int src_phase, int now_phase, - Scheme_Env *dummy_env, Scheme_Object *insp) -{ - Scheme_Object **rs_save, **rs, *v; - Scheme_Prefix *pf; - int i, j, tl_map_len; - - rs_save = rs = MZ_RUNSTACK; - - if (rp->num_toplevels || rp->num_stxes || rp->num_lifts) { - i = rp->num_toplevels; - if (rp->num_stxes) { - i += rp->num_stxes + 1; - } - i += rp->num_lifts; - - tl_map_len = ((rp->num_toplevels + rp->num_lifts + (rp->num_stxes ? 1 : 0)) + 31) / 32; - - pf = scheme_malloc_tagged(sizeof(Scheme_Prefix) - + ((i-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + (tl_map_len * sizeof(int))); - pf->iso.so.type = scheme_prefix_type; - pf->num_slots = i; - pf->num_toplevels = rp->num_toplevels; - pf->num_stxes = rp->num_stxes; - --rs; - MZ_RUNSTACK = rs; - rs[0] = (Scheme_Object *)pf; - - for (i = 0; i < rp->num_toplevels; i++) { - v = rp->toplevels[i]; - if (!already_linked || SCHEME_FALSEP(v)) - v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx, insp); - else if (SAME_TYPE(SCHEME_TYPE(v), scheme_module_variable_type)) { - /* not already linked, after all */ - v = link_toplevel(rp->toplevels, i, genv, src_modidx, now_modidx, insp); - } - pf->a[i] = v; - } - - if (rp->num_stxes) { - if (insp && SCHEME_FALSEP(insp)) - insp = scheme_get_current_inspector(); - i = rp->num_toplevels; - v = scheme_make_shift(scheme_make_integer(now_phase - src_phase), - src_modidx, now_modidx, - !already_linked ? genv->module_registry->exports : NULL, - rp->src_insp_desc, insp); - if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) { - /* Put lazy-shift info in pf->a[i]: */ - Scheme_Object **ls; - ls = MALLOC_N(Scheme_Object *, 2); - ls[0] = v; - ls[1] = (Scheme_Object *)rp; - pf->a[i] = (Scheme_Object *)ls; - /* Rest of a left zeroed, to be filled in lazily by quote-syntax evaluation */ - } else { - /* No shift, so fill in stxes immediately */ - i++; - for (j = 0; j < rp->num_stxes; j++) { - pf->a[i + j] = rp->stxes[j]; - } - } - j = rp->num_stxes + 1; - } else - j = 0; - - if (rp->num_lifts) { - Scheme_Object *sym, *home; - sym = scheme_make_symbol(""); /* uninterned! */ - j += rp->num_toplevels; - home = (Scheme_Object *)scheme_get_home_weak_link(genv); - for (i = 0; i < rp->num_lifts; i++, j++) { - v = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Bucket_With_Home); - v->type = scheme_variable_type; - ((Scheme_Bucket_With_Flags *)v)->flags = GLOB_HAS_HOME_PTR; - ((Scheme_Bucket_With_Home *)v)->home_link = home; - ((Scheme_Bucket *)v)->key = (char *)sym; - pf->a[j] = v; - } - } - } - - return rs_save; -} - -void scheme_pop_prefix(Scheme_Object **rs) -{ - /* This function must not allocate, since a relevant multiple-values - result may be in the thread record (and we don't want it zerod) */ - MZ_RUNSTACK = rs; -} - -Scheme_Object *scheme_suspend_prefix(Scheme_Object **rs) -{ - if (rs != MZ_RUNSTACK) { - Scheme_Object *v; - v = MZ_RUNSTACK[0]; - MZ_RUNSTACK++; - return v; - } else - return NULL; -} - -Scheme_Object **scheme_resume_prefix(Scheme_Object *v) -{ - if (v) { - --MZ_RUNSTACK; - MZ_RUNSTACK[0] = v; - return MZ_RUNSTACK + 1; - } else - return MZ_RUNSTACK; -} - -#ifdef MZ_PRECISE_GC -static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC -{ - if (!GC_is_partial(gc)) { - if (scheme_inc_prefix_finalize != (Scheme_Prefix *)0x1) { - Scheme_Prefix *pf = scheme_inc_prefix_finalize; - while (pf->next_final != (Scheme_Prefix *)0x1) { - pf = pf->next_final; - } - pf->next_final = scheme_prefix_finalize; - scheme_prefix_finalize = scheme_inc_prefix_finalize; - scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; - } - } - - if (scheme_prefix_finalize != (Scheme_Prefix *)0x1) { - Scheme_Prefix *pf = scheme_prefix_finalize, *next; - Scheme_Object *clo; - int i, *use_bits, maxpos; - - scheme_prefix_finalize = (Scheme_Prefix *)0x1; - while (pf != (Scheme_Prefix *)0x1) { - /* If not marked, only references are through closures: */ - if (!GC_is_marked2(pf, gc)) { - /* Clear slots that are not use in map */ - maxpos = (pf->num_slots - pf->num_stxes); - use_bits = PREFIX_TO_USE_BITS(pf); - for (i = (maxpos + 31) / 32; i--; ) { - int j; - for (j = 0; j < 32; j++) { - if (!(use_bits[i] & ((unsigned)1 << j))) { - int pos; - pos = (i * 32) + j; - if (pos < pf->num_toplevels) - pf->a[pos] = NULL; /* top level */ - else if (pos < maxpos) { - if (pf->num_stxes) { - if (pos == pf->num_toplevels) { - /* any syntax object */ - int k; - for (k = pf->num_stxes+1; k--;) { - pf->a[k + pf->num_toplevels] = NULL; - } - } else - pf->a[pos + pf->num_stxes] = NULL; /* lifted */ - } else - pf->a[pos] = NULL; /* lifted */ - } - } - } - use_bits[i] = 0; - } - /* Should mark/copy pf, but not trigger or require mark propagation: */ -#ifdef MZ_GC_BACKTRACE - GC_set_backpointer_object(pf->backpointer); -#endif - GC_mark_no_recur(gc, 1); - gcMARK2(pf, gc); - pf = (Scheme_Prefix *)GC_resolve2(pf, gc); - GC_retract_only_mark_stack_entry(pf, gc); - GC_mark_no_recur(gc, 0); - } else - pf = (Scheme_Prefix *)GC_resolve2(pf, gc); - - /* Clear use map */ - use_bits = PREFIX_TO_USE_BITS(pf); - maxpos = (pf->num_slots - pf->num_stxes); - for (i = (maxpos + 31) / 32; i--; ) - use_bits[i] = 0; - - /* Fix up closures that reference this prefix: */ - clo = (Scheme_Object *)GC_resolve2(pf->fixup_chain, gc); - pf->fixup_chain = NULL; - while (clo) { - Scheme_Object *next; - if (SCHEME_TYPE(clo) == scheme_closure_type) { - Scheme_Closure *cl = (Scheme_Closure *)clo; - int closure_size = ((Scheme_Lambda *)GC_resolve2(cl->code, gc))->closure_size; - next = cl->vals[closure_size - 1]; - cl->vals[closure_size-1] = (Scheme_Object *)pf; - } else if (SCHEME_TYPE(clo) == scheme_native_closure_type) { - Scheme_Native_Closure *cl = (Scheme_Native_Closure *)clo; - int closure_size = ((Scheme_Native_Lambda *)GC_resolve2(cl->code, gc))->closure_size; - next = cl->vals[closure_size - 1]; - cl->vals[closure_size-1] = (Scheme_Object *)pf; - } else { - MZ_ASSERT(0); - next = NULL; - } - clo = (Scheme_Object *)GC_resolve2(next, gc); - } - if (SCHEME_PREFIX_FLAGS(pf) & 0x1) - SCHEME_PREFIX_FLAGS(pf) -= 0x1; - - /* Next */ - next = pf->next_final; - pf->next_final = NULL; - - pf = next; - } - } -} - -int check_pruned_prefix(void *p) XFORM_SKIP_PROC -{ - Scheme_Prefix *pf = (Scheme_Prefix *)p; - return SCHEME_PREFIX_FLAGS(pf) & 0x1; -} -#endif - /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff --git a/racket/src/racket/src/file.c b/racket/src/racket/src/file.c index 88f7bdec1b..c28e18ae7a 100644 --- a/racket/src/racket/src/file.c +++ b/racket/src/racket/src/file.c @@ -54,12 +54,6 @@ #define IS_A_SEP(kind, x) ((kind == SCHEME_UNIX_PATH_KIND) ? IS_A_UNIX_SEP(x) : IS_A_DOS_SEP(x)) #define IS_A_PRIM_SEP(kind, x) ((kind == SCHEME_UNIX_PATH_KIND) ? IS_A_UNIX_PRIM_SEP(x) : IS_A_DOS_PRIM_SEP(x)) -SHARED_OK int scheme_ignore_user_paths; -void scheme_set_ignore_user_paths(int v) { scheme_ignore_user_paths = v; } - -SHARED_OK int scheme_ignore_link_paths; -void scheme_set_ignore_link_paths(int v) { scheme_ignore_link_paths = v; } - #define CURRENT_WD() scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY) #define TO_PATH(x) (SCHEME_GENERAL_PATHP(x) ? x : scheme_char_string_to_path(x)) @@ -127,13 +121,6 @@ static Scheme_Object *file_modify_seconds(int argc, Scheme_Object *argv[]); static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[]); static Scheme_Object *file_identity(int argc, Scheme_Object *argv[]); static Scheme_Object *file_size(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_library_collection_links(int argc, Scheme_Object *argv[]); -static Scheme_Object *use_compiled_kind(int, Scheme_Object *[]); -static Scheme_Object *compiled_file_roots(int, Scheme_Object *[]); -static Scheme_Object *use_user_paths(int, Scheme_Object *[]); -static Scheme_Object *use_link_paths(int, Scheme_Object *[]); -static Scheme_Object *use_compiled_file_check(int, Scheme_Object *[]); static Scheme_Object *find_system_path(int argc, Scheme_Object **argv); static Scheme_Object *current_directory(int argc, Scheme_Object *argv[]); @@ -172,7 +159,7 @@ SHARED_OK static Scheme_Object *addon_dir; READ_ONLY static Scheme_Object *windows_symbol, *unix_symbol; -void scheme_init_file(Scheme_Env *env) +void scheme_init_file(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -235,270 +222,235 @@ void scheme_init_file(Scheme_Env *env) p = scheme_make_immed_prim(path_p, "path?", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("path?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("path?", p, env); - scheme_add_global_constant("path-for-some-system?", + scheme_addto_prim_instance("path-for-some-system?", scheme_make_folding_prim(general_path_p, "path-for-some-system?", 1, 1, 1), env); - scheme_add_global_constant("path-convention-type", + scheme_addto_prim_instance("path-convention-type", scheme_make_folding_prim(path_kind, "path-convention-type", 1, 1, 1), env); - scheme_add_global_constant("system-path-convention-type", + scheme_addto_prim_instance("system-path-convention-type", scheme_make_immed_prim(platform_path_kind, "system-path-convention-type", 0, 0), env); - scheme_add_global_constant("path->string", + scheme_addto_prim_instance("path->string", scheme_make_immed_prim(path_to_string, "path->string", 1, 1), env); - scheme_add_global_constant("path->bytes", + scheme_addto_prim_instance("path->bytes", scheme_make_immed_prim(path_to_bytes, "path->bytes", 1, 1), env); - scheme_add_global_constant("path-element->bytes", + scheme_addto_prim_instance("path-element->bytes", scheme_make_immed_prim(path_element_to_bytes, "path-element->bytes", 1, 1), env); - scheme_add_global_constant("path-element->string", + scheme_addto_prim_instance("path-element->string", scheme_make_immed_prim(path_element_to_string, "path-element->string", 1, 1), env); - scheme_add_global_constant("string->path", + scheme_addto_prim_instance("string->path", scheme_make_immed_prim(string_to_path, "string->path", 1, 1), env); - scheme_add_global_constant("bytes->path", + scheme_addto_prim_instance("bytes->path", scheme_make_immed_prim(bytes_to_path, "bytes->path", 1, 2), env); - scheme_add_global_constant("bytes->path-element", + scheme_addto_prim_instance("bytes->path-element", scheme_make_immed_prim(bytes_to_path_element, "bytes->path-element", 1, 2), env); - scheme_add_global_constant("string->path-element", + scheme_addto_prim_instance("string->path-element", scheme_make_immed_prim(string_to_path_element, "string->path-element", 1, 1), env); - scheme_add_global_constant("file-exists?", + scheme_addto_prim_instance("file-exists?", scheme_make_prim_w_arity(file_exists, "file-exists?", 1, 1), env); - scheme_add_global_constant("directory-exists?", + scheme_addto_prim_instance("directory-exists?", scheme_make_prim_w_arity(directory_exists, "directory-exists?", 1, 1), env); - scheme_add_global_constant("link-exists?", + scheme_addto_prim_instance("link-exists?", scheme_make_prim_w_arity(link_exists, "link-exists?", 1, 1), env); - scheme_add_global_constant("delete-file", + scheme_addto_prim_instance("delete-file", scheme_make_prim_w_arity(delete_file, "delete-file", 1, 1), env); - scheme_add_global_constant("rename-file-or-directory", + scheme_addto_prim_instance("rename-file-or-directory", scheme_make_prim_w_arity(rename_file, "rename-file-or-directory", 2, 3), env); - scheme_add_global_constant("copy-file", + scheme_addto_prim_instance("copy-file", scheme_make_prim_w_arity(copy_file, "copy-file", 2, 3), env); - scheme_add_global_constant("build-path", + scheme_addto_prim_instance("build-path", scheme_make_immed_prim(scheme_build_path, "build-path", 1, -1), env); - scheme_add_global_constant("build-path/convention-type", + scheme_addto_prim_instance("build-path/convention-type", scheme_make_immed_prim(build_path_kind, "build-path/convention-type", 2, -1), env); - scheme_add_global_constant("path->directory-path", + scheme_addto_prim_instance("path->directory-path", scheme_make_immed_prim(path_to_directory_path, "path->directory-path", 1, 1), env); - scheme_add_global_constant("split-path", + scheme_addto_prim_instance("split-path", scheme_make_prim_w_arity2(split_path, "split-path", 1, 1, 3, 3), env); - scheme_add_global_constant("explode-path", + scheme_addto_prim_instance("explode-path", scheme_make_immed_prim(explode_path, "explode-path", 1, 1), env); - scheme_add_global_constant("relative-path?", + scheme_addto_prim_instance("relative-path?", scheme_make_immed_prim(relative_path_p, "relative-path?", 1, 1), env); - scheme_add_global_constant("absolute-path?", + scheme_addto_prim_instance("absolute-path?", scheme_make_immed_prim(absolute_path_p, "absolute-path?", 1, 1), env); - scheme_add_global_constant("complete-path?", + scheme_addto_prim_instance("complete-path?", scheme_make_immed_prim(complete_path_p, "complete-path?", 1, 1), env); - scheme_add_global_constant("path->complete-path", + scheme_addto_prim_instance("path->complete-path", scheme_make_immed_prim(path_to_complete_path, "path->complete-path", 1, 2), env); - scheme_add_global_constant("resolve-path", + scheme_addto_prim_instance("resolve-path", scheme_make_prim_w_arity(resolve_path, "resolve-path", 1, 1), env); - scheme_add_global_constant("simplify-path", + scheme_addto_prim_instance("simplify-path", scheme_make_prim_w_arity(scheme_simplify_path, "simplify-path", 1, 2), env); - scheme_add_global_constant("cleanse-path", + scheme_addto_prim_instance("cleanse-path", scheme_make_prim_w_arity(cleanse_path, "cleanse-path", 1, 1), env); - scheme_add_global_constant("expand-user-path", + scheme_addto_prim_instance("expand-user-path", scheme_make_prim_w_arity(expand_user_path, "expand-user-path", 1, 1), env); - scheme_add_global_constant("directory-list", + scheme_addto_prim_instance("directory-list", scheme_make_prim_w_arity(directory_list, "directory-list", 0, 1), env); - scheme_add_global_constant("filesystem-root-list", + scheme_addto_prim_instance("filesystem-root-list", scheme_make_prim_w_arity(filesystem_root_list, "filesystem-root-list", 0, 0), env); - scheme_add_global_constant("make-directory", + scheme_addto_prim_instance("make-directory", scheme_make_prim_w_arity(make_directory, "make-directory", 1, 1), env); - scheme_add_global_constant("delete-directory", + scheme_addto_prim_instance("delete-directory", scheme_make_prim_w_arity(delete_directory, "delete-directory", 1, 1), env); - scheme_add_global_constant("make-file-or-directory-link", + scheme_addto_prim_instance("make-file-or-directory-link", scheme_make_prim_w_arity(make_link, "make-file-or-directory-link", 2, 2), env); - scheme_add_global_constant("file-or-directory-modify-seconds", + scheme_addto_prim_instance("file-or-directory-modify-seconds", scheme_make_prim_w_arity(file_modify_seconds, "file-or-directory-modify-seconds", 1, 3), env); - scheme_add_global_constant("file-or-directory-permissions", + scheme_addto_prim_instance("file-or-directory-permissions", scheme_make_prim_w_arity(file_or_dir_permissions, "file-or-directory-permissions", 1, 2), env); - scheme_add_global_constant("file-or-directory-identity", + scheme_addto_prim_instance("file-or-directory-identity", scheme_make_prim_w_arity(file_identity, "file-or-directory-identity", 1, 2), env); - scheme_add_global_constant("file-size", + scheme_addto_prim_instance("file-size", scheme_make_prim_w_arity(file_size, "file-size", 1, 1), env); - scheme_add_global_constant("current-drive", + scheme_addto_prim_instance("current-drive", scheme_make_prim_w_arity(current_drive, "current-drive", 0, 0), env); - scheme_add_global_constant("find-system-path", + scheme_addto_prim_instance("find-system-path", scheme_make_prim_w_arity(find_system_path, "find-system-path", 1, 1), env); - scheme_add_global_constant("current-directory", + scheme_addto_prim_instance("current-directory", scheme_register_parameter(current_directory, "current-directory", MZCONFIG_CURRENT_DIRECTORY), env); - scheme_add_global_constant("current-directory-for-user", + scheme_addto_prim_instance("current-directory-for-user", scheme_register_parameter(current_user_directory, "current-directory-for-user", MZCONFIG_CURRENT_USER_DIRECTORY), env); - scheme_add_global_constant("current-force-delete-permissions", + scheme_addto_prim_instance("current-force-delete-permissions", scheme_register_parameter(current_force_delete_perms, "current-force-delete-permissions", MZCONFIG_FORCE_DELETE_PERMS), env); - - scheme_add_global_constant("current-library-collection-paths", - scheme_register_parameter(current_library_collection_paths, - "current-library-collection-paths", - MZCONFIG_COLLECTION_PATHS), - env); - scheme_add_global_constant("current-library-collection-links", - scheme_register_parameter(current_library_collection_links, - "current-library-collection-links", - MZCONFIG_COLLECTION_LINKS), - env); - scheme_add_global_constant("use-compiled-file-paths", - scheme_register_parameter(use_compiled_kind, - "use-compiled-file-paths", - MZCONFIG_USE_COMPILED_KIND), - env); - scheme_add_global_constant("current-compiled-file-roots", - scheme_register_parameter(compiled_file_roots, - "current-compiled-file-roots", - MZCONFIG_USE_COMPILED_ROOTS), - env); - scheme_add_global_constant("use-user-specific-search-paths", - scheme_register_parameter(use_user_paths, - "use-user-specific-search-paths", - MZCONFIG_USE_USER_PATHS), - env); - scheme_add_global_constant("use-collection-link-paths", - scheme_register_parameter(use_link_paths, - "use-collection-link-paths", - MZCONFIG_USE_LINK_PATHS), - env); - scheme_add_global_constant("use-compiled-file-check", - scheme_register_parameter(use_compiled_file_check, - "use-compiled-file-check", - MZCONFIG_USE_COMPILED_FILE_CHECK), - env); } void scheme_init_file_places() @@ -5008,240 +4960,6 @@ static Scheme_Object *current_force_delete_perms(int argc, Scheme_Object *argv[] argc, argv, -1, NULL, NULL, 1); } -static Scheme_Object *check_link_key_val(Scheme_Object *key, Scheme_Object *val) -{ - Scheme_Object *new_val = scheme_null, *a; - - if (!SCHEME_FALSEP(key) - && (!SCHEME_SYMBOLP(key) - || !scheme_is_module_path(key))) - return NULL; - - while (SCHEME_PAIRP(val)) { - a = SCHEME_CAR(val); - if (!SCHEME_PATH_STRINGP(a)) - return NULL; - a = TO_PATH(a); - if (!scheme_is_complete_path(SCHEME_PATH_VAL(a), - SCHEME_PATH_LEN(a), - SCHEME_PLATFORM_PATH_KIND)) - return NULL; - new_val = scheme_make_pair(a, new_val); - val = SCHEME_CDR(val); - } - - if (!SCHEME_NULLP(val)) - return NULL; - - return scheme_reverse(new_val); -} - -static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok, int abs_ok, int sym_ok, int links_ok) -{ - Scheme_Object *v = argv[0]; - Scheme_Object *new_hts = scheme_null; - - if (scheme_proper_list_length(v) < 0) - return NULL; - - if (SCHEME_NULLP(v)) - return v; - - while (SCHEME_PAIRP(v)) { - Scheme_Object *s; - s = SCHEME_CAR(v); - if (sym_ok && SAME_OBJ(s, same_symbol)) { - /* ok */ - } else if (links_ok && SCHEME_FALSEP(s)) { - /* ok */ - } else if (links_ok && (SCHEME_CHAPERONE_HASHTP(s) - || SCHEME_CHAPERONE_HASHTRP(s) - || SCHEME_CHAPERONE_BUCKTP(s))) { - Scheme_Hash_Tree *new_ht; - Scheme_Object *key, *val, *idx, *a[2]; - - new_ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - a[0] = s; - idx = scheme_hash_table_iterate_start(1, a); - while (SCHEME_TRUEP(idx)) { - a[0] = s; - a[1] = idx; - key = scheme_hash_table_iterate_key(2, a); - - val = scheme_chaperone_hash_get(s, key); - if (val) { - val = check_link_key_val(key, val); - if (!val) return NULL; - new_ht = scheme_hash_tree_set(new_ht, key, val); - } - - a[0] = s; - a[1] = idx; - idx = scheme_hash_table_iterate_next(2, a); - } - - new_hts = scheme_make_pair((Scheme_Object *)new_ht, new_hts); - } else { - if (!SCHEME_PATH_STRINGP(s)) - return NULL; - s = TO_PATH(s); - if (!abs_ok && !scheme_is_relative_path(SCHEME_PATH_VAL(s), - SCHEME_PATH_LEN(s), - SCHEME_PLATFORM_PATH_KIND)) - return NULL; - if (!rel_ok && !scheme_is_complete_path(SCHEME_PATH_VAL(s), - SCHEME_PATH_LEN(s), - SCHEME_PLATFORM_PATH_KIND)) - return NULL; - } - v = SCHEME_CDR(v); - } - - if (!SCHEME_NULLP(v)) - return NULL; - - new_hts = scheme_reverse(new_hts); - - /* Convert to list of paths: */ - { - Scheme_Object *last = NULL, *first = NULL, *p, *s; - v = argv[0]; - while (SCHEME_PAIRP(v)) { - s = SCHEME_CAR(v); - if (SCHEME_SYMBOLP(s)) { - /* ok */ - } else if (SCHEME_FALSEP(s)) { - /* ok */ - } else if (SCHEME_PATH_STRINGP(s)) { - s = TO_PATH(s); - } else { - s = SCHEME_CAR(new_hts); - new_hts = SCHEME_CDR(new_hts); - } - - p = scheme_make_pair(s, scheme_null); - if (!first) - first = p; - else - SCHEME_CDR(last) = p; - last = p; - - v = SCHEME_CDR(v); - } - - return first; - } -} - -static Scheme_Object *collpaths_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 0, 1, 0, 0); -} - -Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]) { - return current_library_collection_paths(argc, argv); -} - -static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-library-collection-paths", - scheme_make_integer(MZCONFIG_COLLECTION_PATHS), - argc, argv, - -1, collpaths_p, "(listof (and/c path-string? complete-path?))", 1); -} - -static Scheme_Object *colllinks_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 0, 1, 0, 1); -} - -Scheme_Object *scheme_current_library_collection_links(int argc, Scheme_Object *argv[]) { - return current_library_collection_links(argc, argv); -} - -static Scheme_Object *current_library_collection_links(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-library-collection-links", - scheme_make_integer(MZCONFIG_COLLECTION_LINKS), - argc, argv, - -1, colllinks_p, - "(listof (or/c #f (and/c path-string? complete-path?)" - /**/ " (hash/c (or/c (and/c symbol? module-path?) #f)" - /**/ " (listof (and/c path-string? complete-path?)))))", - 1); -} - -static Scheme_Object *compiled_kind_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 1, 0, 0, 0); -} - -static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("use-compiled-file-paths", - scheme_make_integer(MZCONFIG_USE_COMPILED_KIND), - argc, argv, - -1, compiled_kind_p, "(listof (and/c path-string? relative-path?))", 1); -} - -static Scheme_Object *compiled_roots_p(int argc, Scheme_Object **argv) -{ - return collpaths_gen_p(argc, argv, 1, 1, 1, 0); -} - -Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]) -{ - return compiled_file_roots(argc, argv); -} - -static Scheme_Object *compiled_file_roots(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-compiled-file-roots", - scheme_make_integer(MZCONFIG_USE_COMPILED_ROOTS), - argc, argv, - -1, compiled_roots_p, "(listof (or/c path-string? 'same))", 1); -} - -static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("use-user-specific-search-paths", - scheme_make_integer(MZCONFIG_USE_USER_PATHS), - argc, argv, - -1, NULL, NULL, 1); -} - -static Scheme_Object *use_link_paths(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("use-collection-link-paths", - scheme_make_integer(MZCONFIG_USE_LINK_PATHS), - argc, argv, - -1, NULL, NULL, 1); -} - -static Scheme_Object *compiled_file_check_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v = argv[0]; - - if (SCHEME_SYMBOLP(v) - && !SCHEME_SYM_WEIRDP(v) - && (((SCHEME_SYM_LEN(v) == 14) - && !strcmp(SCHEME_SYM_VAL(v), "modify-seconds")) - || ((SCHEME_SYM_LEN(v) == 6) - && !strcmp(SCHEME_SYM_VAL(v), "exists")))) - return v; - - return NULL; -} - -static Scheme_Object *use_compiled_file_check(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("use-compiled-file-check", - scheme_make_integer(MZCONFIG_USE_COMPILED_FILE_CHECK), - argc, argv, - -1, compiled_file_check_p, "(or/c 'modify-seconds 'exists)", 0); -} - /********************************************************************************/ Scheme_Object *scheme_get_run_cmd(void) @@ -5307,10 +5025,10 @@ find_system_path(int argc, Scheme_Object **argv) } else { scheme_wrong_contract("find-system-path", "(or/c 'home-dir 'pref-dir 'pref-file 'temp-dir\n" - " 'init-dir 'init-file 'addon-dir\n" - " 'doc-dir 'desk-dir 'sys-dir 'exec-file 'run-file\n" - " 'collects-dir 'config-dir 'orig-dir\n" - " 'host-collects-dir 'host-config-dir)", + " 'init-dir 'init-file 'addon-dir\n" + " 'doc-dir 'desk-dir 'sys-dir 'exec-file 'run-file\n" + " 'collects-dir 'config-dir 'orig-dir\n" + " 'host-collects-dir 'host-config-dir)", 0, argc, argv); return NULL; } diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 07ebba620f..a74ec23c5d 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -30,7 +30,6 @@ overflow and continuation-jump limits. */ #include "schpriv.h" -#include "schexpobs.h" #include "schmach.h" #include "schrktio.h" @@ -82,6 +81,7 @@ READ_ONLY static Scheme_Object *call_with_prompt_proc; READ_ONLY static Scheme_Object *abort_continuation_proc; READ_ONLY static Scheme_Object *internal_call_cc_prim; READ_ONLY static Scheme_Object *finish_call_cc_prim; +READ_ONLY static Scheme_Object *propagate_abort_prim; /* Caches need to be thread-local: */ THREAD_LOCAL_DECL(static Scheme_Prompt *available_prompt); @@ -105,6 +105,7 @@ static Scheme_Object *ormap (int argc, Scheme_Object *argv[]); static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]); static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]); static Scheme_Object *finish_call_cc (int argc, Scheme_Object *argv[]); +static Scheme_Object *propagate_abort (int argc, Scheme_Object *argv[]); static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[]); static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]); static Scheme_Object *call_with_prompt (int argc, Scheme_Object *argv[]); @@ -207,7 +208,7 @@ typedef struct Scheme_Dynamic_Wind_List { /*========================================================================*/ void -scheme_init_fun (Scheme_Env *env) +scheme_init_fun (Scheme_Startup_Env *env) { Scheme_Object *o; @@ -228,8 +229,9 @@ scheme_init_fun (Scheme_Env *env) o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("procedure?", o, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("procedure?", o, env); scheme_procedure_p_proc = o; @@ -238,34 +240,30 @@ scheme_init_fun (Scheme_Env *env) "apply", 2, -1, 0, -1); - scheme_add_global_constant("apply", scheme_apply_proc, env); - scheme_add_global_constant("map", - scheme_make_noncm_prim(map, - "map", - 2, -1), - env); - scheme_add_global_constant("for-each", - scheme_make_noncm_prim(for_each, - "for-each", - 2, -1), - env); - scheme_add_global_constant("andmap", - scheme_make_prim_w_arity(andmap, - "andmap", - 2, -1), - env); - scheme_add_global_constant("ormap", - scheme_make_prim_w_arity(ormap, - "ormap", - 2, -1), - env); + scheme_addto_prim_instance("apply", scheme_apply_proc, env); + + o = scheme_make_noncm_prim(map, "map", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("map", o, env); + + o = scheme_make_noncm_prim(for_each, "for-each", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("for-each", o, env); + + o = scheme_make_prim_w_arity(andmap, "andmap", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("andmap", o, env); + + o = scheme_make_prim_w_arity(ormap, "ormap", 2, -1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("ormap", o, env); REGISTER_SO(scheme_call_with_values_proc); scheme_call_with_values_proc = scheme_make_prim_w_arity2(call_with_values, "call-with-values", 2, 2, 0, -1); - scheme_add_global_constant("call-with-values", + scheme_addto_prim_instance("call-with-values", scheme_call_with_values_proc, env); @@ -278,7 +276,7 @@ scheme_init_fun (Scheme_Env *env) | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("values", + scheme_addto_prim_instance("values", scheme_values_proc, env); @@ -286,7 +284,7 @@ scheme_init_fun (Scheme_Env *env) "call-with-escape-continuation", 1, 1, 0, -1); - scheme_add_global_constant("call-with-escape-continuation", o, env); + scheme_addto_prim_instance("call-with-escape-continuation", o, env); REGISTER_SO(internal_call_cc_prim); internal_call_cc_prim = scheme_make_prim_w_arity2(internal_call_cc, @@ -298,6 +296,8 @@ scheme_init_fun (Scheme_Env *env) "finish-call-with-current-continuation", 2, 2, 0, -1); + REGISTER_SO(propagate_abort_prim); + propagate_abort_prim = scheme_make_prim_w_arity(propagate_abort, "propagate-abort", 0, -1); # define MAX_CALL_CC_ARG_COUNT 2 o = scheme_make_prim_w_arity2(call_cc, @@ -305,15 +305,15 @@ scheme_init_fun (Scheme_Env *env) 1, MAX_CALL_CC_ARG_COUNT, 0, -1); - scheme_add_global_constant("call-with-current-continuation", o, env); + scheme_addto_prim_instance("call-with-current-continuation", o, env); - scheme_add_global_constant("continuation?", + scheme_addto_prim_instance("continuation?", scheme_make_folding_prim(continuation_p, "continuation?", 1, 1, 1), env); - scheme_add_global_constant("call-with-continuation-barrier", + scheme_addto_prim_instance("call-with-continuation-barrier", scheme_make_prim_w_arity2(call_with_continuation_barrier, "call-with-continuation-barrier", 1, 1, @@ -325,11 +325,11 @@ scheme_init_fun (Scheme_Env *env) "call-with-continuation-prompt", 1, -1, 0, -1); - scheme_add_global_constant("call-with-continuation-prompt", + scheme_addto_prim_instance("call-with-continuation-prompt", call_with_prompt_proc, env); - scheme_add_global_constant("call-with-composable-continuation", + scheme_addto_prim_instance("call-with-composable-continuation", scheme_make_prim_w_arity2(call_with_control, "call-with-composable-continuation", 1, 2, @@ -340,93 +340,93 @@ scheme_init_fun (Scheme_Env *env) abort_continuation_proc = scheme_make_prim_w_arity(abort_continuation, "abort-current-continuation", 1, -1); - scheme_add_global_constant("abort-current-continuation", + scheme_addto_prim_instance("abort-current-continuation", abort_continuation_proc, env); - scheme_add_global_constant("continuation-prompt-available?", + scheme_addto_prim_instance("continuation-prompt-available?", scheme_make_prim_w_arity(continuation_prompt_available, "continuation-prompt-available?", 1, 2), env); - scheme_add_global_constant("make-continuation-prompt-tag", + scheme_addto_prim_instance("make-continuation-prompt-tag", scheme_make_prim_w_arity(make_prompt_tag, "make-continuation-prompt-tag", 0, 1), env); - scheme_add_global_constant("default-continuation-prompt-tag", + scheme_addto_prim_instance("default-continuation-prompt-tag", scheme_make_prim_w_arity(get_default_prompt_tag, "default-continuation-prompt-tag", 0, 0), env); - scheme_add_global_constant("continuation-prompt-tag?", + scheme_addto_prim_instance("continuation-prompt-tag?", scheme_make_folding_prim(prompt_tag_p, "continuation-prompt-tag?", 1, 1, 1), env); - scheme_add_global_constant("impersonate-prompt-tag", + scheme_addto_prim_instance("impersonate-prompt-tag", scheme_make_prim_w_arity(impersonate_prompt_tag, "impersonate-prompt-tag", 3, -1), env); - scheme_add_global_constant("chaperone-prompt-tag", + scheme_addto_prim_instance("chaperone-prompt-tag", scheme_make_prim_w_arity(chaperone_prompt_tag, "chaperone-prompt-tag", 3, -1), env); - scheme_add_global_constant("call-with-semaphore", + scheme_addto_prim_instance("call-with-semaphore", scheme_make_prim_w_arity2(call_with_sema, "call-with-semaphore", 2, -1, 0, -1), env); - scheme_add_global_constant("call-with-semaphore/enable-break", + scheme_addto_prim_instance("call-with-semaphore/enable-break", scheme_make_prim_w_arity2(call_with_sema_enable_break, "call-with-semaphore/enable-break", 2, -1, 0, -1), env); - scheme_add_global_constant("make-continuation-mark-key", + scheme_addto_prim_instance("make-continuation-mark-key", scheme_make_prim_w_arity(make_continuation_mark_key, "make-continuation-mark-key", 0, 1), env); - scheme_add_global_constant("continuation-mark-key?", + scheme_addto_prim_instance("continuation-mark-key?", scheme_make_prim_w_arity(continuation_mark_key_p, "continuation-mark-key?", 1, 1), env); - scheme_add_global_constant("impersonate-continuation-mark-key", + scheme_addto_prim_instance("impersonate-continuation-mark-key", scheme_make_prim_w_arity(impersonate_continuation_mark_key, "impersonate-continuation-mark-key", 3, -1), env); - scheme_add_global_constant("chaperone-continuation-mark-key", + scheme_addto_prim_instance("chaperone-continuation-mark-key", scheme_make_prim_w_arity(chaperone_continuation_mark_key, "chaperone-continuation-mark-key", 3, -1), env); - scheme_add_global_constant("current-continuation-marks", + scheme_addto_prim_instance("current-continuation-marks", scheme_make_prim_w_arity(cc_marks, "current-continuation-marks", 0, 1), env); - scheme_add_global_constant("continuation-marks", + scheme_addto_prim_instance("continuation-marks", scheme_make_prim_w_arity(cont_marks, "continuation-marks", 1, 2), env); - scheme_add_global_constant("continuation-mark-set->list", + scheme_addto_prim_instance("continuation-mark-set->list", scheme_make_prim_w_arity(extract_cc_marks, "continuation-mark-set->list", 2, 3), env); - scheme_add_global_constant("continuation-mark-set->list*", + scheme_addto_prim_instance("continuation-mark-set->list*", scheme_make_prim_w_arity(extract_cc_markses, "continuation-mark-set->list*", 2, 4), @@ -436,22 +436,22 @@ scheme_init_fun (Scheme_Env *env) "continuation-mark-set-first", 2, 4); SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("continuation-mark-set-first", o, env); + scheme_addto_prim_instance("continuation-mark-set-first", o, env); REGISTER_SO(scheme_call_with_immed_mark_proc); scheme_call_with_immed_mark_proc = scheme_make_prim_w_arity2(call_with_immediate_cc_mark, "call-with-immediate-continuation-mark", 2, 3, 0, -1); - scheme_add_global_constant("call-with-immediate-continuation-mark", + scheme_addto_prim_instance("call-with-immediate-continuation-mark", scheme_call_with_immed_mark_proc, env); - scheme_add_global_constant("continuation-mark-set?", + scheme_addto_prim_instance("continuation-mark-set?", scheme_make_prim_w_arity(cc_marks_p, "continuation-mark-set?", 1, 1), env); - scheme_add_global_constant("continuation-mark-set->context", + scheme_addto_prim_instance("continuation-mark-set->context", scheme_make_prim_w_arity(extract_cc_proc_marks, "continuation-mark-set->context", 1, 1), @@ -462,70 +462,71 @@ scheme_init_fun (Scheme_Env *env) "void", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(scheme_void_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("void", scheme_void_proc, env); + scheme_addto_prim_instance("void", scheme_void_proc, env); REGISTER_SO(scheme_void_p_proc); scheme_void_p_proc = scheme_make_folding_prim(void_p, "void?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(scheme_void_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("void?", scheme_void_p_proc, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("void?", scheme_void_p_proc, env); - scheme_add_global_constant("time-apply", + scheme_addto_prim_instance("time-apply", scheme_make_prim_w_arity2(time_apply, "time-apply", 2, 2, 4, 4), env); - scheme_add_global_constant("current-milliseconds", + scheme_addto_prim_instance("current-milliseconds", scheme_make_immed_prim(current_milliseconds, "current-milliseconds", 0, 0), env); - scheme_add_global_constant("current-inexact-milliseconds", + scheme_addto_prim_instance("current-inexact-milliseconds", scheme_make_immed_prim(current_inexact_milliseconds, "current-inexact-milliseconds", 0, 0), env); - scheme_add_global_constant("current-process-milliseconds", + scheme_addto_prim_instance("current-process-milliseconds", scheme_make_immed_prim(current_process_milliseconds, "current-process-milliseconds", 0, 1), env); - scheme_add_global_constant("current-gc-milliseconds", + scheme_addto_prim_instance("current-gc-milliseconds", scheme_make_immed_prim(current_gc_milliseconds, "current-gc-milliseconds", 0, 0), env); - scheme_add_global_constant("current-seconds", + scheme_addto_prim_instance("current-seconds", scheme_make_immed_prim(current_seconds, "current-seconds", 0, 0), env); - scheme_add_global_constant("seconds->date", + scheme_addto_prim_instance("seconds->date", scheme_make_immed_prim(seconds_to_date, "seconds->date", 1, 2), env); - scheme_add_global_constant("dynamic-wind", + scheme_addto_prim_instance("dynamic-wind", scheme_make_prim_w_arity(dynamic_wind, "dynamic-wind", 3, 3), env); - scheme_add_global_constant("object-name", + scheme_addto_prim_instance("object-name", scheme_make_folding_prim(object_name, "object-name", 1, 1, 1), env); - scheme_add_global_constant("procedure-arity", + scheme_addto_prim_instance("procedure-arity", scheme_make_folding_prim(procedure_arity, "procedure-arity", 1, 1, 1), env); - scheme_add_global_constant("procedure-arity?", + scheme_addto_prim_instance("procedure-arity?", scheme_make_folding_prim(procedure_arity_p, "procedure-arity?", 1, 1, 1), @@ -534,98 +535,102 @@ scheme_init_fun (Scheme_Env *env) o = scheme_make_folding_prim(scheme_procedure_arity_includes, "procedure-arity-includes?", 2, 3, 1); - SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); scheme_procedure_arity_includes_proc = o; - scheme_add_global_constant("procedure-arity-includes?", o, env); + scheme_addto_prim_instance("procedure-arity-includes?", o, env); - scheme_add_global_constant("procedure-reduce-arity", + scheme_addto_prim_instance("procedure-reduce-arity", scheme_make_prim_w_arity(procedure_reduce_arity, "procedure-reduce-arity", 2, 2), env); - scheme_add_global_constant("procedure-rename", + scheme_addto_prim_instance("procedure-rename", scheme_make_prim_w_arity(procedure_rename, "procedure-rename", 2, 2), env); - scheme_add_global_constant("procedure->method", + scheme_addto_prim_instance("procedure->method", scheme_make_prim_w_arity(procedure_to_method, "procedure->method", 1, 1), env); - scheme_add_global_constant("procedure-closure-contents-eq?", - scheme_make_folding_prim(procedure_equal_closure_p, - "procedure-closure-contents-eq?", - 2, 2, 1), - env); + + o = scheme_make_folding_prim(procedure_equal_closure_p, + "procedure-closure-contents-eq?", + 2, 2, 1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("procedure-closure-contents-eq?", o, env); REGISTER_SO(scheme_procedure_specialize_proc); o = scheme_make_prim_w_arity(procedure_specialize, "procedure-specialize", 1, 1); scheme_procedure_specialize_proc = o; - scheme_add_global_constant("procedure-specialize", o, env); + scheme_addto_prim_instance("procedure-specialize", o, env); - scheme_add_global_constant("chaperone-procedure", + scheme_addto_prim_instance("chaperone-procedure", scheme_make_prim_w_arity(chaperone_procedure, "chaperone-procedure", 2, -1), env); - scheme_add_global_constant("impersonate-procedure", + scheme_addto_prim_instance("impersonate-procedure", scheme_make_prim_w_arity(impersonate_procedure, "impersonate-procedure", 2, -1), env); - scheme_add_global_constant("chaperone-procedure*", + scheme_addto_prim_instance("chaperone-procedure*", scheme_make_prim_w_arity(chaperone_procedure_star, "chaperone-procedure*", 2, -1), env); - scheme_add_global_constant("impersonate-procedure*", + scheme_addto_prim_instance("impersonate-procedure*", scheme_make_prim_w_arity(impersonate_procedure_star, "impersonate-procedure*", 2, -1), env); - scheme_add_global_constant("primitive?", + scheme_addto_prim_instance("primitive?", scheme_make_folding_prim(primitive_p, "primitive?", 1, 1, 1), env); - scheme_add_global_constant("primitive-closure?", + scheme_addto_prim_instance("primitive-closure?", scheme_make_folding_prim(primitive_closure_p, "primitive-closure?", 1, 1, 1), env); - scheme_add_global_constant("primitive-result-arity", + scheme_addto_prim_instance("primitive-result-arity", scheme_make_folding_prim(primitive_result_arity, "primitive-result-arity", 1, 1, 1), env); - scheme_add_global_constant("procedure-result-arity", + scheme_addto_prim_instance("procedure-result-arity", scheme_make_folding_prim(procedure_result_arity, "procedure-result-arity", 1, 1, 1), env); - scheme_add_global_constant("current-print", + scheme_addto_prim_instance("current-print", scheme_register_parameter(current_print, "current-print", MZCONFIG_PRINT_HANDLER), env); - scheme_add_global_constant("current-prompt-read", + scheme_addto_prim_instance("current-prompt-read", scheme_register_parameter(current_prompt_read, "current-prompt-read", MZCONFIG_PROMPT_READ_HANDLER), env); - scheme_add_global_constant("current-read-interaction", + scheme_addto_prim_instance("current-read-interaction", scheme_register_parameter(current_read, "current-read-interaction", MZCONFIG_READ_HANDLER), env); - scheme_add_global_constant("current-get-interaction-input-port", + scheme_addto_prim_instance("current-get-interaction-input-port", scheme_register_parameter(current_get_read_input_port, "current-get-interaction-input-port", MZCONFIG_READ_INPUT_PORT_HANDLER), @@ -674,7 +679,7 @@ scheme_init_fun (Scheme_Env *env) } void -scheme_init_unsafe_fun (Scheme_Env *env) +scheme_init_unsafe_fun (Scheme_Startup_Env *env) { Scheme_Object *o; @@ -683,37 +688,37 @@ scheme_init_unsafe_fun (Scheme_Env *env) scheme_check_not_undefined_proc = o; SCHEME_PRIM_PROC_FLAGS(o) |= (SCHEME_PRIM_OPT_IMMEDIATE | scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED)); - scheme_add_global_constant("check-not-unsafe-undefined", o, env); + scheme_addto_prim_instance("check-not-unsafe-undefined", o, env); REGISTER_SO(scheme_check_assign_not_undefined_proc); o = scheme_make_prim_w_arity(scheme_check_assign_not_undefined, "check-not-unsafe-undefined/assign", 2, 2); scheme_check_assign_not_undefined_proc = o; SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("check-not-unsafe-undefined/assign", o, env); + scheme_addto_prim_instance("check-not-unsafe-undefined/assign", o, env); - scheme_add_global_constant("unsafe-undefined", scheme_undefined, env); + scheme_addto_prim_instance("unsafe-undefined", scheme_undefined, env); REGISTER_SO(scheme_chaperone_undefined_property); o = scheme_make_struct_type_property(scheme_intern_symbol("chaperone-unsafe-undefined")); scheme_chaperone_undefined_property = o; - scheme_add_global_constant("prop:chaperone-unsafe-undefined", o, env); + scheme_addto_prim_instance("prop:chaperone-unsafe-undefined", o, env); o = scheme_make_prim_w_arity(chaperone_unsafe_undefined, "chaperone-struct-unsafe-undefined", 1, 1); - scheme_add_global_constant("chaperone-struct-unsafe-undefined", o, env); + scheme_addto_prim_instance("chaperone-struct-unsafe-undefined", o, env); - scheme_add_global_constant("unsafe-chaperone-procedure", + scheme_addto_prim_instance("unsafe-chaperone-procedure", scheme_make_prim_w_arity(unsafe_chaperone_procedure, "unsafe-chaperone-procedure", 2, -1), env); - scheme_add_global_constant("unsafe-impersonate-procedure", + scheme_addto_prim_instance("unsafe-impersonate-procedure", scheme_make_prim_w_arity(unsafe_impersonate_procedure, "unsafe-impersonate-procedure", 2, -1), env); - GLOBAL_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env); } void @@ -744,7 +749,7 @@ make_prim_closure(Scheme_Prim *fun, int eternal, { Scheme_Primitive_Proc *prim; int hasr, size; - + hasr = ((minr != 1) || (maxr != 1)); size = (hasr ? sizeof(Scheme_Prim_W_Result_Arity) @@ -827,7 +832,8 @@ scheme_make_noncm_prim(Scheme_Prim *fun, const char *name, { /* A non-cm primitive leaves the mark stack unchanged when it returns, it can't return multiple values or a tail call, and it cannot - use its third argument (i.e., the closure pointer). */ + use its third argument (i.e., the closure pointer) unless + SCHEME_PRIM_IS_CLOSURE is also set. */ return make_prim_closure(fun, 1, name, mina, maxa, SCHEME_PRIM_OPT_NONCM, 1, 1, @@ -1137,38 +1143,6 @@ static Scheme_Prompt *allocate_prompt(Scheme_Prompt **cached_prompt) { return prompt; } -static void save_dynamic_state(Scheme_Thread *thread, Scheme_Dynamic_State *state) { - state->current_local_env = thread->current_local_env; - state->scope = thread->current_local_scope; - state->use_scope = thread->current_local_use_scope; - state->name = thread->current_local_name; - state->modidx = thread->current_local_modidx; - state->menv = thread->current_local_menv; -} - -static void restore_dynamic_state(Scheme_Dynamic_State *state, Scheme_Thread *thread) { - thread->current_local_env = state->current_local_env; - thread->current_local_scope = state->scope; - thread->current_local_use_scope = state->use_scope; - thread->current_local_name = state->name; - thread->current_local_modidx = state->modidx; - thread->current_local_menv = state->menv; -} - -void scheme_set_dynamic_state(Scheme_Dynamic_State *state, Scheme_Comp_Env *env, - Scheme_Object *scope, Scheme_Object *use_scope, - Scheme_Object *name, - Scheme_Env *menv, - Scheme_Object *modidx) -{ - state->current_local_env = env; - state->scope = scope; - state->use_scope = use_scope; - state->name = name; - state->modidx = modidx; - state->menv = menv; -} - static void *apply_again_k(void) { Scheme_Thread *p = scheme_current_thread; @@ -1188,10 +1162,10 @@ static void *apply_again_k(void) } void *scheme_top_level_do(void *(*k)(void), int eb) { - return scheme_top_level_do_worker(k, eb, 0, NULL); + return scheme_top_level_do_worker(k, eb, 0); } -void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Scheme_Dynamic_State *dyn_state) +void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread) { /* Wraps a function `k' with a handler for stack overflows and barriers to full-continuation jumps. No barrier if !eb. */ @@ -1200,7 +1174,6 @@ void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Schem mz_jmp_buf *save; mz_jmp_buf newbuf; Scheme_Stack_State envss; - Scheme_Dynamic_State save_dyn_state; Scheme_Thread * volatile p = scheme_current_thread; volatile int old_pcc = scheme_prompt_capture_count; Scheme_Cont_Frame_Data cframe; @@ -1237,12 +1210,6 @@ void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Schem while (1) { scheme_save_env_stack_w_thread(envss, p); - save_dynamic_state(p, &save_dyn_state); - - if (dyn_state) { - restore_dynamic_state(dyn_state, p); - dyn_state = NULL; - } if (prompt) { scheme_push_continuation_frame(&cframe); @@ -1286,7 +1253,6 @@ void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Schem } } } - restore_dynamic_state(&save_dyn_state, p); } if (!again) @@ -1313,8 +1279,6 @@ void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread, Schem if (!new_thread) { p = scheme_current_thread; - restore_dynamic_state(&save_dyn_state, p); - p->error_buf = save; } @@ -1380,27 +1344,41 @@ force_values(Scheme_Object *obj, int multi_ok) { if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) { Scheme_Thread *p = scheme_current_thread; - GC_CAN_IGNORE Scheme_Object *rator; + GC_CAN_IGNORE Scheme_Object *rator, *result; GC_CAN_IGNORE Scheme_Object **rands; - + int argc = p->ku.apply.tail_num_rands, popc = 0; + + rands = p->ku.apply.tail_rands; + /* Watch out for use of tail buffer: */ - if (p->ku.apply.tail_rands == p->tail_buffer) - scheme_realloc_tail_buffer(p); + if (rands == p->tail_buffer) { + GC_CAN_IGNORE Scheme_Object **runstack = MZ_RUNSTACK; + if (((runstack - MZ_RUNSTACK_START) - argc) > SCHEME_TAIL_COPY_THRESHOLD) { + /* There's room on the runstack; use that instead of allocating a new buffer */ + runstack -= argc; + memcpy(runstack, rands, argc * sizeof(Scheme_Object *)); + rands = runstack; + popc = argc; + MZ_RUNSTACK = rands; + } else { + scheme_realloc_tail_buffer(p); + rands = p->ku.apply.tail_rands; + } + } rator = p->ku.apply.tail_rator; - rands = p->ku.apply.tail_rands; p->ku.apply.tail_rator = NULL; p->ku.apply.tail_rands = NULL; - if (multi_ok) { - return _scheme_apply_multi(rator, - p->ku.apply.tail_num_rands, - rands); - } else { - return _scheme_apply(rator, - p->ku.apply.tail_num_rands, - rands); - } + if (multi_ok) + result = _scheme_apply_multi(rator, argc, rands); + else + result = _scheme_apply(rator, argc, rands); + + if (popc) + MZ_RUNSTACK += popc; + + return result; } else if (SAME_OBJ(obj, SCHEME_EVAL_WAITING)) { Scheme_Thread *p = scheme_current_thread; if (multi_ok) @@ -1516,33 +1494,7 @@ scheme_apply_thread_thunk(Scheme_Object *rator) p->ku.k.i1 = 0; p->ku.k.i2 = 1; - return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 1, NULL); -} - -Scheme_Object * -scheme_apply_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = rator; - p->ku.k.p2 = rands; - p->ku.k.i1 = num_rands; - p->ku.k.i2 = 0; - - return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 0, dyn_state); -} - -Scheme_Object * -scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state) -{ - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = rator; - p->ku.k.p2 = rands; - p->ku.k.i1 = num_rands; - p->ku.k.i2 = 1; - - return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 0, dyn_state); + return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 1); } Scheme_Object * @@ -1730,302 +1682,6 @@ _scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands) return X_scheme_apply_to_list(rator, rands, 0, 0); } -static Scheme_Object *cert_with_specials_k(void); - -static Scheme_Object * -cert_with_specials(Scheme_Object *code, - Scheme_Object *insp, - Scheme_Object *old_stx, - intptr_t phase, - int deflt, int cadr_deflt) -/* Arms (insp) or re-arms (old_stx) taints. */ -{ - Scheme_Object *prop; - int next_cadr_deflt = 0, phase_delta = 0; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - Scheme_Object **args; - args = MALLOC_N(Scheme_Object*, 3); - args[0] = code; - args[1] = insp; - args[2] = old_stx; - p->ku.k.p1 = (void *)args; - p->ku.k.i1 = phase; - p->ku.k.i2 = deflt; - p->ku.k.i3 = cadr_deflt; - return scheme_handle_stack_overflow(cert_with_specials_k); - } - } -#endif - - if (SCHEME_STXP(code)) { - if (scheme_stx_is_tainted(code)) - /* nothing happens to already-tainted syntax objects */ - return code; - - prop = scheme_stx_property(code, taint_mode_symbol, NULL); - if (SCHEME_FALSEP(prop)) - prop = scheme_stx_property(code, certify_mode_symbol, NULL); - if (SAME_OBJ(prop, none_symbol)) - return code; - else if (SAME_OBJ(prop, opaque_symbol)) { - if (old_stx) - return scheme_stx_taint_rearm(code, old_stx); - else - return scheme_stx_taint_arm(code, insp); - } else if (SAME_OBJ(prop, transparent_symbol)) { - cadr_deflt = 0; - /* fall through */ - } else if (SAME_OBJ(prop, transparent_binding_symbol)) { - cadr_deflt = 0; - next_cadr_deflt = 1; - /* fall through */ - } else { - /* Default transparency depends on module-identifier=? comparison - to `begin', `define-values', and `define-syntaxes'. */ - int trans = deflt; - if (SCHEME_TRUEP(prop)) - scheme_log(NULL, - SCHEME_LOG_WARNING, - 0, - "warning: unrecognized 'taint-mode property value: %V", - prop); - if (SCHEME_STX_PAIRP(code)) { - Scheme_Object *name; - /* name = SCHEME_STX_CAR(code); */ - name = scheme_stx_taint_disarm(code, NULL); - name = SCHEME_STX_CAR(name); - if (SCHEME_STX_SYMBOLP(name)) { - if (scheme_stx_free_eq_x(scheme_begin_stx, name, phase) - || scheme_stx_free_eq_x(scheme_module_begin_stx, name, phase)) { - trans = 1; - next_cadr_deflt = 0; - } else if (scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, name, phase)) { - trans = 1; - next_cadr_deflt = 0; - phase_delta = 1; - } else if (scheme_stx_free_eq_x(scheme_define_values_stx, name, phase) - || scheme_stx_free_eq_x(scheme_define_syntaxes_stx, name, phase)) { - trans = 1; - next_cadr_deflt = 1; - } - } - } - - if (!trans) { - if (old_stx) - return scheme_stx_taint_rearm(code, old_stx); - else - return scheme_stx_taint_arm(code, insp); - } - } - } - - if (SCHEME_STX_PAIRP(code)) { - Scheme_Object *a, *d, *v; - - a = SCHEME_STX_CAR(code); - a = cert_with_specials(a, insp, old_stx, phase + phase_delta, cadr_deflt, 0); - d = SCHEME_STX_CDR(code); - d = cert_with_specials(d, insp, old_stx, phase + phase_delta, 1, next_cadr_deflt); - - v = scheme_make_pair(a, d); - - if (SCHEME_PAIRP(code)) - return v; - - v = scheme_datum_to_syntax(v, code, scheme_false, 0, 1); - - if (scheme_syntax_is_original(v) - && !scheme_syntax_is_original(code)) { - /* Since we copied properties without scopes, we need to - explicitly remove originalness */ - v = scheme_syntax_remove_original(v); - } - - return v; - } else if (SCHEME_STX_NULLP(code)) - return code; - - if (old_stx) - return scheme_stx_taint_rearm(code, old_stx); - else - return scheme_stx_taint_arm(code, insp); -} - -static Scheme_Object *cert_with_specials_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object **args = (Scheme_Object **)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - return cert_with_specials(args[0], args[1], args[2], - p->ku.k.i1, - p->ku.k.i2, p->ku.k.i3); -} - -Scheme_Object * -scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, - Scheme_Object *rator, Scheme_Object *code, - Scheme_Comp_Env *env, Scheme_Object *boundname, - Scheme_Compile_Expand_Info *rec, int drec, - int for_set, - int scope_macro_use) -{ - Scheme_Object *orig_code = code; - - if (scheme_is_rename_transformer(rator)) { - Scheme_Object *scope; - - rator = scheme_rename_transformer_id(rator, env); - /* rator is now an identifier */ - - /* and it's introduced by this expression: */ - scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - rator = scheme_stx_flip_scope(rator, scope, scheme_true); - - if (for_set) { - Scheme_Object *tail, *setkw; - - tail = SCHEME_STX_CDR(code); - setkw = SCHEME_STX_CAR(code); - tail = SCHEME_STX_CDR(tail); - code = scheme_make_pair(setkw, scheme_make_pair(rator, tail)); - code = scheme_datum_to_syntax(code, orig_code, orig_code, 0, 0); - } else if (SCHEME_SYMBOLP(SCHEME_STX_VAL(code))) - code = rator; - else { - code = SCHEME_STX_CDR(code); - code = scheme_make_pair(rator, code); - code = scheme_datum_to_syntax(code, orig_code, scheme_sys_wraps(env), 0, 0); - } - - code = scheme_stx_track(code, orig_code, name); - - /* Restore old dye packs: */ - code = cert_with_specials(code, NULL, orig_code, env->genv->phase, 0, 0); - - return code; - } else { - Scheme_Object *scope, *use_scope, *rands_vec[1], *track_code, *pre_code; - - if (scheme_is_set_transformer(rator)) - rator = scheme_set_transformer_proc(rator); - - { - /* Ensure that source doesn't already have 'taint-mode or 'certify-mode, - in case argument properties are used for result properties. */ - Scheme_Object *prop; - prop = scheme_stx_property(code, taint_mode_symbol, NULL); - if (SCHEME_TRUEP(prop)) - code = scheme_stx_property(code, taint_mode_symbol, scheme_false); - prop = scheme_stx_property(code, certify_mode_symbol, NULL); - if (SCHEME_TRUEP(prop)) - code = scheme_stx_property(code, certify_mode_symbol, scheme_false); - } - track_code = code; /* after mode properties are removed */ - - scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - code = scheme_stx_flip_scope(code, scope, scheme_true); - - if (scope_macro_use) { - use_scope = scheme_new_scope(SCHEME_STX_USE_SITE_SCOPE); - scheme_add_compilation_frame_use_site_scope(env, use_scope); - code = scheme_stx_add_scope(code, use_scope, scheme_true); - } else - use_scope = NULL; - - code = scheme_stx_taint_disarm(code, NULL); - - pre_code = code; - SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(env->observer, code); - - { - Scheme_Dynamic_State dyn_state; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - scheme_prepare_exp_env(env->genv); - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)env->genv->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, env, scope, use_scope, boundname, - menv, menv ? menv->link_midx : env->genv->link_midx); - - rands_vec[0] = code; - code = scheme_apply_with_dynamic_state(rator, 1, rands_vec, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - } - - SCHEME_EXPAND_OBSERVE_MACRO_POST_X(env->observer, code, pre_code); - - if (!SCHEME_STXP(code)) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%S: received value from syntax expander was not syntax\n" - " received: %V", - SCHEME_STX_SYM(name), - code); - } - - code = scheme_stx_flip_scope(code, scope, scheme_true); - - code = scheme_stx_track(code, track_code, name); - - /* Restore old dye packs: */ - code = cert_with_specials(code, NULL, orig_code, env->genv->phase, 0, 0); - - return code; - } -} - -Scheme_Object *scheme_syntax_taint_arm(Scheme_Object *stx, Scheme_Object *insp, int use_mode) -{ - intptr_t phase; - - if (SCHEME_FALSEP(insp)) { - insp = scheme_get_local_inspector(); - } - - if (use_mode) { - Scheme_Thread *p = scheme_current_thread; - phase = (p->current_local_env - ? p->current_local_env->genv->phase - : p->current_phase_shift); - return cert_with_specials(stx, insp, NULL, phase, 0, 0); - } else - return scheme_stx_taint_arm(stx, insp); -} - -Scheme_Object *scheme_syntax_taint_disarm(Scheme_Object *o, Scheme_Object *insp) -{ - if (SCHEME_FALSEP(insp)) { - insp = scheme_get_local_inspector(); - } - - return scheme_stx_taint_disarm(o, insp); -} - -Scheme_Object *scheme_syntax_taint_rearm(Scheme_Object *stx, Scheme_Object *from_stx) -{ - Scheme_Thread *p = scheme_current_thread; - intptr_t phase; - - phase = (p->current_local_env - ? p->current_local_env->genv->phase - : p->current_phase_shift); - - return cert_with_specials(stx, NULL, from_stx, phase, 0, 0); -} - /*========================================================================*/ /* arity */ /*========================================================================*/ @@ -2367,8 +2023,10 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (type == scheme_lambda_type) data = (Scheme_Lambda *)p; - else + else if (type == scheme_closure_type) data = SCHEME_CLOSURE_CODE(p); + else + return scheme_false; mina = maxa = data->num_params; if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) { @@ -2551,7 +2209,7 @@ int scheme_closure_preserves_marks(Scheme_Object *p) return 0; } -Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected) +Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected, int imprecise) /* result is interned --- a symbol or fixnum */ { Scheme_Object *p; @@ -2559,11 +2217,11 @@ Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Obje if (expected && SCHEME_SYMBOLP(expected)) { if (SCHEME_SYM_VAL(expected)[0] == 's') { - return (scheme_check_structure_shape(e, expected) + return (scheme_get_or_check_structure_shape(e, expected) ? expected : NULL); } else if (SCHEME_SYM_VAL(expected)[0] == 'p') { - return (scheme_check_structure_property_shape(e, expected) + return (scheme_get_or_check_structure_property_shape(e, expected) ? expected : NULL); } @@ -2576,7 +2234,9 @@ Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Obje return NULL; p = scheme_get_or_check_arity(e, -3); - + if (SCHEME_FALSEP(p)) + return NULL; + if (SCHEME_PAIRP(p)) { /* encode as a symbol */ int sz = 32, c = 0; @@ -2603,8 +2263,13 @@ Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Obje it preserves marks, which is useful information for the JIT. */ intptr_t i = SCHEME_INT_VAL(p); i = ((uintptr_t)i) << 1; - if (scheme_closure_preserves_marks(e)) { - i |= 0x1; + if (expected && SCHEME_INTP(expected) && !(SCHEME_INT_VAL(expected) & 0x1)) { + /* It's ok for an `e` that preserves marks to match an + expectation of not preserving marks */ + } else { + if (!imprecise && scheme_closure_preserves_marks(e)) { + i |= 0x1; + } } p = scheme_make_integer(i); } @@ -2821,7 +2486,8 @@ const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error) } else { Scheme_Object *name; - if (type == scheme_ir_lambda_type) { + if ((type == scheme_ir_lambda_type) + || (type == scheme_lambda_type)) { name = ((Scheme_Lambda *)p)->name; } else if (type == scheme_closure_type) { name = SCHEME_CLOSURE_CODE(p)->name; @@ -3091,7 +2757,7 @@ Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[]) /* -2 means a bignum */ inc_ok = ((argc > 2) && SCHEME_TRUEP(argv[2])); - + return get_or_check_arity(argv[0], n, argv[1], inc_ok); } @@ -3122,7 +2788,7 @@ static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok) return 0; } -void scheme_init_reduced_proc_struct(Scheme_Env *env) +void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env) { if (!scheme_reduced_procedure_struct) { Scheme_Inspector *insp; @@ -7445,7 +7111,7 @@ static Scheme_Object *do_call_with_prompt(Scheme_Closed_Prim f, void *data, prim = scheme_make_closed_prim(f, data); a[0] = prim; a[1] = scheme_default_prompt_tag; - a[2] = scheme_make_prim(propagate_abort); + a[2] = propagate_abort_prim; if (multi) { if (top_level) @@ -8401,23 +8067,14 @@ scheme_get_stack_trace(Scheme_Object *mark_set) name = scheme_make_pair(scheme_false, loc); else name = scheme_make_pair(SCHEME_VEC_ELS(name)[0], loc); - } else if (SCHEME_PAIRP(name) && SCHEME_RMPP(SCHEME_CAR(name))) { - /* a resolved module path means that we're running a module body */ + } else if (SCHEME_PAIRP(name) && SAME_OBJ(SCHEME_CDR(name), scheme_true)) { + /* a pair with #t we're running a module body */ const char *what; - if (SCHEME_FALSEP(SCHEME_CDR(name))) - what = "[traversing imports]"; - else if (SCHEME_VOIDP(SCHEME_CDR(name))) - what = "[running expand-time body]"; - else - what = "[running body]"; + what = "[running body]"; name = SCHEME_CAR(name); - name = SCHEME_PTR_VAL(name); - if (SCHEME_PAIRP(name)) - name = scheme_make_pair(scheme_intern_symbol("submod"), name); - loc = scheme_make_location(name, scheme_false, - scheme_false, scheme_false, scheme_false); + loc = scheme_make_location(name, scheme_false, scheme_false, scheme_false, scheme_false); name = scheme_intern_symbol(what); name = scheme_make_pair(name, loc); @@ -8784,10 +8441,10 @@ extract_one_cc_mark(int argc, Scheme_Object *argv[]) if (SCHEME_TRUEP(argv[0]) && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) scheme_wrong_contract("continuation-mark-set-first", "(or/c continuation-mark-set? #f)", 0, argc, argv); - + if ((argv[1] == scheme_parameterization_key) || (argv[1] == scheme_break_enabled_key)) { - /* Minor hack: these keys are used in "startup.rkt" to access + /* Minor hack: these keys are used in the startup linklet to access parameterizations, and we want that access to go through prompts. If they keys somehow leaked, it's ok, because that doesn't expose anything that isn't already exposed by functions @@ -10048,8 +9705,9 @@ scheme_default_read_handler(int argc, Scheme_Object *argv[]) argv); config = scheme_current_config(); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_false); + // FIXME + // config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); + // config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_false); scheme_push_continuation_frame(&cframe); scheme_install_config(config); diff --git a/racket/src/racket/src/future.c b/racket/src/racket/src/future.c index f33158b19e..5299f4ee40 100644 --- a/racket/src/racket/src/future.c +++ b/racket/src/racket/src/future.c @@ -267,6 +267,7 @@ void scheme_end_futures_per_place() { } +/* Set differently below when futures are supported */ #define SCHEME_FUTURE_PRIM_IS_NARY_INLINED SCHEME_PRIM_SOMETIMES_INLINED #define SCHEME_FUTURE_PRIM_IS_UNARY_INLINED SCHEME_PRIM_SOMETIMES_INLINED @@ -456,6 +457,7 @@ typedef struct future_thread_params_t { Scheme_Current_LWC *lwc; } future_thread_params_t; +/* Set differently above when futures are not supported */ #define SCHEME_FUTURE_PRIM_IS_NARY_INLINED SCHEME_PRIM_IS_NARY_INLINED #define SCHEME_FUTURE_PRIM_IS_UNARY_INLINED SCHEME_PRIM_IS_UNARY_INLINED @@ -466,17 +468,12 @@ typedef struct future_thread_params_t { /**********************************************************************/ /* Invoked by the runtime on startup to make primitives known */ -void scheme_init_futures(Scheme_Env *newenv) +void scheme_init_futures(Scheme_Startup_Env *newenv) { Scheme_Object *p; - /* Order and properties here need to be in sync with the order and - properties in the other scheme_init_futures() */ - - scheme_add_global_constant( - "future?", - scheme_make_folding_prim( - future_p, + scheme_addto_prim_instance("future?", + scheme_make_folding_prim(future_p, "future?", 1, 1, @@ -485,12 +482,10 @@ void scheme_init_futures(Scheme_Env *newenv) p = scheme_make_prim_w_arity(scheme_future, "future", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("future", p, newenv); + scheme_addto_prim_instance("future", p, newenv); - scheme_add_global_constant( - "processor-count", - scheme_make_prim_w_arity( - processor_count, + scheme_addto_prim_instance("processor-count", + scheme_make_prim_w_arity(processor_count, "processor-count", 0, 0), @@ -498,72 +493,62 @@ void scheme_init_futures(Scheme_Env *newenv) p = scheme_make_prim_w_arity(touch, "touch", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("touch", p, newenv); + scheme_addto_prim_instance("touch", p, newenv); - p = scheme_make_immed_prim( - scheme_current_future, - "current-future", - 0, - 0); + p = scheme_make_immed_prim(scheme_current_future, + "current-future", + 0, + 0); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("current-future", p, newenv); + scheme_addto_prim_instance("current-future", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_p, - "fsemaphore?", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_p, + "fsemaphore?", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore?", p, newenv); + scheme_addto_prim_instance("fsemaphore?", p, newenv); - p = scheme_make_immed_prim( - make_fsemaphore, - "make-fsemaphore", - 1, - 1); + p = scheme_make_immed_prim(make_fsemaphore, + "make-fsemaphore", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("make-fsemaphore", p, newenv); + scheme_addto_prim_instance("make-fsemaphore", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_count, - "fsemaphore-count", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_count, + "fsemaphore-count", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-count", p, newenv); + scheme_addto_prim_instance("fsemaphore-count", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_wait, - "fsemaphore-wait", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_wait, + "fsemaphore-wait", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-wait", p, newenv); + scheme_addto_prim_instance("fsemaphore-wait", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_post, - "fsemaphore-post", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_post, + "fsemaphore-post", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-post", p, newenv); + scheme_addto_prim_instance("fsemaphore-post", p, newenv); - p = scheme_make_immed_prim( - scheme_fsemaphore_try_wait, - "fsemaphore-try-wait?", - 1, - 1); + p = scheme_make_immed_prim(scheme_fsemaphore_try_wait, + "fsemaphore-try-wait?", + 1, + 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_FUTURE_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("fsemaphore-try-wait?", p, newenv); + scheme_addto_prim_instance("fsemaphore-try-wait?", p, newenv); - GLOBAL_PRIM_W_ARITY("would-be-future", would_be_future, 1, 1, newenv); - GLOBAL_PRIM_W_ARITY("futures-enabled?", futures_enabled, 0, 0, newenv); - GLOBAL_PRIM_W_ARITY("reset-future-logs-for-tracing!", reset_future_logs_for_tracking, 0, 0, newenv); - GLOBAL_PRIM_W_ARITY("mark-future-trace-end!", mark_future_trace_end, 0, 0, newenv); - - scheme_finish_primitive_module(newenv); - scheme_protect_primitive_provide(newenv, NULL); + ADD_PRIM_W_ARITY("would-be-future", would_be_future, 1, 1, newenv); + ADD_PRIM_W_ARITY("futures-enabled?", futures_enabled, 0, 0, newenv); + ADD_PRIM_W_ARITY("reset-future-logs-for-tracing!", reset_future_logs_for_tracking, 0, 0, newenv); + ADD_PRIM_W_ARITY("mark-future-trace-end!", mark_future_trace_end, 0, 0, newenv); } #ifdef MZ_USE_FUTURES @@ -573,7 +558,7 @@ void scheme_init_futures_once() init_cpucount(); REGISTER_SO(bad_multi_result_proc); - bad_multi_result_proc = scheme_make_prim(bad_multi_result); + bad_multi_result_proc = scheme_make_prim_w_arity(bad_multi_result, "bad-multi-result", 0, -1); } void scheme_init_futures_per_place() diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index a3b8d73d26..18d3147f9c 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -1572,7 +1572,6 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) } case scheme_vector_type: case scheme_fxvector_type: - case scheme_wrap_chunk_type: { int len = SCHEME_VEC_SIZE(o), i, val; Scheme_Object *elem; @@ -1850,33 +1849,6 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) o = (Scheme_Object *)((Scheme_Place_Bi_Channel *)o)->link->sendch; } break; - case scheme_resolved_module_path_type: - /* Needed for interning */ - { - k += 7; - o = SCHEME_PTR_VAL(o); - } - break; - case scheme_module_index_type: - { - Scheme_Modidx *midx = (Scheme_Modidx *)o; -# include "mzhashchk.inc" - hi->depth += 2; - k++; - k = (k << 3) + k; - k += equal_hash_key(midx->path, 0, hi); - o = midx->base; - } - break; - case scheme_scope_table_type: - { - Scheme_Scope_Table *mt = (Scheme_Scope_Table *)o; - hi->depth += 2; - k = (k << 3) + k; - k += equal_hash_key((Scheme_Object *)mt->simple_scopes, 0, hi); - o = mt->multi_scopes; - } - break; default: { Scheme_Primary_Hash_Proc h1 = scheme_type_hash1s[t]; @@ -2075,7 +2047,6 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) } case scheme_vector_type: case scheme_fxvector_type: - case scheme_wrap_chunk_type: { int len = SCHEME_VEC_SIZE(o), i; uintptr_t k = 0; @@ -2352,30 +2323,6 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) return k; } - case scheme_resolved_module_path_type: - /* Needed for interning */ - o = SCHEME_PTR_VAL(o); - goto top; - case scheme_module_index_type: - { - Scheme_Modidx *midx = (Scheme_Modidx *)o; - uintptr_t v1, v2; -# include "mzhashchk.inc" - hi->depth += 2; - v1 = equal_hash_key2(midx->path, hi); - v2 = equal_hash_key2(midx->base, hi); - return v1 + v2; - } - case scheme_scope_table_type: - { - Scheme_Scope_Table *mt = (Scheme_Scope_Table *)o; - uintptr_t k; - hi->depth += 2; - k = equal_hash_key2((Scheme_Object *)mt->simple_scopes, hi); - k += equal_hash_key2(mt->multi_scopes, hi); - return k; - } - break; case scheme_place_bi_channel_type: /* a bi channel has sendch and recvch, but sends are the same iff recvs are the same: */ @@ -2814,6 +2761,21 @@ Scheme_Object *scheme_hash_tree_next_pos(Scheme_Hash_Tree *tree, mzlonglong pos) #define mzHAMT_MAX_INDEX_LEVEL 4 /* For the compressed form of the index */ +Scheme_Object *make_index_frame(Scheme_Hash_Tree *ht, intptr_t i, Scheme_Object *rest) +{ + Scheme_Object *vec; + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)ht; + SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(i); + SCHEME_VEC_ELS(vec)[2] = rest; + return vec; +} + +#define INDEX_FRAMEP(o) SCHEME_VECTORP(o) +#define INDEX_FRAME_SUBTREE(o) ((Scheme_Hash_Tree *)(SCHEME_VEC_ELS(o)[0])) +#define INDEX_FRAME_INDEX(o) (SCHEME_INT_VAL(SCHEME_VEC_ELS(o)[1])) +#define INDEX_FRAME_REST(o) (SCHEME_VEC_ELS(o)[2]) + /* instead of returning a pos, these unsafe iteration ops */ /* return a view into the tree consisting of a: */ /* - subtree */ @@ -2845,9 +2807,7 @@ Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht) || HASHTR_COLLISIONP(ht->els[i]))) { /* go down tree but save return point */ if (level == -1) { - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht, i, stack); } else if (level < mzHAMT_MAX_INDEX_LEVEL) { ht_n[level] = ht; i_n[level] = i; @@ -2855,13 +2815,9 @@ Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht) } else { stack = scheme_null; for (j = 0; j < mzHAMT_MAX_INDEX_LEVEL; j++) { - stack = scheme_make_pair((Scheme_Object *)ht_n[j], - scheme_make_pair(scheme_make_integer(i_n[j]), - stack)); + stack = make_index_frame(ht_n[j], i_n[j], stack); } - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht, i, stack); level = -1; } ht = (Scheme_Hash_Tree *)ht->els[i]; @@ -2869,9 +2825,7 @@ Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht) } if (level == -1) { - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht, i, stack); return stack; } else { i = (1<els[i]) || HASHTR_COLLISIONP(ht->els[i]))) { if (level == -1) { - stack = scheme_make_pair((Scheme_Object *)ht, - scheme_make_pair(scheme_make_integer(i), - stack)); + stack = make_index_frame(ht, i, stack); return stack; } else { i = (1<els[i]; @@ -3318,6 +3264,9 @@ Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Schem } } else { /* update collision */ + /* (we're not looking for a shortcut here if the current value + matched the new value, but we could do that if it seems + worthwhile; hopefully, collisions are relatively rare) */ in_tree = hamt_set(in_tree, code, 0, key, val, 0); inc = 0; } @@ -3357,6 +3306,9 @@ Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Schem return tree; } else return tree; + } else if (SAME_OBJ(val, mzHAMT_VAL(in_tree, pos))) { + /* Shortcut: setting to the current value */ + return tree; } else return hamt_set(tree, h, 0, key, val, 0); } else { diff --git a/racket/src/racket/src/help-startup.rkt b/racket/src/racket/src/help-startup.rkt new file mode 100644 index 0000000000..d96caba9b4 --- /dev/null +++ b/racket/src/racket/src/help-startup.rkt @@ -0,0 +1,40 @@ +(module help-startup '#%kernel + (#%provide get-linklet + get-version-comparisons) + + (define-values (get-lines) + (lambda (in) + (let-values ([(l) (read-line in 'any)]) + (if (eof-object? l) + null + (cons l (get-lines in)))))) + + (define-values (get-linklet) + (lambda (src) + (read + (open-input-string + (apply + string-append + (map (lambda (l) + (regexp-replace* #rx"\\\\(.)" + (substring l 1 (sub1 (string-length l))) + "\\1")) + (reverse (cdr (reverse (cddr (call-with-input-file src get-lines))))))))))) + + (define-values (get-version-comparisons) + (lambda (vers) + (call-with-input-file + vers + (lambda (in) + (letrec-values ([(get-version-comparisons) + (lambda () + (let-values ([(line) (read-line in 'any)]) + (if (eof-object? line) + "" + (let-values ([(m) (regexp-match #rx"^#define (MZSCHEME_VERSION_[A-Z]) ([0-9]+)" + line)]) + (if m + (string-append " || (" (cadr m) " != " (caddr m) ")" + (get-version-comparisons)) + (get-version-comparisons))))))]) + (get-version-comparisons))))))) diff --git a/racket/src/racket/src/jit.c b/racket/src/racket/src/jit.c index c99665c9c7..5e083042de 100644 --- a/racket/src/racket/src/jit.c +++ b/racket/src/racket/src/jit.c @@ -53,6 +53,11 @@ static Scheme_Object *make_global_ref(Scheme_Object *var, Scheme_Object *dummy) o = scheme_alloc_object(); o->type = scheme_global_ref_type; SCHEME_PTR1_VAL(o) = var; + if (!SCHEME_FALSEP(dummy)) { + Scheme_Instance *home; + home = scheme_get_bucket_home((Scheme_Bucket *)dummy); + dummy = (Scheme_Object *)home; + } SCHEME_PTR2_VAL(o) = dummy; return o; @@ -414,7 +419,6 @@ static int is_short(Scheme_Object *obj, int fuel) return is_short(branch->fbranch, fuel); } case scheme_toplevel_type: - case scheme_quote_syntax_type: case scheme_local_type: case scheme_local_unbox_type: case scheme_lambda_type: @@ -447,29 +451,6 @@ Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc return globs->a[pos]; } -static Scheme_Object *extract_syntax(Scheme_Quote_Syntax *qs, Scheme_Native_Closure *nc) -{ - /* GLOBAL ASSUMPTION: we assume that globals are the last thing - in the closure; grep for "GLOBAL ASSUMPTION" in fun.c. */ - Scheme_Prefix *globs; - int i, pos; - Scheme_Object *v; - - globs = (Scheme_Prefix *)nc->vals[nc->code->u2.orig_code->closure_size - 1]; - - i = qs->position; - pos = qs->midpoint; - - v = globs->a[i+pos+1]; - if (!v) { - v = globs->a[pos]; - v = scheme_delayed_shift((Scheme_Object **)v, i); - globs->a[i+pos+1] = v; - } - - return v; -} - static Scheme_Object *extract_closure_local(int pos, mz_jit_state *jitter, int get_constant) { if (PAST_LIMIT()) return NULL; @@ -562,6 +543,10 @@ int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack if ((((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OTHER_TYPE_MASK) == SCHEME_PRIM_STRUCT_TYPE_PRED) return 0; + /* Closures need a 3rd argument, so don't claim NONCM for them, either. + (Currently, all of those are predicates, anyway.) */ + if (((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_IS_CLOSURE) + return 0; return 1; } } @@ -662,7 +647,7 @@ int scheme_is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st { Scheme_Object *rator; rator = scheme_specialize_to_constant(((Scheme_App_Rec *)obj)->args[0], jitter, - stack_start + ((Scheme_App_Rec *)obj)->num_args); + stack_start + ((Scheme_App_Rec *)obj)->num_args); if (scheme_inlined_nary_prim(rator, obj, jitter) && !SAME_OBJ(rator, scheme_values_proc)) return 1; @@ -697,7 +682,6 @@ int scheme_is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st break; case scheme_toplevel_type: - case scheme_quote_syntax_type: case scheme_local_type: case scheme_local_unbox_type: case scheme_lambda_type: @@ -768,7 +752,6 @@ int scheme_is_non_gc(Scheme_Object *obj, int depth) return 1; break; - case scheme_quote_syntax_type: case scheme_local_unbox_type: return 1; break; @@ -2676,14 +2659,20 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w dummy = SCHEME_PTR2_VAL(obj); obj = SCHEME_PTR1_VAL(obj); - - /* Load global array: */ - pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); - jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); - /* Load bucket: */ - pos = SCHEME_TOPLEVEL_POS(obj); - jit_ldxi_p(JIT_R1, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); - CHECK_LIMIT(); + + if (!SCHEME_SYMBOLP(obj) && !SCHEME_FALSEP(obj)) { + /* Load global array: */ + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); + jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + /* Load bucket: */ + pos = SCHEME_TOPLEVEL_POS(obj); + jit_ldxi_p(JIT_R1, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + CHECK_LIMIT(); + } else { + scheme_mz_load_retained(jitter, JIT_R1, obj); + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(dummy)); + jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + } /* Load dummy bucket: */ if (SCHEME_FALSEP(dummy)) { @@ -2714,12 +2703,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w return 1; } break; - case scheme_splice_sequence_type: case scheme_define_values_type: - case scheme_define_syntaxes_type: - case scheme_begin_for_syntax_type: - case scheme_require_form_type: - case scheme_module_type: case scheme_inline_variant_type: { scheme_signal_error("internal error: cannot JIT a top-level form"); @@ -2992,18 +2976,20 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w mz_patch_branch(ref2); __END_SHORT_JUMPS__(1); (void)jit_movi_p(JIT_R0, NULL); - jit_stxi_p(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_V1, JIT_R0); - for (i = 0; i < lv->count; i++) { - jit_ldxi_p(JIT_R1, JIT_R2, WORDS_TO_BYTES(i)); - if (ab) { - pos = mz_remap(lv->position + i); - jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); - jit_str_p(JIT_R0, JIT_R1); - } else { - pos = mz_remap(lv->position + i); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R1); + if (lv->count) { + jit_stxi_p(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_V1, JIT_R0); + for (i = 0; i < lv->count; i++) { + jit_ldxi_p(JIT_R1, JIT_R2, WORDS_TO_BYTES(i)); + if (ab) { + pos = mz_remap(lv->position + i); + jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + jit_str_p(JIT_R0, JIT_R1); + } else { + pos = mz_remap(lv->position + i); + jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R1); + } + CHECK_LIMIT(); } - CHECK_LIMIT(); } } } @@ -3295,44 +3281,6 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w return scheme_generate(wcm->body, jitter, is_tail, wcm_may_replace, multi_ok, orig_target, for_branch, for_values); } - case scheme_quote_syntax_type: - { - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; - int i, c, p; - START_JIT_DATA(); - - LOG_IT(("quote-syntax\n")); - - if (for_branch) - finish_branch_with_true(jitter, for_branch); - else { - i = qs->position; - c = mz_remap(qs->depth); - p = qs->midpoint; - - mz_rs_sync(); - - if (SCHEME_NATIVE_LAMBDA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) { - Scheme_Object *stx; - stx = extract_syntax(qs, jitter->nc); - scheme_mz_load_retained(jitter, target, stx); - CHECK_LIMIT(); - } else { - jit_movi_i(JIT_R0, WORDS_TO_BYTES(c)); - jit_movi_i(JIT_R1, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[i + p + 1])); - jit_movi_i(JIT_R2, (int)(intptr_t)&(((Scheme_Prefix *)0x0)->a[p])); - (void)jit_calli(sjc.quote_syntax_code); - CHECK_LIMIT(); - - if (target != JIT_R0) - jit_movr_p(target, JIT_R0); - } - } - - END_JIT_DATA(10); - - return 1; - } default: /* Other parts of the JIT rely on this code modifying the target register, only */ if (for_branch) { diff --git a/racket/src/racket/src/jit.h b/racket/src/racket/src/jit.h index efce3eb7c5..5447280ec9 100644 --- a/racket/src/racket/src/jit.h +++ b/racket/src/racket/src/jit.h @@ -294,7 +294,6 @@ struct scheme_jit_common_record { void *bad_result_arity_code; void *unbound_global_code; - void *quote_syntax_code; void *call_original_unary_arith_code; void *call_original_binary_arith_code; void *call_original_binary_rev_arith_code; @@ -307,24 +306,25 @@ struct scheme_jit_common_record { void *bad_cXr_code; void *bad_mcar_code, *bad_mcdr_code; void *bad_set_mcar_code, *bad_set_mcdr_code; + void *bad_syntax_e_code; void *imag_part_code, *real_part_code, *make_rectangular_code; void *bad_flimag_part_code, *bad_flreal_part_code, *bad_make_flrectangular_code; - void *unbox_code, *set_box_code, *box_cas_fail_code; + void *unbox_code, *set_box_code, *unbox_star_fail_code, *set_box_star_fail_code, *box_cas_fail_code, *weak_box_value_code; void *vector_cas_fail_code; - void *bad_vector_length_code; + void *bad_vector_length_code, *bad_vector_star_length_code; void *bad_flvector_length_code; void *bad_fxvector_length_code; void *bad_string_length_code; void *bad_bytes_length_code; void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code; void *chap_vector_ref_code, *chap_vector_ref_check_index_code, *chap_vector_set_code, *chap_vector_set_check_index_code; + void *vector_star_ref_code, *vector_star_ref_check_index_code, *vector_star_set_code, *vector_star_set_check_index_code; void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code; void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code; void *flvector_ref_check_index_code[JIT_NUM_FL_KINDS]; void *flvector_set_check_index_code[JIT_NUM_FL_KINDS], *flvector_set_flonum_check_index_code[JIT_NUM_FL_KINDS]; void *fxvector_ref_code, *fxvector_ref_check_index_code, *fxvector_set_code, *fxvector_set_check_index_code; void *struct_raw_ref_code, *struct_raw_set_code, *struct_raw_refs_code; - void *syntax_e_code; void *on_demand_jit_arity_code, *in_progress_on_demand_jit_arity_code; void *get_stack_pointer_code; void *stack_cache_pop_code; @@ -347,8 +347,9 @@ struct scheme_jit_common_record { void *list_p_code, *list_p_branch_code; void *list_length_code; void *list_ref_code, *list_tail_code; + void *hash_ref_code; void *finish_tail_call_code, *finish_tail_call_fixup_code; - void *module_run_start_code, *module_exprun_start_code, *module_start_start_code; + void *linklet_run_start_code; void *thread_start_child_code; void *box_flonum_from_stack_code, *box_flonum_from_reg_code; void *fl1_fail_code[JIT_NUM_FL_KINDS], *fl2rr_fail_code[2][JIT_NUM_FL_KINDS]; @@ -1420,7 +1421,7 @@ int scheme_generate_inlined_test(mz_jit_state *jitter, Scheme_Object *obj, int b Branch_Info *for_branch); int scheme_generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry, int known_list, int dest); int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, - int inline_slow, int pop_and_jump, + int inline_slow, int pop_and_jump, int check_proc, int is_tail, int multi_ok, int dest); int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters, int skipped); diff --git a/racket/src/racket/src/jit_ts.c b/racket/src/racket/src/jit_ts.c index 3ac7fd5714..1b151c78a9 100644 --- a/racket/src/racket/src/jit_ts.c +++ b/racket/src/racket/src/jit_ts.c @@ -47,9 +47,9 @@ define_ts_s_v(raise_bad_call_with_values, FSRC_MARKS) define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_MARKS) define_ts_s_s(call_with_values_from_multiple_result, FSRC_MARKS) define_ts_S_s(apply_checked_fail, FSRC_MARKS) -define_ts_Sl_s(scheme_delayed_shift, FSRC_OTHER) define_ts_b_v(scheme_unbound_global, FSRC_MARKS) define_ts_ss_v(scheme_set_box, FSRC_MARKS) +define_ts_ss_v(scheme_set_box_star, FSRC_MARKS) define_ts_iS_s(scheme_checked_car, FSRC_MARKS) define_ts_iS_s(scheme_checked_cdr, FSRC_MARKS) define_ts_iS_s(scheme_checked_caar, FSRC_MARKS) @@ -70,20 +70,23 @@ define_ts_iS_s(scheme_checked_flreal_part, FSRC_MARKS) define_ts_iS_s(scheme_checked_make_flrectangular, FSRC_MARKS) define_ts_iS_s(scheme_checked_vector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_vector_set, FSRC_MARKS) +define_ts_iS_s(scheme_checked_vector_star_ref, FSRC_MARKS) +define_ts_iS_s(scheme_checked_vector_star_set, FSRC_MARKS) define_ts_iS_s(scheme_checked_string_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_string_set, FSRC_MARKS) define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_byte_string_set, FSRC_MARKS) define_ts_iS_s(scheme_checked_flvector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_flvector_set, FSRC_MARKS) +define_ts_iS_s(scheme_checked_syntax_e, FSRC_MARKS) #ifdef MZ_LONG_DOUBLE define_ts_iS_s(scheme_checked_extflvector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_extflvector_set, FSRC_MARKS) #endif define_ts_iS_s(scheme_checked_fxvector_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_fxvector_set, FSRC_MARKS) -define_ts_iS_s(scheme_checked_syntax_e, FSRC_MARKS) define_ts_s_s(scheme_vector_length, FSRC_MARKS) +define_ts_s_s(scheme_vector_star_length, FSRC_MARKS) define_ts_s_s(scheme_flvector_length, FSRC_MARKS) #ifdef MZ_LONG_DOUBLE define_ts_s_s(scheme_extflvector_length, FSRC_MARKS) @@ -94,6 +97,8 @@ define_ts_s_s(scheme_byte_string_length, FSRC_MARKS) define_ts_ss_s(scheme_string_eq_2, FSRC_MARKS) define_ts_ss_s(scheme_byte_string_eq_2, FSRC_MARKS) define_ts_s_s(scheme_unbox, FSRC_MARKS) +define_ts_s_s(scheme_unbox_star, FSRC_MARKS) +define_ts_s_s(scheme_weak_box_value, FSRC_MARKS) define_ts_si_s(scheme_struct_ref, FSRC_MARKS) define_ts_sis_v(scheme_struct_set, FSRC_MARKS) define_ts_Sii_s(unsafe_struct_refs, FSRC_MARKS) @@ -102,6 +107,7 @@ define_ts_iS_s(scheme_procedure_arity_includes, FSRC_MARKS) define_ts_ssi_s(vector_check_chaperone_of, FSRC_MARKS) define_ts_iS_s(scheme_checked_list_ref, FSRC_MARKS) define_ts_iS_s(scheme_checked_list_tail, FSRC_MARKS) +define_ts_iS_s(scheme_checked_hash_ref, FSRC_MARKS) define_ts_iSs_s(scheme_struct_getter, FSRC_MARKS) define_ts_iSs_s(scheme_struct_setter, FSRC_MARKS) define_ts_iS_s(scheme_box_cas, FSRC_MARKS) @@ -187,7 +193,6 @@ define_ts_s_s(scheme_box, FSRC_OTHER) # define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity # define ts_call_wrong_return_arity call_wrong_return_arity # define ts_scheme_unbound_global scheme_unbound_global -# define ts_scheme_delayed_shift scheme_delayed_shift # define ts_scheme_checked_car scheme_checked_car # define ts_scheme_checked_cdr scheme_checked_cdr # define ts_scheme_checked_caar scheme_checked_caar @@ -208,12 +213,16 @@ define_ts_s_s(scheme_box, FSRC_OTHER) # define ts_scheme_checked_make_flrectangular scheme_checked_make_flrectangular # define ts_scheme_make_complex scheme_make_complex # define ts_scheme_unbox scheme_unbox +# define ts_scheme_unbox_star scheme_unbox_star +# define ts_scheme_weak_box_value scheme_weak_box_value # define ts_scheme_set_box scheme_set_box +# define ts_scheme_set_box_star scheme_set_box_star # define ts_scheme_box_cas scheme_box_cas # define ts_scheme_checked_vector_cas scheme_checked_vector_cas # define ts_chaperone_set_mark chaperone_set_mark # define ts_scheme_chaperone_get_immediate_cc_mark scheme_chaperone_get_immediate_cc_mark # define ts_scheme_vector_length scheme_vector_length +# define ts_scheme_vector_star_length scheme_vector_star_length # define ts_scheme_flvector_length scheme_flvector_length #ifdef MZ_LONG_DOUBLE # define ts_scheme_extflvector_length scheme_extflvector_length @@ -235,19 +244,21 @@ define_ts_s_s(scheme_box, FSRC_OTHER) # define ts_call_with_values_from_multiple_result call_with_values_from_multiple_result # define ts_scheme_checked_vector_ref scheme_checked_vector_ref # define ts_scheme_checked_vector_set scheme_checked_vector_set +# define ts_scheme_checked_vector_star_ref scheme_checked_vector_star_ref +# define ts_scheme_checked_vector_star_set scheme_checked_vector_star_set # define ts_scheme_checked_string_ref scheme_checked_string_ref # define ts_scheme_checked_string_set scheme_checked_string_set # define ts_scheme_checked_byte_string_ref scheme_checked_byte_string_ref # define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set # define ts_scheme_checked_flvector_ref scheme_checked_flvector_ref # define ts_scheme_checked_flvector_set scheme_checked_flvector_set +# define ts_scheme_checked_syntax_e scheme_checked_syntax_e #ifdef MZ_LONG_DOUBLE # define ts_scheme_checked_extflvector_ref scheme_checked_extflvector_ref # define ts_scheme_checked_extflvector_set scheme_checked_extflvector_set #endif # define ts_scheme_checked_fxvector_ref scheme_checked_fxvector_ref # define ts_scheme_checked_fxvector_set scheme_checked_fxvector_set -# define ts_scheme_checked_syntax_e scheme_checked_syntax_e # define ts_scheme_extract_checked_procedure scheme_extract_checked_procedure # define ts_scheme_procedure_arity_includes scheme_procedure_arity_includes # define ts_apply_checked_fail apply_checked_fail @@ -256,6 +267,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER) # define ts_vector_check_chaperone_of vector_check_chaperone_of # define ts_scheme_checked_list_ref scheme_checked_list_ref # define ts_scheme_checked_list_tail scheme_checked_list_tail +# define ts_scheme_checked_hash_ref scheme_checked_hash_ref # define ts_scheme_struct_getter scheme_struct_getter # define ts_scheme_struct_setter scheme_struct_setter # define ts_scheme_checked_char_to_integer scheme_checked_char_to_integer diff --git a/racket/src/racket/src/jitcommon.c b/racket/src/racket/src/jitcommon.c index 4b282bd360..96fef332cd 100644 --- a/racket/src/racket/src/jitcommon.c +++ b/racket/src/racket/src/jitcommon.c @@ -212,7 +212,6 @@ static int common0(mz_jit_state *jitter, void *_data) { int in; GC_CAN_IGNORE jit_insn *ref; - GC_CAN_IGNORE jit_insn *ref2 USED_ONLY_FOR_FUTURES; /* *** check_arity_code *** */ /* Called as a function: */ @@ -277,56 +276,6 @@ static int common0(mz_jit_state *jitter, void *_data) (void)mz_finish_lwe(ts_scheme_unbound_global, ref); CHECK_LIMIT(); - /* *** quote_syntax_code *** */ - /* R0 is WORDS_TO_BYTES(c), R1 is &0->a[i+p+1], R2 is &0->a[p] */ - sjc.quote_syntax_code = jit_get_ip(); - mz_prolog(JIT_V1); - __START_SHORT_JUMPS__(1); - /* Load global array: */ - jit_ldxr_p(JIT_V1, JIT_RUNSTACK, JIT_R0); -#ifdef JIT_PRECISE_GC - /* Save global-array index before we lose it: */ - mz_set_local_p(JIT_R0, JIT_LOCAL3); -#endif - /* Load syntax object: */ - jit_ldxr_p(JIT_R0, JIT_V1, JIT_R1); - /* Is it null? */ - ref = jit_bnei_p(jit_forward(), JIT_R0, 0x0); - CHECK_LIMIT(); - /* Syntax object is NULL, so we need to create it. */ - jit_ldxr_p(JIT_R0, JIT_V1, JIT_R2); /* put element at p in R0 */ -#ifndef JIT_PRECISE_GC - /* Save global array: */ - mz_set_local_p(JIT_V1, JIT_LOCAL3); -#endif - /* Move R1 to V1 to save it: */ - jit_movr_p(JIT_V1, JIT_R1); - /* Compute i in JIT_R1: */ - jit_subr_p(JIT_R1, JIT_R1, JIT_R2); - jit_subi_p(JIT_R1, JIT_R1, WORDS_TO_BYTES(1)); - jit_rshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE); - CHECK_LIMIT(); - /* Call scheme_delayed_shift: */ - JIT_UPDATE_THREAD_RSPTR(); - CHECK_LIMIT(); - mz_prepare(2); - jit_pusharg_l(JIT_R1); - jit_pusharg_p(JIT_R0); - (void)mz_finish_lwe(ts_scheme_delayed_shift, ref2); - CHECK_LIMIT(); - jit_retval(JIT_R0); - /* Restore global array into JIT_R1, and put computed element at i+p+1: */ -#ifdef JIT_PRECISE_GC - mz_get_local_p(JIT_R1, JIT_LOCAL3); - jit_ldxr_p(JIT_R1, JIT_RUNSTACK, JIT_R1); -#else - mz_get_local_p(JIT_R1, JIT_LOCAL3); -#endif - jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); - mz_patch_branch(ref); - __END_SHORT_JUMPS__(1); - mz_epilog(JIT_V1); - return 1; } @@ -337,7 +286,7 @@ static int common1(mz_jit_state *jitter, void *_data) /* *** [bad_][m]{car,cdr,...,{imag,real}_part}_code *** */ /* Argument is in R2 for cXX+r, R0 otherwise */ - for (i = 0; i < 13; i++) { + for (i = 0; i < 14; i++) { void *code; code = jit_get_ip(); @@ -381,6 +330,9 @@ static int common1(mz_jit_state *jitter, void *_data) case 12: sjc.bad_cXr_code = code; break; + case 13: + sjc.bad_syntax_e_code = code; + break; } mz_prolog(JIT_R1); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); @@ -441,6 +393,9 @@ static int common1(mz_jit_state *jitter, void *_data) case 12: (void)mz_finish_lwe(ts_apply_prim_to_fail, ref); break; + case 13: + (void)mz_finish_lwe(ts_scheme_checked_syntax_e, ref); + break; } CHECK_LIMIT(); @@ -547,6 +502,29 @@ static int common1b(mz_jit_state *jitter, void *_data) mz_epilog(JIT_R2); scheme_jit_register_sub_func(jitter, sjc.set_box_code, scheme_false); + /* *** unbox_star_fail_code *** */ + /* R0 is argument */ + sjc.unbox_star_fail_code = jit_get_ip(); + mz_prolog(JIT_R1); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_unbox_star, ref); + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.unbox_star_fail_code, scheme_false); + + /* *** set_box_star_fail_code *** */ + /* R0 is box, R1 is value */ + sjc.set_box_star_fail_code = jit_get_ip(); + mz_prolog(JIT_R2); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(2); + jit_pusharg_p(JIT_R1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_set_box_star, ref); + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.set_box_star_fail_code, scheme_false); + /* *** {box,vector}_cas_fail_code *** */ /* Arguments are on runstack; */ /* call scheme_{box,vector}_cas to raise the exception, @@ -575,6 +553,17 @@ static int common1b(mz_jit_state *jitter, void *_data) scheme_jit_register_sub_func(jitter, ref2, scheme_false); } + /* *** weak_box_value_code *** */ + /* R0 is argument */ + sjc.weak_box_value_code = jit_get_ip(); + mz_prolog(JIT_R1); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_weak_box_value, ref); /* doesn't return */ + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.weak_box_value_code, scheme_false); + /* *** bad_vector_length_code *** */ /* R0 is argument */ sjc.bad_vector_length_code = jit_get_ip(); @@ -596,6 +585,17 @@ static int common1b(mz_jit_state *jitter, void *_data) CHECK_LIMIT(); scheme_jit_register_sub_func(jitter, sjc.bad_vector_length_code, scheme_false); + /* *** bad_vector_star_length_code *** */ + /* R0 is argument */ + sjc.bad_vector_star_length_code = jit_get_ip(); + mz_prolog(JIT_R1); + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(1); + jit_pusharg_p(JIT_R0); + (void)mz_finish_lwe(ts_scheme_vector_star_length, ref); + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, sjc.bad_vector_star_length_code, scheme_false); + /* *** bad_flvector_length_code *** */ /* R0 is argument */ sjc.bad_flvector_length_code = jit_get_ip(); @@ -1089,7 +1089,7 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter) jit_str_p(JIT_RUNSTACK, JIT_R0); /* if we have a chaperone-vector*, fall through and use extra arg */ - jit_ldxi_s(JIT_R2, JIT_R2, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R2, &MZ_OPT_HASH_KEY(&((Scheme_Vector *)0x0)->iso)); ref_not_star = jit_bmci_ul(jit_forward(), JIT_R2, SCHEME_VEC_CHAPERONE_STAR); /* get outermost from further down the stack */ jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); @@ -1127,7 +1127,7 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter) mz_patch_branch(ref_chaperone_of_check); jit_ldr_p(JIT_R1, JIT_RUNSTACK); - jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); /* if impersonator, no chaperone-of check needed */ ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, SCHEME_CHAPERONE_IS_IMPERSONATOR); @@ -1173,7 +1173,7 @@ static int common3(mz_jit_state *jitter, void *_data) vector, it includes the offset to the start of the elements array). In set mode, value is on run stack. */ for (iii = 0; iii < 2; iii++) { /* ref, set */ - for (ii = -1; ii < 4; ii++) { /* chap-vector, vector, string, bytes, fx */ + for (ii = -1; ii < 5; ii++) { /* chap-vector, vector, string, bytes, fx, vector* */ for (i = 0; i < 2; i++) { /* check index? */ GC_CAN_IGNORE jit_insn *ref, *reffail; GC_CAN_IGNORE jit_insn *refrts USED_ONLY_FOR_FUTURES; @@ -1186,6 +1186,7 @@ static int common3(mz_jit_state *jitter, void *_data) switch (ii) { case -1: case 0: + case 4: ty = scheme_vector_type; offset = (int)(intptr_t)&SCHEME_VEC_ELS(0x0); count_offset = (int)(intptr_t)&SCHEME_VEC_SIZE(0x0); @@ -1204,6 +1205,20 @@ static int common3(mz_jit_state *jitter, void *_data) sjc.chap_vector_set_check_index_code = code; } } + } else if (ii == 4) { + if (!iii) { + if (!i) { + sjc.vector_star_ref_code = code; + } else { + sjc.vector_star_ref_check_index_code = code; + } + } else { + if (!i) { + sjc.vector_star_set_code = code; + } else { + sjc.vector_star_set_check_index_code = code; + } + } } else if (!iii) { if (!i) { sjc.vector_ref_code = code; @@ -1336,6 +1351,14 @@ static int common3(mz_jit_state *jitter, void *_data) jit_retval(JIT_R0); mz_epilog(JIT_R2); break; + case 4: + if (!iii) { + (void)mz_finish_lwe(ts_scheme_checked_vector_star_ref, refrts); + } else { + (void)mz_finish_lwe(ts_scheme_checked_vector_star_set, refrts); + } + /* doesn't return */ + break; case 1: if (!iii) { (void)mz_finish_lwe(ts_scheme_checked_string_ref, refrts); @@ -1405,7 +1428,7 @@ static int common3(mz_jit_state *jitter, void *_data) (void)jit_bler_ul(reffail, JIT_R2, JIT_V1); if (log_elem_size) jit_lshi_ul(JIT_V1, JIT_V1, log_elem_size); - if (!ii || (ii == -1)) /* vector */ + if (!ii || (ii == -1) || (ii == 4)) /* vector */ jit_addi_p(JIT_V1, JIT_V1, offset); } else { /* constant index supplied: */ @@ -1417,6 +1440,7 @@ static int common3(mz_jit_state *jitter, void *_data) case -1: /* chap-vector */ case 0: /* vector */ case 3: /* fxvector */ + case 4: /* vector* */ jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); break; case 1: /* string */ @@ -1466,6 +1490,7 @@ static int common3(mz_jit_state *jitter, void *_data) (void)jit_bmci_l(reffail, JIT_R2, 0x1); case -1: /* chap-vector, fall-though from fxvector */ case 0: /* vector, fall-though from fxvector */ + case 4: /* vector*, fall-through from fxvector */ jit_stxr_p(JIT_V1, JIT_R0, JIT_R2); break; case 1: /* string */ @@ -1920,59 +1945,6 @@ static int common4(mz_jit_state *jitter, void *_data) scheme_jit_register_sub_func(jitter, code, scheme_false); } - /* *** syntax_e_code *** */ - /* R0 is (potential) syntax object */ - { - GC_CAN_IGNORE jit_insn *ref, *reffail; - GC_CAN_IGNORE jit_insn *refrts USED_ONLY_FOR_FUTURES; - sjc.syntax_e_code = jit_get_ip(); - __START_TINY_JUMPS__(1); - mz_prolog(JIT_R2); - - ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); - - reffail = jit_get_ip(); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); - CHECK_RUNSTACK_OVERFLOW(); - jit_str_p(JIT_RUNSTACK, JIT_R0); - jit_movi_i(JIT_R1, 1); - JIT_UPDATE_THREAD_RSPTR(); - CHECK_LIMIT(); - jit_prepare(2); - jit_pusharg_p(JIT_RUNSTACK); - jit_pusharg_i(JIT_R1); - (void)mz_finish_lwe(ts_scheme_checked_syntax_e, refrts); - jit_retval(JIT_R0); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); - mz_epilog(JIT_R2); - CHECK_LIMIT(); - - /* It's not a fixnum... */ - mz_patch_branch(ref); - (void)mz_bnei_t(reffail, JIT_R0, scheme_stx_type, JIT_R2); - - /* It's a syntax object... needs to propagate? */ - jit_ldxi_l(JIT_R2, JIT_R0, &((Scheme_Stx *)0x0)->u.to_propagate); - ref = jit_beqi_p(jit_forward(), JIT_R2, 0x0); - CHECK_LIMIT(); - - /* Maybe needs to propagate; check STX_SUBSTX_FLAG flag */ - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); - (void)jit_bmsi_ul(reffail, JIT_R2, STX_SUBSTX_FLAG); - - /* Maybe needs taint handling; check STX_ARMED_FLAG flag */ - mz_patch_branch(ref); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); - (void)jit_bmsi_ul(reffail, JIT_R2, STX_ARMED_FLAG); - - /* No propagations or dye packs. Extract value. */ - jit_ldxi_p(JIT_R0, JIT_R0, &((Scheme_Stx *)0x0)->val); - - mz_epilog(JIT_R2); - CHECK_LIMIT(); - __END_TINY_JUMPS__(1); - } - /* *** struct_{pred,get,set}[_branch,_multi,_tail]_code *** */ /* R0 is (potential) struct proc, R1 is (potential) struct. */ /* In branch mode, V1 is target address for false branch. */ @@ -2367,7 +2339,7 @@ static int common4c(mz_jit_state *jitter, void *_data) } else num_args = 0; - scheme_generate_struct_alloc(jitter, num_args, 1, 1, ii == 2, ii == 1, JIT_R0); + scheme_generate_struct_alloc(jitter, num_args, 1, 1, 1, ii == 2, ii == 1, JIT_R0); CHECK_LIMIT(); @@ -2962,7 +2934,7 @@ static int common7(mz_jit_state *jitter, void *_data) scheme_is_list(). */ refloop = jit_get_ip(); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref1 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_FLAG_MASK); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); @@ -2972,7 +2944,7 @@ static int common7(mz_jit_state *jitter, void *_data) ref3 = mz_bnei_t(jit_forward(), JIT_R0, scheme_pair_type, JIT_R2); CHECK_LIMIT(); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref4 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_FLAG_MASK); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); @@ -2994,7 +2966,7 @@ static int common7(mz_jit_state *jitter, void *_data) mz_patch_branch(ref2); mz_patch_branch(ref5); - jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); #ifdef MZ_USE_FUTURES if (scheme_is_multithreaded(0)) { /* Need an atomic update in case another thread is setting @@ -3002,7 +2974,7 @@ static int common7(mz_jit_state *jitter, void *_data) ref5 = jit_bmsi_i(jit_forward(), JIT_R2, PAIR_IS_LIST); jit_movr_i(JIT_R0, JIT_R2); jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_LIST); - jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); /* In the unlikely case that the compare-and-swap fails, then it's ok to lose the caching of the list bit: */ jit_lock_cmpxchgr_s(JIT_R1, JIT_R2); /* implicitly uses JIT_R0 */ @@ -3011,7 +2983,7 @@ static int common7(mz_jit_state *jitter, void *_data) #endif { jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_LIST); - jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso), JIT_R1, JIT_R2); + jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso), JIT_R1, JIT_R2); } __END_SHORT_JUMPS__(1); @@ -3030,21 +3002,21 @@ static int common7(mz_jit_state *jitter, void *_data) mz_patch_branch(ref8); mz_patch_ucbranch(ref6); - jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); #ifdef MZ_USE_FUTURES /* As above: */ if (scheme_is_multithreaded(0)) { ref5 = jit_bmsi_i(jit_forward(), JIT_R2, PAIR_IS_NON_LIST); jit_movr_i(JIT_R0, JIT_R2); jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_NON_LIST); - jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_addi_p(JIT_R1, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); jit_lock_cmpxchgr_s(JIT_R1, JIT_R2); /* implicitly uses JIT_R0 */ mz_patch_branch(ref5); } else #endif { jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_NON_LIST); - jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso), JIT_R1, JIT_R2); + jit_stxi_s(&MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso), JIT_R1, JIT_R2); } CHECK_LIMIT(); @@ -3096,7 +3068,7 @@ static int common8(mz_jit_state *jitter, void *_data) ref4 = mz_bnei_t(jit_forward(), JIT_R0, scheme_pair_type, JIT_R2); CHECK_LIMIT(); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref5 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_IS_NON_LIST); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); @@ -3728,17 +3700,17 @@ static int more_common0(mz_jit_state *jitter, void *_data) scheme_jit_register_sub_func(jitter, sjc.struct_proc_extract_code, scheme_false); } - /* *** module_run_start_code *** */ + /* *** linklet_run_start_code *** */ /* Pushes a module name onto the stack for stack traces. */ { int in; - sjc.module_run_start_code = jit_get_ip(); + sjc.linklet_run_start_code = jit_get_ip(); jit_prolog(3); in = jit_arg_p(); - jit_getarg_p(JIT_R0, in); /* menv */ + jit_getarg_p(JIT_R0, in); /* linklet */ in = jit_arg_p(); - jit_getarg_p(JIT_R1, in); /* env */ + jit_getarg_p(JIT_R1, in); /* instance */ in = jit_arg_p(); jit_getarg_p(JIT_R2, in); /* &name */ CHECK_LIMIT(); @@ -3747,75 +3719,19 @@ static int more_common0(mz_jit_state *jitter, void *_data) mz_push_locals(); mz_set_local_p(JIT_R2, JIT_LOCAL2); - jit_prepare(2); + jit_movi_i(JIT_R2, 1); + + jit_prepare(3); + jit_pusharg_i(JIT_R2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_module_run_finish); + (void)mz_finish(scheme_linklet_run_finish); CHECK_LIMIT(); mz_pop_locals(); jit_ret(); CHECK_LIMIT(); - scheme_jit_register_sub_func(jitter, sjc.module_run_start_code, scheme_eof); - } - - /* *** module_exprun_start_code *** */ - /* Pushes a module name onto the stack for stack traces. */ - { - int in; - - sjc.module_exprun_start_code = jit_get_ip(); - jit_prolog(3); - in = jit_arg_p(); - jit_getarg_p(JIT_R0, in); /* menv */ - in = jit_arg_p(); - jit_getarg_i(JIT_R1, in); /* set_ns */ - in = jit_arg_p(); - jit_getarg_p(JIT_R2, in); /* &name */ - CHECK_LIMIT(); - - /* Store the name where we can find it */ - mz_push_locals(); - mz_set_local_p(JIT_R2, JIT_LOCAL2); - - jit_prepare(2); - jit_pusharg_i(JIT_R1); - jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_module_exprun_finish); - CHECK_LIMIT(); - mz_pop_locals(); - jit_ret(); - CHECK_LIMIT(); - - scheme_jit_register_sub_func(jitter, sjc.module_exprun_start_code, scheme_eof); - } - - /* *** module_start_start_code *** */ - /* Pushes a module name onto the stack for stack traces. */ - { - int in; - - sjc.module_start_start_code = jit_get_ip(); - jit_prolog(2); - in = jit_arg_p(); - jit_getarg_p(JIT_R0, in); /* a */ - in = jit_arg_p(); - jit_getarg_p(JIT_R1, in); /* &name */ - CHECK_LIMIT(); - - /* Store the name where we can find it */ - mz_push_locals(); - mz_set_local_p(JIT_R1, JIT_LOCAL2); - - jit_prepare(1); - jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_module_start_finish); - CHECK_LIMIT(); - mz_pop_locals(); - jit_ret(); - CHECK_LIMIT(); - - scheme_jit_register_sub_func(jitter, sjc.module_start_start_code, scheme_eof); + scheme_jit_register_sub_func(jitter, sjc.linklet_run_start_code, scheme_eof); } /* *** thread_start_child_code *** */ @@ -4153,6 +4069,39 @@ static int more_common1(mz_jit_state *jitter, void *_data) } } + /* hash_ref_code */ + /* args are in R0, R1, R2 */ + { + GC_CAN_IGNORE jit_insn *ref USED_ONLY_FOR_FUTURES; + + sjc.hash_ref_code = jit_get_ip(); + + mz_prolog(JIT_R2); + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3)); + CHECK_RUNSTACK_OVERFLOW(); + jit_str_p(JIT_RUNSTACK, JIT_R0); + jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1); + jit_stxi_p(WORDS_TO_BYTES(2), JIT_RUNSTACK, JIT_R2); + JIT_UPDATE_THREAD_RSPTR(); + CHECK_LIMIT(); + + jit_movi_i(JIT_R1, 3); + jit_prepare(2); + jit_pusharg_p(JIT_RUNSTACK); + jit_pusharg_i(JIT_R1); + (void)mz_finish_lwe(ts_scheme_checked_hash_ref, ref); + CHECK_LIMIT(); + jit_retval(JIT_R0); + + jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3)); + JIT_UPDATE_THREAD_RSPTR(); + + mz_epilog(JIT_V1); + CHECK_LIMIT(); + + scheme_jit_register_sub_func(jitter, sjc.hash_ref_code, scheme_false); + } + #ifdef MZ_USE_LWC /* native_starter_code */ { diff --git a/racket/src/racket/src/jitinline.c b/racket/src/racket/src/jitinline.c index d7111d8cb3..3f334cda95 100644 --- a/racket/src/racket/src/jitinline.c +++ b/racket/src/racket/src/jitinline.c @@ -36,7 +36,7 @@ static Scheme_Object *equal_as_bool(Scheme_Object *a, Scheme_Object *b); #endif #include "jit_ts.c" -static Scheme_Object *equal_as_bool(Scheme_Object *a, Scheme_Object *b) +static Scheme_Object *equal_as_bool(Scheme_Object *a, Scheme_Object *b) XFORM_ASSERT_NO_CONVERSION { if (scheme_equal(a, b)) return scheme_true; @@ -272,6 +272,7 @@ static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec return 1; } +/* -1 for can_chaperone for `chaperone?` test */ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app, Scheme_Type lo_ty, Scheme_Type hi_ty, int can_chaperone, Branch_Info *for_branch, int branch_short, @@ -535,6 +536,77 @@ static int generate_inlined_immutable_test(mz_jit_state *jitter, Scheme_App2_Rec return 1; } +static int generate_inlined_char_category_test(mz_jit_state *jitter, Scheme_App2_Rec *app, int bit, + Branch_Info *for_branch, int branch_short, + int dest) +{ + GC_CAN_IGNORE jit_insn *reffail = NULL, *ref, *pref; + + LOG_IT(("inlined %s\n", ((Scheme_Primitive_Proc *)rator)->name)); + + mz_runstack_skipped(jitter, 1); + + scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); + CHECK_LIMIT(); + + mz_runstack_unskipped(jitter, 1); + + mz_rs_sync(); + + __START_SHORT_JUMPS__(branch_short); + + if (for_branch) { + scheme_prepare_branch_jump(jitter, for_branch); + CHECK_LIMIT(); + } + + pref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); + reffail = jit_get_ip(); + (void)jit_movi_p(JIT_R2, ((Scheme_Primitive_Proc *)app->rator)->prim_val); + __END_SHORT_JUMPS__(branch_short); + (void)jit_calli(sjc.call_original_unary_arith_code); + __START_SHORT_JUMPS__(branch_short); + mz_patch_branch(pref); + (void)mz_bnei_t(reffail, JIT_R0, scheme_char_type, JIT_R2); + + /* Extract character value */ + jit_ldxi_i(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0)); + + /* Lookup */ + jit_movi_p(JIT_R1, scheme_uchar_table); + jit_rshi_i(JIT_R2, JIT_R0, (SCHEME_UCHAR_FIND_SHIFT - JIT_LOG_WORD_SIZE)); + jit_andi_i(JIT_R2, JIT_R2, (SCHEME_UCHAR_FIND_HI_MASK << JIT_LOG_WORD_SIZE)); + jit_ldxr_p(JIT_R1, JIT_R1, JIT_R2); + jit_andi_i(JIT_R2, JIT_R0, SCHEME_UCHAR_FIND_LO_MASK); + jit_lshi_i(JIT_R2, JIT_R2, 1); /* 1 = log_2(sizeof(short)) */ + jit_ldxr_s(JIT_R1, JIT_R1, JIT_R2); + + /* JIT_R1 now has character-property bits */ + ref = jit_bmci_i(jit_forward(), JIT_R1, bit); + CHECK_LIMIT(); + + if (for_branch) { + scheme_add_branch_false(for_branch, ref); + scheme_branch_for_true(jitter, for_branch); + CHECK_LIMIT(); + } else { + GC_CAN_IGNORE jit_insn *ref2; + (void)jit_movi_p(dest, scheme_true); + __START_INNER_TINY__(branch_short); + ref2 = jit_jmpi(jit_forward()); + __END_INNER_TINY__(branch_short); + mz_patch_branch(ref); + (void)jit_movi_p(dest, scheme_false); + __START_INNER_TINY__(branch_short); + mz_patch_ucbranch(ref2); + __END_INNER_TINY__(branch_short); + } + + __END_SHORT_JUMPS__(branch_short); + + return 1; +} + static Scheme_Object *extract_struct_constant(mz_jit_state *jitter, Scheme_Object *rator) { if (SCHEME_PROCP(rator)) @@ -671,7 +743,9 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, (void)jit_calli(sjc.struct_prop_pred_code); } } else if (kind == INLINE_STRUCT_PROC_CONSTR) { - scheme_generate_struct_alloc(jitter, rand2 ? 2 : 1, 0, 0, is_tail, multi_ok, JIT_R0); + int check_proc; + check_proc = !extract_struct_constant(jitter, rator); + scheme_generate_struct_alloc(jitter, rand2 ? 2 : 1, 0, 0, check_proc, is_tail, multi_ok, JIT_R0); CHECK_LIMIT(); } else { scheme_signal_error("internal error: unknown struct-op mode"); @@ -837,6 +911,8 @@ static int generate_inlined_nary_struct_op(int kind, mz_jit_state *jitter, int is_tail, int multi_ok, int dest) /* de-sync'd ok; for branch, sync'd before */ { + int check_proc; + /* generate code to evaluate the arguments */ scheme_generate_app(app, NULL, app->num_args, app->num_args, jitter, 0, 0, 0, 1); CHECK_LIMIT(); @@ -844,8 +920,10 @@ static int generate_inlined_nary_struct_op(int kind, mz_jit_state *jitter, jit_movr_l(JIT_R0, JIT_V1); /* move rator to R0 */ + check_proc = !extract_struct_constant(jitter, rator); + /* arguments are now on the runstack, rator is in R0 */ - scheme_generate_struct_alloc(jitter, app->num_args, 0, 0, is_tail, multi_ok, dest); + scheme_generate_struct_alloc(jitter, app->num_args, 0, 0, check_proc, is_tail, multi_ok, dest); CHECK_LIMIT(); @@ -858,7 +936,7 @@ static int generate_inlined_nary_struct_op(int kind, mz_jit_state *jitter, } int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, - int inline_slow, int pop_and_jump, + int inline_slow, int pop_and_jump, int check_proc, int is_tail, int multi_ok, int dest) /* Rator is in R0. For unary case, R1 is argument. @@ -980,27 +1058,31 @@ int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, /* Continue trying fast path: check proc */ mz_patch_branch(ref); - (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); - jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); - (void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR); - CHECK_LIMIT(); + if (check_proc) { + (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); + jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); + (void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR); + CHECK_LIMIT(); + } jit_ldxi_p(JIT_R2, JIT_R0, &(SCHEME_PRIM_CLOSURE_ELS(0x0)[0])); /* R2 now has the Scheme_Struct_Type* */ - if (num_args != 2) { - /* V1 is available */ - jit_ldxi_i(JIT_V1, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); - if (num_args == -1) - (void)jit_bner_i(refslow, JIT_V1, JIT_R1); - else - (void)jit_bnei_i(refslow, JIT_V1, num_args); - } else { - /* No registers available, so we'll have to re-extract to R2 */ - jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); - (void)jit_bnei_i(refslow, JIT_R2, num_args); - jit_ldxi_p(JIT_R2, JIT_R0, &(SCHEME_PRIM_CLOSURE_ELS(0x0)[0])); + if (check_proc) { + if (num_args != 2) { + /* V1 is available */ + jit_ldxi_i(JIT_V1, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); + if (num_args == -1) + (void)jit_bner_i(refslow, JIT_V1, JIT_R1); + else + (void)jit_bnei_i(refslow, JIT_V1, num_args); + } else { + /* No registers available, so we'll have to re-extract to R2 */ + jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->num_slots); + (void)jit_bnei_i(refslow, JIT_R2, num_args); + jit_ldxi_p(JIT_R2, JIT_R0, &(SCHEME_PRIM_CLOSURE_ELS(0x0)[0])); + } } CHECK_LIMIT(); @@ -1229,6 +1311,9 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "syntax?")) { generate_inlined_type_test(jitter, app, scheme_stx_type, scheme_stx_type, 0, for_branch, branch_short, dest); return 1; + } else if(IS_NAMED_PRIM(rator, "variable-reference?")) { + generate_inlined_type_test(jitter, app, scheme_global_ref_type, scheme_global_ref_type, 0, for_branch, branch_short, dest); + return 1; } else if (IS_NAMED_PRIM(rator, "char?")) { generate_inlined_type_test(jitter, app, scheme_char_type, scheme_char_type, 0, for_branch, branch_short, dest); return 1; @@ -1286,6 +1371,12 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "path?")) { generate_inlined_type_test(jitter, app, SCHEME_PLATFORM_PATH_KIND, SCHEME_PLATFORM_PATH_KIND, 0, for_branch, branch_short, dest); return 1; + } else if (IS_NAMED_PRIM(rator, "hash?")) { + generate_inlined_type_test(jitter, app, scheme_hash_table_type, scheme_bucket_table_type, 1, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "syntax?")) { + generate_inlined_type_test(jitter, app, scheme_stx_type, scheme_stx_type, 0, for_branch, branch_short, dest); + return 1; } else if (IS_NAMED_PRIM(rator, "eof-object?")) { generate_inlined_constant_test(jitter, app, scheme_eof, NULL, for_branch, branch_short, dest); return 1; @@ -1307,6 +1398,9 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "immutable?")) { generate_inlined_immutable_test(jitter, app, for_branch, branch_short, dest); return 1; + } else if (IS_NAMED_PRIM(rator, "char-whitespace?")) { + generate_inlined_char_category_test(jitter, app, SCHEME_ISSPACE_BIT, for_branch, branch_short, dest); + return 1; } else if (IS_NAMED_PRIM(rator, "list?") || IS_NAMED_PRIM(rator, "list-pair?")) { int for_list_pair = 0; @@ -1339,7 +1433,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in CHECK_LIMIT(); /* We have a pair. Optimistically check for PAIR_IS_LIST: */ - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref6 = jit_bmsi_ul(jit_forward(), JIT_R2, PAIR_IS_LIST); if (for_branch) { @@ -1411,7 +1505,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in /* Check for positive bignum: */ __START_SHORT_JUMPS__(branch_short); ref2 = mz_bnei_t(jit_forward(), JIT_R0, scheme_bignum_type, JIT_R2); - jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); + jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)0x0)->iso)); ref3 = jit_bmci_ul(jit_forward(), JIT_R2, 0x1); __END_SHORT_JUMPS__(branch_short); /* Ok bignum. Instead of jumping, install the fixnum 1: */ @@ -1602,8 +1696,38 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in (void)jit_calli(sjc.list_length_code); jit_movr_p(dest, JIT_R0); + return 1; + } else if (IS_NAMED_PRIM(rator, "syntax-e")) { + GC_CAN_IGNORE jit_insn *reffail = NULL, *ref; + + LOG_IT("inlined syntax-e\n"); + + mz_runstack_skipped(jitter, 1); + + scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); + CHECK_LIMIT(); + + mz_runstack_unskipped(jitter, 1); + + mz_rs_sync_fail_branch(); + + __START_TINY_JUMPS__(1); + + ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); + reffail = jit_get_ip(); + __END_TINY_JUMPS__(1); + (void)jit_calli(sjc.bad_syntax_e_code); + __START_TINY_JUMPS__(1); + mz_patch_branch(ref); + (void)mz_bnei_t(reffail, JIT_R0, scheme_stx_type, JIT_R1); + (void)jit_ldxi_p(dest, JIT_R0, &(SCHEME_STX_VAL((Scheme_Stx *)0x0))); + VALIDATE_RESULT(dest); + CHECK_LIMIT(); + __END_TINY_JUMPS__(1); + return 1; } else if (IS_NAMED_PRIM(rator, "vector-length") + || IS_NAMED_PRIM(rator, "vector*-length") || IS_NAMED_PRIM(rator, "fxvector-length") || IS_NAMED_PRIM(rator, "unsafe-vector-length") || IS_NAMED_PRIM(rator, "unsafe-fxvector-length") @@ -1636,7 +1760,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in for_fl = 1; extfl = 1; unsafe = 1; - } else { + } else if (IS_NAMED_PRIM(rator, "vector-length")) { can_chaperone = 1; } @@ -1663,9 +1787,13 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in (void)jit_calli(sjc.bad_flvector_length_code)); } else if (for_fx) (void)jit_calli(sjc.bad_fxvector_length_code); - else { + else if (can_chaperone) { (void)jit_calli(sjc.bad_vector_length_code); /* can return with updated R0 */ + jit_retval(JIT_R0); + } else { + (void)jit_calli(sjc.bad_vector_star_length_code); + /* does not return */ } /* bad_vector_length_code may unpack a proxied object */ @@ -1754,8 +1882,14 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in jit_fixnum_l(dest, JIT_R0); return 1; - } else if (IS_NAMED_PRIM(rator, "unbox")) { + } else if (IS_NAMED_PRIM(rator, "unbox") + || IS_NAMED_PRIM(rator, "unbox*") + || IS_NAMED_PRIM(rator, "weak-box-value")) { GC_CAN_IGNORE jit_insn *reffail, *ref, *refdone; + int for_weak, for_star; + + for_weak = IS_NAMED_PRIM(rator, "weak-box-value"); + for_star = IS_NAMED_PRIM(rator, "unbox*"); LOG_IT(("inlined unbox\n")); @@ -1773,20 +1907,39 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in __END_TINY_JUMPS__(1); reffail = jit_get_ip(); - (void)jit_calli(sjc.unbox_code); - jit_movr_p(dest, JIT_R0); + if (for_weak) + (void)jit_calli(sjc.weak_box_value_code); /* always raises an exception */ + else if (for_star) + (void)jit_calli(sjc.unbox_star_fail_code); + else + (void)jit_calli(sjc.unbox_code); + if (!for_weak && !for_star) + jit_movr_p(dest, JIT_R0); __START_TINY_JUMPS__(1); - refdone = jit_jmpi(jit_forward()); + if (!for_weak && !for_star) + refdone = jit_jmpi(jit_forward()); + else + refdone = NULL; mz_patch_branch(ref); - (void)mz_bnei_t(reffail, JIT_R0, scheme_box_type, JIT_R1); + (void)mz_bnei_t(reffail, JIT_R0, (for_weak ? scheme_weak_box_type : scheme_box_type), JIT_R1); __END_TINY_JUMPS__(1); (void)jit_ldxi_p(dest, JIT_R0, &SCHEME_BOX_VAL(0x0)); - - __START_TINY_JUMPS__(1); - mz_patch_ucbranch(refdone); - __END_TINY_JUMPS__(1); + + if (for_weak) { + __START_TINY_JUMPS__(1); + ref = jit_bnei_p(jit_forward(), dest, NULL); + jit_movi_p(dest, scheme_false); + mz_patch_branch(ref); + __END_TINY_JUMPS__(1); + } + + if (!for_weak && !for_star) { + __START_TINY_JUMPS__(1); + mz_patch_ucbranch(refdone); + __END_TINY_JUMPS__(1); + } return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-unbox*")) { @@ -1832,22 +1985,6 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_patch_ucbranch(ref2); __END_TINY_JUMPS__(1); - return 1; - } else if (IS_NAMED_PRIM(rator, "syntax-e")) { - LOG_IT(("inlined syntax-e\n")); - - mz_runstack_skipped(jitter, 1); - - scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); - CHECK_LIMIT(); - - mz_runstack_unskipped(jitter, 1); - - mz_rs_sync(); - - (void)jit_calli(sjc.syntax_e_code); - jit_movr_p(dest, JIT_R0); - return 1; } else if (IS_NAMED_PRIM(rator, "imag-part") || IS_NAMED_PRIM(rator, "real-part") @@ -2219,6 +2356,50 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_patch_ucbranch(refdone); __END_TINY_JUMPS__(1); + return 1; + } else if (IS_NAMED_PRIM(rator, "prefab-struct-key")) { + GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3; + + mz_runstack_skipped(jitter, 1); + scheme_generate_non_tail(app->rand, jitter, 0, 1, 0); + CHECK_LIMIT(); + mz_runstack_unskipped(jitter, 1); + + mz_rs_sync(); + + jit_movi_p(JIT_R1, scheme_false); + + __START_SHORT_JUMPS__(1); + ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); + + /* check for chaperone: */ + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); + ref3 = jit_bnei_i(jit_forward(), JIT_R2, scheme_chaperone_type); + mz_patch_branch(ref2); + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAPERONE_VAL((Scheme_Object *)0x0)); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + mz_patch_branch(ref3); + CHECK_LIMIT(); + + /* check for structure: */ + ref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_structure_type); + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&((Scheme_Structure *)0x0)->stype); + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&((Scheme_Struct_Type *)0x0)->prefab_key); + ref3 = jit_beqi_p(jit_forward(), JIT_R0, NULL); + /* is a prefab; extract key */ + jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CDR(0x0)); + jit_movr_p(JIT_R1, JIT_R0); + CHECK_LIMIT(); + + mz_patch_branch(ref3); + mz_patch_branch(ref2); + mz_patch_branch(ref); + CHECK_LIMIT(); + __END_SHORT_JUMPS__(1); + + jit_movr_p(dest, JIT_R1); + return 1; } else if (IS_NAMED_PRIM(rator, "cpointer-tag")) { GC_CAN_IGNORE jit_insn *ref, *refslow, *refdone; @@ -2436,7 +2617,7 @@ int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ return direction; } -static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, +static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, int cmp, Branch_Info *for_branch, int branch_short, int dest) /* de-sync'd ok */ { @@ -2451,6 +2632,24 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, direction = scheme_generate_two_args(r1, r2, jitter, 0, 2); CHECK_LIMIT(); + if (direction < 0) { + /* reverse sense of comparison */ + switch (cmp) { + case CMP_LEQ: + cmp = CMP_GEQ; + break; + case CMP_GEQ: + cmp = CMP_LEQ; + break; + case CMP_GT: + cmp = CMP_LT; + break; + case CMP_LT: + cmp = CMP_GT; + break; + } + } + mz_rs_sync(); __START_SHORT_JUMPS__(branch_short); @@ -2503,13 +2702,39 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, CHECK_LIMIT(); } - if (!direct) { + if (!direct || (cmp != CMP_EQUAL)) { /* Extract character value */ jit_ldxi_i(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0)); jit_ldxi_i(JIT_R1, JIT_R1, (intptr_t)&SCHEME_CHAR_VAL((Scheme_Object *)0x0)); - ref = jit_bner_i(jit_forward(), JIT_R0, JIT_R1); + + switch (cmp) { + case CMP_EQUAL: + ref = jit_bner_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_LEQ: + ref = jit_bgtr_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_GEQ: + ref = jit_bltr_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_GT: + ref = jit_bler_i(jit_forward(), JIT_R0, JIT_R1); + break; + case CMP_LT: + ref = jit_bger_i(jit_forward(), JIT_R0, JIT_R1); + break; + default: + ref = NULL; /* never happens */ + } } else { - ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); + /* Equality on small chars can compare pointers */ + switch(cmp) { + case CMP_EQUAL: + ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); + break; + default: + ref = NULL; /* never happens */ + } } CHECK_LIMIT(); if (for_branch) { @@ -2564,9 +2789,12 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int (void)jit_calli(sjc.struct_raw_set_code); else if (for_fx) (void)jit_calli(sjc.fxvector_set_check_index_code); - else if (!for_fl) - (void)jit_calli(sjc.vector_set_check_index_code); - else if (unbox_flonum) + else if (!for_fl) { + if (can_chaperone) + (void)jit_calli(sjc.vector_set_check_index_code); + else + (void)jit_calli(sjc.vector_star_set_check_index_code); + } else if (unbox_flonum) (void)jit_calli(sjc.flvector_set_flonum_check_index_code[extfl]); else (void)jit_calli(sjc.flvector_set_check_index_code[extfl]); @@ -2575,9 +2803,12 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int (void)jit_calli(sjc.struct_raw_ref_code); else if (for_fx) (void)jit_calli(sjc.fxvector_ref_check_index_code); - else if (!for_fl) - (void)jit_calli(sjc.vector_ref_check_index_code); - else + else if (!for_fl) { + if (can_chaperone) + (void)jit_calli(sjc.vector_ref_check_index_code); + else + (void)jit_calli(sjc.vector_star_ref_check_index_code); + } else (void)jit_calli(sjc.flvector_ref_check_index_code[extfl]); } CHECK_LIMIT(); @@ -2798,7 +3029,9 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i if (!SCHEME_INTP(a1) && !SCHEME_FALSEP(a1) && !SCHEME_VOIDP(a1) - && !SAME_OBJ(a1, scheme_true)) { + && !SAME_OBJ(a1, scheme_true) + && !SAME_OBJ(a1, scheme_null) + && !SAME_OBJ(a1, scheme_undefined)) { scheme_mz_load_retained(jitter, JIT_R1, a1); ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); /* In case true is a fall-through, note that the test @@ -3269,7 +3502,19 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_BIT, 0, for_branch, branch_short, 0, 0, NULL, dest); return 1; } else if (IS_NAMED_PRIM(rator, "char=?")) { - generate_binary_char(jitter, app, for_branch, branch_short, dest); + generate_binary_char(jitter, app, CMP_EQUAL, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "char<=?")) { + generate_binary_char(jitter, app, CMP_LEQ, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "char>=?")) { + generate_binary_char(jitter, app, CMP_GEQ, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "char>?")) { + generate_binary_char(jitter, app, CMP_GT, for_branch, branch_short, dest); + return 1; + } else if (IS_NAMED_PRIM(rator, "charrand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); @@ -3859,9 +4110,15 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i if (ref3) mz_patch_branch(ref3); reffail = jit_get_ip(); - (void)jit_calli(sjc.set_box_code); - ref2 = jit_jmpi(jit_forward()); - mz_patch_branch(ref); + if (!for_star) + (void)jit_calli(sjc.set_box_code); + else + (void)jit_calli(sjc.set_box_star_fail_code); + if (!for_star) { + ref2 = jit_jmpi(jit_forward()); + mz_patch_branch(ref); + } else + ref2 = NULL; if (!unsafe) { jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)0x0)); (void)jit_bmsi_ul(reffail, JIT_R2, 0x1); @@ -3870,9 +4127,11 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i (void)jit_stxi_p(&SCHEME_BOX_VAL(0x0), JIT_R0, JIT_R1); - __START_TINY_JUMPS__(1); - mz_patch_ucbranch(ref2); - __END_TINY_JUMPS__(1); + if (!for_star) { + __START_TINY_JUMPS__(1); + mz_patch_ucbranch(ref2); + __END_TINY_JUMPS__(1); + } if (!result_ignored) (void)jit_movi_p(dest, scheme_void); @@ -4220,7 +4479,12 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (!SCHEME_PRIMP(rator)) return 0; - if (!(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_IS_NARY_INLINED)) + if (SAME_OBJ(rator, scheme_hash_ref_proc)) { + if ((app->num_args != 3) + || (SCHEME_TYPE(app->args[3]) < _scheme_values_types_) + || SCHEME_PROCP(app->args[3])) + return 0; + } else if (!(SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_IS_NARY_INLINED)) return 0; if (app->num_args < ((Scheme_Primitive_Proc *)rator)->mina) @@ -4383,6 +4647,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int return 1; } else if (!for_branch) { if (IS_NAMED_PRIM(rator, "vector-set!") + || IS_NAMED_PRIM(rator, "vector*-set!") || IS_NAMED_PRIM(rator, "unsafe-vector-set!") || IS_NAMED_PRIM(rator, "unsafe-vector*-set!") || IS_NAMED_PRIM(rator, "flvector-set!") @@ -4406,6 +4671,10 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (IS_NAMED_PRIM(rator, "vector-set!")) { which = 0; check_mutable = 1; + } else if (IS_NAMED_PRIM(rator, "vector*-set!")) { + which = 0; + can_chaperone = 0; + check_mutable = 1; } else if (IS_NAMED_PRIM(rator, "fxvector-set!")) { which = 0; for_fx = 1; @@ -5216,6 +5485,51 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (!is_ref && !result_ignored) (void)jit_movi_p(dest, scheme_void); + return 1; + } else if (IS_NAMED_PRIM(rator, "hash-ref")) { + GC_CAN_IGNORE jit_insn *refdone0, *refdone, *refslow; + + /* We only get here is we have three arguments with the last as a + non-procedure constant */ + + scheme_generate_two_args(app->args[1], app->args[2], jitter, 1, 3); + CHECK_LIMIT(); + + mz_rs_sync(); + + /* Jump to slow path for anything other than an immutable hasheq */ + __START_SHORT_JUMPS__(1); + refslow = mz_bnei_t(jit_forward(), JIT_R0, scheme_eq_hash_tree_type, JIT_R2); + __END_SHORT_JUMPS__(1); + + /* scheme_eq_hash_tree_get doesn't trigger a GC */ + jit_prepare(2); + jit_pusharg_p(JIT_R1); + jit_pusharg_p(JIT_R0); + (void)jit_finish(scheme_eq_hash_tree_get); + jit_retval(dest); + + __START_SHORT_JUMPS__(1); + refdone0 = jit_bnei_p(jit_forward(), dest, NULL); + scheme_mz_load_retained(jitter, dest, app->args[3]); + CHECK_LIMIT(); + + refdone = jit_jmpi(jit_forward()); + + /* slow path */ + mz_patch_branch(refslow); + __END_SHORT_JUMPS__(1); + + scheme_mz_load_retained(jitter, JIT_R2, app->args[3]); + (void)jit_calli(sjc.hash_ref_code); + jit_movr_p(dest, JIT_R0); + CHECK_LIMIT(); + + __START_SHORT_JUMPS__(1); + mz_patch_branch(refdone0); + mz_patch_ucbranch(refdone); + __END_SHORT_JUMPS__(1); + return 1; } } diff --git a/racket/src/racket/src/jitprep.c b/racket/src/racket/src/jitprep.c index bb0bfc0a7b..807bed567d 100644 --- a/racket/src/racket/src/jitprep.c +++ b/racket/src/racket/src/jitprep.c @@ -35,7 +35,7 @@ #ifdef MZ_USE_JIT -static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit); +static Scheme_Object *jit_expr(Scheme_Object *expr); static Scheme_Object *jit_application(Scheme_Object *o) { @@ -48,7 +48,7 @@ static Scheme_Object *jit_application(Scheme_Object *o) for (i = 0; i < n; i++) { orig = app->args[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (!SAME_OBJ(orig, naya)) break; } @@ -65,7 +65,7 @@ static Scheme_Object *jit_application(Scheme_Object *o) for (i++; i < n; i++) { orig = app2->args[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); app2->args[i] = naya; } @@ -79,8 +79,8 @@ static Scheme_Object *jit_application2(Scheme_Object *o) app = (Scheme_App2_Rec *)o; - nrator = scheme_jit_expr(app->rator); - nrand = scheme_jit_expr(app->rand); + nrator = jit_expr(app->rator); + nrand = jit_expr(app->rand); if (SAME_OBJ(nrator, app->rator) && SAME_OBJ(nrand, app->rand)) @@ -101,9 +101,9 @@ static Scheme_Object *jit_application3(Scheme_Object *o) app = (Scheme_App3_Rec *)o; - nrator = scheme_jit_expr(app->rator); - nrand1 = scheme_jit_expr(app->rand1); - nrand2 = scheme_jit_expr(app->rand2); + nrator = jit_expr(app->rator); + nrand1 = jit_expr(app->rand1); + nrand2 = jit_expr(app->rand2); if (SAME_OBJ(nrator, app->rator) && SAME_OBJ(nrand1, app->rand1) @@ -130,7 +130,7 @@ static Scheme_Object *jit_sequence(Scheme_Object *o) for (i = 0; i < n; i++) { orig = seq->array[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (!SAME_OBJ(orig, naya)) break; } @@ -146,7 +146,7 @@ static Scheme_Object *jit_sequence(Scheme_Object *o) for (i++; i < n; i++) { orig = seq2->array[i]; - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); seq2->array[i] = naya; } @@ -160,9 +160,9 @@ static Scheme_Object *jit_branch(Scheme_Object *o) b = (Scheme_Branch_Rec *)o; - t = scheme_jit_expr(b->test); - tb = scheme_jit_expr(b->tbranch); - fb = scheme_jit_expr(b->fbranch); + t = jit_expr(b->test); + tb = jit_expr(b->tbranch); + fb = jit_expr(b->fbranch); if (SAME_OBJ(t, b->test) && SAME_OBJ(tb, b->tbranch) @@ -183,8 +183,8 @@ static Scheme_Object *jit_let_value(Scheme_Object *o) Scheme_Let_Value *lv = (Scheme_Let_Value *)o; Scheme_Object *body, *rhs; - rhs = scheme_jit_expr(lv->value); - body = scheme_jit_expr(lv->body); + rhs = jit_expr(lv->value); + body = jit_expr(lv->body); if (SAME_OBJ(rhs, lv->value) && SAME_OBJ(body, lv->body)) @@ -203,8 +203,8 @@ static Scheme_Object *jit_let_one(Scheme_Object *o) Scheme_Let_One *lo = (Scheme_Let_One *)o; Scheme_Object *body, *rhs; - rhs = scheme_jit_expr(lo->value); - body = scheme_jit_expr(lo->body); + rhs = jit_expr(lo->value); + body = jit_expr(lo->body); if (SAME_OBJ(rhs, lo->value) && SAME_OBJ(body, lo->body)) @@ -223,7 +223,7 @@ static Scheme_Object *jit_let_void(Scheme_Object *o) Scheme_Let_Void *lv = (Scheme_Let_Void *)o; Scheme_Object *body; - body = scheme_jit_expr(lv->body); + body = jit_expr(lv->body); if (SAME_OBJ(body, lv->body)) return o; @@ -255,7 +255,7 @@ static Scheme_Object *jit_letrec(Scheme_Object *o) procs2[i] = v; } - v = scheme_jit_expr(lr->body); + v = jit_expr(lr->body); lr2->body = v; return (Scheme_Object *)lr2; @@ -266,9 +266,9 @@ static Scheme_Object *jit_wcm(Scheme_Object *o) Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - k = scheme_jit_expr(wcm->key); - v = scheme_jit_expr(wcm->val); - b = scheme_jit_expr(wcm->body); + k = jit_expr(wcm->key); + v = jit_expr(wcm->val); + b = jit_expr(wcm->body); if (SAME_OBJ(wcm->key, k) && SAME_OBJ(wcm->val, v) && SAME_OBJ(wcm->body, b)) @@ -300,26 +300,26 @@ static Scheme_Object *clone_inline_variant(Scheme_Object *obj, Scheme_Object *na static Scheme_Object *define_values_jit(Scheme_Object *data) { - Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya; + Scheme_Object *orig = SCHEME_DEFN_RHS(data), *naya; if (SAME_TYPE(SCHEME_TYPE(orig), scheme_lambda_type) - && (SCHEME_VEC_SIZE(data) == 2)) - naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]); + && (SCHEME_DEFN_VAR_COUNT(data) == 1)) + naya = scheme_jit_closure(orig, SCHEME_DEFN_VAR_(data, 0)); else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type) && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_lambda_type) - && (SCHEME_VEC_SIZE(data) == 2)) { - naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_VEC_ELS(data)[1]); - if (!SAME_OBJ(naya, SCHEME_VEC_ELS(orig)[0])) + && (SCHEME_DEFN_VAR_COUNT(data) == 1)) { + naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_DEFN_VAR_(data, 0)); + if (!SAME_OBJ(naya, SCHEME_DEFN_RHS(orig))) naya = clone_inline_variant(orig, naya); } else - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (SAME_OBJ(naya, orig)) return data; else { orig = naya; naya = scheme_clone_vector(data, 0, 1); - SCHEME_VEC_ELS(naya)[0] = orig; + SCHEME_DEFN_RHS(naya) = orig; return naya; } } @@ -329,7 +329,7 @@ static Scheme_Object *inline_variant_jit(Scheme_Object *data) Scheme_Object *a, *orig; orig = SCHEME_VEC_ELS(data)[0]; - a = scheme_jit_expr(orig); + a = jit_expr(orig); if (!SAME_OBJ(a, orig)) return clone_inline_variant(data, a); else @@ -343,7 +343,7 @@ static Scheme_Object *set_jit(Scheme_Object *data) orig_val = sb->val; - naya_val = scheme_jit_expr(orig_val); + naya_val = jit_expr(orig_val); if (SAME_OBJ(naya_val, orig_val)) return data; @@ -364,8 +364,8 @@ static Scheme_Object *apply_values_jit(Scheme_Object *data) { Scheme_Object *f, *e; - f = scheme_jit_expr(SCHEME_PTR1_VAL(data)); - e = scheme_jit_expr(SCHEME_PTR2_VAL(data)); + f = jit_expr(SCHEME_PTR1_VAL(data)); + e = jit_expr(SCHEME_PTR2_VAL(data)); if (SAME_OBJ(f, SCHEME_PTR1_VAL(data)) && SAME_OBJ(e, SCHEME_PTR2_VAL(data))) @@ -384,9 +384,9 @@ static Scheme_Object *with_immed_mark_jit(Scheme_Object *o) Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - k = scheme_jit_expr(wcm->key); - v = scheme_jit_expr(wcm->val); - b = scheme_jit_expr(wcm->body); + k = jit_expr(wcm->key); + v = jit_expr(wcm->val); + b = jit_expr(wcm->body); if (SAME_OBJ(wcm->key, k) && SAME_OBJ(wcm->val, v) && SAME_OBJ(wcm->body, b)) @@ -482,7 +482,7 @@ static Scheme_Object *bangboxenv_jit(Scheme_Object *data) Scheme_Object *orig, *naya, *new_data; orig = SCHEME_PTR2_VAL(data); - naya = scheme_jit_expr(orig); + naya = jit_expr(orig); if (SAME_OBJ(naya, orig)) return data; else { @@ -503,7 +503,7 @@ static Scheme_Object *begin0_jit(Scheme_Object *data) count = seq->count; for (i = 0; i < count; i++) { old = seq->array[i]; - naya = scheme_jit_expr(old); + naya = jit_expr(old); if (!SAME_OBJ(old, naya)) break; } @@ -522,23 +522,13 @@ static Scheme_Object *begin0_jit(Scheme_Object *data) seq2->array[i] = naya; for (i++; i < count; i++) { old = seq->array[i]; - naya = scheme_jit_expr(old); + naya = jit_expr(old); seq2->array[i] = naya; } return (Scheme_Object *)seq2; } -static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr) -{ - return do_define_syntaxes_clone(expr, 1); -} - -static Scheme_Object *begin_for_syntax_jit(Scheme_Object *expr) -{ - return do_define_syntaxes_clone(expr, 1); -} - /*========================================================================*/ /* closures */ /*========================================================================*/ @@ -589,7 +579,7 @@ Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context) /* expressions */ /*========================================================================*/ -Scheme_Object *scheme_jit_expr(Scheme_Object *expr) +static Scheme_Object *jit_expr(Scheme_Object *expr) { Scheme_Type type = SCHEME_TYPE(expr); @@ -601,7 +591,6 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr) case scheme_application3_type: return jit_application3(expr); case scheme_sequence_type: - case scheme_splice_sequence_type: return jit_sequence(expr); case scheme_branch_type: return jit_branch(expr); @@ -632,18 +621,12 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr) } case scheme_define_values_type: return define_values_jit(expr); - case scheme_define_syntaxes_type: - return define_syntaxes_jit(expr); - case scheme_begin_for_syntax_type: - return begin_for_syntax_jit(expr); case scheme_set_bang_type: return set_jit(expr); case scheme_boxenv_type: return bangboxenv_jit(expr); case scheme_begin0_sequence_type: return begin0_jit(expr); - case scheme_require_form_type: - return scheme_top_level_require_jit(expr); case scheme_varref_form_type: return ref_jit(expr); case scheme_apply_values_type: @@ -652,8 +635,6 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr) return with_immed_mark_jit(expr); case scheme_case_lambda_sequence_type: return scheme_case_lambda_jit(expr); - case scheme_module_type: - return scheme_module_jit(expr); case scheme_inline_variant_type: return inline_variant_jit(expr); default: @@ -661,60 +642,47 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr) } } +Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *linklet, int step) +/* step 1: clone the immediate record, to be mutated for actual prepataion + step 2: actual preparation */ +{ + Scheme_Linklet *new_linklet; + Scheme_Object *bodies, *v; + int i; + + if (!linklet->jit_ready) { + new_linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + memcpy(new_linklet, linklet, sizeof(Scheme_Linklet)); + } else + new_linklet = linklet; + + if (new_linklet->jit_ready >= step) + return new_linklet; + + if (step == 1) { + new_linklet->jit_ready = 1; + return new_linklet; + } + + i = SCHEME_VEC_SIZE(linklet->bodies); + bodies = scheme_make_vector(i, NULL); + while (i--) { + v = jit_expr(SCHEME_VEC_ELS(linklet->bodies)[i]); + SCHEME_VEC_ELS(bodies)[i] = v; + } + + new_linklet->bodies = bodies; + + new_linklet->jit_ready = 2; + + return new_linklet; +} + #else -Scheme_Object *scheme_jit_expr(Scheme_Object *expr) +Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *linklet, int step) { - return expr; + return linklet; } #endif - -static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit) -{ - Resolve_Prefix *rp, *orig_rp; - Scheme_Object *naya, *rhs; - - rhs = SCHEME_VEC_ELS(expr)[0]; -#ifdef MZ_USE_JIT - if (jit) { - if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type)) - naya = scheme_jit_expr(rhs); - else { - int changed = 0; - Scheme_Object *a, *l = rhs; - naya = scheme_null; - while (!SCHEME_NULLP(l)) { - a = scheme_jit_expr(SCHEME_CAR(l)); - if (!SAME_OBJ(a, SCHEME_CAR(l))) - changed = 1; - naya = scheme_make_pair(a, naya); - l = SCHEME_CDR(l); - } - if (changed) - naya = scheme_reverse(naya); - else - naya = rhs; - } - } else -#endif - naya = rhs; - - orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1]; - rp = scheme_prefix_eval_clone(orig_rp); - - if (SAME_OBJ(naya, rhs) - && SAME_OBJ(orig_rp, rp)) - return expr; - else { - expr = scheme_clone_vector(expr, 0, 1); - SCHEME_VEC_ELS(expr)[0] = naya; - SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp; - return expr; - } -} - -Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *expr) -{ - return do_define_syntaxes_clone(expr, 0); -} diff --git a/racket/src/racket/src/jitstack.c b/racket/src/racket/src/jitstack.c index 309e01dedb..aa25395954 100644 --- a/racket/src/racket/src/jitstack.c +++ b/racket/src/racket/src/jitstack.c @@ -198,7 +198,8 @@ Scheme_Object *scheme_native_stack_trace(void) } #ifdef MZ_USE_DWARF_LIBUNWIND - unw_getcontext(&cx); + if (unw_getcontext(&cx) != 0) + return NULL; unw_init_local(&c, &cx); unw_set_safe_pointer_range(&c, stack_start, real_stack_end); use_unw = 1; @@ -694,36 +695,16 @@ void scheme_jit_now(Scheme_Object *f) } -typedef void *(*Module_Run_Proc)(Scheme_Env *menv, Scheme_Env *env, Scheme_Object **name); -typedef void *(*Module_Exprun_Proc)(Scheme_Env *menv, int set_ns, Scheme_Object **name); -typedef void *(*Module_Start_Proc)(struct Start_Module_Args *a, Scheme_Object **name); +typedef Scheme_Object *(*Linklet_Run_Proc)(Scheme_Linklet *linklet, Scheme_Instance *inst, Scheme_Object **name); typedef void (*Thread_Start_Child_Proc)(Scheme_Thread *child, Scheme_Object *child_thunk); -void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name) +Scheme_Object *scheme_linklet_run_start(Scheme_Linklet *linklet, Scheme_Instance *inst, Scheme_Object *name) { - Module_Run_Proc proc = (Module_Run_Proc)sjc.module_run_start_code; + Linklet_Run_Proc proc = (Linklet_Run_Proc)sjc.linklet_run_start_code; if (proc && !CHECK_RUNSTACK_REGISTER_UPDATE) - return proc(menv, env, &name); + return proc(linklet, inst, &name); else - return scheme_module_run_finish(menv, env); -} - -void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name) -{ - Module_Exprun_Proc proc = (Module_Exprun_Proc)sjc.module_exprun_start_code; - if (proc && !CHECK_RUNSTACK_REGISTER_UPDATE) - return proc(menv, set_ns, &name); - else - return scheme_module_exprun_finish(menv, set_ns); -} - -void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name) -{ - Module_Start_Proc proc = (Module_Start_Proc)sjc.module_start_start_code; - if (proc && !CHECK_RUNSTACK_REGISTER_UPDATE) - return proc(a, &name); - else - return scheme_module_start_finish(a); + return scheme_linklet_run_finish(linklet, inst, 1); } void scheme_thread_start_child(Scheme_Thread *child, Scheme_Object *child_thunk) diff --git a/racket/src/racket/src/jitstate.c b/racket/src/racket/src/jitstate.c index 1af76c4f40..107a4ad46a 100644 --- a/racket/src/racket/src/jitstate.c +++ b/racket/src/racket/src/jitstate.c @@ -93,7 +93,8 @@ void scheme_mz_load_retained(mz_jit_state *jitter, int rs, void *obj) && !SAME_OBJ((Scheme_Object *)obj, scheme_true) && !SAME_OBJ((Scheme_Object *)obj, scheme_false) && !SAME_OBJ((Scheme_Object *)obj, scheme_void) - && !SAME_OBJ((Scheme_Object *)obj, scheme_null)) { + && !SAME_OBJ((Scheme_Object *)obj, scheme_null) + && !SAME_OBJ((Scheme_Object *)obj, scheme_undefined)) { #ifdef JIT_PRECISE_GC int retptr; void *p; diff --git a/racket/src/racket/src/letrec_check.c b/racket/src/racket/src/letrec_check.c index b2ec468b99..3c811b85e6 100644 --- a/racket/src/racket/src/letrec_check.c +++ b/racket/src/racket/src/letrec_check.c @@ -814,14 +814,11 @@ static Scheme_Object *letrec_check_define_values(Scheme_Object *lam, Letrec_Chec if (SCHEME_VEC_SIZE(lam) <= 1) return lam; else { - Scheme_Object *vars = SCHEME_VEC_ELS(lam)[0]; - Scheme_Object *val = SCHEME_VEC_ELS(lam)[1]; - SCHEME_ASSERT(SCHEME_PAIRP(vars) || SCHEME_NULLP(vars), - "letrec_check_define_values: processing resolved code"); + Scheme_Object *val = SCHEME_VEC_ELS(lam)[0]; val = letrec_check_expr(val, frame, pos); - SCHEME_VEC_ELS(lam)[1] = val; + SCHEME_VEC_ELS(lam)[0] = val; } return lam; @@ -882,33 +879,6 @@ static Scheme_Object *letrec_check_set(Scheme_Object *o, Letrec_Check_Frame *fra return o; } -static Scheme_Object *letrec_check_define_syntaxes(Scheme_Object *lam, Letrec_Check_Frame *frame, Scheme_Object *pos) -{ - Scheme_Object *val; - val = SCHEME_VEC_ELS(lam)[3]; - - val = letrec_check_expr(val, frame, pos); - SCHEME_VEC_ELS(lam)[3] = val; - - return lam; -} - -static Scheme_Object *letrec_check_begin_for_syntax(Scheme_Object *lam, Letrec_Check_Frame *frame, Scheme_Object *pos) -{ - Scheme_Object *l, *a, *val; - - l = SCHEME_VEC_ELS(lam)[2]; - - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - val = letrec_check_expr(a, frame, pos); - SCHEME_CAR(l) = val; - l = SCHEME_CDR(l); - } - - return lam; -} - static Scheme_Object *letrec_check_case_lambda(Scheme_Object *o, Letrec_Check_Frame *frame, Scheme_Object *pos) { Scheme_Case_Lambda *cl; @@ -959,43 +929,6 @@ static Scheme_Object *letrec_check_apply_values(Scheme_Object *lam, Letrec_Check return lam; } -static Scheme_Object *letrec_check_module(Scheme_Object *o, Letrec_Check_Frame *frame, Scheme_Object *pos) -{ - int i, cnt; - Scheme_Module *m; - Scheme_Object *val; - m = (Scheme_Module *)o; - - if (!m->comp_prefix) { - /* already resolved */ - return (Scheme_Object *)m; - } - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - for(i = 0; i < cnt; i++) { - val = SCHEME_VEC_ELS(m->bodies[0])[i]; - val = letrec_check_expr(val, frame, pos); - SCHEME_VEC_ELS(m->bodies[0])[i] = val; - } - - { - /* check submodules */ - int k; - Scheme_Object *p; - for (k = 0; k < 2; k++) { - p = (k ? m->post_submodules : m->pre_submodules); - if (p) { - while (!SCHEME_NULLP(p)) { - letrec_check_expr(SCHEME_CAR(p), frame, pos); - p = SCHEME_CDR(p); - } - } - } - } - - return o; -} - static Scheme_Object *letrec_check_k(void) { Scheme_Thread *p = scheme_current_thread; @@ -1041,7 +974,6 @@ static Scheme_Object *letrec_check_expr(Scheme_Object *expr, Letrec_Check_Frame case scheme_application3_type: return letrec_check_application3(expr, frame, pos); case scheme_sequence_type: - case scheme_splice_sequence_type: return letrec_check_sequence(expr, frame, pos); case scheme_branch_type: return letrec_check_branch(expr, frame, pos); @@ -1053,10 +985,7 @@ static Scheme_Object *letrec_check_expr(Scheme_Object *expr, Letrec_Check_Frame return letrec_check_lets(expr, frame, pos); case scheme_ir_toplevel_type: /* var ref to a top level */ return expr; - case scheme_ir_quote_syntax_type: - return expr; case scheme_variable_type: - case scheme_module_variable_type: scheme_signal_error("got top-level in wrong place"); return 0; case scheme_define_values_type: @@ -1065,10 +994,6 @@ static Scheme_Object *letrec_check_expr(Scheme_Object *expr, Letrec_Check_Frame return letrec_check_ref(expr, frame, pos); case scheme_set_bang_type: return letrec_check_set(expr, frame, pos); - case scheme_define_syntaxes_type: - return letrec_check_define_syntaxes(expr, frame, pos); - case scheme_begin_for_syntax_type: - return letrec_check_begin_for_syntax(expr, frame, pos); case scheme_case_lambda_sequence_type: return letrec_check_case_lambda(expr, frame, pos); case scheme_begin0_sequence_type: @@ -1078,17 +1003,14 @@ static Scheme_Object *letrec_check_expr(Scheme_Object *expr, Letrec_Check_Frame case scheme_with_immed_mark_type: scheme_signal_error("internal error: with-immediate-mark not expected before optimization"); return NULL; - case scheme_require_form_type: - return expr; - case scheme_module_type: - return letrec_check_module(expr, frame, pos); default: return expr; } } -Scheme_Object *scheme_letrec_check_expr(Scheme_Object *expr) +Scheme_Linklet *scheme_letrec_check_linklet(Scheme_Linklet *linklet) { + int i, cnt; Scheme_Object *val; Scheme_Object *init_pos = scheme_false; Letrec_Check_Frame *frame; @@ -1105,11 +1027,16 @@ Scheme_Object *scheme_letrec_check_expr(Scheme_Object *expr) positions. We use a list of numbers for the RHS of a `let[rec]-values` form with multiple variables. */ - val = letrec_check_expr(expr, frame, init_pos); + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for(i = 0; i < cnt; i++) { + val = SCHEME_VEC_ELS(linklet->bodies)[i]; + val = letrec_check_expr(val, frame, init_pos); + SCHEME_VEC_ELS(linklet->bodies)[i] = val; + } clean_dead_deferred_expr(*frame->deferred_chain); - return val; + return linklet; } /*========================================================================*/ diff --git a/racket/src/racket/src/linklet.c b/racket/src/racket/src/linklet.c new file mode 100644 index 0000000000..bc4e480df7 --- /dev/null +++ b/racket/src/racket/src/linklet.c @@ -0,0 +1,1655 @@ +/* + Racket + Copyright (c) 2004-2016 PLT Design Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library 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 distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" +#include "schrunst.h" + +READ_ONLY Scheme_Object *scheme_varref_const_p_proc; +READ_ONLY Scheme_Object *scheme_varref_unsafe_p_proc; + +SHARED_OK Scheme_Hash_Tree *empty_hash_tree; + +SHARED_OK static int validate_compile_result = 0; +SHARED_OK static int recompile_every_compile = 0; + +static Scheme_Object *constant_symbol; +static Scheme_Object *consistent_symbol; +static Scheme_Object *noncm_symbol; +static Scheme_Object *immediate_symbol; +static Scheme_Object *omitable_symbol; +static Scheme_Object *folding_symbol; + +THREAD_LOCAL_DECL(Scheme_Hash_Table *local_primitive_tables); + +static Scheme_Object *primitive_table(int argc, Scheme_Object **argv); +static Scheme_Object *primitive_to_position(int argc, Scheme_Object **argv); +static Scheme_Object *position_to_primitive(int argc, Scheme_Object **argv); +static Scheme_Object *primitive_in_category_p(int argc, Scheme_Object **argv); + +static Scheme_Object *linklet_p(int argc, Scheme_Object **argv); +static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *eval_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *read_compiled_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *instantiate_linklet(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_import_variables(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_export_variables(int argc, Scheme_Object **argv); + +static Scheme_Object *instance_p(int argc, Scheme_Object **argv); +static Scheme_Object *make_instance(int argc, Scheme_Object **argv); +static Scheme_Object *instance_name(int argc, Scheme_Object **argv); +static Scheme_Object *instance_data(int argc, Scheme_Object **argv); +static Scheme_Object *instance_variable_names(int argc, Scheme_Object **argv); +static Scheme_Object *instance_variable_value(int argc, Scheme_Object **argv); +static Scheme_Object *instance_set_variable_value(int argc, Scheme_Object **argv); +static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv); + +static Scheme_Object *linklet_directory_p(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_directory_to_hash(int argc, Scheme_Object **argv); +static Scheme_Object *hash_to_linklet_directory(int argc, Scheme_Object **argv); + +static Scheme_Object *linklet_bundle_p(int argc, Scheme_Object **argv); +static Scheme_Object *linklet_bundle_to_hash(int argc, Scheme_Object **argv); +static Scheme_Object *hash_to_linklet_bundle(int argc, Scheme_Object **argv); + +static Scheme_Object *variable_p(int argc, Scheme_Object **argv); +static Scheme_Object *variable_instance(int argc, Scheme_Object **argv); +static Scheme_Object *variable_const_p(int argc, Scheme_Object **argv); +static Scheme_Object *variable_unsafe_p(int argc, Scheme_Object **argv); + +static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Scheme_Linklet *linklet, + Scheme_Object *name, + Scheme_Object **_import_keys, + Scheme_Object *get_import, + int unsafe_mode); + +static Scheme_Object *_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt); + +static Scheme_Hash_Tree *push_prefix(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + Scheme_Hash_Tree *source_names); +static void pop_prefix(); +static Scheme_Object *suspend_prefix(); +static void resume_prefix(Scheme_Object *v); + +static Scheme_Bucket *make_bucket(Scheme_Object *key, Scheme_Object *val, Scheme_Instance *inst); + +#ifdef MZ_PRECISE_GC +static void mark_pruned_prefixes(struct NewGC *gc); +static int check_pruned_prefix(void *p); +#endif + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +/*========================================================================*/ +/* initialization */ +/*========================================================================*/ + +void scheme_init_linklet(Scheme_Startup_Env *env) +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif + + REGISTER_SO(constant_symbol); + REGISTER_SO(consistent_symbol); + constant_symbol = scheme_intern_symbol("constant"); + consistent_symbol = scheme_intern_symbol("consistent"); + + REGISTER_SO(noncm_symbol); + REGISTER_SO(immediate_symbol); + REGISTER_SO(omitable_symbol); + REGISTER_SO(folding_symbol); + noncm_symbol = scheme_intern_symbol("noncm"); + immediate_symbol = scheme_intern_symbol("immediate"); + omitable_symbol = scheme_intern_symbol("omitable"); + folding_symbol = scheme_intern_symbol("folding"); + + scheme_switch_prim_instance(env, "#%linklet"); + + ADD_IMMED_PRIM("primitive->compiled-position", primitive_to_position, 1, 1, env); + ADD_IMMED_PRIM("compiled-position->primitive", position_to_primitive, 1, 1, env); + ADD_IMMED_PRIM("primitive-in-category?", primitive_in_category_p, 2, 2, env); + + ADD_FOLDING_PRIM("linklet?", linklet_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY2("compile-linklet", compile_linklet, 1, 6, 2, 2, env); + ADD_PRIM_W_ARITY2("recompile-linklet", recompile_linklet, 1, 4, 2, 2, env); + ADD_IMMED_PRIM("eval-linklet", eval_linklet, 1, 1, env); + ADD_PRIM_W_ARITY("read-compiled-linklet", read_compiled_linklet, 1, 1, env); + ADD_PRIM_W_ARITY2("instantiate-linklet", instantiate_linklet, 2, 4, 0, -1, env); + ADD_PRIM_W_ARITY("linklet-import-variables", linklet_import_variables, 1, 1, env); + ADD_PRIM_W_ARITY("linklet-export-variables", linklet_export_variables, 1, 1, env); + + ADD_FOLDING_PRIM("instance?", instance_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("make-instance", make_instance, 1, -1, env); + ADD_PRIM_W_ARITY("instance-name", instance_name, 1, 1, env); + ADD_PRIM_W_ARITY("instance-data", instance_data, 1, 1, env); + ADD_PRIM_W_ARITY("instance-variable-names", instance_variable_names, 1, 1, env); + ADD_PRIM_W_ARITY2("instance-variable-value", instance_variable_value, 2, 3, 0, -1, env); + ADD_PRIM_W_ARITY("instance-set-variable-value!", instance_set_variable_value, 3, 4, env); + ADD_PRIM_W_ARITY("instance-unset-variable!", instance_unset_variable, 2, 2, env); + + ADD_FOLDING_PRIM("linklet-directory?", linklet_directory_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("hash->linklet-directory", hash_to_linklet_directory, 1, 1, env); + ADD_PRIM_W_ARITY("linklet-directory->hash", linklet_directory_to_hash, 1, 1, env); + + ADD_FOLDING_PRIM("linklet-bundle?", linklet_bundle_p, 1, 1, 1, env); + ADD_PRIM_W_ARITY("hash->linklet-bundle", hash_to_linklet_bundle, 1, 1, env); + ADD_PRIM_W_ARITY("linklet-bundle->hash", linklet_bundle_to_hash, 1, 1, env); + + ADD_FOLDING_PRIM_UNARY_INLINED("variable-reference?", variable_p, 1, 1, 1, env); + ADD_IMMED_PRIM("variable-reference->instance", variable_instance, 1, 2, env); + + REGISTER_SO(scheme_varref_const_p_proc); + scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p, + "variable-reference-constant?", + 1, 1); + scheme_addto_prim_instance("variable-reference-constant?", scheme_varref_const_p_proc, env); + + REGISTER_SO(scheme_varref_unsafe_p_proc); + scheme_varref_unsafe_p_proc = scheme_make_prim_w_arity(variable_unsafe_p, + "variable-reference-from-unsafe?", + 1, 1); + scheme_addto_prim_instance("variable-reference-from-unsafe?", scheme_varref_unsafe_p_proc, env); + + scheme_restore_prim_instance(env); + + if (scheme_getenv("PLT_VALIDATE_COMPILE")) { + /* Enables validation of bytecode as it is generated, + to double-check that the compiler is producing + valid bytecode as it should. */ + validate_compile_result = 1; + } + + { + /* Enables re-running the optimizer N times on every compilation. */ + const char *s; + s = scheme_getenv("PLT_RECOMPILE_COMPILE"); + if (s) { + int i = 0; + while ((s[i] >= '0') && (s[i] <= '9')) { + recompile_every_compile = (recompile_every_compile * 10) + (s[i]-'0'); + i++; + } + if (recompile_every_compile <= 0) + recompile_every_compile = 1; + else if (recompile_every_compile > 32) + recompile_every_compile = 32; + } + } +} + +void scheme_init_unsafe_linklet(Scheme_Startup_Env *env) +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif + + scheme_switch_prim_instance(env, "#%linklet"); + + ADD_IMMED_PRIM("primitive-table", primitive_table, 1, 2, env); + + scheme_restore_prim_instance(env); +} + +void scheme_init_linklet_places(void) +{ +#ifdef MZ_PRECISE_GC + scheme_prefix_finalize = (Scheme_Prefix *)0x1; /* 0x1 acts as a sentenel */ + scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; + GC_set_post_propagate_hook(mark_pruned_prefixes); + GC_set_treat_as_incremental_mark(scheme_prefix_type, check_pruned_prefix); +#endif +} + +/*========================================================================*/ +/* linklet and instance functions */ +/*========================================================================*/ + +static Scheme_Object *primitive_table(int argc, Scheme_Object *argv[]) +{ + Scheme_Hash_Table *table; + + if (!SCHEME_SYMBOLP(argv[0])) + scheme_wrong_contract("primitive-table", "symbol?", 0, argc, argv); + if ((argc > 1) && !SCHEME_HASHTRP(argv[1])) + scheme_wrong_contract("primitive-table", "(and/c hash? immutable?)", 1, argc, argv); + + table = (Scheme_Hash_Table *)scheme_hash_get(scheme_startup_env->primitive_tables, argv[0]); + if (!table && local_primitive_tables) + table = (Scheme_Hash_Table *)scheme_hash_get(local_primitive_tables, argv[0]); + + if (!table) { + if (argc > 1) { + if (!local_primitive_tables) { + REGISTER_SO(local_primitive_tables); + local_primitive_tables = scheme_make_hash_table(SCHEME_hash_ptr); + } + scheme_hash_set(local_primitive_tables, argv[0], argv[1]); + } else + return scheme_false; + } + + if (argc < 2) + return (Scheme_Object *)table; + else + return scheme_void; +} + +static Scheme_Object *primitive_to_position(int argc, Scheme_Object **argv) +{ + Scheme_Object *pos; + pos = scheme_hash_get(scheme_startup_env->primitive_ids_table, argv[0]); + return (pos ? pos : scheme_false); +} + +static Scheme_Object *position_to_primitive(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + if (SCHEME_INTP(argv[0]) && (SCHEME_INT_VAL(argv[0]) >= 0)) + v = scheme_position_to_builtin(SCHEME_INT_VAL(argv[0])); + else + v = NULL; + return (v ? v : scheme_false); +} + +static Scheme_Object *primitive_in_category_p(int argc, Scheme_Object **argv) +{ + Scheme_Object *v, *cat; + int r; + + if (!SCHEME_SYMBOLP(argv[0])) + scheme_wrong_contract("primitive-in-category?", "symbol?", 0, argc, argv); + cat = argv[1]; + if (!SCHEME_SYMBOLP(cat)) + scheme_wrong_contract("primitive-in-category?", "symbol?", 1, argc, argv); + + v = scheme_hash_get(scheme_startup_env->all_primitives_table, argv[0]); + if (!v) + r = 0; + else if (SCHEME_PRIMP(v)) { + int opt = ((Scheme_Prim_Proc_Header *)v)->flags & SCHEME_PRIM_OPT_MASK; + if (SAME_OBJ(cat, noncm_symbol)) { + r = (opt >= SCHEME_PRIM_OPT_NONCM); + /* Remove closures from noncm */ + if (((Scheme_Prim_Proc_Header *)v)->flags & SCHEME_PRIM_IS_CLOSURE) + r = 0; + } else if (SAME_OBJ(cat, immediate_symbol)) + r = (opt >= SCHEME_PRIM_OPT_IMMEDIATE); + else if (SAME_OBJ(cat, folding_symbol)) + r = (opt >= SCHEME_PRIM_OPT_FOLDING); + else if (SAME_OBJ(cat, omitable_symbol)) + r = (SCHEME_PRIM_PROC_OPT_FLAGS(v) & (SCHEME_PRIM_IS_OMITABLE_ANY + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL + | SCHEME_PRIM_IS_UNSAFE_OMITABLE)); + else + r = 0; + } else + r = 0; + + return (r ? scheme_true : scheme_false); +} + +static Scheme_Object *linklet_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type) + ? scheme_true + : scheme_false); +} + +void extract_import_info(const char *who, int argc, Scheme_Object **argv, + Scheme_Object **_import_keys, Scheme_Object **_get_import) +{ + + if (argc > 2) { + *_import_keys = argv[2]; + if (SCHEME_FALSEP(*_import_keys)) + *_import_keys = NULL; + else if (!SCHEME_VECTORP(*_import_keys)) + scheme_wrong_contract(who, "(or/c vector? #f)", 2, argc, argv); + } else + *_import_keys = NULL; + + if (argc > 3) { + scheme_check_proc_arity2(who, 1, 3, argc, argv, 1); + if (SCHEME_TRUEP(argv[3])) { + if (!*_import_keys) { + scheme_contract_error(who, + "no vector supplied for import keys, but import-getting function provided;\n" + " the function argument must be `#f' when the vector argument is `#f'", + "import-getting function", 1, argv[3], + NULL); + } + *_get_import = argv[3]; + } else + *_get_import = NULL; + } else + *_get_import = NULL; +} + +static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv) +{ + Scheme_Object *name, *e, *import_keys, *get_import, *a[2]; + int unsafe; + + /* Last argument, `serializable?`, is ignored */ + + extract_import_info("compile-linklet", argc, argv, &import_keys, &get_import); + + if ((argc > 1) && SCHEME_TRUEP(argv[1])) + name = argv[1]; + else + name = scheme_intern_symbol("anonymous"); + + e = argv[0]; + if (!SCHEME_STXP(e)) + e = scheme_datum_to_syntax(e, scheme_false, DTS_CAN_GRAPH); + + /* We don't care about `serializable?` at this layer. */ + + unsafe = ((argc > 5) && SCHEME_TRUEP(argv[5])); + + e = (Scheme_Object *)compile_and_or_optimize_linklet(e, NULL, name, &import_keys, get_import, unsafe); + + if (import_keys) { + a[0] = e; + a[1] = import_keys; + return scheme_values(2, a); + } else + return e; +} + +static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv) +{ + Scheme_Object *name, *import_keys, *get_import, *a[2]; + Scheme_Linklet *linklet; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("recompile-linklet", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + + extract_import_info("recompile-linklet", argc, argv, &import_keys, &get_import); + + if ((argc > 1) && SCHEME_TRUEP(argv[1])) + name = argv[1]; + else + name = ((Scheme_Linklet *)argv[0])->name; + + if (import_keys && (SCHEME_VEC_SIZE(import_keys) != SCHEME_VEC_SIZE(linklet->importss))) { + scheme_contract_error("recompile-linklet", + "given number of import keys does not match import count of linklet", + "linklet", 1, linklet, + "linklet imports", 1, scheme_make_integer(SCHEME_VEC_SIZE(linklet->importss)), + "given keys", 1, scheme_make_integer(SCHEME_VEC_SIZE(import_keys)), + NULL); + } + + linklet = compile_and_or_optimize_linklet(NULL, linklet, name, &import_keys, get_import, 0); + + if (import_keys) { + a[0] = (Scheme_Object *)linklet; + a[1] = import_keys; + + return scheme_values(2, a); + } else + return (Scheme_Object *)linklet; +} + +static Scheme_Object *eval_linklet(int argc, Scheme_Object **argv) +{ + /* "Evaluation" is not necessary before instantiation, but it makes + the linklet JIT-prepared (so the JIT-prepared linklet could be + reused, for example) while also making the linklet ineligible for + marshaling. */ + Scheme_Linklet *linklet; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("eval-linklet", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + if (!linklet->jit_ready) { + Scheme_Object *b; + b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); + if (SCHEME_TRUEP(b)) { + /* Make a JIT-prepable linklet --- but don't actually prep until + forced by instantiation. */ + linklet = scheme_jit_linklet(linklet, 1); + } + } + + return (Scheme_Object *)linklet; +} + +static Scheme_Object *read_compiled_linklet(int argc, Scheme_Object **argv) +{ + if (!SCHEME_INPUT_PORTP(argv[0])) + scheme_wrong_contract("read-compiled-linklet", "input-port?", 0, argc, argv); + + return scheme_read_compiled(argv[0]); +} + +static Scheme_Object *instantiate_linklet(int argc, Scheme_Object **argv) +{ + Scheme_Linklet *linklet; + Scheme_Object *l; + Scheme_Instance *inst, **instances; + int len = 0, num_importss, use_prompt, return_instance; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("instantiate-linklet", "linklet?", 0, argc, argv); + + l = argv[1]; + while (!SCHEME_NULLP(l)) { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_instance_type)) + break; + l = SCHEME_CDR(l); + len++; + } + if (!SCHEME_NULLP(l)) + scheme_wrong_contract("instantiate-linklet", "(listof instance?)", 1, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + num_importss = SCHEME_VEC_SIZE(linklet->importss); + if (len != num_importss) + scheme_contract_error("instantiate-linklet", + "given number of instances does not match import count of linklet", + "linklet", 1, linklet, + "expected imports", 1, scheme_make_integer(num_importss), + "given instances", 1, scheme_make_integer(len), + NULL); + + if ((argc > 2) && SCHEME_TRUEP(argv[2])) { + if (!SAME_TYPE(SCHEME_TYPE(argv[2]), scheme_instance_type)) + scheme_wrong_contract("instantiate-linklet", "(or/c instance? #f)", 2, argc, argv); + inst = (Scheme_Instance *)argv[2]; + return_instance = 0; + } else { + inst = scheme_make_instance(linklet->name, scheme_false); + return_instance = 1; + } + + use_prompt = ((argc < 4) || SCHEME_TRUEP(argv[3])); + + instances = MALLOC_N(Scheme_Instance*, len); + l = argv[1]; + len = 0; + while (!SCHEME_NULLP(l)) { + instances[len++] = (Scheme_Instance *)SCHEME_CAR(l); + l = SCHEME_CDR(l); + } + + if (!return_instance) + return _instantiate_linklet_multi(linklet, inst, len, instances, use_prompt); + else { + (void)_instantiate_linklet_multi(linklet, inst, len, instances, use_prompt); + return (Scheme_Object *)inst; + } +} + +static Scheme_Object *linklet_import_variables(int argc, Scheme_Object **argv) +{ + Scheme_Linklet *linklet; + int i, j; + Scheme_Object *l, *ll = scheme_null; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("linklet-import-variables", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + + for (i = SCHEME_VEC_SIZE(linklet->importss); i--; ) { + l = scheme_null; + for (j = SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j--; ) { + l = scheme_make_pair(SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j], l); + } + ll = scheme_make_pair(l, ll); + } + + return ll; +} + +static Scheme_Object *linklet_export_variables(int argc, Scheme_Object **argv) +{ + Scheme_Linklet *linklet; + int i; + Scheme_Object *l = scheme_null; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) + scheme_wrong_contract("linklet-export-variables", "linklet?", 0, argc, argv); + + linklet = (Scheme_Linklet *)argv[0]; + + for (i = linklet->num_exports; i--; ) { + l = scheme_make_pair(SCHEME_VEC_ELS(linklet->defns)[i], l); + } + + return l; +} + +static Scheme_Object *instance_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type) + ? scheme_true + : scheme_false); +} + +static int parse_constantness_flag(const char *who, int i, int argc, Scheme_Object **argv) +{ + int set_flags = 0; + + if (SCHEME_FALSEP(argv[i])) + set_flags = 0; + else if (SAME_OBJ(argv[i], constant_symbol)) + set_flags = GLOB_IS_IMMUTATED; + else if (SAME_OBJ(argv[i], consistent_symbol)) + set_flags = GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT; + else + scheme_wrong_contract(who, "(or/c #f 'constant 'consistent)", i, argc, argv); + + return set_flags; +} + +static Scheme_Object *make_instance(int argc, Scheme_Object **argv) +{ + Scheme_Instance *inst; + int i; + + inst = scheme_make_instance(argv[0], (argc > 1) ? argv[1] : scheme_false); + + if (argc > 3) { + Scheme_Bucket **a, *b; + int set_flags = 0; + + set_flags = parse_constantness_flag("make-instance", 2, argc, argv); + + i = 3; + a = MALLOC_N(Scheme_Bucket *, (argc - i) >> 1); + + for (; i < argc; i += 2) { + if (!SCHEME_SYMBOLP(argv[i])) + scheme_wrong_contract("make-instance", "symbol?", i, argc, argv); + if (i+1 == argc) + scheme_contract_error("make-instance", + "value missing for variable name", + "variable name", 1, argv[i], + NULL); + b = make_bucket(argv[i], argv[i+1], inst); + if (set_flags) + ((Scheme_Bucket_With_Flags *)b)->flags |= set_flags; + a[(i-2)>>1] = b; + } + + inst->array_size = (argc-2)>>1; + inst->variables.a = a; + } + + return (Scheme_Object *)inst; +} + +static Scheme_Object *instance_name(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-name", "instance?", 0, argc, argv); + + return ((Scheme_Instance *)argv[0])->name; +} + +static Scheme_Object *instance_data(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-data", "instance?", 0, argc, argv); + + return ((Scheme_Instance *)argv[0])->data; +} + +static Scheme_Object *instance_variable_names(int argc, Scheme_Object **argv) +{ + Scheme_Bucket *b; + int i; + Scheme_Object *l = scheme_null; + Scheme_Instance *inst; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-variable-names", "instance?", 0, argc, argv); + + inst = (Scheme_Instance *)argv[0]; + + if (inst->array_size) { + for (i = inst->array_size; i--; ) { + l = scheme_make_pair((Scheme_Object *)inst->variables.a[i]->key, l); + } + } else if (inst->variables.bt) { + for (i = inst->variables.bt->size; i--; ) { + b = inst->variables.bt->buckets[i]; + if (b && b->val) { + l = scheme_make_pair((Scheme_Object *)b->key, l); + } + } + } + + return l; +} + +static Scheme_Object *instance_variable_value(int argc, Scheme_Object **argv) +{ + Scheme_Instance *inst; + Scheme_Bucket *b; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-variable-value", "instance?", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("instance-variable-value", "symbol?", 1, argc, argv); + + inst = (Scheme_Instance *)argv[0]; + + b = scheme_instance_variable_bucket_or_null(argv[1], inst); + if (b && b->val) + return b->val; + + if (argc > 2) { + if (SCHEME_PROCP(argv[2])) + return _scheme_tail_apply(argv[2], 0, NULL); + return argv[2]; + } + + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "instance-variable-value: instance variable not found\n" + " instance: %V\n" + " name: %S", + inst->name, + argv[1]); + return NULL; +} + +static Scheme_Object *instance_set_variable_value(int argc, Scheme_Object **argv) +{ + Scheme_Bucket *b; + int set_flags = 0; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-set-variable-value!", "instance?", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("instance-set-variable-value!", "symbol?", 1, argc, argv); + if (argc > 3) + set_flags = parse_constantness_flag("instance-set-variable-value!", 3, argc, argv); + + b = scheme_instance_variable_bucket(argv[1], (Scheme_Instance *)argv[0]); + + scheme_set_global_bucket("instance-set-variable-value!", b, argv[2], 1); + + b->val = argv[2]; + if (set_flags) + ((Scheme_Bucket_With_Flags *)b)->flags |= set_flags; + + return scheme_void; +} + +static Scheme_Object *instance_unset_variable(int argc, Scheme_Object **argv) +{ + Scheme_Bucket *b; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_instance_type)) + scheme_wrong_contract("instance-unset-variable!", "instance?", 0, argc, argv); + if (!SCHEME_SYMBOLP(argv[1])) + scheme_wrong_contract("instance-unset-variable!", "symbol?", 1, argc, argv); + + b = scheme_instance_variable_bucket(argv[1], (Scheme_Instance *)argv[0]); + b->val = NULL; + + return scheme_void; +} + +static Scheme_Object *linklet_directory_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_directory_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *linklet_directory_to_hash(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_directory_type)) + scheme_wrong_contract("linklet-directory->hash", "linklet-directory?", 0, argc, argv); + + return SCHEME_PTR_VAL(argv[0]); +} + +static Scheme_Object *hash_to_linklet_directory(int argc, Scheme_Object **argv) +{ + mzlonglong pos; + Scheme_Object *k, *v; + Scheme_Hash_Tree *hash; + + if (!SCHEME_HASHTRP(argv[0]) + || !SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0]))) + scheme_wrong_contract("hash->linklet-directory", + "(and/c hash? hash-eq? immutable? (not/c impersonator?))", + 0, argc, argv); + hash = (Scheme_Hash_Tree *)argv[0]; + + /* mapping: #f -> bundle, sym -> linklet directory */ + + pos = scheme_hash_tree_next(hash, -1); + while (pos != -1) { + scheme_hash_tree_index(hash, pos, &k, &v); + if (SCHEME_FALSEP(k)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)) + scheme_contract_error("hash->linklet-directory", + "value for #f key is not a linklet bundle", + "value", 1, v, + NULL); + } else if (SCHEME_SYMBOLP(k)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_directory_type)) + scheme_contract_error("hash->linklet-directory", + "value for symbol key is not a linklet directory", + "key", 1, k, + "value", 1, v, + NULL); + } else { + scheme_contract_error("hash->linklet-directory", + "key in given hash is not #f or a symbol", + "key", 1, k, + NULL); + } + pos = scheme_hash_tree_next(hash, pos); + } + + v = scheme_alloc_small_object(); + v->type = scheme_linklet_directory_type; + SCHEME_PTR_VAL(v) = argv[0]; + return v; +} + +static Scheme_Object *linklet_bundle_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_bundle_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *linklet_bundle_to_hash(int argc, Scheme_Object **argv) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_bundle_type)) + scheme_wrong_contract("linklet-bundle->hash", "linklet-bundle?", 0, argc, argv); + + return SCHEME_PTR_VAL(argv[0]); +} + +static Scheme_Object *hash_to_linklet_bundle(int argc, Scheme_Object **argv) +{ + mzlonglong pos; + Scheme_Object *k, *v; + Scheme_Hash_Tree *hash; + + if (!SCHEME_HASHTRP(argv[0]) + || !SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(argv[0]))) + scheme_wrong_contract("hash->linklet-bundle", + "(and/c hash? hash-eq? immutable? (not/c impersonator?))", + 0, argc, argv); + + hash = (Scheme_Hash_Tree *)argv[0]; + + /* mapping: keys must be symbols and fixnums */ + + pos = scheme_hash_tree_next(hash, -1); + while (pos != -1) { + scheme_hash_tree_index(hash, pos, &k, &v); + if (!SCHEME_SYMBOLP(k) && !SCHEME_INTP(k)) { + scheme_contract_error("hash->linklet-bundle", + "key in given hash is not a symbol or fixnum", + "key", 1, k, + NULL); + } + pos = scheme_hash_tree_next(hash, pos); + } + + v = scheme_alloc_small_object(); + v->type = scheme_linklet_bundle_type; + SCHEME_PTR_VAL(v) = argv[0]; + return v; +} + +static Scheme_Object *variable_p(int argc, Scheme_Object **argv) +{ + return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *variable_instance(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + v = argv[0]; + + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) + scheme_wrong_contract("variable-reference->instance", "variable-reference?", 0, argc, argv); + + if ((argc < 2) || SCHEME_FALSEP(argv[1])) { + /* Definition instance might be a primitive-table symbol, or it might be #f for "anonymous": */ + v = SCHEME_PTR1_VAL(argv[0]); + if (SCHEME_SYMBOLP(v) || SCHEME_FALSEP(v)) + return v; + else if (SAME_OBJ(v, scheme_true)) + return SCHEME_PTR2_VAL(argv[0]); /* same as use instance for a local */ + else { + v = (Scheme_Object *)scheme_get_bucket_home((Scheme_Bucket *)v); + if (!v) { + /* The definition instance was GCed? Return the use-site instance */ + return SCHEME_PTR2_VAL(argv[0]); + } + return v; + } + } else { + /* Get use instance: */ + return SCHEME_PTR2_VAL(argv[0]); + } +} + +static Scheme_Object *variable_const_p(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + v = argv[0]; + + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) + scheme_wrong_contract("variable-reference-constant?", "variable-reference?", 0, argc, argv); + + if (SCHEME_VARREF_FLAGS(v) & VARREF_IS_CONSTANT) + return scheme_true; + + v = SCHEME_PTR1_VAL(v); + if (!SCHEME_FALSEP(v)) { + if (SCHEME_SYMBOLP(v) + || (((Scheme_Bucket_With_Flags *)v)->flags & GLOB_IS_IMMUTATED)) + return scheme_true; + } + + return scheme_false; +} + +static Scheme_Object *variable_unsafe_p(int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + v = argv[0]; + + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) + scheme_wrong_contract("variable-reference-from-unsafe?", "variable-reference?", 0, argc, argv); + + if (SCHEME_VARREF_FLAGS(v) & VARREF_FROM_UNSAFE) + return scheme_true; + else + return scheme_false; +} + +/*========================================================================*/ +/* instance variable buckets */ +/*========================================================================*/ + +Scheme_Object *scheme_get_home_weak_link(Scheme_Instance *i) +{ + if (!i->weak_self_link) { + Scheme_Object *wb; + if (scheme_starting_up) + wb = scheme_box((Scheme_Object *)i); + else + wb = scheme_make_weak_box((Scheme_Object *)i); + i->weak_self_link = wb; + } + + return i->weak_self_link; +} + +Scheme_Instance *scheme_get_bucket_home(Scheme_Bucket *b) +{ + Scheme_Object *l; + + l = ((Scheme_Bucket_With_Home *)b)->home_link; + if (l) { + if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) + return (Scheme_Instance *)l; + else + return (Scheme_Instance *)SCHEME_WEAK_BOX_VAL(l); + } else + return NULL; +} + +void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Instance *e) +{ + if (!((Scheme_Bucket_With_Home *)b)->home_link) { + if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK) + ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)e; + else { + Scheme_Object *link; + link = scheme_get_home_weak_link(e); + ((Scheme_Bucket_With_Home *)b)->home_link = link; + } + } +} + +static Scheme_Bucket *make_bucket(Scheme_Object *key, Scheme_Object *val, Scheme_Instance *inst) +{ + Scheme_Bucket *b; + + b = (Scheme_Bucket *)MALLOC_ONE_TAGGED(Scheme_Bucket_With_Home); + b->so.type = scheme_variable_type; + b->key = (char *)key; + b->val = val; + scheme_set_bucket_home(b, inst); + + return b; +} + +Scheme_Instance *scheme_make_instance(Scheme_Object *name, Scheme_Object *data) +{ + Scheme_Instance *inst; + + if (!empty_hash_tree) { + REGISTER_SO(empty_hash_tree); + empty_hash_tree = scheme_make_hash_tree(0); + } + + inst = MALLOC_ONE_TAGGED(Scheme_Instance); + inst->iso.so.type = scheme_instance_type; + + inst->name = (name ? name : scheme_false); + inst->data = data; + + inst->source_names = empty_hash_tree; + + if (scheme_starting_up) { + /* Avoid recording procedure-implementation details in bytecode + that uses the instances that are created on startup. */ + SCHEME_INSTANCE_FLAGS(inst) |= SCHEME_INSTANCE_USE_IMPRECISE; + } + + return inst; +} + +void scheme_instance_to_hash_mode(Scheme_Instance *inst, int size_estimate) +{ + Scheme_Bucket_Table *variables; + Scheme_Bucket **a; + + if (inst->array_size) { + size_estimate = inst->array_size * 2; + a = inst->variables.a; + } else + a = NULL; + + variables = scheme_make_bucket_table(size_estimate, SCHEME_hash_ptr); + variables->with_home = 1; + + inst->variables.bt = variables; + inst->array_size = 0; + + if (a) { + size_estimate >>= 1; + while (size_estimate--) { + scheme_add_bucket_to_table(inst->variables.bt, a[size_estimate]); + } + } +} + +Scheme_Bucket *scheme_instance_variable_bucket(Scheme_Object *symbol, Scheme_Instance *inst) +{ + Scheme_Bucket *b; + + if (inst->array_size) { + int i; + for (i = inst->array_size; i--; ) { + b = inst->variables.a[i]; + if (SAME_OBJ(symbol, (Scheme_Object *)b->key)) + return b; + } + } + + if (inst->array_size || !inst->variables.bt) + scheme_instance_to_hash_mode(inst, 0); + + b = scheme_bucket_from_table(inst->variables.bt, (char *)symbol); + ASSERT_IS_VARIABLE_BUCKET(b); + if (SCHEME_FALSEP(symbol)) + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_STRONG_HOME_LINK; + + scheme_set_bucket_home(b, inst); + + return b; +} + +Scheme_Bucket *scheme_instance_variable_bucket_or_null(Scheme_Object *symbol, Scheme_Instance *inst) +{ + Scheme_Bucket *b; + + if (inst->array_size) { + int i; + for (i = inst->array_size; i--; ) { + b = inst->variables.a[i]; + if (SAME_OBJ(symbol, (Scheme_Object *)b->key)) + return b; + } + return NULL; + } else if (!inst->variables.bt) + return NULL; + + b = scheme_bucket_or_null_from_table(inst->variables.bt, (char *)symbol, 0); + if (b) { + ASSERT_IS_VARIABLE_BUCKET(b); + scheme_set_bucket_home(b, inst); + } + + return b; +} + +/*========================================================================*/ +/* managing bucket names */ +/*========================================================================*/ + +static Scheme_Object *generate_bucket_name(Scheme_Object *old_name, Scheme_Instance *instance) +{ + int search_start = 0; + char buf[32]; + Scheme_Object *n; + + while (1) { + sprintf(buf, ".%d", search_start); + n = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + n = scheme_symbol_append(old_name, n); + if (!scheme_instance_variable_bucket_or_null(n, instance)) + return n; + search_start++; + } +} + +static Scheme_Hash_Tree *update_source_names(Scheme_Hash_Tree *source_names, + Scheme_Object *old_name, Scheme_Object *new_name) +{ + Scheme_Object *v; + + v = scheme_hash_tree_get(source_names, old_name); + if (v) + return scheme_hash_tree_set(source_names, new_name, v); + else + return source_names; +} + +/*========================================================================*/ +/* compiling linklets */ +/*========================================================================*/ + +static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Scheme_Linklet *linklet, + Scheme_Object *name, + Scheme_Object **_import_keys, Scheme_Object *get_import, + int unsafe_mode) +{ + Scheme_Config *config; + int enforce_const, set_undef, can_inline; + + config = scheme_current_config(); + enforce_const = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); + set_undef = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_ALLOW_SET_UNDEFINED)); + can_inline = SCHEME_FALSEP(scheme_get_param(config, MZCONFIG_DISALLOW_INLINE)); + + if (_import_keys && !*_import_keys) + _import_keys = NULL; + + if (!linklet) { + linklet = scheme_compile_linklet(form, set_undef, (_import_keys ? *_import_keys : NULL)); + linklet = scheme_letrec_check_linklet(linklet); + } else { + linklet = scheme_unresolve_linklet(linklet, (set_undef ? COMP_ALLOW_SET_UNDEFINED : 0)); + } + linklet->name = name; + linklet = scheme_optimize_linklet(linklet, enforce_const, can_inline, unsafe_mode, + _import_keys, get_import); + + linklet = scheme_resolve_linklet(linklet, enforce_const); + linklet = scheme_sfs_linklet(linklet); + + if (recompile_every_compile) { + int i; + for (i = recompile_every_compile; i--; ) { + linklet = scheme_unresolve_linklet(linklet, (set_undef ? COMP_ALLOW_SET_UNDEFINED : 0)); + linklet = scheme_optimize_linklet(linklet, enforce_const, can_inline, unsafe_mode, + _import_keys, get_import); + linklet = scheme_resolve_linklet(linklet, enforce_const); + linklet = scheme_sfs_linklet(linklet); + } + } + + if (validate_compile_result) + scheme_validate_linklet(NULL, linklet); + + return linklet; +} + +Scheme_Linklet *scheme_compile_and_optimize_linklet(Scheme_Object *form, Scheme_Object *name) +{ + return compile_and_or_optimize_linklet(form, NULL, name, NULL, NULL, 0); +} + +/*========================================================================*/ +/* instantiating linklets */ +/*========================================================================*/ + +static Scheme_Object *body_one_expr(void *prefix_plus_expr, int argc, Scheme_Object **argv) +{ + Scheme_Object *v; + + resume_prefix(SCHEME_CAR((Scheme_Object *)prefix_plus_expr)); + v = _scheme_eval_linked_expr_multi(SCHEME_CDR((Scheme_Object *)prefix_plus_expr)); + (void)suspend_prefix(); + + return v; +} + +static int needs_prompt(Scheme_Object *e) +{ + Scheme_Type t; + + while (1) { + t = SCHEME_TYPE(e); + if (t > _scheme_values_types_) + return 0; + + switch (t) { + case scheme_lambda_type: + case scheme_toplevel_type: + case scheme_local_type: + case scheme_local_unbox_type: + return 0; + case scheme_case_lambda_sequence_type: + return 0; + case scheme_define_values_type: + e = SCHEME_VEC_ELS(e)[0]; + break; + case scheme_inline_variant_type: + e = SCHEME_VEC_ELS(e)[0]; + break; + default: + return 1; + } + } +} + +Scheme_Object *scheme_linklet_run_finish(Scheme_Linklet* linklet, Scheme_Instance *instance, int use_prompt) +{ + Scheme_Thread *p; + Scheme_Object *body, *save_prefix, *v = scheme_void; + int i, cnt; + mz_jmp_buf newbuf, * volatile savebuf; + + p = scheme_current_thread; + savebuf = p->error_buf; + p->error_buf = &newbuf; + + if (scheme_setjmp(newbuf)) { + Scheme_Thread *p2; + p2 = scheme_current_thread; + p2->error_buf = savebuf; + scheme_longjmp(*savebuf, 1); + } else { + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for (i = 0; i < cnt; i++) { + body = SCHEME_VEC_ELS(linklet->bodies)[i]; + if (use_prompt && needs_prompt(body)) { + /* We need to push the prefix after the prompt is set, so + restore the runstack and then add the prefix back. */ + save_prefix = suspend_prefix(); + v = _scheme_call_with_prompt_multi(body_one_expr, + scheme_make_raw_pair(save_prefix, body)); + resume_prefix(save_prefix); + + /* Double-check that the definition-installing part of the + continuation was not skipped. Otherwise, the compiler would + not be able to assume that a variable reference that is + lexically later (incuding a reference to an imported + variable) always references a defined variable. Putting the + prompt around a definition's RHS might be a better + approach, but that would change the language (so mabe next + time). */ + if (SAME_TYPE(SCHEME_TYPE(body), scheme_define_values_type)) { + int vcnt, j; + + vcnt = SCHEME_VEC_SIZE(body) - 1; + for (j = 0; j < vcnt; j++) { + Scheme_Object *var; + Scheme_Prefix *toplevels; + Scheme_Bucket *b; + + var = SCHEME_VEC_ELS(body)[j+1]; + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + + if (!b->val) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, + b->key, + "define-values: skipped variable definition;\n" + " cannot continue without defining variable\n" + " variable: %S\n" + " in module: %D", + (Scheme_Object *)b->key, + instance->name); + } + } + } + } else + v = _scheme_eval_linked_expr_multi(body); + + if (i < (cnt - 1)) + scheme_ignore_result(v); + } + + p = scheme_current_thread; + p->error_buf = savebuf; + } + + return v; +} + +static Scheme_Object *eval_linklet_body(Scheme_Linklet *linklet, Scheme_Instance *instance, int use_prompt) +{ +#ifdef MZ_USE_JIT + if (use_prompt) + return scheme_linklet_run_start(linklet, instance, scheme_make_pair(instance->name, scheme_true)); +#endif + + return scheme_linklet_run_finish(linklet, instance, 0); +} + +static void *instantiate_linklet_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Linklet *linklet = (Scheme_Linklet *)p->ku.k.p1; + Scheme_Instance *instance = (Scheme_Instance *)p->ku.k.p2; + Scheme_Instance **instances = (Scheme_Instance **)p->ku.k.p3; + int multi = p->ku.k.i1; + int num_instances = p->ku.k.i2; + int use_prompt = p->ku.k.i3; + int depth; + Scheme_Object *b, *v; + Scheme_Hash_Tree *source_names; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + depth = linklet->max_let_depth; + if (!scheme_check_runstack(depth)) { + p->ku.k.p1 = linklet; + p->ku.k.p2 = instance; + p->ku.k.p3 = instances; + p->ku.k.i1 = multi; + p->ku.k.i2 = num_instances; + p->ku.k.i3 = use_prompt; + return (Scheme_Object *)scheme_enlarge_runstack(depth, instantiate_linklet_k); + } + + if (!linklet->jit_ready) { + b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); + if (SCHEME_TRUEP(b)) + linklet = scheme_jit_linklet(linklet, 2); + } else { + linklet = scheme_jit_linklet(linklet, 2); + } + + /* Pushng the prefix looks up imported variables */ + source_names = push_prefix(linklet, instance, num_instances, instances, linklet->source_names); + + /* For variables in this instances, merge source-name info from the + linklet to the instance */ + if (source_names->count) { + if (instance->source_names->count) { + mzlonglong pos; + Scheme_Hash_Tree *ht = instance->source_names; + Scheme_Object *k, *v; + pos = scheme_hash_tree_next(source_names, -1); + while (pos != -1) { + scheme_hash_tree_index(source_names, pos, &k, &v); + ht = scheme_hash_tree_set(ht, k, v); + pos = scheme_hash_tree_next(source_names, pos); + } + instance->source_names = ht; + } else + instance->source_names = source_names; + } + + v = eval_linklet_body(linklet, instance, use_prompt); + + pop_prefix(); + + if (!multi) + v = scheme_check_one_value(v); + + return (void *)v; +} + +static Scheme_Object *do_instantiate_linklet(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt, int multi, int top) +{ + Scheme_Thread *p = scheme_current_thread; + + p->ku.k.p1 = linklet; + p->ku.k.p2 = instance; + p->ku.k.p3 = instances; + + p->ku.k.i1 = multi; + p->ku.k.i2 = num_instances; + p->ku.k.i3 = use_prompt; + + if (top) + return (Scheme_Object *)scheme_top_level_do(instantiate_linklet_k, 1); + else + return (Scheme_Object *)instantiate_linklet_k(); +} + +static Scheme_Object *_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt) +{ + return do_instantiate_linklet(linklet, instance, num_instances, instances, use_prompt, 1, 0); +} + +Scheme_Object *scheme_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt) +{ + return do_instantiate_linklet(linklet, instance, num_instances, instances, use_prompt, 1, 1); +} + +/*========================================================================*/ +/* creating/pushing prefix for top-levels and syntax objects */ +/*========================================================================*/ + +static Scheme_Hash_Tree *push_prefix(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + Scheme_Hash_Tree *source_names) +{ + Scheme_Object **rs, *v; + Scheme_Prefix *pf; + int i, j, pos, tl_map_len, num_importss, num_defns, starts_empty; + GC_CAN_IGNORE const char *bad_reason = NULL; + + rs = MZ_RUNSTACK; + + num_importss = SCHEME_VEC_SIZE(linklet->importss); + num_defns = SCHEME_VEC_SIZE(linklet->defns); + + i = 1 + linklet->num_total_imports + num_defns; + tl_map_len = (i + 31) / 32; + + pf = scheme_malloc_tagged(sizeof(Scheme_Prefix) + + ((i-mzFLEX_DELTA) * sizeof(Scheme_Object *)) + + (tl_map_len * sizeof(int))); + pf->iso.so.type = scheme_prefix_type; + pf->num_slots = i; + --rs; + MZ_RUNSTACK = rs; + rs[0] = (Scheme_Object *)pf; + + pos = 0; + + /* Initial bucket, key by #f, provides access to the instance */ + if (linklet->need_instance_access) + v = (Scheme_Object *)scheme_instance_variable_bucket(scheme_false, instance); + else + v = NULL; + pf->a[pos++] = v; + + for (j = 0; j < num_importss; j++) { + int num_imports = SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[j]); + for (i = 0; i < num_imports; i++) { + v = SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[j])[i]; + v = (Scheme_Object *)scheme_instance_variable_bucket(v, (Scheme_Instance *)instances[j]); + + if (v) { + if (!((Scheme_Bucket *)v)->val) { + bad_reason = "is unintialized"; + v = NULL; + } else if (linklet->import_shapes) { + Scheme_Object *shape = SCHEME_VEC_ELS(linklet->import_shapes)[pos-1]; + if (SAME_OBJ(shape, scheme_void)) { + /* Optimizer assumed constant; if it isn't, too bad */ + bad_reason = NULL; + } else if (SAME_OBJ(shape, scheme_true)) { + if (!(((Scheme_Bucket_With_Flags *)v)->flags & GLOB_IS_CONSISTENT)) { + bad_reason = "is not a procedure or structure-type constant across all instantiations"; + v = NULL; + } + } else if (SCHEME_TRUEP(shape)) { + if (!scheme_get_or_check_procedure_shape(((Scheme_Bucket *)v)->val, shape, 0)) { + bad_reason = "has the wrong procedure or structure-type shape"; + v = NULL; + } + } + } + } else + bad_reason = "is not exported"; + + if (!v) { + scheme_signal_error("instantiate-linklet: mismatch;\n" + " reference to a variable that %s;\n" + " possibly, bytecode file needs re-compile because dependencies changed\n" + " name: %D\n" + " exporting instance: %D\n" + " importing instance: %D", + bad_reason, + SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[j])[i], + instances[j]->name, + instance->name); + } + pf->a[pos++] = v; + } + } + + starts_empty = (!instance->array_size && !instance->variables.bt); + + if (!num_defns) { + /* don't allocate empty array, etc. */ + } else if (starts_empty && (num_defns < 10)) { + /* Faster to build an array-shaped instance (which will be + converted to a bucket table on demand, if necessary) */ + Scheme_Bucket **a, *b; + + a = MALLOC_N(Scheme_Bucket *, num_defns); + for (i = 0; i < num_defns; i++) { + v = SCHEME_VEC_ELS(linklet->defns)[i]; + if (SCHEME_FALSEP(v)) { + pf->a[pos++] = NULL; + } else { + b = make_bucket(v, NULL, instance); + a[i] = b; + pf->a[pos++] = (Scheme_Object *)b; + } + } + + instance->array_size = num_defns; + instance->variables.a = a; + } else { + /* General case: bucket-table instance: */ + for (i = 0; i < num_defns; i++) { + v = SCHEME_VEC_ELS(linklet->defns)[i]; + if (SCHEME_FALSEP(v)) { + v = NULL; + } else { + if ((i >= linklet->num_exports) && !starts_empty) { + /* avoid conflict with any existing bucket */ + if (scheme_instance_variable_bucket_or_null(v, instance)) { + v = generate_bucket_name(v, instance); + source_names = update_source_names(source_names, SCHEME_VEC_ELS(linklet->defns)[i], v); + } + } + v = (Scheme_Object *)scheme_instance_variable_bucket(v, instance); + } + pf->a[pos++] = v; + } + } + + return source_names; +} + +static void pop_prefix() +{ + /* This function must not allocate, since a relevant multiple-values + result may be in the thread record (and we don't want it zerod) */ + MZ_RUNSTACK++; +} + +static Scheme_Object *suspend_prefix() +{ + Scheme_Object *v; + v = MZ_RUNSTACK[0]; + MZ_RUNSTACK++; + return v; +} + +static void resume_prefix(Scheme_Object *v) +{ + --MZ_RUNSTACK; + MZ_RUNSTACK[0] = v; +} + +#ifdef MZ_PRECISE_GC +static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC +{ + if (!GC_is_partial(gc)) { + if (scheme_inc_prefix_finalize != (Scheme_Prefix *)0x1) { + Scheme_Prefix *pf = scheme_inc_prefix_finalize; + while (pf->next_final != (Scheme_Prefix *)0x1) { + pf = pf->next_final; + } + pf->next_final = scheme_prefix_finalize; + scheme_prefix_finalize = scheme_inc_prefix_finalize; + scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; + } + } + + if (scheme_prefix_finalize != (Scheme_Prefix *)0x1) { + Scheme_Prefix *pf = scheme_prefix_finalize, *next; + Scheme_Object *clo; + int i, *use_bits, maxpos; + + scheme_prefix_finalize = (Scheme_Prefix *)0x1; + while (pf != (Scheme_Prefix *)0x1) { + /* If not marked, only references are through closures: */ + if (!GC_is_marked2(pf, gc)) { + /* Clear slots that are not use in map */ + maxpos = pf->num_slots; + use_bits = PREFIX_TO_USE_BITS(pf); + for (i = (maxpos + 31) / 32; i--; ) { + int j; + for (j = 0; j < 32; j++) { + if (!(use_bits[i] & ((unsigned)1 << j))) { + int pos; + pos = (i * 32) + j; + if (pos < maxpos) + pf->a[pos] = NULL; + } + } + use_bits[i] = 0; + } + /* Should mark/copy pf, but not trigger or require mark propagation: */ +#ifdef MZ_GC_BACKTRACE + GC_set_backpointer_object(pf->backpointer); +#endif + GC_mark_no_recur(gc, 1); + gcMARK2(pf, gc); + pf = (Scheme_Prefix *)GC_resolve2(pf, gc); + GC_retract_only_mark_stack_entry(pf, gc); + GC_mark_no_recur(gc, 0); + pf->saw_num_slots = -1; + } else + pf = (Scheme_Prefix *)GC_resolve2(pf, gc); + + /* Clear use map */ + use_bits = PREFIX_TO_USE_BITS(pf); + maxpos = pf->num_slots; + for (i = (maxpos + 31) / 32; i--; ) + use_bits[i] = 0; + + /* Fix up closures that reference this prefix: */ + clo = (Scheme_Object *)GC_resolve2(pf->fixup_chain, gc); + pf->fixup_chain = NULL; + while (clo) { + Scheme_Object *next; + if (SCHEME_TYPE(clo) == scheme_closure_type) { + Scheme_Closure *cl = (Scheme_Closure *)clo; + int closure_size = ((Scheme_Lambda *)GC_resolve2(cl->code, gc))->closure_size; + next = cl->vals[closure_size - 1]; + cl->vals[closure_size-1] = (Scheme_Object *)pf; + } else if (SCHEME_TYPE(clo) == scheme_native_closure_type) { + Scheme_Native_Closure *cl = (Scheme_Native_Closure *)clo; + int closure_size = ((Scheme_Native_Lambda *)GC_resolve2(cl->code, gc))->closure_size; + next = cl->vals[closure_size - 1]; + cl->vals[closure_size-1] = (Scheme_Object *)pf; + } else { + MZ_ASSERT(0); + next = NULL; + } + clo = (Scheme_Object *)GC_resolve2(next, gc); + } + if (SCHEME_PREFIX_FLAGS(pf) & 0x1) + SCHEME_PREFIX_FLAGS(pf) -= 0x1; + + /* Next */ + next = pf->next_final; + pf->next_final = NULL; + + pf = next; + } + } +} + +int check_pruned_prefix(void *p) XFORM_SKIP_PROC +{ + Scheme_Prefix *pf = (Scheme_Prefix *)p; + return SCHEME_PREFIX_FLAGS(pf) & 0x1; +} +#endif + +/*========================================================================*/ +/* precise GC traversers */ +/*========================================================================*/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#include "mzmark_linklet.inc" + +static void register_traversers(void) +{ +} + +END_XFORM_SKIP; + +#endif diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index ef9d124f32..165f597dfb 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -49,10 +49,17 @@ READ_ONLY Scheme_Object *scheme_unsafe_cdr_proc; READ_ONLY Scheme_Object *scheme_unsafe_mcar_proc; READ_ONLY Scheme_Object *scheme_unsafe_mcdr_proc; READ_ONLY Scheme_Object *scheme_unsafe_unbox_proc; +READ_ONLY Scheme_Object *scheme_unsafe_unbox_star_proc; +READ_ONLY Scheme_Object *scheme_unsafe_set_box_star_proc; + /* read only locals */ ROSYM static Scheme_Object *weak_symbol; ROSYM static Scheme_Object *equal_symbol; +ROSYM static Scheme_Hash_Tree *empty_hash; +ROSYM static Scheme_Hash_Tree *empty_hasheq; +ROSYM static Scheme_Hash_Tree *empty_hasheqv; + /* locals */ static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *mpair_p_prim (int argc, Scheme_Object *argv[]); @@ -100,7 +107,9 @@ static Scheme_Object *box (int argc, Scheme_Object *argv[]); static Scheme_Object *immutable_box (int argc, Scheme_Object *argv[]); static Scheme_Object *box_p (int argc, Scheme_Object *argv[]); static Scheme_Object *unbox (int argc, Scheme_Object *argv[]); +static Scheme_Object *unbox_star (int argc, Scheme_Object *argv[]); static Scheme_Object *set_box (int argc, Scheme_Object *argv[]); +static Scheme_Object *set_box_star (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_box_cas (int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_box(int argc, Scheme_Object **argv); static Scheme_Object *impersonate_box(int argc, Scheme_Object **argv); @@ -117,7 +126,6 @@ Scheme_Object *scheme_make_immutable_hasheqv(int argc, Scheme_Object *argv[]); static Scheme_Object *direct_hash(int argc, Scheme_Object *argv[]); static Scheme_Object *direct_hasheq(int argc, Scheme_Object *argv[]); static Scheme_Object *direct_hasheqv(int argc, Scheme_Object *argv[]); -static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_p(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[]); @@ -126,7 +134,6 @@ Scheme_Object *scheme_hash_equal_p(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[]); -static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_remove(int argc, Scheme_Object *argv[]); static Scheme_Object *hash_table_clear_bang(int argc, Scheme_Object *argv[]); @@ -209,32 +216,29 @@ static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Schem static Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val); static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table); -#define BOX "box" -#define BOXP "box?" -#define UNBOX "unbox" -#define SETBOX "set-box!" - void -scheme_init_list (Scheme_Env *env) +scheme_init_list (Scheme_Startup_Env *env) { Scheme_Object *p; scheme_null->type = scheme_null_type; - scheme_add_global_constant ("null", scheme_null, env); + scheme_addto_prim_instance ("null", scheme_null, env); REGISTER_SO(scheme_pair_p_proc); p = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("pair?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("pair?", p, env); scheme_pair_p_proc = p; REGISTER_SO(scheme_mpair_p_proc); p = scheme_make_folding_prim(mpair_p_prim, "mpair?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("mpair?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("mpair?", p, env); scheme_mpair_p_proc = p; REGISTER_SO(scheme_cons_proc); @@ -242,56 +246,63 @@ scheme_init_list (Scheme_Env *env) scheme_cons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("cons", p, env); + scheme_addto_prim_instance ("cons", p, env); REGISTER_SO(scheme_car_proc); p = scheme_make_folding_prim(scheme_checked_car, "car", 1, 1, 1); scheme_car_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("car", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("car", p, env); REGISTER_SO(scheme_cdr_proc); p = scheme_make_folding_prim(scheme_checked_cdr, "cdr", 1, 1, 1); scheme_cdr_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cdr", p, env); REGISTER_SO(scheme_mcons_proc); p = scheme_make_immed_prim(mcons_prim, "mcons", 2, 2); scheme_mcons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("mcons", p, env); + | SCHEME_PRIM_IS_OMITABLE_ALLOCATION + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("mcons", p, env); p = scheme_make_immed_prim(scheme_checked_mcar, "mcar", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("mcar", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("mcar", p, env); p = scheme_make_immed_prim(scheme_checked_mcdr, "mcdr", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("mcdr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("mcdr", p, env); p = scheme_make_immed_prim(scheme_checked_set_mcar, "set-mcar!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("set-mcar!", p, env); + scheme_addto_prim_instance ("set-mcar!", p, env); p = scheme_make_immed_prim(scheme_checked_set_mcdr, "set-mcdr!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("set-mcdr!", p, env); + scheme_addto_prim_instance ("set-mcdr!", p, env); REGISTER_SO(scheme_null_p_proc); p = scheme_make_folding_prim(null_p_prim, "null?", 1, 1, 1); scheme_null_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("null?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("null?", p, env); REGISTER_SO(scheme_list_p_proc); p = scheme_make_folding_prim(list_p_prim, "list?", 1, 1, 1); scheme_list_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("list?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("list?", p, env); REGISTER_SO(scheme_list_proc); p = scheme_make_immed_prim(list_prim, "list", 0, -1); @@ -300,7 +311,7 @@ scheme_init_list (Scheme_Env *env) | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("list", p, env); + scheme_addto_prim_instance ("list", p, env); REGISTER_SO(scheme_list_star_proc); p = scheme_make_immed_prim(list_star_prim, "list*", 1, -1); @@ -309,31 +320,33 @@ scheme_init_list (Scheme_Env *env) | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("list*", p, env); + scheme_addto_prim_instance ("list*", p, env); REGISTER_SO(scheme_list_pair_p_proc); p = scheme_make_folding_prim(list_pair_p_prim, "list-pair?", 1, 1, 1); scheme_list_pair_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("list-pair?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("list-pair?", p, env); p = scheme_make_folding_prim(immutablep, "immutable?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("immutable?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("immutable?", p, env); p = scheme_make_immed_prim(length_prim, "length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("length", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("length", p, env); - scheme_add_global_constant ("append", - scheme_make_immed_prim(append_prim, - "append", - 0, -1), - env); - scheme_add_global_constant ("reverse", + p = scheme_make_immed_prim(append_prim, "append", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("append", p, env); + + scheme_addto_prim_instance ("reverse", scheme_make_immed_prim(reverse_prim, "reverse", 1, 1), @@ -341,469 +354,482 @@ scheme_init_list (Scheme_Env *env) p = scheme_make_immed_prim(scheme_checked_list_tail, "list-tail", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("list-tail", p, env); + scheme_addto_prim_instance ("list-tail", p, env); p = scheme_make_immed_prim(scheme_checked_list_ref, "list-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("list-ref",p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("list-ref",p, env); - scheme_add_global_constant ("assq", + scheme_addto_prim_instance ("assq", scheme_make_immed_prim(assq, "assq", 2, 2), env); - scheme_add_global_constant ("assv", + scheme_addto_prim_instance ("assv", scheme_make_immed_prim(assv, "assv", 2, 2), env); - scheme_add_global_constant ("assoc", + scheme_addto_prim_instance ("assoc", scheme_make_immed_prim(assoc, "assoc", 2, 2), env); p = scheme_make_folding_prim(scheme_checked_caar, "caar", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caar", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("caar", p, env); p = scheme_make_folding_prim(scheme_checked_cadr, "cadr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cadr", p, env); p = scheme_make_folding_prim(scheme_checked_cdar, "cdar", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdar", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cdar", p, env); p = scheme_make_folding_prim(scheme_checked_cddr, "cddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cddr", p, env); p = scheme_make_folding_prim(caaar_prim, "caaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaar", p, env); + scheme_addto_prim_instance ("caaar", p, env); p = scheme_make_folding_prim(caadr_prim, "caadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caadr", p, env); + scheme_addto_prim_instance ("caadr", p, env); p = scheme_make_folding_prim(cadar_prim, "cadar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadar", p, env); + scheme_addto_prim_instance ("cadar", p, env); p = scheme_make_folding_prim(cdaar_prim, "cdaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaar", p, env); + scheme_addto_prim_instance ("cdaar", p, env); p = scheme_make_folding_prim(cdadr_prim, "cdadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdadr", p, env); + scheme_addto_prim_instance ("cdadr", p, env); p = scheme_make_folding_prim(cddar_prim, "cddar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddar", p, env); + scheme_addto_prim_instance ("cddar", p, env); p = scheme_make_folding_prim(caddr_prim, "caddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("caddr", p, env); p = scheme_make_folding_prim(cdddr_prim, "cdddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cdddr", p, env); p = scheme_make_folding_prim(cddddr_prim, "cddddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cddddr", p, env); p = scheme_make_folding_prim(cadddr_prim, "cadddr", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadddr", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("cadddr", p, env); p = scheme_make_folding_prim(cdaddr_prim, "cdaddr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaddr", p, env); + scheme_addto_prim_instance ("cdaddr", p, env); p = scheme_make_folding_prim(cddadr_prim, "cddadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddadr", p, env); + scheme_addto_prim_instance ("cddadr", p, env); p = scheme_make_folding_prim(cdddar_prim, "cdddar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdddar", p, env); + scheme_addto_prim_instance ("cdddar", p, env); p = scheme_make_folding_prim(caaddr_prim, "caaddr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaddr", p, env); + scheme_addto_prim_instance ("caaddr", p, env); p = scheme_make_folding_prim(cadadr_prim, "cadadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadadr", p, env); + scheme_addto_prim_instance ("cadadr", p, env); p = scheme_make_folding_prim(caddar_prim, "caddar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caddar", p, env); + scheme_addto_prim_instance ("caddar", p, env); p = scheme_make_folding_prim(cdaadr_prim, "cdaadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaadr", p, env); + scheme_addto_prim_instance ("cdaadr", p, env); p = scheme_make_folding_prim(cdadar_prim, "cdadar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdadar", p, env); + scheme_addto_prim_instance ("cdadar", p, env); p = scheme_make_folding_prim(cddaar_prim, "cddaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cddaar", p, env); + scheme_addto_prim_instance ("cddaar", p, env); p = scheme_make_folding_prim(cdaaar_prim, "cdaaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cdaaar", p, env); + scheme_addto_prim_instance ("cdaaar", p, env); p = scheme_make_folding_prim(cadaar_prim, "cadaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("cadaar", p, env); + scheme_addto_prim_instance ("cadaar", p, env); p = scheme_make_folding_prim(caadar_prim, "caadar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caadar", p, env); + scheme_addto_prim_instance ("caadar", p, env); p = scheme_make_folding_prim(caaadr_prim, "caaadr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaadr", p, env); + scheme_addto_prim_instance ("caaadr", p, env); p = scheme_make_folding_prim(caaaar_prim, "caaaar", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant ("caaaar", p, env); + scheme_addto_prim_instance ("caaaar", p, env); REGISTER_SO(scheme_box_proc); - p = scheme_make_immed_prim(box, BOX, 1, 1); + p = scheme_make_immed_prim(box, "box", 1, 1); scheme_box_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant(BOX, p, env); + scheme_addto_prim_instance("box", p, env); REGISTER_SO(scheme_box_immutable_proc); p = scheme_make_immed_prim(immutable_box, "box-immutable", 1, 1); scheme_box_immutable_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant("box-immutable", p, env); + scheme_addto_prim_instance("box-immutable", p, env); REGISTER_SO(scheme_box_p_proc); - p = scheme_make_folding_prim(box_p, BOXP, 1, 1, 1); + p = scheme_make_folding_prim(box_p, "box?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant(BOXP, p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("box?", p, env); scheme_box_p_proc = p; - p = scheme_make_noncm_prim(unbox, UNBOX, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant(UNBOX, p, env); + p = scheme_make_noncm_prim(unbox, "unbox", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unbox", p, env); - p = scheme_make_immed_prim(set_box, SETBOX, 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant(SETBOX, p, env); + p = scheme_make_immed_prim(set_box, "set-box!", 2, 2); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("set-box!", p, env); + + p = scheme_make_noncm_prim(unbox_star, "unbox*", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unbox*", p, env); + + p = scheme_make_immed_prim(set_box_star, "set-box*!", 2, 2); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("set-box*!", p, env); p = scheme_make_immed_prim(scheme_box_cas, "box-cas!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("box-cas!", p, env); + scheme_addto_prim_instance("box-cas!", p, env); - scheme_add_global_constant("chaperone-box", + scheme_addto_prim_instance("chaperone-box", scheme_make_prim_w_arity(chaperone_box, "chaperone-box", 3, -1), env); - scheme_add_global_constant("impersonate-box", + scheme_addto_prim_instance("impersonate-box", scheme_make_prim_w_arity(impersonate_box, "impersonate-box", 3, -1), env); - scheme_add_global_constant("make-hash", - scheme_make_immed_prim(make_hash, - "make-hash", - 0, 1), - env); - scheme_add_global_constant("make-hasheq", - scheme_make_immed_prim(make_hasheq, - "make-hasheq", - 0, 1), - env); - scheme_add_global_constant("make-hasheqv", - scheme_make_immed_prim(make_hasheqv, - "make-hasheqv", - 0, 1), - env); - scheme_add_global_constant("make-weak-hash", - scheme_make_immed_prim(make_weak_hash, - "make-weak-hash", - 0, 1), - env); - scheme_add_global_constant("make-weak-hasheq", - scheme_make_immed_prim(make_weak_hasheq, - "make-weak-hasheq", - 0, 1), - env); - scheme_add_global_constant("make-weak-hasheqv", - scheme_make_immed_prim(make_weak_hasheqv, - "make-weak-hasheqv", - 0, 1), - env); - scheme_add_global_constant("make-immutable-hash", - scheme_make_immed_prim(scheme_make_immutable_hash, - "make-immutable-hash", - 0, 1), - env); - scheme_add_global_constant("make-immutable-hasheq", - scheme_make_immed_prim(scheme_make_immutable_hasheq, - "make-immutable-hasheq", - 0, 1), - env); - scheme_add_global_constant("make-immutable-hasheqv", - scheme_make_immed_prim(scheme_make_immutable_hasheqv, - "make-immutable-hasheqv", - 0, 1), - env); - scheme_add_global_constant("hash", - scheme_make_immed_prim(direct_hash, - "hash", - 0, -1), - env); - scheme_add_global_constant("hasheq", - scheme_make_immed_prim(direct_hasheq, - "hasheq", - 0, -1), - env); - scheme_add_global_constant("hasheqv", - scheme_make_immed_prim(direct_hasheqv, - "hasheqv", - 0, -1), - env); - scheme_add_global_constant("hash?", - scheme_make_folding_prim(hash_p, - "hash?", - 1, 1, 1), - env); - scheme_add_global_constant("hash-eq?", + + p = scheme_make_immed_prim(make_hash, "make-hash", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-hash", p, env); + + p = scheme_make_immed_prim(make_hasheq, "make-hasheq", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-hasheq", p, env); + + p = scheme_make_immed_prim(make_hasheqv, "make-hasheqv", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-hasheqv", p, env); + + p = scheme_make_immed_prim(make_weak_hash, "make-weak-hash", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-weak-hash", p, env); + + p = scheme_make_immed_prim(make_weak_hasheq, "make-weak-hasheq", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-weak-hasheq", p, env); + + p = scheme_make_immed_prim(make_weak_hasheqv, "make-weak-hasheqv", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-weak-hasheqv", p, env); + + p = scheme_make_immed_prim(scheme_make_immutable_hash, "make-immutable-hash", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-immutable-hash", p, env); + + p = scheme_make_immed_prim(scheme_make_immutable_hasheq, "make-immutable-hasheq", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-immutable-hasheq", p, env); + + p = scheme_make_immed_prim(scheme_make_immutable_hasheqv, "make-immutable-hasheqv", 0, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("make-immutable-hasheqv", p, env); + + p = scheme_make_immed_prim(direct_hash, "hash", 0, -1); + /* not SCHEME_PRIM_IS_OMITABLE_ALLOCATION, because `equal?`-hashing functions are called */ + scheme_addto_prim_instance("hash", p, env); + + p = scheme_make_immed_prim(direct_hasheq, "hasheq", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("hasheq", p, env); + + p = scheme_make_immed_prim(direct_hasheqv, "hasheqv", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION); + scheme_addto_prim_instance("hasheqv", p, env); + + p = scheme_make_folding_prim(hash_p, "hash?", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance ("hash?", p, env); + + + scheme_addto_prim_instance("hash-eq?", scheme_make_folding_prim(scheme_hash_eq_p, "hash-eq?", 1, 1, 1), env); - scheme_add_global_constant("hash-eqv?", + scheme_addto_prim_instance("hash-eqv?", scheme_make_folding_prim(scheme_hash_eqv_p, "hash-eqv?", 1, 1, 1), env); - scheme_add_global_constant("hash-equal?", + scheme_addto_prim_instance("hash-equal?", scheme_make_folding_prim(scheme_hash_equal_p, "hash-equal?", 1, 1, 1), env); - scheme_add_global_constant("hash-weak?", + scheme_addto_prim_instance("hash-weak?", scheme_make_folding_prim(hash_weak_p, "hash-weak?", 1, 1, 1), env); - scheme_add_global_constant("hash-count", - scheme_make_immed_prim(hash_table_count, - "hash-count", - 1, 1), - env); - scheme_add_global_constant("hash-copy", + + p = scheme_make_immed_prim(scheme_checked_hash_count, "hash-count", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); + scheme_addto_prim_instance("hash-count", p, env); + + scheme_addto_prim_instance("hash-copy", scheme_make_noncm_prim(hash_table_copy, "hash-copy", 1, 1), env); - scheme_add_global_constant("hash-set!", + scheme_addto_prim_instance("hash-set!", scheme_make_noncm_prim(hash_table_put_bang, "hash-set!", 3, 3), env); - scheme_add_global_constant("hash-set", + scheme_addto_prim_instance("hash-set", scheme_make_noncm_prim(scheme_hash_table_put, "hash-set", 3, 3), env); REGISTER_SO(scheme_hash_ref_proc); - scheme_hash_ref_proc = scheme_make_prim_w_arity(hash_table_get, "hash-ref", 2, 3); - scheme_add_global_constant("hash-ref", scheme_hash_ref_proc, env); - scheme_add_global_constant("hash-remove!", + scheme_hash_ref_proc = scheme_make_prim_w_arity(scheme_checked_hash_ref, "hash-ref", 2, 3); + scheme_addto_prim_instance("hash-ref", scheme_hash_ref_proc, env); + scheme_addto_prim_instance("hash-remove!", scheme_make_noncm_prim(hash_table_remove_bang, "hash-remove!", 2, 2), env); - scheme_add_global_constant("hash-remove", + scheme_addto_prim_instance("hash-remove", scheme_make_noncm_prim(hash_table_remove, "hash-remove", 2, 2), env); - scheme_add_global_constant("hash-clear!", + scheme_addto_prim_instance("hash-clear!", scheme_make_noncm_prim(hash_table_clear_bang, "hash-clear!", 1, 1), env); - scheme_add_global_constant("hash-clear", + scheme_addto_prim_instance("hash-clear", scheme_make_noncm_prim(hash_table_clear, "hash-clear", 1, 1), env); - scheme_add_global_constant("hash-map", + scheme_addto_prim_instance("hash-map", scheme_make_noncm_prim(hash_table_map, "hash-map", 2, 3), env); - scheme_add_global_constant("hash-for-each", + scheme_addto_prim_instance("hash-for-each", scheme_make_noncm_prim(hash_table_for_each, "hash-for-each", 2, 3), env); - scheme_add_global_constant("hash-iterate-first", + scheme_addto_prim_instance("hash-iterate-first", scheme_make_immed_prim(scheme_hash_table_iterate_start, "hash-iterate-first", 1, 1), env); - scheme_add_global_constant("hash-iterate-next", + scheme_addto_prim_instance("hash-iterate-next", scheme_make_immed_prim(scheme_hash_table_iterate_next, "hash-iterate-next", 2, 2), env); - scheme_add_global_constant("hash-iterate-value", + scheme_addto_prim_instance("hash-iterate-value", scheme_make_noncm_prim(scheme_hash_table_iterate_value, "hash-iterate-value", 2, 2), env); - scheme_add_global_constant("hash-iterate-key", + scheme_addto_prim_instance("hash-iterate-key", scheme_make_noncm_prim(scheme_hash_table_iterate_key, "hash-iterate-key", 2, 2), env); - scheme_add_global_constant("hash-iterate-pair", + scheme_addto_prim_instance("hash-iterate-pair", scheme_make_immed_prim(scheme_hash_table_iterate_pair, "hash-iterate-pair", 2, 2), env); - scheme_add_global_constant("hash-iterate-key+value", + scheme_addto_prim_instance("hash-iterate-key+value", scheme_make_prim_w_arity2(scheme_hash_table_iterate_key_value, "hash-iterate-key+value", 2, 2, 2, 2), env); - scheme_add_global_constant("hash-keys-subset?", + scheme_addto_prim_instance("hash-keys-subset?", scheme_make_immed_prim(hash_keys_subset_p, "hash-keys-subset?", 2, 2), env); - scheme_add_global_constant("chaperone-hash", + scheme_addto_prim_instance("chaperone-hash", scheme_make_prim_w_arity(chaperone_hash, "chaperone-hash", 5, -1), env); - scheme_add_global_constant("impersonate-hash", + scheme_addto_prim_instance("impersonate-hash", scheme_make_prim_w_arity(impersonate_hash, "impersonate-hash", 5, -1), env); - scheme_add_global_constant("eq-hash-code", + scheme_addto_prim_instance("eq-hash-code", scheme_make_immed_prim(eq_hash_code, "eq-hash-code", 1, 1), env); - scheme_add_global_constant("eqv-hash-code", + scheme_addto_prim_instance("eqv-hash-code", scheme_make_immed_prim(eqv_hash_code, "eqv-hash-code", 1, 1), env); - scheme_add_global_constant("equal-hash-code", + scheme_addto_prim_instance("equal-hash-code", scheme_make_noncm_prim(equal_hash_code, "equal-hash-code", 1, 1), env); - scheme_add_global_constant("equal-secondary-hash-code", + scheme_addto_prim_instance("equal-secondary-hash-code", scheme_make_noncm_prim(equal_hash2_code, "equal-secondary-hash-code", 1, 1), env); - scheme_add_global_constant("make-weak-box", + scheme_addto_prim_instance("make-weak-box", scheme_make_immed_prim(make_weak_box, "make-weak-box", 1, 1), env); - scheme_add_global_constant("weak-box-value", - scheme_make_immed_prim(weak_box_value, - "weak-box-value", - 1, 2), - env); - scheme_add_global_constant("weak-box?", + + p = scheme_make_immed_prim(weak_box_value, "weak-box-value", 1, 2); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); + scheme_addto_prim_instance("weak-box-value", p, env); + + scheme_addto_prim_instance("weak-box?", scheme_make_folding_prim(weak_boxp, "weak-box?", 1, 1, 1), env); - scheme_add_global_constant("make-ephemeron", + scheme_addto_prim_instance("make-ephemeron", scheme_make_immed_prim(make_ephemeron, "make-ephemeron", 2, 2), env); - scheme_add_global_constant("ephemeron-value", + scheme_addto_prim_instance("ephemeron-value", scheme_make_immed_prim(ephemeron_value, "ephemeron-value", 1, 2), env); - scheme_add_global_constant("ephemeron?", + scheme_addto_prim_instance("ephemeron?", scheme_make_folding_prim(ephemeronp, "ephemeron?", 1, 1, 1), env); - scheme_add_global_constant("impersonator-ephemeron", + scheme_addto_prim_instance("impersonator-ephemeron", scheme_make_immed_prim(impersonator_ephemeron, "impersonator-ephemeron", 1, 1), env); - scheme_add_global_constant("make-reader-graph", + scheme_addto_prim_instance("make-reader-graph", scheme_make_prim_w_arity(make_graph, "make-reader-graph", 1, 1), env); - scheme_add_global_constant("make-placeholder", + scheme_addto_prim_instance("make-placeholder", scheme_make_prim_w_arity(make_placeholder, "make-placeholder", 1, 1), env); - scheme_add_global_constant("placeholder-get", + scheme_addto_prim_instance("placeholder-get", scheme_make_prim_w_arity(placeholder_get, "placeholder-get", 1, 1), env); - scheme_add_global_constant("placeholder-set!", + scheme_addto_prim_instance("placeholder-set!", scheme_make_prim_w_arity(placeholder_set, "placeholder-set!", 2, 2), env); - scheme_add_global_constant("placeholder?", + scheme_addto_prim_instance("placeholder?", scheme_make_folding_prim(placeholder_p, "placeholder?", 1, 1, 1), env); - scheme_add_global_constant("make-hash-placeholder", + scheme_addto_prim_instance("make-hash-placeholder", scheme_make_prim_w_arity(make_hash_placeholder, "make-hash-placeholder", 1, 1), env); - scheme_add_global_constant("make-hasheq-placeholder", + scheme_addto_prim_instance("make-hasheq-placeholder", scheme_make_prim_w_arity(make_hasheq_placeholder, "make-hasheq-placeholder", 1, 1), env); - scheme_add_global_constant("make-hasheqv-placeholder", + scheme_addto_prim_instance("make-hasheqv-placeholder", scheme_make_prim_w_arity(make_hasheqv_placeholder, "make-hasheqv-placeholder", 1, 1), env); - scheme_add_global_constant("hash-placeholder?", + scheme_addto_prim_instance("hash-placeholder?", scheme_make_folding_prim(table_placeholder_p, "hash-placeholder?", 1, 1, 1), @@ -814,10 +840,17 @@ scheme_init_list (Scheme_Env *env) weak_symbol = scheme_intern_symbol("weak"); equal_symbol = scheme_intern_symbol("equal"); + + REGISTER_SO(empty_hash); + REGISTER_SO(empty_hasheq); + REGISTER_SO(empty_hasheqv); + empty_hash = scheme_make_hash_tree(1); + empty_hasheq = scheme_make_hash_tree(0); + empty_hasheqv = scheme_make_hash_tree(2); } void -scheme_init_unsafe_list (Scheme_Env *env) +scheme_init_unsafe_list (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -827,91 +860,103 @@ scheme_init_unsafe_list (Scheme_Env *env) p = scheme_make_immed_prim(unsafe_cons_list, "unsafe-cons-list", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant ("unsafe-cons-list", p, env); + scheme_addto_prim_instance ("unsafe-cons-list", p, env); scheme_unsafe_cons_list_proc = p; REGISTER_SO(scheme_unsafe_car_proc); p = scheme_make_folding_prim(unsafe_car, "unsafe-car", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL - | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-car", p, env); + | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-car", p, env); scheme_unsafe_car_proc = p; REGISTER_SO(scheme_unsafe_cdr_proc); p = scheme_make_folding_prim(unsafe_cdr, "unsafe-cdr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL - | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-cdr", p, env); + | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-cdr", p, env); scheme_unsafe_cdr_proc = p; p = scheme_make_folding_prim(unsafe_list_ref, "unsafe-list-ref", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-list-ref", p, env); + scheme_addto_prim_instance ("unsafe-list-ref", p, env); p = scheme_make_folding_prim(unsafe_list_tail, "unsafe-list-tail", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-list-tail", p, env); + scheme_addto_prim_instance ("unsafe-list-tail", p, env); REGISTER_SO(scheme_unsafe_mcar_proc); p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("unsafe-mcar", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-mcar", p, env); scheme_unsafe_mcar_proc = p; REGISTER_SO(scheme_unsafe_mcdr_proc); p = scheme_make_immed_prim(unsafe_mcdr, "unsafe-mcdr", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant ("unsafe-mcdr", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance ("unsafe-mcdr", p, env); scheme_unsafe_mcdr_proc = p; p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("unsafe-set-mcar!", p, env); + scheme_addto_prim_instance ("unsafe-set-mcar!", p, env); p = scheme_make_immed_prim(unsafe_set_mcdr, "unsafe-set-mcdr!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant ("unsafe-set-mcdr!", p, env); + scheme_addto_prim_instance ("unsafe-set-mcdr!", p, env); REGISTER_SO(scheme_unsafe_unbox_proc); p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-unbox", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-unbox", p, env); scheme_unsafe_unbox_proc = p; + REGISTER_SO(scheme_unsafe_unbox_star_proc); p = scheme_make_immed_prim(unsafe_unbox_star, "unsafe-unbox*", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-unbox*", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-unbox*", p, env); + scheme_unsafe_unbox_star_proc = p; + REGISTER_SO(scheme_unsafe_set_box_star_proc); p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("unsafe-set-box!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-set-box!", p, env); + scheme_unsafe_set_box_star_proc = p; p = scheme_make_immed_prim(unsafe_set_box_star, "unsafe-set-box*!", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("unsafe-set-box*!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("unsafe-set-box*!", p, env); p = scheme_make_prim_w_arity(scheme_box_cas, "unsafe-box*-cas!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-box*-cas!", p, env); + scheme_addto_prim_instance("unsafe-box*-cas!", p, env); } void -scheme_init_unsafe_hash (Scheme_Env *env) +scheme_init_unsafe_hash (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -920,38 +965,38 @@ scheme_init_unsafe_hash (Scheme_Env *env) "unsafe-mutable-hash-iterate-first", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-first", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-first", p, env); p = scheme_make_immed_prim(unsafe_hash_tree_iterate_start, "unsafe-immutable-hash-iterate-first", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-first", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-first", p, env); p = scheme_make_immed_prim(unsafe_bucket_table_iterate_start, "unsafe-weak-hash-iterate-first", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-weak-hash-iterate-first", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-first", p, env); /* unsafe-hash-iterate-next ---------------------------------------- */ p = scheme_make_immed_prim(unsafe_hash_table_iterate_next, "unsafe-mutable-hash-iterate-next", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-next", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-next", p, env); p = scheme_make_immed_prim(unsafe_hash_tree_iterate_next, "unsafe-immutable-hash-iterate-next", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-next", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-next", p, env); p = scheme_make_immed_prim(unsafe_bucket_table_iterate_next, "unsafe-weak-hash-iterate-next", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-weak-hash-iterate-next", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-next", p, env); /* unsafe-hash-iterate-key ---------------------------------------- */ p = scheme_make_noncm_prim(unsafe_hash_table_iterate_key, @@ -959,21 +1004,21 @@ scheme_init_unsafe_hash (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-key", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-key", p, env); p = scheme_make_noncm_prim(unsafe_hash_tree_iterate_key, "unsafe-immutable-hash-iterate-key", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-key", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-key", p, env); p = scheme_make_noncm_prim(unsafe_bucket_table_iterate_key, "unsafe-weak-hash-iterate-key", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-key", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-key", p, env); /* unsafe-hash-iterate-value ---------------------------------------- */ p = scheme_make_noncm_prim(unsafe_hash_table_iterate_value, @@ -981,21 +1026,21 @@ scheme_init_unsafe_hash (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-value", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-value", p, env); p = scheme_make_noncm_prim(unsafe_hash_tree_iterate_value, "unsafe-immutable-hash-iterate-value", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-value", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-value", p, env); p = scheme_make_noncm_prim(unsafe_bucket_table_iterate_value, "unsafe-weak-hash-iterate-value", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-value", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-value", p, env); /* unsafe-hash-iterate-key+value ---------------------------------------- */ p = scheme_make_prim_w_arity2(unsafe_hash_table_iterate_key_value, @@ -1004,7 +1049,7 @@ scheme_init_unsafe_hash (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-key+value", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-key+value", p, env); p = scheme_make_prim_w_arity2(unsafe_hash_tree_iterate_key_value, "unsafe-immutable-hash-iterate-key+value", @@ -1012,7 +1057,7 @@ scheme_init_unsafe_hash (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-key+value", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-key+value", p, env); p = scheme_make_prim_w_arity2(unsafe_bucket_table_iterate_key_value, "unsafe-weak-hash-iterate-key+value", @@ -1020,7 +1065,7 @@ scheme_init_unsafe_hash (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-key+value", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-key+value", p, env); /* unsafe-hash-iterate-pair ---------------------------------------- */ p = scheme_make_immed_prim(unsafe_hash_table_iterate_pair, @@ -1029,14 +1074,14 @@ scheme_init_unsafe_hash (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-mutable-hash-iterate-pair", p, env); + scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-pair", p, env); p = scheme_make_immed_prim(unsafe_hash_tree_iterate_pair, "unsafe-immutable-hash-iterate-pair", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant ("unsafe-immutable-hash-iterate-pair", p, env); + scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-pair", p, env); p = scheme_make_immed_prim(unsafe_bucket_table_iterate_pair, "unsafe-weak-hash-iterate-pair", @@ -1044,7 +1089,7 @@ scheme_init_unsafe_hash (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION | SCHEME_PRIM_IS_UNSAFE_OMITABLE); - scheme_add_global_constant ("unsafe-weak-hash-iterate-pair", p, env); + scheme_addto_prim_instance ("unsafe-weak-hash-iterate-pair", p, env); } Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr) @@ -1856,10 +1901,18 @@ Scheme_Object *scheme_unbox(Scheme_Object *obj) && SCHEME_BOXP(SCHEME_CHAPERONE_VAL(obj))) return chaperone_unbox(obj); - scheme_wrong_contract(UNBOX, "box?", 0, 1, &obj); + scheme_wrong_contract("unbox", "box?", 0, 1, &obj); } - return (Scheme_Object *)SCHEME_BOX_VAL(obj); + return SCHEME_BOX_VAL(obj); +} + +Scheme_Object *scheme_unbox_star(Scheme_Object *obj) +{ + if (!SCHEME_BOXP(obj)) + scheme_wrong_contract("unbox*", "(and/c box? (not/c impersonator?))", 0, 1, &obj); + + return SCHEME_BOX_VAL(obj); } Scheme_Object *scheme_box_cas(int argc, Scheme_Object *argv[]) @@ -1925,11 +1978,19 @@ void scheme_set_box(Scheme_Object *b, Scheme_Object *v) return; } - scheme_wrong_contract(SETBOX, "(and/c box? (not/c immutable?))", 0, 1, &b); + scheme_wrong_contract("set-box!", "(and/c box? (not/c immutable?))", 0, 1, &b); } SCHEME_BOX_VAL(b) = v; } +void scheme_set_box_star(Scheme_Object *b, Scheme_Object *v) +{ + if (!SCHEME_MUTABLE_BOXP(b)) + scheme_wrong_contract("set-box*!", "(and/c box? (not/c immutable?) (not/c impersonator?))", 0, 1, &b); + + SCHEME_BOX_VAL(b) = v; +} + static Scheme_Object *box(int c, Scheme_Object *p[]) { return scheme_box(p[0]); @@ -1955,12 +2016,23 @@ static Scheme_Object *unbox(int c, Scheme_Object *p[]) return scheme_unbox(p[0]); } +static Scheme_Object *unbox_star(int c, Scheme_Object *p[]) +{ + return scheme_unbox_star(p[0]); +} + static Scheme_Object *set_box(int c, Scheme_Object *p[]) { scheme_set_box(p[0], p[1]); return scheme_void; } +static Scheme_Object *set_box_star(int c, Scheme_Object *p[]) +{ + scheme_set_box_star(p[0], p[1]); + return scheme_void; +} + static Scheme_Object *do_chaperone_box(const char *name, int is_impersonator, int argc, Scheme_Object **argv) { Scheme_Chaperone *px; @@ -2185,7 +2257,7 @@ Scheme_Object *scheme_make_immutable_hasheqv(int argc, Scheme_Object *argv[]) return make_immutable_table("make-immutable-hasheqv", 2, argc, argv); } -static Scheme_Object *direct_table(const char *who, int kind, int argc, Scheme_Object *argv[]) +static Scheme_Object *direct_table(const char *who, int kind, Scheme_Hash_Tree *empty, int argc, Scheme_Object *argv[]) { int i; Scheme_Hash_Tree *ht; @@ -2198,7 +2270,10 @@ static Scheme_Object *direct_table(const char *who, int kind, int argc, Scheme_O return NULL; } - ht = scheme_make_hash_tree(kind); + if (!argc) + ht = scheme_make_hash_tree(kind); + else + ht = empty; for (i = 0; i < argc; i += 2) { ht = scheme_hash_tree_set(ht, argv[i], argv[i+1]); @@ -2209,17 +2284,17 @@ static Scheme_Object *direct_table(const char *who, int kind, int argc, Scheme_O static Scheme_Object *direct_hash(int argc, Scheme_Object *argv[]) { - return direct_table("hash", 1, argc, argv); + return direct_table("hash", 1, empty_hash, argc, argv); } static Scheme_Object *direct_hasheq(int argc, Scheme_Object *argv[]) { - return direct_table("hasheq", 0, argc, argv); + return direct_table("hasheq", 0, empty_hasheq, argc, argv); } static Scheme_Object *direct_hasheqv(int argc, Scheme_Object *argv[]) { - return direct_table("hasheqv", 2, argc, argv); + return direct_table("hasheqv", 2, empty_hasheqv, argc, argv); } Scheme_Hash_Table *scheme_make_hash_table_equal() @@ -2237,21 +2312,6 @@ Scheme_Hash_Table *scheme_make_hash_table_equal() return t; } -static int compare_equal_modidx_eq(void *v1, void *v2) -{ - return !scheme_equal_modix_eq((Scheme_Object *)v1, (Scheme_Object *)v2); -} - -Scheme_Hash_Table *scheme_make_hash_table_equal_modix_eq() -{ - Scheme_Hash_Table *t; - - t = scheme_make_hash_table_equal(); - t->compare = compare_equal_modidx_eq; - - return t; -} - Scheme_Hash_Table *scheme_make_hash_table_eqv() { Scheme_Hash_Table *t; @@ -2264,7 +2324,7 @@ Scheme_Hash_Table *scheme_make_hash_table_eqv() return t; } -static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[]) +Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]) { Scheme_Object *v = argv[0]; @@ -2528,7 +2588,7 @@ Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[]) scheme_wrong_contract("hash-set", "(and hash? immutable?)", 0, argc, argv); return NULL; } - + return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)v, argv[1], argv[2]); } @@ -2588,7 +2648,7 @@ static Scheme_Object *gen_hash_table_get(int argc, Scheme_Object *argv[]) return hash_failed(argc, argv); } -static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[]) +Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]) XFORM_ASSERT_NO_CONVERSION { Scheme_Object *v; @@ -3137,8 +3197,8 @@ static Scheme_Object *hash_keys_subset_p_slow(int argc, Scheme_Object *argv[]) return NULL; } - i1 = hash_table_count(1, argv); - c2 = hash_table_count(1, b); + i1 = scheme_checked_hash_count(1, argv); + c2 = scheme_checked_hash_count(1, b); if (SCHEME_INT_VAL(i1) > SCHEME_INT_VAL(c2)) return scheme_false; @@ -3529,7 +3589,15 @@ static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, { return chaperone_hash_op(name, table, key, NULL, 3, scheme_null); } -static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *key, Scheme_Object **_chap_key, Scheme_Object **_chap_val, int ischap) + +Scheme_Object *scheme_chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key) +{ + return chaperone_hash_key(name, table, key); +} + +static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *key, + Scheme_Object **_chap_key, Scheme_Object **_chap_val, + int ischap) { Scheme_Object *chap_key, *chap_val; chap_key = chaperone_hash_key(name, obj, key); @@ -3540,6 +3608,13 @@ static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Schem *_chap_val = chap_val; } +void scheme_chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *k, + Scheme_Object **_chap_key, Scheme_Object **_chap_val, + int ischap) +{ + return chaperone_hash_key_value(name, obj, k, _chap_key, _chap_val, ischap); +} + static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table) { return chaperone_hash_op(name, table, NULL, NULL, 4, scheme_null); @@ -3715,6 +3790,13 @@ static Scheme_Object *weak_box_value(int argc, Scheme_Object *argv[]) return o; } +Scheme_Object *scheme_weak_box_value(Scheme_Object *obj) +{ + Scheme_Object *a[1]; + a[0] = obj; + return weak_box_value(1, a); +} + static Scheme_Object *weak_boxp(int argc, Scheme_Object *argv[]) { return (SCHEME_WEAKP(argv[0]) ? scheme_true : scheme_false); @@ -4344,7 +4426,7 @@ Scheme_Object *unsafe_hash_tree_iterate_key_value(int argc, Scheme_Object *argv[ key = subtree->els[i]; if (SCHEME_NP_CHAPERONEP(obj)) { - chaperone_hash_key_value("unsafe-immutable-hash-iterate-pair", + chaperone_hash_key_value("unsafe-immutable-hash-iterate-key+value", obj, subtree->els[i], &res[0], &res[1], 0); } else { res[0] = key; diff --git a/racket/src/racket/src/makeexn b/racket/src/racket/src/makeexn index 2a48d17193..a86b17aa7a 100755 --- a/racket/src/racket/src/makeexn +++ b/racket/src/racket/src/makeexn @@ -43,19 +43,20 @@ propeties (the latter in curly braces), strings are contracts/comments. (variable [variable_field_check (id "symbol" "the variable's identifier")] "not-yet-defined global or module variable")) - (syntax [syntax_field_check + (#:only-kernstruct + syntax [syntax_field_check (exprs "immutable list of syntax objects" "illegal expression(s)") - {exn:source scheme_source_property |scheme_make_prim(extract_syntax_locations)|}] + {exn:source scheme_source_property |scheme_make_prim_w_arity(extract_syntax_locations, "extract_syntax_locations", 0, -1)|}] "syntax error, but not a \\scmfirst{read} error" (unbound [] "unbound module variable") (missing-module [module_path_field_check_3 (path "module path" "module path") - {exn:module-path scheme_module_path_property |scheme_make_prim(extract_module_path_3)|}] + {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_3, "extract_module_path_3", 0, -1)|}] "error resolving a module path")) (read [read_field_check (srclocs "immutable list of \\scmk{srcloc}s (see \\SecRef{linecol})" "source location(s) of error") - {exn:source scheme_source_property |scheme_make_prim(extract_read_locations)|}] + {exn:source scheme_source_property |scheme_make_prim_w_arity(extract_read_locations, "extract_read_locations", 0, -1)|}] "\\rawscm{read} parsing error" (eof [] "unexpected end-of-file") (non-char [] "unexpected non-character")) @@ -65,9 +66,10 @@ propeties (the latter in curly braces), strings are contracts/comments. (errno [errno_field_check (errno "pair of symbol and number" "system error code")] "error with system error code") - (missing-module [module_path_field_check_2 + (#:only-kernstruct + missing-module [module_path_field_check_2 (path "module path" "module path") - {exn:module-path scheme_module_path_property |scheme_make_prim(extract_module_path_2)|}] + {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_2, "extract_module_path_2", 0, -1)|}] "error resolving a module path")) (network [] "TCP and UDP errors" (errno [errno_field_check @@ -96,21 +98,22 @@ Not an exception in the above sense: (define l info) (define-struct ex (define string base doc args props guard parent parent-def - numtotal depth mark)) + numtotal depth mark only-kernstruct?)) (define-struct fld (name type doc)) (define-struct prop (scheme-name c-name value)) (define max-exn-args 0) (define (make-an-ex sym parent parent-def parent-name totalargs args props - guard doc depth mark) + guard doc depth mark only-kernstruct?) (let* ([s (symbol->string sym)] [name (string-append parent-name (if (string=? "" parent-name) "" ":") s)] [count (+ totalargs (length args))]) - (when (> count max-exn-args) - (set! max-exn-args count)) + (when (and (> count max-exn-args) + (not only-kernstruct?)) + (set! max-exn-args count)) (make-ex (string-append "MZ" (list->string (let loop ([l (string->list name)]) @@ -133,7 +136,8 @@ Not an exception in the above sense: parent-def count depth - mark))) + mark + only-kernstruct?))) (define (make-arg-list args) (cond @@ -153,28 +157,33 @@ Not an exception in the above sense: [else (make-prop-list (cdr args))])) -(define (make-struct-list v parent parent-def parent-name totalargs depth) +(define (make-struct-list v parent parent-def parent-name totalargs depth only-kernstruct?) (cond [(null? v) '()] [else - (let*-values ([(s mark) - (let* ([s (symbol->string (car v))] - [c (string-ref s 0)]) - (if (or (char=? #\* c) - (char=? #\+ c)) - (values (string->symbol (substring s 1 (string-length s))) c) + (let*-values ([(v only-kernstruct?) + (if (eq? '#:only-kernstruct (car v)) + (values (cdr v) #t) + (values v only-kernstruct?))] + [(s mark) + (let* ([s (symbol->string (car v))] + [c (string-ref s 0)]) + (if (or (char=? #\* c) + (char=? #\+ c)) + (values (string->symbol (substring s 1 (string-length s))) c) (values (car v) #f)))] - [(e) (make-an-ex s parent parent-def parent-name totalargs - (if (null? (cadr v)) - null - (make-arg-list (cdadr v))) - (if (null? (cadr v)) - null - (make-prop-list (cdadr v))) - (if (null? (cadr v)) - #f - (caadr v)) - (caddr v) depth mark)]) + [(e) (make-an-ex s parent parent-def parent-name totalargs + (if (null? (cadr v)) + null + (make-arg-list (cdadr v))) + (if (null? (cadr v)) + null + (make-prop-list (cdadr v))) + (if (null? (cadr v)) + #f + (caadr v)) + (caddr v) depth mark + only-kernstruct?)]) (cons e (apply append (map @@ -184,10 +193,11 @@ Not an exception in the above sense: (ex-define e) (ex-string e) (ex-numtotal e) - (add1 depth))) + (add1 depth) + only-kernstruct?)) (cdddr v)))))])) -(set! l (make-struct-list l #f #f "" 0 0)) +(set! l (make-struct-list l #f #f "" 0 0 #f)) (define (gen-kernstruct filename) @@ -277,7 +287,7 @@ Not an exception in the above sense: #ifndef _MZEXN_DEFINES #define _MZEXN_DEFINES enum { - @(add-newlines (for/list ([e l]) @list{ @(ex-define e),})) + @(add-newlines (for/list ([e l] #:unless (ex-only-kernstruct? e)) @list{ @(ex-define e),})) MZEXN_OTHER }; #endif @@ -290,16 +300,22 @@ Not an exception in the above sense: static exn_rec exn_table[] = { @(let loop ([ll l]) (let ([e (car ll)]) - (cons @list{ { @(ex-numtotal e), NULL, NULL, 0, NULL, @; - @(if (ex-parent e) - (let loop ([pos 0][ll l]) - (if (eq? (car ll) (ex-parent e)) - pos - (loop (add1 pos) (cdr ll)))) - -1) }} - (if (null? (cdr ll)) - '() - (cons ",\n" (loop (cdr ll))))))) + (if (ex-only-kernstruct? e) + (loop (cdr ll)) + (cons @list{ { @(ex-numtotal e), NULL, NULL, 0, NULL, @; + @(if (ex-parent e) + (let loop ([pos 0][ll l]) + (cond + [(eq? (car ll) (ex-parent e)) + pos] + [(ex-only-kernstruct? (car ll)) + (loop pos (cdr ll))] + [else + (loop (add1 pos) (cdr ll))])) + -1) }} + (if (null? (cdr ll)) + '() + (cons ",\n" (loop (cdr ll)))))))) }; #else static exn_rec *exn_table; @@ -312,7 +328,7 @@ Not an exception in the above sense: #ifndef GLOBAL_EXN_ARRAY exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER); @(add-newlines - (for/list ([e l]) + (for/list ([e l] #:unless (ex-only-kernstruct? e)) @list{ exn_table[@(ex-define e)].args = @(ex-numtotal e)@";"})) #endif @@ -320,7 +336,10 @@ Not an exception in the above sense: #ifdef _MZEXN_DECL_FIELDS @(add-newlines - (for*/list ([e l] [l (in-value (ex-args e))] #:when (pair? l)) + (for*/list ([e l] + #:unless (ex-only-kernstruct? e) + [l (in-value (ex-args e))] + #:when (pair? l)) (define fields (add-between (map (lambda (f) @list{"@(fld-name f)"}) l) ", ")) @list{ static const char *@(ex-define e)_FIELDS[@(length l)] = @; @@ -330,7 +349,10 @@ Not an exception in the above sense: #ifdef _MZEXN_DECL_PROPS @(add-newlines - (for*/list ([e l] [l (in-value (ex-props e))] #:when (pair? l)) + (for*/list ([e l] + #:unless (ex-only-kernstruct? e) + [l (in-value (ex-props e))] + #:when (pair? l)) (define (acons x y l) @list{scheme_make_pair(scheme_make_pair(@x, @y), @l)}) @list{# define @(ex-define e)_PROPS @; @@ -343,7 +365,8 @@ Not an exception in the above sense: #ifdef _MZEXN_SETUP @(add-newlines - (for/list ([e l]) + (for/list ([e l] + #:unless (ex-only-kernstruct? e)) @list{ SETUP_STRUCT(@(ex-define e), @; @(let ([p (ex-parent-def e)]) (if p @list{EXN_PARENT(@p)} 'NULL)), @; @@ -356,7 +379,7 @@ Not an exception in the above sense: 'scheme_null @list{@(ex-define e)_PROPS}), @; @(if (ex-guard e) - @list{scheme_make_prim(@(ex-guard e))} + @list{scheme_make_prim_w_arity(@(ex-guard e), "@(ex-guard e)" , 0, -1)} 'NULL))})) #endif @||}) diff --git a/racket/src/racket/src/marshal.c b/racket/src/racket/src/marshal.c index 0cffd156fd..e1f3d15941 100644 --- a/racket/src/racket/src/marshal.c +++ b/racket/src/racket/src/marshal.c @@ -25,724 +25,13 @@ #include "schpriv.h" -#define cons(a,b) scheme_make_pair(a,b) #define CONS(a,b) scheme_make_pair(a,b) -static Scheme_Object *write_let_value(Scheme_Object *obj); -static Scheme_Object *read_let_value(Scheme_Object *obj); -static Scheme_Object *write_let_void(Scheme_Object *obj); -static Scheme_Object *read_let_void(Scheme_Object *obj); -static Scheme_Object *write_letrec(Scheme_Object *obj); -static Scheme_Object *read_letrec(Scheme_Object *obj); -static Scheme_Object *write_let_one(Scheme_Object *obj); -static Scheme_Object *read_let_one(Scheme_Object *obj); -static Scheme_Object *write_top(Scheme_Object *obj); -static Scheme_Object *read_top(Scheme_Object *obj); -static Scheme_Object *write_case_lambda(Scheme_Object *obj); -static Scheme_Object *read_case_lambda(Scheme_Object *obj); - -static Scheme_Object *read_define_values(Scheme_Object *obj); -static Scheme_Object *write_define_values(Scheme_Object *obj); -static Scheme_Object *read_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *write_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj); -static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj); -static Scheme_Object *read_set_bang(Scheme_Object *obj); -static Scheme_Object *write_set_bang(Scheme_Object *obj); -static Scheme_Object *read_boxenv(Scheme_Object *obj); -static Scheme_Object *write_boxenv(Scheme_Object *obj); -static Scheme_Object *read_varref(Scheme_Object *obj); -static Scheme_Object *write_varref(Scheme_Object *obj); -static Scheme_Object *read_apply_values(Scheme_Object *obj); -static Scheme_Object *write_apply_values(Scheme_Object *obj); -static Scheme_Object *read_with_immed_mark(Scheme_Object *obj); -static Scheme_Object *write_with_immed_mark(Scheme_Object *obj); -static Scheme_Object *read_inline_variant(Scheme_Object *obj); -static Scheme_Object *write_inline_variant(Scheme_Object *obj); - -static Scheme_Object *write_application(Scheme_Object *obj); -static Scheme_Object *read_application(Scheme_Object *obj); -static Scheme_Object *write_sequence(Scheme_Object *obj); -static Scheme_Object *read_sequence(Scheme_Object *obj); -static Scheme_Object *read_sequence_save_first(Scheme_Object *obj); -static Scheme_Object *read_sequence_splice(Scheme_Object *obj); -static Scheme_Object *write_branch(Scheme_Object *obj); -static Scheme_Object *read_branch(Scheme_Object *obj); -static Scheme_Object *write_with_cont_mark(Scheme_Object *obj); -static Scheme_Object *read_with_cont_mark(Scheme_Object *obj); -static Scheme_Object *write_quote_syntax(Scheme_Object *obj); -static Scheme_Object *read_quote_syntax(Scheme_Object *obj); - -static Scheme_Object *write_toplevel(Scheme_Object *obj); -static Scheme_Object *read_toplevel(Scheme_Object *obj); -static Scheme_Object *write_variable(Scheme_Object *obj); -static Scheme_Object *read_variable(Scheme_Object *obj); -static Scheme_Object *write_module_variable(Scheme_Object *obj); -static Scheme_Object *read_module_variable(Scheme_Object *obj); -static Scheme_Object *write_local(Scheme_Object *obj); -static Scheme_Object *read_local(Scheme_Object *obj); -static Scheme_Object *read_local_unbox(Scheme_Object *obj); -static Scheme_Object *write_resolve_prefix(Scheme_Object *obj); -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj); - -static Scheme_Object *write_lambda(Scheme_Object *obj); -static Scheme_Object *read_lambda(Scheme_Object *obj); - -static Scheme_Object *write_module(Scheme_Object *obj); -static Scheme_Object *read_module(Scheme_Object *obj); -static Scheme_Object *read_top_level_require(Scheme_Object *obj); -static Scheme_Object *write_top_level_require(Scheme_Object *obj); - -static Scheme_Object *ht_to_vector(Scheme_Object *ht, int delay); -static Scheme_Object *closure_marshal_name(Scheme_Object *name); - -void scheme_init_marshal(Scheme_Env *env) +void scheme_init_marshal(Scheme_Startup_Env *env) { - scheme_install_type_writer(scheme_application_type, write_application); - scheme_install_type_reader(scheme_application_type, read_application); - scheme_install_type_writer(scheme_application2_type, write_application); - scheme_install_type_reader(scheme_application2_type, read_application); - scheme_install_type_writer(scheme_application3_type, write_application); - scheme_install_type_reader(scheme_application3_type, read_application); - scheme_install_type_writer(scheme_sequence_type, write_sequence); - scheme_install_type_reader(scheme_sequence_type, read_sequence); - scheme_install_type_writer(scheme_branch_type, write_branch); - scheme_install_type_reader(scheme_branch_type, read_branch); - scheme_install_type_writer(scheme_with_cont_mark_type, write_with_cont_mark); - scheme_install_type_reader(scheme_with_cont_mark_type, read_with_cont_mark); - scheme_install_type_writer(scheme_quote_syntax_type, write_quote_syntax); - scheme_install_type_reader(scheme_quote_syntax_type, read_quote_syntax); - scheme_install_type_writer(scheme_begin0_sequence_type, write_sequence); - scheme_install_type_reader(scheme_begin0_sequence_type, read_sequence_save_first); - scheme_install_type_writer(scheme_splice_sequence_type, write_sequence); - scheme_install_type_reader(scheme_splice_sequence_type, read_sequence_splice); - - scheme_install_type_writer(scheme_let_value_type, write_let_value); - scheme_install_type_reader(scheme_let_value_type, read_let_value); - scheme_install_type_writer(scheme_let_void_type, write_let_void); - scheme_install_type_reader(scheme_let_void_type, read_let_void); - scheme_install_type_writer(scheme_letrec_type, write_letrec); - scheme_install_type_reader(scheme_letrec_type, read_letrec); - scheme_install_type_writer(scheme_let_one_type, write_let_one); - scheme_install_type_reader(scheme_let_one_type, read_let_one); - scheme_install_type_writer(scheme_case_lambda_sequence_type, write_case_lambda); - scheme_install_type_reader(scheme_case_lambda_sequence_type, read_case_lambda); - - scheme_install_type_writer(scheme_define_values_type, write_define_values); - scheme_install_type_reader(scheme_define_values_type, read_define_values); - scheme_install_type_writer(scheme_define_syntaxes_type, write_define_syntaxes); - scheme_install_type_reader(scheme_define_syntaxes_type, read_define_syntaxes); - scheme_install_type_writer(scheme_begin_for_syntax_type, write_begin_for_syntax); - scheme_install_type_reader(scheme_begin_for_syntax_type, read_begin_for_syntax); - scheme_install_type_writer(scheme_set_bang_type, write_set_bang); - scheme_install_type_reader(scheme_set_bang_type, read_set_bang); - scheme_install_type_writer(scheme_boxenv_type, write_boxenv); - scheme_install_type_reader(scheme_boxenv_type, read_boxenv); - scheme_install_type_writer(scheme_varref_form_type, write_varref); - scheme_install_type_reader(scheme_varref_form_type, read_varref); - scheme_install_type_writer(scheme_apply_values_type, write_apply_values); - scheme_install_type_reader(scheme_apply_values_type, read_apply_values); - scheme_install_type_writer(scheme_with_immed_mark_type, write_with_immed_mark); - scheme_install_type_reader(scheme_with_immed_mark_type, read_with_immed_mark); - scheme_install_type_writer(scheme_inline_variant_type, write_inline_variant); - scheme_install_type_reader(scheme_inline_variant_type, read_inline_variant); - - scheme_install_type_writer(scheme_compilation_top_type, write_top); - scheme_install_type_reader(scheme_compilation_top_type, read_top); - - scheme_install_type_writer(scheme_lambda_type, write_lambda); - scheme_install_type_reader(scheme_lambda_type, read_lambda); - - scheme_install_type_writer(scheme_toplevel_type, write_toplevel); - scheme_install_type_reader(scheme_toplevel_type, read_toplevel); - scheme_install_type_writer(scheme_variable_type, write_variable); - scheme_install_type_reader(scheme_variable_type, read_variable); - scheme_install_type_writer(scheme_module_variable_type, write_module_variable); - scheme_install_type_reader(scheme_module_variable_type, read_module_variable); - scheme_install_type_writer(scheme_local_type, write_local); - scheme_install_type_reader(scheme_local_type, read_local); - scheme_install_type_writer(scheme_local_unbox_type, write_local); - scheme_install_type_reader(scheme_local_unbox_type, read_local_unbox); - scheme_install_type_writer(scheme_resolve_prefix_type, write_resolve_prefix); - scheme_install_type_reader(scheme_resolve_prefix_type, read_resolve_prefix); - - scheme_install_type_writer(scheme_module_type, write_module); - scheme_install_type_reader(scheme_module_type, read_module); - scheme_install_type_writer(scheme_require_form_type, write_top_level_require); - scheme_install_type_reader(scheme_require_form_type, read_top_level_require); + /* nothing */ } - -static Scheme_Object *write_let_value(Scheme_Object *obj) -{ - Scheme_Let_Value *lv; - - lv = (Scheme_Let_Value *)obj; - - return cons(scheme_make_integer(lv->count), - cons(scheme_make_integer(lv->position), - cons(SCHEME_LET_VALUE_AUTOBOX(lv) ? scheme_true : scheme_false, - cons(scheme_protect_quote(lv->value), - scheme_protect_quote(lv->body))))); -} - -static Scheme_Object *read_let_value(Scheme_Object *obj) -{ - Scheme_Let_Value *lv; - - lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value)); - lv->iso.so.type = scheme_let_value_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - lv->position = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - SCHEME_LET_VALUE_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - lv->value = SCHEME_CAR(obj); - lv->body = SCHEME_CDR(obj); - - return (Scheme_Object *)lv; -} - -static Scheme_Object *write_let_void(Scheme_Object *obj) -{ - Scheme_Let_Void *lv; - - lv = (Scheme_Let_Void *)obj; - - return cons(scheme_make_integer(lv->count), - cons(SCHEME_LET_VOID_AUTOBOX(lv) ? scheme_true : scheme_false, - scheme_protect_quote(lv->body))); -} - -static Scheme_Object *read_let_void(Scheme_Object *obj) -{ - Scheme_Let_Void *lv; - - lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void)); - lv->iso.so.type = scheme_let_void_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - SCHEME_LET_VOID_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); - lv->body = SCHEME_CDR(obj); - - return (Scheme_Object *)lv; -} - -static Scheme_Object *write_let_one(Scheme_Object *obj) -{ - scheme_signal_error("let-one writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_let_one(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_letrec(Scheme_Object *obj) -{ - Scheme_Letrec *lr = (Scheme_Letrec *)obj; - Scheme_Object *l = scheme_null; - int i = lr->count; - - while (i--) { - l = cons(scheme_protect_quote(lr->procs[i]), l); - } - - return cons(scheme_make_integer(lr->count), - cons(scheme_protect_quote(lr->body), l)); -} - -static Scheme_Object *read_letrec(Scheme_Object *obj) -{ - Scheme_Letrec *lr; - int i, c; - Scheme_Object **sa; - - lr = MALLOC_ONE_TAGGED(Scheme_Letrec); - - lr->so.type = scheme_letrec_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return NULL; - lr->body = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (c < 0) return NULL; - if (c < 4096) - sa = MALLOC_N(Scheme_Object*, c); - else { - sa = scheme_malloc_fail_ok(scheme_malloc, scheme_check_overflow(c, sizeof(Scheme_Object *), 0)); - if (!sa) scheme_signal_error("out of memory allocating letrec bytecode"); - } - lr->procs = sa; - for (i = 0; i < c; i++) { - if (!SCHEME_PAIRP(obj)) return NULL; - lr->procs[i] = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - } - - return (Scheme_Object *)lr; -} - -static Scheme_Object *binding_namess_to_vectors(Scheme_Object *l) -{ - Scheme_Object *r = scheme_null; - - if (!l) return scheme_null; - - while (!SCHEME_NULLP(l)) { - r = cons(cons(SCHEME_CAR(SCHEME_CAR(l)), - ht_to_vector(SCHEME_CDR(SCHEME_CAR(l)), 0)), - r); - l = SCHEME_CDR(l); - } - - return r; -} - -static Scheme_Object *write_top(Scheme_Object *obj) -{ - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj; - - if (!top->prefix) - scheme_contract_error("write", - "cannot marshal shared compiled code", - "compiled code", 1, obj, - NULL); - - return cons(scheme_make_integer(top->max_let_depth), - cons(binding_namess_to_vectors(top->binding_namess), - cons((Scheme_Object *)top->prefix, - scheme_protect_quote(top->code)))); -} - -static Scheme_Object *read_top(Scheme_Object *obj) -{ - Scheme_Compilation_Top *top; - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - if (!SCHEME_PAIRP(obj)) return NULL; - top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); - if (top->max_let_depth < 0) return NULL; /* Should this check for a max as well? */ - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - top->binding_namess = SCHEME_CAR(obj); /* checking is in scheme_install_binding_names() */ - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); - top->code = SCHEME_CDR(obj); - if (!SAME_TYPE(SCHEME_TYPE(top->prefix), scheme_resolve_prefix_type)) - return NULL; - - return (Scheme_Object *)top; -} - -static Scheme_Object *write_case_lambda(Scheme_Object *obj) -{ - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)obj; - int i; - Scheme_Object *l; - - i = cl->count; - - l = scheme_null; - for (; i--; ) { - l = cons(cl->array[i], l); - } - - return cons(closure_marshal_name(cl->name), - l); -} - -static Scheme_Object *read_case_lambda(Scheme_Object *obj) -{ - Scheme_Object *s, *a; - int count, i, all_closed = 1; - Scheme_Case_Lambda *cl; - - if (!SCHEME_PAIRP(obj)) return NULL; - s = SCHEME_CDR(obj); - for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) { - count++; - } - - cl = (Scheme_Case_Lambda *) - scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) - + (count - mzFLEX_DELTA) * sizeof(Scheme_Object *)); - - cl->so.type = scheme_case_lambda_sequence_type; - cl->count = count; - cl->name = SCHEME_CAR(obj); - if (SCHEME_NULLP(cl->name)) - cl->name = NULL; - - s = SCHEME_CDR(obj); - for (i = 0; i < count; i++, s = SCHEME_CDR(s)) { - a = SCHEME_CAR(s); - cl->array[i] = a; - if (!SCHEME_PROCP(a)) { - if (!SAME_TYPE(SCHEME_TYPE(a), scheme_lambda_type)) - return NULL; - all_closed = 0; - } - else { - if (!SAME_TYPE(SCHEME_TYPE(a), scheme_closure_type)) - return NULL; - } - } - - if (all_closed) { - /* Empty closure: produce procedure value directly. - (We assume that this was generated by a direct write of - a case-lambda data record in print.c, and that it's not - in a CASE_LAMBDA_EXPD syntax record.) */ - return scheme_case_lambda_execute((Scheme_Object *)cl); - } - - return (Scheme_Object *)cl; -} - -static Scheme_Object *read_define_values(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_define_values_type; - return obj; -} - -static Scheme_Object *write_define_values(Scheme_Object *obj) -{ - Scheme_Object *e; - - obj = scheme_clone_vector(obj, 0, 0); - e = scheme_protect_quote(SCHEME_VEC_ELS(obj)[0]); - SCHEME_VEC_ELS(obj)[0] = e; - - return obj; -} - -static Scheme_Object *read_define_syntaxes(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_define_syntaxes_type; - return obj; -} - -static Scheme_Object *write_define_syntaxes(Scheme_Object *obj) -{ - return write_define_values(obj); -} - -static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_begin_for_syntax_type; - return obj; -} - -static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj) -{ - return scheme_clone_vector(obj, 0, 0); -} - -static Scheme_Object *read_set_bang(Scheme_Object *obj) -{ - Scheme_Set_Bang *sb; - - sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); - sb->so.type = scheme_set_bang_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj)); - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - sb->var = SCHEME_CAR(obj); - sb->val = SCHEME_CDR(obj); - - return (Scheme_Object *)sb; -} - -static Scheme_Object *write_set_bang(Scheme_Object *obj) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj; - return scheme_make_pair((sb->set_undef ? scheme_true : scheme_false), - scheme_make_pair(sb->var, - scheme_protect_quote(sb->val))); -} - -Scheme_Object *write_varref(Scheme_Object *o) -{ - int is_const = (SCHEME_VARREF_FLAGS(o) & 0x1); - - if (is_const) { - if (SCHEME_PTR1_VAL(o) != SCHEME_PTR2_VAL(o)) - scheme_signal_error("internal error: expected varref halves to be the same"); - } - - return scheme_make_pair((is_const ? scheme_true : SCHEME_PTR1_VAL(o)), - SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_varref(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_varref_form_type; - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - if (SAME_OBJ(SCHEME_CAR(o), scheme_true)) { - SCHEME_VARREF_FLAGS(data) |= 0x1; - SCHEME_PTR1_VAL(data) = SCHEME_CDR(o); - } else - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - - return data; -} - -Scheme_Object *write_apply_values(Scheme_Object *o) -{ - return scheme_make_pair(scheme_protect_quote(SCHEME_PTR1_VAL(o)), - scheme_protect_quote(SCHEME_PTR2_VAL(o))); -} - -Scheme_Object *read_apply_values(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_apply_values_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} - -Scheme_Object *write_with_immed_mark(Scheme_Object *o) -{ - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; - Scheme_Object *vec, *v; - - vec = scheme_make_vector(3, NULL); - - v = scheme_protect_quote(wcm->key); - SCHEME_VEC_ELS(vec)[0] = v; - v = scheme_protect_quote(wcm->val); - SCHEME_VEC_ELS(vec)[1] = v; - v = scheme_protect_quote(wcm->body); - SCHEME_VEC_ELS(vec)[2] = v; - - return vec; -} - -Scheme_Object *read_with_immed_mark(Scheme_Object *o) -{ - Scheme_With_Continuation_Mark *wcm; - - if (!SCHEME_VECTORP(o)) return NULL; - if (SCHEME_VEC_SIZE(o) != 3) return NULL; - - wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - wcm->so.type = scheme_with_immed_mark_type; - - wcm->key = SCHEME_VEC_ELS(o)[0]; - wcm->val = SCHEME_VEC_ELS(o)[1]; - wcm->body = SCHEME_VEC_ELS(o)[2]; - - return (Scheme_Object *)wcm; -} - -Scheme_Object *write_boxenv(Scheme_Object *o) -{ - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_boxenv(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_boxenv_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} - -static Scheme_Object *read_inline_variant(Scheme_Object *obj) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(obj)) return NULL; - - data = scheme_make_vector(3, scheme_false); - data->type = scheme_inline_variant_type; - SCHEME_VEC_ELS(data)[0] = SCHEME_CAR(obj); - SCHEME_VEC_ELS(data)[1] = SCHEME_CDR(obj); - /* third slot is filled when module->accessible table is made */ - - return data; -} - -static Scheme_Object *write_inline_variant(Scheme_Object *obj) -{ - return scheme_make_pair(SCHEME_VEC_ELS(obj)[0], - SCHEME_VEC_ELS(obj)[1]); -} - - -#define BOOL(x) (x ? scheme_true : scheme_false) - -static Scheme_Object *write_application(Scheme_Object *obj) -{ - scheme_signal_error("app writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_application(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_sequence(Scheme_Object *obj) -{ - Scheme_Object *l; - int i; - - i = ((Scheme_Sequence *)obj)->count; - - l = scheme_null; - for (; i--; ) { - l = cons(scheme_protect_quote(((Scheme_Sequence *)obj)->array[i]), l); - } - - return l; -} - -static Scheme_Object *read_sequence(Scheme_Object *obj) -{ - return scheme_make_sequence_compilation(obj, 1, 1); -} - -static Scheme_Object *read_sequence_save_first(Scheme_Object *obj) -{ - return scheme_make_sequence_compilation(obj, -2, 1); -} - -static Scheme_Object *read_sequence_splice(Scheme_Object *obj) -{ - obj = scheme_make_sequence_compilation(obj, 1, 1); - if (!obj) return NULL; - - if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type)) - obj->type = scheme_splice_sequence_type; - return obj; -} - -static Scheme_Object *write_branch(Scheme_Object *obj) -{ - scheme_signal_error("branch writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_branch(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_with_cont_mark(Scheme_Object *obj) -{ - Scheme_With_Continuation_Mark *wcm; - - wcm = (Scheme_With_Continuation_Mark *)obj; - - return cons(scheme_protect_quote(wcm->key), - cons(scheme_protect_quote(wcm->val), - scheme_protect_quote(wcm->body))); -} - -static Scheme_Object *read_with_cont_mark(Scheme_Object *obj) -{ - Scheme_With_Continuation_Mark *wcm; - - if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj))) - return NULL; /* bad .zo */ - - wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - wcm->so.type = scheme_with_cont_mark_type; - wcm->key = SCHEME_CAR(obj); - wcm->val = SCHEME_CADR(obj); - wcm->body = SCHEME_CDR(SCHEME_CDR(obj)); - - return (Scheme_Object *)wcm; -} - -static Scheme_Object *write_quote_syntax(Scheme_Object *obj) -{ - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; - - return cons(scheme_make_integer(qs->depth), - cons(scheme_make_integer(qs->position), - scheme_make_integer(qs->midpoint))); -} - -static Scheme_Object *read_quote_syntax(Scheme_Object *obj) -{ - Scheme_Quote_Syntax *qs; - Scheme_Object *a; - int c, i, p; - - if (!SCHEME_PAIRP(obj)) return NULL; - - a = SCHEME_CAR(obj); - c = SCHEME_INT_VAL(a); - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - a = SCHEME_CAR(obj); - i = SCHEME_INT_VAL(a); - - a = SCHEME_CDR(obj); - p = SCHEME_INT_VAL(a); - - qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); - qs->so.type = scheme_quote_syntax_type; - qs->depth = c; - qs->position = i; - qs->midpoint = p; - - return (Scheme_Object *)qs; -} - -#define BOOL(x) (x ? scheme_true : scheme_false) - static int not_relative_path(Scheme_Object *p, Scheme_Hash_Table *cache) { Scheme_Object *dir, *rel_p; @@ -758,7 +47,7 @@ static int not_relative_path(Scheme_Object *p, Scheme_Hash_Table *cache) return 0; } -static Scheme_Object *closure_marshal_name(Scheme_Object *name) +Scheme_Object *scheme_closure_marshal_name(Scheme_Object *name) { if (name) { if (SCHEME_VECTORP(name)) { @@ -783,16 +72,20 @@ static Scheme_Object *closure_marshal_name(Scheme_Object *name) return name; } -static Scheme_Object *write_lambda(Scheme_Object *obj) +void scheme_write_lambda(Scheme_Object *obj, + Scheme_Object **_name, + Scheme_Object **_ds, + Scheme_Object **_closure_map, + Scheme_Object **_tl_map) { Scheme_Lambda *data; - Scheme_Object *name, *l, *code, *ds, *tl_map; + Scheme_Object *name, *code, *ds, *tl_map, *closure_map; int svec_size, pos; Scheme_Marshal_Tables *mt; data = (Scheme_Lambda *)obj; - name = closure_marshal_name(data->name); + name = scheme_closure_marshal_name(data->name); svec_size = data->closure_size; if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) { @@ -826,7 +119,6 @@ static Scheme_Object *write_lambda(Scheme_Object *obj) case scheme_true_type: case scheme_false_type: case scheme_void_type: - case scheme_quote_syntax_type: ds = code; break; default: @@ -922,53 +214,35 @@ static Scheme_Object *write_lambda(Scheme_Object *obj) } } - l = CONS(scheme_make_svector(svec_size, - data->closure_map), - ds); - - if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) - l = CONS(scheme_make_integer(data->closure_size), - l); - - return CONS(scheme_make_integer(SCHEME_LAMBDA_FLAGS(data) & 0x7F), - CONS(scheme_make_integer(data->num_params), - CONS(scheme_make_integer(data->max_let_depth), - CONS(tl_map, - CONS(name, - l))))); + *_name = name; + *_ds = ds; + closure_map = scheme_make_svector(svec_size, data->closure_map); + *_closure_map = closure_map; + *_tl_map = tl_map; } -static Scheme_Object *read_lambda(Scheme_Object *obj) +Scheme_Object *scheme_read_lambda(int flags, int closure_size, int num_params, int max_let_depth, + Scheme_Object *name, + Scheme_Object *ds, + Scheme_Object *closure_map, + Scheme_Object *tl_map) { Scheme_Lambda *data; - Scheme_Object *v, *tl_map; #define BAD_CC "bad compiled closure" #define X_SCHEME_ASSERT(x, y) data = (Scheme_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Lambda)); - data->iso.so.type = scheme_lambda_type; - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - SCHEME_LAMBDA_FLAGS(data) = (short)(SCHEME_INT_VAL(v)); + SCHEME_LAMBDA_FLAGS(data) = (short)flags; - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - data->num_params = SCHEME_INT_VAL(v); + data->num_params = num_params; if (data->num_params < 0) return NULL; - if (!SCHEME_PAIRP(obj)) return NULL; - data->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); + data->max_let_depth = max_let_depth; if (data->max_let_depth < 0) return NULL; - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - tl_map = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); if (!SCHEME_FALSEP(tl_map)) { if (SCHEME_INTP(tl_map)) data->tl_map = (void *)tl_map; @@ -993,38 +267,21 @@ static Scheme_Object *read_lambda(Scheme_Object *obj) return NULL; } - if (!SCHEME_PAIRP(obj)) return NULL; - data->name = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); + data->name = name; if (SCHEME_NULLP(data->name)) data->name = NULL; - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); + data->body = ds; + + if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(closure_map))) return NULL; + data->closure_map = SCHEME_SVEC_VEC(closure_map); - /* v is an svector or an integer... */ if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) { - if (!SCHEME_INTP(v)) return NULL; - data->closure_size = SCHEME_INT_VAL(v); - - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - } - - data->body = obj; - - if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(v))) return NULL; - - if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS)) - data->closure_size = SCHEME_SVEC_LEN(v); - - if ((SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS)) - if (data->closure_size + scheme_boxmap_size(data->closure_size + data->num_params) != SCHEME_SVEC_LEN(v)) + data->closure_size = closure_size; + if (data->closure_size + scheme_boxmap_size(data->closure_size + data->num_params) != SCHEME_SVEC_LEN(closure_map)) return NULL; - - data->closure_map = SCHEME_SVEC_VEC(v); + } else + data->closure_size = SCHEME_SVEC_LEN(closure_map); /* If the closure is empty, create the closure now */ if (!data->closure_size) @@ -1033,1020 +290,218 @@ static Scheme_Object *read_lambda(Scheme_Object *obj) return (Scheme_Object *)data; } - -static Scheme_Object *write_toplevel(Scheme_Object *obj) +static Scheme_Object *hash_tree_to_vector(Scheme_Hash_Tree *ht) { - int pos, flags; - Scheme_Object *pr; + Scheme_Object **keys; + Scheme_Object *vec, *k, *v; + int i = 0, pos = 0; - pos = SCHEME_TOPLEVEL_POS(obj); - flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK); + vec = scheme_make_vector(2 * ht->count, NULL); - pr = (flags - ? scheme_make_pair(scheme_make_integer(pos), - scheme_make_integer(flags)) - : scheme_make_integer(pos)); + keys = scheme_extract_sorted_keys((Scheme_Object *)ht); - return scheme_make_pair(scheme_make_integer(SCHEME_TOPLEVEL_DEPTH(obj)), - pr); -} - -static Scheme_Object *read_toplevel(Scheme_Object *obj) -{ - int pos, depth, flags; - - if (!SCHEME_PAIRP(obj)) return NULL; - - depth = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (SCHEME_PAIRP(obj)) { - pos = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - flags = SCHEME_INT_VAL(SCHEME_CDR(obj)) & SCHEME_TOPLEVEL_FLAGS_MASK; - } else { - pos = (int)SCHEME_INT_VAL(obj); - flags = 0; - } - - if (depth < 0) return NULL; - if (pos < 0) return NULL; - - return scheme_make_toplevel(depth, pos, 1, flags); -} - -static Scheme_Object *write_variable(Scheme_Object *obj) - /* #%kernel references are handled in print.c, instead */ -{ - Scheme_Object *sym; - Scheme_Env *home; - Scheme_Module *m; - - sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key; - - home = scheme_get_bucket_home((Scheme_Bucket *)obj); - if (home) - m = home->module; - else - m = NULL; - - /* If we get a writeable variable (instead of a module variable), - it must be a reference to a module referenced directly by its - a symbolic name (i.e., no path). */ - - if (m) { - sym = scheme_make_pair(m->modname, sym); - if (home->mod_phase) - sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym); - } - - return sym; -} - -static Scheme_Object *read_variable(Scheme_Object *obj) - /* #%kernel references are handled in read.c, instead */ -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - if (!SCHEME_SYMBOLP(obj)) return NULL; - - return (Scheme_Object *)scheme_global_bucket(obj, env); -} - -static Scheme_Object *write_module_variable(Scheme_Object *obj) -{ - scheme_signal_error("module variables should have been handled in print.c"); - return NULL; -} - -static Scheme_Object *read_module_variable(Scheme_Object *obj) -{ - scheme_signal_error("module variables should have been handled in read.c"); - return NULL; -} - -static Scheme_Object *write_local(Scheme_Object *obj) -{ - return scheme_make_integer(SCHEME_LOCAL_POS(obj)); -} - -static Scheme_Object *do_read_local(Scheme_Type t, Scheme_Object *obj) -{ - int n, flags; - - if (SCHEME_PAIRP(obj)) { - flags = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - } else - flags = 0; - - n = (int)SCHEME_INT_VAL(obj); - if (n < 0) return NULL; - - return scheme_make_local(t, n, flags); -} - -static Scheme_Object *read_local(Scheme_Object *obj) -{ - return do_read_local(scheme_local_type, obj); -} - -static Scheme_Object *read_local_unbox(Scheme_Object *obj) -{ - return do_read_local(scheme_local_unbox_type, obj); -} - -static Scheme_Object *make_delayed_syntax(Scheme_Object *stx) -{ - Scheme_Object *ds; - Scheme_Marshal_Tables *mt; - - mt = scheme_current_thread->current_mt; - if (mt->pass < 0) - return stx; - - ds = scheme_alloc_small_object(); - ds->type = scheme_delay_syntax_type; - SCHEME_PTR_VAL(ds) = stx; - - return ds; -} - -static Scheme_Object *write_resolve_prefix(Scheme_Object *obj) -{ - Resolve_Prefix *rp = (Resolve_Prefix *)obj; - Scheme_Object *tv, *sv, *ds; - int i; - - i = rp->num_toplevels; - tv = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(tv)[i] = rp->toplevels[i]; - } - - i = rp->num_stxes; - sv = scheme_make_vector(i, NULL); - while (i--) { - if (rp->stxes[i]) { - if (SCHEME_INTP(rp->stxes[i])) { - /* Need to force this object, so we can write it. - This should only happen if we're writing back - code loaded from bytecode. */ - scheme_load_delayed_syntax(rp, i); - } - - ds = make_delayed_syntax(rp->stxes[i]); - } else - ds = scheme_false; - SCHEME_VEC_ELS(sv)[i] = ds; - } - - tv = scheme_make_pair(scheme_make_integer(rp->num_lifts), - scheme_make_pair(tv, sv)); - - tv = scheme_make_pair(rp->src_insp_desc, tv); - - return tv; -} - -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj) -{ - Resolve_Prefix *rp; - Scheme_Object *tv, *sv, **a, *stx, *tl, *insp_desc; - intptr_t i; - - if (!SCHEME_PAIRP(obj)) return NULL; - insp_desc = SCHEME_CAR(obj); - if (!SCHEME_SYMBOLP(insp_desc)) - return NULL; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return NULL; - - if (!SCHEME_INTP(SCHEME_CAR(obj))) { - obj = SCHEME_CDR(obj); - } - - if (!SCHEME_PAIRP(obj)) return NULL; - - i = SCHEME_INT_VAL(SCHEME_CAR(obj)); - if (i < 0) return NULL; - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - tv = SCHEME_CAR(obj); - sv = SCHEME_CDR(obj); - - if (!SCHEME_VECTORP(tv)) return NULL; - if (!SCHEME_VECTORP(sv)) return NULL; - - rp = MALLOC_ONE_TAGGED(Resolve_Prefix); - rp->so.type = scheme_resolve_prefix_type; - rp->num_toplevels = (int)SCHEME_VEC_SIZE(tv); - rp->num_stxes = (int)SCHEME_VEC_SIZE(sv); - rp->num_lifts = (int)i; - - i = rp->num_toplevels; - a = MALLOC_N(Scheme_Object *, i); - while (i--) { - tl = SCHEME_VEC_ELS(tv)[i]; - if (!SCHEME_FALSEP(tl) - && !SCHEME_SYMBOLP(tl) - && !SAME_TYPE(SCHEME_TYPE(tl), scheme_variable_type) - && !SAME_TYPE(SCHEME_TYPE(tl), scheme_module_variable_type)) - return NULL; - a[i] = tl; - } - rp->toplevels = a; - - i = rp->num_stxes; - a = MALLOC_N(Scheme_Object *, i); - while (i--) { - stx = SCHEME_VEC_ELS(sv)[i]; - if (SCHEME_FALSEP(stx)) { - stx = NULL; - } else if (SCHEME_RPAIRP(stx)) { - struct Scheme_Load_Delay *d; - Scheme_Object *pr; - d = (struct Scheme_Load_Delay *)SCHEME_CDR(stx); - stx = SCHEME_CAR(stx); - pr = rp->delay_info_rpair; - if (!pr) { - pr = scheme_make_raw_pair(scheme_make_integer(0), (Scheme_Object *)d); - rp->delay_info_rpair = pr; - } - SCHEME_CAR(pr) = scheme_make_integer(SCHEME_INT_VAL(SCHEME_CAR(pr)) + 1); - } else { - if (!SCHEME_STXP(stx)) return NULL; - } - a[i] = stx; - } - rp->stxes = a; - - rp->src_insp_desc = insp_desc; - - return (Scheme_Object *)rp; -} - -static Scheme_Object *ht_to_vector(Scheme_Object *ht, int delay) -/* recurs for values in hash table; we assume that such nesting is shallow */ -{ - intptr_t i, j, c; - Scheme_Object **sorted_keys; - Scheme_Object *k, *val, *vec; - - if (!ht) - return scheme_false; - if (SCHEME_VECTORP(ht)) { - /* may need to force delayed syntax: */ - c = SCHEME_VEC_SIZE(ht); - for (i = 0; i < c; i += 2) { - val = SCHEME_VEC_ELS(ht)[i+1]; - if (!SAME_OBJ(scheme_true, val)) { - k = scheme_stx_force_delayed(val); - if (!SAME_OBJ(k, val)) - SCHEME_VEC_ELS(ht)[i+1] = k; - } - } - return ht; - } - - if (SCHEME_HASHTRP(ht)) - c = ((Scheme_Hash_Tree *)ht)->count; - else - c = ((Scheme_Hash_Table *)ht)->count; - - vec = scheme_make_vector(2 * c, NULL); - j = 0; - - sorted_keys = scheme_extract_sorted_keys(ht); - - if (SCHEME_HASHTRP(ht)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)ht; - for (i = 0; i < c; i++) { - k = sorted_keys[i]; - val = scheme_hash_tree_get(t, k); - if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val)) - val = ht_to_vector(val, delay); - else if (delay && !SAME_OBJ(val, scheme_true)) - val = make_delayed_syntax(val); - SCHEME_VEC_ELS(vec)[j++] = k; - SCHEME_VEC_ELS(vec)[j++] = val; - } - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)ht; - for (i = 0; i < c; i++) { - k = sorted_keys[i]; - val = scheme_hash_get(t, k); - if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val)) - val = ht_to_vector(val, delay); - else if (delay && !SAME_OBJ(val, scheme_true)) - val = make_delayed_syntax(val); - SCHEME_VEC_ELS(vec)[j++] = k; - SCHEME_VEC_ELS(vec)[j++] = val; - } + for (i = 0; i < ht->count; i++) { + k = keys[i]; + v = scheme_hash_tree_get(ht, k); + SCHEME_VEC_ELS(vec)[pos++] = k; + SCHEME_VEC_ELS(vec)[pos++] = v; } return vec; } -static Scheme_Object *protect_expr_quotes(Scheme_Object *body) -/* protect each expression in a phase-1-or-higher module-body vector */ +Scheme_Object *scheme_write_linklet(Scheme_Object *obj) { - Scheme_Object *e, *v, *v2, *body2 = NULL; - int i, j; + Scheme_Linklet *linklet = (Scheme_Linklet *)obj; + Scheme_Object *l; - for (j = SCHEME_VEC_SIZE(body); j--; ) { - v = SCHEME_VEC_ELS(body)[j]; - e = scheme_protect_quote(SCHEME_VEC_ELS(v)[1]); - if (!SAME_OBJ(e, SCHEME_VEC_ELS(v)[1])) { - i = SCHEME_VEC_SIZE(v); - v2 = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(v2)[i] = SCHEME_VEC_ELS(v)[i]; - } - SCHEME_VEC_ELS(v2)[1] = e; - v = v2; - - if (!body2) { - i = SCHEME_VEC_SIZE(body); - body2 = scheme_make_vector(i, NULL); - while (--i > j) { - SCHEME_VEC_ELS(body2)[i] = SCHEME_VEC_ELS(body)[i]; - } - } - } - - if (body2) - SCHEME_VEC_ELS(body2)[j] = v; - } - - return (body2 ? body2 : body); -} - -static Scheme_Object *write_module(Scheme_Object *obj) -{ - Scheme_Module *m = (Scheme_Module *)obj; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *l, *v, *phase; - int i, j, k, count, cnt; - Scheme_Object **sorted_keys; + if (linklet->jit_ready) + scheme_arg_mismatch("write", + "cannot marshal linklet that has been evaluated", + obj); l = scheme_null; - cnt = 0; - if (m->other_requires) { - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)m->other_requires); - cnt = m->other_requires->count; - for (i = 0; i < cnt; i++) { - l = scheme_make_pair(sorted_keys[i], - scheme_make_pair(scheme_hash_get(m->other_requires, - sorted_keys[i]), - l)); - } - } - l = cons(scheme_make_integer(cnt), l); - - l = cons(m->dt_requires, l); - l = cons(m->tt_requires, l); - l = cons(m->et_requires, l); - l = cons(m->requires, l); - - for (j = 0; j < m->num_phases; j++) { - v = m->bodies[j]; - if (j > 0) - v = protect_expr_quotes(v); - l = cons(v, l); - } - - cnt = 0; - if (m->me->other_phases) - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)m->me->other_phases); - else - sorted_keys = NULL; - for (k = -3; k < (m->me->other_phases ? m->me->other_phases->count : 0); k++) { - switch (k) { - case -3: - phase = scheme_make_integer(-1); - pt = m->me->dt; - break; - case -2: - phase = scheme_make_integer(1); - pt = m->me->et; - break; - case -1: - phase = scheme_make_integer(0); - pt = m->me->rt; - break; - default: - phase = sorted_keys[k]; - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, phase); - } - - if (pt) { - l = cons(scheme_make_integer(pt->num_provides), l); - l = cons(scheme_make_integer(pt->num_var_provides), l); - - count = pt->num_provides; - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provides[i]; - } - l = cons(v, l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_srcs[i]; - } - l = cons(v, l); - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_src_names[i]; - } - l = cons(v, l); - - if (pt->provide_nominal_srcs) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_nominal_srcs[i]; - } - l = cons(v, l); - } else { - l = cons(scheme_false, l); - } - - if (pt->provide_src_phases) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = scheme_make_integer(pt->provide_src_phases[i]); - } - } else - v = scheme_false; - l = cons(v, l); - - if ((SCHEME_INT_VAL(phase) >= 0) && (SCHEME_INT_VAL(phase) < m->num_phases)) { - Scheme_Module_Export_Info *exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; - - if (exp_info) { - v = scheme_false; - - if (exp_info->provide_protects) { - for (i = 0; i < count; i++) { - if (exp_info->provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (exp_info->provide_protects[i] ? scheme_true : scheme_false); - } - } - } - l = cons(v, l); - - count = exp_info->num_indirect_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = exp_info->indirect_provides[i]; - } - l = cons(v, l); - - count = exp_info->num_indirect_syntax_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = exp_info->indirect_syntax_provides[i]; - } - l = cons(v, l); - } else - l = cons(scheme_void, l); - } else - l = cons(scheme_void, l); - - l = cons(pt->phase_index, l); - cnt++; - } - } - l = cons(scheme_make_integer(cnt), l); - l = cons(scheme_make_integer(m->num_phases), l); - - l = cons((Scheme_Object *)m->prefix, l); - l = cons(m->dummy, l); - - l = cons(scheme_make_integer(m->max_let_depth), l); - - v = m->rn_stx; - if (!v) - v = scheme_false; - else if (!SAME_OBJ(v, scheme_true)) { - v = scheme_stx_force_delayed(v); - if (!SAME_OBJ(v, m->rn_stx)) - m->rn_stx = v; - v = make_delayed_syntax(v); - } - l = cons(v, l); - - /* previously recorded "functional?" info: */ - l = cons(scheme_false, l); - l = cons(scheme_false, l); - - if (m->lang_info) - l = cons(scheme_protect_quote(m->lang_info), l); + if (linklet->import_shapes) + l = scheme_make_pair(linklet->import_shapes, l); else - l = cons(scheme_false, l); + l = scheme_make_pair(scheme_false, l); - for (k = 0; k < 2; k++) { - v = (k ? m->pre_submodules : m->post_submodules); - if (v && !SCHEME_NULLP(v)) { - Scheme_Object *l2 = scheme_null; - while (!SCHEME_NULLP(v)) { - l2 = scheme_make_pair(write_module(SCHEME_CAR(v)), - l2); - v = SCHEME_CDR(v); - } - l = cons(l2, l); - } else - l = cons(scheme_null, l); - } + l = scheme_make_pair(linklet->importss, l); + l = scheme_make_pair(linklet->defns, l); + l = scheme_make_pair(hash_tree_to_vector(linklet->source_names), l); - l = cons((m->phaseless ? scheme_true : scheme_false), l); + l = scheme_make_pair(linklet->bodies, l); - l = cons(ht_to_vector(m->other_binding_names, 1), l); - l = cons(ht_to_vector(m->et_binding_names, 1), l); - l = cons(ht_to_vector(m->binding_names, 1), l); - l = cons(m->me->src_modidx, l); - - l = cons(scheme_resolved_module_path_value(m->modsrc), l); - l = cons(scheme_resolved_module_path_value(m->modname), l); + l = scheme_make_pair(scheme_make_integer(linklet->num_exports), l); + l = scheme_make_pair(scheme_make_integer(linklet->num_lifts), l); + l = scheme_make_pair(scheme_make_integer(linklet->max_let_depth), l); + l = scheme_make_pair((linklet->need_instance_access ? scheme_true : scheme_false), l); - if (m->submodule_path) - l = cons(m->submodule_path, l); - else - l = cons(scheme_null, l); + l = scheme_make_pair(linklet->name, l); return l; } -static int check_requires_ok(Scheme_Object *l) -{ - Scheme_Object *x; - while (!SCHEME_NULLP(l)) { - x = SCHEME_CAR(l); - if (!SAME_TYPE(SCHEME_TYPE(x), scheme_module_index_type)) - return 0; - l = SCHEME_CDR(l); - } - return 1; -} - #if 0 # define return_NULL() return (printf("%d\n", __LINE__), NULL) #else # define return_NULL() return NULL #endif -static Scheme_Object *read_module(Scheme_Object *obj) +static int is_vector_of_symbols(Scheme_Object *v, int false_ok) { - Scheme_Module *m; - Scheme_Object *ie, *nie, **bodies, *bns; - Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; - Scheme_Module_Exports *me; - Scheme_Module_Phase_Exports *pt; - Scheme_Module_Export_Info **exp_infos, *exp_info; - char *ps; - int *sps; - int i, j, count, cnt; + int i; - m = MALLOC_ONE_TAGGED(Scheme_Module); - m->so.type = scheme_module_type; - m->predefined = scheme_starting_up; + if (!SCHEME_VECTORP(v)) + return 0; + + for (i = SCHEME_VEC_SIZE(v); i--; ) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[i]) + && (!false_ok || !SCHEME_FALSEP(SCHEME_VEC_ELS(v)[i]))) + return 0; + } - me = scheme_make_module_exports(); - m->me = me; + return 1; +} + +static int is_vector_of_shapes(Scheme_Object *v) +{ + int i; + Scheme_Object *s; + + if (!SCHEME_VECTORP(v)) + return 0; + + for (i = SCHEME_VEC_SIZE(v); i--; ) { + s = SCHEME_VEC_ELS(v)[i]; + if (SCHEME_TRUEP(s) + && !SCHEME_SYMBOLP(s) + && !SCHEME_INTP(s) + && !SAME_OBJ(s, scheme_true) + && !SAME_OBJ(s, scheme_void)) + return 0; + } + + return 1; +} + +static int is_vector_of_vector_of_symbols(Scheme_Object *v) +{ + int i; + + if (!SCHEME_VECTORP(v)) + return 0; + + for (i = SCHEME_VEC_SIZE(v); i--; ) { + if (!is_vector_of_symbols(SCHEME_VEC_ELS(v)[i], 0)) + return 0; + } + + return 1; +} + +static Scheme_Object *vector_to_hash_tree(Scheme_Object *vec) +{ + Scheme_Hash_Tree *ht; + int i = 0; + + if (!SCHEME_VECTORP(vec)) + return NULL; + if (SCHEME_VEC_SIZE(vec) & 0x1) + return NULL; + + ht = scheme_make_hash_tree(0); + for (i = SCHEME_VEC_SIZE(vec) - 2; i >= 0; i -= 2) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(vec)[i]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(vec)[i+1])) + return NULL; + ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(vec)[i], SCHEME_VEC_ELS(vec)[i+1]); + } + + return (Scheme_Object *)ht; +} + +Scheme_Object *scheme_read_linklet(Scheme_Object *obj) +{ + Scheme_Linklet *linklet = (Scheme_Linklet *)obj; + Scheme_Object *e, *a; + + linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + linklet->so.type = scheme_linklet_type; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + linklet->name = SCHEME_CAR(obj); + if (!SCHEME_SYMBOLP(linklet->name)) return_NULL(); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + linklet->need_instance_access = SCHEME_TRUEP(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); e = SCHEME_CAR(obj); - m->submodule_path = e; - if (!scheme_is_list(e)) return_NULL(); - while (!SCHEME_NULLP(e)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); - e = SCHEME_CDR(e); - } + linklet->max_let_depth = SCHEME_INT_VAL(e); obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); - m->modname = e; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); - m->modsrc = e; - m->me->modsrc = e; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - me->src_modidx = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (!SAME_TYPE(SCHEME_TYPE(me->src_modidx), scheme_module_index_type)) - return_NULL(); - ((Scheme_Modidx *)me->src_modidx)->resolved = m->modname; - m->self_modidx = me->src_modidx; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - bns = SCHEME_CAR(obj); - if (!SCHEME_FALSEP(bns)) { - if (!SCHEME_VECTORP(bns)) return_NULL(); - m->binding_names = bns; - } - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - bns = SCHEME_CAR(obj); - if (!SCHEME_FALSEP(bns)) { - if (!SCHEME_VECTORP(bns)) return_NULL(); - m->et_binding_names = bns; - } - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - bns = SCHEME_CAR(obj); - if (!SCHEME_FALSEP(bns)) { - if (!SCHEME_VECTORP(bns)) return_NULL(); - m->other_binding_names = bns; - } - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->phaseless = (SCHEME_TRUEP(SCHEME_CAR(obj)) ? scheme_true : NULL); - obj = SCHEME_CDR(obj); - - for (i = 0; i < 2; i++) { - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - nve = scheme_null; - while (!SCHEME_NULLP(e)) { - if (!SCHEME_PAIRP(e)) return_NULL(); - ne = read_module(SCHEME_CAR(e)); - nve = scheme_make_pair(ne, nve); - e = SCHEME_CDR(e); - } - if (i) - m->post_submodules = nve; - else - m->pre_submodules = nve; - } - if (!SCHEME_PAIRP(obj)) return_NULL(); e = SCHEME_CAR(obj); - if (SCHEME_FALSEP(e)) - e = NULL; - else if (!(SCHEME_VECTORP(e) - && (3 == SCHEME_VEC_SIZE(e)) - && scheme_is_module_path(SCHEME_VEC_ELS(e)[0]) - && SCHEME_SYMBOLP(SCHEME_VEC_ELS(e)[1]))) + linklet->num_lifts = SCHEME_INT_VAL(e); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = SCHEME_CAR(obj); + linklet->num_exports = SCHEME_INT_VAL(e); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + a = SCHEME_CAR(obj); + if (!SCHEME_VECTORP(a)) return_NULL(); + linklet->bodies = a; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + a = vector_to_hash_tree(SCHEME_CAR(obj)); + if (!a) return_NULL(); + linklet->source_names = (Scheme_Hash_Tree *)a; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + a = SCHEME_CAR(obj); + if (!is_vector_of_symbols(a, 1)) return_NULL(); + linklet->defns = a; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + a = SCHEME_CAR(obj); + if (!is_vector_of_vector_of_symbols(a)) return_NULL(); + linklet->importss = a; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + a = SCHEME_CAR(obj); + if (!SCHEME_FALSEP(a)) { + if (!is_vector_of_shapes(a)) return_NULL(); + linklet->import_shapes = a; + } + + if (linklet->num_exports > SCHEME_VEC_SIZE(linklet->defns)) + return_NULL(); + if (linklet->num_lifts > (SCHEME_VEC_SIZE(linklet->defns) - linklet->num_exports)) return_NULL(); - m->lang_info = e; - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - /* "functional?" info ignored */ - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - /* "functional?" info ignored */ - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->rn_stx = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (SCHEME_FALSEP(m->rn_stx)) - m->rn_stx = NULL; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->dummy = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (cnt < 1) return_NULL(); - - m->num_phases = cnt; - exp_infos = (Scheme_Module_Export_Info **)scheme_malloc_fail_ok(scheme_malloc, scheme_check_overflow(cnt, sizeof(Scheme_Module_Export_Info *), 0)); - while (cnt--) { - exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); - SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); - exp_infos[cnt] = exp_info; + { + int i = 0, j; + for (j = SCHEME_VEC_SIZE(linklet->importss); j--; ) { + i += SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[j]); + } + linklet->num_total_imports = i; } - m->exp_infos = exp_infos; - cnt = m->num_phases; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (cnt < 0) return_NULL(); - - while (cnt--) { - Scheme_Object *phase; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - phase = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) + if (linklet->import_shapes) { + if (linklet->num_total_imports != SCHEME_VEC_SIZE(linklet->import_shapes)) return_NULL(); - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - pt = me->rt; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - pt = me->et; - } else if (SAME_OBJ(phase, scheme_false)) { - pt = me->dt; - } else { - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = phase; - if (!me->other_phases) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); - me->other_phases = ht; - } - scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (SCHEME_VOIDP(ie)) { - /* no exp_infos entry */ - count = -1; - } else { - if (!SCHEME_INTP(phase) || (SCHEME_INT_VAL(phase) < 0) - || (SCHEME_INT_VAL(phase) >= m->num_phases)) - return_NULL(); - exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - exp_info->indirect_syntax_provides = v; - exp_info->num_indirect_syntax_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - exp_info->indirect_provides = v; - exp_info->num_indirect_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (SCHEME_FALSEP(esp)) { - exp_info->provide_protects = NULL; - count = -1; - } else { - if (!SCHEME_VECTORP(esp)) return_NULL(); - count = SCHEME_VEC_SIZE(esp); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); - } - exp_info->provide_protects = ps; - } - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esph = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esnom = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esn = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - es = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nve = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ne = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if ((count != -1) && (SCHEME_INT_VAL(ne) != count)) return_NULL(); - - count = SCHEME_INT_VAL(ne); - pt->num_provides = count; - pt->num_var_provides = SCHEME_INT_VAL(nve); - - if (!SCHEME_VECTORP(e) || (SCHEME_VEC_SIZE(e) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(e)[i]; - } - pt->provides = v; - - if (!SCHEME_VECTORP(es) || (SCHEME_VEC_SIZE(es) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(es)[i]; - } - pt->provide_srcs = v; - - if (!SCHEME_VECTORP(esn) || (SCHEME_VEC_SIZE(esn) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(esn)[i]; - } - pt->provide_src_names = v; - - if (SCHEME_FALSEP(esnom)) { - pt->provide_nominal_srcs = NULL; - } else { - if (!SCHEME_VECTORP(esnom) || (SCHEME_VEC_SIZE(esnom) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(esnom)[i]; - } - pt->provide_nominal_srcs = v; - } - - if (SCHEME_FALSEP(esph)) - sps = NULL; - else { - if (!SCHEME_VECTORP(esph) || (SCHEME_VEC_SIZE(esph) != count)) return_NULL(); - sps = MALLOC_N_ATOMIC(int, count); - for (i = 0; i < count; i++) { - sps[i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(esph)[i]); - } - } - pt->provide_src_phases = sps; } - count = me->rt->num_provides; - - bodies = MALLOC_N(Scheme_Object*, m->num_phases); - m->bodies = bodies; - for (j = m->num_phases; j--; ) { - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - if (j) { - bodies[j] = e; - for (i = SCHEME_VEC_SIZE(e); i--; ) { - e = SCHEME_VEC_ELS(bodies[j])[i]; - if (!SCHEME_VECTORP(e)) return_NULL(); - if (SCHEME_VEC_SIZE(e) != 5) return_NULL(); - /* SCHEME_VEC_ELS(e)[1] should be code */ - if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) - return_NULL(); - if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[0])) { - if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[4])) return_NULL(); - } else { - e = SCHEME_VEC_ELS(e)[0]; - if (!SCHEME_SYMBOLP(e)) { - while (SCHEME_PAIRP(e)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); - e = SCHEME_CDR(e); - } - if (!SCHEME_NULLP(e)) return_NULL(); - } - } - } - } else { - bodies[j] = e; - } - obj = SCHEME_CDR(obj); - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->et_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->tt_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->dt_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - while (cnt--) { - Scheme_Object *phase; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - phase = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - return_NULL(); - - if (SAME_OBJ(phase, scheme_make_integer(0)) - || SAME_OBJ(phase, scheme_make_integer(1)) - || SAME_OBJ(phase, scheme_make_integer(-1))) - return_NULL(); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - if (!check_requires_ok(e)) return_NULL(); - - if (!m->other_requires) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); - m->other_requires = ht; - } - scheme_hash_set(m->other_requires, phase, e); - - obj = SCHEME_CDR(obj); - } - - return (Scheme_Object *)m; -} - -Scheme_Object *write_top_level_require(Scheme_Object *o) -{ - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_top_level_require(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_require_form_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; + return (Scheme_Object *)linklet; } diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c deleted file mode 100644 index 5d652b9683..0000000000 --- a/racket/src/racket/src/module.c +++ /dev/null @@ -1,13081 +0,0 @@ -/* - Racket - Copyright (c) 2004-2018 PLT Design Inc. - Copyright (c) 2000-2001 Matthew Flatt - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library 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 distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - 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 implements the first-order, top-level module system -- - both the expander and compiler front-end, as well as run-time - support for modules. An initiantiated module is implemented - essentially as a namespace. The bindings at the top level of a - module are namespace top-level bindings. */ - -#include "schpriv.h" -#include "schmach.h" -#include "schexpobs.h" - -#define mz_MIN(l,o) ((l) < (o) ? (l) : (o)) - -/* globals */ -SHARED_OK Scheme_Object *(*scheme_module_demand_hook)(int, Scheme_Object **); -THREAD_LOCAL_DECL(Scheme_Bucket_Table *scheme_module_code_cache); - -SHARED_OK static Scheme_Bucket_Table *modpath_table; -#ifdef MZ_USE_PLACES -SHARED_OK static mzrt_mutex *modpath_table_mutex; -#else -# define mzrt_mutex_lock(l) /* empty */ -# define mzrt_mutex_unlock(l) /* empty */ -#endif - -/* locals */ -static Scheme_Object *current_module_name_resolver(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_module_name_prefix(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_module_name_source(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_module_load_path(int argc, Scheme_Object *argv[]); -static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require_copy(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require_constant(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_require_etonly(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_attach_module_decl(int argc, Scheme_Object *argv[]); -static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_name(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_indirect_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_lang_info(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_submodules(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_compiled_phaseless_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_lang_info(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_imports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_to_indirect_exports(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_is_declared(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_is_predefined(int argc, Scheme_Object *argv[]); - -static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]); -static Scheme_Object *module_path_index_submodule(int argc, Scheme_Object *argv[]); - -static Scheme_Object *is_module_path(int argc, Scheme_Object **argv); - -static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_resolved_module_path(int argc, Scheme_Object *argv[]); -static Scheme_Object *resolved_module_path_name(int argc, Scheme_Object *argv[]); - -static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv); - -/* syntax */ -static Scheme_Object *module_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *modulestar_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *modulestar_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *module_begin_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *declare_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *declare_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *require_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *provide_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Module *module_load(Scheme_Object *modname, Scheme_Env *env, const char *who); - -static void run_module(Scheme_Env *menv, int set_ns); -static void run_module_exptime(Scheme_Env *menv, int phase); - -static void eval_exptime(Scheme_Object *names, int count, - Scheme_Object *expr, - Scheme_Env *genv, Scheme_Comp_Env *env, - Resolve_Prefix *rp, int let_depth, int shift, - Scheme_Bucket_Table *syntax, int at_phase, - Scheme_Object *ids_for_rename_trans, - Scheme_Object *insp); - -typedef struct Module_Begin_Expand_State { - /* All pointers, because it's allocated with scheme_malloc(): */ - Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ - Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */ - Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */ - Scheme_Hash_Tree *all_defs; /* phase -> list of sxtid */ - Scheme_Hash_Table *all_defs_out; /* phase -> list of (cons protected? (stx-list except-name ...)) */ - int *all_simple_bindings; /* can we reconstruct bindings for `module->namespace`? */ - int *_num_phases; - Scheme_Object *saved_provides; /* list of (cons form phase) */ - Scheme_Object *saved_submodules; /* list of (cons form phase) */ - Scheme_Hash_Table *submodule_names; /* symbol -> #t (pre-module) or # (post-module) */ - Scheme_Hash_Table *modidx_cache; - Scheme_Object *redef_modname; - Scheme_Object *end_statementss; /* list of lists */ - Scheme_Object *modsrc; /* source for top-level module */ - Scheme_Object **sub_iidx_ptrs; /* contains `iidx`es for `(module* name #f ...)` submodules */ -} Module_Begin_Expand_State; - -static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Compile_Expand_Info *erec, int derec, - int phase, Scheme_Object *body_lists, - Module_Begin_Expand_State *bxs); - -static Scheme_Object *expand_all_provides(Scheme_Object *form, - Scheme_Comp_Env *cenv, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object *self_modidx, - Module_Begin_Expand_State *bxs, - int keep_expanded); - -static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Comp_Env *env, - Scheme_Object *l, int post, - Module_Begin_Expand_State *bxs, - int keep_expanded); - -static Scheme_Object *fixup_expanded(Scheme_Object *expanded_l, - Scheme_Object *expanded_provides, - int phase, - int kind); - -static void check_formerly_unbound(Scheme_Object *unbounds, Scheme_Comp_Env *env); -static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **_begin_for_syntax_stx); -static int is_modulestar_stop(Scheme_Comp_Env *env); - -typedef int (*Convert_Submodule_Proc)(Scheme_Object *mp, Scheme_Object *data); -static Scheme_Object *convert_submodule_path(Scheme_Object *name, - Convert_Submodule_Proc check, - Scheme_Object *check_data); -static int check_is_submodule(Scheme_Object *modname, Scheme_Object *_genv); - -static Scheme_Object *sys_wraps_phase(intptr_t p); - -static int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b); - -static int phaseless_rhs(Scheme_Object *val, int var_count, int phase); - -#define cons scheme_make_pair - -/* global read-only kernel stuff */ -READ_ONLY static Scheme_Object *kernel_modname; -READ_ONLY static Scheme_Object *kernel_symbol; -READ_ONLY static Scheme_Object *kernel_modidx; -READ_ONLY static Scheme_Module *kernel; -READ_ONLY static Scheme_Object *flfxnum_modname; -READ_ONLY static Scheme_Object *extfl_modname; -READ_ONLY static Scheme_Object *futures_modname; -READ_ONLY static Scheme_Object *unsafe_modname; -READ_ONLY static Scheme_Object *foreign_modname; - -/* global read-only symbols */ -ROSYM static Scheme_Object *module_begin_symbol; -ROSYM static Scheme_Object *prefix_symbol; -ROSYM static Scheme_Object *only_symbol; -ROSYM static Scheme_Object *rename_symbol; -ROSYM static Scheme_Object *all_except_symbol; -ROSYM static Scheme_Object *prefix_all_except_symbol; -ROSYM static Scheme_Object *all_from_symbol; -ROSYM static Scheme_Object *all_from_except_symbol; -ROSYM static Scheme_Object *all_defined_symbol; -ROSYM static Scheme_Object *all_defined_except_symbol; -ROSYM static Scheme_Object *prefix_all_defined_symbol; -ROSYM static Scheme_Object *prefix_all_defined_except_symbol; -ROSYM static Scheme_Object *struct_symbol; -ROSYM static Scheme_Object *protect_symbol; -ROSYM static Scheme_Object *expand_symbol; -ROSYM static Scheme_Object *for_syntax_symbol; -ROSYM static Scheme_Object *for_template_symbol; -ROSYM static Scheme_Object *for_label_symbol; -ROSYM static Scheme_Object *for_meta_symbol; -ROSYM static Scheme_Object *just_meta_symbol; -ROSYM static Scheme_Object *quote_symbol; -ROSYM static Scheme_Object *lib_symbol; -ROSYM static Scheme_Object *planet_symbol; -ROSYM static Scheme_Object *file_symbol; -ROSYM static Scheme_Object *submod_symbol; -ROSYM static Scheme_Object *module_name_symbol; -ROSYM static Scheme_Object *nominal_id_symbol; -ROSYM static Scheme_Object *phaseless_keyword; -ROSYM static Scheme_Object *empty_namespace_keyword; - -READ_ONLY static Scheme_Object *modbeg_syntax; - -/* phase wraps */ -THREAD_LOCAL_DECL(static Scheme_Object *scheme_sys_wraps0); -THREAD_LOCAL_DECL(static Scheme_Object *scheme_sys_wraps1); - -/* global syntax */ -THREAD_LOCAL_DECL(Scheme_Object *scheme_module_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_modulestar_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_module_begin_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_begin_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_define_values_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_define_syntaxes_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_top_stx); -THREAD_LOCAL_DECL(Scheme_Object *scheme_begin_for_syntax_stx); - -THREAD_LOCAL_DECL(Scheme_Object *more_constant_stxes[NUM_MORE_CONSTANT_STXES]); - -#ifdef MZ_XFORM -# define cnstXOA XFORM_OK_ASSIGN -#else -# define cnstXOA /* empty */ -#endif -#define CONSTANT_STX(pos) cnstXOA (more_constant_stxes[pos]) - -#define require_stx CONSTANT_STX(0) -#define provide_stx CONSTANT_STX(1) -#define declare_stx CONSTANT_STX(2) -#define set_stx CONSTANT_STX(3) -#define app_stx CONSTANT_STX(4) -#define lambda_stx CONSTANT_STX(5) -#define case_lambda_stx CONSTANT_STX(6) -#define let_values_stx CONSTANT_STX(7) -#define letrec_values_stx CONSTANT_STX(8) -#define if_stx CONSTANT_STX(9) -#define begin0_stx CONSTANT_STX(10) -#define with_continuation_mark_stx CONSTANT_STX(11) -#define letrec_syntaxes_stx CONSTANT_STX(12) -#define var_ref_stx CONSTANT_STX(13) -#define expression_stx CONSTANT_STX(14) -#define quote_stx CONSTANT_STX(15) -#define datum_stx CONSTANT_STX(16) - -#define make_struct_type_stx CONSTANT_STX(17) -#define make_struct_type_property_stx CONSTANT_STX(18) -#define list_stx CONSTANT_STX(19) -#define cons_stx CONSTANT_STX(20) -#define gensym_stx CONSTANT_STX(21) -#define string_to_uninterned_symbol_stx CONSTANT_STX(22) - -READ_ONLY static Scheme_Object *empty_self_modidx; -READ_ONLY static Scheme_Object *empty_self_modname; - -THREAD_LOCAL_DECL(static Scheme_Object *empty_self_shift_cache); -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *starts_table); -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *submodule_empty_modidx_table); -#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) -# define PLACE_LOCAL_MODPATH_TABLE 1 -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *place_local_modpath_table); -#else -# define PLACE_LOCAL_MODPATH_TABLE 0 -#endif - -THREAD_LOCAL_DECL(static Scheme_Env *initial_modules_env); -THREAD_LOCAL_DECL(static int num_initial_modules); -THREAD_LOCAL_DECL(static Scheme_Object **initial_modules); - -/* caches */ -THREAD_LOCAL_DECL(static Scheme_Modidx *modidx_caching_chain); -THREAD_LOCAL_DECL(static Scheme_Object *global_shift_cache); -#define GLOBAL_SHIFT_CACHE_SIZE 40 -#ifdef USE_SENORA_GC -# define SHIFT_CACHE_NULL scheme_false -# define SHIFT_CACHE_NULLP(x) SCHEME_FALSEP(x) -#else -# define SHIFT_CACHE_NULL NULL -# define SHIFT_CACHE_NULLP(x) !(x) -#endif - -#define SCHEME_RMP_VAL(obj) SCHEME_PTR_VAL(obj) - -#define DONE_MODFORM_KIND 0 -#define EXPR_MODFORM_KIND 1 -#define DEFN_MODFORM_KIND 2 -#define PROVIDE_MODFORM_KIND 3 -#define MODULE_MODFORM_KIND 4 -#define SAVED_MODFORM_KIND 5 -#define DECLARE_MODFORM_KIND 6 -#define LIFTREQ_MODFORM_KIND 7 - -/* combined bitwise: */ -#define NON_PHASELESS_IMPORT 0x1 -#define NON_PHASELESS_FORM 0x2 - -typedef void (*Check_Func)(Scheme_Object *id, Scheme_Object *self_modidx, - Scheme_Object *nominal_modname, Scheme_Object *nominal_export, - Scheme_Object *modname, Scheme_Object *srcname, int exet, - int isval, void *data, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *scope_src, - Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase); -static void parse_requires(Scheme_Object *form, int at_phase, - Scheme_Object *base_modidx, - Scheme_Env *env, - Scheme_Module *for_m, - Scheme_Object *rns, - Check_Func ck, void *data, - Scheme_Object *redef_modname, - int copy_vars, - int eval_exp, int eval_run, - int *all_simple, - Scheme_Hash_Table *modix_cache, - Scheme_Hash_Table *submodule_names, - int *non_phaseless); -static void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, - int at_phase, - Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Object *self_modidx, - Scheme_Hash_Table *all_defs_out, - Scheme_Hash_Table *tables, - Scheme_Hash_Tree *all_defs, - Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded); -static int compute_reprovides(Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Module *mod_for_requires, - Scheme_Hash_Table *tables, - Scheme_Env *genv, - int num_phases, - Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, - const char *matching_form, - Scheme_Object *all_mods, Scheme_Object *all_phases); -static void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - int num_phases, Scheme_Module_Export_Info **exp_infos); -static Scheme_Object **compute_indirects(Scheme_Env *genv, - Scheme_Module_Phase_Exports *pt, - int *_count, - int vars); -static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, - int eval_exp, int eval_run, intptr_t base_phase, Scheme_Object *cycle_list, - int not_new); -static void eval_module_body(Scheme_Env *menv, Scheme_Env *env); - -static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], - int copy, int etonly); - -static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv); - -static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, int *exets, - Scheme_Object **exsnoms, - int start, int count, int do_uninterned); - -#define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0])) -#define MODCHAIN_AVAIL(p, n) (SCHEME_VEC_ELS(p)[3+n]) - -/**********************************************************************/ -/* initialization */ -/**********************************************************************/ - -void scheme_init_module(Scheme_Env *env) -{ - scheme_add_global_keyword("module", - scheme_make_primitive_syntax(module_compile, - module_expand), - env); - scheme_add_global_keyword("module*", - scheme_make_primitive_syntax(modulestar_compile, - modulestar_expand), - env); - - REGISTER_SO(modbeg_syntax); - modbeg_syntax = scheme_make_primitive_syntax(module_begin_compile, - module_begin_expand); - - scheme_add_global_keyword("#%module-begin", - modbeg_syntax, - env); - - scheme_add_global_keyword("#%declare", - scheme_make_primitive_syntax(declare_compile, - declare_expand), - env); - - scheme_add_global_keyword("#%require", - scheme_make_primitive_syntax(require_compile, - require_expand), - env); - scheme_add_global_keyword("#%provide", - scheme_make_primitive_syntax(provide_compile, - provide_expand), - env); - -#ifdef MZ_USE_PLACES - mzrt_mutex_create(&modpath_table_mutex); -#endif - - if (!empty_self_modidx) { - REGISTER_SO(empty_self_modidx); - REGISTER_SO(empty_self_modname); - empty_self_modidx = scheme_make_modidx(scheme_false, scheme_false, scheme_false); - (void)scheme_hash_key(empty_self_modidx); - empty_self_modname = scheme_make_symbol("expanded module"); /* uninterned */ - empty_self_modname = scheme_intern_resolved_module_path(empty_self_modname); - } - - REGISTER_SO(quote_symbol); - REGISTER_SO(file_symbol); - REGISTER_SO(lib_symbol); - REGISTER_SO(planet_symbol); - REGISTER_SO(submod_symbol); - quote_symbol = scheme_intern_symbol("quote"); - file_symbol = scheme_intern_symbol("file"); - lib_symbol = scheme_intern_symbol("lib"); - planet_symbol = scheme_intern_symbol("planet"); - submod_symbol = scheme_intern_symbol("submod"); - - REGISTER_SO(kernel_symbol); - REGISTER_SO(kernel_modname); - REGISTER_SO(kernel_modidx); - REGISTER_SO(unsafe_modname); - REGISTER_SO(flfxnum_modname); - REGISTER_SO(extfl_modname); - REGISTER_SO(futures_modname); - REGISTER_SO(foreign_modname); - kernel_symbol = scheme_intern_symbol("#%kernel"); - kernel_modname = scheme_intern_resolved_module_path(kernel_symbol); - kernel_modidx = scheme_make_modidx(scheme_make_pair(quote_symbol, - scheme_make_pair(kernel_symbol, - scheme_null)), - scheme_false, kernel_modname); - (void)scheme_hash_key(kernel_modidx); - unsafe_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%unsafe")); - flfxnum_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%flfxnum")); - extfl_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%extfl")); - futures_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%futures")); - foreign_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%foreign")); - - REGISTER_SO(module_begin_symbol); - module_begin_symbol = scheme_intern_symbol("#%module-begin"); - - GLOBAL_PARAMETER("current-module-name-resolver", current_module_name_resolver, MZCONFIG_CURRENT_MODULE_RESOLVER, env); - GLOBAL_PARAMETER("current-module-declare-name", current_module_name_prefix, MZCONFIG_CURRENT_MODULE_NAME, env); - GLOBAL_PARAMETER("current-module-declare-source", current_module_name_source, MZCONFIG_CURRENT_MODULE_SRC, env); - GLOBAL_PARAMETER("current-module-path-for-load", current_module_load_path, MZCONFIG_CURRENT_MODULE_LOAD_PATH, env); - - GLOBAL_PRIM_W_ARITY("dynamic-require", scheme_dynamic_require, 2, 3, env); - GLOBAL_PRIM_W_ARITY("dynamic-require-for-syntax", dynamic_require_for_syntax, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-require", namespace_require, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-attach-module", namespace_attach_module, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-attach-module-declaration", namespace_attach_module_decl, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-unprotect-module", namespace_unprotect_module, 2, 3, env); - GLOBAL_PRIM_W_ARITY("namespace-require/copy", namespace_require_copy, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-require/constant", namespace_require_constant, 1, 1, env); - GLOBAL_PRIM_W_ARITY("namespace-require/expansion-time", namespace_require_etonly, 1, 1, env); - GLOBAL_PRIM_W_ARITY("compiled-module-expression?", module_compiled_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-compiled-name", module_compiled_name, 1, 2, env); - GLOBAL_PRIM_W_ARITY("module-compiled-imports", module_compiled_imports, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("module-compiled-exports", module_compiled_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY2("module-compiled-indirect-exports",module_compiled_indirect_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module-compiled-language-info", module_compiled_lang_info, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-compiled-submodules", module_compiled_submodules, 2, 3, env); - GLOBAL_PRIM_W_ARITY("module-compiled-cross-phase-persistent?", module_compiled_phaseless_p, 1, 1, env); - GLOBAL_FOLDING_PRIM("module-path-index?", module_path_index_p, 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-path-index-resolve", module_path_index_resolve, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("module-path-index-split", module_path_index_split, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module-path-index-submodule", module_path_index_submodule,1, 1, env); - GLOBAL_PRIM_W_ARITY("module-path-index-join", module_path_index_join, 2, 3, env); - GLOBAL_FOLDING_PRIM("resolved-module-path?", resolved_module_path_p, 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-resolved-module-path", make_resolved_module_path, 1, 1, env); - GLOBAL_PRIM_W_ARITY("resolved-module-path-name", resolved_module_path_name, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-provide-protected?", module_export_protected_p, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module->namespace", module_to_namespace, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module->language-info", module_to_lang_info, 1, 2, env); - GLOBAL_PRIM_W_ARITY("module->imports", module_to_imports, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("module->exports", module_to_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY2("module->indirect-exports", module_to_indirect_exports, 1, 1, 2, 2, env); - GLOBAL_PRIM_W_ARITY("module-declared?", module_is_declared, 1, 2, env); - GLOBAL_PRIM_W_ARITY("module-predefined?", module_is_predefined, 1, 1, env); - GLOBAL_PRIM_W_ARITY("module-path?", is_module_path, 1, 1, env); -} - -void scheme_init_module_resolver(void) -{ - Scheme_Object *o; - Scheme_Config *config; - - /* this function is called multiple times when scheme_basic_env() is called multiple times */ - - if (!starts_table) { - REGISTER_SO(starts_table); - starts_table = scheme_make_weak_equal_table(); -#if PLACE_LOCAL_MODPATH_TABLE - REGISTER_SO(place_local_modpath_table); - place_local_modpath_table = scheme_make_weak_equal_table(); -#endif - } - - config = scheme_current_config(); - - o = scheme_make_prim_w_arity(default_module_resolver, - "default-module-name-resolver", - 2, 4); - - scheme_set_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER, o); - - scheme_set_param(config, MZCONFIG_CURRENT_MODULE_NAME, scheme_false); -} - -static void add_exp_infos(Scheme_Module *m) -{ - Scheme_Module_Export_Info **exp_infos, *exp_info; - - exp_infos = MALLOC_N(Scheme_Module_Export_Info *, 1); - exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); - SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); - exp_infos[0] = exp_info; - m->exp_infos = exp_infos; - m->num_phases = 1; -} - -void scheme_finish_kernel(Scheme_Env *env) -{ - /* When this function is called, the initial namespace has all the - primitive bindings for syntax and procedures. This function fills - in the module wrapper for #%kernel. */ - char *running; - - REGISTER_SO(kernel); - - kernel = MALLOC_ONE_TAGGED(Scheme_Module); - kernel->so.type = scheme_module_type; - kernel->predefined = 1; - kernel->phaseless = scheme_true; - env->module = kernel; - - { - Scheme_Object *insp; - insp = scheme_get_current_inspector(); - - env->guard_insp = insp; /* nothing is protected, anyway */ - env->access_insp = insp; - kernel->insp = insp; - } - - kernel->modname = kernel_modname; - kernel->modsrc = kernel_modname; - kernel->requires = scheme_null; - kernel->et_requires = scheme_null; - kernel->tt_requires = scheme_null; - kernel->dt_requires = scheme_null; - kernel->other_requires = NULL; - add_exp_infos(kernel); - - { - Scheme_Bucket_Table *ht; - int i, j, count, syntax_start = 0; - Scheme_Bucket **bs; - Scheme_Object **exs; - /* Provide all syntax and variables: */ - count = 0; - for (j = 0; j < 2; j++) { - if (!j) - ht = env->toplevel; - else { - ht = env->syntax; - syntax_start = count; - } - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - count++; - } - } - - exs = MALLOC_N(Scheme_Object *, count); - count = 0; - for (j = 0; j < 2; j++) { - if (!j) - ht = env->toplevel; - else - ht = env->syntax; - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - exs[count++] = (Scheme_Object *)b->key; - } - } - - { - Scheme_Module_Exports *me; - me = scheme_make_module_exports(); - kernel->me = me; - kernel->me->modsrc = kernel_modname; - } - - kernel->me->rt->provides = exs; - kernel->me->rt->provide_srcs = NULL; - kernel->me->rt->provide_src_names = exs; - kernel->me->rt->num_provides = count; - kernel->me->rt->num_var_provides = syntax_start; - scheme_populate_pt_ht(kernel->me->rt); - - running = (char *)scheme_malloc_atomic(2); - running[0] = 1; - running[1] = 1; - env->running = running; - env->attached = 1; - } - - REGISTER_SO(prefix_symbol); - REGISTER_SO(only_symbol); - REGISTER_SO(rename_symbol); - REGISTER_SO(all_except_symbol); - REGISTER_SO(prefix_all_except_symbol); - REGISTER_SO(all_from_symbol); - REGISTER_SO(all_from_except_symbol); - REGISTER_SO(all_defined_symbol); - REGISTER_SO(all_defined_except_symbol); - REGISTER_SO(prefix_all_defined_symbol); - REGISTER_SO(prefix_all_defined_except_symbol); - REGISTER_SO(struct_symbol); - REGISTER_SO(protect_symbol); - REGISTER_SO(expand_symbol); - REGISTER_SO(for_syntax_symbol); - REGISTER_SO(for_template_symbol); - REGISTER_SO(for_label_symbol); - REGISTER_SO(for_meta_symbol); - REGISTER_SO(just_meta_symbol); - prefix_symbol = scheme_intern_symbol("prefix"); - only_symbol = scheme_intern_symbol("only"); - rename_symbol = scheme_intern_symbol("rename"); - all_except_symbol = scheme_intern_symbol("all-except"); - prefix_all_except_symbol = scheme_intern_symbol("prefix-all-except"); - all_from_symbol = scheme_intern_symbol("all-from"); - all_from_except_symbol = scheme_intern_symbol("all-from-except"); - all_defined_symbol = scheme_intern_symbol("all-defined"); - all_defined_except_symbol = scheme_intern_symbol("all-defined-except"); - prefix_all_defined_symbol = scheme_intern_symbol("prefix-all-defined"); - prefix_all_defined_except_symbol = scheme_intern_symbol("prefix-all-defined-except"); - struct_symbol = scheme_intern_symbol("struct"); - protect_symbol = scheme_intern_symbol("protect"); - expand_symbol = scheme_intern_symbol("expand"); - for_syntax_symbol = scheme_intern_symbol("for-syntax"); - for_template_symbol = scheme_intern_symbol("for-template"); - for_label_symbol = scheme_intern_symbol("for-label"); - for_meta_symbol = scheme_intern_symbol("for-meta"); - just_meta_symbol = scheme_intern_symbol("just-meta"); - - REGISTER_SO(module_name_symbol); - module_name_symbol = scheme_intern_symbol("enclosing-module-name"); - - REGISTER_SO(nominal_id_symbol); - nominal_id_symbol = scheme_intern_symbol("nominal-id"); - - REGISTER_SO(phaseless_keyword); - { - const char *s = "cross-phase-persistent"; - phaseless_keyword = scheme_intern_exact_keyword(s, strlen(s)); - } - - REGISTER_SO(empty_namespace_keyword); - { - const char *s = "empty-namespace"; - empty_namespace_keyword = scheme_intern_exact_keyword(s, strlen(s)); - } -} - -void scheme_init_syntax_bindings() -{ - Scheme_Object *w; - - REGISTER_SO(scheme_sys_wraps0); - REGISTER_SO(scheme_sys_wraps1); - - scheme_sys_wraps0 = sys_wraps_phase(0); - scheme_sys_wraps1 = sys_wraps_phase(1); - - REGISTER_SO(scheme_module_stx); - REGISTER_SO(scheme_modulestar_stx); - REGISTER_SO(scheme_module_begin_stx); - REGISTER_SO(scheme_begin_stx); - REGISTER_SO(scheme_define_values_stx); - REGISTER_SO(scheme_define_syntaxes_stx); - REGISTER_SO(scheme_top_stx); - REGISTER_SO(scheme_begin_for_syntax_stx); - REGISTER_SO(more_constant_stxes); - - w = scheme_sys_wraps0; - scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); - scheme_modulestar_stx = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, w, 0, 0); - scheme_module_begin_stx = scheme_datum_to_syntax(module_begin_symbol, scheme_false, w, 0, 0); - scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); - scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); - scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); - require_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); - provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); - declare_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%declare"), scheme_false, w, 0, 0); - set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); - app_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0); - scheme_top_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0); - lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0); - case_lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0); - let_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0); - letrec_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0); - if_stx = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0); - begin0_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0); - with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0); - letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0); - var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0); - expression_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0); - quote_stx = scheme_datum_to_syntax(scheme_intern_symbol("quote"), scheme_false, w, 0, 0); - datum_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%datum"), scheme_false, w, 0, 0); - - make_struct_type_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type"), scheme_false, w, 0, 0); - make_struct_type_property_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type-property"), scheme_false, w, 0, 0); - cons_stx = scheme_datum_to_syntax(scheme_intern_symbol("cons"), scheme_false, w, 0, 0); - list_stx = scheme_datum_to_syntax(scheme_intern_symbol("list"), scheme_false, w, 0, 0); - gensym_stx = scheme_datum_to_syntax(scheme_intern_symbol("gensym"), scheme_false, w, 0, 0); - string_to_uninterned_symbol_stx = scheme_datum_to_syntax(scheme_intern_symbol("string->uninterned-symbol"), - scheme_false, w, 0, 0); -} - -int scheme_is_kernel_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, kernel_modname); -} - -int scheme_is_unsafe_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, unsafe_modname); -} - -int scheme_is_flfxnum_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, flfxnum_modname); -} - -int scheme_is_extfl_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, extfl_modname); -} - -int scheme_is_futures_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, futures_modname); -} - -int scheme_is_foreign_modname(Scheme_Object *modname) -{ - return SAME_OBJ(modname, foreign_modname); -} - -Scheme_Module *get_special_module(Scheme_Object *name) -{ - if (SAME_OBJ(name, kernel_modname)) - return kernel; - else if (SAME_OBJ(name, unsafe_modname)) - return scheme_get_unsafe_env()->module; - else if (SAME_OBJ(name, flfxnum_modname)) - return scheme_get_flfxnum_env()->module; - else if (SAME_OBJ(name, extfl_modname)) - return scheme_get_extfl_env()->module; - else if (SAME_OBJ(name, futures_modname)) - return scheme_get_futures_env()->module; - else if (SAME_OBJ(name, foreign_modname)) - return scheme_get_foreign_env()->module; - else - return NULL; -} - -Scheme_Env *get_special_modenv(Scheme_Object *name) -{ - if (SAME_OBJ(name, kernel_modname)) - return scheme_get_kernel_env(); - else if (SAME_OBJ(name, flfxnum_modname)) - return scheme_get_flfxnum_env(); - else if (SAME_OBJ(name, extfl_modname)) - return scheme_get_extfl_env(); - else if (SAME_OBJ(name, futures_modname)) - return scheme_get_futures_env(); - else if (SAME_OBJ(name, unsafe_modname)) - return scheme_get_unsafe_env(); - else if (SAME_OBJ(name, foreign_modname)) - return scheme_get_foreign_env(); - else - return NULL; -} - -static int is_builtin_modname(Scheme_Object *modname) -{ - return (SAME_OBJ(modname, kernel_modname) - || SAME_OBJ(modname, unsafe_modname) - || SAME_OBJ(modname, flfxnum_modname) - || SAME_OBJ(modname, extfl_modname) - || SAME_OBJ(modname, futures_modname) - || SAME_OBJ(modname, foreign_modname)); -} - -Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env) -{ - intptr_t phase; - - if (!env) - phase = 0; - else if (SCHEME_INTP((Scheme_Object *)env)) - phase = SCHEME_INT_VAL((Scheme_Object *)env); - else - phase = env->genv->phase; - - return scheme_sys_wraps_phase(scheme_make_integer(phase)); -} - -static Scheme_Object *sys_wraps_phase(intptr_t p) -{ - Scheme_Object *rn, *w; - - rn = scheme_make_module_context(NULL, NULL, kernel_symbol); - rn = scheme_module_context_at_phase(rn, scheme_make_integer(p)); - - /* Add a module mapping for all kernel provides: */ - scheme_extend_module_context_with_shared(rn, kernel_modidx, - kernel->me->rt, - scheme_false, /* no prefix */ - NULL, /* no excepts */ - scheme_make_integer(p), - NULL, - NULL); - - w = scheme_datum_to_syntax(kernel_symbol, scheme_false, scheme_false, 0, 0); - w = scheme_stx_add_module_context(w, rn); - - return w; -} - -Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase) -{ - intptr_t p; - - if (SCHEME_INTP(phase)) - p = SCHEME_INT_VAL(phase); - else - p = -1; - - if (p == 0) return scheme_sys_wraps0; - if (p == 1) return scheme_sys_wraps1; - - return sys_wraps_phase(p); -} - -void scheme_save_initial_module_set(Scheme_Env *env) -/* Can be called multiple times! */ -{ - int i, c, count; - Scheme_Hash_Table *ht; - - if (!initial_modules_env) { - REGISTER_SO(initial_modules_env); - } - initial_modules_env = env; - - ht = env->module_registry->loaded; - c = ht->size; - - count = 0; - for (i = 0; i < c; i++) { - if (ht->vals[i]) - count++; - } - - num_initial_modules = count; - - if (!initial_modules) { - REGISTER_SO(initial_modules); - } - initial_modules = MALLOC_N(Scheme_Object *, count); - - count = 0; - for (i = 0; i < c; i++) { - if (ht->vals[i]) { - initial_modules[count++] = ht->keys[i]; - } - } -} - -void scheme_install_initial_module_set(Scheme_Env *env) -{ - int i; - Scheme_Object *a[3]; - Scheme_Module *m; - - /* Copy over module declarations and instances: */ - for (i = 0; i < num_initial_modules; i++) { - a[0] = (Scheme_Object *)initial_modules_env; - a[1] = initial_modules[i]; - a[2] = (Scheme_Object *)env; - - /* Make sure module is running: */ - m = (Scheme_Module *)scheme_hash_get(initial_modules_env->module_registry->loaded, a[1]); - start_module(m, initial_modules_env, 0, a[1], 0, 1, 0, scheme_null, 0); - - namespace_attach_module(3, a); - } - - scheme_prepare_env_stx_context(env); -} - -static Scheme_Module *registry_get_loaded(Scheme_Env *env, Scheme_Object *name) -{ - Scheme_Object *o; - - if (env->module_pre_registry && env->module_pre_registry->loaded) { - o = scheme_hash_get(env->module_pre_registry->loaded, name); - if (o) - return (Scheme_Module *)o; - } - - return (Scheme_Module *)scheme_hash_get(env->module_registry->loaded, name); -} - -/**********************************************************************/ -/* linklets and instances */ -/**********************************************************************/ - -/* A minimal linklet API to support bootstrapping. */ - -static Scheme_Object *primitive_table(int argc, Scheme_Object *argv[]); - -void scheme_init_linklet(Scheme_Env *env) -{ - Scheme_Env *newenv; - Scheme_Object *modname; - - modname = scheme_intern_symbol("#%linklet"); - newenv = scheme_primitive_module(modname, env); - - GLOBAL_PRIM_W_ARITY("primitive-table", primitive_table, 1, 2, newenv); - - scheme_finish_primitive_module(newenv); - scheme_protect_primitive_provide(newenv, NULL); -} - -static Scheme_Object *primitive_table(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env, *menv; - Scheme_Object *name; - Scheme_Hash_Tree *ht; - - if (!SCHEME_SYMBOLP(argv[0])) - scheme_wrong_contract("primitive-table", "symbol?", 0, argc, argv); - if ((argc > 1) && !SCHEME_HASHTRP(argv[1])) - scheme_wrong_contract("primitive-table", "(and/c hash? immutable?)", 1, argc, argv); - - name = scheme_intern_resolved_module_path(argv[0]); - - env = scheme_get_env(NULL); - menv = get_special_modenv(name); - if (!menv) - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), name); - - if (!menv) { - if (argc > 1) { - Scheme_Object *k, *v; - mzlonglong pos; - - menv = scheme_primitive_module(argv[0], env); - - ht = (Scheme_Hash_Tree *)argv[1]; - pos = scheme_hash_tree_next(ht, -1); - while (pos != -1) { - scheme_hash_tree_index(ht, pos, &k, &v); - if (SCHEME_SYMBOLP(k)) { - scheme_add_global_symbol(k, v, menv); - } - pos = scheme_hash_tree_next(ht, pos); - } - - scheme_finish_primitive_module(menv); - - start_module(menv->module, env, 0, name, 0, 1, 0, scheme_null, 0); - } else - return scheme_false; - } - - if (argc < 2) { - Scheme_Bucket **bs, *b; - intptr_t i; - - ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - bs = menv->toplevel->buckets; - for (i = menv->toplevel->size; i--; ) { - b = bs[i]; - if (b && b->val) { - ht = scheme_hash_tree_set(ht, (Scheme_Object *)b->key, b->val); - } - } - - return (Scheme_Object *)ht; - } else - return scheme_void; -} - -/**********************************************************************/ -/* parameters */ -/**********************************************************************/ - -static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv) -{ - Scheme_Object *p = argv[0]; - - if (argc == 2) - return scheme_void; /* ignore notify */ - - /* if (quote SYMBOL) */ - if (SCHEME_PAIRP(p) - && SAME_OBJ(SCHEME_CAR(p), quote_symbol) - && SCHEME_PAIRP(SCHEME_CDR(p)) - && SCHEME_SYMBOLP(SCHEME_CAR(SCHEME_CDR(p))) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(p)))) - return scheme_intern_resolved_module_path(SCHEME_CAR(SCHEME_CDR(p))); - - scheme_contract_error("default-module-name-resolver", - "the kernel's resolver works only on `quote' forms", - "given", 1, p, - NULL); - return NULL; -} - -static Scheme_Object *check_resolver(int argc, Scheme_Object **argv) -{ - if (scheme_check_proc_arity(NULL, 2, 0, argc, argv) - && scheme_check_proc_arity(NULL, 4, 0, argc, argv)) - return argv[0]; - - scheme_wrong_contract("current-module-name-resolver", - "(case-> (any/c any/c . -> . any) (any/c any/c any/c any/c . -> . any))", - 0, argc, argv); - - return NULL; -} - -static Scheme_Object * -current_module_name_resolver(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-name-resolver", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER), - argc, argv, - -1, check_resolver, - "(and/c (procedure-arity-includes/c 1)" - /* */ " (procedure-arity-includes/c 4))", - 1); -} - -static Scheme_Object *prefix_p(int argc, Scheme_Object **argv) -{ - Scheme_Object *o = argv[0]; - - if (SCHEME_FALSEP(o) || (SCHEME_MODNAMEP(o))) - return o; - - return NULL; -} - -static Scheme_Object * -current_module_name_prefix(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-declared-name", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME), - argc, argv, - -1, prefix_p, "(or/c resolved-module-path? #f)", 1); -} - -static Scheme_Object *source_p(int argc, Scheme_Object **argv) -{ - Scheme_Object *o = argv[0]; - - if (!SCHEME_FALSEP(o) - && !SCHEME_SYMBOLP(o) - && (!SCHEME_PATHP(o) - || !scheme_is_complete_path(SCHEME_PATH_VAL(o), - SCHEME_PATH_LEN(o), - SCHEME_PLATFORM_PATH_KIND))) - return NULL; - - return o; -} - -static Scheme_Object * -current_module_name_source(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-declared-name", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_SRC), - argc, argv, - -1, source_p, - "(or/c symbol? (and/c path-string? complete-path?) #f)", - 1); -} - -static Scheme_Object *load_path_p(int argc, Scheme_Object **argv) -{ - Scheme_Object *o = argv[0]; - - if (!SCHEME_FALSEP(o) - && !scheme_is_module_path(o) - && (!SCHEME_STXP(o) - || !scheme_is_module_path(scheme_syntax_to_datum(o, 0, NULL)))) - return NULL; - - return o; -} - -static Scheme_Object * -current_module_load_path(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-module-path-for-load", - scheme_make_integer(MZCONFIG_CURRENT_MODULE_LOAD_PATH), - argc, argv, - -1, load_path_p, - "(or/c module-path?" - /**/ " (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))" - /**/ " #f)", - 1); -} - -/**********************************************************************/ -/* procedures */ -/**********************************************************************/ - -int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp) -{ - if (!insp) - return 1; - if (SAME_OBJ(insp, scheme_true)) - return 0; - return !scheme_is_subinspector(home_insp, insp); -} - -static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], - Scheme_Env *env, - int get_bucket, - int phase, int mod_phase, int indirect_ok, - int fail_with_error, - int position) -{ - Scheme_Object *modname, *modidx; - Scheme_Object *name, *srcname, *srcmname, *fail_thunk; - Scheme_Module *m, *srcm; - Scheme_Env *menv, *lookup_env = NULL; - int i, count, protected = 0, check_protected_at_source = 0; - - const char *errname; - intptr_t base_phase; - - modname = argv[0]; - name = argv[1]; - if (argc > 2) - fail_thunk = argv[2]; - else - fail_thunk = NULL; - - errname = (phase - ? ((phase < 0) - ? "dynamic-require-for-template" - : "dynamic-require-for-syntax" ) - : "dynamic-require"); - - if (SCHEME_TRUEP(name) - && !SCHEME_SYMBOLP(name) - && !SAME_OBJ(name, scheme_make_integer(0)) - && !SCHEME_VOIDP(name)) { - scheme_wrong_contract(errname, "(or/c symbol? #f 0 void?)", 1, argc, argv); - return NULL; - } - - if (fail_thunk) - scheme_check_proc_arity(errname, 0, 2, argc, argv); - - if (SAME_TYPE(SCHEME_TYPE(modname), scheme_module_index_type)) - modidx = modname; - else - modidx = scheme_make_modidx(modname, scheme_false, scheme_false); - - modname = scheme_module_resolve(modidx, 1); - - if (phase == 1) { - scheme_prepare_exp_env(env); - if (mod_phase) - lookup_env = env->exp_env; - else - env = env->exp_env; - } - - base_phase = env->phase; - - m = module_load(modname, env, errname); - srcm = m; - - srcmname = NULL; - srcname = NULL; - - if (SCHEME_SYMBOLP(name)) { - if (mod_phase) { - srcname = name; - srcmname = modname; - } else { - /* Before starting, check whether the name is provided */ - count = srcm->me->rt->num_provides; - if (position >= 0) { - if (position < srcm->me->rt->num_var_provides) { - i = position; - if ((SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->me->rt->provide_src_names[i])) - && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->me->rt->provide_src_names[i]), SCHEME_SYM_LEN(name))) { - name = srcm->me->rt->provides[i]; - } else { - i = count; /* not found */ - indirect_ok = 0; /* don't look further */ - } - } else { - position -= srcm->me->rt->num_var_provides; - i = count; - } - } else { - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, srcm->me->rt->provides[i])) { - if (i < srcm->me->rt->num_var_provides) { - break; - } else { - if (fail_with_error) { - int started = 0; - if (!phase - && srcm->me->rt->provide_srcs - && SCHEME_TRUEP(srcm->me->rt->provide_srcs[i])) { - /* Handle simple re-exporting */ - int j; - Scheme_Module *srcm2; - - start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null, 0); - started = 1; - - srcmname = srcm->me->rt->provide_srcs[i]; - srcmname = scheme_modidx_shift(srcmname, - srcm->me->src_modidx, - srcm->self_modidx); - srcmname = scheme_module_resolve(srcmname, 1); - srcname = srcm->me->rt->provide_src_names[i]; - if (srcm->me->rt->provide_src_phases - && (srcm->me->rt->provide_src_phases[i] != 0)) { - /* shortcut only checks phase 0, so use the long way */ - srcmname = NULL; - } - - if (srcmname) { - srcm2 = module_load(srcmname, env, errname); - - for (j = srcm2->me->rt->num_var_provides; j--; ) { - if ((!srcm2->me->rt->provide_srcs - || SCHEME_FALSEP(srcm2->me->rt->provide_srcs[j])) - && SAME_OBJ(srcname, srcm2->me->rt->provide_src_names[j])) { - /* simple re-export applies: */ - srcm = srcm2; - count = srcm->me->rt->num_provides; - name = srcm2->me->rt->provides[j]; - i = j; - break; - } - } - if (j < 0) { - /* Try indirect: */ - Scheme_Module_Export_Info *exp_info = srcm2->exp_infos[0]; - for (j = exp_info->num_indirect_provides; j--; ) { - if (SAME_OBJ(srcname, exp_info->indirect_provides[j])) { - srcm = srcm2; - name = srcname; - count = srcm->me->rt->num_provides; - i = count; - position = j; - indirect_ok = 1; - break; - } - } - if (j < 0) { - /* simple re-exporting doesn't work */ - srcmname = NULL; - } - } - } - } - - if (srcmname) { - /* Simple re-exporting shortcut worked */ - break; - } else if (!phase) { - /* The long way: evaluate id in a fresh namespace */ - Scheme_Object *a[3], *ns; - Scheme_Config *config; - Scheme_Cont_Frame_Data cframe; - - if (!started) - start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null, 0); - ns = scheme_make_namespace(0, NULL); - a[0] = (Scheme_Object *)env; - a[1] = srcm->modname; - a[2] = ns; - namespace_attach_module(3, a); - a[0] = scheme_make_pair(scheme_intern_symbol("only"), - scheme_make_pair(srcm->modname, - scheme_make_pair(name, - scheme_null))); - do_namespace_require((Scheme_Env *)ns, 1, a, 0, 0); - - scheme_push_continuation_frame(&cframe); - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - ns); - scheme_set_cont_mark(scheme_parameterization_key, - (Scheme_Object *)config); - - ns = scheme_eval(name, (Scheme_Env *)ns); - - scheme_pop_continuation_frame(&cframe); - - return ns; - } else { - scheme_contract_error(errname, - "name is provided as syntax", - "name", 1, name, - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - } - return NULL; - } - } - } - } - - if (i < count) { - if (srcm->exp_infos[0]->provide_protects) - protected = srcm->exp_infos[0]->provide_protects[i]; - srcmname = (srcm->me->rt->provide_srcs ? srcm->me->rt->provide_srcs[i] : scheme_false); - if (SCHEME_FALSEP(srcmname)) { - srcmname = srcm->modname; - } else { - srcmname = scheme_modidx_shift(srcmname, srcm->me->src_modidx, srcm->self_modidx); - srcmname = scheme_module_resolve(srcmname, 1); - check_protected_at_source = 1; - if (srcm->me->rt->provide_src_phases) - mod_phase += srcm->me->rt->provide_src_phases[i]; - } - srcname = srcm->me->rt->provide_src_names[i]; - } - - if (i == count) { - if (indirect_ok) { - /* Try indirect provides: */ - Scheme_Module_Export_Info *exp_info = srcm->exp_infos[0]; - count = exp_info->num_indirect_provides; - if (position >= 0) { - i = position; - if ((i < exp_info->num_indirect_provides) - && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(exp_info->indirect_provides[i])) - && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(exp_info->indirect_provides[i]), SCHEME_SYM_LEN(name))) { - name = exp_info->indirect_provides[i]; - srcname = name; - srcmname = srcm->modname; - if (exp_info->provide_protects) - protected = exp_info->provide_protects[i]; - } else - i = count; /* not found */ - } else { - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, exp_info->indirect_provides[i])) { - srcname = name; - srcmname = srcm->modname; - if (exp_info->provide_protects) - protected = exp_info->provide_protects[i]; - break; - } - } - } - } - - if (i == count) { - if (fail_with_error) { - if (fail_thunk) - return scheme_tail_apply(fail_thunk, 0, NULL); - scheme_contract_error(errname, - "name is not provided", - "name", 1, name, - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - return NULL; - } - } - } - } - - start_module(m, env, 0, modidx, - (SCHEME_VOIDP(name) - ? 1 - : (SAME_OBJ(name, scheme_make_integer(0)) - ? -1 - : 0)), - (SCHEME_VOIDP(name) - ? 0 - : 1), - base_phase, - scheme_null, - 0); - - if (SCHEME_SYMBOLP(name)) { - Scheme_Bucket *b; - - menv = scheme_module_access(srcmname, lookup_env ? lookup_env : env, mod_phase); - - if (check_protected_at_source) { - Scheme_Module_Phase_Exports *pt; - if (mod_phase == 0) - pt = menv->module->me->rt; - else if (mod_phase == 1) - pt = menv->module->me->et; - else if (menv->module->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(menv->module->me->other_phases, - scheme_make_integer(mod_phase)); - else - pt = NULL; - if (pt) { - count = pt->num_provides; - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, pt->provides[i])) { - if (menv->module->exp_infos[mod_phase]->provide_protects) - protected = menv->module->exp_infos[mod_phase]->provide_protects[i]; - } - } - } - } - - if (protected) { - Scheme_Object *insp; - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - if (scheme_module_protected_wrt(menv->guard_insp, insp)) - scheme_contract_error(errname, - "name is protected", - "name", 1, name, - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - - if (!menv || !menv->toplevel) { - scheme_contract_error(errname, - "module inialization failed", - "module", 1, scheme_get_modsrc(srcm), - NULL); - } - - b = scheme_bucket_from_table(menv->toplevel, (const char *)srcname); - scheme_set_bucket_home(b, menv); - - if (get_bucket) - return (Scheme_Object *)b; - else { - if (!b->val) { - if (!menv->ran) - run_module(menv, 1); - } - if (!b->val && fail_with_error) { - if (fail_thunk) - return scheme_tail_apply(fail_thunk, 0, NULL); - scheme_unbound_global(b); - } - return b->val; - } - } else - return scheme_void; -} - -Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]) -{ - if (scheme_module_demand_hook) { - Scheme_Object *r; - r = scheme_module_demand_hook(argc, argv); - if (r) return r; - } - - return _dynamic_require(argc, argv, scheme_get_env(NULL), 0, 0, 0, 0, 1, -1); -} - -static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[]) -{ - return _dynamic_require(argc, argv, scheme_get_env(NULL), 0, 1, 0, 0, 1, -1); -} - -static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], - int copy, int etonly) -{ - Scheme_Object *form; - - if (!env) - env = scheme_get_env(NULL); - scheme_prepare_exp_env(env); - - if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - form = argv[0]; - else { - form = scheme_datum_to_syntax(scheme_make_pair(require_stx, - scheme_make_pair(argv[0], scheme_null)), - scheme_false, scheme_false, 1, 0); - form = scheme_stx_add_module_context(form, env->stx_context); - } - - parse_requires(form, env->phase, scheme_false, env, NULL, - env->stx_context, - NULL /* ck */, NULL /* data */, - NULL, - copy, - (etonly ? 1 : -1), !etonly, - NULL, NULL, NULL, - NULL); - - return scheme_void; -} - -static Scheme_Object *namespace_require(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 0, 0); -} - -Scheme_Object *scheme_namespace_require(Scheme_Object *r) -{ - Scheme_Object *a[1]; - a[0] = r; - return namespace_require(1, a); -} - -static Scheme_Object *namespace_require_copy(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 1, 0); -} - -static Scheme_Object *namespace_require_constant(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 2, 0); -} - -static Scheme_Object *namespace_require_etonly(int argc, Scheme_Object *argv[]) -{ - return do_namespace_require(NULL, argc, argv, 0, 1); -} - -static Scheme_Object *extend_list_depth(Scheme_Object *l, Scheme_Object *n, int with_ht) -{ - Scheme_Object *p, *orig; - int k; - - if (!SCHEME_INTP(n)) - scheme_raise_out_of_memory(NULL, NULL); - - k = SCHEME_INT_VAL(n); - - if (SCHEME_NULLP(l)) { - if (with_ht) - p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); - else - p = scheme_null; - l = scheme_make_pair(p, scheme_null); - } - - orig = l; - - while (k--) { - if (SCHEME_NULLP(SCHEME_CDR(l))) { - if (with_ht) - p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); - else - p = scheme_null; - p = scheme_make_pair(p, scheme_null); - SCHEME_CDR(l) = p; - } - l = SCHEME_CDR(l); - } - - return orig; -} - -static Scheme_Object *extract_at_depth(Scheme_Object *l, Scheme_Object *n) -{ - int k = SCHEME_INT_VAL(n); - - while (k--) { - l = SCHEME_CDR(l); - } - - return SCHEME_CAR(l); -} - -static void set_at_depth(Scheme_Object *l, Scheme_Object *n, Scheme_Object *v) -{ - int k = SCHEME_INT_VAL(n); - - while (k--) { - l = SCHEME_CDR(l); - } - - SCHEME_CAR(l) = v; -} - -#if 0 -static void check_phase(Scheme_Env *menv, Scheme_Env *env, int phase) -{ - if (env && (env->exp_env == env)) { - /* label phase */ - return; - } - - if (!menv->module->primitive - && ((env && (menv->phase != env->phase)) - || (!env && (menv->phase != phase)))) { - fprintf(stderr, "phase mismatch\n"); - } -} - -static void check_modchain_consistency(Scheme_Hash_Table *ht, int phase) -{ - int i; - - for (i = ht->size; i--; ) { - if (ht->vals[i]) { - check_phase((Scheme_Env *)ht->vals[i], NULL, phase); - } - } -} -#else -static void check_phase(Scheme_Env *menv, Scheme_Env *env, int phase) { } -static void check_modchain_consistency(Scheme_Hash_Table *ht, int phase) { } -#endif - -void ensure_instantiate_for_label(const char *who, Scheme_Env *from_env, Scheme_Object *name, Scheme_Object *modidx) -{ - Scheme_Module *m2; - - m2 = registry_get_loaded(from_env, name); - if (!m2) - scheme_contract_error(who, - "module not declared (in the source namespace)", - "name", 1, name, - NULL); - else { - /* instantiate for-label: */ - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - /* make sure `from_env' is the current namespace, because - start_module() may need to resolve module paths: */ - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)from_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - start_module(m2, - from_env->label_env, 0, - modidx, - 0, 0, -1, - scheme_null, - 0); - - scheme_pop_continuation_frame(&cframe); - } -} - -static Scheme_Object *make_sub_modidx_pair(Scheme_Env *menv, Scheme_Object *name, int i) -{ - Scheme_Object *modidx; - - if (i) { - name = scheme_resolved_module_path_value(name); - while (SCHEME_PAIRP(SCHEME_CDR(name))) { - name = SCHEME_CDR(name); - } - name = SCHEME_CAR(name); - } else { - name = scheme_make_utf8_string(".."); - } - - modidx = scheme_make_modidx(scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string("."), - scheme_make_pair(name, - scheme_null))), - menv->link_midx, - scheme_false); - name = scheme_module_resolve(modidx, 0); - - return scheme_make_pair(name, modidx); -} - -#if 0 -# define LOG_ATTACH(x) (x, fflush(stdout)) -#else -# define LOG_ATTACH(x) /* nothing */ -#endif - -static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Scheme_Object *argv[], - int only_declare) -{ - Scheme_Env *from_env, *to_env, *menv, *menv2; - Scheme_Object *todo, *next_phase_todo, *prev_phase_todo; - Scheme_Object *name, *notifies = scheme_null, *a[2], *resolver; - Scheme_Object *to_modchain, *from_modchain, *l, *main_modidx; - Scheme_Hash_Table *checked, *next_checked, *prev_checked; - Scheme_Object *past_checkeds, *future_checkeds, *future_todos, *past_to_modchains, *past_todos; - Scheme_Module *m2; - int same_namespace, set_env_for_notify = 0, phase, orig_phase, max_phase; - Scheme_Object *nophase_todo; - Scheme_Hash_Table *nophase_checked; - - if (!SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_contract(who, "namespace?", 0, argc, argv); - from_env = (Scheme_Env *)argv[0]; - - if (argc > 2) { - if (!SCHEME_NAMESPACEP(argv[2])) - scheme_wrong_contract(who, "namespace?", 2, argc, argv); - to_env = (Scheme_Env *)argv[2]; - set_env_for_notify = 1; - } else - to_env = scheme_get_env(NULL); - - same_namespace = SAME_OBJ(from_env, to_env); - - if (from_env->phase != to_env->phase) { - scheme_contract_error("namespace-attach-module", - "source and destination namespace phases do not match", - "source phase", 1, scheme_make_integer(from_env->phase), - "destination phase", 1, scheme_make_integer(to_env->phase), - NULL); - } - - main_modidx = scheme_make_modidx(argv[1], scheme_false, scheme_false); - name = scheme_module_resolve(main_modidx, 0); - - if (!only_declare) { - todo = scheme_make_pair(name, scheme_null); - nophase_todo = scheme_null; - } else { - todo = scheme_null; - nophase_todo = scheme_make_pair(name, scheme_null); - } - - next_phase_todo = scheme_null; - prev_phase_todo = scheme_null; - from_modchain = from_env->modchain; - to_modchain = to_env->modchain; - phase = from_env->phase; - orig_phase = phase; - - checked = NULL; - next_checked = NULL; - prev_checked = NULL; - - past_checkeds = scheme_null; - past_todos = scheme_null; - future_checkeds = scheme_null; - future_todos = scheme_null; - past_to_modchains = scheme_null; - - nophase_checked = scheme_make_hash_table(SCHEME_hash_ptr); - if (only_declare) { - scheme_hash_set(nophase_checked, name, scheme_false); - } - - max_phase = phase; - - checked = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(checked, name, scheme_true); - - /* Check whether todo, or anything it needs, is already declared - incompatibly. Successive iterations of the outer loop explore - successive phases (i.e, for-syntax levels). */ - while (!SCHEME_NULLP(todo)) { - if (phase > max_phase) - max_phase = phase; - - if (!checked) - checked = scheme_make_hash_table(SCHEME_hash_ptr); - /* This is just a shortcut: */ - if (!next_checked) - next_checked = scheme_make_hash_table(SCHEME_hash_ptr); - - /* This loop iterates through require chains in the same phase */ - while (!SCHEME_NULLP(todo)) { - name = SCHEME_CAR(todo); - - todo = SCHEME_CDR(todo); - - if (!scheme_hash_get(checked, name)) { - scheme_signal_error("internal error: module not in `checked' table"); - } - - if (!is_builtin_modname(name)) { - LOG_ATTACH(printf("Check %d %s\n", phase, scheme_write_to_string(name, 0))); - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_modchain), name); - - if (!menv) { - /* Assert: name == argv[1] */ - /* Module at least declared? */ - if (registry_get_loaded(from_env, name)) - scheme_contract_error(who, - "module not instantiated (in the source namespace)", - "name", 1, name, - NULL); - else - scheme_contract_error(who, - "unknown module (in the source namespace)", - "name", 1, name, - NULL); - } - - /* If to_modchain goes to #f, then our source check has gone - deeper in phases (for-syntax levels) than the target - namespace has ever gone, so there's definitely no conflict - at this level in that case. */ - if ((phase >= orig_phase) && SCHEME_TRUEP(to_modchain)) { - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - if (menv2) { - if (!SAME_OBJ(menv->toplevel, menv2->toplevel)) - m2 = menv2->module; - else - m2 = NULL; - } else { - m2 = registry_get_loaded(to_env, name); - if (m2 && SAME_OBJ(m2, menv->module)) - m2 = NULL; - } - - if (m2 && (phase > orig_phase) && SAME_OBJ(menv->module, m2)) { - /* different instance of same module is ok at higher phases */ - m2 = NULL; - } - - if (m2) { - char *phase, buf[32], *kind; - - if (!menv->phase) - phase = ""; - else if (menv->phase == 1) - phase = " phase: for syntax\n"; - else { - sprintf(buf, " phase: %" PRIdPTR "\n", menv->phase); - phase = buf; - } - - if (SAME_OBJ(menv->module, m2)) - kind = "instance of the same module"; - else - kind = "module with the same name"; - - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "namespace-attach-module: " - "a different %s is already " - "in the destination namespace\n" - "%s" - " module name: %D", - kind, phase, name); - return NULL; - } - } else - menv2 = NULL; - - if (!menv2 || same_namespace) { - /* Push requires onto the check list: */ - l = menv->require_names; - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(checked, name)) { - LOG_ATTACH(printf("Add %d %s (%p)\n", phase, scheme_write_to_string(name, 0), checked)); - todo = scheme_make_pair(name, todo); - scheme_hash_set(checked, name, (phase < orig_phase) ? scheme_false : scheme_true); - } - l = SCHEME_CDR(l); - } - - /* was here */ - - l = menv->et_require_names; - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(next_checked, name)) { - LOG_ATTACH(printf("Add +%d %s (%p)\n", phase+1, scheme_write_to_string(name, 0), next_checked)); - next_phase_todo = scheme_make_pair(name, next_phase_todo); - scheme_hash_set(next_checked, name, ((phase+1) < orig_phase) ? scheme_false : scheme_true); - } - l = SCHEME_CDR(l); - } - - l = menv->tt_require_names; - if (l) { - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!prev_checked) - prev_checked = scheme_make_hash_table(SCHEME_hash_ptr); - if (!scheme_hash_get(prev_checked, name)) { - LOG_ATTACH(printf("Add -%d %s (%p)\n", phase-1, scheme_write_to_string(name, 0), prev_checked)); - prev_phase_todo = scheme_make_pair(name, prev_phase_todo); - scheme_hash_set(prev_checked, name, (((phase-1) < orig_phase) ? scheme_false : scheme_true)); - } - l = SCHEME_CDR(l); - } - } - - if (!same_namespace) { - l = menv->dt_require_names; - if (l) { - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - - if (!scheme_hash_get(nophase_checked, name)) { - LOG_ATTACH(printf("Add * %s\n", scheme_write_to_string(name, NULL))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, name, scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - - if (menv->other_require_names) { - Scheme_Hash_Table *oht; - int i; - oht = menv->other_require_names; - for (i = 0; i < oht->size; i++) { - if (oht->vals[i]) { - Scheme_Object *lphase = oht->keys[i]; - Scheme_Object *l = oht->vals[i], *todos, *checkeds; - - if (scheme_is_negative(lphase)) { - lphase = scheme_bin_minus(scheme_make_integer(0), lphase); - lphase = scheme_bin_minus(lphase, scheme_make_integer(2)); - past_todos = extend_list_depth(past_todos, lphase, 0); - past_checkeds = extend_list_depth(past_checkeds, lphase, 1); - todos = past_todos; - checkeds = past_checkeds; - } else { - lphase = scheme_bin_minus(lphase, scheme_make_integer(2)); - future_todos = extend_list_depth(future_todos, lphase, 0); - future_checkeds = extend_list_depth(future_checkeds, lphase, 1); - todos = future_todos; - checkeds = future_checkeds; - } - if (todos) { - Scheme_Object *a_todo; - Scheme_Hash_Table *a_checked; - - a_todo = extract_at_depth(todos, lphase); - a_checked = (Scheme_Hash_Table *)extract_at_depth(checkeds, lphase); - - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(a_checked, name)) { - LOG_ATTACH(printf("Add +%ld %s (%p)\n", - SCHEME_INT_VAL(oht->keys[i]), - scheme_write_to_string(name, 0), a_checked)); - a_todo = scheme_make_pair(name, a_todo); - scheme_hash_set(a_checked, - name, - (((phase + SCHEME_INT_VAL(oht->keys[i])) < orig_phase) - ? scheme_false - : scheme_true)); - } - l = SCHEME_CDR(l); - } - - set_at_depth(todos, lphase, a_todo); - } - } - } - } - - if (!same_namespace) { - /* attached submodules: like for-label imports: */ - int i; - for (i = 0; i < 3; i++) { - switch (i) { - case 0: - if (menv->module->supermodule) - l = scheme_make_pair(menv->module->supermodule, scheme_null); - else - l = scheme_null; - break; - case 1: - l = menv->module->post_submodules; - break; - case 2: - default: - l = menv->module->pre_submodules; - break; - } - if (l) { - while (!SCHEME_NULLP(l)) { - name = ((Scheme_Module *)SCHEME_CAR(l))->modname; - - if (!scheme_hash_get(nophase_checked, name)) { - name = make_sub_modidx_pair(menv, name, i); - LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(SCHEME_CAR(name), NULL))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, SCHEME_CAR(name), scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - } - } - } - } - - do { - if (!SCHEME_PAIRP(next_phase_todo)) { - /* Work on earlier phase */ - LOG_ATTACH(printf("prev\n")); - future_todos = cons(next_phase_todo, future_todos); - next_phase_todo = todo; - future_checkeds = cons((Scheme_Object *)next_checked, future_checkeds); - next_checked = checked; - - todo = prev_phase_todo; - checked = prev_checked; - - if (SCHEME_NULLP(past_todos)) { - prev_phase_todo = scheme_null; - prev_checked = NULL; - } else { - prev_phase_todo = SCHEME_CAR(past_todos); - past_todos = SCHEME_CDR(past_todos); - prev_checked = (Scheme_Hash_Table *)SCHEME_CAR(past_checkeds); - past_checkeds = SCHEME_CDR(past_checkeds); - } - - from_modchain = SCHEME_VEC_ELS(from_modchain)[2]; - if (phase > orig_phase) { - to_modchain = SCHEME_CAR(past_to_modchains); - past_to_modchains = SCHEME_CDR(past_to_modchains); - } - phase--; - } else { - /* Work on later phase */ - LOG_ATTACH(printf("later\n")); - past_todos = cons(prev_phase_todo, past_todos); - prev_phase_todo = todo; - past_checkeds = scheme_make_raw_pair((Scheme_Object *)prev_checked, past_checkeds); - prev_checked = checked; - - todo = next_phase_todo; - checked = next_checked; - - if (SCHEME_NULLP(future_todos)) { - next_phase_todo = scheme_null; - next_checked = NULL; - } else { - next_phase_todo = SCHEME_CAR(future_todos); - future_todos = SCHEME_CDR(future_todos); - next_checked = (Scheme_Hash_Table *)SCHEME_CAR(future_checkeds); - future_checkeds = SCHEME_CDR(future_checkeds); - } - - from_modchain = SCHEME_VEC_ELS(from_modchain)[1]; - if (phase >= orig_phase) { - past_to_modchains = cons(to_modchain, past_to_modchains); - if (SCHEME_TRUEP(to_modchain)) - to_modchain = SCHEME_VEC_ELS(to_modchain)[1]; - } - phase++; - } - } while (SCHEME_NULLP(todo) && (SCHEME_PAIRP(prev_phase_todo) - || SCHEME_PAIRP(past_todos))); - } - - LOG_ATTACH(printf("Done phase: %d\n", phase)); - - if (SCHEME_PAIRP(nophase_todo) && !from_env->label_env) - scheme_signal_error("internal error: missing label environment"); - - /* Recursively process phase-#f modules: */ - while (!SCHEME_NULLP(nophase_todo)) { - int is_submod; - - name = SCHEME_CAR(nophase_todo); - if (SCHEME_PAIRP(name)) { - is_submod = 1; - main_modidx = SCHEME_CDR(name); - name = SCHEME_CAR(name); - } else - is_submod = 0; - nophase_todo = SCHEME_CDR(nophase_todo); - - if (!is_builtin_modname(name)) { - int i; - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); - - LOG_ATTACH(printf("Check #f %s\n", scheme_write_to_string(name, 0))); - - if (!menv) { - if ((only_declare || is_submod) && main_modidx) { - ensure_instantiate_for_label(who, from_env, name, main_modidx); - /* try again: */ - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); - } - - if (!menv) - scheme_arg_mismatch(who, - "internal error; unknown module (for label): ", - name); - } - - main_modidx = NULL; - - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - m2 = registry_get_loaded(to_env, name); - if (m2 && !SAME_OBJ(m2, menv->module)) { - const char * kind = "module with the same name"; - const char * phase = ""; - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "namespace-attach-module: " - "a different %s is already " - "in the destination namespace\n" - "%s" - " module name: %D", - kind, phase, name); - } - - for (i = -4; - i < (menv->other_require_names ? menv->other_require_names->size : 0); - i++) { - switch (i) { - case -4: - l = menv->require_names; - break; - case -3: - l = menv->et_require_names; - break; - case -2: - l = menv->tt_require_names; - break; - case -1: - l = menv->dt_require_names; - break; - default: - l = menv->other_require_names->vals[i]; - break; - } - - if (l) { - while (!SCHEME_NULLP(l)) { - name = scheme_module_resolve(SCHEME_CAR(l), 0); - if (!scheme_hash_get(nophase_checked, name)) { - LOG_ATTACH(printf("Add .* %s\n", scheme_write_to_string(name, 0))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, name, scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - - for (i = 0; i < 3; i++) { - switch (i) { - case 0: - if (menv->module->supermodule) - l = scheme_make_pair(menv->module->supermodule, scheme_null); - else - l = scheme_null; - break; - case 1: - l = menv->module->post_submodules; - break; - case 2: - default: - l = menv->module->pre_submodules; - break; - } - - if (l) { - while (!SCHEME_NULLP(l)) { - name = ((Scheme_Module *)SCHEME_CAR(l))->modname; - - if (!scheme_hash_get(nophase_checked, name)) { - name = make_sub_modidx_pair(menv, name, i); - LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(SCHEME_CAR(name), NULL))); - nophase_todo = scheme_make_pair(name, nophase_todo); - scheme_hash_set(nophase_checked, SCHEME_CAR(name), scheme_true); - } - l = SCHEME_CDR(l); - } - } - } - } - } - - /* All of the modules that we saw are in the ***_checked hash tables */ - if (prev_checked) { - past_checkeds = cons((Scheme_Object *)prev_checked, past_checkeds); - } - if (!only_declare){ - if (!checked) - checked = scheme_make_hash_table(SCHEME_hash_ptr); - past_checkeds = cons((Scheme_Object *)checked, past_checkeds); - } - - if (phase < max_phase) { - past_checkeds = cons((Scheme_Object *)next_checked, past_checkeds); - phase++; - } - while (phase < max_phase) { - next_checked = (Scheme_Hash_Table *)SCHEME_CAR(future_checkeds); - past_checkeds = scheme_make_raw_pair((Scheme_Object *)next_checked, past_checkeds); - - future_checkeds = SCHEME_CDR(future_checkeds); - phase++; - } - /* Now all the modules to check are in the past_checkeds - list of hash tables. */ - - /* Transfers phase-#f modules first. */ - { - int i; - Scheme_Hash_Table *ht; - - scheme_prepare_label_env(to_env); - - ht = nophase_checked; - for (i = ht->size; i--; ) { - if (ht->vals[i]) { - name = ht->keys[i]; - - if (!is_builtin_modname(name)) { - - LOG_ATTACH(printf("Copying no-phase %s\n", scheme_write_to_string(name, NULL))); - - m2 = registry_get_loaded(from_env, name); - scheme_hash_set(to_env->module_registry->loaded, name, (Scheme_Object *)m2); - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); - menv2 = scheme_copy_module_env(menv, to_env->label_env, to_env->label_env->modchain, menv->phase + 1); - check_phase(menv2, to_env->label_env, 0); - scheme_hash_set(MODCHAIN_TABLE(to_env->label_env->modchain), name, (Scheme_Object *)menv2); - - if (menv->attached) - menv2->attached = 1; - - /* Push name onto notify list: */ - if (!same_namespace) - notifies = scheme_make_pair(name, notifies); - } - } - } - } - - /* Get modchain at `phase': */ - { - int i; - Scheme_Env *te = to_env; - from_modchain = from_env->modchain; - to_modchain = to_env->modchain; - for (i = from_env->phase; i < phase; i++) { - from_modchain = SCHEME_VEC_ELS(from_modchain)[1]; - - scheme_prepare_exp_env(te); - te = te->exp_env; - to_modchain = SCHEME_VEC_ELS(to_modchain)[1]; - } - } - - /* Go through that list, this time tranferring module instances. */ - /* Again, outer loop iterates through phases. */ - while (!SCHEME_NULLP(past_checkeds)) { - /* Inner loop iterates through requires within a phase. */ - int i; - - checked = (Scheme_Hash_Table *)SCHEME_CAR(past_checkeds); - - LOG_ATTACH(printf("Copying %d (%p)\n", phase, checked)); - - if (phase >= orig_phase) - check_modchain_consistency(MODCHAIN_TABLE(to_modchain), phase); - - for (i = checked->size; i--; ) { - if (checked->vals[i]) { - int just_declare = SCHEME_FALSEP(checked->vals[i]); - name = checked->keys[i]; - - if (!is_builtin_modname(name)) { - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_modchain), name); - - LOG_ATTACH(printf("Copy %d %s (%d)\n", phase, scheme_write_to_string(name, 0), just_declare)); - - /* Declare in the new namespace: */ - if (!scheme_hash_get(to_env->module_registry->exports, name)) { - scheme_hash_set(to_env->module_registry->loaded, name, (Scheme_Object *)menv->module); - scheme_hash_set(to_env->module_registry->exports, name, (Scheme_Object *)menv->module->me); - - /* Push name onto notify list: */ - if (!same_namespace) - notifies = scheme_make_pair(name, notifies); - } - - /* Clone/copy menv for the new namespace: */ - if ((phase >= orig_phase) && !just_declare) { - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - if (!menv2) { - menv2 = scheme_copy_module_env(menv, to_env, to_modchain, orig_phase); - if (menv->attached) - menv2->attached = 1; - - check_phase(menv2, NULL, phase); - scheme_hash_set(MODCHAIN_TABLE(to_modchain), name, (Scheme_Object *)menv2); - } - } - } - } - } - - past_checkeds = SCHEME_CDR(past_checkeds); - if (!SCHEME_NULLP(past_checkeds)) { - from_modchain = SCHEME_VEC_ELS(from_modchain)[2]; - if (phase > orig_phase) - to_modchain = SCHEME_VEC_ELS(to_modchain)[2]; - --phase; - } - } - - /* Notify module name resolver of attached modules: */ - { - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - config = scheme_current_config(); - - if (set_env_for_notify) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)to_env); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - resolver = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER); - while (!SCHEME_NULLP(notifies)) { - a[0] = SCHEME_CAR(notifies); - a[1] = (Scheme_Object *)from_env; - - scheme_apply(resolver, 2, a); - - notifies = SCHEME_CDR(notifies); - } - - if (set_env_for_notify) { - scheme_pop_continuation_frame(&cframe); - } - } - - return scheme_void; -} - -static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[]) -{ - return do_namespace_attach_module("namespace-attach-module", argc, argv, 0); -} - -static Scheme_Object *namespace_attach_module_decl(int argc, Scheme_Object *argv[]) -{ - return do_namespace_attach_module("namespace-attach-module-declaration", argc, argv, 1); -} - -static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *to_env, *menv2; - Scheme_Object *name, *to_modchain, *insp, *code_insp; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_inspector_type)) - scheme_wrong_contract("namespace-unprotect-module", "inspector?", 0, argc, argv); - - insp = argv[0]; - if (argc > 2) - to_env = (Scheme_Env *)argv[2]; - else - to_env = scheme_get_env(NULL); - - name = scheme_module_resolve(scheme_make_modidx(argv[1], scheme_false, scheme_false), 0); - - to_modchain = to_env->modchain; - - code_insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - if (!SAME_OBJ(name, kernel_modname) - && !SAME_OBJ(name, flfxnum_modname) - && !SAME_OBJ(name, extfl_modname) - && !SAME_OBJ(name, futures_modname) - && !SAME_OBJ(name, foreign_modname)) { - if (SAME_OBJ(name, unsafe_modname)) - menv2 = scheme_get_unsafe_env(); - else - menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name); - - if (!menv2) { - scheme_contract_error("namespace-unprotect-module", - "module not instantiated (in the target namespace)", - "name", 1, name, - NULL); - } - - if (!scheme_module_protected_wrt(menv2->guard_insp, insp) && !menv2->attached) { - code_insp = scheme_make_inspector(code_insp); - menv2->guard_insp = code_insp; - } - } - - return scheme_void; -} - -static int plain_char(int c) -{ - return (((c >= 'a') && (c <= 'z')) - || ((c >= 'A') && (c <= 'Z')) - || ((c >= '0') && (c <= '9')) - || (c == '-') - || (c == '_') - || (c == '+')); -} - -static int ok_hex(int c) -{ - return (((c >= 'a') && (c <= 'f')) - || ((c >= '0') && (c <= '9'))); -} - -static int ok_escape(int c1, int c2) -{ - c1 = (((c1 >= 'a') && (c1 <= 'f')) - ? (c1 - 'a' + 10) - : (c1 - '0')); - c2 = (((c2 >= 'a') && (c2 <= 'f')) - ? (c2 - 'a' + 10) - : (c2 - '0')); - - c1 = (c1 << 4) + c2; - - if (plain_char(c1)) - return 0; - else - return 1; -} - -static int ok_path_string(Scheme_Object *obj, int dir_ok, int just_file_ok, int file_end_ok, int for_planet) -{ - mzchar *s = SCHEME_CHAR_STR_VAL(obj); - int i = SCHEME_CHAR_STRLEN_VAL(obj), c, start_package_pos = 0, end_package_pos = 0; - int prev_was_slash = 0, saw_slash = !file_end_ok, saw_dot = 0; - - if (!i) - return 0; - if (s[0] == '/') - return 0; - if (s[i - 1] == '/') - return 0; - - if (for_planet) { - /* Must have at least two slashes, and a version spec is allowed between them */ - int j, counter = 0, colon1_pos = 0, colon2_pos = 0; - for (j = 0; j < i; j++) { - c = s[j]; - if (c == '/') { - counter++; - if (counter == 1) - start_package_pos = j + 1; - else if (counter == 2) - end_package_pos = j; - } else if (c == ':') { - if (counter == 1) { - if (colon2_pos) - return 0; - else if (colon1_pos) - colon2_pos = j; - else - colon1_pos = j; - } - } - } - - if (counter == 1) - end_package_pos = i; - - if (end_package_pos <= start_package_pos) - return 0; - - if (colon1_pos) { - /* Check that the version spec is well-formed, leaving the rest to the loop below */ - int colon1_end = (colon2_pos ? colon2_pos : end_package_pos); - - if (colon1_end == (colon1_pos + 1)) - return 0; - for (j = colon1_pos + 1; j < colon1_end; j++) { - c = s[j]; - if (!((c >= '0') && (c <= '9'))) - return 0; - } - - if (colon2_pos) { - colon2_pos++; - c = s[colon2_pos]; - if ((c == '<') || (c == '>')) { - if (s[colon2_pos+1] == '=') - colon2_pos += 2; - else - return 0; - } else if (c == '=') { - colon2_pos += 1; - } else { - if ((c >= '0') && (c <= '9')) { - /* check for range: */ - for (j = colon2_pos; j < end_package_pos; j++) { - if (s[j] == '-') { - colon2_pos = j + 1; - break; - } else if (!((c >= '0') && (c <= '9'))) - return 0; - } - } - } - if (end_package_pos == colon2_pos) - return 0; - - for (j = colon2_pos; j < end_package_pos; j++) { - c = s[j]; - if (!((c >= '0') && (c <= '9'))) - return 0; - } - } - - /* tell loop below to ignore the version part: */ - start_package_pos = colon1_pos; - } else { - /* package must have normal directory syntax */ - start_package_pos = end_package_pos = 0; - } - } - - while (i--) { - c = s[i]; - if (c == '/') { - saw_slash = 1; - if (prev_was_slash) - return 0; - prev_was_slash = 1; - } else if (c == '.') { - if (s[i+1] && (s[i+1] != '/') && (s[i+1] != '.')) { - if (saw_slash) { - /* can't have suffix on a directory */ - return 0; - } - saw_dot = 1; - } - prev_was_slash = 0; - } else { - if (plain_char(c) - || ((c == '%') - && ok_hex(s[i+1]) - && ok_hex(s[i+2]) - && ok_escape(s[i+1], s[i+2]))) { - prev_was_slash = 0; - } else if ((i < start_package_pos) || (i >= end_package_pos)) - return 0; - else { - prev_was_slash = 0; - } - } - } - - if (!just_file_ok) { - if (saw_dot && !saw_slash) { - /* can't have a file name with no directory */ - return 0; - } - } - - if (!dir_ok) { - for (i = 0; s[i]; i++) { - if (s[i] == '.') { - if (!s[i+1] || (s[i+1] == '/')) - return 0; - if (s[i+1] == '.') - if (!s[i+2] || (s[i+2] == '/')) - return 0; - while (s[i] == '.') { - i++; - } - } - } - } - - return 1; -} - -static int ok_planet_number(Scheme_Object *a) -{ - if (SCHEME_INTP(a)) { - if (SCHEME_INT_VAL(a) >= 0) - return 1; - } else if (SCHEME_BIGNUMP(a)) { - if (SCHEME_BIGPOS(a)) - return 1; - } - return 0; -} - - -static int ok_planet_string(Scheme_Object *obj) -{ - mzchar *s; - int i, c; - - if (!SCHEME_CHAR_STRINGP(obj)) - return 0; - - s = SCHEME_CHAR_STR_VAL(obj); - i = SCHEME_CHAR_STRLEN_VAL(obj); - - if (!i) - return 0; - - while (i--) { - c = s[i]; - if ((c == '%') - && ok_hex(s[i+1]) - && ok_hex(s[i+2]) - && ok_escape(s[i+1], s[i+2])) { - /* ok */ - } else if (plain_char(c) || (c == '.')) { - /* ok */ - } else - return 0; - } - - return 1; -} - -int scheme_is_module_path(Scheme_Object *obj) -{ - if (SCHEME_PAIRP(obj) - && (SAME_OBJ(SCHEME_CAR(obj), submod_symbol))) { - Scheme_Object *p, *a; - int len = 0; - p = SCHEME_CDR(obj); - if (SCHEME_PAIRP(p)) { - p = SCHEME_CDR(p); - while (SCHEME_PAIRP(p)) { - len++; - a = SCHEME_CAR(p); - if (!SCHEME_SYMBOLP(a) - && (!SCHEME_CHAR_STRINGP(a) - || (SCHEME_CHAR_STRLEN_VAL(a) != 2) - || (SCHEME_CHAR_STR_VAL(a)[0] != '.') - || (SCHEME_CHAR_STR_VAL(a)[1] != '.'))) - break; - p = SCHEME_CDR(p); - } - } else - p = scheme_false; - if (SCHEME_NULLP(p)) { - obj = SCHEME_CDR(obj); - obj = SCHEME_CAR(obj); - if (SCHEME_CHAR_STRINGP(obj) - && (((SCHEME_CHAR_STRLEN_VAL(obj) == 1) - && (SCHEME_CHAR_STR_VAL(obj)[0] == '.')) - || ((SCHEME_CHAR_STRLEN_VAL(obj) == 2) - && (SCHEME_CHAR_STR_VAL(obj)[0] == '.') - && (SCHEME_CHAR_STR_VAL(obj)[1] == '.')))) - return 1; - } - } - - if (SCHEME_PATHP(obj)) - return 1; - - if (SCHEME_CHAR_STRINGP(obj)) { - return ok_path_string(obj, 1, 1, 1, 0); - } - - if (SCHEME_SYMBOLP(obj)) { - obj = scheme_make_sized_offset_utf8_string((char *)(obj), - SCHEME_SYMSTR_OFFSET(obj), - SCHEME_SYM_LEN(obj)); - return ok_path_string(obj, 0, 0, 0, 0); - } - - if (SCHEME_PAIRP(obj)) { - if (SAME_OBJ(SCHEME_CAR(obj), quote_symbol)) { - obj = SCHEME_CDR(obj); - if (SCHEME_PAIRP(obj)) { - if (SCHEME_NULLP(SCHEME_CDR(obj))) { - obj = SCHEME_CAR(obj); - return SCHEME_SYMBOLP(obj); - } else - return 0; - } else - return 0; - } else if (SAME_OBJ(SCHEME_CAR(obj), lib_symbol)) { - obj = SCHEME_CDR(obj); - if (SCHEME_PAIRP(obj)) { - Scheme_Object *a; - int is_first = 1; - while (SCHEME_PAIRP(obj)) { - a = SCHEME_CAR(obj); - if (SCHEME_CHAR_STRINGP(a)) { - if (!ok_path_string(a, 0, is_first, is_first, 0)) - return 0; - } else - return 0; - obj = SCHEME_CDR(obj); - is_first = 0; - } - if (SCHEME_NULLP(obj)) - return 1; - else - return 0; - } else - return 0; - } else if (SAME_OBJ(SCHEME_CAR(obj), file_symbol)) { - obj = SCHEME_CDR(obj); - if (SCHEME_PAIRP(obj) && SCHEME_NULLP(SCHEME_CDR(obj))) { - int i; - mzchar *s; - obj = SCHEME_CAR(obj); - if (!SCHEME_CHAR_STRINGP(obj)) - return 0; - s = SCHEME_CHAR_STR_VAL(obj); - i = SCHEME_CHAR_STRLEN_VAL(obj); - if (!i) - return 0; - while (i--) { - if (!s[i]) - return 0; - } - return 1; - } - } else if (SAME_OBJ(SCHEME_CAR(obj), planet_symbol)) { - Scheme_Object *a, *subs; - int len, counter; - - len = scheme_proper_list_length(obj); - - if (len == 2) { - /* Symbolic or string shorthand? */ - obj = SCHEME_CDR(obj); - a = SCHEME_CAR(obj); - if (SCHEME_SYMBOLP(a)) { - obj = scheme_make_sized_offset_utf8_string((char *)(a), - SCHEME_SYMSTR_OFFSET(a), - SCHEME_SYM_LEN(a)); - return ok_path_string(obj, 0, 0, 0, 1); - } else if (SCHEME_CHAR_STRINGP(a)) { - return ok_path_string(a, 0, 0, 1, 1); - } - } - - if (len < 3) - return 0; - obj = SCHEME_CDR(obj); - a = SCHEME_CAR(obj); - if (!SCHEME_CHAR_STRINGP(a)) - return 0; - if (!ok_path_string(a, 0, 1, 1, 0)) - return 0; - obj = SCHEME_CDR(obj); - subs = SCHEME_CDR(obj); - obj = SCHEME_CAR(obj); - len = scheme_proper_list_length(obj); - if (len < 2) - return 0; - - a = SCHEME_CAR(obj); - if (!ok_planet_string(a)) - return 0; - - obj = SCHEME_CDR(obj); - a = SCHEME_CAR(obj); - if (!ok_planet_string(a)) - return 0; - - /* planet allows a major and minor version number: */ - counter = 0; - for (obj = SCHEME_CDR(obj); !SCHEME_NULLP(obj); obj = SCHEME_CDR(obj)) { - if (counter == 2) - return 0; - a = SCHEME_CAR(obj); - if (ok_planet_number(a)) { - /* ok */ - } else if ((counter == 1) && SCHEME_PAIRP(a)) { - if (scheme_proper_list_length(a) != 2) - return 0; - if (ok_planet_number(SCHEME_CAR(a))) { - if (ok_planet_number(SCHEME_CADR(a))) { - if (scheme_bin_lt_eq(SCHEME_CAR(a), SCHEME_CADR(a))) { - /* ok */ - } else - return 0; - } else - return 0; - } else if (SCHEME_SYMBOLP(SCHEME_CAR(a))) { - if (SCHEME_SYM_LEN(SCHEME_CAR(a))) { - int c; - c = SCHEME_SYM_VAL(SCHEME_CAR(a))[0]; - if ((c == '=') || (c == '+') || (c == '-')) { - if (!ok_planet_number(SCHEME_CADR(a))) - return 0; - /* else ok */ - } else - return 0; - } else - return 0; - } else - return 0; - } else - return 0; - counter++; - } - - for (; !SCHEME_NULLP(subs); subs = SCHEME_CDR(subs)) { - a = SCHEME_CAR(subs); - if (!SCHEME_CHAR_STRINGP(a)) - return 0; - if (!ok_path_string(a, 0, 0, 0, 0)) - return 0; - } - - return 1; - } - } - - return 0; -} - -static Scheme_Object *is_module_path(int argc, Scheme_Object **argv) -{ - return (scheme_is_module_path(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *require_binding_to_key(Scheme_Hash_Table *required, - Scheme_Object *binding_vec, - Scheme_Object *sym) -{ - Scheme_Object *vec, *vec2, *modname; - - vec = scheme_hash_get(required, sym); - if (vec) { - if (SCHEME_FALSEP(vec)) { - /* we've split the mapping for this symbol into binding-specific - mappings already; fall through */ - } else { - /* the symbol is mapped -- for the same binding? */ - if (same_resolved_modidx(SCHEME_VEC_ELS(binding_vec)[0], - SCHEME_VEC_ELS(vec)[1]) - && SAME_OBJ(SCHEME_VEC_ELS(binding_vec)[1], - SCHEME_VEC_ELS(vec)[2]) - && SAME_OBJ(SCHEME_VEC_ELS(binding_vec)[2], - SCHEME_VEC_ELS(vec)[8])) { - /* Yes, this symbol is mapped only for that one binding, so far */ - return sym; - } else { - /* need to re-key the existing mapping to a full binding, - map the plain symbol to #f, and fall through to generate - a full key for the new binding */ - vec2 = scheme_make_vector(4, NULL); - modname = scheme_module_resolve(SCHEME_VEC_ELS(vec)[1], 0); - SCHEME_VEC_ELS(vec2)[0] = modname; - SCHEME_VEC_ELS(vec2)[1] = SCHEME_VEC_ELS(vec)[2]; - SCHEME_VEC_ELS(vec2)[2] = SCHEME_VEC_ELS(vec)[8]; - SCHEME_VEC_ELS(vec2)[3] = sym; - - scheme_hash_set(required, vec2, vec); - scheme_hash_set(required, sym, scheme_false); - } - } - } else { - /* no binding mapped with this symbol in the key, yet, so we can - just use the symbol: */ - return sym; - } - - modname = scheme_module_resolve(SCHEME_VEC_ELS(binding_vec)[0], 0); - - vec2 = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec2)[0] = modname; - SCHEME_VEC_ELS(vec2)[1] = SCHEME_VEC_ELS(binding_vec)[1]; - SCHEME_VEC_ELS(vec2)[2] = SCHEME_VEC_ELS(binding_vec)[2]; - SCHEME_VEC_ELS(vec2)[3] = sym; - - return vec2; -} - -static int prep_required_id(Scheme_Object *vec) -{ - Scheme_Object *id = SCHEME_VEC_ELS(vec)[6]; - - if (SCHEME_SYMBOLP(id)) { - id = scheme_datum_to_syntax(id, scheme_false, SCHEME_VEC_ELS(vec)[5], 0, 0); - SCHEME_VEC_ELS(vec)[6] = id; - } - - return 1; -} - -static int do_add_simple_require_renames(Scheme_Object *rn, Scheme_Env *env, - Scheme_Hash_Table *required, Scheme_Object *orig_src, - Scheme_Module *im, Scheme_Module_Phase_Exports *pt, - Scheme_Object *idx, - Scheme_Object *src_phase_index, - int can_override, - int skip_binding_step) -{ - int i, saw_mb, numvals; - Scheme_Object **exs, **exss, **exsns, *midx, *vec, *nml, *key; - int *exets; - int with_shared = 1; - - saw_mb = 0; - - if (!pt->num_provides) - return 0; - - if (with_shared && !skip_binding_step) { - if (!pt->src_modidx && im->me->src_modidx) - pt->src_modidx = im->me->src_modidx; - scheme_extend_module_context_with_shared(rn, idx, pt, - scheme_false, /* no prefix */ - NULL, /* no excepts */ - src_phase_index, - orig_src, - NULL); - } - - exs = pt->provides; - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - exets = pt->provide_src_phases; - numvals = pt->num_var_provides; - for (i = pt->num_provides; i--; ) { - if (exss && !SCHEME_FALSEP(exss[i])) - midx = scheme_modidx_shift(exss[i], im->me->src_modidx, idx); - else - midx = idx; - if (!with_shared && !skip_binding_step) { - scheme_extend_module_context(rn, orig_src, midx, exs[i], exsns[i], idx, exs[i], - exets ? exets[i] : 0, src_phase_index, pt->phase_index); - } - if (SAME_OBJ(exs[i], module_begin_symbol)) - saw_mb = 1; - - if (required) { - /* - A `required' vector has the following slots: - 0 : list of nominal source (i.e., the modules written with `require') - 1 : the initial midx for the import - 2 : a symbolic name in the original exporting module - 3 : variable => #t; syntax => #f - 4 : the exported name as a symbol - 5 : a syntax object for error reporting - 6 : identifier as imported, where table key is corresponding binding; - a symbol value should be converted to an id using slot 5; see prep_required_id() - 7 : boolean, true if slot 6 is overrideable - 8 : source phase - */ - vec = scheme_make_vector(9, NULL); - nml = scheme_make_pair(idx, scheme_null); - - /* Since all initial exports have different names, we can use the - simple form of a key and be consistent with binding_to_key(): */ - key = exs[i]; - - SCHEME_VEC_ELS(vec)[0] = nml; - SCHEME_VEC_ELS(vec)[1] = midx; - SCHEME_VEC_ELS(vec)[2] = exsns[i]; - SCHEME_VEC_ELS(vec)[3] = ((i < numvals) ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[4] = exs[i]; - SCHEME_VEC_ELS(vec)[5] = orig_src; - SCHEME_VEC_ELS(vec)[6] = exs[i]; /* => id by cmbining with orig_src */ - SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_make_integer(0); - - scheme_hash_set(required, key, vec); - } - } - - return saw_mb; -} - -static Scheme_Object *get_table(Scheme_Hash_Table *tables, Scheme_Object *phase) -{ - Scheme_Object *vec; - Scheme_Hash_Table *required; - - vec = scheme_hash_get(tables, phase); - if (!vec) { - required = scheme_make_hash_table_equal(); - vec = scheme_make_vector(3, scheme_false); - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required; - scheme_hash_set(tables, phase, vec); - } - - return vec; -} - -static Scheme_Hash_Table *get_required_from_tables(Scheme_Hash_Table *tables, Scheme_Object *phase) -{ - Scheme_Object *vec; - - if (!tables) - return NULL; - - vec = get_table(tables, phase); - - return (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1]; -} - -static int add_simple_require_renames(Scheme_Object *orig_src, - Scheme_Object *rn_set, Scheme_Env *env, - Scheme_Hash_Table *tables, - Scheme_Module *im, Scheme_Object *idx, - Scheme_Object *import_shift /* = src_phase_index */, - Scheme_Object *only_export_phase, - int can_override, - int skip_binding_step) -{ - int saw_mb; - Scheme_Object *phase; - - if (im->me->rt - && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(0)))) - saw_mb = do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, import_shift), env, - get_required_from_tables(tables, import_shift), - orig_src, im, im->me->rt, idx, - import_shift, - can_override, - skip_binding_step); - else - saw_mb = 0; - - if (im->me->et - && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(1)))) { - if (SCHEME_FALSEP(import_shift)) - phase = scheme_false; - else - phase = scheme_bin_plus(scheme_make_integer(1), import_shift); - do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, phase), env, - get_required_from_tables(tables, phase), - orig_src, im, im->me->et, idx, - import_shift, - can_override, - skip_binding_step); - } - - if (im->me->dt - && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_false))) { - do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, scheme_false), env, - get_required_from_tables(tables, scheme_false), - orig_src, im, im->me->dt, idx, - import_shift, - can_override, - skip_binding_step); - } - - if (im->me->other_phases) { - Scheme_Object *val, *key; - int i; - for (i = 0; i < im->me->other_phases->size; i++) { - val = im->me->other_phases->vals[i]; - if (val) { - key = im->me->other_phases->keys[i]; - if (!only_export_phase || scheme_eqv(only_export_phase, key)) { - if (SCHEME_FALSEP(import_shift)) - phase = scheme_false; - else - phase = scheme_bin_plus(key, import_shift); - do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, phase), env, - get_required_from_tables(tables, phase), - orig_src, im, (Scheme_Module_Phase_Exports *)val, idx, - import_shift, - can_override, - skip_binding_step); - } - } - } - } - - return saw_mb; -} - -static void add_reconstructed_binding(Scheme_Object *name, Scheme_Object *one_rn, Scheme_Object *self_modidx, - Scheme_Env *env, int phase) -{ - Scheme_Hash_Table *binding_names; - - scheme_extend_module_context(one_rn, NULL, self_modidx, name, name, self_modidx, name, phase, - scheme_make_integer(phase), NULL); - - binding_names = (Scheme_Hash_Table *)env->binding_names; - if (!binding_names) { - binding_names = scheme_make_hash_table(SCHEME_hash_ptr); - env->binding_names = (Scheme_Object *)binding_names; - } - scheme_hash_set(binding_names, name, - scheme_stx_add_module_context(scheme_datum_to_syntax(name, scheme_false, scheme_false, 0, 0), - one_rn)); -} - -void scheme_prep_namespace_rename(Scheme_Env *menv) -{ - while (menv->mod_phase > 0) { - scheme_prepare_template_env(menv); - menv = menv->template_env; - } - - scheme_prepare_exp_env(menv); - start_module(menv->module, menv, 0, NULL, -1, 1, menv->phase, scheme_null, 1); - - if (!menv->rename_set_ready) { - if (menv->module->rn_stx) { - Scheme_Object *rns; - Scheme_Module *m = menv->module; - - scheme_prepare_env_stx_context(menv); - - if (SAME_OBJ(scheme_true, m->rn_stx)) { - /* Reconstruct renames based on defns and requires. This case is - used only when it's easy to reconstruct: no rename on import, - no prefixes or exclusions on import, no definitions within the - module that are inaccessible due to scope differences, etc. */ - int i, j; - Scheme_Module *im; - Scheme_Object *l, *idx, *one_rn, *shift, *name; - - rns = menv->stx_context; - one_rn = scheme_module_context_at_phase(rns, scheme_make_integer(0)); - - /* Required: */ - for (i = -4; i < (menv->other_require_names ? menv->other_require_names->size : 0); i++) { - switch (i) { - case -4: - l = menv->require_names; - shift = scheme_make_integer(0); - break; - case -3: - l = menv->et_require_names; - shift = scheme_make_integer(1); - break; - case -2: - l = menv->tt_require_names; - shift = scheme_make_integer(-1); - break; - case -1: - l = menv->dt_require_names; - shift = scheme_false; - break; - default: - l = menv->other_require_names->vals[i]; - shift = menv->other_require_names->keys[i]; - break; - } - - if (l) { - /* Do initial import first to get shadowing right: */ - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - idx = SCHEME_CAR(l); - name = scheme_module_resolve(idx, 0); - - im = get_special_module(name); - if (!im) - im = registry_get_loaded(menv, name); - - add_simple_require_renames(NULL, rns, menv, NULL, im, idx, shift, - NULL, 0, 0); - } - } - } - - /* Local, provided: */ - for (i = 0; i < m->me->rt->num_provides; i++) { - if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) { - name = m->me->rt->provide_src_names[i]; - add_reconstructed_binding(name, one_rn, m->self_modidx, menv, 0); - } - } - for (j = 0; j < m->num_phases; j++) { - Scheme_Module_Export_Info *exp_info = m->exp_infos[j]; - Scheme_Env *penv; - one_rn = scheme_module_context_at_phase(rns, scheme_make_integer(j)); - penv = scheme_find_env_at_phase(menv, scheme_make_integer(j)); - for (i = 0; i < exp_info->num_indirect_provides; i++) { - name = exp_info->indirect_provides[i]; - add_reconstructed_binding(name, one_rn, m->self_modidx, penv, j); - } - for (i = 0; i < exp_info->num_indirect_syntax_provides; i++) { - name = exp_info->indirect_syntax_provides[i]; - add_reconstructed_binding(name, one_rn, m->self_modidx, penv, j); - } - } - - rns = scheme_module_context_to_stx(rns, NULL); - - m->rn_stx = rns; - } else if (SCHEME_PAIRP(m->rn_stx)) { - /* Delayed shift: */ - Scheme_Object *rn_stx, *midx; - - rn_stx = SCHEME_CAR(m->rn_stx); - midx = SCHEME_CDR(m->rn_stx); - - rn_stx = scheme_stx_force_delayed(rn_stx); - - rn_stx = scheme_stx_shift(rn_stx, scheme_make_integer(0), midx, m->self_modidx, - NULL, m->prefix->src_insp_desc, menv->access_insp); - - m->rn_stx = rn_stx; - } else { - Scheme_Object *rn_stx; - rn_stx = scheme_stx_force_delayed(m->rn_stx); - m->rn_stx = rn_stx; - } - - rns = m->rn_stx; - if (menv->phase) - rns = scheme_stx_shift(rns, scheme_make_integer(menv->phase), NULL, NULL, NULL, NULL, NULL); - - rns = scheme_stx_to_module_context(rns); - menv->stx_context = rns; - - menv->rename_set_ready = 1; - } else { - /* had #:empty-namespace declaration */ - scheme_prepare_env_stx_context(menv); - } - } -} - -Scheme_Object *scheme_module_to_namespace(Scheme_Object *name, Scheme_Env *env) -{ - Scheme_Env *menv; - Scheme_Object *modchain; - - if (SCHEME_MODNAMEP(name)) { - ; - } else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_index_type)) { - name = scheme_module_resolve(name, 1); - } else { - /* name is path or module-path */ - name = scheme_module_resolve(scheme_make_modidx(name, scheme_false, scheme_false), 1); - } - - menv = get_special_modenv(name); - if (!menv) { - modchain = env->modchain; - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(modchain), name); - if (!menv) { - if (registry_get_loaded(env, name)) - scheme_contract_error("module->namespace", - "module not instantiated in the current namespace", - "name", 1, name, - NULL); - else - scheme_contract_error("module->namespace", - "unknown module in the current namespace", - "name", 1, name, - NULL); - } - } - - { - Scheme_Object *insp; - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - if (scheme_module_protected_wrt(menv->guard_insp, insp) || menv->attached) { - scheme_contract_error("module->namespace", - "current code inspector cannot access namespace of module", - "module name", 1, name, - NULL); - } - } - - scheme_prep_namespace_rename(menv); - - menv->interactive_bindings = 1; - - return (Scheme_Object *)menv; -} - -static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - if (!SCHEME_PATHP(argv[0]) - && !SCHEME_MODNAMEP(argv[0]) - && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type) - && !scheme_is_module_path(argv[0])) - scheme_wrong_contract("module->namespace", "(or/c module-path? module-path-index? resolved-module-path?)", 0, argc, argv); - - return scheme_module_to_namespace(argv[0], env); -} - -static Scheme_Module *module_to_(const char *who, int argc, Scheme_Object *argv[], int unknown_ok) -{ - Scheme_Env *env; - Scheme_Object *name; - Scheme_Module *m; - - env = scheme_get_env(NULL); - - name = argv[0]; - - if (!SCHEME_PATHP(name) - && !SCHEME_MODNAMEP(name) - && !SAME_TYPE(SCHEME_TYPE(name), scheme_module_index_type) - && !scheme_is_module_path(name)) - scheme_wrong_contract(who, "(or/c module-path? module-path-index? resolved-module-path?)", 0, argc, argv); - - if (!SCHEME_MODNAMEP(name)) { - if (!SAME_TYPE(SCHEME_TYPE(name), scheme_module_index_type)) - name = scheme_make_modidx(name, scheme_false, scheme_false); - name = scheme_module_resolve(name, (argc > 1) ? SCHEME_TRUEP(argv[1]) : 0); - } - - m = get_special_module(name); - if (!m) { - env = scheme_get_env(NULL); - m = registry_get_loaded(env, name); - } - - if (!m && !unknown_ok) - scheme_contract_error(who, - "unknown module in the current namespace", - "name", 1, name, - NULL); - - return m; -} - -static Scheme_Object *module_to_lang_info(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->language-info", argc, argv, 0); - - return (m->lang_info ? m->lang_info : scheme_false); -} - -static Scheme_Object *module_is_declared(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module-declared?", argc, argv, 1); - - return (m ? scheme_true : scheme_false); -} - -int scheme_module_is_declared(Scheme_Object *name, int try_load) -{ - Scheme_Object *a[2]; - Scheme_Module *m; - - a[0] = name; - a[1] = (try_load ? scheme_true : scheme_false); - m = module_to_("module-declared?", 2, a, 1); - - return (m ? 1 : 0); -} - -static Scheme_Object *module_is_predefined(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module-predefined?", argc, argv, 1); - - return ((m && m->predefined) ? scheme_true : scheme_false); -} - -int scheme_is_predefined_module_p(Scheme_Object *name) -{ - Scheme_Object *a[1]; - Scheme_Module *m; - - a[0] = name; - m = module_to_("module-predefined?", 1, a, 1); - - return m && m->predefined; -} - -static Scheme_Object *extract_compiled_imports(Scheme_Module *m) -{ - Scheme_Object *l; - int i; - - l = scheme_null; - if (!SCHEME_NULLP(m->requires)) - l = scheme_make_pair(scheme_make_pair(scheme_make_integer(0), - m->requires), - l); - if (!SCHEME_NULLP(m->et_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_make_integer(1), - m->et_requires), - l); - if (!SCHEME_NULLP(m->tt_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_make_integer(-1), - m->tt_requires), - l); - if (!SCHEME_NULLP(m->dt_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_false, - m->dt_requires), - l); - - if (m->other_requires) { - for (i = 0; i < m->other_requires->size; i++) { - if (m->other_requires->vals[i]) { - l = scheme_make_pair(scheme_make_pair(m->other_requires->keys[i], - m->other_requires->vals[i]), - l); - } - } - } - - return l; -} - -static Scheme_Object *make_provide_desc(Scheme_Module_Phase_Exports *pt, int i) -{ - return scheme_make_pair(pt->provides[i], - scheme_make_pair((pt->provide_nominal_srcs - ? pt->provide_nominal_srcs[i] - : scheme_null), - scheme_null)); -} - -static Scheme_Object *extract_compiled_exports(Scheme_Module *m) -{ - Scheme_Object *a[2]; - Scheme_Object *ml, *vl, *val_l, *mac_l; - Scheme_Module_Phase_Exports *pt; - int i, n, k; - - val_l = scheme_null; - mac_l = scheme_null; - - for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) { - switch(k) { - case -3: - pt = m->me->rt; - break; - case -2: - pt = m->me->et; - break; - case -1: - pt = m->me->dt; - break; - default: - pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k]; - break; - } - - if (pt) { - ml = scheme_null; - vl = scheme_null; - n = pt->num_var_provides; - for (i = pt->num_provides - 1; i >= n; --i) { - ml = scheme_make_pair(make_provide_desc(pt, i), ml); - } - for (; i >= 0; --i) { - vl = scheme_make_pair(make_provide_desc(pt, i), vl); - } - - if (!SCHEME_NULLP(vl)) - val_l = scheme_make_pair(scheme_make_pair(pt->phase_index, vl), - val_l); - - if (!SCHEME_NULLP(ml)) - mac_l = scheme_make_pair(scheme_make_pair(pt->phase_index, ml), - mac_l); - } - } - - a[0] = val_l; - a[1] = mac_l; - return scheme_values(2, a); -} - -static Scheme_Object *extract_compiled_indirect_exports(Scheme_Module *m) -{ - int k, i; - Scheme_Object *l, *a; - Scheme_Module_Export_Info *ei; - - l = scheme_null; - - for (k = m->num_phases; k--; ) { - ei = m->exp_infos[k]; - if (ei && ei->num_indirect_provides) { - a = scheme_null; - for (i = ei->num_indirect_provides; i--; ) { - a = scheme_make_pair(ei->indirect_provides[i], a); - } - a = scheme_make_pair(scheme_make_integer(k), a); - l = scheme_make_pair(a, l); - } - } - - return l; -} - -static Scheme_Object *module_to_imports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->imports", argc, argv, 0); - - return extract_compiled_imports(m); -} - -static Scheme_Object *module_to_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->exports", argc, argv, 0); - - return extract_compiled_exports(m); -} - -static Scheme_Object *module_to_indirect_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = module_to_("module->indirect_exports", argc, argv, 0); - - return extract_compiled_indirect_exports(m); -} - -static Scheme_Object *module_compiled_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - - return (m ? scheme_true : scheme_false); -} - -static Scheme_Object *wrap_module_in_top(Scheme_Object *m, Scheme_Object *t) -{ - Scheme_Compilation_Top *top; - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - memcpy(top, t, sizeof(Scheme_Compilation_Top)); - top->code = m; - - return (Scheme_Object *)top; -} - -static void reset_submodule_paths(Scheme_Module *m) -{ - Scheme_Module *m2; - Scheme_Object *stack, *l, *l2, *v, *v2, *name, *submodule_path; - int k; - - stack = scheme_make_pair((Scheme_Object *)m, scheme_null); - while (!SCHEME_NULLP(stack)) { - m = (Scheme_Module *)SCHEME_CAR(stack); - stack = SCHEME_CDR(stack); - - submodule_path = scheme_resolved_module_path_value(m->modname); - if (SCHEME_SYMBOLP(submodule_path)) - submodule_path = scheme_make_pair(submodule_path, scheme_null); - submodule_path = scheme_reverse(submodule_path); - - for (k = 0; k < 2; k++) { - l = (k ? m->post_submodules : m->pre_submodules); - if (l) { - l2 = scheme_null; - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, SCHEME_CAR(l), sizeof(Scheme_Module)); - - name = scheme_resolved_module_path_value(m2->modname); - if (SCHEME_PAIRP(name)) { - while (SCHEME_PAIRP(name) && SCHEME_PAIRP(SCHEME_CDR(name))) { - name = SCHEME_CDR(name); - } - name = SCHEME_CAR(name); - } - v = scheme_reverse(scheme_make_pair(name, submodule_path)); - v2 = scheme_intern_resolved_module_path(v); - m2->modname = v2; - m2->submodule_path = SCHEME_CDR(v); - - l2 = scheme_make_pair((Scheme_Object *)m2, l2); - stack = scheme_make_pair((Scheme_Object *)m2, stack); - } - l2 = scheme_reverse(l2); - if (k) - m->post_submodules = l2; - else - m->pre_submodules = l2; - } - } - } -} - -static Scheme_Object *module_compiled_name(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m, *m2; - Scheme_Object *v, *p; - - m = scheme_extract_compiled_module(argv[0]); - - if (m) { - if (argc > 1) { - v = argv[1]; - if (!SCHEME_SYMBOLP(v)) { - if (SCHEME_PAIRP(v)) { - while (SCHEME_PAIRP(v)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) - break; - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) - v = NULL; - } else - v = NULL; - } - if (!v) - scheme_wrong_contract("module-compiled-name", "(or/c symbol? (listof symbol?))", 1, argc, argv); - if (SCHEME_PAIRP(v)) { - p = SCHEME_CDR(v); - if (SCHEME_NULLP(p)) - v = SCHEME_CAR(v); - } else - p = scheme_null; - v = scheme_intern_resolved_module_path(v); - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, m, sizeof(Scheme_Module)); - m2->modname = v; - m2->submodule_path = p; - reset_submodule_paths(m2); - return wrap_module_in_top((Scheme_Object *)m2, argv[0]); - } else - return scheme_resolved_module_path_value(m->modname); - } - - scheme_wrong_contract("module-compiled-name", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - - if (m) - return extract_compiled_imports(m); - - scheme_wrong_contract("module-compiled-imports", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - m = scheme_extract_compiled_module(argv[0]); - - if (m) - return extract_compiled_exports(m); - - scheme_wrong_contract("module-compiled-exports", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_indirect_exports(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - m = scheme_extract_compiled_module(argv[0]); - - if (m) - return extract_compiled_indirect_exports(m); - - scheme_wrong_contract("module-compiled-indirect-exports", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_lang_info(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - - if (m) { - return (m->lang_info ? m->lang_info : scheme_false); - } - - scheme_wrong_contract("module-compiled-language-info", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_submodules(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m, *m2; - Scheme_Object *l, *l2; - int pre; - - m = scheme_extract_compiled_module(argv[0]); - pre = SCHEME_TRUEP(argv[1]); - - if (m) { - if (argc > 2) { - l2 = scheme_null; - for (l = argv[2]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - m2 = scheme_extract_compiled_module(SCHEME_CAR(l)); - if (!m2) break; - l2 = scheme_make_pair((Scheme_Object *)m2, l2); - } - if (SCHEME_NULLP(l)) { - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, m, sizeof(Scheme_Module)); - l2 = scheme_reverse(l2); - if (pre) - m2->pre_submodules = l2; - else - m2->post_submodules = l2; - reset_submodule_paths(m2); - return wrap_module_in_top((Scheme_Object *)m2, argv[0]); - } else { - scheme_wrong_contract("module-compiled-submodules", "(listof compiled-module-expression?)", 2, argc, argv); - } - } else { - l2 = scheme_null; - l = (pre ? m->pre_submodules : m->post_submodules); - l = l ? l : scheme_null; - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - l2 = scheme_make_pair(wrap_module_in_top(SCHEME_CAR(l), argv[0]), l2); - } - } - - return scheme_reverse(l2); - } - - scheme_wrong_contract("module-compiled-submodules", "compiled-module-expression?", 0, argc, argv); - return NULL; -} - -static Scheme_Object *module_compiled_phaseless_p(int argc, Scheme_Object *argv[]) -{ - Scheme_Module *m; - - m = scheme_extract_compiled_module(argv[0]); - if (m) { - if (m->phaseless) - return scheme_true; - } else - scheme_wrong_contract("module-compiled-cross-phase-persistent?", - "compiled-module-expression?", 0, argc, argv); - - return scheme_false; -} - -static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[]) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[]) -{ - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-resolve", "module-path-index?", 0, argc, argv); - - return scheme_module_resolve(argv[0], 0); -} - -static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[]) -{ - Scheme_Modidx *modidx; - Scheme_Object *a[2]; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-split", "module-path-index?", 0, argc, argv); - - modidx = (Scheme_Modidx *)argv[0]; - a[0] = modidx->path; - a[1] = modidx->base; - - return scheme_values(2, a); -} - -static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]) -{ - if (!scheme_is_module_path(argv[0]) - && !SCHEME_FALSEP(argv[0])) - scheme_wrong_contract("module-path-index-join", "(or/c module-path? #f)", 0, argc, argv); - - if (argv[1]) { /* mzc will generate NULL sometimes; see scheme_declare_module(), below */ - if (SCHEME_TRUEP(argv[1]) - && !SCHEME_MODNAMEP(argv[1]) - && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-join", "(or/c module-path-index? resolved-module-path? #f)", 1, argc, argv); - - if (SCHEME_FALSEP(argv[0]) && !SCHEME_FALSEP(argv[1])) - scheme_contract_error("module-path-index-join", - "first argument cannot be #f when second argument is not #f", - "second argument", 1, argv[1], - NULL); - } - - if (argc > 2) { - Scheme_Object *l = argv[2]; - if (SCHEME_TRUEP(l)) { - if (SCHEME_PAIRP(l)) { - while (SCHEME_PAIRP(l)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(l))) - break; - l = SCHEME_CDR(l); - } - } else - l = scheme_false; - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("module-path-index-join", "(non-empty-listof symbol?)", 2, argc, argv); - if (SCHEME_TRUEP(argv[0]) || SCHEME_TRUEP(argv[1])) - scheme_contract_error("module-path-index-join", - "third argument must be #f when first or second argument is non-#f", - "first argument", 1, argv[0], - "second argument", 1, argv[1], - "third argument", 1, argv[2], - NULL); - return scheme_get_submodule_empty_self_modidx(argv[2], 0); - } - } - - return scheme_make_modidx(argv[0], argv[1], scheme_false); -} - -static Scheme_Object *module_path_index_submodule(int argc, Scheme_Object *argv[]) -{ - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-path-index-submodule", "module-path-index?", 0, argc, argv); - - return scheme_modidx_submodule(argv[0]); -} - -Scheme_Object *scheme_modidx_submodule(Scheme_Object *_modidx) -{ - Scheme_Modidx *modidx; - Scheme_Object *a; - - modidx = (Scheme_Modidx *)_modidx; - a = modidx->resolved; - if (SCHEME_TRUEP(modidx->path) - || SCHEME_TRUEP(modidx->base) - || SCHEME_FALSEP(a)) - return scheme_false; - - a = scheme_resolved_module_path_value(a); - if (!SCHEME_PAIRP(a)) - return scheme_false; - - return SCHEME_CDR(a); -} - -void scheme_init_module_path_table() -{ - REGISTER_SO(modpath_table); -#if PLACE_LOCAL_MODPATH_TABLE - modpath_table = scheme_make_nonlock_equal_bucket_table(); -#else - modpath_table = scheme_make_weak_equal_table(); -#endif -} - -static Scheme_Object *make_resolved_module_path_obj(Scheme_Object *o) -{ - Scheme_Object *rmp; - - rmp = scheme_alloc_small_object(); - rmp->type = scheme_resolved_module_path_type; - SCHEME_PTR_VAL(rmp) = o; - - return rmp; -} - -Scheme_Object *scheme_resolved_module_path_value(Scheme_Object *rmp) -{ - return SCHEME_RMP_VAL(rmp); -} - -int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object *o) { - Scheme_Object *rmp_val = SCHEME_RMP_VAL(rmp); - if (SAME_OBJ(rmp_val, o)) - return 1; - else if (SCHEME_BYTE_STRINGP(rmp_val) && SCHEME_SYMBOLP(o)) { - return !strncmp(SCHEME_BYTE_STR_VAL(rmp_val), - SCHEME_SYM_VAL(o), - mz_MIN(SCHEME_BYTE_STRLEN_VAL(rmp_val), SCHEME_SYM_LEN(o))); - } else { - scheme_arg_mismatch("scheme_resolved_module_path_value_matches", - "internal error: unknown type of resolved_module_path_value", - rmp_val); - return 0; - } -} - -Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o) -{ - Scheme_Bucket_Table *create_table; - Scheme_Object *rmp; - Scheme_Bucket *b; - - rmp = make_resolved_module_path_obj(o); -#if PLACE_LOCAL_MODPATH_TABLE - if (place_local_modpath_table) { - scheme_start_atomic(); - b = scheme_bucket_or_null_from_table(place_local_modpath_table, (const char *)rmp, 0); - scheme_end_atomic_no_swap(); - if (b) { - return (Scheme_Object *)HT_EXTRACT_WEAK(b->key); - } - } -#endif - - scheme_start_atomic(); - b = scheme_bucket_or_null_from_table(modpath_table, (const char *)rmp, 0); - scheme_end_atomic_no_swap(); - - if (b) { -#if PLACE_LOCAL_MODPATH_TABLE - return (Scheme_Object *)b->key; -#else - return (Scheme_Object *)HT_EXTRACT_WEAK(b->key); -#endif - } - -#if PLACE_LOCAL_MODPATH_TABLE - create_table = place_local_modpath_table ? place_local_modpath_table : modpath_table; -#else - create_table = modpath_table; -#endif - - scheme_start_atomic(); - b = scheme_bucket_from_table(create_table, (const char *)rmp); - scheme_end_atomic_no_swap(); - - if (!b->val) - b->val = scheme_true; - -#if PLACE_LOCAL_MODPATH_TABLE - if (!place_local_modpath_table) - return (Scheme_Object *)b->key; -#endif - return(Scheme_Object *)HT_EXTRACT_WEAK(b->key); -} - -static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[]) -{ - return (SCHEME_MODNAMEP(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *make_resolved_module_path(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *p; - - p = argv[0]; - if (SCHEME_PAIRP(p)) { - if (scheme_is_list(p)) { - p = SCHEME_CDR(p); - if (SCHEME_PAIRP(p)) { - while (SCHEME_PAIRP(p)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) - break; - p = SCHEME_CDR(p); - } - } else - p = scheme_false; - if (SCHEME_NULLP(p)) - p = SCHEME_CAR(argv[0]); - else - p = scheme_false; - } else - p = scheme_false; - } - - if (!SCHEME_SYMBOLP(p) - && (!SCHEME_PATHP(p) - || !scheme_is_complete_path(SCHEME_PATH_VAL(p), - SCHEME_PATH_LEN(p), - SCHEME_PLATFORM_PATH_KIND))) - scheme_wrong_contract("make-resolved-module-path", - "(or/c symbol?" - " (and/c path? complete-path?)" - " (cons/c (or/c symbol? (and/c path? complete-path?)) (non-empty-listof symbol?))" - ")", - 0, argc, argv); - - return scheme_intern_resolved_module_path(argv[0]); -} - -static Scheme_Object *resolved_module_path_name(int argc, Scheme_Object *argv[]) -{ - if (!SCHEME_MODNAMEP(argv[0])) - scheme_wrong_contract("resolved-module-path-name", "resolved-module-path?", 0, argc, argv); - - return scheme_resolved_module_path_value(argv[0]); -} - - -static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv) -{ - Scheme_Env *env; - Scheme_Object *modname, *name; - Scheme_Module *m; - int i, count; - - if (!SCHEME_MODNAMEP(argv[0]) - && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) - scheme_wrong_contract("module-provide-protected?", "(or/c resolved-module-path? module-path-index?)", 0, argc, argv); - if (!SCHEME_SYMBOLP(argv[1])) - scheme_wrong_contract("module-provide-protected?", "symbol?", 1, argc, argv); - - modname = scheme_module_resolve(argv[0], 1); - name = argv[1]; - - env = scheme_get_env(NULL); - m = get_special_module(modname); - if (!m) - m = registry_get_loaded(env, modname); - if (!m) { - scheme_contract_error("module-provide-protected?", - "unknown module (in the source namespace)", - "name", 1, modname, - NULL); - return NULL; - } - - count = m->me->rt->num_provides; - for (i = 0; i < count; i++) { - if (SAME_OBJ(name, m->me->rt->provides[i])) { - if (m->exp_infos[0]->provide_protects && m->exp_infos[0]->provide_protects[i]) - return scheme_true; - else - return scheme_false; - } - } - - return scheme_true; -} - -/**********************************************************************/ -/* basic module operations */ -/**********************************************************************/ - -Scheme_Object *scheme_make_modidx(Scheme_Object *path, - Scheme_Object *base_modidx, - Scheme_Object *resolved) -{ - Scheme_Modidx *modidx; - Scheme_Object *subpath; - - if (SCHEME_MODNAMEP(path)) - return path; - - if (SCHEME_PAIRP(path) - && SAME_OBJ(SCHEME_CAR(path), quote_symbol) - && SCHEME_PAIRP(SCHEME_CDR(path)) - && SAME_OBJ(SCHEME_CADR(path), kernel_symbol) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(path))) - && kernel_modidx) - return kernel_modidx; - - modidx = MALLOC_ONE_TAGGED(Scheme_Modidx); - modidx->so.type = scheme_module_index_type; - modidx->path = path; - - /* base is needed only for relative-path strings, - `file' forms, path literals, and `(submod ...)' forms: */ - if (SCHEME_PAIRP(path) - && SAME_OBJ(submod_symbol, SCHEME_CAR(path))) - subpath = SCHEME_CAR(SCHEME_CDR(path)); - else - subpath = path; - if (SCHEME_CHAR_STRINGP(subpath) - || (SCHEME_PAIRP(subpath) - && SAME_OBJ(file_symbol, SCHEME_CAR(subpath))) - || SCHEME_PATHP(subpath)) - modidx->base = base_modidx; - else - modidx->base = scheme_false; - - modidx->resolved = resolved; - - return (Scheme_Object *)modidx; -} - -static int same_modidx(Scheme_Object *a, Scheme_Object *b) -{ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) - a = ((Scheme_Modidx *)a)->path; - if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) - b = ((Scheme_Modidx *)b)->path; - - return scheme_equal(a, b); -} - -static int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b) -{ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) - a = scheme_module_resolve(a, 1); - if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) - b = scheme_module_resolve(b, 1); - - return scheme_equal(a, b); -} - -Scheme_Object *scheme_resolved_module_path_to_modidx(Scheme_Object *rmp) -{ - Scheme_Object *path; - - path = SCHEME_PTR_VAL(rmp); - if (!SCHEME_PATHP(path)) { - if (SCHEME_SYMBOLP(path)) - path = scheme_make_pair(quote_symbol, scheme_make_pair(path, scheme_null)); - else { - if (SCHEME_SYMBOLP(SCHEME_CAR(path))) - path = scheme_make_pair(scheme_make_pair(quote_symbol, scheme_make_pair(SCHEME_CAR(path), scheme_null)), - scheme_null); - path = scheme_make_pair(submod_symbol, path); - } - } - - return scheme_make_modidx(path, scheme_false, rmp); -} - -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache) -{ - Scheme_Bucket *b; - Scheme_Object *modidx; - - if (SCHEME_NULLP(submodule_path)) { - if (can_cache) - return empty_self_modidx; - return scheme_make_modidx(scheme_false, scheme_false, empty_self_modname); - } - - if (!submodule_empty_modidx_table) { - REGISTER_SO(submodule_empty_modidx_table); - submodule_empty_modidx_table = scheme_make_weak_equal_table(); - } - - if (can_cache) { - scheme_start_atomic(); - b = scheme_bucket_from_table(submodule_empty_modidx_table, (const char *)submodule_path); - if (b->val) - modidx = scheme_ephemeron_value(b->val); - else - modidx = NULL; - } else { - b = NULL; - modidx = NULL; - } - - if (!modidx) { - modidx = make_resolved_module_path_obj(scheme_make_pair(scheme_resolved_module_path_value(empty_self_modname), - submodule_path)); - modidx = scheme_make_modidx(scheme_false, scheme_false, modidx); - if (b) { - modidx = scheme_make_ephemeron(submodule_path, modidx); - b->val = modidx; - modidx = scheme_ephemeron_value(modidx); - } - } - - if (can_cache) - scheme_end_atomic_no_swap(); - - return modidx; -} - -static Scheme_Object *_module_resolve_k(void); - -static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx, Scheme_Env *env, int load_it) -{ - if (SCHEME_MODNAMEP(modidx) || SCHEME_FALSEP(modidx)) - return modidx; - - if (SAME_OBJ(modidx, empty_self_modidx)) - return empty_self_modname; - - if (SCHEME_FALSEP(((Scheme_Modidx *)modidx)->resolved)) { - /* Need to resolve access path to a module name: */ - Scheme_Object *a[4]; - Scheme_Object *name, *base; - - base = ((Scheme_Modidx *)modidx)->base; - if (!SCHEME_FALSEP(base)) { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)base; - p->ku.k.p2 = (void *)env; - p->ku.k.i1 = load_it; - base = scheme_handle_stack_overflow(_module_resolve_k); - } else { - base = _module_resolve(base, NULL, env, load_it); - } - } - - if (SCHEME_SYMBOLP(base)) - base = scheme_false; - - if (stx && !SCHEME_FALSEP(stx) && !SCHEME_STXP(stx)) - stx = NULL; - - a[0] = ((Scheme_Modidx *)modidx)->path; - a[1] = base; - a[2] = (stx ? stx : scheme_false); - a[3] = (load_it ? scheme_true : scheme_false); - - if (SCHEME_FALSEP(a[0])) { - scheme_contract_error("module-path-index-resolve", - "\"self\" index has no resolution", - "module path index", 1, modidx, - NULL); - } - - - { - Scheme_Cont_Frame_Data cframe; - - if (env) { - Scheme_Config *config; - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a); - - if (env) { - scheme_pop_continuation_frame(&cframe); - } - } - - if (!SCHEME_MODNAMEP(name)) { - a[0] = name; - scheme_wrong_contract("module name resolver", "resolved-module-path?", -1, -1, a); - } - - ((Scheme_Modidx *)modidx)->resolved = name; - } - - return ((Scheme_Modidx *)modidx)->resolved; -} - -static Scheme_Object *_module_resolve_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *base = (Scheme_Object *)p->ku.k.p1; - Scheme_Env *env = (Scheme_Env *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return _module_resolve(base, NULL, env, p->ku.k.i1); -} - -Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it) -{ - return _module_resolve(modidx, NULL, NULL, load_it); -} - -Scheme_Object *module_resolve_in_namespace(Scheme_Object *modidx, Scheme_Env *env, int load_it) -{ - return _module_resolve(modidx, NULL, env, load_it); -} - -static Scheme_Object *clone_modidx(Scheme_Object *modidx, Scheme_Object *src_modidx) -{ - Scheme_Object *base; - - if (SAME_OBJ(modidx, src_modidx)) - return modidx; - - if (!SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type)) - return modidx; - - /* Need to shift relative part? */ - base = ((Scheme_Modidx *)modidx)->base; - if (!SCHEME_FALSEP(base)) { - /* FIXME: depth */ - base = clone_modidx(base, src_modidx); - } - - return scheme_make_modidx(((Scheme_Modidx *)modidx)->path, - base, - scheme_false); -} - - -Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, - Scheme_Object *shift_from_modidx, - Scheme_Object *shift_to_modidx) -{ - Scheme_Object *base; - - if (!shift_to_modidx) - return modidx; - - if (SAME_OBJ(modidx, shift_from_modidx)) - return shift_to_modidx; - - if (!SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type)) - return modidx; - - /* Need to shift relative part? */ - base = ((Scheme_Modidx *)modidx)->base; - if (!SCHEME_FALSEP(base)) { - /* FIXME: depth */ - Scheme_Object *sbase; - sbase = scheme_modidx_shift(base, shift_from_modidx, shift_to_modidx); - - if (!SAME_OBJ(base, sbase)) { - /* There was a shift in the relative part. */ - Scheme_Modidx *sbm; - int i, c; - Scheme_Object *smodidx, *cvec; - - /* Shift cached? sbase as a modname is rare, but we need at least a little - caching to make other things (e.g., .zo output) compact, so we use - a small global cache in that case. */ - - if (SCHEME_MODNAMEP(sbase)) { - sbm = NULL; - cvec = global_shift_cache; - } else if (SAME_OBJ(sbase, empty_self_modidx)) { - sbm = (Scheme_Modidx *)sbase; - cvec = empty_self_shift_cache; - } else { - sbm = (Scheme_Modidx *)sbase; - cvec = sbm->shift_cache; - } - - /* attempt lookup in cache */ - /* ASSERT(SCHEME_VECTORP(cvec)); */ - c = (cvec ? SCHEME_VEC_SIZE(cvec) : 0); - for (i = 0; i < c; i += 2) { - if (SHIFT_CACHE_NULLP(SCHEME_VEC_ELS(cvec)[i])) - break; - if (SAME_OBJ(modidx, SCHEME_VEC_ELS(cvec)[i])) - return SCHEME_VEC_ELS(cvec)[i + 1]; - } - - /* lookup failed, add entry to cache */ - smodidx = scheme_make_modidx(((Scheme_Modidx *)modidx)->path, - sbase, - scheme_false); - - /* make room in cache */ - if (!sbm) { - if (!global_shift_cache) - global_shift_cache = scheme_make_vector(GLOBAL_SHIFT_CACHE_SIZE, SHIFT_CACHE_NULL); - else { - for (i = (GLOBAL_SHIFT_CACHE_SIZE - 2); i--; ) { - SCHEME_VEC_ELS(global_shift_cache)[i+2] = SCHEME_VEC_ELS(global_shift_cache)[i]; - } - } - cvec = global_shift_cache; - i = 0; - } else { - /* May have GCed: */ - if (cvec && !sbm->shift_cache - && !SAME_OBJ((Scheme_Object *)sbm, empty_self_modidx)) - sbm->shift_cache = cvec; - - if (i >= c) { - /* Grow cache vector */ - Scheme_Object *naya; - int j; - - naya = scheme_make_vector(c + 10, SHIFT_CACHE_NULL); - for (j = 0; j < c; j++) { - SCHEME_VEC_ELS(naya)[j] = SCHEME_VEC_ELS(cvec)[j]; - } - if (!SAME_OBJ((Scheme_Object *)sbm, empty_self_modidx) && !sbm->shift_cache) { - sbm->cache_next = modidx_caching_chain; - modidx_caching_chain = sbm; - } - cvec = naya; - if (!SAME_OBJ((Scheme_Object *)sbm, empty_self_modidx)) { - sbm->shift_cache = cvec; - } else { - empty_self_shift_cache = cvec; - } - } - } - - /* set entry in cache */ - SCHEME_VEC_ELS(cvec)[i] = modidx; - SCHEME_VEC_ELS(cvec)[i+1] = smodidx; - - return smodidx; - } - } - - return modidx; -} - -void scheme_clear_modidx_cache(void) -{ - Scheme_Modidx *sbm, *next; - - global_shift_cache = NULL; - empty_self_shift_cache = NULL; - - for (sbm = modidx_caching_chain; sbm; sbm = next) { - sbm->shift_cache = NULL; - next = sbm->cache_next; - sbm->cache_next = NULL; - } - modidx_caching_chain = NULL; -} - -static Scheme_Module *module_load(Scheme_Object *name, Scheme_Env *env, const char *who) -{ - Scheme_Module *m; - - m = get_special_module(name); - if (!m) { - m = registry_get_loaded(env, name); - - if (!m) { - scheme_contract_error((who ? who : "require"), - "unknown module", - "module name", 1, name, - NULL); - return NULL; - } - } - - return m; -} - -static int is_procedure_expression(Scheme_Object *e) -{ - Scheme_Type t; - - if (SCHEME_PROCP(e)) - return 1; - - t = SCHEME_TYPE(e); - - return ((t == scheme_lambda_type) - || (t == scheme_case_lambda_sequence_type)); -} - -static void get_procedure_shape(Scheme_Object *e, Scheme_Object **_c) -{ - Scheme_Object *p, *v; - - p = scheme_get_or_check_procedure_shape(e, NULL); - - v = scheme_alloc_small_object(); - v->type = scheme_proc_shape_type; - SCHEME_PTR_VAL(v) = p; - - *_c = v; -} - -static void setup_accessible_table(Scheme_Module *m) -{ - if (!m->exp_infos[0]->accessible) { - Scheme_Module_Phase_Exports *pt; - int j; - - for (j = 0; j < m->num_phases; j++) { - if (!j) - pt = m->me->rt; - else if (j == 1) - pt = m->me->et; - else { - if (m->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, - scheme_make_integer(j)); - else - pt = NULL; - } - - if (pt) { - Scheme_Hash_Table *ht; - int i, count, nvp; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - nvp = pt->num_var_provides; - for (i = 0; i < nvp; i++) { - if (SCHEME_FALSEP(pt->provide_srcs[i])) { - scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(i)); - } - } - - count = m->exp_infos[j]->num_indirect_provides; - for (i = 0; i < count; i++) { - scheme_hash_set(ht, m->exp_infos[j]->indirect_provides[i], scheme_make_integer(i + nvp)); - } - - /* Add syntax as negative ids: */ - count = pt->num_provides; - for (i = nvp; i < count; i++) { - if (SCHEME_FALSEP(pt->provide_srcs[i])) - scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(-(i+1))); - } - - if (!j) { - /* find constants: */ - int i, cnt = SCHEME_VEC_SIZE(m->bodies[0]), k; - Scheme_Object *form, *tl; - - for (i = 0; i < cnt; i++) { - form = SCHEME_VEC_ELS(m->bodies[0])[i]; - if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { - int checked_st = 0, is_st_prop = 0, has_guard = 0; - Scheme_Object *is_st = NULL; - Simple_Struct_Type_Info stinfo; - Scheme_Object *parent_identity; - for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { - tl = SCHEME_VEC_ELS(form)[k]; - if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { - int pos = SCHEME_TOPLEVEL_POS(tl); - if (pos < m->prefix->num_toplevels) { - tl = m->prefix->toplevels[pos]; - if (SCHEME_SYMBOLP(tl)) { - Scheme_Object *v; - v = scheme_hash_get(ht, tl); - if (!v) { - /* The defined name is inaccessible. The bytecode compiler - won't generate such modules, but synthesized module bytecode - might leave bindings out of the `toplevels' table. */ - } else { - if (SCHEME_VEC_SIZE(form) == 2) { - if (scheme_ir_duplicate_ok(SCHEME_VEC_ELS(form)[0], 1)) { - /* record simple constant from cross-module propagation: */ - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(form)[0]), scheme_inline_variant_type)) { - /* record a potentially inlineable function */ - if (SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] != (Scheme_Object *)m->prefix) - SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] = (Scheme_Object *)m->prefix; - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { - /* that it's a procedure: */ - v = scheme_make_vector(2, v); - SCHEME_VEC_ELS(v)[1] = SCHEME_VEC_ELS(form)[0]; - } else { - /* record that it's fixed for any given instantiation: */ - v = scheme_make_pair(v, scheme_fixed_key); - } - } else { - if (!checked_st) { - if (scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], - SCHEME_VEC_SIZE(form)-1, - CHECK_STRUCT_TYPE_RESOLVED, - NULL, &stinfo, &parent_identity, - NULL, NULL, NULL, NULL, 0, - m->prefix->toplevels, ht, - &is_st, - 5)) { - is_st = scheme_make_pair(is_st, parent_identity); - } else { - is_st = NULL; - if (scheme_is_simple_make_struct_type_property(SCHEME_VEC_ELS(form)[0], - SCHEME_VEC_SIZE(form)-1, - CHECK_STRUCT_TYPE_RESOLVED, - &has_guard, - NULL, NULL, NULL, NULL, 0, - m->prefix->toplevels, ht, - 5)) - is_st_prop = 1; - } - checked_st = 1; - } - if (is_st) { - intptr_t shape; - shape = scheme_get_struct_proc_shape(k-1, &stinfo); - /* Vector of size 3 => struct shape */ - v = scheme_make_vector(3, v); - SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); - SCHEME_VEC_ELS(v)[2] = is_st; - } else if (is_st_prop) { - intptr_t shape; - shape = scheme_get_struct_property_proc_shape(k-1, has_guard); - /* Vector of size 4 => struct property shape */ - v = scheme_make_vector(4, v); - SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); - SCHEME_VEC_ELS(v)[2] = scheme_false; - SCHEME_VEC_ELS(v)[3] = scheme_false; - } - } - scheme_hash_set(ht, tl, v); - } - } else - scheme_signal_error("internal error: strange defn target %d", SCHEME_TYPE(tl)); - } - } - } - } - } - } - - m->exp_infos[j]->accessible = ht; - } - } - } -} - -Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, intptr_t rev_mod_phase) -{ - Scheme_Env *menv; - - menv = get_special_modenv(name); - - if (!menv) { - Scheme_Object *chain; - int ph; - - chain = env->modchain; - ph = rev_mod_phase; - while (ph && chain) { - chain = (SCHEME_VEC_ELS(chain))[2]; - if (SCHEME_FALSEP(chain)) - return NULL; - ph--; - } - - if (!chain) { - scheme_signal_error("internal error: missing chain for module instances"); - return NULL; - } - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(chain), name); - - while ((ph < rev_mod_phase) && menv) { - menv = menv->exp_env; - ph++; - } - } - - return menv; -} - -static void check_certified(Scheme_Object *guard_insp, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - Scheme_Object *stx, /* for error reporting */ - Scheme_Module *module, /* for error reporting */ - Scheme_Object *symbol, /* for error reporting */ - int var, /* for error reporting */ - int prot, /* for error reporting */ - int *_would_complain) -{ - int need_cert = 1; - - if (need_cert && current_insp) - need_cert = scheme_module_protected_wrt(guard_insp, current_insp); - if (need_cert && binding_insp) - need_cert = scheme_module_protected_wrt(guard_insp, binding_insp); - - if (need_cert) { - if (_would_complain) { - *_would_complain = 1; - } else { - /* For error, if stx is no more specific than symbol, drop symbol. */ - if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { - symbol = stx; - stx = NULL; - } - scheme_wrong_syntax(scheme_compile_stx_string, stx, symbol, - "access disallowed by code inspector to %s %s from module: %D", - prot ? "protected" : "unexported", - var ? "variable" : "syntax", - scheme_get_modsrc(module)); - } - } -} - -static Scheme_Object *to_defined_symbol_at_phase(Scheme_Object *symbol, Scheme_Env *env, Scheme_Object *phase) -{ - Scheme_Object *binding; - - binding = scheme_stx_lookup(symbol, phase); - if (SCHEME_VECTORP(binding) - && SAME_OBJ(env->module->self_modidx, SCHEME_VEC_ELS(binding)[0]) - && SAME_OBJ(phase, SCHEME_VEC_ELS(binding)[2])) - return SCHEME_VEC_ELS(binding)[1]; - - return SCHEME_STX_VAL(symbol); -} - -static Scheme_Object *to_defined_symbol(Scheme_Object *symbol, Scheme_Env *env) -{ - return to_defined_symbol_at_phase(symbol, env, scheme_make_integer(env->phase)); -} - -static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t mod_phase, Scheme_Object *guard_insp, - Scheme_Object *symbol, - Scheme_Object *stx, /* for error reporting, only */ - Scheme_Object *current_insp, - Scheme_Object *binding_insp, - int position, int want_pos, - int *_protected, int *_unexported, - Scheme_Env *from_env, /* for error reporting, only */ - int *_would_complain, - Scheme_Object **_is_constant) -/* Returns the actual name when !want_pos, needed in case of - uninterned names. Otherwise, returns a position value on success. - If position < -1, then merely checks for protected syntax. - - Access for protected and unexported names depends on - `current_insp` (dynamic context) and `binding_insp` (static context). */ -{ - Scheme_Module_Phase_Exports *pt; - - if (SAME_OBJ(scheme_get_kernel_env()->module, module) - || ((module->primitive && !module->exp_infos[0]->provide_protects))) { - if (want_pos) - return scheme_make_integer(-1); - else - return symbol; - } - - switch (mod_phase) { - case 0: - pt = module->me->rt; - break; - case 1: - pt = module->me->et; - break; - default: - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(module->me->other_phases, - scheme_make_integer(mod_phase)); - break; - } - - if (pt) { - if (position >= 0) { - /* Check whether the symbol at `pos' matches the string part of - the expected symbol. */ - Scheme_Object *isym; - int need_cert = 0; - - if (position < pt->num_var_provides) { - if (!pt->provide_srcs - || SCHEME_FALSEP(pt->provide_srcs[position])) - isym = pt->provide_src_names[position]; - else - isym = NULL; - } else { - int ipos = position - pt->num_var_provides; - int num_indirect_provides; - Scheme_Object **indirect_provides; - - if ((mod_phase >= 0) && (mod_phase < module->num_phases)) { - num_indirect_provides = module->exp_infos[mod_phase]->num_indirect_provides; - indirect_provides = module->exp_infos[mod_phase]->indirect_provides; - } else { - num_indirect_provides = 0; - indirect_provides = NULL; - } - - if (ipos < num_indirect_provides) { - isym = indirect_provides[ipos]; - need_cert = 1; - if (_protected) - *_protected = 1; - } else - isym = NULL; - } - - if (isym) { - if (SAME_OBJ(isym, symbol) - || (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol) - && !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) { - - if ((position < pt->num_var_provides) - && scheme_module_protected_wrt(guard_insp, current_insp)) { - char *provide_protects; - - if ((mod_phase >= 0) && (mod_phase < module->num_phases)) - provide_protects = module->exp_infos[mod_phase]->provide_protects; - else - provide_protects = NULL; - - if (provide_protects - && provide_protects[position]) { - if (_protected) - *_protected = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 1, _would_complain); - } - } - - if (need_cert) - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 0, _would_complain); - - if (want_pos) - return scheme_make_integer(position); - else - return isym; - } - } - /* failure */ - } else { - Scheme_Object *pos; - - if (mod_phase < module->num_phases) - pos = scheme_hash_get(module->exp_infos[mod_phase]->accessible, symbol); - else - pos = NULL; - - if (pos) { - if (SCHEME_PAIRP(pos)) { - if (_is_constant) *_is_constant = SCHEME_CDR(pos); - pos = SCHEME_CAR(pos); - } else if (SCHEME_VECTORP(pos)) { - if (SCHEME_VEC_SIZE(pos) == 2) { - if (_is_constant) - get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant); - } else if (SCHEME_VEC_SIZE(pos) == 3) { - /* vector of size 3 => struct proc */ - if (_is_constant) { - Scheme_Object *ps; - - ps = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1]), - SCHEME_VEC_ELS(pos)[2]); - - *_is_constant = ps; - } - } else { - MZ_ASSERT(SCHEME_VEC_SIZE(pos) == 4); - /* vector of size 4 => struct property proc */ - if (_is_constant) { - Scheme_Object *ps; - - ps = scheme_make_struct_property_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1])); - - *_is_constant = ps; - } - } - pos = SCHEME_VEC_ELS(pos)[0]; - } - } - - if (pos) { - if (position < -1) { - if (SCHEME_INT_VAL(pos) < 0) - pos = scheme_make_integer(-SCHEME_INT_VAL(pos) - 1); - else - pos = NULL; - } else { - if (SCHEME_INT_VAL(pos) < 0) - pos = NULL; - } - } - - if (pos) { - char *provide_protects; - - if ((mod_phase >= 0) && (mod_phase < module->num_phases)) - provide_protects = module->exp_infos[mod_phase]->provide_protects; - else - provide_protects = NULL; - - if (provide_protects - && (SCHEME_INT_VAL(pos) < pt->num_provides) - && provide_protects[SCHEME_INT_VAL(pos)]) { - if (_protected) - *_protected = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 1, _would_complain); - } - - if ((position >= -1) - && (SCHEME_INT_VAL(pos) >= pt->num_var_provides)) { - /* unexported var -- need cert */ - if (_protected) - *_protected = 1; - if (_unexported) - *_unexported = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 1, 0, _would_complain); - } - - if (want_pos) - return pos; - else - return symbol; - } - - if (position < -1) { - /* unexported syntax -- need cert */ - if (_unexported) - *_unexported = 1; - check_certified(guard_insp, current_insp, binding_insp, stx, module, symbol, 0, 0, _would_complain); - return NULL; - } - } - } - - if (_would_complain) { - *_would_complain = 1; - return NULL; - } - - /* For error, if stx is no more specific than symbol, drop symbol. */ - if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { - symbol = stx; - stx = NULL; - } - - { - const char *srcstr; - intptr_t srclen; - - if (from_env->module) - srcstr = scheme_display_to_string(scheme_get_modsrc(from_env->module), &srclen); - else { - srcstr = ""; - srclen = 0; - } - - scheme_wrong_syntax("link", stx, symbol, - "module mismatch;\n" - " possibly, bytecode file needs re-compile because dependencies changed\n" - "%s%t%s" - " exporting module: %D\n" - " exporting phase level: %d\n" - " internal explanation: variable not provided (directly or indirectly%s)", - srclen ? " importing module: " : "", - srcstr, srclen, - srclen ? "\n" : "", - scheme_get_modsrc(module), - mod_phase, - (position >= 0) ? " and at the expected position" : ""); - } - - return NULL; -} - -Scheme_Object *scheme_check_accessible_in_module_instance(Scheme_Env *env, - Scheme_Object *symbol, - Scheme_Object *stx, /* for error reporting, only */ - Scheme_Object *current_insp, - Scheme_Object *binding_insp, - int position, int want_pos, - int *_protected, int *_unexported, - Scheme_Env *from_env, /* for error reporting, only */ - int *_would_complain, - Scheme_Object **_is_constant) -{ - if (!SCHEME_SYMBOLP(symbol)) - symbol = to_defined_symbol(symbol, env); - - return check_accessible_in_module(env->module, env->mod_phase, env->guard_insp, - symbol, stx, - current_insp, binding_insp, - position, want_pos, - _protected, _unexported, - from_env, - _would_complain, - _is_constant); -} - -Scheme_Object *scheme_check_accessible_in_module_name(Scheme_Object *modidx, intptr_t mod_phase, Scheme_Env *env, - Scheme_Object *symbol, int position, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - Scheme_Object **_is_constant) -{ - Scheme_Module *module; - Scheme_Object *modname, *pos; - int would_complain = 0; - - modname = scheme_module_resolve(modidx, 0); - - module = registry_get_loaded(env, modname); - if (!module) - return 0; - - pos = check_accessible_in_module(module, mod_phase, scheme_make_inspector(module->insp), - symbol, NULL, - current_insp, binding_insp, - position, 1, - NULL, NULL, - NULL, - &would_complain, - _is_constant); - - return (would_complain - ? NULL - : (pos ? pos : scheme_make_integer(position))); -} - - -void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env) -{ - Scheme_Env *unsafe_env; - - unsafe_env = scheme_get_unsafe_env(); - - if (insp && SCHEME_HASHTRP(insp)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)insp; - int i; - Scheme_Object *k, *v; - - for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) { - scheme_hash_tree_index(t, i, &k, &v); - insp = k; - if (scheme_module_protected_wrt(unsafe_env->guard_insp, insp)) { - break; - } - } - - if (i < 0) - return; - } - - if (!insp || scheme_module_protected_wrt(unsafe_env->guard_insp, insp)) { - scheme_wrong_syntax("link", - NULL, NULL, - "attempt to access unsafe bindings from an untrusted context"); - } -} - -int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname) -{ - Scheme_Module *m; - Scheme_Object *pos; - - if (SAME_OBJ(modname, kernel_modname) - || SAME_OBJ(modname, unsafe_modname) - || SAME_OBJ(modname, flfxnum_modname) - || SAME_OBJ(modname, extfl_modname) - || SAME_OBJ(modname, futures_modname) - || SAME_OBJ(modname, foreign_modname)) - return -1; - - m = module_load(modname, env, NULL); - if (!m || m->primitive) - return -1; - - setup_accessible_table(m); - - pos = scheme_hash_get(m->exp_infos[0]->accessible, varname); - - if (SCHEME_PAIRP(pos)) - pos = SCHEME_CAR(pos); - else if (SCHEME_VECTORP(pos)) - pos = SCHEME_VEC_ELS(pos)[0]; - - if (pos && (SCHEME_INT_VAL(pos) >= 0)) - return SCHEME_INT_VAL(pos); - else - return -1; -} - -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, - Scheme_Object *name, int mod_phase) -{ - if (SAME_OBJ(modname, kernel_modname)) { - Scheme_Env *kenv; - kenv = scheme_get_kernel_env(); - if (SCHEME_STXP(name)) - name = SCHEME_STX_SYM(name); - return scheme_lookup_in_table(kenv->syntax, (char *)name); - } else if (SAME_OBJ(modname, unsafe_modname) - || SAME_OBJ(modname, flfxnum_modname) - || SAME_OBJ(modname, extfl_modname) - || SAME_OBJ(modname, futures_modname) - || SAME_OBJ(modname, foreign_modname)) { - /* no unsafe, flfxnum, extfl, or futures syntax */ - return NULL; - } else { - Scheme_Env *menv; - Scheme_Object *val; - int i; - - for (i = 0; i < mod_phase; i++) { - scheme_prepare_template_env(env); - env = env->template_env; - if (!env) return NULL; - } - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), modname); - - if (!menv) - return NULL; - - if (menv->module - && menv->running - && ((mod_phase+1) < menv->module->num_phases) - && !menv->running[mod_phase+1]) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, name, - "module mismatch;\n" - " attempted to use a module that is not available\n" - " possible cause:\n" - " using (dynamic-require .... #f)\n" - " but need (dynamic-require .... 0)\n" - " module: %D\n" - " phase: %d", - scheme_get_modsrc(menv->module), - mod_phase); - return NULL; - } - - for (i = 0; i < mod_phase; i++) { - scheme_prepare_exp_env(menv); - menv = menv->exp_env; - if (!menv) return NULL; - } - - if (SCHEME_STXP(name)) - name = to_defined_symbol(name, menv); - - val = scheme_lookup_in_table(menv->syntax, (char *)name); - - return val; - } -} - -static int wait_registry(Scheme_Env *env) -{ - Scheme_Object *lock, *a[2]; - - while (1) { - lock = scheme_hash_get(env->module_registry->loaded, scheme_false); - if (!lock) - return 1; - - if (SAME_OBJ(SCHEME_CDR(lock), (Scheme_Object *)scheme_current_thread)) - return 0; - - a[0] = SCHEME_CAR(lock); - a[1] = SCHEME_CDR(lock); - (void)scheme_sync(2, a); - } -} - -static void lock_registry(Scheme_Env *env) -{ - Scheme_Object *lock; - lock = scheme_make_pair(scheme_make_sema(0), - (Scheme_Object *) scheme_current_thread); - scheme_hash_set(env->module_registry->loaded, scheme_false, lock); -} - -static void unlock_registry(Scheme_Env *env) -{ - Scheme_Object *lock; - if (env) { - lock = scheme_hash_get(env->module_registry->loaded, scheme_false); - scheme_post_sema(SCHEME_CAR(lock)); - scheme_hash_set(env->module_registry->loaded, scheme_false, NULL); - } -} - -XFORM_NONGCING static intptr_t make_key(int base_phase, int eval_exp, int eval_run) -{ - return (((unsigned)base_phase << 3) - | (eval_exp ? ((eval_exp > 0) ? 2 : 4) : 0) - | (eval_run ? 1 : 0)); -} - -static int did_start(Scheme_Object *v, int base_phase, int eval_exp, int eval_run) -{ - intptr_t key; - - key = make_key(base_phase, eval_exp, eval_run); - - if (!v) - return 0; - - if (scheme_hash_tree_get((Scheme_Hash_Tree *)v, scheme_make_integer(key))) - return 1; - - return 0; -} - -static Scheme_Object *add_start(Scheme_Object *v, int base_phase, int eval_exp, int eval_run) -{ - intptr_t key; - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v; - Scheme_Bucket *b; - - if (!ht) - ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - key = make_key(base_phase, eval_exp, eval_run); - - ht = scheme_hash_tree_set(ht, scheme_make_integer(key), scheme_true); - - b = scheme_bucket_from_table(starts_table, (const char *)ht); - if (!b->val) - b->val = scheme_true; - return (Scheme_Object *)HT_EXTRACT_WEAK(b->key); -} - -#if 0 -static int indent = 0; -# define show_indent(d) (indent += d) -static void show(const char *what, Scheme_Env *menv, int v1, int v2, int ph, int base_phase) -{ - if (menv->phase > 3) return; - if (1 || SCHEME_SYMBOLP(SCHEME_PTR_VAL(menv->module->modname))) - if (1 || SCHEME_SYM_VAL(SCHEME_PTR_VAL(menv->module->modname))[0] != '#') { - int i; - for (i = 0; i < indent; i++) { - fprintf(stderr, " "); - } - fprintf(stderr, "%s \t%s @%ld+%d/%d [%d/%d] %p\n", - what, scheme_write_to_string(menv->module->modname, NULL), - menv->phase, ph, base_phase, v1, v2, menv->modchain); - } -} -static void show_done(const char *what, Scheme_Env *menv, int v1, int v2, int i, int base_phase){ - show(what, menv, v1, v2, i, base_phase); -} -#else -# define show_indent(d) /* nothing */ -# define show(w, m, v1, v2, i, bp) /* nothing */ -# define show_done(w, m, v1, v2, i, bp) /* nothing */ -#endif - -static void clone_require_names(Scheme_Module *m, Scheme_Object *phase) -{ - Scheme_Object *np, *np_first, *np_last, *l, *reqs; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - reqs = m->requires; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - reqs = m->et_requires; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - reqs = m->tt_requires; - } else if (SAME_OBJ(phase, scheme_false)) { - reqs = m->dt_requires; - } else { - if (m->other_requires) { - reqs = scheme_hash_get(m->other_requires, phase); - if (!reqs) - reqs = scheme_null; - } else - reqs = scheme_null; - } - - if (SCHEME_NULLP(reqs)) return; - - np_first = scheme_null; - np_last = NULL; - - for (l = reqs; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - np = cons(clone_modidx(SCHEME_CAR(l), m->me->src_modidx), scheme_null); - if (np_last) - SCHEME_CDR(np_last) = np; - else - np_first = np; - np_last = np; - } - - np = np_first; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - m->requires = np; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - m->et_requires = np; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - m->tt_requires = np; - } else if (SAME_OBJ(phase, scheme_false)) { - m->dt_requires = np; - } else { - scheme_hash_set(m->other_requires, phase, np); - } -} - -static void clone_all_require_names(Scheme_Module *m) -{ - clone_require_names(m, scheme_make_integer(0)); - clone_require_names(m, scheme_make_integer(1)); - clone_require_names(m, scheme_make_integer(-1)); - clone_require_names(m, scheme_false); - - if (m->other_requires) { - Scheme_Hash_Table *ht; - intptr_t i; - ht = scheme_clone_hash_table(m->other_requires); - m->other_requires = ht; - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - clone_require_names(m, ht->keys[i]); - } - } - } -} - -static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase, - Scheme_Env *load_env, Scheme_Object *syntax_idx) -{ - Scheme_Object *np, *np_first, *np_last, *midx, *l, *reqs, *req_names; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - req_names = menv->require_names; - reqs = menv->module->requires; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - req_names = menv->et_require_names; - reqs = menv->module->et_requires; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - req_names = menv->tt_require_names; - reqs = menv->module->tt_requires; - } else if (SAME_OBJ(phase, scheme_false)) { - req_names = menv->dt_require_names; - reqs = menv->module->dt_requires; - } else { - if (menv->module->other_requires) { - reqs = scheme_hash_get(menv->module->other_requires, phase); - if (!reqs) - reqs = scheme_null; - } else - reqs = scheme_null; - if (!SCHEME_NULLP(reqs) && !menv->other_require_names) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_eqv(); - menv->other_require_names = ht; - } - if (menv->other_require_names) - req_names = scheme_hash_get(menv->other_require_names, phase); - else - req_names = NULL; - } - - if (req_names && !SCHEME_NULLP(req_names)) - return; - - np_first = scheme_null; - np_last = NULL; - - for (l = reqs; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = scheme_modidx_shift(SCHEME_CAR(l), - menv->module->me->src_modidx, - (syntax_idx ? syntax_idx : menv->link_midx)); - - if (load_env) - module_load(scheme_module_resolve(midx, 1), load_env, NULL); - - np = cons(midx, scheme_null); - if (np_last) - SCHEME_CDR(np_last) = np; - else - np_first = np; - np_last = np; - } - - np = np_first; - - if (!SAME_OBJ(np, req_names)) { - if (SAME_OBJ(phase, scheme_make_integer(0))) { - menv->require_names = np; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - menv->et_require_names = np; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - menv->tt_require_names = np; - } else if (SAME_OBJ(phase, scheme_false)) { - menv->dt_require_names = np; - } else { - if (menv->other_require_names) - scheme_hash_set(menv->other_require_names, phase, np); - } - } -} - -static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, - intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx); - -static Scheme_Object *chain_start_module_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Env *menv = (Scheme_Env *)p->ku.k.p1; - Scheme_Env *env = (Scheme_Env *)p->ku.k.p2; - Scheme_Object *cycle_list = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *syntax_idx = (Scheme_Object *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - chain_start_module(menv, env, - p->ku.k.i1, p->ku.k.i2, - p->ku.k.i3, cycle_list, syntax_idx); - - return scheme_true; -} - -static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, - intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx) -{ - Scheme_Object *new_cycle_list, *midx, *l; - Scheme_Module *im; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)menv; - p->ku.k.p2 = (void *)env; - p->ku.k.i1 = eval_exp; - p->ku.k.i2 = eval_run; - p->ku.k.i3 = base_phase; - p->ku.k.p3 = (void *)cycle_list; - p->ku.k.p4 = (void *)syntax_idx; - (void)scheme_handle_stack_overflow(chain_start_module_k); - return; - } - } -#endif - - new_cycle_list = scheme_make_pair(menv->module->modname, cycle_list); - - if (!SCHEME_NULLP(menv->module->dt_requires)) { - compute_require_names(menv, scheme_false, env, syntax_idx); - - scheme_prepare_label_env(menv); - - for (l = menv->dt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, - menv->label_env, 0, - midx, - 0, 0, base_phase, - new_cycle_list, - 0); - } - } - - if (!SCHEME_NULLP(menv->module->tt_requires)) { - - compute_require_names(menv, scheme_make_integer(-1), env, syntax_idx); - - scheme_prepare_template_env(menv); - - for (l = menv->tt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, - menv->template_env, 0, - midx, - eval_exp, eval_run, base_phase, - new_cycle_list, - 0); - } - } - - compute_require_names(menv, scheme_make_integer(0), env, syntax_idx); - - for (l = menv->require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list, 0); - } - - scheme_prepare_exp_env(menv); - menv->exp_env->link_midx = menv->link_midx; - - if (!SCHEME_NULLP(menv->module->et_requires)) { - compute_require_names(menv, scheme_make_integer(1), env, syntax_idx); - - for (l = menv->et_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list, 0); - } - } - - if (menv->module->other_requires) { - int i; - Scheme_Object *phase, *n; - Scheme_Env *menv2; - for (i = 0; i < menv->module->other_requires->size; i++) { - if (menv->module->other_requires->vals[i]) { - phase = menv->module->other_requires->keys[i]; - - if (scheme_is_negative(phase)) { - compute_require_names(menv, phase, env, syntax_idx); - - n = phase; - menv2 = menv; - while (scheme_is_negative(n)) { - scheme_prepare_template_env(menv2); - menv2 = menv2->template_env; - n = scheme_bin_plus(n, scheme_make_integer(1)); - } - - l = scheme_hash_get(menv->other_require_names, phase); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, - menv2, 0, - midx, - eval_exp, eval_run, base_phase, - new_cycle_list, - 0); - } - } else { - compute_require_names(menv, phase, env, syntax_idx); - - n = phase; - menv2 = menv; - while (scheme_is_positive(n)) { - scheme_prepare_exp_env(menv2); - menv2->exp_env->link_midx = menv2->link_midx; - menv2 = menv2->exp_env; - n = scheme_bin_minus(n, scheme_make_integer(1)); - } - - l = scheme_hash_get(menv->other_require_names, phase); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - midx = SCHEME_CAR(l); - - im = module_load(scheme_module_resolve(midx, 1), env, NULL); - - start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list, 0); - } - } - } - } - } -} - -typedef struct Start_Module_Args { - Scheme_Env *menv; - Scheme_Env *env; - int eval_exp; - int eval_run; - intptr_t base_phase; - Scheme_Object *cycle_list; - Scheme_Object *syntax_idx; -} Start_Module_Args; - -static void chain_start_module_w_push(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, - intptr_t base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx) -{ - Start_Module_Args a; - - a.menv = menv; - a.env = env; - a.eval_exp = eval_exp; - a.eval_run = eval_run; - a.base_phase = base_phase; - a.cycle_list = cycle_list; - a.syntax_idx = syntax_idx; - -#ifdef MZ_USE_JIT - (void)scheme_module_start_start(&a, scheme_make_pair(menv->module->modname, scheme_false)); -#else - (void)scheme_module_start_finish(&a); -#endif -} - -void *scheme_module_start_finish(struct Start_Module_Args *a) -{ - chain_start_module(a->menv, a->env, - a->eval_exp, a->eval_run, a->base_phase, - a->cycle_list, a->syntax_idx); - return NULL; -} - -static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int restart, - Scheme_Object *syntax_idx, int not_new) -{ - Scheme_Env *menv; - - if (!restart) { - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - if (menv) { - check_phase(menv, env, 0); - return menv; - } - } - - if (m->primitive) { - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - if (!menv) { - menv = m->primitive; - scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv); - } - menv->require_names = scheme_null; - menv->et_require_names = scheme_null; - menv->tt_require_names = scheme_null; - menv->dt_require_names = scheme_null; - return menv; - } - - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - if (!menv || restart) { - Scheme_Object *insp; - - if (!menv) { - char *running; - - if (not_new) - scheme_signal_error("internal error: shouldn't instantiate module %s now", - scheme_write_to_string(m->modname, NULL)); - - /* printf("new %ld %s\n", env->phase, scheme_write_to_string(m->modname, NULL)); */ - menv = scheme_new_module_env(env, m, 0, 0); - scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv); - - running = (char *)scheme_malloc_atomic(menv->module->num_phases); - menv->running = running; - memset(menv->running, 0, menv->module->num_phases); - - menv->phase = env->phase; - menv->link_midx = syntax_idx; - } else { - Scheme_Env *env2; - - if (menv->module->num_phases < m->num_phases) { - char *running; - running = (char *)scheme_malloc_atomic(m->num_phases); - menv->running = running; - } - - menv->module = m; - memset(menv->running, 0, menv->module->num_phases); - menv->ran = 0; - menv->did_starts = NULL; - - for (env2 = menv->exp_env; env2; env2 = env2->exp_env) { - env2->module = m; - } - for (env2 = menv->template_env; env2; env2 = env2->template_env) { - env2->module = m; - } - env2 = menv->label_env; - if (env2) - env2->module = m; - - menv->interactive_bindings = 1; - } - - menv->access_insp = m->insp; - insp = scheme_make_inspector(m->insp); - menv->guard_insp = insp; - - /* These three should be set by various "finish"es, but - we initialize them in case there's an error running a "finish". */ - menv->require_names = scheme_null; - menv->et_require_names = scheme_null; - menv->tt_require_names = scheme_null; - menv->dt_require_names = scheme_null; - - if (env->label_env != env) { - setup_accessible_table(m); - - /* Create provided global variables: */ - if ((menv->phase <= 0) - && ((menv->phase + m->num_phases) > 0)) { - Scheme_Module_Phase_Exports *pt; - Scheme_Object **exss, **exsns; - int i, count; - Scheme_Env *menv2 = menv; - int pl; - - pl = -menv->phase; - - for (i = 0; i < pl; i++) { - scheme_prepare_exp_env(menv2); - menv2 = menv2->exp_env; - } - - switch(pl) { - case 0: - pt = m->me->rt; - break; - case 1: - pt = m->me->et; - break; - default: - if (m->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, scheme_make_integer(pl)); - else - pt = NULL; - break; - } - - if (pt) { - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - count = pt->num_var_provides; - - for (i = 0; i < count; i++) { - if (SCHEME_FALSEP(exss[i])) - scheme_add_to_table(menv2->toplevel, (const char *)exsns[i], NULL, 0); - } - } - - if (m->exp_infos[pl]) { - count = m->exp_infos[pl]->num_indirect_provides; - exsns = m->exp_infos[pl]->indirect_provides; - for (i = 0; i < count; i++) { - scheme_add_to_table(menv2->toplevel, (const char *)exsns[i], NULL, 0); - } - } - } - } - } - - return menv; -} - -static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int phase, int restart) -{ - if (!restart) { - if (menv && menv->running[phase]) - return; - } - - if (menv->module->primitive) - return; - - menv->running[phase] = 1; - if (scheme_starting_up) - menv->attached = 1; /* protect initial modules from redefinition, etc. */ - - run_module_exptime(menv, phase); - - return; -} - -static void run_module_exptime(Scheme_Env *menv, int phase) -{ -#ifdef MZ_USE_JIT - (void)scheme_module_exprun_start(menv, phase, scheme_make_pair(menv->module->modname, scheme_void)); -#else - (void)scheme_module_exprun_finish(menv, phase); -#endif -} - -void *scheme_module_exprun_finish(Scheme_Env *menv, int at_phase) -{ - int let_depth, for_stx; - Scheme_Object *names, *e; - Resolve_Prefix *rp; - Scheme_Comp_Env *rhs_env; - int i, cnt, len; - Scheme_Env *exp_env; - Scheme_Bucket_Table *syntax; - - if (menv->module->primitive) - return NULL; - - if ((menv->module->num_phases <= at_phase) || (!SCHEME_VEC_SIZE(menv->module->bodies[at_phase]))) - return NULL; - - for (i = 1; i < at_phase; i++) { - scheme_prepare_exp_env(menv); - if (!menv->exp_env->link_midx) - menv->exp_env->link_midx = menv->link_midx; - menv = menv->exp_env; - } - scheme_prepare_exp_env(menv); - exp_env = menv->exp_env; - if (!exp_env->link_midx) - exp_env->link_midx = menv->link_midx; - - if (!exp_env) - return NULL; - - syntax = menv->syntax; - - rhs_env = scheme_new_comp_env(menv, menv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); - - cnt = SCHEME_VEC_SIZE(menv->module->bodies[at_phase]); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(menv->module->bodies[at_phase])[i]; - - names = SCHEME_VEC_ELS(e)[0]; - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - for_stx = SCHEME_TRUEP(SCHEME_VEC_ELS(e)[4]); - e = SCHEME_VEC_ELS(e)[1]; - - if (for_stx) { - names = NULL; - len = 0; - } else { - if (SCHEME_SYMBOLP(names)) - names = scheme_make_pair(names, scheme_null); - len = scheme_list_length(names); - } - - eval_exptime(names, len, e, exp_env, rhs_env, - rp, let_depth, 1, (for_stx ? NULL : syntax), at_phase, - scheme_false, menv->access_insp); - } - - return NULL; -} - -static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart) -{ - if (m->primitive) { - menv->running[0] = 1; - menv->ran = 1; - return; - } - - if (menv->running[0] > 0) { - return; - } - - menv->running[0] = 1; - - if (menv->module->prim_body) { - Scheme_Invoke_Proc ivk = menv->module->prim_body; - menv->ran = 1; - ivk(menv, menv->phase, menv->link_midx, m->bodies[0]); - } else { - eval_module_body(menv, env); - } -} - -static void should_run_for_compile(Scheme_Env *menv, int phase) -{ - if (menv->running[phase]) return; - - if (!phase) { - scheme_prepare_template_env(menv); - menv = menv->template_env; - } else { - while (phase > 1) { - scheme_prepare_exp_env(menv); - menv = menv->exp_env; - phase--; - } - } - -#if 0 - if (!scheme_hash_get(MODCHAIN_TABLE(menv->instance_env->modchain), menv->module->modname)) - scheme_signal_error("internal error: inconsistent instance_env"); -#endif - - if (!menv->available_next[0]) { - menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0); - MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv; - } -} - -static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, - Scheme_Object *syntax_idx, int eval_exp, int eval_run, intptr_t base_phase, - Scheme_Object *cycle_list, int not_new) -/* Make an instance of module `m' in `env', which means that phase level 0 of module `m' - will be shifted to phase `env->phase'. - Let P=`base_phase'-`env->phase'. - - If `eval_run', then instantiate phase-level P of `m' (which is at `base_phase' in `env'). - - If `eval_exp' is -1, then (also) make its P+1 phase-level ready. - - If `eval_exp' is 1, then visit at phase P => run phase P+1. */ -{ - Scheme_Env *menv; - Scheme_Object *l; - int prep_namespace = 0, i; - - if (is_builtin_modname(m->modname)) - return; - - for (l = cycle_list; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (SAME_OBJ(m->modname, SCHEME_CAR(l))) { - scheme_contract_error("module", - "import cycle detected", - "module in cycle", 1, scheme_get_modsrc(m), - NULL); - } - } - - menv = instantiate_module(m, env, restart, syntax_idx, not_new); - - check_phase(menv, env, 0); - - show("chck", menv, eval_exp, eval_run, 0, base_phase); - - if (did_start(menv->did_starts, base_phase, eval_exp, eval_run)) - return; - - show("strt", menv, eval_exp, eval_run, 0, base_phase); - show_indent(+1); - - { - Scheme_Object *v; - v = add_start(menv->did_starts, base_phase, eval_exp, eval_run); - menv->did_starts = v; - } - - chain_start_module_w_push(menv, env, eval_exp, eval_run, base_phase, cycle_list, syntax_idx); - - if (restart) { - if (menv->rename_set_ready) { - menv->rename_set_ready = 0; - prep_namespace = 1; - } - } - - if (eval_run || eval_exp) { - for (i = menv->module->num_phases; i-- ; ) { - if (env->phase + i == base_phase) { - if (eval_exp) { - if (i + 1 < menv->module->num_phases) { - if (eval_exp > 0) { - show("exp=", menv, eval_exp, eval_run, i, base_phase); - expstart_module(menv, env, i+1, restart); - } else { - should_run_for_compile(menv, i); - } - } - } - if (eval_run) { - show("run=", menv, eval_exp, eval_run, i, base_phase); - if (i == 0) - do_start_module(m, menv, env, restart); - else - expstart_module(menv, env, i, restart); - } - } else if (env->phase + i > base_phase) { - if (eval_exp) { - should_run_for_compile(menv, i); - if (eval_exp > 0) { - if (env->phase + i == base_phase + 1) { - show("run+", menv, eval_exp, eval_run, i, base_phase); - if (i == 0) - do_start_module(m, menv, env, restart); - else - expstart_module(menv, env, i, restart); - } - } - } - } else { - /* env->phase + i < base_phase */ - } - } - - } - - show_indent(-1); - show_done("done", menv, eval_exp, eval_run, 0, base_phase); - - if (prep_namespace) - scheme_prep_namespace_rename(menv); -} - -static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) -{ - Scheme_Object *v, *prev; - Scheme_Env *menv, *uenv; - int need_lock; - - need_lock = wait_registry(env); - - v = MODCHAIN_AVAIL(env->modchain, pos); - if (!SCHEME_FALSEP(v)) { - MODCHAIN_AVAIL(env->modchain, pos) = scheme_false; - - /* Reverse order of the list; if X requires Y, Y - has been pushed onto the front of the list - before X. */ - prev = scheme_false; - while (SCHEME_NAMESPACEP(v)) { - menv = (Scheme_Env *)v; - v = menv->available_next[pos]; - menv->available_next[pos] = prev; - prev = (Scheme_Object *)menv; - } - v = prev; - - if (need_lock) { - lock_registry(env); - uenv = env; - } else - uenv = NULL; - - while (SCHEME_NAMESPACEP(v)) { - menv = (Scheme_Env *)v; - v = menv->available_next[pos]; - menv->available_next[pos] = NULL; - BEGIN_ESCAPEABLE(unlock_registry, uenv); - start_module(menv->module, menv->instance_env, 0, - NULL, 1, 0, base_phase, - scheme_null, 1); - END_ESCAPEABLE(); - } - - if (need_lock) - unlock_registry(env); - } -} - -void scheme_prepare_compile_env(Scheme_Env *env) -/* We're going to compile expressions at env->phase, so make sure - that env->phase is visited. */ -{ - do_prepare_compile_env(env, env->phase, 0); -} - -static void *eval_module_body_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Env *menv, *env; - - menv = (Scheme_Env *)p->ku.k.p1; - env = (Scheme_Env *)p->ku.k.p2; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - eval_module_body(menv, env); - - return NULL; -} - -#if 0 -# define LOG_RUN_DECLS intptr_t start_time -# define LOG_START_RUN(mod) (start_time = scheme_get_process_milliseconds()) -# define LOG_END_RUN(mod) (printf("Ran %s [%d msec]\n", \ - scheme_write_to_string(mod->modname, NULL), \ - scheme_get_process_milliseconds() - start_time)) -#else -# define LOG_RUN_DECLS /* empty */ -# define LOG_START_RUN(mod) /* empty */ -# define LOG_END_RUN(mod) /* empty */ -#endif - -static void eval_module_body(Scheme_Env *menv, Scheme_Env *env) -{ - if (menv->module->phaseless) { - /* Phaseless modules are implemented by last-minute sharing of the - `toplevels' table. In principle, much more repeated work up to - this point could be skipped, but this is the simplest point to - implement the sharing. */ - if (SAME_OBJ(scheme_true, menv->module->phaseless)) { - menv->module->phaseless = (Scheme_Object *)menv->toplevel; - } else { - menv->toplevel = (Scheme_Bucket_Table *)menv->module->phaseless; - return; - } - } - -#ifdef MZ_USE_JIT - (void)scheme_module_run_start(menv, env, scheme_make_pair(scheme_get_modsrc(menv->module), scheme_true)); -#else - (void)scheme_module_run_finish(menv, env); -#endif -} - -static Scheme_Object *body_one_expr(void *prefix_plus_expr, int argc, Scheme_Object **argv) -{ - Scheme_Object *v, **saved_runstack; - - saved_runstack = scheme_resume_prefix(SCHEME_CAR((Scheme_Object *)prefix_plus_expr)); - v = _scheme_eval_linked_expr_multi(SCHEME_CDR((Scheme_Object *)prefix_plus_expr)); - scheme_suspend_prefix(saved_runstack); - - scheme_ignore_result(v); - - return scheme_void; -} - -static int needs_prompt(Scheme_Object *e) -{ - Scheme_Type t; - - while (1) { - t = SCHEME_TYPE(e); - if (t > _scheme_values_types_) - return 0; - - switch (t) { - case scheme_lambda_type: - case scheme_toplevel_type: - case scheme_local_type: - case scheme_local_unbox_type: - return 0; - case scheme_case_lambda_sequence_type: - return 0; - case scheme_define_values_type: - e = SCHEME_VEC_ELS(e)[0]; - break; - case scheme_inline_variant_type: - e = SCHEME_VEC_ELS(e)[0]; - break; - default: - return 1; - } - } -} - -void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) -{ - Scheme_Thread *p; - Scheme_Module *m = menv->module; - Scheme_Object *body, **save_runstack, *save_prefix; - int depth; - int i, cnt; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - int volatile save_phase_shift; - mz_jmp_buf newbuf, * volatile savebuf; - LOG_RUN_DECLS; - - menv->running[0] = 1; - menv->ran = 1; - - depth = m->max_let_depth + scheme_prefix_depth(m->prefix); - if (!scheme_check_runstack(depth)) { - p = scheme_current_thread; - p->ku.k.p1 = menv; - p->ku.k.p2 = env; - (void)scheme_enlarge_runstack(depth, eval_module_body_k); - return NULL; - } - - LOG_START_RUN(menv->module); - - save_runstack = scheme_push_prefix(menv, 0, m->prefix, - m->me->src_modidx, menv->link_midx, - 0, menv->phase, NULL, - menv->access_insp); - - p = scheme_current_thread; - save_phase_shift = p->current_phase_shift; - p->current_phase_shift = menv->phase; - savebuf = p->error_buf; - p->error_buf = &newbuf; - - if (scheme_setjmp(newbuf)) { - Scheme_Thread *p2; - p2 = scheme_current_thread; - p2->error_buf = savebuf; - p2->current_phase_shift = save_phase_shift; - scheme_longjmp(*savebuf, 1); - } else { - if (env && menv->phase) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - for (i = 0; i < cnt; i++) { - body = SCHEME_VEC_ELS(m->bodies[0])[i]; - if (needs_prompt(body)) { - /* We need to push the prefix after the prompt is set, so - restore the runstack and then add the prefix back. */ - save_prefix = scheme_suspend_prefix(save_runstack); - (void)_scheme_call_with_prompt_multi(body_one_expr, - scheme_make_raw_pair(save_prefix, body)); - scheme_resume_prefix(save_prefix); - - /* Double-check that the definition-installing part of the - continuation was not skipped. Otherwise, the compiler would - not be able to assume that a variable reference that is - lexically later (incuding a reference to an imported - variable) always references a defined variable. Putting the - prompt around a definition's RHS might be a better - approach, but that would change the language (so mabe next - time). */ - if (SAME_TYPE(SCHEME_TYPE(body), scheme_define_values_type)) { - int vcnt, j; - - vcnt = SCHEME_VEC_SIZE(body) - 1; - for (j = 0; j < vcnt; j++) { - Scheme_Object *var; - Scheme_Prefix *toplevels; - Scheme_Bucket *b; - - var = SCHEME_VEC_ELS(body)[j+1]; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - - if (!b->val) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, - b->key, - "define-values: skipped variable definition;\n" - " cannot continue without defining variable\n" - " variable: %S\n" - " in module: %D", - (Scheme_Object *)b->key, - menv->module->modsrc); - } - } - } - } else - scheme_ignore_result(_scheme_eval_linked_expr_multi(body)); - } - - if (scheme_module_demand_hook) { - Scheme_Object *a[1], *val, *sym; - a[0] = menv->module->modname; - sym = scheme_module_demand_hook(1, a); - if (sym) { - val = scheme_lookup_global(sym, menv); - if (val) { - a[0] = val; - val = scheme_module_demand_hook(3, a); - if (val) { - scheme_add_global_symbol(sym, val, menv); - } - } - } - } - - if (env && menv->phase) { - scheme_pop_continuation_frame(&cframe); - } - - p = scheme_current_thread; - p->error_buf = savebuf; - p->current_phase_shift = save_phase_shift; - - scheme_pop_prefix(save_runstack); - } - - LOG_END_RUN(menv->module); - - return NULL; -} - -static void run_module(Scheme_Env *menv, int set_ns) -{ - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - if (set_ns) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)menv); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } - - eval_module_body(menv, NULL); - - if (set_ns) { - scheme_pop_continuation_frame(&cframe); - } - -} - -Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) -{ - Scheme_Module *m; - Scheme_Env *env; - Scheme_Object *prefix, *insp, *src, *midx; - Scheme_Config *config; - char *running; - - m = MALLOC_ONE_TAGGED(Scheme_Module); - m->so.type = scheme_module_type; - m->predefined = scheme_starting_up; - m->phaseless = scheme_true; - - env = scheme_new_module_env(for_env, m, 0, 0); - - if (!scheme_defining_primitives) { - config = scheme_current_config(); - prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME); - if (SCHEME_MODNAMEP(prefix)) - name = prefix; - else - name = scheme_intern_resolved_module_path(name); - src = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_SRC); - if (SCHEME_FALSEP(src)) - src = prefix; - else - src = scheme_intern_resolved_module_path(src); - if (SCHEME_FALSEP(src)) - src = name; - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); - } - else { - name = scheme_intern_resolved_module_path(name); - src = name; - insp = scheme_get_current_inspector(); - } - - m->modname = name; - m->modsrc = src; - m->requires = scheme_null; - m->et_requires = scheme_null; - m->tt_requires = scheme_null; - m->dt_requires = scheme_null; - m->primitive = env; - m->insp = insp; - - midx = scheme_make_modidx(scheme_false, scheme_false, name); - m->self_modidx = midx; - - { - Scheme_Module_Exports *me; - me = scheme_make_module_exports(); - m->me = me; - me->modsrc = src; - } - - scheme_hash_set(for_env->module_registry->exports, m->modname, (Scheme_Object *)m->me); - - env->access_insp = insp; - insp = scheme_make_inspector(insp); - env->guard_insp = insp; - - scheme_hash_set(for_env->module_registry->loaded, m->modname, (Scheme_Object *)m); - - running = scheme_malloc_atomic(2); - running[0] = 1; - running[1] = 1; - env->running = running; - - return env; -} - -void scheme_set_primitive_module_phaseless(Scheme_Env *env, int phaseless) -{ - env->module->phaseless = (phaseless ? scheme_true : NULL); -} - -void scheme_finish_primitive_module(Scheme_Env *env) -{ - Scheme_Module *m = env->module; - Scheme_Bucket_Table *ht; - Scheme_Bucket **bs; - Scheme_Object **exs; - int i, count; - - if (!m->exp_infos) - add_exp_infos(m); - - /* Provide all variables: */ - count = 0; - ht = env->toplevel; - - bs = ht->buckets; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - count++; - } - - exs = MALLOC_N(Scheme_Object *, count); - count = 0; - for (i = ht->size; i--; ) { - Scheme_Bucket *b = bs[i]; - if (b && b->val) - exs[count++] = (Scheme_Object *)b->key; - } - - m->me->rt->provides = exs; - m->me->rt->provide_srcs = NULL; - m->me->rt->provide_src_names = exs; - m->me->rt->num_provides = count; - m->me->rt->num_var_provides = count; - - qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, 0, count, 1); - - env->running[0] = 1; -} - -void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) -{ - Scheme_Module *m = env->module; - int i; - - if (!m->exp_infos) - add_exp_infos(m); - - if (!m->exp_infos[0]->provide_protects) { - Scheme_Hash_Table *ht; - char *exps; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - exps = MALLOC_N_ATOMIC(char, m->me->rt->num_provides); - for (i = m->me->rt->num_provides; i--; ) { - exps[i] = 0; - scheme_hash_set(ht, m->me->rt->provides[i], scheme_make_integer(i)); - } - add_exp_infos(m); - m->exp_infos[0]->provide_protects = exps; - m->exp_infos[0]->accessible = ht; - } - - if (name) { - for (i = m->me->rt->num_provides; i--; ) { - if (SAME_OBJ(name, m->me->rt->provides[i])) { - m->exp_infos[0]->provide_protects[i] = 1; - break; - } - } - } else { - /* Protect all */ - for (i = m->me->rt->num_provides; i--; ) { - m->exp_infos[0]->provide_protects[i] = 1; - } - } -} - -Scheme_Bucket *scheme_module_bucket(Scheme_Object *modname, Scheme_Object *var, int pos, Scheme_Env *env) -{ - Scheme_Object *a[2]; - - if (SAME_OBJ(modname, kernel_symbol)) - a[0] = ((Scheme_Modidx *)kernel_modidx)->path; - else - a[0] = modname; - a[1] = var; - - return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 0, 0, 1, 1, pos); -} - -Scheme_Object *scheme_builtin_value(const char *name) -{ - Scheme_Object *a[2], *v; - - a[1] = scheme_intern_symbol(name); - - /* Try kernel first: */ - a[0] = kernel_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Try flfxnum next: */ - a[0] = flfxnum_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Try extfl next: */ - a[0] = extfl_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Try unsafe next: */ - a[0] = unsafe_modname; - v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1); - if (v) - return v; - - /* Also try #%utils... */ - a[0] = scheme_make_pair(quote_symbol, - scheme_make_pair(scheme_intern_symbol("#%utils"), - scheme_null)); - v = _dynamic_require(2, a, initial_modules_env, 0, 0, 0, 0, 0, -1); - if (v) - return v; - - return NULL; -} - -Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) { - Scheme_Compilation_Top *c = (Scheme_Compilation_Top *)o; - - if (!c->prefix) /* => compiled module is in `code' field */ - return (Scheme_Module *)c->code; - - if (SAME_TYPE(SCHEME_TYPE(c->code), scheme_module_type)) { - return (Scheme_Module *)c->code; - } - } - - return NULL; -} - -Scheme_Module_Exports *scheme_make_module_exports() -{ - Scheme_Module_Exports *me; - Scheme_Module_Phase_Exports *pt; - - me = MALLOC_ONE_RT(Scheme_Module_Exports); - SET_REQUIRED_TAG(me->type = scheme_rt_module_exports); - - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = scheme_make_integer(0); - me->rt = pt; - - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = scheme_make_integer(1); - me->et = pt; - - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = scheme_false; - me->dt = pt; - - return me; -} - -/**********************************************************************/ -/* define-syntaxes */ -/**********************************************************************/ - -static void *eval_exptime_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *names; - int count, at_phase; - Scheme_Object *expr; - Scheme_Env *genv; - Scheme_Comp_Env *comp_env; - Resolve_Prefix *rp; - int let_depth, shift; - Scheme_Bucket_Table *syntax; - Scheme_Object *ids_for_rename_trans, *insp; - - names = (Scheme_Object *)p->ku.k.p1; - expr = (Scheme_Object *)p->ku.k.p2; - genv = (Scheme_Env *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[0]; - comp_env = (Scheme_Comp_Env *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[1]; - ids_for_rename_trans = SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[2]; - rp = (Resolve_Prefix *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[3]; - syntax = (Scheme_Bucket_Table *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[4]; - insp = SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[5]; - count = p->ku.k.i1; - let_depth = p->ku.k.i2; - shift = p->ku.k.i3; - at_phase = p->ku.k.i4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - - eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, at_phase, - ids_for_rename_trans, insp); - - return NULL; -} - -static int is_simple_expr(Scheme_Object *v) -{ - Scheme_Type t; - - t = SCHEME_TYPE(v); - if (SAME_TYPE(t, scheme_lambda_type)) - return 1; - - return 0; -} - -static void eval_exptime(Scheme_Object *names, int count, - Scheme_Object *expr, - Scheme_Env *genv, Scheme_Comp_Env *comp_env, - Resolve_Prefix *rp, - int let_depth, int shift, Scheme_Bucket_Table *syntax, - int at_phase, - Scheme_Object *ids_for_rename_trans, - Scheme_Object *insp) -{ - Scheme_Object *macro, *vals, *name, **save_runstack; - int i, g, depth; - - depth = let_depth + scheme_prefix_depth(rp); - if (!scheme_check_runstack(depth)) { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = names; - p->ku.k.p2 = expr; - vals = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vals)[0] = (Scheme_Object *)genv; - SCHEME_VEC_ELS(vals)[1] = (Scheme_Object *)comp_env; - SCHEME_VEC_ELS(vals)[2] = ids_for_rename_trans; - SCHEME_VEC_ELS(vals)[3] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vals)[4] = (Scheme_Object *)syntax; - SCHEME_VEC_ELS(vals)[5] = insp; - p->ku.k.p4 = vals; - p->ku.k.i1 = count; - p->ku.k.i2 = let_depth; - p->ku.k.i3 = shift; - p->ku.k.i4 = at_phase; - (void)scheme_enlarge_runstack(depth, eval_exptime_k); - return; - } - - if (SCHEME_TYPE(expr) > _scheme_values_types_) { - vals = expr; - } else { - save_runstack = scheme_push_prefix(genv, 0, rp, - (shift ? genv->module->me->src_modidx : NULL), - (shift ? genv->link_midx : NULL), - at_phase, genv->phase, - NULL, insp); - - if (is_simple_expr(expr)) { - vals = _scheme_eval_linked_expr_multi_wp(expr, scheme_current_thread); - } else { - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - Scheme_Dynamic_State dyn_state; - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)genv); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, comp_env, NULL, NULL, scheme_false, - genv, (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx)); - vals = scheme_eval_linked_expr_multi_with_dynamic_state(expr, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - } - - scheme_pop_prefix(save_runstack); - } - - if (names) { - if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { - g = scheme_current_thread->ku.multiple.count; - if (count == g) { - Scheme_Object **values; - - values = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; - if (SAME_OBJ(values, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - for (i = 0; i < g; i++, names = SCHEME_CDR(names)) { - name = SCHEME_CAR(names); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = values[i]; - - if (SCHEME_TRUEP(ids_for_rename_trans) - && scheme_is_binding_rename_transformer(values[i])) { - scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), - scheme_rename_transformer_id(values[i], NULL), - scheme_make_integer(at_phase-1)); - } - scheme_add_to_table(syntax, (const char *)name, macro, 0); - - if (SCHEME_TRUEP(ids_for_rename_trans)) - ids_for_rename_trans = SCHEME_CDR(ids_for_rename_trans); - } - - return; - } - } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) { - name = SCHEME_CAR(names); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = vals; - - if (SCHEME_TRUEP(ids_for_rename_trans) - && scheme_is_binding_rename_transformer(vals)) { - scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), - scheme_rename_transformer_id(vals, NULL), - scheme_make_integer(at_phase-1)); - } - scheme_add_to_table(syntax, (const char *)name, macro, 0); - - return; - } else - g = 1; - - if (count) - name = SCHEME_CAR(names); - else - name = NULL; - - { - const char *symname; - - symname = (name ? scheme_symbol_name(name) : ""); - - scheme_wrong_return_arity("define-syntaxes", - count, g, - (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, - "%s%s%s", - name ? "defining \"" : "0 names", - symname, - name ? ((count == 1) ? "\"" : "\", ...") : ""); - } - } -} - -/**********************************************************************/ -/* module */ -/**********************************************************************/ - -static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix, - Scheme_Object *supermodule); - -static Scheme_Object *do_module_execute_k() -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *data = (Scheme_Object *)p->ku.k.p1; - Scheme_Env *genv = (Scheme_Env *)p->ku.k.p2; - Scheme_Object *prefix = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *supermodule = (Scheme_Object *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - return do_module_execute(data, genv, p->ku.k.i1, p->ku.k.i2, prefix, supermodule); -} - -static Scheme_Object *do_module_execute_recur(Scheme_Object *data, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix, - Scheme_Object *supermodule) -{ -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)data; - p->ku.k.p2 = (void *)genv; - p->ku.k.i1 = set_cache; - p->ku.k.i2 = set_in_pre; - p->ku.k.p3 = (void *)prefix; - p->ku.k.p4 = (void *)supermodule; - return scheme_handle_stack_overflow(do_module_execute_k); - } else { - return do_module_execute(data, genv, set_cache, set_in_pre, prefix, supermodule); - } -} - -static void execute_submodules(Scheme_Module *m, int pre, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix) -{ - Scheme_Object *p; - - p = (pre ? m->pre_submodules : m->post_submodules); - - if (p) { - if (SCHEME_PAIRP(scheme_resolved_module_path_value(prefix))) { - prefix = scheme_resolved_module_path_value(prefix); - prefix = scheme_intern_resolved_module_path(SCHEME_CAR(prefix)); - } - - while (!SCHEME_NULLP(p)) { - do_module_execute_recur(SCHEME_CAR(p), genv, set_cache, set_in_pre, prefix, - (Scheme_Object *)m); - p = SCHEME_CDR(p); - } - } -} - -static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, - int set_cache, int set_in_pre, - Scheme_Object *prefix, - Scheme_Object *supermodule) -{ - Scheme_Module *m, *old_m; - Scheme_Env *env; - Scheme_Env *old_menv; - Scheme_Config *config; - Scheme_Object *src, *insp; - - m = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m, data, sizeof(Scheme_Module)); - - if (set_cache && m->code_key - && (!m->pre_submodules || SCHEME_NULLP(m->pre_submodules)) - && (!m->post_submodules || SCHEME_NULLP(m->post_submodules))) { - if (!scheme_module_code_cache) { - REGISTER_SO(scheme_module_code_cache); - scheme_module_code_cache = scheme_make_weak_equal_table(); - } - scheme_add_to_table(scheme_module_code_cache, - (const char *)m->code_key, - scheme_make_ephemeron(m->code_key, data), - 0); - } - - if (m->code_key) { - /* clone `requires', etc., so that different uses of the cached - module don't share resolution of modiule paths in modidxs */ - clone_all_require_names(m); - } - - config = scheme_current_config(); - - if (!prefix) - prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME); - - if (SCHEME_MODNAMEP(prefix)) { - if (m->submodule_path && !SCHEME_NULLP(m->submodule_path)) { - prefix = scheme_make_pair(scheme_resolved_module_path_value(prefix), - m->submodule_path); - prefix = scheme_intern_resolved_module_path(prefix); - } - - m->modname = prefix; - - if (m->self_modidx) { - if (!SCHEME_SYMBOLP(m->self_modidx)) { - Scheme_Modidx *midx = (Scheme_Modidx *)m->self_modidx; - Scheme_Object *nmidx; - - nmidx = scheme_make_modidx(midx->path, midx->base, m->modname); - m->self_modidx = nmidx; - - if (m->rn_stx && !SAME_OBJ(scheme_true, m->rn_stx)) { - /* Delay the shift: */ - Scheme_Object *v; - v = m->rn_stx; - v = scheme_make_pair(v, (Scheme_Object *)midx); - m->rn_stx = v; - } - } - } - } else - prefix = m->modname; /* used for submodules */ - - /* printf("declare %s\n", scheme_write_to_string(m->modname, NULL)); */ - - src = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_SRC); - if (!SCHEME_FALSEP(src)) { - src = scheme_intern_resolved_module_path(src); - m->modsrc = src; - } else { - src = m->modname; - if (m->submodule_path && !SCHEME_NULLP(m->submodule_path)) { - src = scheme_resolved_module_path_value(src); - if (SCHEME_PAIRP(src)) - src = SCHEME_CAR(src); - src = scheme_intern_resolved_module_path(src); - } - m->modsrc = src; - } - - if (supermodule) - m->supermodule = supermodule; - - if (genv) - env = genv; - else - env = scheme_environment_from_dummy(m->dummy); - - old_menv = get_special_modenv(m->modname); - if (!old_menv) - old_menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname); - - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); - - if (old_menv) { - if (scheme_module_protected_wrt(old_menv->guard_insp, insp) || old_menv->attached) { - scheme_contract_error("module->namespace", - "current code inspector cannot redeclare module", - "module name", 1, m->modname, - NULL); - return NULL; - } - } - - if (old_menv) - old_m = old_menv->module; - else - old_m = (Scheme_Module *)scheme_hash_get(env->module_registry->loaded, m->modname); - - if (old_m && old_m->phaseless) { - scheme_contract_error("module->namespace", - "cannot redeclare cross-phase persistent module", - "module name", 1, m->modname, - NULL); - return NULL; - } - - if (!set_in_pre) { - /* execute pre-submodules: */ - execute_submodules(m, 1, genv, set_cache, set_in_pre, prefix); - } - - if (!SAME_OBJ(m->me->modsrc, m->modsrc)) { - /* have to clone m->me, etc. */ - Scheme_Module_Exports *naya_me; - - naya_me = MALLOC_ONE_TAGGED(Scheme_Module_Exports); - memcpy(naya_me, m->me, sizeof(Scheme_Module_Exports)); - m->me = naya_me; - m->me->modsrc = m->modsrc; - } - - m->insp = insp; - if (set_in_pre) { - if (!env->module_pre_registry->loaded) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - env->module_pre_registry->loaded = ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; /* print (for debugging) as opqaue */ - env->module_pre_registry->exports = ht; - } - scheme_hash_set(env->module_pre_registry->loaded, m->modname, (Scheme_Object *)m); - scheme_hash_set(env->module_pre_registry->exports, m->modname, (Scheme_Object *)m->me); - } else { - scheme_hash_set(env->module_registry->loaded, m->modname, (Scheme_Object *)m); - scheme_hash_set(env->module_registry->exports, m->modname, (Scheme_Object *)m->me); - } - - if (!set_in_pre) { - Scheme_Object *resolver, *a[2]; - resolver = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER); - a[0] = m->modname; - a[1] = scheme_false; - scheme_apply(resolver, 2, a); - } - - /* Replacing an already-running or already-syntaxing module? */ - if (old_menv) { - old_menv->interactive_bindings = 1; - start_module(m, env, 1, NULL, - ((m->num_phases > 1) ? old_menv->running[1] : 0), - old_menv->running[0], - env->phase, scheme_null, 1); - } - - /* execute post-submodules: */ - execute_submodules(m, 0, genv, set_cache, set_in_pre, prefix); - - return scheme_void; -} - -Scheme_Object *scheme_module_execute(Scheme_Object *data, Scheme_Env *genv) -{ - return do_module_execute(data, genv, 1, 0, NULL, NULL); -} - -Scheme_Object *scheme_get_modsrc(Scheme_Module *mod) -{ - Scheme_Object *p, *p2; - - p = scheme_resolved_module_path_value(mod->modname); - if (SCHEME_PAIRP(p)) { - /* Construct a submodule path based on `modsrc` instead of `modname`. */ - p2 = scheme_resolved_module_path_value(mod->modsrc); - if (SAME_OBJ(SCHEME_CAR(p), p2)) - return mod->modname; - else - return scheme_intern_resolved_module_path(scheme_make_pair(p2, SCHEME_CDR(p))); - } else - return mod->modsrc; -} - -static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp) -{ - Scheme_Object *vec2; - int i; - - i = SCHEME_VEC_SIZE(vec); - vec2 = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i]; - } - SCHEME_VEC_ELS(vec2)[1] = naya; - SCHEME_VEC_ELS(vec2)[3] = (Scheme_Object *)rp; - - return vec2; -} - -static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec, int jit) -{ - Scheme_Object *orig, *naya = NULL; - Resolve_Prefix *orig_rp, *rp; - int i, cnt; - - cnt = SCHEME_VEC_SIZE(orig_l); - for (i = 0; i < cnt; i++) { - orig = SCHEME_VEC_ELS(orig_l)[i]; - if (in_vec) { - orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3]; - rp = scheme_prefix_eval_clone(orig_rp); - orig = SCHEME_VEC_ELS(orig)[1]; - } else { - orig_rp = rp = NULL; - } - - if (jit) - naya = scheme_jit_expr(orig); - else - naya = orig; - - if (!SAME_OBJ(orig, naya) - || !SAME_OBJ(orig_rp, rp)) - break; - } - - if (i < cnt) { - Scheme_Object *new_l; - int j; - new_l = scheme_make_vector(cnt, NULL); - for (j = 0; j < i; j++) { - SCHEME_VEC_ELS(new_l)[j] = SCHEME_VEC_ELS(orig_l)[j]; - } - if (in_vec) - naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp); - SCHEME_VEC_ELS(new_l)[i] = naya; - for (i++; i < cnt; i++) { - orig = SCHEME_VEC_ELS(orig_l)[i]; - if (in_vec) { - orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3]; - rp = scheme_prefix_eval_clone(orig_rp); - orig = SCHEME_VEC_ELS(orig)[1]; - } else { - orig_rp = rp = NULL; - } - - if (jit) - naya = scheme_jit_expr(orig); - else - naya = orig; - - if (in_vec) { - if (!SAME_OBJ(orig, naya) - || !SAME_OBJ(rp, orig_rp)) - naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp); - else - naya = SCHEME_VEC_ELS(orig_l)[i]; - } - SCHEME_VEC_ELS(new_l)[i] = naya; - } - return new_l; - } else - return orig_l; -} - -static Scheme_Object *do_module_clone(Scheme_Object *data, int jit) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *l1, *l2, *pre_submods, *post_submods, *sm, **naya = NULL; - int j, i, submod_changed; - Resolve_Prefix *rp; - - rp = scheme_prefix_eval_clone(m->prefix); - - for (j = m->num_phases; j--; ) { - if (!jit && !j) { - if (naya) - naya[0] = m->bodies[0]; - break; - } - l1 = jit_vector(m->bodies[j], j > 0, jit); - if (naya) - naya[j] = l1; - else if (!SAME_OBJ(l1, m->bodies[j])) { - naya = MALLOC_N(Scheme_Object*, m->num_phases); - for (i = m->num_phases; i-- > j; ) { - naya[i] = m->bodies[i]; - } - naya[j] = l1; - } - } - - pre_submods = m->pre_submodules; - post_submods = m->post_submodules; - submod_changed = 0; - - for (j = 0; j < 2; j++) { - l1 = (j ? post_submods : pre_submods); - if (l1 && !SCHEME_NULLP(l1)) { - l2 = scheme_null; - while (!SCHEME_NULLP(l1)) { - sm = do_module_clone(SCHEME_CAR(l1), jit); - if (!SAME_OBJ(sm, SCHEME_CAR(l1))) - submod_changed = 1; - l2 = scheme_make_pair(sm, l2); - l1 = SCHEME_CDR(l1); - } - if (submod_changed) { - l2 = scheme_reverse(l2); - if (j) - post_submods = l2; - else - pre_submods = l2; - } - } - } - - if (!naya) { - if (SAME_OBJ(rp, m->prefix) && !submod_changed) - return data; - naya = m->bodies; - } - - m = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m, data, sizeof(Scheme_Module)); - m->bodies = naya; - m->prefix = rp; - - m->pre_submodules = pre_submods; - m->post_submodules = post_submods; - - return (Scheme_Object *)m; -} - -Scheme_Object *scheme_module_jit(Scheme_Object *data) -{ - return do_module_clone(data, 1); -} - -Scheme_Object *scheme_module_eval_clone(Scheme_Object *data) -{ - return do_module_clone(data, 0); -} - -static Scheme_Object *strip_lexical_context(Scheme_Object *stx); - -static Scheme_Object *strip_lexical_context_k() -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *v = (Scheme_Object *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - return strip_lexical_context(v); -} - -static Scheme_Object *strip_lexical_context(Scheme_Object *stx) -{ - Scheme_Object *v = NULL; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)v; - - return scheme_handle_stack_overflow(strip_lexical_context_k); - } -#endif - - if (SCHEME_STXP(stx)) { - stx = scheme_stx_taint_disarm(stx, NULL); - v = SCHEME_STX_VAL(stx); - } else - v = stx; - - if (SCHEME_PAIRP(v)) { - v = scheme_make_pair(strip_lexical_context(SCHEME_CAR(v)), - strip_lexical_context(SCHEME_CDR(v))); - } else if (SCHEME_VECTORP(v)) { - Scheme_Object *v2, *a; - int i = SCHEME_VEC_SIZE(v); - v2 = scheme_make_vector(i, NULL); - for (; i--; ) { - a = strip_lexical_context(SCHEME_VEC_ELS(v)[i]); - SCHEME_VEC_ELS(v2)[i] = a; - } - } else if (SCHEME_BOXP(v)) { - v = strip_lexical_context(SCHEME_BOX_VAL(v)); - v = scheme_box(v); - } - /* FIXME: handle prefabs & hashes */ - - if (SCHEME_STXP(stx)) - v = scheme_datum_to_syntax(v, stx, scheme_false, 0, 1); - - return v; -} - -static void check_not_tainted(Scheme_Object *orig) -{ - if (scheme_stx_is_tainted(orig)) - scheme_wrong_syntax(NULL, orig, NULL, - "cannot expand module body tainted by macro expansion"); -} - -static Scheme_Env *find_env(Scheme_Env *env, intptr_t ph) -{ - return scheme_find_env_at_phase(env, scheme_make_integer(ph - env->phase)); -} - -static Scheme_Object *extract_root_module_name(Scheme_Module *m) -{ - Scheme_Object *root_module_name; - - root_module_name = m->submodule_ancestry; - if (SCHEME_NULLP(root_module_name)) { - root_module_name = m->modname; - } else { - while (SCHEME_PAIRP(SCHEME_CDR(root_module_name))) { - root_module_name = SCHEME_CDR(root_module_name); - } - root_module_name = ((Scheme_Env *)SCHEME_CAR(root_module_name))->module->modname; - } - - return root_module_name; -} - -static void add_binding_names_from_environment(Scheme_Module *m, Scheme_Env *benv) -{ - if (benv->binding_names) { - int c; - - if (SCHEME_HASHTP(benv->binding_names)) - c = ((Scheme_Hash_Table *)benv->binding_names)->count; - else - c = ((Scheme_Hash_Tree *)benv->binding_names)->count; - - if (c) { - Scheme_Hash_Table *ht; - - ht = (Scheme_Hash_Table *)m->other_binding_names; - if (!ht) { - ht = scheme_make_hash_table_eqv(); - m->other_binding_names = (Scheme_Object *)ht; - } - - scheme_hash_set(ht, scheme_env_phase(benv), benv->binding_names); - } - } -} - -#if 0 -# define LOG_EXPAND_DECLS intptr_t start_time -# define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds()) -# define LOG_END_EXPAND(mod) (printf("Expanded/compiled %s [%d msec]\n", \ - scheme_write_to_string(mod->modname, NULL), \ - scheme_get_process_milliseconds() - start_time)) -#else -# define LOG_EXPAND_DECLS /* empty */ -# define LOG_START_EXPAND(mod) /* empty */ -# define LOG_END_EXPAND(mod) /* empty */ -#endif - -static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object *submodule_ancestry, Scheme_Object *submodule_path, int post, - Module_Begin_Expand_State *super_bxs, - Scheme_Object *super_phase_shift) -{ - Scheme_Object *fm, *disarmed_form; - Scheme_Object *nm, *ii, *iidx, *self_modidx, *rmp, *rn_set, *mb_ctx, *ctx_form; - Scheme_Module *iim; - Scheme_Env *menv, *top_env; - Scheme_Comp_Env *benv; - Scheme_Module *m; - Scheme_Object *mbval, *orig_ii; - Scheme_Object *this_empty_self_modidx, **sub_iidx_ptrs; - int saw_mb, check_mb = 0, shift_back = 0; - Scheme_Object *restore_confusing_name = NULL; - LOG_EXPAND_DECLS; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PRIM_MODULE(env->observer); - if (rec[drec].depth > 0) - rec[drec].depth++; - } - - if (!scheme_is_toplevel(env)) - scheme_wrong_syntax(NULL, NULL, form, "not in a module-definition context"); - - disarmed_form = scheme_stx_taint_disarm(form, NULL); - - fm = SCHEME_STX_CDR(disarmed_form); - if (!SCHEME_STX_PAIRP(fm)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - nm = SCHEME_STX_CAR(fm); - if (!SCHEME_STX_SYMBOLP(nm)) - scheme_wrong_syntax(NULL, nm, form, "module name is not an identifier"); - fm = SCHEME_STX_CDR(fm); - if (!SCHEME_STX_PAIRP(fm)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - ii = SCHEME_STX_CAR(fm); - fm = SCHEME_STX_CDR(fm); - - orig_ii = ii; - - if (post && SCHEME_FALSEP(SCHEME_STX_VAL(ii))) { - ii = NULL; - ctx_form = disarmed_form; - } else { - /* "Punch a hole" in the enclosing context by removing the - immediately enclosing module context: */ - fm = disarmed_form; - fm = scheme_revert_use_site_scopes(fm, env); - fm = scheme_stx_unintroduce_from_module_context(fm, env->genv->stx_context); - ctx_form = fm; - fm = SCHEME_STX_CDR(fm); - nm = SCHEME_STX_CAR(fm); - fm = SCHEME_STX_CDR(fm); - ii = SCHEME_STX_CAR(fm); - fm = SCHEME_STX_CDR(fm); - super_phase_shift = scheme_make_integer(0); - orig_ii = ii; - } - - if (!SCHEME_STXP(fm)) - fm = scheme_datum_to_syntax(fm, scheme_false, scheme_false, 0, 0); - - m = MALLOC_ONE_TAGGED(Scheme_Module); - m->so.type = scheme_module_type; - m->predefined = scheme_starting_up; - m->phaseless = (scheme_starting_up ? scheme_true : NULL); - - /* must set before calling new_module_env: */ - rmp = SCHEME_STX_VAL(nm); - rmp = scheme_intern_resolved_module_path(rmp); - m->modname = rmp; - if (super_bxs) - m->modsrc = super_bxs->modsrc; - else - m->modsrc = rmp; - - if (!SCHEME_NULLP(submodule_ancestry)) - submodule_path = scheme_append(submodule_path, scheme_make_pair(SCHEME_STX_VAL(nm), scheme_null)); - m->submodule_ancestry = submodule_ancestry; - m->submodule_path = submodule_path; - - if (!SCHEME_NULLP(submodule_path)) { - Scheme_Object *self_name; - self_name = scheme_resolved_module_path_value(extract_root_module_name(m)); - self_name = scheme_intern_resolved_module_path(scheme_make_pair(self_name, submodule_path)); - m->modname = self_name; - } - - LOG_START_EXPAND(m); - - if (SAME_OBJ(m->modname, kernel_modname) - || SAME_OBJ(m->modname, unsafe_modname) - || SAME_OBJ(m->modname, flfxnum_modname) - || SAME_OBJ(m->modname, extfl_modname) - || SAME_OBJ(m->modname, futures_modname) - || SAME_OBJ(m->modname, foreign_modname)) { - /* Too confusing. Give it a different name while compiling. */ - Scheme_Object *k2; - const char *kname; - if (SAME_OBJ(m->modname, kernel_modname)) - kname = "#%kernel"; - else if (SAME_OBJ(m->modname, flfxnum_modname)) - kname = "#%flfxnum"; - else if (SAME_OBJ(m->modname, extfl_modname)) - kname = "#%extfl"; - else if (SAME_OBJ(m->modname, futures_modname)) - kname = "#%futures"; - else if (SAME_OBJ(m->modname, foreign_modname)) - kname = "#%foreign"; - else - kname = "#%unsafe"; - k2 = scheme_intern_resolved_module_path(scheme_make_symbol(kname)); /* uninterned! */ - restore_confusing_name = m->modname; - m->modname = k2; - } - - { - Scheme_Module_Exports *me; - me = scheme_make_module_exports(); - m->me = me; - me->modsrc = m->modsrc; - } - - top_env = env->genv; - /* Create module env from phase-0 env. This doesn't create bad - sharing, because compile-time module instances for compiling this - module are all fresh instances. */ - while (top_env->phase) { - scheme_prepare_template_env(top_env); - top_env = top_env->template_env; - } - - /* Create module environment. This environment gets a fresh table - for phase-1 instances: */ - menv = scheme_new_module_env(top_env, m, 1, SCHEME_NULLP(submodule_ancestry)); - - menv->disallow_unbound = 1; - - self_modidx = scheme_make_modidx(scheme_false, scheme_false, m->modname); - m->self_modidx = self_modidx; - m->me->src_modidx = self_modidx; - - m->insp = env->insp; - - if (ii) { - m->ii_src = ii; - - ii = scheme_syntax_to_datum(ii, 0, NULL); - - if (!scheme_is_module_path(ii)) { - scheme_wrong_syntax(NULL, m->ii_src, form, "initial import is not a well-formed module path"); - } - - iidx = scheme_make_modidx(ii, - self_modidx, - scheme_false); - } else { - void **super_bxs_info; - Scheme_Object *shift; - - iidx = scheme_make_modidx(scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string(".."), - scheme_null)), - self_modidx, - scheme_false); - - shift = scheme_make_pair(iidx, *super_bxs->sub_iidx_ptrs); - *super_bxs->sub_iidx_ptrs = shift; - - super_phase_shift = scheme_bin_minus(scheme_make_integer(0), super_phase_shift); - - shift = scheme_make_shift(super_phase_shift, - top_env->module->self_modidx, iidx, - menv->module_registry->exports, - m->insp, m->insp); - - super_bxs_info = MALLOC_N(void*, 6); - super_bxs_info[0] = super_bxs; - super_bxs_info[1] = shift; - super_bxs_info[2] = top_env->module->self_modidx; - super_bxs_info[3] = iidx; - super_bxs_info[4] = top_env; - super_bxs_info[5] = super_phase_shift; - m->super_bxs_info = super_bxs_info; - } - - sub_iidx_ptrs = MALLOC_N(Scheme_Object*, 1); - *sub_iidx_ptrs = scheme_null; - m->sub_iidx_ptrs = sub_iidx_ptrs; - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer); - } - - /* load the module for the initial require */ - if (iidx) { - iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL); - start_module(iim, find_env(menv, SCHEME_INT_VAL(super_phase_shift)), 0, iidx, 1, 0, menv->phase, scheme_null, 0); - } else - iim = NULL; - - m->requires = scheme_null; - m->et_requires = scheme_null; - m->tt_requires = scheme_null; - m->dt_requires = scheme_null; - - if (iim && iim->phaseless) - m->phaseless = scheme_true; - - if (iidx) { - Scheme_Object *ins; - ins = cons(iidx, scheme_null); - if (SAME_OBJ(super_phase_shift, scheme_make_integer(0))) { - m->requires = ins; - } else if (SAME_OBJ(super_phase_shift, scheme_make_integer(-1))) { - m->tt_requires = ins; - } else { - Scheme_Hash_Table *oht; - oht = m->other_requires; - if (!oht) { - oht = scheme_make_hash_table_eqv(); - m->other_requires = oht; - } - scheme_hash_set(oht, super_phase_shift, ins); - } - } - - scheme_prepare_env_stx_context(menv); - - rn_set = menv->stx_context; - - { - Scheme_Object *insp; - menv->access_insp = env->insp; - insp = scheme_make_inspector(env->insp); - menv->guard_insp = insp; - } - - scheme_prepare_exp_env(menv); - - /* Allow phase-1 references to unbound identifiers; we check - at the end of body expansion to make sure that all referenced - identifiers were eventually bound. Meanwhile, - reference-before-definition errors are possible. */ - menv->exp_env->disallow_unbound = -1; - - mb_ctx = scheme_false; - - /* For each provide in iim, add a module rename to fm */ - orig_ii = scheme_stx_add_module_context(orig_ii, rn_set); - if (ii) { - saw_mb = add_simple_require_renames(orig_ii, rn_set, menv, NULL, iim, iidx, scheme_make_integer(0), - NULL, 1, 0); - mb_ctx = scheme_datum_to_syntax(scheme_false, scheme_false, orig_ii, 0, 0); - } else { - Scheme_Object *shift; - shift = (Scheme_Object *)m->super_bxs_info[1]; - fm = scheme_stx_add_shift(fm, shift); - mb_ctx = scheme_stx_add_shift(ctx_form, shift); - orig_ii = scheme_stx_add_shift(orig_ii, shift); - shift_back = 1; - /* there must be a `#%module-begin' in the enclosing module; if it's - shadowed, then we want a different error message than the one for - saw_mb == 0 */ - saw_mb = 1; - } - - m->ii_src = orig_ii; - - { - Scheme_Object *frame_scopes; - frame_scopes = scheme_module_context_frame_scopes(rn_set, NULL); - if (rec[drec].comp) - benv = scheme_new_comp_env(menv, env->insp, frame_scopes, - SCHEME_MODULE_BEGIN_FRAME | SCHEME_KEEP_SCOPES_FRAME); - else - benv = scheme_new_expand_env(menv, env->insp, frame_scopes, - SCHEME_MODULE_BEGIN_FRAME | SCHEME_KEEP_SCOPES_FRAME); - benv->observer = env->observer; - } - - /* If fm isn't a single expression, it certainly needs a - `#%module-begin': */ - if (SCHEME_STX_PAIRP(fm) && SCHEME_STX_NULLP(SCHEME_STX_CDR(fm))) { - /* Perhaps expandable... */ - fm = SCHEME_STX_CAR(fm); - check_not_tainted(fm); - } else { - fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 2), - fm); - check_mb = 1; - } - - fm = scheme_datum_to_syntax(fm, form, mb_ctx, 0, 2); - - if (!rec[drec].comp) { - if (check_mb) { - SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm); - } - } - - fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp)); - - this_empty_self_modidx = scheme_get_submodule_empty_self_modidx(submodule_path, 1); - - /* phase shift to replace self_modidx of previous expansion: */ - fm = scheme_stx_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, - m->insp, m->insp); - if (m->ii_src) { - /* shift the initial import to record the chain for rn_stx */ - ii = scheme_stx_shift(m->ii_src, NULL, this_empty_self_modidx, self_modidx, NULL, - m->insp, m->insp); - m->ii_src = ii; - } - - fm = scheme_stx_add_module_frame_context(fm, rn_set); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm); - } - - if (!check_mb) { - fm = scheme_check_immediate_macro(fm, benv, rec, drec, &mbval, 1); - - /* If expansion is not the primitive `#%module-begin', add local one: */ - if (!SAME_OBJ(mbval, modbeg_syntax)) { - Scheme_Object *mb; - mb = scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 0); - fm = scheme_make_pair(mb, scheme_make_pair(fm, scheme_null)); - fm = scheme_datum_to_syntax(fm, form, mb_ctx, 0, 2); - fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp)); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm); - } - - check_mb = 1; - } - } - - if (check_mb && !saw_mb) { - scheme_wrong_syntax(NULL, NULL, form, - "no #%%module-begin binding in the module's language"); - } - - if (rec[drec].comp) { - Scheme_Object *dummy, *pv; - - dummy = scheme_make_environment_dummy(env); - m->dummy = dummy; - - scheme_compile_rec_done_local(rec, drec); - fm = scheme_compile_expr(fm, benv, rec, drec); - - /* result should be a module body value: */ - if (!SAME_OBJ(fm, (Scheme_Object *)m)) { - scheme_wrong_syntax(NULL, NULL, form, "expansion of #%%module-begin is not a #%%plain-module-begin form"); - } - - if (restore_confusing_name) - m->modname = restore_confusing_name; - - m->ii_src = NULL; - m->super_bxs_info = NULL; - m->sub_iidx_ptrs = NULL; - - pv = scheme_stx_property(form, scheme_intern_symbol("module-language"), NULL); - if (pv && SCHEME_TRUEP(pv)) { - if (SCHEME_VECTORP(pv) - && (3 == SCHEME_VEC_SIZE(pv)) - && scheme_is_module_path(SCHEME_VEC_ELS(pv)[0]) - && SCHEME_SYMBOLP(SCHEME_VEC_ELS(pv)[1])) - m->lang_info = pv; - } - - fm = (Scheme_Object *)m; - } else { - Scheme_Object *hints, *formname, *ps; - Scheme_Object *shift; - - fm = scheme_expand_expr(fm, benv, rec, drec); - - if (shift_back) { - shift = (Scheme_Object *)m->super_bxs_info[5]; - fm = scheme_stx_add_shift(fm, scheme_bin_minus(scheme_make_integer(0), shift)); - } - - m->ii_src = NULL; - m->super_bxs_info = NULL; - m->sub_iidx_ptrs = NULL; - - hints = m->hints; - m->hints = NULL; - - formname = SCHEME_STX_CAR(disarmed_form); - fm = cons(formname, - cons(nm, - cons(orig_ii, - cons(fm, scheme_null)))); - - fm = scheme_datum_to_syntax(fm, form, ctx_form, 0, 2); - - /* for future expansion, shift away from self_modidx: */ - ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL); - fm = scheme_stx_add_shift(fm, ps); - - if (hints) { - Scheme_Object *stx, *l; - - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-requires"), - m->requires); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-for-syntax-requires"), - m->et_requires); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-for-template-requires"), - m->tt_requires); - - l = scheme_null; - if (!SCHEME_NULLP(m->dt_requires)) - l = scheme_make_pair(scheme_make_pair(scheme_false, m->dt_requires), - l); - if (m->other_requires) { - int i; - for (i = 0; i < m->other_requires->size; i++) { - if (m->other_requires->vals[i]) { - l = scheme_make_pair(scheme_make_pair(m->other_requires->keys[i], - m->other_requires->vals[i]), - l); - } - } - } - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-direct-for-meta-requires"), - l); - - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-variable-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-syntax-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-indirect-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-indirect-for-meta-provides"), - SCHEME_CAR(hints)); - hints = SCHEME_CDR(hints); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-kernel-reprovide-hint"), - SCHEME_CAR(hints)); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-self-path-index"), - this_empty_self_modidx); - - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-body-context-simple?"), - (SAME_OBJ(scheme_true, m->rn_stx) - ? scheme_true - : scheme_false)); - - stx = scheme_datum_to_syntax(scheme_intern_symbol("inside"), scheme_false, scheme_false, 0, 0); - stx = scheme_stx_add_module_context(stx, rn_set); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-body-context"), - scheme_stx_add_shift(stx, ps)); - - stx = scheme_datum_to_syntax(scheme_intern_symbol("outside"), scheme_false, scheme_false, 0, 0); - stx = scheme_stx_introduce_to_module_context(stx, rn_set); - fm = scheme_stx_property(fm, - scheme_intern_symbol("module-body-inside-context"), - scheme_stx_add_shift(stx, ps)); - } - - /* make self_modidx like the empty modidx; this update plays the - role of applying a shift to identifiers that are in syntax - properties, such as the 'origin property */ - if (SAME_OBJ(this_empty_self_modidx, empty_self_modidx)) - ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname; - else - ((Scheme_Modidx *)self_modidx)->resolved = ((Scheme_Modidx *)this_empty_self_modidx)->resolved; - - while (SCHEME_PAIRP(*sub_iidx_ptrs)) { - /* Each in `*sub_iidx_ptrs` corresponds to the implicit `..` import for - a `(module* name #f ...)` submodule: */ - ((Scheme_Modidx *)SCHEME_CAR(*sub_iidx_ptrs))->resolved = ((Scheme_Modidx *)self_modidx)->resolved; - *sub_iidx_ptrs = SCHEME_CDR(*sub_iidx_ptrs); - } - } - - if (rec[drec].comp || (rec[drec].depth != -2)) { - /* rename tables no longer needed; NULL them out */ - menv->stx_context = NULL; - } - - m->submodule_ancestry = NULL; /* ancestry no longer needed; NULL to avoid leak */ - - LOG_END_EXPAND(m); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm); - } - return fm; -} - -static Scheme_Object * -module_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_module(form, env, rec, drec, scheme_null, scheme_null, 0, - NULL, scheme_make_integer(0)); -} - -static Scheme_Object * -module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return do_module(form, env, erec, drec, scheme_null, scheme_null, 0, - NULL, scheme_make_integer(0)); -} - -static Scheme_Object * -modulestar_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not in a module top-level)"); - return NULL; -} - -static Scheme_Object * -modulestar_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return modulestar_compile(form, env, erec, drec); -} - -/* For mzc: */ -Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *env) -{ - Scheme_Comp_Env *rhs_env; - Scheme_Dynamic_State dyn_state; - - rhs_env = scheme_new_comp_env(env, NULL, NULL, SCHEME_TOPLEVEL_FRAME); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, - env, (env->link_midx - ? env->link_midx - : (env->module - ? env->module->me->src_modidx - : NULL))); - - return scheme_apply_multi_with_dynamic_state(proc, 0, NULL, &dyn_state); -} - -Scheme_Object *scheme_prune_bindings_table(Scheme_Object *binding_names, Scheme_Object *rn_stx, Scheme_Object *phase) -{ - int dropped = 0; - intptr_t i; - Scheme_Object *k, *val, *base_stx; - Scheme_Hash_Tree *ht; - - ht = scheme_make_hash_tree(SCHEME_hashtr_eq); - - base_stx = scheme_stx_add_module_context(scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0), - scheme_module_context_at_phase(scheme_stx_to_module_context(rn_stx), - phase)); - - if (SCHEME_HASHTRP(binding_names)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)binding_names; - for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) { - scheme_hash_tree_index(t, i, &k, &val); - if (!scheme_stx_could_bind(val, - scheme_datum_to_syntax(k, scheme_false, base_stx, 0, 0), - phase)) { - dropped = 1; - val = scheme_true; - } - ht = scheme_hash_tree_set(ht, k, val); - } - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)binding_names; - for (i = t->size; i--; ) { - if (t->vals[i]) { - k = t->keys[i]; - val = t->vals[i]; - if (!scheme_stx_could_bind(val, - scheme_datum_to_syntax(k, scheme_false, base_stx, 0, 0), - phase)) { - dropped = 1; - val = scheme_true; - } - ht = scheme_hash_tree_set(ht, k, val); - } - } - } - - if (dropped) - return (Scheme_Object *)ht; - else - return binding_names; -} - -/**********************************************************************/ -/* #%module-begin */ -/**********************************************************************/ - -static void check_require_name(Scheme_Object *id, Scheme_Object *self_modidx, - Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, - Scheme_Object *modidx, Scheme_Object *exname, int exet, - int isval, void *tables, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *scope_src, - Scheme_Object *phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) -{ - Scheme_Hash_Table *required; - Scheme_Object *vec, *nml, *tvec, *binding; - - tvec = scheme_hash_get((Scheme_Hash_Table *)tables, phase); - if (!tvec) { - required = get_required_from_tables(tables, phase); - } else { - required = (Scheme_Hash_Table *)(SCHEME_VEC_ELS(tvec)[1]); - } - - if (!scheme_hash_get(required, SCHEME_STX_VAL(id))) { - /* no mapping so far means that we haven't imported anything - with this name so far, and we'll be able to use a symbol - as a key; see require_binding_to_key() */ - binding = SCHEME_STX_VAL(id); - } else { - /* Look for import collisions by checking whether `id` has a binding; - if so, then check whether that binding matches an import that - we have already. If it has a binding and it's not the same binding, - then it's an import conflict. If it's the same bindig, we keep - track of all the imports of the binding. */ - binding = scheme_stx_lookup_exact(id, phase); - if (SCHEME_FALSEP(binding)) { - /* not defined */ - binding = NULL; - } else { - if (!SCHEME_VECTORP(binding) - || (SCHEME_VECTORP(binding) - && self_modidx - && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], self_modidx))) { - scheme_wrong_syntax("module", id, form, "imported identifier already defined"); - return; - } else if (SCHEME_VECTORP(binding) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], exname) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], scheme_make_integer(exet)) - && same_resolved_modidx(SCHEME_VEC_ELS(binding)[0], modidx)) { - /* import is redundant, but may add new nominal info */ - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - } else { - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - if (scheme_hash_get(required, binding)) { - /* use error report or override below */ - } else { - /* identifier has a binding in some context, but not within the current module */ - binding = NULL; - } - } - } - - if (!binding) { - if (!scheme_hash_get(required, SCHEME_STX_VAL(id))) { - /* we can just use a symbol as a key, since it's not mapped - so far */ - binding = SCHEME_STX_VAL(id); - } else { - /* generate a binding vector: */ - binding = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(binding)[0] = modidx; - SCHEME_VEC_ELS(binding)[1] = exname; - SCHEME_VEC_ELS(binding)[2] = scheme_make_integer(exet); - /* convert to a general key: */ - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - } - } - } - - if (!SAME_OBJ(src_phase_index, scheme_make_integer(0)) - || !SAME_OBJ(nominal_export_phase, scheme_make_integer(0)) - || !SAME_OBJ(nominal_name, SCHEME_STX_VAL(id))) { - nominal_modidx = scheme_make_pair(nominal_modidx, - scheme_make_pair(src_phase_index, - scheme_make_pair(nominal_name, - scheme_make_pair(nominal_export_phase, - scheme_null)))); - } - - vec = scheme_hash_get(required, binding); - if (vec) { - Scheme_Object *srcs; - char *fromsrc = NULL, *fromsrc_colon = "", *phase_expl; - intptr_t fromsrclen = 0; - - if (same_resolved_modidx(SCHEME_VEC_ELS(vec)[1], modidx) - && SAME_OBJ(SCHEME_VEC_ELS(vec)[2], exname) - && SAME_OBJ(SCHEME_VEC_ELS(vec)[8], scheme_make_integer(exet))) { - /* already required, same source; add redundant nominal (for re-provides), - and also add source phase for re-provides. */ - nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = nml; - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7]) - && prep_required_id(vec) - && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, phase)) - SCHEME_VEC_ELS(vec)[7] = scheme_false; - return; - } - - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7]) - && prep_required_id(vec) - && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, phase)) { - /* can override; first, remove old binding mapping: */ - if (SCHEME_SYMBOLP(binding)) - scheme_hash_set(required, binding, scheme_false); - else - scheme_hash_set(required, binding, NULL); - /* construct overriding `binding`: */ - binding = scheme_make_vector(4, NULL); - vec = scheme_module_resolve(modidx, 0); - SCHEME_VEC_ELS(binding)[0] = vec; - SCHEME_VEC_ELS(binding)[1] = exname; - SCHEME_VEC_ELS(binding)[2] = scheme_make_integer(exet); - SCHEME_VEC_ELS(binding)[3] = SCHEME_STX_VAL(id); - } else { - /* error: already imported */ - srcs = scheme_null; - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[5])) { - srcs = scheme_make_pair(SCHEME_VEC_ELS(vec)[5], srcs); - /* don't use error_write_to_string_w_max since this is code */ - if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) { - fromsrc = scheme_write_to_string_w_max(scheme_syntax_to_datum(SCHEME_VEC_ELS(vec)[5], 0, NULL), - &fromsrclen, 32); - fromsrc_colon = ":"; - } - } - - if (!fromsrc) { - fromsrc = "a different source"; - fromsrclen = strlen(fromsrc); - } - - if (err_src) - srcs = scheme_make_pair(err_src, srcs); - - if (SCHEME_FALSEP(phase)) - phase_expl = " for label"; - else if (!SCHEME_INT_VAL(phase)) - phase_expl = ""; - else if (SCHEME_INT_VAL(phase) == 1) - phase_expl = " for syntax"; - else { - char buf[32]; - sprintf(buf, " for phase %" PRIdPTR, SCHEME_INT_VAL(phase)); - phase_expl = scheme_strdup(buf); - } - - scheme_wrong_syntax_with_more_sources("module", id, err_src, srcs, - "identifier already imported%s from%s %t", - phase_expl, - fromsrc_colon, fromsrc, fromsrclen); - } - } - - /* Remember require: */ - vec = scheme_make_vector(9, NULL); - nml = scheme_make_pair(nominal_modidx, scheme_null); - SCHEME_VEC_ELS(vec)[0] = nml; - SCHEME_VEC_ELS(vec)[1] = modidx; - SCHEME_VEC_ELS(vec)[2] = exname; - SCHEME_VEC_ELS(vec)[3] = (isval ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[4] = SCHEME_STX_VAL(id); - SCHEME_VEC_ELS(vec)[5] = (err_src ? err_src : scheme_false); - SCHEME_VEC_ELS(vec)[6] = id; - SCHEME_VEC_ELS(vec)[7] = scheme_false; - SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(exet); - - scheme_hash_set(required, binding, vec); -} - -static int check_already_required(Scheme_Hash_Table *required, - Scheme_Object *id, int phase, - Scheme_Object *binding) -{ - Scheme_Object *vec; - - binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); - - vec = scheme_hash_get(required, binding); - if (vec) { - if (prep_required_id(vec) - && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, scheme_make_integer(phase))) { - scheme_hash_set(required, binding, NULL); - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) - return 0; - return 1; - } - } - - return 0; -} - -static void warn_previously_required(Scheme_Object *modname, Scheme_Object *name) -{ - scheme_log(NULL, SCHEME_LOG_WARNING, 0, - "warning: defined identifier is already imported: %S in module: %D", - SCHEME_STX_VAL(name), - modname); -} - -static int check_already_defined(Scheme_Object *name, Scheme_Env *genv) -{ - return (scheme_lookup_in_table(genv->toplevel, (const char *)name) - || scheme_lookup_in_table(genv->syntax, (const char *)name)); -} - -static void propagate_imports(Module_Begin_Expand_State *bxs, - Module_Begin_Expand_State *super_bxs, - Scheme_Object *rn, - Scheme_Object *from_idx, - Scheme_Object *to_idx, - Scheme_Env *super_genv, - Scheme_Env *genv, - Scheme_Object *phase_shift) -/* Record imports from the enclosing module as imports here, - and record definitions from the enclosing module as imports here. */ -{ - Scheme_Hash_Table *ht, *required, *super_required; - Scheme_Object *phase, *super_key, *name, *super_vec, *vec; - Scheme_Object *l, *v, *super_defs, *key, *val, *binding; - int i, j; - Scheme_Env *super_def_genv; - - ht = super_bxs->tables; - for (i = ht->size; i--; ) { - if (ht->vals[i]) { - phase = ht->keys[i]; - super_required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(ht->vals[i])[1]; - - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_plus(phase, phase_shift); - - required = (Scheme_Hash_Table *)get_required_from_tables(bxs->tables, phase); - - for (j = super_required->size; j--; ) { - if (super_required->vals[j]) { - super_key = super_required->keys[j]; - super_vec = super_required->vals[j]; - - if (SCHEME_TRUEP(super_vec)) { - vec = scheme_make_vector(9, NULL); - - l = SCHEME_VEC_ELS(super_vec)[0]; - v = scheme_null; - while (!SCHEME_NULLP(l)) { - v = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(l), from_idx, to_idx), - v); - l = SCHEME_CDR(l); - } - v = scheme_reverse(v); - SCHEME_VEC_ELS(vec)[0] = v; - - v = scheme_modidx_shift(SCHEME_VEC_ELS(super_vec)[1], from_idx, to_idx); - SCHEME_VEC_ELS(vec)[1] = v; - - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(super_vec)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(super_vec)[3]; - SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(super_vec)[4]; - SCHEME_VEC_ELS(vec)[5] = SCHEME_VEC_ELS(super_vec)[5]; - - if (!SAME_OBJ(phase_shift, scheme_make_integer(0))) - prep_required_id(super_vec); - - v = SCHEME_VEC_ELS(super_vec)[6]; - if (SCHEME_TRUEP(v) && !SAME_OBJ(phase_shift, scheme_make_integer(0))) - v = scheme_stx_add_shift(v, phase_shift); - SCHEME_VEC_ELS(vec)[6] = v; - - SCHEME_VEC_ELS(vec)[7] = scheme_true; /* can be shadowed */ - - SCHEME_VEC_ELS(vec)[8] = SCHEME_VEC_ELS(super_vec)[8]; - } else - vec = scheme_false; - - scheme_hash_set(required, super_key, vec); - } - } - } - } - - i = -1; - while (1) { - i = scheme_hash_tree_next(super_bxs->all_defs, i); - if (i == -1) break; - if (scheme_hash_tree_index(super_bxs->all_defs, i, &key, &val)) { - phase = key; - super_defs = val; - - super_def_genv = find_env(super_genv, SCHEME_INT_VAL(phase)); - - required = (Scheme_Hash_Table *)get_required_from_tables(bxs->tables, - scheme_bin_plus(phase, phase_shift)); - - while (!SCHEME_NULLP(super_defs)) { - name = SCHEME_CAR(super_defs); - super_defs = SCHEME_CDR(super_defs); - - vec = scheme_make_vector(9, NULL); - - v = scheme_make_pair(to_idx, scheme_null); - SCHEME_VEC_ELS(vec)[0] = v; - SCHEME_VEC_ELS(vec)[1] = to_idx; - binding = scheme_stx_lookup_stop_at_free_eq(name, phase, NULL); - if (!SCHEME_VECTORP(binding) - || !SAME_OBJ(phase, SCHEME_VEC_ELS(binding)[2])) - scheme_signal_error("internal error: broken binding of defined id from enclosing module: %V at %V = %V", - name, phase, binding); - v = SCHEME_VEC_ELS(binding)[1]; - SCHEME_VEC_ELS(vec)[2] = v; - if (scheme_lookup_in_table(super_def_genv->toplevel, (char *)v)) - SCHEME_VEC_ELS(vec)[3] = scheme_true; - else - SCHEME_VEC_ELS(vec)[3] = scheme_false; - SCHEME_VEC_ELS(vec)[4] = SCHEME_STX_VAL(name); - SCHEME_VEC_ELS(vec)[5] = name; - if (!SAME_OBJ(phase_shift, scheme_make_integer(0))) - name = scheme_stx_add_shift(name, phase_shift); - SCHEME_VEC_ELS(vec)[6] = name; - SCHEME_VEC_ELS(vec)[7] = scheme_true; /* can be shadowed */ - SCHEME_VEC_ELS(vec)[8] = phase; - - v = require_binding_to_key(required, binding, SCHEME_STX_VAL(name)); - scheme_hash_set(required, v, vec); - } - } - } -} - -Scheme_Object *introduce_to_module_context(Scheme_Object *a, Scheme_Object *rn) -{ - return scheme_stx_introduce_to_module_context(a, rn); -} - -Scheme_Object *reverse_and_introduce_module_context(Scheme_Object *fm, Scheme_Object *rn) -{ - Scheme_Object *l2 = scheme_null; - - while (!SCHEME_NULLP(fm)) { - l2 = scheme_make_pair(introduce_to_module_context(SCHEME_CAR(fm), rn), - l2); - fm = SCHEME_CDR(fm); - } - return l2; -} - -static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv) -{ - name = scheme_stx_lookup_exact(name, scheme_env_phase((Scheme_Env *)_genv)); - return SCHEME_VEC_ELS(name)[1]; -} - -static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires) -{ - for (; !SCHEME_NULLP(imods); imods = SCHEME_CDR(imods)) { - Scheme_Object *il, *ilast = NULL; - Scheme_Object *idx = SCHEME_CAR(imods); - - for (il = requires; SCHEME_PAIRP(il); il = SCHEME_CDR(il)) { - if (same_modidx(idx, SCHEME_CAR(il))) - break; - ilast = il; - } - - if (SCHEME_NULLP(il)) { - il = scheme_make_pair(idx, scheme_null); - if (ilast) - SCHEME_CDR(ilast) = il; - else - requires = il; - } - } - - return requires; -} - -static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *_env) -{ - Scheme_Comp_Env *env; - Scheme_Object *rn, *name, *ids, *id, *new_ids = scheme_null; - - env = (Scheme_Comp_Env *)SCHEME_VEC_ELS(data)[0]; - rn = SCHEME_VEC_ELS(data)[2]; - - for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - - id = introduce_to_module_context(id, rn); - - name = scheme_global_binding(id, env->genv, 0); - - /* Create the bucket, indicating that the name will be defined: */ - scheme_add_global_symbol(name, scheme_undefined, env->genv); - - new_ids = cons(id, new_ids); - } - - new_ids = scheme_reverse(new_ids); - *_ids = new_ids; - - return scheme_make_lifted_defn(scheme_sys_wraps(env), _ids, expr, _env); -} - -static Scheme_Object *shift_require_phase(Scheme_Object *e, Scheme_Object *phase, int can_just_meta) -{ - Scheme_Object *l, *a; - - l = e; - if (SCHEME_STXP(l)) l = scheme_stx_content(l); - if (SCHEME_PAIRP(l)) { - a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = scheme_stx_content(a); - - if (can_just_meta && SAME_OBJ(a, just_meta_symbol)) { - /* Shift any `for-meta` within `just-meta`: */ - l = SCHEME_CDR(l); - if (scheme_proper_list_length(l) >= 1) { - a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = scheme_stx_content(a); - if (SCHEME_FALSEP(a) || SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { - e = scheme_null; - for (l = SCHEME_CDR(l); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - e = scheme_make_pair(shift_require_phase(SCHEME_CAR(l), phase, 0), - e); - } - - e = scheme_reverse(e); - return scheme_make_pair(just_meta_symbol, scheme_make_pair(a, e)); - } else - l = scheme_make_pair(e, scheme_null); - } else - l = scheme_make_pair(e, l); - } else if (SAME_OBJ(a, for_meta_symbol)) { - l = SCHEME_CDR(l); - if (SCHEME_PAIRP(l)) { - a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = scheme_stx_content(a); - if (SCHEME_FALSEP(a)) { - return e; - } else if (SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { - phase = scheme_bin_plus(a, phase); - l = SCHEME_CDR(l); - } else - l = scheme_make_pair(e, scheme_null); - } else - l = scheme_make_pair(e, scheme_null); - } else if (SAME_OBJ(a, for_label_symbol)) { - return e; - } else if (SAME_OBJ(a, for_syntax_symbol)) { - phase = scheme_bin_plus(scheme_make_integer(1), phase); - l = SCHEME_CDR(l); - } else if (SAME_OBJ(a, for_template_symbol)) { - phase = scheme_bin_plus(scheme_make_integer(-1), phase); - l = SCHEME_CDR(l); - } else - l = scheme_make_pair(e, scheme_null); - } else - l = scheme_make_pair(e, scheme_null); - - return scheme_make_pair(for_meta_symbol, - scheme_make_pair(phase, l)); -} - -static Scheme_Object *make_require_form(Scheme_Object *module_path, intptr_t rel_phase, - Scheme_Object *scope, intptr_t scope_phase) -{ - Scheme_Object *e = module_path, *r; - - if (rel_phase != 0) { - e = shift_require_phase(e, scheme_make_integer(rel_phase), 1); - } - if (scope_phase == 0) - r = require_stx; - else { - r = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), - scheme_false, - sys_wraps_phase(scope_phase), - 0, 0); - } - e = scheme_make_pair(r, scheme_make_pair(e, scheme_null)); - e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0); - - e = scheme_stx_add_scope(e, scope, scheme_make_integer(scope_phase)); - - return e; -} - -Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, - intptr_t phase, - Scheme_Object *scope, - void *data, - Scheme_Object **_ref_expr, - Scheme_Comp_Env *cenv) -{ - Scheme_Object *e; - Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1]; - Scheme_Env *env = (Scheme_Env *)((void **)data)[2]; - Scheme_Module *for_m = (Scheme_Module *)((void **)data)[3]; - Scheme_Object *rns = (Scheme_Object *)((void **)data)[4]; - void *tables = ((void **)data)[6]; - Scheme_Object *redef_modname = (Scheme_Object *)((void **)data)[7]; - int *all_simple = (int *)((void **)data)[8]; - Scheme_Hash_Table *submodule_names = (Scheme_Hash_Table *)((void **)data)[9]; - - if (*_ref_expr) { - e = introduce_to_module_context(*_ref_expr, rns); - *_ref_expr = e; - } - - e = make_require_form(module_path, phase - env->phase, scope, env->phase); - e = scheme_revert_use_site_scopes(e, cenv); - e = introduce_to_module_context(e, rns); - - parse_requires(e, env->phase, base_modidx, env, for_m, - rns, - check_require_name, tables, - redef_modname, - 0, - 1, phase ? 1 : 0, - all_simple, - NULL, - submodule_names, - NULL); - - scheme_prepare_compile_env(env); - if (phase > env->phase) { - /* Right-hand side of a `define-syntax`; need to prepare compile-time env */ - scheme_prepare_compile_env(env->exp_env); - } - - return e; -} - -static Scheme_Object *package_require_data(Scheme_Object *base_modidx, - Scheme_Env *env, - Scheme_Module *for_m, - Scheme_Object *rns, - void *data, - Scheme_Object *redef_modname, - int *all_simple, - Scheme_Hash_Table *submodule_names) -{ - void **vals; - - vals = MALLOC_N(void*, 10); - vals[0] = NULL; /* this slot is available */ - vals[1] = base_modidx; - vals[2] = env; - vals[3] = for_m; - vals[4] = rns; - vals[5] = NULL; /* removed argument */ - vals[6] = data; - vals[7] = redef_modname; - vals[8] = all_simple; - vals[9] = submodule_names; - - return scheme_make_raw_pair((Scheme_Object *)vals, NULL); -} - - -static void flush_definitions(Scheme_Env *genv) -{ - if (genv->syntax) { - Scheme_Bucket_Table *t; - t = scheme_make_bucket_table(7, SCHEME_hash_ptr); - genv->syntax = t; - } - if (genv->toplevel) { - Scheme_Bucket_Table *t; - t = scheme_make_bucket_table(7, SCHEME_hash_ptr); - t->with_home = 1; - genv->toplevel = t; - } - - genv->binding_names = NULL; -} - -static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) -{ - int num_phases, *_num_phases, i, exicount, *all_simple_bindings, has_submodules; - Scheme_Hash_Tree *all_defs; - Scheme_Hash_Table *tables, *all_defs_out, *all_provided, *all_reprovided, *modidx_cache; - Scheme_Module_Export_Info **exp_infos, *exp_info; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists, *expanded_l; - Scheme_Env *genv; - Module_Begin_Expand_State *bxs; - Scheme_Expand_Info crec; - - form = scheme_stx_taint_disarm(orig_form, NULL); - - if (!(env->flags & SCHEME_MODULE_BEGIN_FRAME)) - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not a module body)"); - - if (scheme_stx_proper_list_length(form) < 0) - scheme_wrong_syntax(NULL, NULL, form, IMPROPER_LIST_FORM); - - if (!env->genv->module) - scheme_wrong_syntax(NULL, NULL, form, "not currently transforming a module"); - - /* Redefining a module? */ - redef_modname = env->genv->module->modname; - if (!scheme_hash_get(env->genv->module_registry->loaded, redef_modname)) - redef_modname = NULL; - - tables = scheme_make_hash_table_equal(); - - modidx_cache = scheme_make_hash_table_equal(); - - all_provided = scheme_make_hash_table_eqv(); - all_reprovided = scheme_make_hash_table_eqv(); - all_defs = scheme_make_hash_tree(SCHEME_hashtr_eqv); - all_defs_out = scheme_make_hash_table_eqv(); - - rn_set = env->genv->stx_context; - - /* For `module->namespace`: */ - { - Scheme_Object *rn_stx; - rn_stx = scheme_module_context_to_stx(rn_set, env->genv->module->ii_src); - env->genv->module->rn_stx = rn_stx; - } - - /* It's possible that #%module-begin expansion introduces - scoped identifiers for definitions. */ - form = introduce_to_module_context(form, rn_set); - - observer = env->observer; - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form); - } - - _num_phases = MALLOC_ONE_ATOMIC(int); - *_num_phases = 0; - - all_simple_bindings = (int *)scheme_malloc_atomic(sizeof(int)); - *all_simple_bindings = 1; - - if (env->genv->module->super_bxs_info) { - *all_simple_bindings = 0; - } - - bxs = scheme_malloc(sizeof(Module_Begin_Expand_State)); - bxs->tables = tables; - bxs->all_provided = all_provided; - bxs->all_reprovided = all_reprovided; - bxs->all_defs = all_defs; - bxs->all_defs_out = all_defs_out; - bxs->all_simple_bindings = all_simple_bindings; - bxs->_num_phases = _num_phases; - bxs->saved_provides = scheme_null; - bxs->saved_submodules = scheme_null; - bxs->submodule_names = NULL; - bxs->modidx_cache = modidx_cache; - bxs->redef_modname = redef_modname; - bxs->end_statementss = scheme_null; - bxs->modsrc = env->genv->module->modsrc; - bxs->sub_iidx_ptrs = env->genv->module->sub_iidx_ptrs; - - if (env->genv->module->super_bxs_info) { - /* initialize imports that are available for export from the enclosing module's - `all_defs' and `imports' (within `tables'): */ - void **super_bxs_info = env->genv->module->super_bxs_info; - propagate_imports(bxs, - (Module_Begin_Expand_State *)super_bxs_info[0], - (Scheme_Object *)super_bxs_info[1], - (Scheme_Object *)super_bxs_info[2], - (Scheme_Object *)super_bxs_info[3], - (Scheme_Env *)super_bxs_info[4], - env->genv, - (Scheme_Object *)super_bxs_info[5]); - } - - if (!rec[drec].comp) { - /* In expand mode, we need to compile anyway in case of nested modules. */ - crec.comp = 1; - crec.dont_mark_local_use = 0; - crec.resolve_module_ids = 0; - crec.substitute_bindings = 1; - crec.pre_unwrapped = 0; - crec.env_already = 0; - crec.comp_flags = rec[drec].comp_flags; - - if (!env->prefix) { - Comp_Prefix *cp; - cp = MALLOC_ONE_RT(Comp_Prefix); -#ifdef MZTAG_REQUIRED - cp->type = scheme_rt_comp_prefix; -#endif - env->prefix = cp; - } - } - - body_lists = do_module_begin_at_phase(form, env, - rec[drec].comp ? rec : &crec, - rec[drec].comp ? drec : 0, - rec[drec].comp ? NULL : rec, drec, - 0, - scheme_null, - bxs); - num_phases = *_num_phases; - - if (!rec[drec].comp) { - expanded_l = SCHEME_CAR(body_lists); - body_lists = SCHEME_CDR(body_lists); - } else - expanded_l = body_lists; - - /* Compute provides for re-provides and all-defs-out: */ - (void)compute_reprovides(all_provided, - all_reprovided, - env->genv->module, - tables, - env->genv, - num_phases, - bxs->all_defs, all_defs_out, - "require", NULL, NULL); - - exp_infos = MALLOC_N(Scheme_Module_Export_Info*, num_phases); - for (i = 0; i < num_phases; i++) { - exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); - SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); - exp_infos[i] = exp_info; - } - - /* Compute provide arrays */ - compute_provide_arrays(all_provided, tables, - env->genv->module->me, - env->genv, - form, - num_phases, exp_infos); - - /* Compute indirect provides (which is everything at the top-level): */ - genv = env->genv; - for (i = 0; i < num_phases; i++) { - switch (i) { - case 0: - pt = env->genv->module->me->rt; - break; - case 1: - pt = env->genv->module->me->et; - break; - default: - if (env->genv->module->me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->genv->module->me->other_phases, - scheme_make_integer(i)); - else - pt = NULL; - break; - } - if (pt) { - exis = compute_indirects(genv, pt, &exicount, 1); - exp_infos[i]->indirect_provides = exis; - exp_infos[i]->num_indirect_provides = exicount; - exis = compute_indirects(genv, pt, &exicount, 0); - exp_infos[i]->indirect_syntax_provides = exis; - exp_infos[i]->num_indirect_syntax_provides = exicount; - } - genv = genv->exp_env; - } - - has_submodules = (!SCHEME_NULLP(bxs->saved_submodules) - || (env->genv->module->submodule_path - && !SCHEME_NULLP(env->genv->module->submodule_path))); - - if (!rec[drec].comp) { - Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt; - int excount = rt->num_provides; - int exvcount = rt->num_var_provides; - Scheme_Object **exsns = rt->provide_src_names; - Scheme_Object **exs = rt->provides; - Scheme_Object **exss = rt->provide_srcs; - - /* Produce annotations (in the form of properties) - for module information: - 'module-variable-provides = '(item ...) - 'module-syntax-provides = '(item ...) - 'module-indirect-provides = '(id ...) - 'module-indirect-for-meta-provides = '((phase id ...) ...) - 'module-kernel-reprovide-hint = 'kernel-reexport - - item = name - | (ext-id . def-id) - | (modidx ext-id . def-id) - kernel-reexport = #f - | #t - | exclusion-id - */ - int j, k; - Scheme_Object *e, *a, *result; - - result = scheme_null; - - /* kernel re-export info (now always #f): */ - result = scheme_make_pair(scheme_false, result); - - /* Indirect provides for phases other than 0 */ - e = scheme_null; - for (k = num_phases; k--; ) { - if (exp_infos[k]->num_indirect_provides) { - a = scheme_null; - for (j = exp_infos[k]->num_indirect_provides; j--; ) { - a = scheme_make_pair(exp_infos[k]->indirect_provides[j], a); - } - a = scheme_make_pair(scheme_make_integer(k), a); - e = scheme_make_pair(a, e); - } - } - result = scheme_make_pair(e, result); - - /* Indirect provides */ - a = scheme_null; - for (j = exp_infos[0]->num_indirect_provides; j--; ) { - a = scheme_make_pair(exp_infos[0]->indirect_provides[j], a); - } - result = scheme_make_pair(a, result); - - /* add syntax and value exports: */ - for (j = 0; j < 2; j++) { - int top, i; - - e = scheme_null; - - if (!j) { - i = exvcount; - top = excount; - } else { - i = 0; - top = exvcount; - } - - for (; i < top; i++) { - if (SCHEME_FALSEP(exss[i]) - && SAME_OBJ(exs[i], exsns[i])) - a = exs[i]; - else { - a = scheme_make_pair(exs[i], exsns[i]); - if (!SCHEME_FALSEP(exss[i])) { - a = scheme_make_pair(exss[i], a); - } - } - e = scheme_make_pair(a, e); - } - result = scheme_make_pair(e, result); - } - - env->genv->module->hints = result; - } - - if (rec[drec].comp || has_submodules) { - Scheme_Object *a, **bodies; - - bodies = MALLOC_N(Scheme_Object*, num_phases); - for (i = 0; i < num_phases; i++) { - a = SCHEME_CAR(body_lists); - if (i > 0) a = scheme_reverse(a); - a = scheme_list_to_vector(a); - bodies[i] = a; - body_lists = SCHEME_CDR(body_lists); - } - env->genv->module->bodies = bodies; - env->genv->module->num_phases = num_phases; - - env->genv->module->exp_infos = exp_infos; - - if (!*all_simple_bindings) { - /* No need to keep indirect syntax provides */ - for (i = 0; i < num_phases; i++) { - exp_infos[i]->indirect_syntax_provides = NULL; - exp_infos[i]->num_indirect_syntax_provides = 0; - } - } - - if (*all_simple_bindings && env->genv->module->rn_stx && rec[drec].comp) { - /* We will be able to reconstruct binding for `module->namespace`: */ - env->genv->module->rn_stx = scheme_true; - } else { - Scheme_Env *bnenv = env->genv; - env->genv->module->binding_names = bnenv->binding_names; - if (bnenv->exp_env) { - bnenv = bnenv->exp_env; - env->genv->module->et_binding_names = bnenv->binding_names; - for (bnenv = bnenv->exp_env; bnenv; bnenv = bnenv->exp_env) { - add_binding_names_from_environment(env->genv->module, bnenv); - } - bnenv = env->genv; - } - for (bnenv = bnenv->template_env; bnenv; bnenv = bnenv->template_env) { - add_binding_names_from_environment(env->genv->module, bnenv); - } - } - } else { - /* For a property on the expanded module: */ - if (*all_simple_bindings && env->genv->module->rn_stx) { - /* We will be able to reconstruct binding for `module->namespace`: */ - env->genv->module->rn_stx = scheme_true; - } - } - - if (rec[drec].comp || has_submodules) { - Scheme_Object *dummy; - dummy = scheme_make_environment_dummy(env); - env->genv->module->dummy = dummy; - } - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_NEXT(observer); - } - - /* Submodules */ - if (has_submodules) { - Scheme_Object *expanded_modules, *root_module_name; - - root_module_name = extract_root_module_name(env->genv->module); - - /* Need to declare the just-finished module, so it can be - referenced by nested modules: */ - { - Optimize_Info *oi; - Resolve_Prefix *rp; - Resolve_Info *ri; - Scheme_Object *o; - int max_let_depth; - int use_jit; - - /* Since we optimize & resolve the module here, it won't need to - be optimized and resolved later. The resolve pass - sets m->comp_prefix to NULL, which is how optimize & resolve - know to avoid re-optimizing and re-resolving. */ - - /* Note: don't use MZCONFIG_USE_JIT for module bodies */ - use_jit = scheme_startup_use_jit; - - o = scheme_letrec_check_expr((Scheme_Object *)env->genv->module); - - oi = scheme_optimize_info_create(env->prefix, env->genv, env->insp, 1); - scheme_optimize_info_enforce_const(oi, rec[drec].comp_flags & COMP_ENFORCE_CONSTS); - if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - o = scheme_optimize_expr(o, oi, 0); - - rp = scheme_resolve_prefix(0, env->prefix, env->insp); - ri = scheme_resolve_info_create(rp); - scheme_resolve_info_enforce_const(ri, rec[drec].comp_flags & COMP_ENFORCE_CONSTS); - - o = scheme_resolve_expr(o, ri); - max_let_depth = scheme_resolve_info_max_let_depth(ri); - o = scheme_sfs(o, NULL, max_let_depth); - - if (use_jit) - o = scheme_jit_expr(o); - else - o = scheme_eval_clone(o); - - (void)do_module_execute(o, env->genv, 0, 1, root_module_name, NULL); - } - - if (!rec[drec].comp && (is_modulestar_stop(env))) { - Scheme_Object *l = bxs->saved_submodules; - expanded_modules = NULL; - while (!SCHEME_NULLP(l)) { - expanded_modules = scheme_make_pair(SCHEME_CAR(SCHEME_CAR(l)), - expanded_modules); - l = SCHEME_CDR(l); - } - bxs->saved_submodules = scheme_null; - } else - expanded_modules = expand_submodules(rec, drec, env, bxs->saved_submodules, 1, bxs, !rec[drec].comp); - - if (!rec[drec].comp) { - (void)fixup_expanded(expanded_l, expanded_modules, 0, MODULE_MODFORM_KIND); - } - } - - /* Return module or expanded code: */ - if (rec[drec].comp) { - return (Scheme_Object *)env->genv->module; - } else { - Scheme_Object *p; - - if (rec[drec].depth == -2) { - /* This was a local expand. Flush definitions, because the body expand may start over. */ - Scheme_Env *f_genv = env->genv; - while (f_genv) { - flush_definitions(f_genv); - f_genv = f_genv->exp_env; - } - } - - p = SCHEME_STX_CAR(form); - - return scheme_datum_to_syntax(cons(p, expanded_l), orig_form, orig_form, 0, 2); - } -} - -static Scheme_Object *get_higher_phase_lifts(Module_Begin_Expand_State *bxs, - Scheme_Object *begin_for_syntax_stx) -{ - Scheme_Object *p, *e, *fm = scheme_null, *bfs; - - if (SCHEME_PAIRP(bxs->end_statementss)) { - /* No other ends, so start shitfing higher-phase ends into `b-f-s': */ - int depth = 1; - for (p = bxs->end_statementss; SCHEME_PAIRP(p); p = SCHEME_CDR(p), depth++) { - if (SCHEME_PAIRP(SCHEME_CAR(p))) - break; - } - if (SCHEME_PAIRP(p)) { - /* wrap `depth' `begin-for-syntaxes' around SCHEME_CAR(p): */ - int di; - e = scheme_reverse(SCHEME_CAR(p)); - bfs = scheme_datum_to_syntax(SCHEME_STX_VAL(begin_for_syntax_stx), scheme_false, sys_wraps_phase(depth-1), 0, 0); - e = scheme_make_pair(bfs, e); - for (di = 1; di < depth; di++) { - bfs = scheme_datum_to_syntax(SCHEME_STX_VAL(begin_for_syntax_stx), scheme_false, sys_wraps_phase(depth-di-1), 0, 0); - e = scheme_make_pair(bfs, scheme_make_pair(e, scheme_null)); - } - fm = scheme_make_pair(scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0), - scheme_null); - /* first `depth' end-statement lists are now empty: */ - p = SCHEME_CDR(p); - for (di = 0; di < depth; di++) { - p = scheme_make_pair(scheme_null, p); - } - bxs->end_statementss = p; - } else - bxs->end_statementss = scheme_null; - } - - return fm; -} - -static Scheme_Object *revert_use_site_scopes_via_context(Scheme_Object *o, Scheme_Object *rn_set, intptr_t phase) -{ - return scheme_stx_adjust_module_use_site_context(o, - rn_set, - SCHEME_STX_REMOVE); -} - -static Scheme_Object *handle_submodule_form(const char *who, - Scheme_Object *e, - Scheme_Comp_Env *env, int phase, - Scheme_Object *rn_set, Scheme_Object *observer, - Module_Begin_Expand_State *bxs, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Compile_Expand_Info *erec, int derec, - int *_kind) -{ - Scheme_Object *name = NULL, *fst, *p; - int is_star; - - fst = SCHEME_STX_CAR(e); - - is_star = scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase); - - e = revert_use_site_scopes_via_context(e, rn_set, phase); - - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - if (is_star) { - SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer); - } else { - SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer); - } - } - - if (SCHEME_STX_PAIRP(e)) { - p = SCHEME_STX_CDR(e); - if (SCHEME_STX_PAIRP(p)) { - name = SCHEME_STX_CAR(p); - p = SCHEME_STX_CDR(p); - if (!SCHEME_STX_SYMBOLP(name) - || !SCHEME_STX_PAIRP(p)) { - name = NULL; - } - } - } - if (!name) { - scheme_wrong_syntax(who, NULL, e, NULL); - } - - if (!bxs->submodule_names) { - Scheme_Hash_Table *smn; - smn = scheme_make_hash_table(SCHEME_hash_ptr); - bxs->submodule_names = smn; - } - if (scheme_hash_get(bxs->submodule_names, SCHEME_STX_VAL(name))) { - scheme_wrong_syntax(who, name, fst, "duplicate submodule definition"); - } - scheme_hash_set(bxs->submodule_names, - SCHEME_STX_VAL(name), - is_star ? scheme_void : scheme_true); - - if (!is_star) { - p = expand_submodules(erec ? erec : rec, erec ? derec :drec, env, - scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), scheme_null), 0, - bxs, !!erec); - if (erec) - e = SCHEME_CAR(p); - else - e = NULL; - *_kind = DONE_MODFORM_KIND; - } else { - p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), - bxs->saved_submodules); - bxs->saved_submodules = p; - *_kind = MODULE_MODFORM_KIND; - } - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e); - } - - return e; -} - -static Scheme_Object *do_module_begin_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - void **args = p->ku.k.p1; - Scheme_Object *form = (Scheme_Object *)args[0]; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)args[1]; - Scheme_Compile_Expand_Info *rec = (Scheme_Compile_Expand_Info *)args[2]; - Scheme_Compile_Expand_Info *erec = (Scheme_Compile_Expand_Info *)args[3]; - int phase = SCHEME_INT_VAL((Scheme_Object *)args[4]); - Scheme_Object *body_lists = (Scheme_Object *)args[5]; - Module_Begin_Expand_State *bxs = (Module_Begin_Expand_State *)args[6]; - - p->ku.k.p1 = NULL; - - return do_module_begin_at_phase(form, env, rec, 0, erec, 0, - phase, body_lists, bxs); -} - -static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Compile_Expand_Info *erec, int derec, - int phase, - Scheme_Object *body_lists, /* starts from phase + 1; null in expand mode */ - Module_Begin_Expand_State *bxs) -/* Result in expand mode is expressions in order. - Result in compile mode is a body_lists starting with `phase', - where a body_lists has each phase in order, with each list after the first in reverse order. - If both rec[drec].comp && erec, cons results. - If !rec[drec].comp, then erec is non-NULL. */ -{ - Scheme_Object *fm, *first, *last, *p, *rn_set, *exp_body, *self_modidx, *prev_p; - Scheme_Object *expanded_l; - Scheme_Comp_Env *xenv, *cenv, *rhs_env; - Scheme_Hash_Table *required; /* name -> (vector nominal-modidx-list modidx srcname var? prntname) - first nominal-modidx goes with modidx, rest are for re-provides */ - Scheme_Hash_Table *provided; /* exname -> (cons locname-stx-or-sym protected?) */ - Scheme_Object *all_rt_defs; /* list of stxid; this is almost redundant to the syntax and toplevel - tables, but it preserves the original name for exporting */ - Scheme_Hash_Tree *adt; - Scheme_Object *lift_data; - Scheme_Object *lift_ctx; - Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; - int maybe_has_lifts = 0, expand_ends = (phase == 0), non_phaseless, requested_phaseless; - int requested_empty_namespace; - Scheme_Object *observer, *vec, *end_statements; - Scheme_Object *begin_for_syntax_stx, *non_phaseless_form = NULL; - const char *who = "module"; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *pt = scheme_current_thread; - Scheme_Compile_Expand_Info *recx, *erecx; - void **args; - - if (rec) { - recx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); - } else - recx = NULL; - - if (erec) { - erecx = MALLOC_ONE_ATOMIC(Scheme_Compile_Expand_Info); - memcpy(erecx, erec + derec, sizeof(Scheme_Compile_Expand_Info)); - } else - erecx = NULL; - - args = MALLOC_N(void*, 7); - - args[0] = form; - args[1] = env; - args[2] = recx; - args[3] = erecx; - args[4] = scheme_make_integer(phase); - args[5] = body_lists; - args[6] = bxs; - - pt->ku.k.p1 = (void *)args; - - fm = scheme_handle_stack_overflow(do_module_begin_k); - - if (recx) - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - if (erecx) - memcpy(erec + derec, erecx, sizeof(Scheme_Compile_Expand_Info)); - - return fm; - } -#endif - - if (*bxs->_num_phases < phase + 1) - *bxs->_num_phases = phase + 1; - - non_phaseless = (env->genv->module->phaseless ? 0 : NON_PHASELESS_IMPORT); - requested_phaseless = 0; - requested_empty_namespace = 0; - env->genv->module->phaseless = NULL; - - /* Expand each expression in form up to `begin', `define-values', `define-syntax', - `require', `provide', `#%app', etc. */ - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_MODULE_FRAME - | SCHEME_FOR_STOPS), - NULL, - env); - - install_stops(xenv, phase, &begin_for_syntax_stx); - - first = scheme_null; - last = NULL; - - rn_set = env->genv->stx_context; - - xenv->expand_result_adjust = introduce_to_module_context; - xenv->expand_result_adjust_arg = rn_set; - - vec = get_table(bxs->tables, scheme_make_integer(phase)); - if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[0])) - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel; - if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[2])) - SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax; - required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1]; - - if (phase == 0) { - /* Put initial requires into the table: - (This is redundant for the rename set, but we need to fill - the `all_requires' table, etc.) */ - if (env->genv->module->ii_src && SCHEME_TRUEP(SCHEME_STX_VAL(env->genv->module->ii_src))) { - Scheme_Module *iim; - Scheme_Object *nmidx, *orig_src; - - /* stx src of original import: */ - orig_src = env->genv->module->ii_src; - if (!orig_src) - orig_src = scheme_false; - else if (!SCHEME_STXP(orig_src)) - orig_src = scheme_false; - - nmidx = SCHEME_CAR(env->genv->module->requires); - iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL); - - add_simple_require_renames(orig_src, rn_set, env->genv, bxs->tables, - iim, nmidx, - scheme_make_integer(0), - NULL, 1, 1); - - scheme_hash_set(bxs->modidx_cache, ((Scheme_Modidx *)nmidx)->path, nmidx); - } - } - - provided = (Scheme_Hash_Table *)scheme_hash_get(bxs->all_provided, scheme_make_integer(phase)); - if (!provided) { - provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(bxs->all_provided, scheme_make_integer(phase), (Scheme_Object *)provided); - } - - all_rt_defs = scheme_hash_tree_get(bxs->all_defs, scheme_make_integer(phase)); - if (!all_rt_defs) all_rt_defs = scheme_null; - - if (SCHEME_NULLP(body_lists)) - exp_body = scheme_null; - else { - exp_body = SCHEME_CAR(body_lists); - body_lists = SCHEME_CDR(body_lists); - } - - self_modidx = env->genv->module->self_modidx; - - /* For syntax-local-context, etc., in a d-s RHS: */ - rhs_env = scheme_new_comp_env(env->genv, env->insp, NULL, SCHEME_TOPLEVEL_FRAME); - - observer = env->observer; - rhs_env->observer = observer; - - maybe_has_lifts = 0; - lift_ctx = scheme_generate_lifts_key(); - - req_data = package_require_data(self_modidx, env->genv, env->genv->module, - rn_set, - bxs->tables, - bxs->redef_modname, - bxs->all_simple_bindings, - bxs->submodule_names); - - if (SCHEME_PAIRP(bxs->end_statementss)) { - end_statements = SCHEME_CAR(bxs->end_statementss); - bxs->end_statementss = SCHEME_CDR(bxs->end_statementss); - } else - end_statements = scheme_null; - - /* Pass 1 */ - - /* Partially expand all expressions, and process definitions, requires, - and provides. Also, flatten top-level `begin' expressions: */ - for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) { - Scheme_Object *e; - int kind; - - while (1) { - Scheme_Object *fst; - - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT(observer); - } - - e = SCHEME_STX_CAR(fm); - - p = (maybe_has_lifts - ? scheme_frame_get_end_statement_lifts(xenv) - : end_statements); - prev_p = (maybe_has_lifts - ? scheme_frame_get_provide_lifts(xenv) - : scheme_null); - scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), - p, lift_ctx, req_data, prev_p, scheme_void); - maybe_has_lifts = 1; - - { - Scheme_Expand_Info erec1; - erec1.comp = 0; - erec1.depth = -1; - erec1.pre_unwrapped = 0; - erec1.substitute_bindings = 1; - erec1.env_already = 0; - erec1.comp_flags = rec[drec].comp_flags; - e = scheme_expand_expr(e, xenv, &erec1, 0); - } - - lifted_reqs = scheme_frame_get_require_lifts(xenv); - if (erec && !SCHEME_NULLP(lifted_reqs)) { - p = scheme_make_pair(scheme_make_pair(lifted_reqs, scheme_make_integer(LIFTREQ_MODFORM_KIND)), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - fst = scheme_frame_get_lifts(xenv); - if (!SCHEME_NULLP(fst)) { - /* Expansion lifted expressions, so add them to - the front and try again. */ - *bxs->all_simple_bindings = 0; - fm = SCHEME_STX_CDR(fm); - e = introduce_to_module_context(e, rn_set); - fm = scheme_named_map_1(NULL, introduce_to_module_context, fm, rn_set); - fm = scheme_make_pair(e, fm); - if (erec) { - SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm); - } - fm = scheme_append(fst, fm); - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, fst); - } - } else { - /* No definition lifts added... */ - if (SCHEME_STX_PAIRP(e)) - fst = SCHEME_STX_CAR(e); - else - fst = NULL; - - if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_free_eq_x(scheme_begin_stx, fst, phase)) { - fm = SCHEME_STX_CDR(fm); - e = introduce_to_module_context(e, rn_set); - if (erec) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); - } - fm = scheme_flatten_begin(e, fm); - if (erec) { - SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm); - } - if (SCHEME_STX_NULLP(fm)) { - e = scheme_frame_get_provide_lifts(xenv); - e = scheme_reverse(e); - if (expand_ends) { - fm = scheme_frame_get_end_statement_lifts(xenv); - fm = reverse_and_introduce_module_context(fm, rn_set); - if (!SCHEME_NULLP(e)) - fm = scheme_append(fm, e); - maybe_has_lifts = 0; - } else - fm = e; - if (SCHEME_NULLP(fm) && expand_ends) - fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx); - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm); - } - if (SCHEME_NULLP(fm)) { - e = NULL; - break; - } - } - } else - break; - } - } - if (!e) break; /* (begin) expansion at end */ - - e = introduce_to_module_context(e, rn_set); - - if (erec) { - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); - } - - if (SCHEME_STX_PAIRP(e)) { - Scheme_Object *fst; - - fst = SCHEME_STX_CAR(e); - - if (SCHEME_STX_SYMBOLP(fst)) { - if (scheme_stx_free_eq_x(scheme_define_values_stx, fst, phase)) { - /************ define-values *************/ - Scheme_Object *vars, *val; - int var_count = 0; - - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer); - } - - /* Create top-level vars; uses revert_use_site_scopes() on the vars */ - scheme_define_parse(e, &vars, &val, 0, xenv, 1); - - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *name, *orig_name, *binding; - - name = SCHEME_STX_CAR(vars); - - orig_name = name; - - /* Remember the original: */ - all_rt_defs = scheme_make_pair(name, all_rt_defs); - - binding = scheme_stx_lookup_exact(name, scheme_make_integer(phase)); - - if (!SCHEME_FALSEP(binding)) { - if (SCHEME_SYMBOLP(binding)) { - scheme_wrong_syntax(who, orig_name, e, "out-of-context identifier for definition"); - return NULL; - } else if (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], self_modidx) - && check_already_defined(SCHEME_VEC_ELS(binding)[1], env->genv)) { - scheme_wrong_syntax(who, orig_name, e, "duplicate definition for identifier"); - return NULL; - } else if (check_already_required(required, name, phase, binding)) - warn_previously_required(env->genv->module->modname, orig_name); - } - - /* Generate symbol for this binding: */ - name = scheme_global_binding(name, env->genv, 0); - - /* Create the bucket, indicating that the name will be defined: */ - scheme_add_global_symbol(name, scheme_undefined, env->genv); - - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name) - || !scheme_stx_equal_module_context(orig_name, env->genv->module->rn_stx)) - *bxs->all_simple_bindings = 0; - - vars = SCHEME_STX_CDR(vars); - var_count++; - } - - if (!(non_phaseless & NON_PHASELESS_FORM) && !phaseless_rhs(val, var_count, phase)) { - non_phaseless |= NON_PHASELESS_FORM; - non_phaseless_form = val; - } - - if (!rec[drec].comp) { - /* Reconstruct to remove scopes that don't belong on the binding names in the expansion: */ - e = scheme_datum_to_syntax(scheme_make_pair(fst, scheme_make_pair(vars, - scheme_make_pair(val, - scheme_null))), - e, e, 0, 2); - } - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - kind = DEFN_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(scheme_define_syntaxes_stx, fst, phase) - || scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { - /************ define-syntaxes & begin-for-syntax *************/ - /* Define the macro: */ - Scheme_Compile_Info mrec, erec1; - Scheme_Object *names, *orig_names, *l, *code, *m, *vec, *boundname, *frame_scopes; - Resolve_Prefix *rp; - Resolve_Info *ri; - Scheme_Comp_Env *oenv, *eenv; - Optimize_Info *oi; - int count = 0; - int for_stx; - int max_let_depth; - - for_stx = scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase); - - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - } - - if (for_stx) { - if (erec) { - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer); - } - if (scheme_stx_proper_list_length(e) < 0) - scheme_wrong_syntax(NULL, NULL, e, NULL); - code = e; - } else { - if (erec) { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer); - } - scheme_define_parse(e, &names, &code, 1, env, 1); - } - - if (!for_stx && SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) - boundname = SCHEME_STX_CAR(names); - else - boundname = scheme_false; - - if (erec) { - SCHEME_EXPAND_OBSERVE_PREPARE_ENV(observer); - } - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - - frame_scopes = scheme_module_context_use_site_frame_scopes(env->genv->exp_env->stx_context); - - eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, - frame_scopes, - SCHEME_KEEP_SCOPES_FRAME); - eenv->observer = observer; - if (!for_stx) - scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, - req_data, scheme_false, scheme_false); - - oenv = env; - - if (!for_stx) { - orig_names = scheme_null; - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - Scheme_Object *name, *orig_name, *binding; - name = SCHEME_STX_CAR(l); - - orig_name = name; - - /* Remember the original: */ - all_rt_defs = scheme_make_pair(name, all_rt_defs); - orig_names = scheme_make_pair(name, orig_names); - - binding = scheme_stx_lookup_exact(name, scheme_make_integer(phase)); - - if (!SCHEME_FALSEP(binding)) { - if (SCHEME_SYMBOLP(binding)) { - scheme_wrong_syntax(who, orig_name, e, "out-of-context identifier for definition"); - return NULL; - } else if (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], self_modidx) - && check_already_defined(SCHEME_VEC_ELS(binding)[1], env->genv)) { - scheme_wrong_syntax(who, orig_name, e, - "duplicate definition for identifier"); - return NULL; - } else if (check_already_required(required, name, phase, binding)) - warn_previously_required(oenv->genv->module->modname, orig_name); - } - - /* Generate symbol for this binding: */ - name = scheme_global_binding(name, env->genv, 0); - - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name) - || !scheme_stx_equal_module_context(orig_name, env->genv->module->rn_stx)) - *bxs->all_simple_bindings = 0; - - count++; - } - orig_names = scheme_reverse(orig_names); - } else - orig_names = NULL; - - if (for_stx) - names = NULL; - else - names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv); - - mrec.comp = 1; - mrec.dont_mark_local_use = 0; - mrec.resolve_module_ids = 0; - mrec.substitute_bindings = 1; - mrec.pre_unwrapped = 0; - mrec.env_already = 0; - mrec.comp_flags = rec[drec].comp_flags; - - if (erec) { - erec1.comp = 0; - erec1.depth = -1; - erec1.pre_unwrapped = 0; - erec1.substitute_bindings = 1; - erec1.env_already = 0; - erec1.comp_flags = rec[drec].comp_flags; - } - - if (for_stx) { - adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); - bxs->all_defs = adt; - if (erec) { - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - /* We expand & compile the for-syntax code in one pass. */ - } - m = do_module_begin_at_phase(code, eenv, - &mrec, 0, - (erec ? &erec1 : NULL), 0, - phase + 1, body_lists, - bxs); - if (erec) { - code = SCHEME_STX_CAR(code); - code = scheme_make_pair(code, SCHEME_CAR(m)); - m = SCHEME_CDR(m); - } - if (rec[drec].comp) - body_lists = SCHEME_CDR(m); - m = SCHEME_CAR(m); - /* turn list of compiled expressions into a splice: */ - m = scheme_make_sequence_compilation(m, 0, 0); - if (m->type == scheme_sequence_type) - m->type = scheme_splice_sequence_type; - } else { - if (erec) { - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - eenv->value_name = boundname; - eenv->observer = xenv->observer; - code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0); - } - eenv->value_name = boundname; - eenv->observer = NULL; - m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); - eenv->value_name = NULL; - } - - if (!for_stx) { - lifted_reqs = scheme_frame_get_require_lifts(eenv); - if (erec && !SCHEME_NULLP(lifted_reqs)) { - p = scheme_make_pair(scheme_make_pair(lifted_reqs, scheme_make_integer(LIFTREQ_MODFORM_KIND)), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - } - - m = scheme_letrec_check_expr(m); - - oi = scheme_optimize_info_create(eenv->prefix, eenv->genv, env->insp, 1); - scheme_optimize_info_set_context(oi, (Scheme_Object *)env->genv->module); - if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - scheme_optimize_info_never_inline(oi); - m = scheme_optimize_expr(m, oi, 0); - - rp = scheme_resolve_prefix(1, eenv->prefix, env->insp); - ri = scheme_resolve_info_create(rp); - scheme_enable_expression_resolve_lifts(ri); - m = scheme_resolve_expr(m, ri); - m = scheme_merge_expression_resolve_lifts(m, rp, ri); - rp = scheme_remap_prefix(rp, ri); - - max_let_depth = scheme_resolve_info_max_let_depth(ri); - - /* Add code with names and lexical depth to exp-time body: */ - vec = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(vec)[0] = (for_stx - ? scheme_false - : ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) - ? SCHEME_CAR(names) - : names)); - SCHEME_VEC_ELS(vec)[1] = m; - SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(max_let_depth); - SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false); - exp_body = scheme_make_pair(vec, exp_body); - - if (eenv->prefix->unbound) - unbounds = scheme_make_pair(eenv->prefix->unbound, unbounds); - - m = scheme_sfs(m, NULL, max_let_depth); - if (scheme_startup_use_jit /* Note: not scheme_resolve_info_use_jit(ri) */) - m = scheme_jit_expr(m); - rp = scheme_prefix_eval_clone(rp); - - eval_exptime(names, count, m, eenv->genv, rhs_env, rp, max_let_depth, 0, - (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), - phase + 1, - for_stx ? scheme_false : orig_names, NULL); - - if (erec) { - if (for_stx) { - m = code; - } else { - m = SCHEME_STX_CDR(e); - m = SCHEME_STX_CAR(m); - m = scheme_make_pair(fst, - scheme_make_pair(orig_names, scheme_make_pair(code, scheme_null))); - } - e = scheme_datum_to_syntax(m, e, e, 0, 2); - } else - e = NULL; - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - - kind = DONE_MODFORM_KIND; - - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } else if (scheme_stx_free_eq_x(require_stx, fst, phase)) { - /************ require *************/ - if (erec) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer); - } - - e = revert_use_site_scopes_via_context(e, rn_set, phase); - - /* Adds requires to renamings and required modules to requires lists: */ - parse_requires(e, phase, self_modidx, env->genv, env->genv->module, - rn_set, - check_require_name, bxs->tables, - bxs->redef_modname, - 0, - 1, phase ? 1 : 0, - bxs->all_simple_bindings, bxs->modidx_cache, - bxs->submodule_names, - &non_phaseless); - - if (!erec) - e = NULL; - - if (erec) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - kind = DONE_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(provide_stx, fst, phase)) { - /************ provide *************/ - /* remember it for pass 3 */ - p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), - bxs->saved_provides); - bxs->saved_provides = p; - kind = PROVIDE_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(declare_stx, fst, phase)) { - /************ declare *************/ - Scheme_Object *kws, *kw; - - kws = SCHEME_STX_CDR(e); - while (SCHEME_STX_PAIRP(kws)) { - kw = SCHEME_STX_CAR(kws); - if (SCHEME_KEYWORDP(SCHEME_STX_VAL(kw))) { - if (SAME_OBJ(SCHEME_STX_VAL(kw), phaseless_keyword)) { - if (requested_phaseless) - scheme_wrong_syntax(who, kw, e, "duplicate declaration"); - requested_phaseless = 1; - } else if (SAME_OBJ(SCHEME_STX_VAL(kw), empty_namespace_keyword)) { - if (requested_empty_namespace) - scheme_wrong_syntax(who, kw, e, "duplicate declaration"); - requested_empty_namespace = 1; - } else { - scheme_wrong_syntax(who, kw, e, "unrecognized keyword"); - } - } else { - scheme_wrong_syntax(who, kw, e, "expected a keyword"); - } - kws = SCHEME_STX_CDR(kws); - } - if (!SCHEME_STX_NULLP(kws)) - scheme_wrong_syntax(who, NULL, e, IMPROPER_LIST_FORM); - - kind = DECLARE_MODFORM_KIND; - } else if (scheme_stx_free_eq_x(scheme_module_stx, fst, phase) - || scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase)) { - /************ module[*] *************/ - /* check outer syntax & name, then expand pre-module or remember for post-module pass */ - int k; - - e = handle_submodule_form(who, - e, env, phase, - rn_set, observer, - bxs, - rec, drec, erec, derec, - &k); - kind = k; - } else { - kind = EXPR_MODFORM_KIND; - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } - } else { - kind = EXPR_MODFORM_KIND; - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } - } else { - kind = EXPR_MODFORM_KIND; - non_phaseless |= NON_PHASELESS_FORM; - if (!non_phaseless_form) - non_phaseless_form = e; - } - - if (e) { - p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(kind)), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - fm = SCHEME_STX_CDR(fm); - - /* If we're out of declarations, check for lifted-to-end: */ - if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) { - e = scheme_frame_get_provide_lifts(xenv); - e = scheme_reverse(e); - if (expand_ends) { - fm = scheme_frame_get_end_statement_lifts(xenv); - fm = reverse_and_introduce_module_context(fm, rn_set); - if (!SCHEME_NULLP(e)) - fm = scheme_append(fm, e); - maybe_has_lifts = 0; - if (SCHEME_NULLP(fm)) - fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx); - } else - fm = e; - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm); - } - } - } - /* first = a list of (cons semi-expanded-expression kind) */ - - if (!expand_ends) { - if (maybe_has_lifts) - end_statements = scheme_frame_get_end_statement_lifts(xenv); - } - - if (!phase) { - /* Check that all bindings used in phase-N expressions (for N >= 1) - were defined by now: */ - check_formerly_unbound(unbounds, env); - } - - /* Pass 2 */ - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); - } - - { - /* Module and each `begin-for-syntax' group manages its own prefix: */ - Scheme_Object *frame_scopes; - frame_scopes = scheme_module_context_frame_scopes(rn_set, xenv->scopes); - cenv = scheme_new_comp_env(env->genv, env->insp, frame_scopes, - SCHEME_TOPLEVEL_FRAME | SCHEME_KEEP_SCOPES_FRAME); - cenv->observer = env->observer; - cenv->intdef_next = xenv; - } - - lift_data = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv; - SCHEME_VEC_ELS(lift_data)[1] = self_modidx; - SCHEME_VEC_ELS(lift_data)[2] = rn_set; - - maybe_has_lifts = 0; - - prev_p = NULL; - expanded_l = scheme_null; - for (p = first; !SCHEME_NULLP(p); ) { - Scheme_Object *e, *l, *ll; - int kind; - - e = SCHEME_CAR(p); - kind = SCHEME_INT_VAL(SCHEME_CDR(e)); - e = SCHEME_CAR(e); - - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT(observer); - } - - if (kind == SAVED_MODFORM_KIND) { - expanded_l = scheme_make_pair(SCHEME_CDR(e), expanded_l); - SCHEME_CAR(p) = SCHEME_CAR(e); - prev_p = p; - p = SCHEME_CDR(p); - } else if (kind == DECLARE_MODFORM_KIND) { - expanded_l = scheme_make_pair(e, expanded_l); - p = SCHEME_CDR(p); - } else if (kind == LIFTREQ_MODFORM_KIND) { - expanded_l = scheme_append(e, expanded_l); - p = SCHEME_CDR(p); - } else if ((kind == PROVIDE_MODFORM_KIND) - || (kind == MODULE_MODFORM_KIND)) { - /* handle `provide's and `module's in later passes */ - if (erec) - expanded_l = scheme_make_pair(e, expanded_l); - if (rec[drec].comp) { - if (!prev_p) - first = SCHEME_CDR(p); - else - SCHEME_CDR(prev_p) = SCHEME_CDR(p); - } - p = SCHEME_CDR(p); - } else if ((kind == EXPR_MODFORM_KIND) - || (kind == DEFN_MODFORM_KIND)) { - Scheme_Comp_Env *nenv; - - l = (maybe_has_lifts - ? scheme_frame_get_end_statement_lifts(cenv) - : end_statements); - ll = (maybe_has_lifts - ? scheme_frame_get_provide_lifts(cenv) - : scheme_null); - scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll, scheme_void); - maybe_has_lifts = 1; - - if (kind == DEFN_MODFORM_KIND) - nenv = cenv; - else - nenv = scheme_new_compilation_frame(0, 0, NULL, cenv); - - if (erec) { - Scheme_Expand_Info erec1; - scheme_init_expand_recs(erec, derec, &erec1, 1); - e = scheme_expand_expr(e, nenv, &erec1, 0); - expanded_l = scheme_make_pair(e, expanded_l); - } - - if (rec[drec].comp) { - Scheme_Compile_Info crec1; - scheme_init_compile_recs(rec, drec, &crec1, 1); - crec1.resolve_module_ids = 0; - nenv->observer = NULL; - e = scheme_compile_expr(e, nenv, &crec1, 0); - nenv->observer = env->observer; - } - - lifted_reqs = scheme_frame_get_require_lifts(cenv); - if (erec && !SCHEME_NULLP(lifted_reqs)) - expanded_l = scheme_make_pair(SCHEME_CAR(expanded_l), - scheme_append(lifted_reqs, SCHEME_CDR(expanded_l))); - - l = scheme_frame_get_lifts(cenv); - if (SCHEME_NULLP(l)) { - /* No lifts - continue normally */ - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } else { - /* Lifts - insert them and try again */ - Scheme_Object *fst; - *bxs->all_simple_bindings = 0; - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); - } - if (erec) { - e = scheme_make_pair(scheme_make_pair(e, SCHEME_CAR(expanded_l)), - scheme_make_integer(SAVED_MODFORM_KIND)); /* kept both expanded & maybe compiled */ - /* add back expanded at correct position later: */ - expanded_l = SCHEME_CDR(expanded_l); - } else - e = scheme_make_pair(e, scheme_make_integer(DONE_MODFORM_KIND)); /* don't re-compile/-expand */ - SCHEME_CAR(p) = e; - for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = SCHEME_CAR(ll); - if (SCHEME_STX_PAIRP(SCHEME_CAR(e))) - fst = SCHEME_STX_CAR(SCHEME_CAR(e)); - else - fst = NULL; - if (fst - && (scheme_stx_free_eq3(fst, scheme_module_stx, scheme_make_integer(phase), scheme_make_integer(0)) - || scheme_stx_free_eq3(fst, scheme_modulestar_stx, scheme_make_integer(phase), scheme_make_integer(0)))) { - /* a `module` or `module*` form; handle as in first pass */ - int k; - e = handle_submodule_form(who, - e, env, phase, - rn_set, observer, - bxs, - rec, drec, erec, derec, - &k); - if (e) - e = scheme_make_pair(e, scheme_make_integer(k)); - else - e = scheme_make_pair(scheme_void, DONE_MODFORM_KIND); - } else { - e = scheme_make_pair(e, scheme_make_integer(DEFN_MODFORM_KIND)); - } - SCHEME_CAR(ll) = e; - } - p = scheme_append(l, p); - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } else { - if (erec) - expanded_l = scheme_make_pair(e, expanded_l); - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } - - /* If we're out of declarations, check for lifted-to-end: */ - if (SCHEME_NULLP(p) && maybe_has_lifts) { - int expr_cnt; - Scheme_Object *sp; - e = scheme_frame_get_provide_lifts(cenv); - e = scheme_reverse(e); - if (expand_ends) { - p = scheme_frame_get_end_statement_lifts(cenv); - p = scheme_reverse(p); - expr_cnt = scheme_list_length(p); - if (!SCHEME_NULLP(e)) - p = scheme_append(p, e); - } else { - p = e; - expr_cnt = 0; - } - if (erec) { - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p); - } - for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = SCHEME_CAR(ll); - if (expr_cnt <= 0) { - sp = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), - bxs->saved_provides); - bxs->saved_provides = sp; - } - e = scheme_make_pair(e, ((expr_cnt > 0) - ? scheme_make_integer(EXPR_MODFORM_KIND) - : scheme_make_integer(PROVIDE_MODFORM_KIND))); - SCHEME_CAR(ll) = e; - expr_cnt--; - } - maybe_has_lifts = 0; - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } - if (erec) expanded_l = scheme_reverse(expanded_l); - - /* If not phase 0, save end statements */ - if (!expand_ends) { - if (maybe_has_lifts) - end_statements = scheme_frame_get_end_statement_lifts(cenv); - if (!SCHEME_NULLP(end_statements) || !SCHEME_NULLP(bxs->end_statementss)) { - p = scheme_make_pair(end_statements, bxs->end_statementss); - bxs->end_statementss = p; - } - } - - adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); - bxs->all_defs = adt; - - /* Pass 3 */ - /* if at phase 0, expand provides for all phases */ - if (erec) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); - } - - if (phase == 0) { - Scheme_Object *expanded_provides; - - expanded_provides = expand_all_provides(form, cenv, - (erec ? erec : rec), (erec ? derec : drec), - self_modidx, - bxs, !!erec); - - if (erec) { - expanded_provides = scheme_reverse(expanded_provides); - (void)fixup_expanded(expanded_l, expanded_provides, 0, PROVIDE_MODFORM_KIND); - } - } - - /* first = a list of compiled expressions */ - /* expanded_l = list of expanded expressions */ - - /* If compiling, drop expressions that are constants: */ - if (rec[drec].comp) { - Scheme_Object *prev = NULL, *next; - for (p = first; !SCHEME_NULLP(p); p = next) { - next = SCHEME_CDR(p); - if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, NULL)) { - if (prev) - SCHEME_CDR(prev) = next; - else - first = next; - } else - prev = p; - } - } - - adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); - bxs->all_defs = adt; - - if (cenv->prefix->non_phaseless) - non_phaseless |= NON_PHASELESS_IMPORT; - - if (!phase) - env->genv->module->comp_prefix = cenv->prefix; - else - env->prefix = cenv->prefix; - - if (!SCHEME_NULLP(exp_body)) { - if (*bxs->_num_phases < phase + 2) - *bxs->_num_phases = phase + 2; - } - - if (requested_phaseless) { - if (!non_phaseless) - env->genv->module->phaseless = scheme_true; - else { - if (non_phaseless & NON_PHASELESS_IMPORT) - scheme_wrong_syntax(who, NULL, form, "cannot be cross-phase persistent due to required modules"); - else - scheme_wrong_syntax(who, non_phaseless_form, form, "does not satisfy cross-phase persistent grammar"); - } - } - - if (requested_empty_namespace) - env->genv->module->rn_stx = NULL; - - if (rec[drec].comp) { - body_lists = scheme_make_pair(first, scheme_make_pair(exp_body, body_lists)); - if (erec) - return scheme_make_pair(expanded_l, body_lists); - else - return body_lists; - } else - return expanded_l; -} - -static Scheme_Object *expand_all_provides(Scheme_Object *form, - Scheme_Comp_Env *cenv, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Object *self_modidx, - Module_Begin_Expand_State *bxs, - int keep_expanded) -/* expands `#%provide's for all phases in a module that is otherwise - fully expanded; returns a list of expanded forms in reverse order, - if requested by `keep_expanded'. */ -{ - Scheme_Object *saved_provides; - Scheme_Object *observer, *expanded_provides = scheme_null; - int provide_phase; - Scheme_Object *e, *ex, *fst; - Scheme_Comp_Env *pcenv; - - observer = cenv->observer; - - saved_provides = scheme_reverse(bxs->saved_provides); - while (!SCHEME_NULLP(saved_provides)) { - e = SCHEME_CAR(saved_provides); - provide_phase = SCHEME_INT_VAL(SCHEME_CDR(e)); - e = SCHEME_CAR(e); - - fst = SCHEME_STX_CAR(e); - - /* Expand and add provides to table: */ - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer); - } - - ex = e; - - if (provide_phase != 0) { - Scheme_Env *penv = cenv->genv; - int k; - for (k = 0; k < provide_phase; k++) { - penv = penv->exp_env; - } - if (rec[drec].comp) - pcenv = scheme_new_comp_env(penv, penv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); - else - pcenv = scheme_new_expand_env(penv, penv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); - pcenv->observer = cenv->observer; - } else { - pcenv = cenv; - } - - parse_provides(form, fst, e, provide_phase, - bxs->all_provided, bxs->all_reprovided, - self_modidx, - bxs->all_defs_out, - bxs->tables, - bxs->all_defs, - pcenv, rec, drec, - &ex); - - if (keep_expanded) - expanded_provides = scheme_make_pair(ex, expanded_provides); - - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - - saved_provides = SCHEME_CDR(saved_provides); - } - - return expanded_provides; -} - -static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Comp_Env *env, - Scheme_Object *l, int post, - Module_Begin_Expand_State *bxs, - int keep_expanded) -{ - Scheme_Object *mods = scheme_null, *mod, *ancestry; - - ancestry = scheme_make_pair((Scheme_Object *)env->genv, env->genv->module->submodule_ancestry); - /* do_module() will extend submodule_path */ - - env = scheme_new_compilation_frame(0, - (SCHEME_TOPLEVEL_FRAME | SCHEME_NESTED_MODULE_FRAME), - NULL, - env); - - l = scheme_reverse(l); - - while (!SCHEME_NULLP(l)) { - mod = SCHEME_CAR(l); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, SCHEME_CAR(mod)); - } - mod = do_module(SCHEME_CAR(mod), env, rec, drec, ancestry, env->genv->module->submodule_path, post, - bxs, SCHEME_CDR(mod)); - if (!rec[drec].comp) { - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,mod); - } - - mods = scheme_make_pair(mod, mods); - - l = SCHEME_CDR(l); - } - - if (keep_expanded) - mods = scheme_reverse(mods); - - if (rec[drec].comp) { - if (post) { - env->genv->module->post_submodules = mods; - /* also reverse pres, now: */ - l = env->genv->module->pre_submodules; - if (l) { - l = scheme_reverse(l); - env->genv->module->pre_submodules = l; - } - } else { - l = env->genv->module->pre_submodules; - if (!l) l = scheme_null; - l = scheme_make_pair(SCHEME_CAR(mods), l); - env->genv->module->pre_submodules = l; - } - } else if (!SCHEME_NULLP(mods)) { - /* setting pre_submodules to '() indicates that there were submodules during expansion */ - env->genv->module->pre_submodules = scheme_null; - if (!post) { - l = env->genv->module->pre_submodule_names; - if (!l) l = scheme_null; - /* extract just the name: */ - mod = SCHEME_CAR(mods); - mod = SCHEME_STX_CDR(mod); - mod = SCHEME_STX_CAR(mod); - mod = SCHEME_STX_VAL(mod); - l = scheme_make_pair(mod, l); - env->genv->module->pre_submodule_names = l; - } - } - - return mods; -} - -static Scheme_Object *fixup_expanded(Scheme_Object *expanded_l, - Scheme_Object *expanded_provides, - int phase, int kind) -/* mutates `expanded_l' to find `#%provide's or `module's (possibly nested in - `begin-for-syntax') and replace them with the ones in - `expanded_provides'. The provides in `expanded_l' and - `expanded_provides' are matched up by order. */ -{ - Scheme_Object *p, *e, *fst, *prov_stx, *l; - - if (kind == PROVIDE_MODFORM_KIND) - prov_stx = provide_stx; - else - prov_stx = scheme_modulestar_stx; - - for (p = expanded_l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { - e = SCHEME_CAR(p); - if (SCHEME_STX_PAIRP(e)) { - fst = SCHEME_STX_CAR(e); - if (scheme_stx_free_eq_x(prov_stx, fst, phase)) { - SCHEME_CAR(p) = SCHEME_CAR(expanded_provides); - expanded_provides = SCHEME_CDR(expanded_provides); - } else if (scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { - l = scheme_flatten_syntax_list(e, NULL); - l = scheme_copy_list(l); - expanded_provides = fixup_expanded(SCHEME_CDR(l), expanded_provides, phase + 1, kind); - e = scheme_datum_to_syntax(l, e, e, 0, 2); - SCHEME_CAR(p) = e; - } - } - } - - return expanded_provides; -} - -static void check_formerly_unbound(Scheme_Object *unbounds, - Scheme_Comp_Env *env) -{ - Scheme_Object *stack = scheme_null, *lst, *p; - Scheme_Env *uenv = env->genv->exp_env; - - while (!SCHEME_NULLP(unbounds)) { - stack = scheme_null; - uenv = env->genv->exp_env; - - lst = SCHEME_CAR(unbounds); - while(1) { - while (!SCHEME_NULLP(lst)) { - p = SCHEME_CAR(lst); - if (SCHEME_PAIRP(p)) { - if (!uenv->exp_env) - scheme_signal_error("internal error: no such environment to check unbounds"); - else { - /* switch to nested list, push current list onto stack: */ - stack = scheme_make_pair(scheme_make_pair(SCHEME_CDR(lst), (Scheme_Object *)uenv), - stack); - uenv = uenv->exp_env; - lst = SCHEME_CAR(lst); - } - } else { - (void)scheme_check_top_identifier_bound(p, uenv, 1); - lst = SCHEME_CDR(lst); - } - } - if (!SCHEME_NULLP(stack)) { - lst = SCHEME_CAR(stack); - stack = SCHEME_CDR(stack); - uenv = (Scheme_Env *)SCHEME_CDR(lst); - lst = SCHEME_CAR(lst); - } else - break; - } - unbounds = SCHEME_CDR(unbounds); - } - - /* Disallow unbound variables from now on: */ - uenv = env->genv->exp_env; - while (uenv) { - uenv->disallow_unbound = 1; - uenv = uenv->exp_env; - } -} - -static int is_modulestar_stop(Scheme_Comp_Env *env) -{ - Scheme_Object *p; - p = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, scheme_sys_wraps(env), 0, 0); - p = scheme_compile_lookup(p, env, - (SCHEME_NULL_FOR_UNBOUND - + SCHEME_DONT_MARK_USE - + SCHEME_ENV_CONSTANTS_OK - + (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)), - env->in_modidx, - NULL, NULL, - NULL, NULL, NULL); - return (scheme_get_stop_expander() == p); -} - -static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **_begin_for_syntax_stx) -{ - Scheme_Object *stop, *w, *s; - - stop = scheme_get_stop_expander(); - - scheme_add_local_syntax(22, xenv); - - if (phase == 0) { - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv, 0); - scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv, 0); - scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv, 0); - scheme_set_local_syntax(3, scheme_begin_for_syntax_stx, stop, xenv, 0); - *_begin_for_syntax_stx = scheme_begin_for_syntax_stx; - scheme_set_local_syntax(4, require_stx, stop, xenv, 0); - scheme_set_local_syntax(5, provide_stx, stop, xenv, 0); - scheme_set_local_syntax(6, set_stx, stop, xenv, 0); - scheme_set_local_syntax(7, app_stx, stop, xenv, 0); - scheme_set_local_syntax(8, scheme_top_stx, stop, xenv, 0); - scheme_set_local_syntax(9, lambda_stx, stop, xenv, 0); - scheme_set_local_syntax(10, case_lambda_stx, stop, xenv, 0); - scheme_set_local_syntax(11, let_values_stx, stop, xenv, 0); - scheme_set_local_syntax(12, letrec_values_stx, stop, xenv, 0); - scheme_set_local_syntax(13, if_stx, stop, xenv, 0); - scheme_set_local_syntax(14, begin0_stx, stop, xenv, 0); - scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv, 0); - scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv, 0); - scheme_set_local_syntax(17, var_ref_stx, stop, xenv, 0); - scheme_set_local_syntax(18, expression_stx, stop, xenv, 0); - scheme_set_local_syntax(19, scheme_modulestar_stx, stop, xenv, 0); - scheme_set_local_syntax(20, scheme_module_stx, stop, xenv, 0); - scheme_set_local_syntax(21, declare_stx, stop, xenv, 0); - } else { - w = scheme_sys_wraps_phase(scheme_make_integer(phase)); - s = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); - scheme_set_local_syntax(0, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); - scheme_set_local_syntax(1, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_set_local_syntax(2, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); - scheme_set_local_syntax(3, s, stop, xenv, 0); - *_begin_for_syntax_stx = s; - s = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); - scheme_set_local_syntax(4, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); - scheme_set_local_syntax(5, s, stop, xenv, 0); - scheme_set_local_syntax(6, scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(7, scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(8, scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(9, scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(10, scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(11, scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(12, scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(13, scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(14, scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(15, scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(16, scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(17, scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0), stop, xenv, 0); - scheme_set_local_syntax(18, scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0), stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, w, 0, 0); - scheme_set_local_syntax(19, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); - scheme_set_local_syntax(20, s, stop, xenv, 0); - s = scheme_datum_to_syntax(scheme_intern_symbol("#%declare"), scheme_false, w, 0, 0); - scheme_set_local_syntax(21, s, stop, xenv, 0); - } -} - -static Scheme_Object * -module_begin_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_module_begin(form, env, rec, drec); -} - -static Scheme_Object * -module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(env->observer); - return do_module_begin(form, env, erec, drec); -} - -static void check_already_provided(Scheme_Hash_Table *provided, Scheme_Object *outname, Scheme_Object *name, - int protected, Scheme_Object *form, Scheme_Object *phase) -{ - Scheme_Object *v; - - v = scheme_hash_get(provided, outname); - if (v) { - if (!scheme_stx_free_eq2(SCHEME_CAR(v), name, phase)) - scheme_wrong_syntax("module", outname, form, "identifier already provided (as a different binding)"); - - if (protected && SCHEME_FALSEP(SCHEME_CDR(v))) - scheme_wrong_syntax("module", outname, form, "identifier already provided as unprotected"); - if (!protected && SCHEME_TRUEP(SCHEME_CDR(v))) - scheme_wrong_syntax("module", outname, form, "identifier already provided as protected"); - } -} - -int compute_reprovides(Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Module *mod_for_requires, - Scheme_Hash_Table *tables, - Scheme_Env *_genv, - int num_phases, - Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, - const char *matching_form, - Scheme_Object *all_mods, /* a phase list to use for all mods */ - Scheme_Object *all_phases) /* a module-path list for all phases */ -{ - Scheme_Hash_Table *provided, *required; - Scheme_Object *reprovided, *tvec; - int i, k, z; - Scheme_Object *rx, *provided_list, *phase, *req_phase; - Scheme_Object *all_x_defs, *all_x_defs_out; - Scheme_Env *genv; - - if (all_phases) { - /* synthesize all_reprovided for the loop below: */ - if (all_mods) - reprovided = scheme_make_pair(scheme_false, scheme_null); - else - reprovided = all_phases; - all_reprovided = scheme_make_hash_table_eqv(); - if (mod_for_requires->requires - && !SCHEME_NULLP(mod_for_requires->requires)) - scheme_hash_set(all_reprovided, scheme_make_integer(0), reprovided); - if (mod_for_requires->et_requires - && !SCHEME_NULLP(mod_for_requires->et_requires)) - scheme_hash_set(all_reprovided, scheme_make_integer(1), reprovided); - if (mod_for_requires->tt_requires - && !SCHEME_NULLP(mod_for_requires->tt_requires)) - scheme_hash_set(all_reprovided, scheme_make_integer(-1), reprovided); - if (mod_for_requires->dt_requires - && !SCHEME_NULLP(mod_for_requires->dt_requires)) - scheme_hash_set(all_reprovided, scheme_false, reprovided); - if (mod_for_requires->other_requires) { - for (z = 0; z < mod_for_requires->other_requires->size; z++) { - if (mod_for_requires->other_requires->vals[z]) - scheme_hash_set(all_reprovided, - mod_for_requires->other_requires->keys[z], - reprovided); - } - } - } else if (all_mods) { - reprovided = scheme_make_pair(scheme_false, scheme_null); - all_reprovided = scheme_make_hash_table_eqv(); - while (SCHEME_PAIRP(all_mods)) { - scheme_hash_set(all_reprovided, SCHEME_CAR(all_mods), reprovided); - all_mods = SCHEME_CDR(all_mods); - } - } - - /* First, check the sanity of the re-provide specifications (unless - we synthesized them): */ - if (!all_mods) { - for (z = 0; z < all_reprovided->size; z++) { - if (all_reprovided->vals[z]) { - Scheme_Object *requires; - - reprovided = all_reprovided->vals[z]; - phase = all_reprovided->keys[z]; - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - requires = mod_for_requires->requires; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - requires = mod_for_requires->et_requires; - } else if (SAME_OBJ(phase, scheme_make_integer(-1))) { - requires = mod_for_requires->tt_requires; - } else if (SAME_OBJ(phase, scheme_false)) { - requires = mod_for_requires->dt_requires; - } else { - if (mod_for_requires->other_requires) - requires = scheme_hash_get(mod_for_requires->other_requires, phase); - else - requires = NULL; - } - if (!requires) - requires = scheme_null; - - for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { - Scheme_Object *midx = SCHEME_CAR(SCHEME_CAR(rx)), *l, *exns; - - for (l = requires; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - if (same_modidx(midx, SCHEME_CAR(l))) - break; - } - if (SCHEME_NULLP(l)) { - /* Didn't require the named module */ - if (matching_form) { - Scheme_Object *name; - name = SCHEME_CAR(rx); - name = SCHEME_STX_CDR(name); - name = SCHEME_STX_CAR(name); - scheme_wrong_syntax("module", - SCHEME_MODNAMEP(midx) ? midx : ((Scheme_Modidx *)midx)->path, - name, - "cannot provide from a module without a matching `%s'", - matching_form); - } else { - return 0; - } - } - - exns = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(rx))); - for (l = exns; !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) { - /* Make sure excluded name was required: */ - Scheme_Object *a, *b, *vec = NULL; - - for (k = 0; k < tables->size; k++) { - if (tables->vals[k]) { - tvec = tables->vals[k]; - required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1]; - - if (required) { - a = SCHEME_STX_CAR(l); - b = scheme_stx_lookup(a, tables->keys[k]); - if (SCHEME_VECTORP(b) - && !SAME_OBJ(SCHEME_VEC_ELS(b)[0], _genv->module->self_modidx)) - b = require_binding_to_key(required, b, SCHEME_STX_VAL(a)); - vec = scheme_hash_get(required, b); - } else - vec = NULL; - - if (vec) { - /* Check for nominal modidx in list */ - Scheme_Object *nml, *nml_modidx; - nml = SCHEME_VEC_ELS(vec)[0]; - for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { - nml_modidx = SCHEME_CAR(nml); - if (SCHEME_PAIRP(nml_modidx)) - nml_modidx = SCHEME_CAR(nml_modidx); - if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nml_modidx)) - break; - } - if (!SCHEME_PAIRP(nml)) - vec = NULL; /* So it was provided, but not from the indicated module */ - } - - if (vec) - break; - } - } - if (!vec) { - a = SCHEME_STX_CAR(l); - scheme_wrong_syntax("module", a, SCHEME_CADR(SCHEME_CAR(rx)), - "excluded name was not required from the module"); - } - } - } - } - } - } - - - /* For each reprovided, walk through requires, check for re-provided bindings: */ - for (z = 0; z < all_reprovided->size; z++) { - reprovided = all_reprovided->vals[z]; - if (reprovided && !SCHEME_NULLP(reprovided)) { - phase = all_reprovided->keys[z]; - - for (k = 0; k < tables->size; k++) { - tvec = tables->vals[k]; - if (tvec) { - required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1]; - req_phase = tables->keys[k]; - - for (i = required->size; i--; ) { - if (required->vals[i] && SCHEME_TRUEP(required->vals[i])) { - Scheme_Object *nominal_modidx, *outname, *nml, *orig_nml, *id; - int break_outer = 0; - - orig_nml = SCHEME_VEC_ELS(required->vals[i])[0]; - outname = SCHEME_VEC_ELS(required->vals[i])[4]; - prep_required_id(required->vals[i]); - id = SCHEME_VEC_ELS(required->vals[i])[6]; - - for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { - for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { - nominal_modidx = SCHEME_CAR(nml); - if (SCHEME_PAIRP(nominal_modidx)) - nominal_modidx = SCHEME_CAR(nominal_modidx); - if (all_mods || same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) { - Scheme_Object *nml_pi; - - if (SCHEME_PAIRP(SCHEME_CAR(nml))) - nml_pi = SCHEME_CADR(SCHEME_CAR(nml)); - else - nml_pi = scheme_make_integer(0); - - if (SAME_OBJ(phase, nml_pi)) { - Scheme_Object *exns, *ree; - - if (!all_mods) { - break_outer = 1; - - ree = SCHEME_CDR(SCHEME_CAR(rx)); - - exns = SCHEME_CDR(ree); - } else { - ree = NULL; - exns = scheme_null; - } - - for (; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { - /* Was this name excluded? */ - Scheme_Object *a; - a = SCHEME_STX_VAL(SCHEME_STX_CAR(exns)); - if (SAME_OBJ(a, outname)) - break; - } - - if (SCHEME_STX_NULLP(exns)) { - /* Not excluded, so provide it. */ - if (matching_form) { - /* Assert: !all_mods */ - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, req_phase); - if (!provided) { - provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(all_provided, req_phase, (Scheme_Object *)provided); - } - check_already_provided(provided, outname, id, 0, SCHEME_CAR(ree), req_phase); - scheme_hash_set(provided, outname, scheme_make_pair(id, scheme_false)); - } else { - provided_list = scheme_hash_get(all_provided, req_phase); - if (!provided_list) - provided_list = scheme_null; - provided_list = scheme_make_pair(id, provided_list); - scheme_hash_set(all_provided, req_phase, provided_list); - } - } - } - } - if (break_outer) break; - } - } - } - } - } - } - } - } - - /* Do all-defined provides */ - genv = _genv; - for (z = 0; z < num_phases; z++) { - all_x_defs = scheme_hash_tree_get(all_defs, scheme_make_integer(z)); - if (!all_x_defs) all_x_defs = scheme_null; - all_x_defs_out = scheme_hash_get(all_defs_out, scheme_make_integer(z)); - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(z)); - phase = scheme_make_integer(z); - - if (all_x_defs_out) { - for (; !SCHEME_NULLP(all_x_defs_out); all_x_defs_out = SCHEME_CDR(all_x_defs_out)) { - Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx, *name_sym; - int protected; - - ree = SCHEME_CAR(all_x_defs_out); - protected = SCHEME_TRUEP(SCHEME_CDR(ree)); - ree = SCHEME_CAR(ree); - ree_kw = SCHEME_CAR(ree); - ree = SCHEME_CDR(ree); - exl = SCHEME_CAR(ree); - pfx = SCHEME_CDR(ree); - - /* Make sure each excluded name was defined: */ - for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { - a = SCHEME_STX_CAR(exns); - name = to_defined_symbol(a, genv); - if (!scheme_lookup_in_table(genv->toplevel, (const char *)name) - && !scheme_lookup_in_table(genv->syntax, (const char *)name)) { - scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined"); - } - } - - for (adl = all_x_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { - name = SCHEME_CAR(adl); - exname = SCHEME_STX_SYM(name); - name_sym = to_defined_symbol(name, genv); - - /* Was this one excluded? */ - for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { - a = SCHEME_STX_CAR(exns); - a = to_defined_symbol(a, genv); - if (SAME_OBJ(a, name_sym)) - break; - } - - if (SCHEME_STX_NULLP(exns)) { - /* not excluded */ - - /* But don't export uninterned: */ - if (!SCHEME_SYM_UNINTERNEDP(exname)) { - /* Also, check that ree_kw and the identifier have the same - introduction (in case one or the other was introduced by - a macro). We perform this check by getting exname's tl_id - as if it had ree_kw's context, then comparing that result - to the actual tl_id. */ - a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0); - a = to_defined_symbol(a, genv); - - if (SAME_OBJ(a, name_sym)) { - /* Add prefix, if any */ - if (SCHEME_TRUEP(pfx)) { - exname = scheme_symbol_append(pfx, exname); - } - check_already_provided(provided, exname, name, protected, ree_kw, phase); - - scheme_hash_set(provided, exname, - scheme_make_pair(name, protected ? scheme_true : scheme_false)); - } - } - } - } - } - } - - genv = _genv->exp_env; - } - - return 1; -} - -static Scheme_Object **compute_indirects(Scheme_Env *genv, - Scheme_Module_Phase_Exports *pt, - int *_count, - int vars) -{ - int i, count, j, start, end; - Scheme_Bucket **bs, *b; - Scheme_Object **exsns = pt->provide_src_names, **exss = pt->provide_srcs, **exis; - int exicount; - Scheme_Bucket_Table *t; - - if (vars) { - start = 0; - end = pt->num_provides; /* check both vars & syntax, in case of rename transformer */ - t = genv->toplevel; - } else { - start = pt->num_var_provides; - end = pt->num_provides; - t = genv->syntax; - } - - count = (t ? t->count : 0); - - if (!count) { - *_count = 0; - return NULL; - } - - bs = t->buckets; - - exis = MALLOC_N(Scheme_Object *, count); - - for (count = 0, i = t->size; i--; ) { - b = bs[i]; - if (b && b->val) { - Scheme_Object *name; - - name = (Scheme_Object *)b->key; - - /* If the name is directly provided, no need for indirect... */ - for (j = start; j < end; j++) { - if (SAME_OBJ(name, exsns[j]) - && SCHEME_FALSEP(exss[j])) - break; - } - - if (j == end) - exis[count++] = name; - } - } - - if (!count) { - *_count = 0; - return NULL; - } - - exicount = count; - - qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1); - - *_count = exicount; - return exis; -} - -Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath, - Scheme_Object *mode) -{ - Scheme_Object *l, *all_mods, *all_phases; - Scheme_Hash_Table *tables, *all_reprovided, *all_provided; - int v, i; - - tables = (Scheme_Hash_Table *)SCHEME_CAR(bindings); - all_reprovided = scheme_make_hash_table_eqv(); - - if (SCHEME_FALSEP(modpath)) { - if (SAME_OBJ(mode, scheme_true)) { - all_mods = scheme_null; - all_phases = scheme_null; - } else { - all_mods = scheme_make_pair(mode, scheme_null); - all_phases = NULL; - } - } else { - Scheme_Object *reprovided; - - modpath = convert_submodule_path(modpath, check_is_submodule, - (Scheme_Object *)genv); - - reprovided = scheme_make_pair(scheme_make_pair(modpath, - scheme_make_pair(scheme_false, - scheme_null)), - scheme_null); - all_mods = NULL; - if (SAME_OBJ(mode, scheme_true)) { - all_phases = reprovided; - } else { - scheme_hash_set(all_reprovided, mode, reprovided); - all_phases = NULL; - } - } - - /* Receives result: */ - all_provided = scheme_make_hash_table_eqv(); - - v = compute_reprovides(all_provided, - all_reprovided, - genv->module, - tables, - genv, - 0, - NULL, NULL, - NULL, - all_mods, all_phases); - - if (!v) { - return scheme_false; - } else { - l = scheme_null; - for (i = 0; i < all_provided->size; i++) { - if (all_provided->vals[i]) { - l = scheme_make_pair(scheme_make_pair(all_provided->keys[i], - all_provided->vals[i]), - l); - } - } - - return l; - } -} - -static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object *in_name, Scheme_Object *noms) -{ - Scheme_Object *first = scheme_null, *last = NULL, *p, *a; - - if (SCHEME_STXP(in_name)) - in_name = SCHEME_STX_VAL(in_name); - - if (SAME_OBJ(in_name, out_name)) - return noms; - - while (SCHEME_PAIRP(noms)) { - a = SCHEME_CAR(noms); - if (SCHEME_PAIRP(a)) { - /* no change */ - } else { - a = scheme_make_pair(a, - scheme_make_pair(scheme_make_integer(0), - scheme_make_pair(in_name, - scheme_make_pair(scheme_make_integer(0), - scheme_null)))); - } - - p = scheme_make_pair(a, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - - noms = SCHEME_CDR(noms); - } - - return first; -} - -static int lookup(Scheme_Env *name_env, int as_syntax, Scheme_Object *name) -{ - Scheme_Bucket_Table *bt = (as_syntax ? name_env->syntax : name_env->toplevel); - - if (!bt) return 0; - - return !!scheme_lookup_in_table(bt, (const char *)name); -} - -void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - int num_phases, Scheme_Module_Export_Info **exp_infos) -{ - int i, k, count, z; - Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase, *binding; - Scheme_Hash_Table *provided, *required; - char *exps; - int *exets; - int excount, exvcount; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *nominal_mod, *nominal_name, *nominal_in_phase, *nominal_src_phase; - Scheme_Env *name_env; - - for (z = 0; z < all_provided->size; z++) { - provided = (Scheme_Hash_Table *)all_provided->vals[z]; - - if (provided) { - phase = all_provided->keys[z]; - required = get_required_from_tables(tables, phase); - if (!required) - required = scheme_make_hash_table_equal(); - - if (SAME_OBJ(phase, scheme_make_integer(0))) - pt = me->rt; - else if (SAME_OBJ(phase, scheme_make_integer(1))) - pt = me->et; - else if (SAME_OBJ(phase, scheme_false)) - pt = me->dt; - else { - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = phase; - if (!me->other_phases) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_eqv(); - me->other_phases = ht; - } - scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); - } - - for (count = 0, i = provided->size; i--; ) { - if (provided->vals[i]) - count++; - } - - exs = MALLOC_N(Scheme_Object *, count); - exsns = MALLOC_N(Scheme_Object *, count); - exss = MALLOC_N(Scheme_Object *, count); - exsnoms = MALLOC_N(Scheme_Object *, count); - exps = MALLOC_N_ATOMIC(char, count); - exets = MALLOC_N_ATOMIC(int, count); - memset(exets, 0, count * sizeof(int)); - - name_env = scheme_find_env_at_phase(genv, phase); - - count = 0; - exvcount = 0; - - for (k = 0; k < 2; k++) { - for (i = provided->size; i--; ) { - if (provided->vals[i]) { - Scheme_Object *name, *prnt_name, *v; - int protected, defined; - - v = provided->vals[i]; /* external name as symbol */ - name = SCHEME_CAR(v); /* internal identifier */ - protected = SCHEME_TRUEP(SCHEME_CDR(v)); - prnt_name = name; - - binding = scheme_stx_lookup_w_nominal(name, phase, - 0, - NULL, NULL, NULL, - NULL, - &nominal_mod, &nominal_name, - &nominal_in_phase, - &nominal_src_phase); - - if (SCHEME_VECTORP(binding)) { - defined = SAME_OBJ(SCHEME_VEC_ELS(binding)[0], genv->module->self_modidx); - name = SCHEME_VEC_ELS(binding)[1]; - } else { - defined = 0; - name = scheme_false; - } - - if (defined && lookup(name_env, k, name)) { - /* Defined locally */ - exs[count] = provided->keys[i]; - exsns[count] = name; - exss[count] = scheme_false; /* means "self" */ - exsnoms[count] = scheme_null; /* since "self" */ - exps[count] = protected; - exets[count] = SCHEME_INT_VAL(phase); - count++; - } else if (defined && lookup(name_env, 1-k, name)) { - /* Skip definition for other round */ - } else if (!defined - && SCHEME_VECTORP(binding) - && (v = scheme_hash_get(required, require_binding_to_key(required, - binding, - SCHEME_STX_VAL(prnt_name))))) { - /* Required */ - if (protected) { - name = SCHEME_CAR(provided->vals[i]); - scheme_wrong_syntax("module", NULL, name, "cannot protect imported identifier with re-provide"); - } - if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[3]) == (k == 0)) { - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; - exps[count] = protected; - exets[count] = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[8]); - count++; - } - } else if (!defined && SCHEME_VECTORP(binding)) { - if (k == 1) { - /* Exporting a binding that was not explicitly imported --- must be - due to a rename transformer or a macro-introduced `provide`. - We treat all such bindings as syntax, even though they - may correspond to variables. */ - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(binding)[1]; - exss[count] = SCHEME_VEC_ELS(binding)[0]; - noms = adjust_for_rename(exs[count], nominal_name, cons(nominal_mod, scheme_null)); - exsnoms[count] = noms; - exps[count] = protected; - count++; - } - } else { - /* Not defined, imported, or otherwise bound */ - char buf[32], *phase_expl; - if (phase) { - if (SCHEME_FALSEP(phase)) { - phase_expl = " for-label"; - } else { - sprintf(buf, " for phase %" PRIdPTR, SCHEME_INT_VAL(phase)); - phase_expl = scheme_strdup(buf); - } - } else - phase_expl = ""; - scheme_wrong_syntax("module", prnt_name, form, - "provided identifier not defined or imported%s", - phase_expl); - } - } - } - - if (!k) - exvcount = count; - } - - excount = count; - - /* Discard exsnom[n]s if there are no re-exports */ - for (i = 0; i < excount; i++) { - if (!SCHEME_NULLP(exsnoms[i])) - break; - } - if (i >= excount) { - exsnoms = NULL; - } - - /* Discard exets if all 0 */ - if (exets) { - for (i = 0; i < excount; i++) { - if (exets[i]) - break; - } - if (i >= excount) - exets = NULL; - } - - /* Sort provide array for variables: interned followed by - uninterned, alphabetical within each. This is important for - having a consistent provide arrays. */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, exvcount, 1); - - /* Sort syntax, too, for deterministic output */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exvcount, excount-exvcount, 0); - - pt->num_provides = excount; - pt->num_var_provides = exvcount; - pt->provides = exs; - pt->provide_src_names = exsns; - pt->provide_srcs = exss; - pt->provide_nominal_srcs = exsnoms; - pt->provide_src_phases = exets; - - /* Discard exps if all 0 */ - if (exps) { - for (i = 0; i < excount; i++) { - if (exps[i]) - break; - } - if (i >= excount) - exps = NULL; - } - - if (exps) { - if (SCHEME_TRUEP(phase)) { - if ((SCHEME_INT_VAL(phase) < 0) - || (SCHEME_INT_VAL(phase) >= num_phases)) - scheme_signal_error("internal error: bad phase for exports"); - exp_infos[SCHEME_INT_VAL(phase)]->provide_protects = exps; - } - } - } - } -} - -/* Helper: */ -static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, - char *exps, int *exets, - Scheme_Object **exsnoms, - int start, int count, int do_uninterned) -{ - int i, j; - Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *pivot; - char tmp_exp; - int tmp_exet; - - if (do_uninterned) { - /* Look for uninterned and move to end: */ - - for (j = count; j--; ) { - if (!SCHEME_SYM_WEIRDP(exs[j])) - break; - } - - for (i = start; i < j; i++) { - if (SCHEME_SYM_WEIRDP(exs[i])) { - tmp_ex = exs[i]; - exs[i] = exs[j]; - exs[j] = tmp_ex; - - if (exsns) { - tmp_exsn = exsns[i]; - tmp_exs = exss[i]; - tmp_exp = exps[i]; - - exsns[i] = exsns[j]; - exss[i] = exss[j]; - exps[i] = exps[j]; - - exsns[j] = tmp_exsn; - exss[j] = tmp_exs; - exps[j] = tmp_exp; - } - if (exets) { - tmp_exet = exets[i]; - exets[i] = exets[j]; - exets[j] = tmp_exet; - } - if (exsnoms) { - tmp_exsnom = exsnoms[i]; - - exsnoms[i] = exsnoms[j]; - - exsnoms[j] = tmp_exsnom; - } - - j--; - /* Skip over uninterns already at the end: */ - while (j) { - if (!SCHEME_SYM_WEIRDP(exs[j])) - break; - else - j--; - } - } - } - - /* Sort interned and uninterned separately: */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, j + 1, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j + 1, count - j - 1, 0); - } else { - j = start; - while (count > 1) { - j = start; - pivot = exs[j]; - - for (i = 1; i < count; i++) { - int k = i + start; - if (strcmp(SCHEME_SYM_VAL(exs[k]), SCHEME_SYM_VAL(pivot)) < 0) { - tmp_ex = exs[k]; - exs[k] = exs[j]; - exs[j] = tmp_ex; - - if (exsns) { - tmp_exsn = exsns[k]; - tmp_exs = exss[k]; - tmp_exp = exps[k]; - - exsns[k] = exsns[j]; - exss[k] = exss[j]; - exps[k] = exps[j]; - - exsns[j] = tmp_exsn; - exss[j] = tmp_exs; - exps[j] = tmp_exp; - } - if (exets) { - tmp_exet = exets[k]; - exets[k] = exets[j]; - exets[j] = tmp_exet; - } - if (exsnoms) { - tmp_exsnom = exsnoms[k]; - - exsnoms[k] = exsnoms[j]; - - exsnoms[j] = tmp_exsnom; - } - - j++; - } - } - - if (j == start) { - start++; - --count; - } else - break; - } - - if (count > 1) { - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, start, j - start, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j, count - (j - start), 0); - } - } -} - -static Scheme_Object *expand_provide(Scheme_Object *e, int at_phase, - Scheme_Hash_Table *tables, - Scheme_Hash_Tree *all_defs, - Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Expand_Info erec1; - Scheme_Thread *p; - Scheme_Object *b, *stop; - Scheme_Comp_Env *xenv; - mz_jmp_buf newbuf, * volatile savebuf; - - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_FOR_STOPS), - NULL, - cenv); - stop = scheme_get_stop_expander(); - scheme_add_local_syntax(1, xenv); - if (!at_phase) - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv, 0); - else - scheme_set_local_syntax(0, scheme_datum_to_syntax(scheme_intern_symbol("begin"), - scheme_false, - scheme_sys_wraps_phase(scheme_make_integer(at_phase)), - 0, 0), - stop, xenv, 0); - - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.depth = -1; - - p = scheme_current_thread; - - b = scheme_make_pair((Scheme_Object *)tables, (Scheme_Object *)all_defs); - p->current_local_bindings = b; - - savebuf = p->error_buf; - p->error_buf = &newbuf; - - if (scheme_setjmp(newbuf)) { - Scheme_Thread *p2; - p2 = scheme_current_thread; - p2->current_local_bindings = NULL; - p2->error_buf = savebuf; - scheme_longjmp(*savebuf, 1); - return NULL; - } else { - e = scheme_expand_expr(e, xenv, &erec1, 0); - - p = scheme_current_thread; - p->current_local_bindings = NULL; - p->error_buf = savebuf; - - return e; - } -} - -void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, - int at_phase, - Scheme_Hash_Table *all_provided, - Scheme_Hash_Table *all_reprovided, - Scheme_Object *self_modidx, - Scheme_Hash_Table *all_defs_out, - Scheme_Hash_Table *tables, - Scheme_Hash_Tree *all_defs, - Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded) -{ - Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL, *rebuild_from = scheme_null; - int protect_cnt = 0, mode_cnt = 0, expanded = 0; - Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL; - Scheme_Object *all_x_defs_out, *all_x_defs; - Scheme_Hash_Table *provided; - Scheme_Object *phase; - - if (scheme_stx_proper_list_length(e) < 0) - scheme_wrong_syntax(NULL, e, form, IMPROPER_LIST_FORM); - - for (l = SCHEME_STX_CDR(e); !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) { - Scheme_Object *a, *midx, *name, *av; - - a = SCHEME_STX_CAR(l); - - while (1) { - if (SCHEME_STX_PAIRP(a) && (scheme_stx_proper_list_length(a) > 0)) { - fst = SCHEME_STX_CAR(a); - if (SCHEME_STX_SYMBOLP(fst)) - av = SCHEME_STX_VAL(fst); - else - av = NULL; - if (SAME_OBJ(protect_symbol, av)) { - if (protect_cnt) - scheme_wrong_syntax(NULL, a, e, "nested `protect' not allowed"); - if (_expanded) - rebuild_from = scheme_make_pair(a, rebuild_from); - protect_stx = a; - a = SCHEME_STX_CDR(a); - a = scheme_flatten_syntax_list(a, NULL); - l = SCHEME_STX_CDR(l); - l = scheme_append(a, l); - protect_cnt = scheme_list_length(a); - - if (protect_cnt != 1) - expanded = 1; - - /* In case a provide ends with an empty protect: */ - if (SCHEME_STX_NULLP(l)) - break; - - a = SCHEME_STX_CAR(l); - } else if (SAME_OBJ(av, for_syntax_symbol) - || SAME_OBJ(av, for_label_symbol) - || SAME_OBJ(av, for_meta_symbol)) { - if (mode_cnt) - scheme_wrong_syntax(NULL, a, e, - (SAME_OBJ(av, for_syntax_symbol) - ? "nested `for-syntax' not allowed" - : (SAME_OBJ(av, for_label_symbol) - ? "nested `for-label' not allowed" - : "nested `for-meta' not allowed"))); - - mode_stx = a; - a = SCHEME_STX_CDR(a); - a = scheme_flatten_syntax_list(a, NULL); - if (SAME_OBJ(av, for_meta_symbol)) { - if (SCHEME_NULLP(a)) { - scheme_wrong_syntax(NULL, mode_stx, e, "missing `for-meta' phase"); - } - mode = SCHEME_CAR(a); - mode = SCHEME_STX_VAL(mode); - if (!SCHEME_FALSEP(mode) - && !SCHEME_INTP(mode) - && !SCHEME_BIGNUMP(mode)) { - scheme_wrong_syntax(NULL, mode_stx, e, "bad `for-meta' phase"); - } - a = SCHEME_CDR(a); - } else if (SAME_OBJ(av, for_syntax_symbol)) - mode = scheme_make_integer(1); - else if (SAME_OBJ(av, for_label_symbol)) - mode = scheme_false; - l = SCHEME_STX_CDR(l); - l = scheme_append(a, l); - mode_cnt = scheme_list_length(a); - if (protect_cnt) - protect_cnt += (mode_cnt - 1);; - a = SCHEME_STX_CAR(l); - } else - break; - } else - break; - } - - if (SCHEME_FALSEP(mode)) - phase = mode; - else - phase = scheme_bin_plus(mode, scheme_make_integer(at_phase)); - - all_x_defs_out = scheme_hash_get(all_defs_out, phase); - if (!all_x_defs_out) all_x_defs_out = scheme_null; - - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, phase); - if (!provided) { - provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(all_provided, phase, (Scheme_Object *)provided); - } - - if (SCHEME_STX_SYMBOLP(a)) { - /* */ - name = SCHEME_STX_VAL(a); - check_already_provided(provided, name, a, protect_cnt, form, phase); - /* Provide a: */ - scheme_hash_set(provided, name, scheme_make_pair(a, protect_cnt ? scheme_true : scheme_false)); - } else if (SCHEME_STX_PAIRP(a)) { - Scheme_Object *rest; - - fst = SCHEME_STX_CAR(a); - rest = SCHEME_STX_CDR(a); - - if (SAME_OBJ(expand_symbol, SCHEME_STX_VAL(fst))) { - Scheme_Object *p; - int islist; - - if (SCHEME_STX_PAIRP(rest)) { - p = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "extra forms after one to expand"); - } else { - scheme_wrong_syntax(NULL, a, e, "missing form to expand"); - return; - } - - all_x_defs = scheme_hash_tree_get(all_defs, mode); - if (!all_x_defs) all_x_defs = scheme_null; - p = expand_provide(p, at_phase, tables, all_defs, cenv, rec, drec); - - if (_expanded) - rebuild_from = scheme_make_pair(p, rebuild_from); - - /* Check for '(begin datum ...) result: */ - p = scheme_flatten_syntax_list(p, &islist); - if (!islist) - p = NULL; - else if (SCHEME_NULLP(p)) - p = NULL; - else { - rest = SCHEME_CAR(p); - if (!SCHEME_STX_SYMBOLP(rest) - || !scheme_stx_free_eq_x(scheme_begin_stx, rest, at_phase)) { - p = NULL; - } - } - - if (!p) { - scheme_wrong_syntax(NULL, a, e, "expansion was not a `begin' sequence"); - return; - } - - p = SCHEME_CDR(p); - l = SCHEME_STX_CDR(l); - l = scheme_make_pair(scheme_false, scheme_append(p, l)); - - if (protect_cnt) { - protect_cnt += scheme_stx_proper_list_length(p); - } - if (mode_cnt) { - mode_cnt += scheme_stx_proper_list_length(p); - } - - expanded = 1; - } else if (SAME_OBJ(rename_symbol, SCHEME_STX_VAL(fst))) { - /* (rename ) */ - Scheme_Object *inm, *enm; - - if (!SCHEME_STX_PAIRP(rest) - || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - inm = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - enm = SCHEME_STX_CAR(rest); - if (!SCHEME_STX_SYMBOLP(inm)) - scheme_wrong_syntax(NULL, a, e, "internal name is not an identifier"); - if (!SCHEME_STX_SYMBOLP(enm)) - scheme_wrong_syntax(NULL, a, e, "external name is not an identifier"); - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "data following external name"); - - enm = SCHEME_STX_VAL(enm); - - check_already_provided(provided, enm, inm, protect_cnt, a, phase); - /* Provide enm: */ - scheme_hash_set(provided, enm, scheme_make_pair(inm, protect_cnt ? scheme_true : scheme_false)); - } else if (SAME_OBJ(all_from_symbol, SCHEME_STX_VAL(fst))) { - /* (all-from ) */ - Scheme_Object *reprovided; - - if (protect_cnt) - scheme_wrong_syntax(NULL, a, e, "not allowed as protected"); - if (!SCHEME_STX_PAIRP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) - scheme_wrong_syntax(NULL, a, e, "data following `all-from'"); - - midx = SCHEME_STX_CAR(rest); - midx = scheme_make_modidx(scheme_syntax_to_datum(midx, 0, NULL), - self_modidx, - scheme_false); - - reprovided = scheme_hash_get(all_reprovided, mode); - if (!reprovided) - reprovided = scheme_null; - - reprovided = scheme_make_pair(scheme_make_pair(midx, scheme_make_pair(e, scheme_null)), - reprovided); - - scheme_hash_set(all_reprovided, mode, reprovided); - } else if (SAME_OBJ(all_from_except_symbol, SCHEME_STX_VAL(fst))) { - /* (all-from-except ...) */ - Scheme_Object *reprovided; - Scheme_Object *exns, *el, *p; - int len; - - if (protect_cnt) - scheme_wrong_syntax(NULL, a, e, "not allowed as protected"); - - len = scheme_stx_proper_list_length(a); - - if (len < 0) - scheme_wrong_syntax(NULL, a, e, IMPROPER_LIST_FORM); - else if (len == 1) - scheme_wrong_syntax(NULL, a, e, "missing module name"); - - midx = SCHEME_STX_CAR(rest); - midx = scheme_make_modidx(scheme_syntax_to_datum(midx, 0, NULL), - self_modidx, - scheme_false); - exns = SCHEME_STX_CDR(rest); - - /* Check all exclusions are identifiers: */ - for (el = exns; SCHEME_STX_PAIRP(el); el = SCHEME_STX_CDR(el)) { - p = SCHEME_STX_CAR(el); - if (!SCHEME_STX_SYMBOLP(p)) { - scheme_wrong_syntax(NULL, p, e, - "excluded name is not an identifier"); - } - } - - reprovided = scheme_hash_get(all_reprovided, mode); - if (!reprovided) - reprovided = scheme_null; - - reprovided = scheme_make_pair(scheme_make_pair(midx, scheme_make_pair(e, exns)), - reprovided); - - scheme_hash_set(all_reprovided, mode, reprovided); - } else if (SAME_OBJ(struct_symbol, SCHEME_STX_VAL(fst))) { - /* (struct ( ...)) */ - int len, i; - Scheme_Object *prnt_base, *base, *fields, *el, **names, *p; - - len = scheme_stx_proper_list_length(rest); - if (len != 2) { - if (len < 0) - scheme_wrong_syntax(NULL, a, e, IMPROPER_LIST_FORM); - else - scheme_wrong_syntax(NULL, a, e, - "not a struct identifier followed by " - "a sequence of field identifiers"); - } - - base = SCHEME_STX_CAR(rest); - fields = SCHEME_STX_CDR(rest); - fields = SCHEME_STX_CAR(fields); - - if (!SCHEME_STX_SYMBOLP(base)) - scheme_wrong_syntax(NULL, base, e, - "struct name is not an identifier"); - - /* Check all field names are identifiers: */ - for (el = fields; SCHEME_STX_PAIRP(el); el = SCHEME_STX_CDR(el)) { - p = SCHEME_STX_CAR(el); - if (!SCHEME_STX_SYMBOLP(p)) { - scheme_wrong_syntax(NULL, p, e, - "field name is not an identifier"); - } - } - if (!SCHEME_STX_NULLP(el)) - scheme_wrong_syntax(NULL, fields, e, IMPROPER_LIST_FORM); - - prnt_base = base; - base = SCHEME_STX_VAL(base); - fields = scheme_syntax_to_datum(fields, 0, NULL); - - names = scheme_make_struct_names(base, fields, SCHEME_STRUCT_EXPTIME, &len); - - for (i = 0; i < len; i++) { - /* Wrap local name with prnt_base in case there are scopes that - trigger "gensym"ing */ - p = scheme_datum_to_syntax(names[i], scheme_false, prnt_base, 0, 0); - check_already_provided(provided, names[i], p, protect_cnt, e, phase); - scheme_hash_set(provided, names[i], - scheme_make_pair(p, protect_cnt ? scheme_true : scheme_false)); - } - } else if (SAME_OBJ(all_defined_symbol, SCHEME_STX_VAL(fst))) { - /* (all-defined) */ - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - - if (!all_x_defs_out) { - scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", - mode); - } - - all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - scheme_false)), - protect_cnt ? scheme_true : scheme_false), - all_x_defs_out); - } else if (SAME_OBJ(prefix_all_defined_symbol, SCHEME_STX_VAL(fst))) { - /* (prefix-all-defined ) */ - Scheme_Object *prefix; - - if (!SCHEME_STX_PAIRP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - prefix = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - scheme_wrong_syntax(NULL, a, e, "bad syntax"); - - if (!SCHEME_STX_SYMBOLP(prefix)) { - scheme_wrong_syntax(NULL, a, e, - "prefix is not an identifier"); - } - prefix = SCHEME_STX_VAL(prefix); - - if (!all_x_defs_out) { - scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", - mode); - } - - all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_x_defs_out); - } else if (SAME_OBJ(all_defined_except_symbol, SCHEME_STX_VAL(fst)) - || SAME_OBJ(prefix_all_defined_except_symbol, SCHEME_STX_VAL(fst))) { - /* ([prefix-]all-defined-except ...) */ - Scheme_Object *exns, *el, *prefix = scheme_false, *p; - int len, is_prefix; - - is_prefix = SAME_OBJ(prefix_all_defined_except_symbol, SCHEME_STX_VAL(fst)); - - len = scheme_stx_proper_list_length(a); - - if (len < 0) - scheme_wrong_syntax(NULL, a, e, IMPROPER_LIST_FORM); - - if (is_prefix && (len < 2)) - scheme_wrong_syntax(NULL, a, e, "missing prefix"); - - if (is_prefix) { - prefix = SCHEME_STX_CAR(rest); - if (!SCHEME_STX_SYMBOLP(prefix)) - scheme_wrong_syntax(NULL, a, e, "prefix is not an identifier"); - prefix = SCHEME_STX_VAL(prefix); - rest = SCHEME_STX_CDR(rest); - } - - exns = rest; - - /* Check all exclusions are identifiers: */ - for (el = exns; SCHEME_STX_PAIRP(el); el = SCHEME_STX_CDR(el)) { - p = SCHEME_STX_CAR(el); - if (!SCHEME_STX_SYMBOLP(p)) { - scheme_wrong_syntax(NULL, p, e, - "excluded name is not an identifier"); - } - } - - if (!all_x_defs_out) { - scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", - mode); - } - - all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(exns, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_x_defs_out); - } else { - scheme_wrong_syntax(NULL, a, e, NULL); - } - } else { - scheme_wrong_syntax(NULL, a, e, NULL); - } - - a = SCHEME_STX_CAR(l); - if (SCHEME_TRUEP(a)) { - if (protect_cnt) { - Scheme_Object *f; - f = SCHEME_STX_CAR(protect_stx); - a = scheme_make_pair(f, scheme_make_pair(a, scheme_null)); - a = scheme_datum_to_syntax(a, protect_stx, protect_stx, 0, 0); - } - if (!SAME_OBJ(mode, scheme_make_integer(0))) { - Scheme_Object *f; - f = SCHEME_STX_CDR(mode_stx); - f = SCHEME_STX_CAR(f); - a = scheme_make_pair(for_meta_symbol, - scheme_make_pair(f, - scheme_make_pair(a, scheme_null))); - a = scheme_datum_to_syntax(a, mode_stx, mode_stx, 0, 0); - } - rebuilt = scheme_make_pair(a, rebuilt); - } - - if (protect_cnt) - --protect_cnt; - - if (all_x_defs_out) - scheme_hash_set(all_defs_out, mode, all_x_defs_out); - - if (mode_cnt) { - --mode_cnt; - if (!mode_cnt) - mode = scheme_make_integer(0); - } - } - - if (_expanded) { - if (expanded) { - Scheme_Object *a; - a = SCHEME_STX_CAR(e); - rebuilt = scheme_make_pair(a, scheme_reverse(rebuilt)); - rebuilt = scheme_datum_to_syntax(rebuilt, e, e, 0, 2); - - while (SCHEME_PAIRP(rebuild_from)) { - rebuilt = scheme_stx_track(rebuilt, SCHEME_CAR(rebuild_from), NULL); - rebuild_from = SCHEME_CDR(rebuild_from); - } - - *_expanded = rebuilt; - } else { - *_expanded = e; - } - } -} - -static int check_in_hash(Scheme_Object *mp, Scheme_Object *data) -{ - Scheme_Object *v; - v = scheme_hash_get((Scheme_Hash_Table *)data, mp); - return v && SAME_OBJ(v, scheme_true); -} - -static int check_is_submodule(Scheme_Object *modname, Scheme_Object *_genv) -{ - Scheme_Env *genv = (Scheme_Env *)_genv; - Scheme_Object *l, *n; - - if (genv->module) { - l = genv->module->pre_submodule_names; - if (!l) - l = genv->module->pre_submodules; - if (l) { - while (!SCHEME_NULLP(l)) { - n = SCHEME_CAR(l); - if (SCHEME_SYMBOLP(n)) { - if (SAME_OBJ(n, modname)) - return 1; - } else { - n = scheme_resolved_module_path_value(((Scheme_Module *)n)->modname); - while (SCHEME_PAIRP(SCHEME_CDR(n))) { - n = SCHEME_CDR(n); - } - n = SCHEME_CAR(n); - if (SAME_OBJ(n, modname)) - return 1; - } - l = SCHEME_CDR(l); - } - } - } - - return 0; -} - -static Scheme_Object *convert_submodule_path(Scheme_Object *name, - Convert_Submodule_Proc check, - Scheme_Object *check_data) -{ - Scheme_Object *mp, *v; - - if (SAME_OBJ(SCHEME_CAR(name), submod_symbol) - && SCHEME_PAIRP(SCHEME_CDR(name)) - && SCHEME_PAIRP(SCHEME_CDR(SCHEME_CDR(name))) - && scheme_is_list(name)) - mp = SCHEME_CADR(name); - else - mp = name; - - if (SCHEME_PAIRP(mp) - && SAME_OBJ(SCHEME_CAR(mp), quote_symbol) - && SCHEME_PAIRP(SCHEME_CDR(mp)) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(mp)))) { - mp = SCHEME_CADR(mp); - if (check(mp, check_data)) { - /* convert to `submod' format */ - if (SAME_OBJ(SCHEME_CAR(name), submod_symbol)) - v = SCHEME_CDR(SCHEME_CDR(name)); - else - v = scheme_null; - name = scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string("."), - scheme_make_pair(mp, v))); - } - } - - return name; -} - -Scheme_Object *scheme_module_exported_list(Scheme_Object *modpath, Scheme_Env *genv) -{ - Scheme_Object *modname, *l, *modidx, *stx, *phase, *result; - Scheme_Module *m; - int i, j; - Scheme_Module_Phase_Exports *pt; - - if (SCHEME_STXP(modpath)) { - stx = modpath; - modpath = scheme_syntax_to_datum(stx, 0, NULL); - } else - stx = NULL; - - modpath = convert_submodule_path(modpath, check_is_submodule, - (Scheme_Object *)genv); - - modidx = scheme_make_modidx(modpath, - (genv->module ? genv->module->self_modidx : scheme_false), - scheme_false); - - modname = _module_resolve(modidx, stx, NULL, 1); - - m = module_load(modname, genv, "syntax-local-module-exports"); - - if (!m) { - /* Can we get here? */ - return scheme_null; - } else { - result = scheme_null; - - for (i = -3; i < (m->me->other_phases ? m->me->other_phases->size : 0); i++) { - l = scheme_null; - switch (i) { - case -3: - pt = m->me->rt; - phase = scheme_make_integer(0); - break; - case -2: - pt = m->me->et; - phase = scheme_make_integer(1); - break; - case -1: - pt = m->me->dt; - phase = scheme_false; - break; - default: - pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[i]; - phase = m->me->other_phases->keys[i]; - break; - } - if (pt) { - for (j = 0; j < pt->num_provides; j++) { - l = scheme_make_pair(pt->provides[j], l); - } - - result = scheme_make_pair(scheme_make_pair(phase, l), - result); - } - } - - return result; - } -} - -static int expression_starts(Scheme_Object *expr, Scheme_Object *id, int phase) -{ - if (SCHEME_STX_PAIRP(expr)) { - expr = SCHEME_STX_CAR(expr); - if (SCHEME_STX_SYMBOLP(expr)) { - if (scheme_stx_free_eq_x(id, expr, phase)) - return 1; - } - } - - return 0; -} - -static int expression_starts_app(Scheme_Object *expr, Scheme_Object *id, int phase) -{ - if (expression_starts(expr, app_stx, phase)) { - expr = SCHEME_STX_CDR(expr); - return expression_starts(expr, id, phase); - } else if (expression_starts(expr, id, phase)) { - /* would explicit `#%app' be the core one? */ - id = scheme_datum_to_syntax(SCHEME_STX_VAL(app_stx), expr, expr, 0, 0); - id = scheme_stx_taint_rearm(id, expr); - if (scheme_stx_free_eq_x(app_stx, id, phase)) - return 1; - } - - return 0; -} - -static Scheme_Object *expression_app_args(Scheme_Object *expr, int phase) -{ - if (expression_starts(expr, app_stx, phase)) { - expr = SCHEME_STX_CDR(expr); - return SCHEME_STX_CDR(expr); - } else - return SCHEME_STX_CDR(expr); -} - -static int phaseless_literal(Scheme_Object *val) -{ - val = SCHEME_STX_VAL(val); - - if (SCHEME_BOOLP(val) - || SCHEME_SYMBOLP(val) - || SCHEME_KEYWORDP(val) - || SCHEME_NULLP(val) - || SCHEME_NUMBERP(val) - || (SCHEME_CHAR_STRINGP(val) && SCHEME_IMMUTABLEP(val)) - || (SCHEME_BYTE_STRINGP(val) && SCHEME_IMMUTABLEP(val))) - return 1; - - return 0; -} - -static int phaseless_constant_expression(Scheme_Object *val, int phase); - -static int phaseless_constant_expressions(Scheme_Object *expr, int phase) -{ - Scheme_Object *a; - - while (SCHEME_STX_PAIRP(expr)) { - a = SCHEME_STX_CAR(expr); - if (!phaseless_constant_expression(a, phase)) - return 0; - expr = SCHEME_STX_CDR(expr); - } - - return SCHEME_STX_NULLP(expr); -} - -static Scheme_Object *phaseless_constant_expression_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *val = (Scheme_Object *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - if (phaseless_constant_expression(val, p->ku.k.i1)) - return scheme_true; - else - return scheme_false; -} - -static int phaseless_constant_expression(Scheme_Object *val, int phase) -{ -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)val; - p->ku.k.i1 = phase; - val = scheme_handle_stack_overflow(phaseless_constant_expression_k); - return SCHEME_TRUEP(val); - } - - /* identifier? */ - if (SCHEME_SYMBOLP(SCHEME_STX_VAL(val))) - return 1; - - if (expression_starts(val, lambda_stx, phase)) - return 1; - - if (expression_starts(val, case_lambda_stx, phase)) - return 1; - - if (expression_starts(val, quote_stx, phase)) { - val = SCHEME_STX_CDR(val); - if (SCHEME_STX_PAIRP(val)) { - val = SCHEME_STX_CAR(val); - if (phaseless_literal(val)) - return 1; - } - return 0; - } else if (expression_starts(val, datum_stx, phase)) { - val = SCHEME_STX_CDR(val); - if (phaseless_literal(val)) - return 1; - return 0; - } else if (phaseless_literal(val)) { - /* would explicit `#%datum' be the core one? */ - Scheme_Object *a; - a = SCHEME_STX_VAL(datum_stx); - val = scheme_stx_taint_rearm(scheme_datum_to_syntax(a, val, val, 0, 0), - val); - if (scheme_stx_free_eq_x(datum_stx, val, phase)) - return 1; - return 0; - } - - if (expression_starts_app(val, cons_stx, phase) - || expression_starts_app(val, list_stx, phase)) { - val = expression_app_args(val, phase); - return phaseless_constant_expressions(val, phase); - } - - return 0; -} - -static int expression_string_argument(Scheme_Object *val, int phase) -{ - Scheme_Object *a, *av; - - if (SCHEME_STX_PAIRP(val)) { - a = SCHEME_STX_CAR(val); - val = SCHEME_STX_CDR(val); - if (SCHEME_STX_NULLP(val)) { - av = SCHEME_STX_VAL(a); - if (SCHEME_CHAR_STRINGP(av) - && phaseless_constant_expression(a, phase)) - return 1; - else if (expression_starts(a, quote_stx, phase)) { - val = SCHEME_STX_CDR(a); - if (SCHEME_STX_PAIRP(val)) { - val = SCHEME_STX_CAR(val); - a = SCHEME_STX_VAL(val); - if (SCHEME_CHAR_STRINGP(a)) - return 1; - } - } - } - } - - return 0; -} - -static int phaseless_rhs(Scheme_Object *val, int var_count, int phase) -{ - if (var_count == 1) { - if (phaseless_constant_expression(val, phase)) - return 1; - else if (expression_starts_app(val, gensym_stx, phase)) { - val = expression_app_args(val, phase); - if (SCHEME_STX_NULLP(val)) - return 1; - else if (expression_string_argument(val, phase)) - return 1; - } else if (expression_starts_app(val, string_to_uninterned_symbol_stx, phase)) { - val = expression_app_args(val, phase); - if (expression_string_argument(val, phase)) - return 1; - } - } else if (var_count == 5) { - if (expression_starts_app(val, make_struct_type_stx, phase) - && phaseless_constant_expressions(val, phase)) { - return 1; - } - } else if (var_count == 3) { - if (expression_starts_app(val, make_struct_type_property_stx, phase) - && phaseless_constant_expressions(val, phase)) { - return 1; - } - } - - return 0; -} - -/**********************************************************************/ -/* top-level require */ -/**********************************************************************/ - -void add_single_require(Scheme_Module_Exports *me, /* from module */ - Scheme_Object *only_phase, - Scheme_Object *src_phase_index, /* import from phase 0 to src_phase_index */ - Scheme_Object *idx, /* from module's idx; may be saved for unmarshalling */ - Scheme_Env *orig_env, /* env for scope_src or copy_vars */ - Scheme_Object *rn_set, /* add requires to renames in this set when no scope_src */ - Scheme_Object *rn_stx, /* module context-as-stx that corresponds to all_simple */ - Scheme_Object *exns, /* NULL or [syntax] list of [syntax] symbols not to import */ - Scheme_Hash_Table *onlys, /* NULL or hash table of names to import; the hash table is mutated */ - Scheme_Object *prefix, /* NULL or prefix symbol */ - Scheme_Object *iname, /* NULL or symbol for a single import */ - Scheme_Object *orig_ename, /* NULL or symbol for a single import */ - Scheme_Object *scope_src, /* default scope_src; if onlys, each is also scope_src */ - int copy_vars, - int *all_simple, - Check_Func ck, /* NULL or called for each addition */ - void *data, - Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *cki, /* ck args */ - Scheme_Hash_Table *collapse_table) /* hints for collapsing to a shared table */ -{ - int j, var_count; - Scheme_Object *to_phase; - Scheme_Object **exs, **exsns, **exss; - int *exets; - Scheme_Object *nominal_modidx, *one_exn, *name, *rn, *ename = orig_ename; - Scheme_Hash_Table *orig_onlys; - int k, shared_rename, do_copy_vars; - Scheme_Env *name_env; - int can_save_marshal = 1; - - if (scope_src) { - if (all_simple - && *all_simple - && rn_stx - && SCHEME_STXP(rn_stx) - && !scheme_stx_equal_module_context(scope_src, rn_stx)) - *all_simple = 0; - } - - if (iname || ename || onlys) - can_save_marshal = 0; - - if (onlys) - orig_onlys = scheme_clone_hash_table(onlys); - else - orig_onlys = NULL; - - for (k = -3; k < (me->other_phases ? me->other_phases->size : 0); k++) { - Scheme_Module_Phase_Exports *pt; - - switch(k) { - case -3: - pt = me->rt; - break; - case -2: - pt = me->et; - break; - case -1: - pt = me->dt; - break; - default: - pt = (Scheme_Module_Phase_Exports *)me->other_phases->vals[k]; - break; - } - - if (pt && only_phase) { - if (!scheme_eqv(pt->phase_index, only_phase)) - pt = NULL; - } - - name_env = orig_env; - if (pt) { - if (SCHEME_FALSEP(pt->phase_index) - || SCHEME_FALSEP(src_phase_index)) { - to_phase = scheme_false; - scheme_prepare_label_env(name_env); - name_env = name_env->label_env; - } else { - if (orig_env) { - to_phase = pt->phase_index; - while (SCHEME_INT_VAL(to_phase) > 0) { - scheme_prepare_exp_env(name_env); - name_env = name_env->exp_env; - to_phase = scheme_bin_minus(to_phase, scheme_make_integer(1)); - } - while (SCHEME_INT_VAL(to_phase) < 0) { - scheme_prepare_template_env(name_env); - name_env = name_env->template_env; - to_phase = scheme_bin_plus(to_phase, scheme_make_integer(1)); - } - } - to_phase = scheme_bin_plus(pt->phase_index, src_phase_index); - } - } else - to_phase = NULL; - - if (pt) { - one_exn = NULL; - - nominal_modidx = idx; - - rn = scheme_module_context_at_phase(rn_set, to_phase); - - if (copy_vars) - do_copy_vars = !orig_env->module && !orig_env->phase && SAME_OBJ(src_phase_index, scheme_make_integer(0)) && (k == -3); - else - do_copy_vars = 0; - - if (can_save_marshal - && !orig_ename - && pt->num_provides - && !do_copy_vars) { - /* Simple "import everything" (possibly with prefix and exceptions) - whose mappings can be shared via the exporting module: */ - if (!pt->src_modidx && me->src_modidx) - pt->src_modidx = me->src_modidx; - shared_rename = 1; - } else - shared_rename = 0; - - exs = pt->provides; - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - exets = pt->provide_src_phases; - var_count = pt->num_var_provides; - - for (j = pt->num_provides; j--; ) { - Scheme_Object *modidx; - - if (orig_ename) { - if (!SAME_OBJ(SCHEME_STX_VAL(orig_ename), exs[j])) - continue; /* we don't want this one. */ - } else if (onlys) { - name = scheme_hash_get(orig_onlys, exs[j]); - if (!name) - continue; /* we don't want this one. */ - scope_src = name; - /* Remove to indicate that it's been imported: */ - scheme_hash_set(onlys, exs[j], NULL); - } else { - if (exns) { - Scheme_Object *l, *a; - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (SCHEME_STXP(a)) - a = SCHEME_STX_VAL(a); - if (SAME_OBJ(a, exs[j])) - break; - } - if (!SCHEME_STX_NULLP(l)) - continue; /* we don't want this one. */ - } - - if (one_exn) { - if (SAME_OBJ(one_exn, exs[j])) - continue; /* we don't want this one. */ - } - } - - modidx = ((exss && !SCHEME_FALSEP(exss[j])) - ? scheme_modidx_shift(exss[j], me->src_modidx, idx) - : idx); - - if (SCHEME_SYM_WEIRDP(exs[j])) { - /* This shouldn't happen. In case it does, don't import a - gensym or parallel symbol. The former is useless. The - latter is supposed to be module-specific, and it could - collide with local module-specific ids. */ - iname = NULL; - continue; - } - - if (!iname) - iname = exs[j]; - - if (prefix) - iname = scheme_symbol_append(prefix, iname); - - if (scope_src) - iname = scheme_datum_to_syntax(iname, scheme_false, scope_src, 0, 0); - else { - iname = scheme_datum_to_syntax(iname, scheme_false, scheme_false, 0, 0); - iname = scheme_stx_add_module_context(iname, rn); - } - - if (ck) - ck(iname, (orig_env->module ? orig_env->module->self_modidx : NULL), - nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, - (j < var_count), - data, cki, form, err_src, scope_src, to_phase, src_phase_index, pt->phase_index); - - { - int done; - - if (do_copy_vars && (j < var_count)) { - Scheme_Env *menv; - Scheme_Object *val, *modname; - Scheme_Bucket *b; - modname = scheme_module_resolve(modidx, 1); - menv = scheme_module_access(modname, orig_env, 0); - val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]); - b = scheme_global_bucket(scheme_global_binding(iname, orig_env, 0), orig_env); - scheme_set_global_bucket(((copy_vars == 2) - ? "namespace-require/constant" - : "namespace-require/copy"), - b, val, 1); - if (copy_vars == 2) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; - done = 0; - } else { - scheme_shadow(orig_env, (Scheme_Object *)b->key, val, 1); - done = 1; - } - } else - done = 0; - - if (!pt->src_modidx && me->src_modidx) - pt->src_modidx = me->src_modidx; - - if (!done && !shared_rename) { - scheme_add_module_binding_w_nominal(iname, to_phase, - modidx, exsns[j], (exets - ? scheme_make_integer(exets[j]) - : scheme_make_integer(0)), - scheme_module_context_inspector(rn), - nominal_modidx, exs[j], - src_phase_index, - pt->phase_index, - pt, collapse_table); - } - } - - iname = NULL; - - if (ename) { - ename = NULL; - break; - } - } - - if (shared_rename) { - Scheme_Hash_Tree *excepts; - - if (exns) { - Scheme_Object *l, *a; - excepts = scheme_make_hash_tree(SCHEME_hashtr_eq); - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (SCHEME_STXP(a)) - a = SCHEME_STX_VAL(a); - excepts = scheme_hash_tree_set(excepts, a, scheme_true); - } - } else - excepts = NULL; - - scheme_extend_module_context_with_shared(rn, idx, pt, - (prefix ? prefix : scheme_false), - excepts, - src_phase_index, scope_src, - NULL); - } - } - } - - if (ename) { - scheme_wrong_syntax(NULL, ename, form, "no such provided variable"); - return; - } -} - -void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *req_modidx, - Scheme_Object *context, - Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase, - Scheme_Object *prefix, /* a sybmol; not included in `excepts` keys */ - Scheme_Hash_Tree *excepts, /* NULL => empty */ - Scheme_Hash_Table *export_registry, - Scheme_Object *insp_desc, Scheme_Object *req_insp_desc, - Scheme_Object *replace_at) -{ - Scheme_Object *name; - Scheme_Module_Exports *me; - Scheme_Env *env; - Scheme_Module *mod; - Scheme_Module_Phase_Exports *pt; - - name = scheme_module_resolve(modidx, 0); - - mod = get_special_module(name); - if (mod) - me = mod->me; - else - me = NULL; - - if (!me) { - if (!export_registry) { - env = scheme_get_env(scheme_current_config()); - export_registry = env->module_registry->exports; - } - - me = (Scheme_Module_Exports *)scheme_hash_get(export_registry, name); - if (!me) { - scheme_signal_error("compiled/expanded code out of context;" - " cannot find exports to restore imported renamings" - " for module: %D", - name); - return; - } - } - - if (SAME_OBJ(pt_phase, scheme_make_integer(0))) - pt = me->rt; - else if (SAME_OBJ(pt_phase, scheme_make_integer(1))) - pt = me->et; - else if (SAME_OBJ(pt_phase, scheme_false)) - pt = me->dt; - else if (me->other_phases) - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(me->other_phases, pt_phase); - else - pt = NULL; - - if (pt) { - if (!pt->src_modidx && me->src_modidx) - pt->src_modidx = me->src_modidx; - scheme_extend_module_context_with_shared(scheme_make_pair(bind_phase, req_insp_desc), - req_modidx, pt, - prefix, excepts, - src_phase, context, - replace_at); - } -} - -Scheme_Object *scheme_get_kernel_modidx(void) -{ - return kernel_modidx; -} - -void parse_requires(Scheme_Object *form, int at_phase, - Scheme_Object *base_modidx, - Scheme_Env *main_env, - Scheme_Module *for_m, - Scheme_Object *rn_set, - Check_Func ck, void *data, - Scheme_Object *redef_modname, - int copy_vars, - int eval_exp, int eval_run, - int *all_simple, - Scheme_Hash_Table *modidx_cache, - Scheme_Hash_Table *submodule_names, - int *non_phaseless) -/* form can be a module-path index or a quoted require spec */ -{ - Scheme_Object *ll = form, *mode = scheme_make_integer(0), *just_mode = NULL, *x_mode, *x_just_mode; - Scheme_Module *m; - Scheme_Object *idxstx, *idx, *name, *i, *exns, *prefix, *iname, *ename, *aa, *aav; - Scheme_Object *scope_src, *err_src; - Scheme_Hash_Table *onlys; - Scheme_Env *env; - int skip_one, mode_cnt = 0, just_mode_cnt = 0, is_mpi; - Scheme_Hash_Table *collapse_table; - - if (SAME_TYPE(SCHEME_TYPE(form), scheme_module_index_type)) { - ll = scheme_make_pair(scheme_false, scheme_make_pair(form, scheme_null)); - is_mpi = 1; - } else { - if (scheme_stx_proper_list_length(form) < 0) - scheme_wrong_syntax(NULL, NULL, form, IMPROPER_LIST_FORM); - is_mpi = 0; - } - - collapse_table = scheme_make_hash_table(SCHEME_hash_ptr); - - for (ll = SCHEME_STX_CDR(ll); !SCHEME_STX_NULLP(ll); ll = SCHEME_STX_CDR(ll)) { - i = SCHEME_STX_CAR(ll); - iname = ename = NULL; - onlys = NULL; - if (SCHEME_STX_PAIRP(i)) { - aa = SCHEME_STX_CAR(i); - aav = SCHEME_STX_VAL(aa); - } else { - aa = NULL; - aav = NULL; - } - - err_src = i; - scope_src = i; - skip_one = 0; - - if (is_mpi) { - idxstx = i; - exns = NULL; - prefix = NULL; - scope_src = NULL; - } else if (SAME_OBJ(for_syntax_symbol, aav) - || SAME_OBJ(for_template_symbol, aav) - || SAME_OBJ(for_label_symbol, aav) - || SAME_OBJ(for_meta_symbol, aav) - || SAME_OBJ(just_meta_symbol, aav)) { - if (!SAME_OBJ(just_meta_symbol, aav)) { - if (mode_cnt) - scheme_wrong_syntax(NULL, i, form, - (SAME_OBJ(for_syntax_symbol, aav) - ? "nested `for-syntax' not allowed" - : (SAME_OBJ(for_template_symbol, aav) - ? "nested `for-template' not allowed" - : (SAME_OBJ(for_label_symbol, aav) - ? "nested `for-label' not allowed" - : "nested `for-meta' not allowed")))); - } else { - if (just_mode_cnt) - scheme_wrong_syntax(NULL, i, form, "nested `just-meta' not allowed"); - } - - aa = scheme_flatten_syntax_list(i, NULL); - ll = SCHEME_STX_CDR(ll); - if (SAME_OBJ(for_meta_symbol, aav) - || SAME_OBJ(just_meta_symbol, aav)) { - Scheme_Object *a_mode; - aa = SCHEME_STX_CDR(aa); - if (SCHEME_STX_NULLP(aa)) - scheme_wrong_syntax(NULL, i, form, "missing `%s-meta' level specification", - (SAME_OBJ(for_meta_symbol, aav) ? "for" : "just")); - a_mode = SCHEME_STX_CAR(aa); - a_mode = SCHEME_STX_VAL(a_mode); - if (!SCHEME_FALSEP(a_mode) - && !SCHEME_INTP(a_mode) - && !SCHEME_BIGNUMP(a_mode)) - scheme_wrong_syntax(NULL, i, form, "bad `%s-meta' level specification", - (SAME_OBJ(for_meta_symbol, aav) ? "for" : "just")); - if (SAME_OBJ(for_meta_symbol, aav)) { - if (SCHEME_FALSEP(a_mode)) - mode = a_mode; - else - mode = scheme_bin_plus(a_mode, scheme_make_integer(0)); - } else - just_mode = a_mode; - } else { - if (SAME_OBJ(for_syntax_symbol, aav)) - mode = scheme_make_integer(1); - else if (SAME_OBJ(for_template_symbol, aav)) - mode = scheme_make_integer(-1); - else - mode = scheme_false; - } - ll = scheme_append(aa, ll); - - if (!SAME_OBJ(just_meta_symbol, aav)) { - mode_cnt = scheme_list_length(aa); - if (just_mode_cnt) - just_mode_cnt += (mode_cnt - 1); - } else { - just_mode_cnt = scheme_list_length(aa); - if (mode_cnt) - mode_cnt += (just_mode_cnt - 1); - } - - skip_one = 1; - } else if (aa && SAME_OBJ(prefix_symbol, SCHEME_STX_VAL(aa))) { - /* prefix */ - int len; - - if (all_simple) - *all_simple = 0; - - len = scheme_stx_proper_list_length(i); - if (len != 3) { - GC_CAN_IGNORE const char *reason; - - if (len < 0) - reason = IMPROPER_LIST_FORM; - else if (len < 2) - reason = "prefix missing"; - else if (len < 3) - reason = "module name missing"; - else - reason = "extra data after module name"; - scheme_wrong_syntax(NULL, i, form, reason); - return; - } - - i = SCHEME_STX_CDR(i); - prefix = SCHEME_STX_CAR(i); - i = SCHEME_STX_CDR(i); - idxstx = SCHEME_STX_CAR(i); - exns = NULL; - - if (!SCHEME_SYMBOLP(SCHEME_STX_VAL(prefix))) { - scheme_wrong_syntax(NULL, prefix, form, "bad prefix (not an identifier)"); - return; - } - - prefix = SCHEME_STX_VAL(prefix); - - } else if (aa && (SAME_OBJ(all_except_symbol, SCHEME_STX_VAL(aa)) - || SAME_OBJ(prefix_all_except_symbol, SCHEME_STX_VAL(aa)))) { - /* all-except and prefix-all-except */ - Scheme_Object *l; - int len; - int has_prefix; - - if (all_simple) - *all_simple = 0; - - has_prefix = SAME_OBJ(prefix_all_except_symbol, SCHEME_STX_VAL(aa)); - - len = scheme_stx_proper_list_length(i); - if (len < 0) - scheme_wrong_syntax(NULL, i, form, IMPROPER_LIST_FORM); - else if (has_prefix && (len < 2)) - scheme_wrong_syntax(NULL, i, form, "prefix missing"); - else if (len < (has_prefix ? 3 : 2)) - scheme_wrong_syntax(NULL, i, form, "module name missing"); - - idxstx = SCHEME_STX_CDR(i); - if (has_prefix) { - prefix = SCHEME_STX_CAR(idxstx); - idxstx = SCHEME_STX_CDR(idxstx); - - if (!SCHEME_SYMBOLP(SCHEME_STX_VAL(prefix))) { - scheme_wrong_syntax(NULL, prefix, form, "prefix is not an identifier"); - return; - } - prefix = SCHEME_STX_VAL(prefix); - } else - prefix = NULL; - exns = SCHEME_STX_CDR(idxstx); - idxstx = SCHEME_STX_CAR(idxstx); - - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l))) { - l = SCHEME_STX_CAR(l); - scheme_wrong_syntax(NULL, l, form, - "excluded name is not an identifier"); - } - } - if (SCHEME_STX_NULLP(exns)) - exns = NULL; - } else if (aa && SAME_OBJ(only_symbol, SCHEME_STX_VAL(aa))) { - /* only */ - int len; - Scheme_Object *rest, *nm; - - if (all_simple) - *all_simple = 0; - - len = scheme_stx_proper_list_length(i); - if (len < 2) { - GC_CAN_IGNORE const char *reason; - - if (len < 0) - reason = IMPROPER_LIST_FORM; - else - reason = "module name missing"; - scheme_wrong_syntax(NULL, i, form, reason); - return; - } - - onlys = scheme_make_hash_table(SCHEME_hash_ptr); - - rest = SCHEME_STX_CDR(i); - idxstx = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - while (SCHEME_STX_PAIRP(rest)) { - nm = SCHEME_STX_CAR(rest); - if (!SCHEME_STX_SYMBOLP(nm)) { - scheme_wrong_syntax(NULL, nm, form, "name for `only' is not an identifier"); - } - scheme_hash_set(onlys, SCHEME_STX_VAL(nm), nm); - rest = SCHEME_STX_CDR(rest); - } - - scope_src = NULL; - exns = NULL; - prefix = NULL; - } else if (aa && SAME_OBJ(rename_symbol, SCHEME_STX_VAL(aa))) { - /* rename */ - int len; - Scheme_Object *rest; - - if (all_simple) - *all_simple = 0; - - len = scheme_stx_proper_list_length(i); - if (len != 4) { - GC_CAN_IGNORE const char *reason; - - if (len < 0) - reason = IMPROPER_LIST_FORM; - else if (len < 2) - reason = "module name missing"; - else if (len < 3) - reason = "internal name missing"; - else if (len < 4) - reason = "external name missing"; - else - reason = "extra data after external name"; - scheme_wrong_syntax(NULL, i, form, reason); - return; - } - - rest = SCHEME_STX_CDR(i); - idxstx = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - iname = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - ename = SCHEME_STX_CAR(rest); - - if (!SCHEME_STX_SYMBOLP(iname)) - scheme_wrong_syntax(NULL, i, form, "internal name is not an identifier"); - if (!SCHEME_STX_SYMBOLP(ename)) - scheme_wrong_syntax(NULL, i, form, "external name is not an identifier"); - - scope_src = iname; - - iname = SCHEME_STX_VAL(iname); - - prefix = NULL; - exns = NULL; - } else { - idxstx = i; - exns = NULL; - prefix = NULL; - } - - if (!skip_one) { - int start = 1; - Scheme_Env *rename_env; - - if (SCHEME_FALSEP(mode)) { - start = 0; - scheme_prepare_label_env(main_env); - env = main_env->label_env; - rename_env = main_env; - } else if (scheme_is_positive(mode)) { - Scheme_Object *n = mode; - env = main_env; - do { - scheme_prepare_exp_env(env); - env = env->exp_env; - n = scheme_bin_minus(n, scheme_make_integer(1)); - } while (scheme_is_positive(n)); - rename_env = env; - } else if (scheme_is_negative(mode)) { - Scheme_Object *n = mode; - env = main_env; - do { - scheme_prepare_template_env(env); - env = env->template_env; - n = scheme_bin_plus(n, scheme_make_integer(1)); - } while (scheme_is_negative(n)); - rename_env = env; - } else { - env = main_env; - rename_env = env; - } - - if (is_mpi) { - idx = form; - } else { - name = scheme_syntax_to_datum(idxstx, 0, NULL); - - if (submodule_names && SCHEME_PAIRP(name)) { - /* check for 'x where x is a submodule name */ - name = convert_submodule_path(name, check_in_hash, - (Scheme_Object *)submodule_names); - } - - if (modidx_cache) - idx = scheme_hash_get(modidx_cache, name); - else - idx = NULL; - if (!idx) { - if (SCHEME_PAIRP(name) - && SAME_OBJ(SCHEME_CAR(name), submod_symbol) - && SCHEME_PAIRP(SCHEME_CDR(name)) - && SCHEME_PATHP(SCHEME_CADR(name))) { - idx = scheme_make_modidx(SCHEME_CADR(name), base_modidx, scheme_false); - idx = scheme_make_modidx(scheme_make_pair(submod_symbol, - scheme_make_pair(scheme_make_utf8_string("."), - SCHEME_CDDR(name))), - idx, - scheme_false); - } else - idx = scheme_make_modidx(name, base_modidx, scheme_false); - if (modidx_cache) - scheme_hash_set(modidx_cache, name, idx); - } - } - - name = _module_resolve(idx, idxstx, NULL, 1); - - m = module_load(name, env, NULL); - - start_module(m, env, 0, idx, - start ? eval_exp : 0, start ? eval_run : 0, - main_env->phase, scheme_null, 0); - - if (non_phaseless && !m->phaseless) - *non_phaseless |= NON_PHASELESS_IMPORT; - - x_just_mode = just_mode; - x_mode = mode; - if (at_phase) { - if (x_mode && SCHEME_TRUEP(x_mode)) { - x_mode = scheme_bin_plus(x_mode, scheme_make_integer(at_phase)); - } - /* x_just_mode refers to the mode at export, which doesn't shift - by phase context at import */ - } - - /* Add name to require list, if it's not there: */ - if (main_env->module) { - Scheme_Object *reqs; - if (SAME_OBJ(x_mode, scheme_make_integer(0))) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->requires); - main_env->module->requires = reqs; - } else if (SAME_OBJ(x_mode, scheme_make_integer(1))) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->et_requires); - main_env->module->et_requires = reqs; - } else if (SAME_OBJ(x_mode, scheme_make_integer(-1))) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->tt_requires); - main_env->module->tt_requires = reqs; - } else if (SAME_OBJ(x_mode, scheme_false)) { - reqs = add_req(scheme_make_pair(idx, scheme_null), main_env->module->dt_requires); - main_env->module->dt_requires = reqs; - } else { - Scheme_Hash_Table *oht; - oht = main_env->module->other_requires; - if (!oht) { - oht = scheme_make_hash_table_eqv(); - main_env->module->other_requires = oht; - } - reqs = scheme_hash_get(oht, x_mode); - if (!reqs) - reqs = scheme_null; - reqs = add_req(scheme_make_pair(idx, scheme_null), reqs); - scheme_hash_set(oht, x_mode, reqs); - } - } - - if (SAME_TYPE(SCHEME_TYPE(idx), scheme_resolved_module_path_type)) - idx = scheme_resolved_module_path_to_modidx(idx); - - add_single_require(m->me, x_just_mode, x_mode, idx, rename_env, - rn_set, (for_m ? for_m->rn_stx : NULL), - exns, onlys, prefix, iname, ename, - scope_src, - copy_vars, - all_simple, - ck, data, - form, err_src, i, - collapse_table); - - if (onlys && onlys->count) { - /* Something required in `only' wasn't provided by the module */ - int k; - for (k = 0; k < onlys->size; k++) { - if (onlys->vals[k]) - scheme_wrong_syntax(NULL, onlys->vals[k], form, "no such provided variable"); - } - } - } - - if (mode_cnt) { - --mode_cnt; - if (!mode_cnt) - mode = scheme_make_integer(0); - } - if (just_mode_cnt) { - --just_mode_cnt; - if (!just_mode_cnt) - just_mode = NULL; - } - } -} - -static void check_dup_require(Scheme_Object *id, Scheme_Object *self_modidx, - Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, - Scheme_Object *modidx, Scheme_Object *srcname, int exet, - int isval, void *ht, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *scope_src, - Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) -{ - Scheme_Object *binding; - - binding = scheme_stx_lookup_exact(id, to_phase); - if (SCHEME_FALSEP(binding)) { - /* not bound, so import is ok */ - } else if (SCHEME_VECTORP(binding) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], srcname) - && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], scheme_make_integer(exet)) - && same_resolved_modidx(SCHEME_VEC_ELS(binding)[0], modidx)) { - /* import is redunant, but ok */ - } else if (SCHEME_VECTORP(binding) - && SCHEME_FALSEP(SCHEME_VEC_ELS(binding)[0])) { - /* shadowing a top-level definition is ok */ - } else { - scheme_wrong_syntax(NULL, id, form, "duplicate import identifier"); - } -} - -static Scheme_Object *check_require_form(Scheme_Env *env, Scheme_Object *form) -{ - Scheme_Hash_Table *ht; - Scheme_Object *rest, *modidx; - Scheme_Env *tmp_env; - - if (env->module) - modidx = env->module->self_modidx; - else - modidx = scheme_false; - - /* Don't check for dups if we import from less that two sources, - since dup checking for a single source happens at that source: */ - rest = SCHEME_STX_CDR(form); - if (SCHEME_STX_NULLP(rest)) { - rest = NULL; - } else if (SCHEME_STX_PAIRP(rest)) { - rest = SCHEME_STX_CDR(rest); - if (SCHEME_STX_NULLP(rest)) { - rest = NULL; - } - } - - scheme_prepare_exp_env(env); - scheme_prepare_template_env(env); - - if (rest) { - /* Parse into dummy environment, first, then parse - into top-level if that works without error. We need those two - steps to avoid creating some bindings before discovering a - collision, and also for checking for duplicates in the spec as - opposed to duplicates with existing imports. */ - ht = scheme_make_hash_table_equal(); - - tmp_env = scheme_make_env_like(env); - scheme_prepare_exp_env(tmp_env); - scheme_prepare_template_env(tmp_env); - - /* add a scope to form so that it doesn't collide with anything: */ - form = scheme_stx_add_scope(form, scheme_new_scope(SCHEME_STX_MACRO_SCOPE), scheme_env_phase(env)); - - parse_requires(form, tmp_env->phase, modidx, tmp_env, NULL, - tmp_env->stx_context, - check_dup_require, ht, - NULL, - 0, - 1, 0, - NULL, NULL, NULL, - NULL); - } - - return modidx; -} - -static Scheme_Object * -do_require_execute(Scheme_Env *env, Scheme_Object *form, int to_context) -{ - Scheme_Object *modidx; - - if (to_context) { - /* Use the current top-level context: */ - form = scheme_stx_from_generic_to_module_context(form, env->stx_context); - } - - /* Check for collisions again, in case there's a difference between - compile and run times: */ - modidx = check_require_form(env, form); - - parse_requires(form, env->phase, modidx, env, NULL, - env->stx_context, - NULL, NULL, - NULL, - 0, - -1, 1, - NULL, NULL, NULL, - NULL); - - return scheme_void; -} - -Scheme_Object * -scheme_top_level_require_execute(Scheme_Object *data) -{ - do_require_execute(scheme_environment_from_dummy(SCHEME_PTR1_VAL(data)), - SCHEME_PTR2_VAL(data), - 1); - return scheme_void; -} - -Scheme_Object * -scheme_top_level_require_jit(Scheme_Object *data) -{ - return data; -} - -static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) -{ - Scheme_Object *dummy, *data; - - if (!scheme_is_toplevel(env)) - scheme_wrong_syntax(NULL, NULL, form, "not at top-level or in module body"); - - /* If we get here, it must be a top-level require. */ - - (void)check_require_form(env->genv, form); - - if (rec && rec[drec].comp) { - /* Remove all context specific to the compile-time environment: */ - form = scheme_stx_from_module_context_to_generic(form, env->genv->stx_context); - - /* Dummy lets us access a top-level environment: */ - dummy = scheme_make_environment_dummy(env); - - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - - data = scheme_alloc_object(); - data->type = scheme_require_form_type; - SCHEME_PTR1_VAL(data) = dummy; - SCHEME_PTR2_VAL(data) = form; - - return data; - } else - return form; -} - -static Scheme_Object * -require_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_require(form, env, rec, drec); -} - -static Scheme_Object * -require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(env->observer); - return do_require(form, env, erec, drec); -} - -Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, - intptr_t phase, - Scheme_Comp_Env *cenv, - Scheme_Object *scope) -{ - Scheme_Object *form; - - form = make_require_form(module_path, phase, scope, cenv->genv->phase); - - form = scheme_revert_use_site_scopes(form, cenv); - - do_require_execute(cenv->genv, form, 0); - - return form; -} - -/**********************************************************************/ -/* dummy forms */ -/**********************************************************************/ - -static Scheme_Object * -provide_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} - -static Scheme_Object * -provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(env->observer); - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} - -static Scheme_Object * -declare_compile(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} - -static Scheme_Object * -declare_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(env->observer); - scheme_wrong_syntax(NULL, NULL, form, "not in module body"); - return NULL; -} diff --git a/racket/src/racket/src/mzclpf_post.inc b/racket/src/racket/src/mzclpf_post.inc index fd12642e10..829b799590 100644 --- a/racket/src/racket/src/mzclpf_post.inc +++ b/racket/src/racket/src/mzclpf_post.inc @@ -17,7 +17,6 @@ if (pf) { int *use_bits; uintptr_t map; - int mark_stxes; /* pf might have been marked via fields: */ pf = (Scheme_Prefix *)GC_resolve2(pf, gc); @@ -39,7 +38,6 @@ pf->backpointer = (Scheme_Object *)c; #endif } - mark_stxes = 0; /* Add this closure to the chain to be repaired when the prefix is marked and potentially moved; if we're here @@ -60,12 +58,7 @@ for (i = 0; i < 31; i++) { if (map & ((unsigned int)1 << i)) { if (!(use_bits[0] & ((unsigned int)1 << i))) { - if ((i < pf->num_toplevels) || !pf->num_stxes) - gcMARK2(pf->a[i], gc); /* top level */ - else if (i == pf->num_toplevels) - mark_stxes = 1; /* any syntax object */ - else - gcMARK2(pf->a[i + pf->num_stxes], gc); /* lifted */ + gcMARK2(pf->a[i], gc); /* top level */ } } } @@ -81,12 +74,7 @@ if (map & ((unsigned int)1 << j)) { if (!(use_bits[i] & ((unsigned int)1 << j))) { pos = (i * 32) + j; - if ((pos < pf->num_toplevels) || !pf->num_stxes) - gcMARK2(pf->a[pos], gc); /* top level */ - else if (pos == pf->num_toplevels) - mark_stxes = 1; /* any syntax object */ - else - gcMARK2(pf->a[pos + pf->num_stxes], gc); /* lifted */ + gcMARK2(pf->a[pos], gc); /* top level */ } } } @@ -94,11 +82,5 @@ } } } - if (mark_stxes) { - /* Mark all syntax-object references */ - for (i = pf->num_stxes+1; i--;) { - gcMARK2(pf->a[i+pf->num_toplevels], gc); - } - } } } diff --git a/racket/src/racket/src/mzmark_compenv.inc b/racket/src/racket/src/mzmark_compenv.inc index 0519d6320a..309278eeca 100644 --- a/racket/src/racket/src/mzmark_compenv.inc +++ b/racket/src/racket/src/mzmark_compenv.inc @@ -12,32 +12,9 @@ static int mark_comp_env_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED Scheme_Comp_Env *e = (Scheme_Comp_Env *)p; - gcMARK2(e->genv, gc); - gcMARK2(e->insp, gc); - gcMARK2(e->prefix, gc); - gcMARK2(e->next, gc); - gcMARK2(e->use_scopes_next, gc); - gcMARK2(e->intdef_next, gc); - gcMARK2(e->scopes, gc); - gcMARK2(e->value_name, gc); - gcMARK2(e->observer, gc); - gcMARK2(e->binders, gc); - gcMARK2(e->bindings, gc); - gcMARK2(e->vals, gc); - gcMARK2(e->shadower_deltas, gc); gcMARK2(e->vars, gc); - gcMARK2(e->dup_check, gc); - gcMARK2(e->intdef_name, gc); - gcMARK2(e->in_modidx, gc); - gcMARK2(e->skip_table, gc); - - gcMARK2(e->use, gc); - gcMARK2(e->lifts, gc); - gcMARK2(e->bindings, gc); - - gcMARK2(e->binding_namess, gc); - - gcMARK2(e->expand_result_adjust_arg, gc); + gcMARK2(e->value_name, gc); + gcMARK2(e->linklet, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -52,32 +29,9 @@ static int mark_comp_env_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Scheme_Comp_Env *e = (Scheme_Comp_Env *)p; - gcFIXUP2(e->genv, gc); - gcFIXUP2(e->insp, gc); - gcFIXUP2(e->prefix, gc); - gcFIXUP2(e->next, gc); - gcFIXUP2(e->use_scopes_next, gc); - gcFIXUP2(e->intdef_next, gc); - gcFIXUP2(e->scopes, gc); - gcFIXUP2(e->value_name, gc); - gcFIXUP2(e->observer, gc); - gcFIXUP2(e->binders, gc); - gcFIXUP2(e->bindings, gc); - gcFIXUP2(e->vals, gc); - gcFIXUP2(e->shadower_deltas, gc); gcFIXUP2(e->vars, gc); - gcFIXUP2(e->dup_check, gc); - gcFIXUP2(e->intdef_name, gc); - gcFIXUP2(e->in_modidx, gc); - gcFIXUP2(e->skip_table, gc); - - gcFIXUP2(e->use, gc); - gcFIXUP2(e->lifts, gc); - gcFIXUP2(e->bindings, gc); - - gcFIXUP2(e->binding_namess, gc); - - gcFIXUP2(e->expand_result_adjust_arg, gc); + gcFIXUP2(e->value_name, gc); + gcFIXUP2(e->linklet, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; diff --git a/racket/src/racket/src/mzmark_linklet.inc b/racket/src/racket/src/mzmark_linklet.inc new file mode 100644 index 0000000000..c8606068dc --- /dev/null +++ b/racket/src/racket/src/mzmark_linklet.inc @@ -0,0 +1,2 @@ +/* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */ + diff --git a/racket/src/racket/src/mzmark_optimize.inc b/racket/src/racket/src/mzmark_optimize.inc index 1567137434..7702d79fe0 100644 --- a/racket/src/racket/src/mzmark_optimize.inc +++ b/racket/src/racket/src/mzmark_optimize.inc @@ -13,10 +13,9 @@ static int mark_optimize_info_MARK(void *p, struct NewGC *gc) { Optimize_Info *i = (Optimize_Info *)p; gcMARK2(i->next, gc); - gcMARK2(i->consts, gc); - gcMARK2(i->cp, gc); - gcMARK2(i->env, gc); - gcMARK2(i->insp, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->cross, gc); + gcMARK2(i->imports_used, gc); gcMARK2(i->top_level_consts, gc); gcMARK2(i->transitive_use_var, gc); gcMARK2(i->context, gc); @@ -38,10 +37,9 @@ static int mark_optimize_info_FIXUP(void *p, struct NewGC *gc) { Optimize_Info *i = (Optimize_Info *)p; gcFIXUP2(i->next, gc); - gcFIXUP2(i->consts, gc); - gcFIXUP2(i->cp, gc); - gcFIXUP2(i->env, gc); - gcFIXUP2(i->insp, gc); + gcFIXUP2(i->linklet, gc); + gcFIXUP2(i->cross, gc); + gcFIXUP2(i->imports_used, gc); gcFIXUP2(i->top_level_consts, gc); gcFIXUP2(i->transitive_use_var, gc); gcFIXUP2(i->context, gc); diff --git a/racket/src/racket/src/mzmark_portfun.inc b/racket/src/racket/src/mzmark_portfun.inc index df14dafc34..e3ff914ab5 100644 --- a/racket/src/racket/src/mzmark_portfun.inc +++ b/racket/src/racket/src/mzmark_portfun.inc @@ -1,55 +1,5 @@ /* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */ -static int mark_load_handler_data_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -#else - return 0; -#endif -} - -static int mark_load_handler_data_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - LoadHandlerData *d = (LoadHandlerData *)p; - - gcMARK2(d->config, gc); - gcMARK2(d->port, gc); - gcMARK2(d->p, gc); - gcMARK2(d->stxsrc, gc); - gcMARK2(d->expected_module, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -# endif -#endif -} - -static int mark_load_handler_data_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - LoadHandlerData *d = (LoadHandlerData *)p; - - gcFIXUP2(d->config, gc); - gcFIXUP2(d->port, gc); - gcFIXUP2(d->p, gc); - gcFIXUP2(d->stxsrc, gc); - gcFIXUP2(d->expected_module, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -# endif -#endif -} - -#define mark_load_handler_data_IS_ATOMIC 0 -#define mark_load_handler_data_IS_CONST_SIZE 1 - - static int mark_indexed_string_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Indexed_String)); diff --git a/racket/src/racket/src/mzmark_print.inc b/racket/src/racket/src/mzmark_print.inc index f96d4d27bd..9d16386bc7 100644 --- a/racket/src/racket/src/mzmark_print.inc +++ b/racket/src/racket/src/mzmark_print.inc @@ -60,17 +60,10 @@ static int mark_marshal_tables_MARK(void *p, struct NewGC *gc) { gcMARK2(mt->symtab, gc); gcMARK2(mt->st_refs, gc); gcMARK2(mt->st_ref_stack, gc); - gcMARK2(mt->reachable_scopes, gc); - gcMARK2(mt->reachable_scope_stack, gc); - gcMARK2(mt->pending_reachable_ids, gc); - gcMARK2(mt->conditionally_reachable_scopes, gc); gcMARK2(mt->intern_map, gc); - gcMARK2(mt->identity_map, gc); - gcMARK2(mt->top_map, gc); gcMARK2(mt->key_map, gc); gcMARK2(mt->delay_map, gc); gcMARK2(mt->cdata_map, gc); - gcMARK2(mt->rn_saved, gc); gcMARK2(mt->shared_offsets, gc); gcMARK2(mt->path_cache, gc); gcMARK2(mt->sorted_keys, gc); @@ -89,17 +82,10 @@ static int mark_marshal_tables_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(mt->symtab, gc); gcFIXUP2(mt->st_refs, gc); gcFIXUP2(mt->st_ref_stack, gc); - gcFIXUP2(mt->reachable_scopes, gc); - gcFIXUP2(mt->reachable_scope_stack, gc); - gcFIXUP2(mt->pending_reachable_ids, gc); - gcFIXUP2(mt->conditionally_reachable_scopes, gc); gcFIXUP2(mt->intern_map, gc); - gcFIXUP2(mt->identity_map, gc); - gcFIXUP2(mt->top_map, gc); gcFIXUP2(mt->key_map, gc); gcFIXUP2(mt->delay_map, gc); gcFIXUP2(mt->cdata_map, gc); - gcFIXUP2(mt->rn_saved, gc); gcFIXUP2(mt->shared_offsets, gc); gcFIXUP2(mt->path_cache, gc); gcFIXUP2(mt->sorted_keys, gc); diff --git a/racket/src/racket/src/mzmark_read.inc b/racket/src/racket/src/mzmark_read.inc index 8539f2ccf0..7346594fad 100644 --- a/racket/src/racket/src/mzmark_read.inc +++ b/racket/src/racket/src/mzmark_read.inc @@ -52,8 +52,6 @@ static int mark_cport_MARK(void *p, struct NewGC *gc) { gcMARK2(cp->symtab, gc); gcMARK2(cp->symtab_entries, gc); gcMARK2(cp->relto, gc); - gcMARK2(cp->magic_sym, gc); - gcMARK2(cp->magic_val, gc); gcMARK2(cp->shared_offsets, gc); gcMARK2(cp->delay_info, gc); gcMARK2(cp->symtab_refs, gc); @@ -76,8 +74,6 @@ static int mark_cport_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(cp->symtab, gc); gcFIXUP2(cp->symtab_entries, gc); gcFIXUP2(cp->relto, gc); - gcFIXUP2(cp->magic_sym, gc); - gcFIXUP2(cp->magic_val, gc); gcFIXUP2(cp->shared_offsets, gc); gcFIXUP2(cp->delay_info, gc); gcFIXUP2(cp->symtab_refs, gc); @@ -94,50 +90,6 @@ static int mark_cport_FIXUP(void *p, struct NewGC *gc) { #define mark_cport_IS_CONST_SIZE 1 -static int mark_readtable_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Readtable)); -#else - return 0; -#endif -} - -static int mark_readtable_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Readtable *t = (Readtable *)p; - gcMARK2(t->mapping, gc); - gcMARK2(t->fast_mapping, gc); - gcMARK2(t->symbol_parser, gc); - gcMARK2(t->names, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Readtable)); -# endif -#endif -} - -static int mark_readtable_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Readtable *t = (Readtable *)p; - gcFIXUP2(t->mapping, gc); - gcFIXUP2(t->fast_mapping, gc); - gcFIXUP2(t->symbol_parser, gc); - gcFIXUP2(t->names, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Readtable)); -# endif -#endif -} - -#define mark_readtable_IS_ATOMIC 0 -#define mark_readtable_IS_CONST_SIZE 1 - - static int mark_read_params_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(ReadParams)); @@ -149,11 +101,9 @@ static int mark_read_params_SIZE(void *p, struct NewGC *gc) { static int mark_read_params_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED ReadParams *rp = (ReadParams *)p; - gcMARK2(rp->table, gc); - gcMARK2(rp->magic_sym, gc); - gcMARK2(rp->magic_val, gc); gcMARK2(rp->delay_load_info, gc); gcMARK2(rp->read_relative_path, gc); + gcMARK2(rp->graph_ht, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -166,11 +116,9 @@ static int mark_read_params_MARK(void *p, struct NewGC *gc) { static int mark_read_params_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED ReadParams *rp = (ReadParams *)p; - gcFIXUP2(rp->table, gc); - gcFIXUP2(rp->magic_sym, gc); - gcFIXUP2(rp->magic_val, gc); gcFIXUP2(rp->delay_load_info, gc); gcFIXUP2(rp->read_relative_path, gc); + gcFIXUP2(rp->graph_ht, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -249,10 +197,6 @@ static int mark_unmarshal_tables_SIZE(void *p, struct NewGC *gc) { static int mark_unmarshal_tables_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p; - gcMARK2(ut->rns, gc); - gcMARK2(ut->current_rns, gc); - gcMARK2(ut->multi_scope_pairs, gc); - gcMARK2(ut->current_multi_scope_pairs, gc); gcMARK2(ut->rp, gc); gcMARK2(ut->decoded, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS @@ -267,10 +211,6 @@ static int mark_unmarshal_tables_MARK(void *p, struct NewGC *gc) { static int mark_unmarshal_tables_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p; - gcFIXUP2(ut->rns, gc); - gcFIXUP2(ut->current_rns, gc); - gcFIXUP2(ut->multi_scope_pairs, gc); - gcFIXUP2(ut->current_multi_scope_pairs, gc); gcFIXUP2(ut->rp, gc); gcFIXUP2(ut->decoded, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS diff --git a/racket/src/racket/src/mzmark_resolve.inc b/racket/src/racket/src/mzmark_resolve.inc index 369c8e995e..28ece3e457 100644 --- a/racket/src/racket/src/mzmark_resolve.inc +++ b/racket/src/racket/src/mzmark_resolve.inc @@ -12,12 +12,15 @@ static int mark_resolve_info_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED Resolve_Info *i = (Resolve_Info *)p; - gcMARK2(i->prefix, gc); - gcMARK2(i->stx_map, gc); + gcMARK2(i->linklet, gc); gcMARK2(i->tl_map, gc); gcMARK2(i->redirects, gc); gcMARK2(i->lifts, gc); + gcMARK2(i->top, gc); gcMARK2(i->next, gc); + gcMARK2(i->toplevel_starts, gc); + gcMARK2(i->toplevel_deltas, gc); + gcMARK2(i->toplevel_defns, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -32,12 +35,15 @@ static int mark_resolve_info_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Resolve_Info *i = (Resolve_Info *)p; - gcFIXUP2(i->prefix, gc); - gcFIXUP2(i->stx_map, gc); + gcFIXUP2(i->linklet, gc); gcFIXUP2(i->tl_map, gc); gcFIXUP2(i->redirects, gc); gcFIXUP2(i->lifts, gc); + gcFIXUP2(i->top, gc); gcFIXUP2(i->next, gc); + gcFIXUP2(i->toplevel_starts, gc); + gcFIXUP2(i->toplevel_deltas, gc); + gcFIXUP2(i->toplevel_defns, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -65,16 +71,10 @@ static int mark_unresolve_info_MARK(void *p, struct NewGC *gc) { Unresolve_Info *i = (Unresolve_Info *)p; gcMARK2(i->vars, gc); - gcMARK2(i->prefix, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->linklet_key, gc); + gcMARK2(i->opt_info, gc); gcMARK2(i->closures, gc); - gcMARK2(i->module, gc); - gcMARK2(i->comp_prefix, gc); - gcMARK2(i->new_toplevels, gc); - gcMARK2(i->from_modidx, gc); - gcMARK2(i->to_modidx, gc); - gcMARK2(i->opt_env, gc); - gcMARK2(i->opt_insp, gc); - gcMARK2(i->inline_variants, gc); gcMARK2(i->toplevels, gc); gcMARK2(i->definitions, gc); gcMARK2(i->ref_lifts, gc); @@ -93,16 +93,10 @@ static int mark_unresolve_info_FIXUP(void *p, struct NewGC *gc) { Unresolve_Info *i = (Unresolve_Info *)p; gcFIXUP2(i->vars, gc); - gcFIXUP2(i->prefix, gc); + gcFIXUP2(i->linklet, gc); + gcFIXUP2(i->linklet_key, gc); + gcFIXUP2(i->opt_info, gc); gcFIXUP2(i->closures, gc); - gcFIXUP2(i->module, gc); - gcFIXUP2(i->comp_prefix, gc); - gcFIXUP2(i->new_toplevels, gc); - gcFIXUP2(i->from_modidx, gc); - gcFIXUP2(i->to_modidx, gc); - gcFIXUP2(i->opt_env, gc); - gcFIXUP2(i->opt_insp, gc); - gcFIXUP2(i->inline_variants, gc); gcFIXUP2(i->toplevels, gc); gcFIXUP2(i->definitions, gc); gcFIXUP2(i->ref_lifts, gc); diff --git a/racket/src/racket/src/mzmark_syntax.inc b/racket/src/racket/src/mzmark_syntax.inc index a0d593f777..702093499c 100644 --- a/racket/src/racket/src/mzmark_syntax.inc +++ b/racket/src/racket/src/mzmark_syntax.inc @@ -38,141 +38,3 @@ static int mark_srcloc_FIXUP(void *p, struct NewGC *gc) { #define mark_srcloc_IS_CONST_SIZE 1 -static int mark_scope_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -#else - return 0; -#endif -} - -static int mark_scope_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - gcMARK2(m->bindings, gc); - if (for_multi) { - gcMARK2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); - gcMARK2(((Scheme_Scope_With_Owner *)m)->phase, gc); - } -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -# endif -#endif -} - -static int mark_scope_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - gcFIXUP2(m->bindings, gc); - if (for_multi) { - gcFIXUP2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); - gcFIXUP2(((Scheme_Scope_With_Owner *)m)->phase, gc); - } -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -# endif -#endif -} - -#define mark_scope_IS_ATOMIC 0 -#define mark_scope_IS_CONST_SIZE 0 - - -static int mark_scope_table_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -#else - return 0; -#endif -} - -static int mark_scope_table_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; - gcMARK2(m->simple_scopes, gc); - gcMARK2(m->multi_scopes, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -# endif -#endif -} - -static int mark_scope_table_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; - gcFIXUP2(m->simple_scopes, gc); - gcFIXUP2(m->multi_scopes, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -# endif -#endif -} - -#define mark_scope_table_IS_ATOMIC 0 -#define mark_scope_table_IS_CONST_SIZE 1 - - -static int mark_propagate_table_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -#else - return 0; -#endif -} - -static int mark_propagate_table_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; - mark_scope_table_MARK(&m->st, gc); - gcMARK2(m->prev, gc); - gcMARK2(m->phase_shift, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -# endif -#endif -} - -static int mark_propagate_table_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; - mark_scope_table_FIXUP(&m->st, gc); - gcFIXUP2(m->prev, gc); - gcFIXUP2(m->phase_shift, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -# endif -#endif -} - -#define mark_propagate_table_IS_ATOMIC 0 -#define mark_propagate_table_IS_CONST_SIZE 1 - - diff --git a/racket/src/racket/src/mzmark_type.inc b/racket/src/racket/src/mzmark_type.inc index 083ba4e512..588f653d2a 100644 --- a/racket/src/racket/src/mzmark_type.inc +++ b/racket/src/racket/src/mzmark_type.inc @@ -46,54 +46,6 @@ static int variable_obj_FIXUP(void *p, struct NewGC *gc) { #define variable_obj_IS_CONST_SIZE 1 -static int module_var_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -#else - return 0; -#endif -} - -static int module_var_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Module_Variable *mv = (Module_Variable *)p; - - gcMARK2(mv->modidx, gc); - gcMARK2(mv->sym, gc); - gcMARK2(mv->insp, gc); - gcMARK2(mv->shape, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -# endif -#endif -} - -static int module_var_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Module_Variable *mv = (Module_Variable *)p; - - gcFIXUP2(mv->modidx, gc); - gcFIXUP2(mv->sym, gc); - gcFIXUP2(mv->insp, gc); - gcFIXUP2(mv->shape, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -# endif -#endif -} - -#define module_var_IS_ATOMIC 0 -#define module_var_IS_CONST_SIZE 1 - - static int bucket_obj_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Bucket)); @@ -206,40 +158,6 @@ static int toplevel_obj_FIXUP(void *p, struct NewGC *gc) { #define toplevel_obj_IS_CONST_SIZE 1 -static int quotesyntax_obj_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); -#else - return 0; -#endif -} - -static int quotesyntax_obj_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); -# endif -#endif -} - -static int quotesyntax_obj_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); -# endif -#endif -} - -#define quotesyntax_obj_IS_ATOMIC 1 -#define quotesyntax_obj_IS_CONST_SIZE 1 - - static int cpointer_obj_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS (SCHEME_CPTR_HAS_OFFSET(p) @@ -961,6 +879,9 @@ static int ir_local_MARK(void *p, struct NewGC *gc) { gcMARK2(var->name, gc); switch (var->mode) { + case SCHEME_VAR_MODE_COMPILE: + gcMARK2(var->compile.use_box, gc); + break; case SCHEME_VAR_MODE_LETREC_CHECK: gcMARK2(var->letrec_check.frame, gc); break; @@ -990,6 +911,9 @@ static int ir_local_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(var->name, gc); switch (var->mode) { + case SCHEME_VAR_MODE_COMPILE: + gcFIXUP2(var->compile.use_box, gc); + break; case SCHEME_VAR_MODE_LETREC_CHECK: gcFIXUP2(var->letrec_check.frame, gc); break; @@ -1017,6 +941,40 @@ static int ir_local_FIXUP(void *p, struct NewGC *gc) { #define ir_local_IS_CONST_SIZE 1 +static int ir_toplevel_SIZE(void *p, struct NewGC *gc) { +#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +#else + return 0; +#endif +} + +static int ir_toplevel_MARK(void *p, struct NewGC *gc) { +#ifndef GC_NO_MARK_PROCEDURE_NEEDED +# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS + return 0; +# else + return + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +# endif +#endif +} + +static int ir_toplevel_FIXUP(void *p, struct NewGC *gc) { +#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED +# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS + return 0; +# else + return + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +# endif +#endif +} + +#define ir_toplevel_IS_ATOMIC 1 +#define ir_toplevel_IS_CONST_SIZE 1 + + static int ir_let_value_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_IR_Let_Value)); @@ -2590,41 +2548,6 @@ static int output_port_FIXUP(void *p, struct NewGC *gc) { #define output_port_IS_CONST_SIZE 1 - -static int syntax_compiler_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -#else - return 0; -#endif -} - -static int syntax_compiler_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -# endif -#endif -} - -static int syntax_compiler_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -# endif -#endif -} - -#define syntax_compiler_IS_ATOMIC 1 -#define syntax_compiler_IS_CONST_SIZE 1 - - static int thread_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Thread)); @@ -2688,14 +2611,6 @@ static int thread_val_MARK(void *p, struct NewGC *gc) { gcMARK2(pr->return_marks_to, gc); gcMARK2(pr->returned_marks, gc); - gcMARK2(pr->current_local_env, gc); - gcMARK2(pr->current_local_scope, gc); - gcMARK2(pr->current_local_use_scope, gc); - gcMARK2(pr->current_local_name, gc); - gcMARK2(pr->current_local_modidx, gc); - gcMARK2(pr->current_local_menv, gc); - gcMARK2(pr->current_local_bindings, gc); - gcMARK2(pr->current_mt, gc); gcMARK2(pr->constant_folding, gc); @@ -2820,14 +2735,6 @@ static int thread_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(pr->return_marks_to, gc); gcFIXUP2(pr->returned_marks, gc); - gcFIXUP2(pr->current_local_env, gc); - gcFIXUP2(pr->current_local_scope, gc); - gcFIXUP2(pr->current_local_use_scope, gc); - gcFIXUP2(pr->current_local_name, gc); - gcFIXUP2(pr->current_local_modidx, gc); - gcFIXUP2(pr->current_local_menv, gc); - gcFIXUP2(pr->current_local_bindings, gc); - gcFIXUP2(pr->current_mt, gc); gcFIXUP2(pr->constant_folding, gc); @@ -3284,7 +3191,7 @@ static int bucket_table_val_FIXUP(void *p, struct NewGC *gc) { #define bucket_table_val_IS_CONST_SIZE 1 -static int namespace_val_SIZE(void *p, struct NewGC *gc) { +static int env_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Env)); #else @@ -3292,50 +3199,13 @@ static int namespace_val_SIZE(void *p, struct NewGC *gc) { #endif } -static int namespace_val_MARK(void *p, struct NewGC *gc) { +static int env_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED Scheme_Env *e = (Scheme_Env *)p; - gcMARK2(e->module, gc); - gcMARK2(e->module_registry, gc); - gcMARK2(e->module_pre_registry, gc); - gcMARK2(e->guard_insp, gc); - gcMARK2(e->access_insp, gc); - - gcMARK2(e->stx_context, gc); - gcMARK2(e->tmp_bind_scope, gc); - - gcMARK2(e->syntax, gc); - gcMARK2(e->exp_env, gc); - gcMARK2(e->template_env, gc); - gcMARK2(e->label_env, gc); - gcMARK2(e->instance_env, gc); - gcMARK2(e->reader_env, gc); - - gcMARK2(e->shadowed_syntax, gc); - - gcMARK2(e->lift_key, gc); - - gcMARK2(e->link_midx, gc); - gcMARK2(e->require_names, gc); - gcMARK2(e->et_require_names, gc); - gcMARK2(e->tt_require_names, gc); - gcMARK2(e->dt_require_names, gc); - gcMARK2(e->other_require_names, gc); - gcMARK2(e->running, gc); - gcMARK2(e->did_starts, gc); - gcMARK2(e->available_next[0], gc); - gcMARK2(e->available_next[1], gc); - - gcMARK2(e->toplevel, gc); - gcMARK2(e->modchain, gc); - - gcMARK2(e->modvars, gc); - - gcMARK2(e->weak_self_link, gc); - - gcMARK2(e->binding_names, gc); - + gcMARK2(e->namespace, gc); + gcMARK2(e->instance, gc); + gcMARK2(e->protected, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -3345,50 +3215,13 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { #endif } -static int namespace_val_FIXUP(void *p, struct NewGC *gc) { +static int env_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED Scheme_Env *e = (Scheme_Env *)p; - gcFIXUP2(e->module, gc); - gcFIXUP2(e->module_registry, gc); - gcFIXUP2(e->module_pre_registry, gc); - gcFIXUP2(e->guard_insp, gc); - gcFIXUP2(e->access_insp, gc); - - gcFIXUP2(e->stx_context, gc); - gcFIXUP2(e->tmp_bind_scope, gc); - - gcFIXUP2(e->syntax, gc); - gcFIXUP2(e->exp_env, gc); - gcFIXUP2(e->template_env, gc); - gcFIXUP2(e->label_env, gc); - gcFIXUP2(e->instance_env, gc); - gcFIXUP2(e->reader_env, gc); - - gcFIXUP2(e->shadowed_syntax, gc); - - gcFIXUP2(e->lift_key, gc); - - gcFIXUP2(e->link_midx, gc); - gcFIXUP2(e->require_names, gc); - gcFIXUP2(e->et_require_names, gc); - gcFIXUP2(e->tt_require_names, gc); - gcFIXUP2(e->dt_require_names, gc); - gcFIXUP2(e->other_require_names, gc); - gcFIXUP2(e->running, gc); - gcFIXUP2(e->did_starts, gc); - gcFIXUP2(e->available_next[0], gc); - gcFIXUP2(e->available_next[1], gc); - - gcFIXUP2(e->toplevel, gc); - gcFIXUP2(e->modchain, gc); - - gcFIXUP2(e->modvars, gc); - - gcFIXUP2(e->weak_self_link, gc); - - gcFIXUP2(e->binding_names, gc); - + gcFIXUP2(e->namespace, gc); + gcFIXUP2(e->instance, gc); + gcFIXUP2(e->protected, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else @@ -3398,48 +3231,54 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { #endif } -#define namespace_val_IS_ATOMIC 0 -#define namespace_val_IS_CONST_SIZE 1 +#define env_val_IS_ATOMIC 0 +#define env_val_IS_CONST_SIZE 1 -static int module_reg_val_SIZE(void *p, struct NewGC *gc) { +static int startup_env_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); #else return 0; #endif } -static int module_reg_val_MARK(void *p, struct NewGC *gc) { +static int startup_env_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Registry *r = (Scheme_Module_Registry *)p; - gcMARK2(r->loaded, gc); - gcMARK2(r->exports, gc); + Scheme_Startup_Env *e = (Scheme_Startup_Env *)p; + + gcMARK2(e->current_table, gc); + gcMARK2(e->primitive_tables, gc); + gcMARK2(e->all_primitives_table, gc); + gcMARK2(e->primitive_ids_table, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); # endif #endif } -static int module_reg_val_FIXUP(void *p, struct NewGC *gc) { +static int startup_env_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Registry *r = (Scheme_Module_Registry *)p; - gcFIXUP2(r->loaded, gc); - gcFIXUP2(r->exports, gc); + Scheme_Startup_Env *e = (Scheme_Startup_Env *)p; + + gcFIXUP2(e->current_table, gc); + gcFIXUP2(e->primitive_tables, gc); + gcFIXUP2(e->all_primitives_table, gc); + gcFIXUP2(e->primitive_ids_table, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); # endif #endif } -#define module_reg_val_IS_ATOMIC 0 -#define module_reg_val_IS_CONST_SIZE 1 +#define startup_env_val_IS_ATOMIC 0 +#define startup_env_val_IS_CONST_SIZE 1 static int random_state_val_SIZE(void *p, struct NewGC *gc) { @@ -3476,56 +3315,12 @@ static int random_state_val_FIXUP(void *p, struct NewGC *gc) { #define random_state_val_IS_CONST_SIZE 1 -static int compilation_top_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -#else - return 0; -#endif -} - -static int compilation_top_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Compilation_Top *t = (Scheme_Compilation_Top *)p; - gcMARK2(t->code, gc); - gcMARK2(t->prefix, gc); - gcMARK2(t->binding_namess, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -# endif -#endif -} - -static int compilation_top_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Compilation_Top *t = (Scheme_Compilation_Top *)p; - gcFIXUP2(t->code, gc); - gcFIXUP2(t->prefix, gc); - gcFIXUP2(t->binding_namess, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -# endif -#endif -} - -#define compilation_top_val_IS_ATOMIC 0 -#define compilation_top_val_IS_CONST_SIZE 1 - - static int prefix_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS Scheme_Prefix *pf = (Scheme_Prefix *)p; gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); #else return 0; @@ -3544,7 +3339,7 @@ static int prefix_val_MARK(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); # endif #endif @@ -3562,7 +3357,7 @@ static int prefix_val_FIXUP(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); # endif #endif @@ -3572,98 +3367,6 @@ static int prefix_val_FIXUP(void *p, struct NewGC *gc) { #define prefix_val_IS_CONST_SIZE 0 -static int resolve_prefix_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -#else - return 0; -#endif -} - -static int resolve_prefix_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Resolve_Prefix *rp = (Resolve_Prefix *)p; - gcMARK2(rp->toplevels, gc); - gcMARK2(rp->stxes, gc); - gcMARK2(rp->delay_info_rpair, gc); - gcMARK2(rp->src_insp_desc, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -# endif -#endif -} - -static int resolve_prefix_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Resolve_Prefix *rp = (Resolve_Prefix *)p; - gcFIXUP2(rp->toplevels, gc); - gcFIXUP2(rp->stxes, gc); - gcFIXUP2(rp->delay_info_rpair, gc); - gcFIXUP2(rp->src_insp_desc, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -# endif -#endif -} - -#define resolve_prefix_val_IS_ATOMIC 0 -#define resolve_prefix_val_IS_CONST_SIZE 1 - - -static int comp_prefix_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -#else - return 0; -#endif -} - -static int comp_prefix_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Comp_Prefix *cp = (Comp_Prefix *)p; - gcMARK2(cp->toplevels, gc); - gcMARK2(cp->inline_variants, gc); - gcMARK2(cp->unbound, gc); - gcMARK2(cp->stxes, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -# endif -#endif -} - -static int comp_prefix_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Comp_Prefix *cp = (Comp_Prefix *)p; - gcFIXUP2(cp->toplevels, gc); - gcFIXUP2(cp->inline_variants, gc); - gcFIXUP2(cp->unbound, gc); - gcFIXUP2(cp->stxes, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -# endif -#endif -} - -#define comp_prefix_val_IS_ATOMIC 0 -#define comp_prefix_val_IS_CONST_SIZE 1 - - static int svector_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); @@ -3719,10 +3422,6 @@ static int stx_val_MARK(void *p, struct NewGC *gc) { Scheme_Stx *stx = (Scheme_Stx *)p; gcMARK2(stx->val, gc); gcMARK2(stx->srcloc, gc); - gcMARK2(stx->scopes, gc); - gcMARK2(stx->u.to_propagate, gc); - gcMARK2(stx->shifts, gc); - gcMARK2(stx->taints, gc); gcMARK2(stx->props, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -3738,10 +3437,6 @@ static int stx_val_FIXUP(void *p, struct NewGC *gc) { Scheme_Stx *stx = (Scheme_Stx *)p; gcFIXUP2(stx->val, gc); gcFIXUP2(stx->srcloc, gc); - gcFIXUP2(stx->scopes, gc); - gcFIXUP2(stx->u.to_propagate, gc); - gcFIXUP2(stx->shifts, gc); - gcFIXUP2(stx->taints, gc); gcFIXUP2(stx->props, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -3756,388 +3451,104 @@ static int stx_val_FIXUP(void *p, struct NewGC *gc) { #define stx_val_IS_CONST_SIZE 1 -static int stx_off_val_SIZE(void *p, struct NewGC *gc) { +static int linklet_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); #else return 0; #endif } -static int stx_off_val_MARK(void *p, struct NewGC *gc) { +static int linklet_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Stx_Offset *o = (Scheme_Stx_Offset *)p; - gcMARK2(o->src, gc); + Scheme_Linklet *l = (Scheme_Linklet *)p; + + gcMARK2(l->name, gc); + gcMARK2(l->importss, gc); + gcMARK2(l->import_shapes, gc); + gcMARK2(l->defns, gc); + gcMARK2(l->source_names, gc); + gcMARK2(l->bodies, gc); + gcMARK2(l->constants, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); # endif #endif } -static int stx_off_val_FIXUP(void *p, struct NewGC *gc) { +static int linklet_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Stx_Offset *o = (Scheme_Stx_Offset *)p; - gcFIXUP2(o->src, gc); + Scheme_Linklet *l = (Scheme_Linklet *)p; + + gcFIXUP2(l->name, gc); + gcFIXUP2(l->importss, gc); + gcFIXUP2(l->import_shapes, gc); + gcFIXUP2(l->defns, gc); + gcFIXUP2(l->source_names, gc); + gcFIXUP2(l->bodies, gc); + gcFIXUP2(l->constants, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); # endif #endif } -#define stx_off_val_IS_ATOMIC 0 -#define stx_off_val_IS_CONST_SIZE 1 +#define linklet_val_IS_ATOMIC 0 +#define linklet_val_IS_CONST_SIZE 1 -static int module_val_SIZE(void *p, struct NewGC *gc) { +static int instance_val_SIZE(void *p, struct NewGC *gc) { #ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); #else return 0; #endif } -static int module_val_MARK(void *p, struct NewGC *gc) { +static int instance_val_MARK(void *p, struct NewGC *gc) { #ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module *m = (Scheme_Module *)p; + Scheme_Instance *i = (Scheme_Instance *)p; - gcMARK2(m->phaseless, gc); - - gcMARK2(m->code_key, gc); - - gcMARK2(m->modname, gc); - gcMARK2(m->modsrc, gc); - - gcMARK2(m->et_requires, gc); - gcMARK2(m->requires, gc); - gcMARK2(m->tt_requires, gc); - gcMARK2(m->dt_requires, gc); - gcMARK2(m->other_requires, gc); - - gcMARK2(m->bodies, gc); - - gcMARK2(m->me, gc); - - gcMARK2(m->exp_infos, gc); - - gcMARK2(m->self_modidx, gc); - - gcMARK2(m->binding_names, gc); - gcMARK2(m->et_binding_names, gc); - gcMARK2(m->other_binding_names, gc); - - gcMARK2(m->insp, gc); - - gcMARK2(m->lang_info, gc); - - gcMARK2(m->hints, gc); - gcMARK2(m->ii_src, gc); - gcMARK2(m->super_bxs_info, gc); - gcMARK2(m->sub_iidx_ptrs, gc); - - gcMARK2(m->comp_prefix, gc); - gcMARK2(m->prefix, gc); - gcMARK2(m->dummy, gc); - - gcMARK2(m->rn_stx, gc); - - gcMARK2(m->submodule_path, gc); - gcMARK2(m->pre_submodules, gc); - gcMARK2(m->post_submodules, gc); - gcMARK2(m->pre_submodule_names, gc); - gcMARK2(m->supermodule, gc); - gcMARK2(m->submodule_ancestry, gc); - - gcMARK2(m->primitive, gc); + gcMARK2(i->variables.a, gc); + gcMARK2(i->weak_self_link, gc); + gcMARK2(i->source_names, gc); + gcMARK2(i->name, gc); + gcMARK2(i->data, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); # endif #endif } -static int module_val_FIXUP(void *p, struct NewGC *gc) { +static int instance_val_FIXUP(void *p, struct NewGC *gc) { #ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module *m = (Scheme_Module *)p; + Scheme_Instance *i = (Scheme_Instance *)p; - gcFIXUP2(m->phaseless, gc); - - gcFIXUP2(m->code_key, gc); - - gcFIXUP2(m->modname, gc); - gcFIXUP2(m->modsrc, gc); - - gcFIXUP2(m->et_requires, gc); - gcFIXUP2(m->requires, gc); - gcFIXUP2(m->tt_requires, gc); - gcFIXUP2(m->dt_requires, gc); - gcFIXUP2(m->other_requires, gc); - - gcFIXUP2(m->bodies, gc); - - gcFIXUP2(m->me, gc); - - gcFIXUP2(m->exp_infos, gc); - - gcFIXUP2(m->self_modidx, gc); - - gcFIXUP2(m->binding_names, gc); - gcFIXUP2(m->et_binding_names, gc); - gcFIXUP2(m->other_binding_names, gc); - - gcFIXUP2(m->insp, gc); - - gcFIXUP2(m->lang_info, gc); - - gcFIXUP2(m->hints, gc); - gcFIXUP2(m->ii_src, gc); - gcFIXUP2(m->super_bxs_info, gc); - gcFIXUP2(m->sub_iidx_ptrs, gc); - - gcFIXUP2(m->comp_prefix, gc); - gcFIXUP2(m->prefix, gc); - gcFIXUP2(m->dummy, gc); - - gcFIXUP2(m->rn_stx, gc); - - gcFIXUP2(m->submodule_path, gc); - gcFIXUP2(m->pre_submodules, gc); - gcFIXUP2(m->post_submodules, gc); - gcFIXUP2(m->pre_submodule_names, gc); - gcFIXUP2(m->supermodule, gc); - gcFIXUP2(m->submodule_ancestry, gc); - - gcFIXUP2(m->primitive, gc); + gcFIXUP2(i->variables.a, gc); + gcFIXUP2(i->weak_self_link, gc); + gcFIXUP2(i->source_names, gc); + gcFIXUP2(i->name, gc); + gcFIXUP2(i->data, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; # else return - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); # endif #endif } -#define module_val_IS_ATOMIC 0 -#define module_val_IS_CONST_SIZE 1 - - -static int exp_info_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -#else - return 0; -#endif -} - -static int exp_info_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; - - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->accessible, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -# endif -#endif -} - -static int exp_info_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; - - gcFIXUP2(m->provide_protects, gc); - gcFIXUP2(m->indirect_provides, gc); - - gcFIXUP2(m->indirect_syntax_provides, gc); - - gcFIXUP2(m->accessible, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -# endif -#endif -} - -#define exp_info_val_IS_ATOMIC 0 -#define exp_info_val_IS_CONST_SIZE 1 - - -static int module_phase_exports_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -#else - return 0; -#endif -} - -static int module_phase_exports_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; - - gcMARK2(m->phase_index, gc); - - gcMARK2(m->src_modidx, gc); - - gcMARK2(m->provides, gc); - gcMARK2(m->provide_srcs, gc); - gcMARK2(m->provide_src_names, gc); - gcMARK2(m->provide_nominal_srcs, gc); - gcMARK2(m->provide_src_phases, gc); - - gcMARK2(m->ht, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -# endif -#endif -} - -static int module_phase_exports_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; - - gcFIXUP2(m->phase_index, gc); - - gcFIXUP2(m->src_modidx, gc); - - gcFIXUP2(m->provides, gc); - gcFIXUP2(m->provide_srcs, gc); - gcFIXUP2(m->provide_src_names, gc); - gcFIXUP2(m->provide_nominal_srcs, gc); - gcFIXUP2(m->provide_src_phases, gc); - - gcFIXUP2(m->ht, gc); - -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -# endif -#endif -} - -#define module_phase_exports_val_IS_ATOMIC 0 -#define module_phase_exports_val_IS_CONST_SIZE 1 - - -static int module_exports_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); -#else - return 0; -#endif -} - -static int module_exports_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Module_Exports *m = (Scheme_Module_Exports *)p; - - gcMARK2(m->rt, gc); - gcMARK2(m->et, gc); - gcMARK2(m->dt, gc); - gcMARK2(m->other_phases, gc); - - gcMARK2(m->src_modidx, gc); - gcMARK2(m->modsrc, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); -# endif -#endif -} - -static int module_exports_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Module_Exports *m = (Scheme_Module_Exports *)p; - - gcFIXUP2(m->rt, gc); - gcFIXUP2(m->et, gc); - gcFIXUP2(m->dt, gc); - gcFIXUP2(m->other_phases, gc); - - gcFIXUP2(m->src_modidx, gc); - gcFIXUP2(m->modsrc, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); -# endif -#endif -} - -#define module_exports_val_IS_ATOMIC 0 -#define module_exports_val_IS_CONST_SIZE 1 - - -static int modidx_val_SIZE(void *p, struct NewGC *gc) { -#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); -#else - return 0; -#endif -} - -static int modidx_val_MARK(void *p, struct NewGC *gc) { -#ifndef GC_NO_MARK_PROCEDURE_NEEDED - Scheme_Modidx *modidx = (Scheme_Modidx *)p; - - gcMARK2(modidx->path, gc); - gcMARK2(modidx->base, gc); - gcMARK2(modidx->resolved, gc); - gcMARK2(modidx->shift_cache, gc); - gcMARK2(modidx->cache_next, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); -# endif -#endif -} - -static int modidx_val_FIXUP(void *p, struct NewGC *gc) { -#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED - Scheme_Modidx *modidx = (Scheme_Modidx *)p; - - gcFIXUP2(modidx->path, gc); - gcFIXUP2(modidx->base, gc); - gcFIXUP2(modidx->resolved, gc); - gcFIXUP2(modidx->shift_cache, gc); - gcFIXUP2(modidx->cache_next, gc); -# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS - return 0; -# else - return - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); -# endif -#endif -} - -#define modidx_val_IS_ATOMIC 0 -#define modidx_val_IS_CONST_SIZE 1 +#define instance_val_IS_ATOMIC 0 +#define instance_val_IS_CONST_SIZE 1 static int guard_val_SIZE(void *p, struct NewGC *gc) { diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 180e9c8769..04b00f5f0c 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -13,19 +13,6 @@ variable_obj { gcBYTES_TO_WORDS(sizeof(Scheme_Bucket_With_Home)); } -module_var { - mark: - Module_Variable *mv = (Module_Variable *)p; - - gcMARK2(mv->modidx, gc); - gcMARK2(mv->sym, gc); - gcMARK2(mv->insp, gc); - gcMARK2(mv->shape, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Module_Variable)); -} - bucket_obj { mark: Scheme_Bucket *b = (Scheme_Bucket *)p; @@ -49,12 +36,6 @@ toplevel_obj { gcBYTES_TO_WORDS(sizeof(Scheme_Toplevel)); } -quotesyntax_obj { - mark: - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax)); -} - cpointer_obj { mark: if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { @@ -234,6 +215,9 @@ ir_local { gcMARK2(var->name, gc); switch (var->mode) { + case SCHEME_VAR_MODE_COMPILE: + gcMARK2(var->compile.use_box, gc); + break; case SCHEME_VAR_MODE_LETREC_CHECK: gcMARK2(var->letrec_check.frame, gc); break; @@ -252,6 +236,12 @@ ir_local { gcBYTES_TO_WORDS(sizeof(Scheme_IR_Local)); } +ir_toplevel { + mark: + size: + gcBYTES_TO_WORDS(sizeof(Scheme_IR_Toplevel)); +} + ir_let_value { mark: Scheme_IR_Let_Value *c = (Scheme_IR_Let_Value *)p; @@ -690,13 +680,6 @@ output_port { gcBYTES_TO_WORDS(sizeof(Scheme_Output_Port)); } - -syntax_compiler { - mark: - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object)); -} - thread_val { mark: Scheme_Thread *pr = (Scheme_Thread *)p; @@ -752,14 +735,6 @@ thread_val { gcMARK2(pr->return_marks_to, gc); gcMARK2(pr->returned_marks, gc); - gcMARK2(pr->current_local_env, gc); - gcMARK2(pr->current_local_scope, gc); - gcMARK2(pr->current_local_use_scope, gc); - gcMARK2(pr->current_local_name, gc); - gcMARK2(pr->current_local_modidx, gc); - gcMARK2(pr->current_local_menv, gc); - gcMARK2(pr->current_local_bindings, gc); - gcMARK2(pr->current_mt, gc); gcMARK2(pr->constant_folding, gc); @@ -936,61 +911,27 @@ bucket_table_val { gcBYTES_TO_WORDS(sizeof(Scheme_Bucket_Table)); } -namespace_val { +env_val { mark: Scheme_Env *e = (Scheme_Env *)p; - gcMARK2(e->module, gc); - gcMARK2(e->module_registry, gc); - gcMARK2(e->module_pre_registry, gc); - gcMARK2(e->guard_insp, gc); - gcMARK2(e->access_insp, gc); - - gcMARK2(e->stx_context, gc); - gcMARK2(e->tmp_bind_scope, gc); - - gcMARK2(e->syntax, gc); - gcMARK2(e->exp_env, gc); - gcMARK2(e->template_env, gc); - gcMARK2(e->label_env, gc); - gcMARK2(e->instance_env, gc); - gcMARK2(e->reader_env, gc); - - gcMARK2(e->shadowed_syntax, gc); - - gcMARK2(e->lift_key, gc); - - gcMARK2(e->link_midx, gc); - gcMARK2(e->require_names, gc); - gcMARK2(e->et_require_names, gc); - gcMARK2(e->tt_require_names, gc); - gcMARK2(e->dt_require_names, gc); - gcMARK2(e->other_require_names, gc); - gcMARK2(e->running, gc); - gcMARK2(e->did_starts, gc); - gcMARK2(e->available_next[0], gc); - gcMARK2(e->available_next[1], gc); - - gcMARK2(e->toplevel, gc); - gcMARK2(e->modchain, gc); - - gcMARK2(e->modvars, gc); - - gcMARK2(e->weak_self_link, gc); - - gcMARK2(e->binding_names, gc); - + gcMARK2(e->namespace, gc); + gcMARK2(e->instance, gc); + gcMARK2(e->protected, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Env)); } -module_reg_val { +startup_env_val { mark: - Scheme_Module_Registry *r = (Scheme_Module_Registry *)p; - gcMARK2(r->loaded, gc); - gcMARK2(r->exports, gc); + Scheme_Startup_Env *e = (Scheme_Startup_Env *)p; + + gcMARK2(e->current_table, gc); + gcMARK2(e->primitive_tables, gc); + gcMARK2(e->all_primitives_table, gc); + gcMARK2(e->primitive_ids_table, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Registry)); + gcBYTES_TO_WORDS(sizeof(Scheme_Startup_Env)); } random_state_val { @@ -999,17 +940,6 @@ random_state_val { gcBYTES_TO_WORDS(sizeof(Scheme_Random_State)); } -compilation_top_val { - mark: - Scheme_Compilation_Top *t = (Scheme_Compilation_Top *)p; - gcMARK2(t->code, gc); - gcMARK2(t->prefix, gc); - gcMARK2(t->binding_namess, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Compilation_Top)); -} - prefix_val { Scheme_Prefix *pf = (Scheme_Prefix *)p; mark: @@ -1019,34 +949,10 @@ prefix_val { size: gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) - + ((((pf->num_slots - pf->num_stxes) + 31) / 32) + + ((((pf->num_slots + 31) / 32) * sizeof(int)))); } -resolve_prefix_val { - mark: - Resolve_Prefix *rp = (Resolve_Prefix *)p; - gcMARK2(rp->toplevels, gc); - gcMARK2(rp->stxes, gc); - gcMARK2(rp->delay_info_rpair, gc); - gcMARK2(rp->src_insp_desc, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); -} - -comp_prefix_val { - mark: - Comp_Prefix *cp = (Comp_Prefix *)p; - gcMARK2(cp->toplevels, gc); - gcMARK2(cp->inline_variants, gc); - gcMARK2(cp->unbound, gc); - gcMARK2(cp->stxes, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Comp_Prefix)); -} - svector_val { mark: Scheme_Object *o = (Scheme_Object *)p; @@ -1062,139 +968,37 @@ stx_val { Scheme_Stx *stx = (Scheme_Stx *)p; gcMARK2(stx->val, gc); gcMARK2(stx->srcloc, gc); - gcMARK2(stx->scopes, gc); - gcMARK2(stx->u.to_propagate, gc); - gcMARK2(stx->shifts, gc); - gcMARK2(stx->taints, gc); gcMARK2(stx->props, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Stx)); } -stx_off_val { +linklet_val { mark: - Scheme_Stx_Offset *o = (Scheme_Stx_Offset *)p; - gcMARK2(o->src, gc); + Scheme_Linklet *l = (Scheme_Linklet *)p; + + gcMARK2(l->name, gc); + gcMARK2(l->importss, gc); + gcMARK2(l->import_shapes, gc); + gcMARK2(l->defns, gc); + gcMARK2(l->source_names, gc); + gcMARK2(l->bodies, gc); + gcMARK2(l->constants, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Offset)); + gcBYTES_TO_WORDS(sizeof(Scheme_Linklet)); } -module_val { +instance_val { mark: - Scheme_Module *m = (Scheme_Module *)p; + Scheme_Instance *i = (Scheme_Instance *)p; - gcMARK2(m->phaseless, gc); - - gcMARK2(m->code_key, gc); - - gcMARK2(m->modname, gc); - gcMARK2(m->modsrc, gc); - - gcMARK2(m->et_requires, gc); - gcMARK2(m->requires, gc); - gcMARK2(m->tt_requires, gc); - gcMARK2(m->dt_requires, gc); - gcMARK2(m->other_requires, gc); - - gcMARK2(m->bodies, gc); - - gcMARK2(m->me, gc); - - gcMARK2(m->exp_infos, gc); - - gcMARK2(m->self_modidx, gc); - - gcMARK2(m->binding_names, gc); - gcMARK2(m->et_binding_names, gc); - gcMARK2(m->other_binding_names, gc); - - gcMARK2(m->insp, gc); - - gcMARK2(m->lang_info, gc); - - gcMARK2(m->hints, gc); - gcMARK2(m->ii_src, gc); - gcMARK2(m->super_bxs_info, gc); - gcMARK2(m->sub_iidx_ptrs, gc); - - gcMARK2(m->comp_prefix, gc); - gcMARK2(m->prefix, gc); - gcMARK2(m->dummy, gc); - - gcMARK2(m->rn_stx, gc); - - gcMARK2(m->submodule_path, gc); - gcMARK2(m->pre_submodules, gc); - gcMARK2(m->post_submodules, gc); - gcMARK2(m->pre_submodule_names, gc); - gcMARK2(m->supermodule, gc); - gcMARK2(m->submodule_ancestry, gc); - - gcMARK2(m->primitive, gc); + gcMARK2(i->variables.a, gc); + gcMARK2(i->weak_self_link, gc); + gcMARK2(i->source_names, gc); + gcMARK2(i->name, gc); + gcMARK2(i->data, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module)); -} - -exp_info_val { - mark: - Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; - - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->accessible, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); -} - -module_phase_exports_val { - mark: - Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; - - gcMARK2(m->phase_index, gc); - - gcMARK2(m->src_modidx, gc); - - gcMARK2(m->provides, gc); - gcMARK2(m->provide_srcs, gc); - gcMARK2(m->provide_src_names, gc); - gcMARK2(m->provide_nominal_srcs, gc); - gcMARK2(m->provide_src_phases, gc); - - gcMARK2(m->ht, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); -} - -module_exports_val { - mark: - Scheme_Module_Exports *m = (Scheme_Module_Exports *)p; - - gcMARK2(m->rt, gc); - gcMARK2(m->et, gc); - gcMARK2(m->dt, gc); - gcMARK2(m->other_phases, gc); - - gcMARK2(m->src_modidx, gc); - gcMARK2(m->modsrc, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports)); -} - -modidx_val { - mark: - Scheme_Modidx *modidx = (Scheme_Modidx *)p; - - gcMARK2(modidx->path, gc); - gcMARK2(modidx->base, gc); - gcMARK2(modidx->resolved, gc); - gcMARK2(modidx->shift_cache, gc); - gcMARK2(modidx->cache_next, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Modidx)); + gcBYTES_TO_WORDS(sizeof(Scheme_Instance)); } guard_val { @@ -1283,38 +1087,21 @@ END env; /**********************************************************************/ +START linklet; + +END linklet; + +/**********************************************************************/ + START compenv; mark_comp_env { mark: Scheme_Comp_Env *e = (Scheme_Comp_Env *)p; - gcMARK2(e->genv, gc); - gcMARK2(e->insp, gc); - gcMARK2(e->prefix, gc); - gcMARK2(e->next, gc); - gcMARK2(e->use_scopes_next, gc); - gcMARK2(e->intdef_next, gc); - gcMARK2(e->scopes, gc); - gcMARK2(e->value_name, gc); - gcMARK2(e->observer, gc); - gcMARK2(e->binders, gc); - gcMARK2(e->bindings, gc); - gcMARK2(e->vals, gc); - gcMARK2(e->shadower_deltas, gc); gcMARK2(e->vars, gc); - gcMARK2(e->dup_check, gc); - gcMARK2(e->intdef_name, gc); - gcMARK2(e->in_modidx, gc); - gcMARK2(e->skip_table, gc); - - gcMARK2(e->use, gc); - gcMARK2(e->lifts, gc); - gcMARK2(e->bindings, gc); - - gcMARK2(e->binding_namess, gc); - - gcMARK2(e->expand_result_adjust_arg, gc); + gcMARK2(e->value_name, gc); + gcMARK2(e->linklet, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env)); @@ -1330,12 +1117,15 @@ mark_resolve_info { mark: Resolve_Info *i = (Resolve_Info *)p; - gcMARK2(i->prefix, gc); - gcMARK2(i->stx_map, gc); + gcMARK2(i->linklet, gc); gcMARK2(i->tl_map, gc); gcMARK2(i->redirects, gc); gcMARK2(i->lifts, gc); + gcMARK2(i->top, gc); gcMARK2(i->next, gc); + gcMARK2(i->toplevel_starts, gc); + gcMARK2(i->toplevel_deltas, gc); + gcMARK2(i->toplevel_defns, gc); size: gcBYTES_TO_WORDS(sizeof(Resolve_Info)); @@ -1346,16 +1136,10 @@ mark_unresolve_info { Unresolve_Info *i = (Unresolve_Info *)p; gcMARK2(i->vars, gc); - gcMARK2(i->prefix, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->linklet_key, gc); + gcMARK2(i->opt_info, gc); gcMARK2(i->closures, gc); - gcMARK2(i->module, gc); - gcMARK2(i->comp_prefix, gc); - gcMARK2(i->new_toplevels, gc); - gcMARK2(i->from_modidx, gc); - gcMARK2(i->to_modidx, gc); - gcMARK2(i->opt_env, gc); - gcMARK2(i->opt_insp, gc); - gcMARK2(i->inline_variants, gc); gcMARK2(i->toplevels, gc); gcMARK2(i->definitions, gc); gcMARK2(i->ref_lifts, gc); @@ -1424,10 +1208,9 @@ mark_optimize_info { Optimize_Info *i = (Optimize_Info *)p; gcMARK2(i->next, gc); - gcMARK2(i->consts, gc); - gcMARK2(i->cp, gc); - gcMARK2(i->env, gc); - gcMARK2(i->insp, gc); + gcMARK2(i->linklet, gc); + gcMARK2(i->cross, gc); + gcMARK2(i->imports_used, gc); gcMARK2(i->top_level_consts, gc); gcMARK2(i->transitive_use_var, gc); gcMARK2(i->context, gc); @@ -1645,20 +1428,6 @@ END place; START portfun; -mark_load_handler_data { - mark: - LoadHandlerData *d = (LoadHandlerData *)p; - - gcMARK2(d->config, gc); - gcMARK2(d->port, gc); - gcMARK2(d->p, gc); - gcMARK2(d->stxsrc, gc); - gcMARK2(d->expected_module, gc); - - size: - gcBYTES_TO_WORDS(sizeof(LoadHandlerData)); -} - mark_indexed_string { mark: Scheme_Indexed_String *is = (Scheme_Indexed_String *)p; @@ -1795,17 +1564,10 @@ mark_marshal_tables { gcMARK2(mt->symtab, gc); gcMARK2(mt->st_refs, gc); gcMARK2(mt->st_ref_stack, gc); - gcMARK2(mt->reachable_scopes, gc); - gcMARK2(mt->reachable_scope_stack, gc); - gcMARK2(mt->pending_reachable_ids, gc); - gcMARK2(mt->conditionally_reachable_scopes, gc); gcMARK2(mt->intern_map, gc); - gcMARK2(mt->identity_map, gc); - gcMARK2(mt->top_map, gc); gcMARK2(mt->key_map, gc); gcMARK2(mt->delay_map, gc); gcMARK2(mt->cdata_map, gc); - gcMARK2(mt->rn_saved, gc); gcMARK2(mt->shared_offsets, gc); gcMARK2(mt->path_cache, gc); gcMARK2(mt->sorted_keys, gc); @@ -2269,8 +2031,6 @@ mark_cport { gcMARK2(cp->symtab, gc); gcMARK2(cp->symtab_entries, gc); gcMARK2(cp->relto, gc); - gcMARK2(cp->magic_sym, gc); - gcMARK2(cp->magic_val, gc); gcMARK2(cp->shared_offsets, gc); gcMARK2(cp->delay_info, gc); gcMARK2(cp->symtab_refs, gc); @@ -2278,25 +2038,12 @@ mark_cport { gcBYTES_TO_WORDS(sizeof(CPort)); } -mark_readtable { - mark: - Readtable *t = (Readtable *)p; - gcMARK2(t->mapping, gc); - gcMARK2(t->fast_mapping, gc); - gcMARK2(t->symbol_parser, gc); - gcMARK2(t->names, gc); - size: - gcBYTES_TO_WORDS(sizeof(Readtable)); -} - mark_read_params { mark: ReadParams *rp = (ReadParams *)p; - gcMARK2(rp->table, gc); - gcMARK2(rp->magic_sym, gc); - gcMARK2(rp->magic_val, gc); gcMARK2(rp->delay_load_info, gc); gcMARK2(rp->read_relative_path, gc); + gcMARK2(rp->graph_ht, gc); size: gcBYTES_TO_WORDS(sizeof(ReadParams)); } @@ -2320,10 +2067,6 @@ mark_delay_load { mark_unmarshal_tables { mark: Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p; - gcMARK2(ut->rns, gc); - gcMARK2(ut->current_rns, gc); - gcMARK2(ut->multi_scope_pairs, gc); - gcMARK2(ut->current_multi_scope_pairs, gc); gcMARK2(ut->rp, gc); gcMARK2(ut->decoded, gc); size: @@ -2401,40 +2144,6 @@ mark_srcloc { gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Srcloc)); } -mark_scope { - Scheme_Scope *m = (Scheme_Scope *)p; - int for_multi = SCHEME_SCOPE_HAS_OWNER(m); - mark: - gcMARK2(m->bindings, gc); - if (for_multi) { - gcMARK2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); - gcMARK2(((Scheme_Scope_With_Owner *)m)->phase, gc); - } - size: - (for_multi - ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) - : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); -} - -mark_scope_table { - mark: - Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; - gcMARK2(m->simple_scopes, gc); - gcMARK2(m->multi_scopes, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); -} - -mark_propagate_table { - mark: - Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; - mark_scope_table_MARK(&m->st, gc); - gcMARK2(m->prev, gc); - gcMARK2(m->phase_shift, gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); -} - END syntax; /**********************************************************************/ diff --git a/racket/src/racket/src/network.c b/racket/src/racket/src/network.c index 161d603d53..408c4ada09 100644 --- a/racket/src/racket/src/network.c +++ b/racket/src/racket/src/network.c @@ -118,63 +118,61 @@ static void udp_evt_needs_wakeup(Scheme_Object *_uw, void *fds); static void register_traversers(void); #endif -void scheme_init_network(Scheme_Env *env) +void scheme_init_network(Scheme_Startup_Env *env) { - Scheme_Env *netenv; - #ifdef MZ_PRECISE_GC register_traversers(); #endif - netenv = scheme_primitive_module(scheme_intern_symbol("#%network"), env); + scheme_switch_prim_instance(env, "#%network"); - GLOBAL_PRIM_W_ARITY2 ( "tcp-connect" , tcp_connect , 2 , 4 , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-connect/enable-break" , tcp_connect_break , 2 , 4 , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-listen" , tcp_listen , 1 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-close" , tcp_stop , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-accept-ready?" , tcp_accept_ready , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-accept" , tcp_accept , 1 , 1 , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-accept-evt" , tcp_accept_evt , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-accept/enable-break" , tcp_accept_break , 1 , 1 , 2 , 2 , netenv ) ; - GLOBAL_FOLDING_PRIM ( "tcp-listener?" , tcp_listener_p , 1 , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY2 ( "tcp-addresses" , tcp_addresses , 1 , 2 , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "tcp-abandon-port" , tcp_abandon_port , 1 , 1 , netenv ) ; - GLOBAL_FOLDING_PRIM ( "tcp-port?" , tcp_port_p , 1 , 1 , 1 , netenv ) ; + ADD_PRIM_W_ARITY2 ( "tcp-connect" , tcp_connect , 2 , 4 , 2 , 2 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-connect/enable-break" , tcp_connect_break , 2 , 4 , 2 , 2 , env) ; + ADD_PRIM_W_ARITY ( "tcp-listen" , tcp_listen , 1 , 4 , env) ; + ADD_PRIM_W_ARITY ( "tcp-close" , tcp_stop , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "tcp-accept-ready?" , tcp_accept_ready , 1 , 1 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-accept" , tcp_accept , 1 , 1 , 2 , 2 , env) ; + ADD_PRIM_W_ARITY ( "tcp-accept-evt" , tcp_accept_evt , 1 , 1 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-accept/enable-break" , tcp_accept_break , 1 , 1 , 2 , 2 , env) ; + ADD_FOLDING_PRIM ( "tcp-listener?" , tcp_listener_p , 1 , 1 , 1 , env) ; + ADD_PRIM_W_ARITY2 ( "tcp-addresses" , tcp_addresses , 1 , 2 , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "tcp-abandon-port" , tcp_abandon_port , 1 , 1 , env) ; + ADD_FOLDING_PRIM ( "tcp-port?" , tcp_port_p , 1 , 1 , 1 , env) ; - GLOBAL_PRIM_W_ARITY ( "udp-open-socket" , make_udp , 0 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-close" , udp_close , 1 , 1 , netenv ) ; - GLOBAL_FOLDING_PRIM ( "udp?" , udp_p , 1 , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-bound?" , udp_bound_p , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-connected?" , udp_connected_p , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-bind!" , udp_bind , 3 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-connect!" , udp_connect , 3 , 3 , netenv ) ; + ADD_PRIM_W_ARITY ( "udp-open-socket" , make_udp , 0 , 2 , env) ; + ADD_PRIM_W_ARITY ( "udp-close" , udp_close , 1 , 1 , env) ; + ADD_FOLDING_PRIM ( "udp?" , udp_p , 1 , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-bound?" , udp_bound_p , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-connected?" , udp_connected_p , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-bind!" , udp_bind , 3 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-connect!" , udp_connect , 3 , 3 , env) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-to" , udp_send_to , 4 , 6 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send" , udp_send , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-to*" , udp_send_to_star , 4 , 6 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send*" , udp_send_star , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-to/enable-break" , udp_send_to_enable_break , 4 , 6 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send/enable-break" , udp_send_enable_break , 2 , 4 , netenv ) ; + ADD_PRIM_W_ARITY ( "udp-send-to" , udp_send_to , 4 , 6 , env) ; + ADD_PRIM_W_ARITY ( "udp-send" , udp_send , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-to*" , udp_send_to_star , 4 , 6 , env) ; + ADD_PRIM_W_ARITY ( "udp-send*" , udp_send_star , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-to/enable-break" , udp_send_to_enable_break , 4 , 6 , env) ; + ADD_PRIM_W_ARITY ( "udp-send/enable-break" , udp_send_enable_break , 2 , 4 , env) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive!" , udp_receive , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive!*" , udp_receive_star , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive!/enable-break" , udp_receive_enable_break , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive-ready-evt" , udp_read_ready_evt , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-ready-evt" , udp_write_ready_evt , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-receive!-evt" , udp_read_evt , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-evt" , udp_write_evt , 2 , 4 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-send-to-evt" , udp_write_to_evt , 4 , 6 , netenv ) ; + ADD_PRIM_W_ARITY ( "udp-receive!" , udp_receive , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive!*" , udp_receive_star , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive!/enable-break" , udp_receive_enable_break , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive-ready-evt" , udp_read_ready_evt , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-ready-evt" , udp_write_ready_evt , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-receive!-evt" , udp_read_evt , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-evt" , udp_write_evt , 2 , 4 , env) ; + ADD_PRIM_W_ARITY ( "udp-send-to-evt" , udp_write_to_evt , 4 , 6 , env) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-loopback?" , udp_multicast_loopback_p , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-set-loopback!", udp_multicast_set_loopback,2, 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-ttl" , udp_multicast_ttl , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-set-ttl!" , udp_multicast_set_ttl , 2 , 2 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-interface" , udp_multicast_interface , 1 , 1 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-set-interface!", udp_multicast_set_interface,2,2, netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-join-group!" , udp_multicast_join_group , 3 , 3 , netenv ) ; - GLOBAL_PRIM_W_ARITY ( "udp-multicast-leave-group!", udp_multicast_leave_group, 3 , 3 , netenv ) ; + ADD_PRIM_W_ARITY ( "udp-multicast-loopback?" , udp_multicast_loopback_p , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-set-loopback!", udp_multicast_set_loopback,2, 2 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-ttl" , udp_multicast_ttl , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-set-ttl!" , udp_multicast_set_ttl , 2 , 2 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-interface" , udp_multicast_interface , 1 , 1 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-set-interface!", udp_multicast_set_interface,2,2, env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-join-group!" , udp_multicast_join_group , 3 , 3 , env) ; + ADD_PRIM_W_ARITY ( "udp-multicast-leave-group!", udp_multicast_leave_group, 3 , 3 , env) ; - scheme_finish_primitive_module(netenv); + scheme_restore_prim_instance(env); } static int check_fd_sema(rktio_fd_t *s, int mode, Scheme_Schedule_Info *sinfo, Scheme_Object *orig) diff --git a/racket/src/racket/src/numarith.c b/racket/src/racket/src/numarith.c index 41541e844b..7ad8bcaceb 100644 --- a/racket/src/racket/src/numarith.c +++ b/racket/src/racket/src/numarith.c @@ -87,7 +87,7 @@ static Scheme_Object *unsafe_extfl_sqrt (int argc, Scheme_Object *argv[]); # define SQRT_MACHINE_CODE_AVAILABLE 1 #endif -void scheme_init_numarith(Scheme_Env *env) +void scheme_init_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -97,7 +97,7 @@ void scheme_init_numarith(Scheme_Env *env) | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("add1", p, env); + scheme_addto_prim_instance("add1", p, env); p = scheme_make_folding_prim(scheme_sub1, "sub1", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED @@ -105,7 +105,7 @@ void scheme_init_numarith(Scheme_Env *env) | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("sub1", p, env); + scheme_addto_prim_instance("sub1", p, env); p = scheme_make_folding_prim(plus, "+", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -114,7 +114,7 @@ void scheme_init_numarith(Scheme_Env *env) | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("+", p, env); + scheme_addto_prim_instance("+", p, env); p = scheme_make_folding_prim(minus, "-", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -124,7 +124,7 @@ void scheme_init_numarith(Scheme_Env *env) | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("-", p, env); + scheme_addto_prim_instance("-", p, env); p = scheme_make_folding_prim(mult, "*", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -133,7 +133,7 @@ void scheme_init_numarith(Scheme_Env *env) | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("*", p, env); + scheme_addto_prim_instance("*", p, env); p = scheme_make_folding_prim(div_prim, "/", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED @@ -141,7 +141,7 @@ void scheme_init_numarith(Scheme_Env *env) | SCHEME_PRIM_WANTS_NUMBER | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("/", p, env); + scheme_addto_prim_instance("/", p, env); p = scheme_make_folding_prim(scheme_abs, "abs", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED @@ -149,21 +149,21 @@ void scheme_init_numarith(Scheme_Env *env) | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS | SCHEME_PRIM_PRODUCES_NUMBER | SCHEME_PRIM_CLOSED_ON_REALS); - scheme_add_global_constant("abs", p, env); + scheme_addto_prim_instance("abs", p, env); p = scheme_make_folding_prim(quotient, "quotient", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("quotient", p, env); + scheme_addto_prim_instance("quotient", p, env); p = scheme_make_folding_prim(rem_prim, "remainder", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("remainder", p, env); + scheme_addto_prim_instance("remainder", p, env); - scheme_add_global_constant("quotient/remainder", + scheme_addto_prim_instance("quotient/remainder", scheme_make_prim_w_arity2(quotient_remainder, "quotient/remainder", 2, 2, @@ -174,10 +174,10 @@ void scheme_init_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("modulo", p, env); + scheme_addto_prim_instance("modulo", p, env); } -void scheme_init_flfxnum_numarith(Scheme_Env *env) +void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -185,37 +185,37 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env) p = scheme_make_folding_prim(fx_plus, "fx+", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fx+", p, env); + scheme_addto_prim_instance("fx+", p, env); p = scheme_make_folding_prim(fx_minus, "fx-", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fx-", p, env); + scheme_addto_prim_instance("fx-", p, env); p = scheme_make_folding_prim(fx_mult, "fx*", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fx*", p, env); + scheme_addto_prim_instance("fx*", p, env); p = scheme_make_folding_prim(fx_div, "fxquotient", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxquotient", p, env); + scheme_addto_prim_instance("fxquotient", p, env); p = scheme_make_folding_prim(fx_rem, "fxremainder", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxremainder", p, env); + scheme_addto_prim_instance("fxremainder", p, env); p = scheme_make_folding_prim(fx_mod, "fxmodulo", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxmodulo", p, env); + scheme_addto_prim_instance("fxmodulo", p, env); p = scheme_make_folding_prim(fx_abs, "fxabs", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED) | SCHEME_PRIM_PRODUCES_FIXNUM; - scheme_add_global_constant("fxabs", p, env); + scheme_addto_prim_instance("fxabs", p, env); p = scheme_make_folding_prim(fl_plus, "fl+", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -225,7 +225,7 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl+", p, env); + scheme_addto_prim_instance("fl+", p, env); p = scheme_make_folding_prim(fl_minus, "fl-", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -235,7 +235,7 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl-", p, env); + scheme_addto_prim_instance("fl-", p, env); p = scheme_make_folding_prim(fl_mult, "fl*", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -245,7 +245,7 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl*", p, env); + scheme_addto_prim_instance("fl*", p, env); p = scheme_make_folding_prim(fl_div, "fl/", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -255,7 +255,7 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl/", p, env); + scheme_addto_prim_instance("fl/", p, env); p = scheme_make_folding_prim(fl_abs, "flabs", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -265,7 +265,7 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("flabs", p, env); + scheme_addto_prim_instance("flabs", p, env); p = scheme_make_folding_prim(fl_sqrt, "flsqrt", 1, 1, 1); if (scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE) @@ -275,11 +275,11 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("flsqrt", p, env); + scheme_addto_prim_instance("flsqrt", p, env); } -void scheme_init_extfl_numarith(Scheme_Env *env) +void scheme_init_extfl_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -292,7 +292,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl+", p, env); + scheme_addto_prim_instance("extfl+", p, env); p = scheme_make_folding_prim(extfl_minus, "extfl-", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -302,7 +302,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl-", p, env); + scheme_addto_prim_instance("extfl-", p, env); p = scheme_make_folding_prim(extfl_mult, "extfl*", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -312,7 +312,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl*", p, env); + scheme_addto_prim_instance("extfl*", p, env); p = scheme_make_folding_prim(extfl_div, "extfl/", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -322,7 +322,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl/", p, env); + scheme_addto_prim_instance("extfl/", p, env); p = scheme_make_folding_prim(extfl_abs, "extflabs", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -332,7 +332,7 @@ void scheme_init_extfl_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("extflabs", p, env); + scheme_addto_prim_instance("extflabs", p, env); p = scheme_make_folding_prim(extfl_sqrt, "extflsqrt", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE)) @@ -342,10 +342,10 @@ void scheme_init_extfl_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("extflsqrt", p, env); + scheme_addto_prim_instance("extflsqrt", p, env); } -void scheme_init_unsafe_numarith(Scheme_Env *env) +void scheme_init_unsafe_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -354,43 +354,43 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fx+", p, env); + scheme_addto_prim_instance("unsafe-fx+", p, env); p = scheme_make_folding_prim(unsafe_fx_minus, "unsafe-fx-", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fx-", p, env); + scheme_addto_prim_instance("unsafe-fx-", p, env); p = scheme_make_folding_prim(unsafe_fx_mult, "unsafe-fx*", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fx*", p, env); + scheme_addto_prim_instance("unsafe-fx*", p, env); p = scheme_make_folding_prim(unsafe_fx_div, "unsafe-fxquotient", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxquotient", p, env); + scheme_addto_prim_instance("unsafe-fxquotient", p, env); p = scheme_make_folding_prim(unsafe_fx_rem, "unsafe-fxremainder", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxremainder", p, env); + scheme_addto_prim_instance("unsafe-fxremainder", p, env); p = scheme_make_folding_prim(unsafe_fx_mod, "unsafe-fxmodulo", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxmodulo", p, env); + scheme_addto_prim_instance("unsafe-fxmodulo", p, env); p = scheme_make_folding_prim(unsafe_fx_abs, "unsafe-fxabs", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxabs", p, env); + scheme_addto_prim_instance("unsafe-fxabs", p, env); p = scheme_make_folding_prim(unsafe_fl_plus, "unsafe-fl+", 2, 2, 1); @@ -402,7 +402,7 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl+", p, env); + scheme_addto_prim_instance("unsafe-fl+", p, env); p = scheme_make_folding_prim(unsafe_fl_minus, "unsafe-fl-", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -413,7 +413,7 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl-", p, env); + scheme_addto_prim_instance("unsafe-fl-", p, env); p = scheme_make_folding_prim(unsafe_fl_mult, "unsafe-fl*", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -424,7 +424,7 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl*", p, env); + scheme_addto_prim_instance("unsafe-fl*", p, env); p = scheme_make_folding_prim(unsafe_fl_div, "unsafe-fl/", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -435,7 +435,7 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl/", p, env); + scheme_addto_prim_instance("unsafe-fl/", p, env); p = scheme_make_folding_prim(unsafe_fl_abs, "unsafe-flabs", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -446,7 +446,7 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("unsafe-flabs", p, env); + scheme_addto_prim_instance("unsafe-flabs", p, env); p = scheme_make_folding_prim(unsafe_fl_sqrt, "unsafe-flsqrt", 1, 1, 1); if (scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE) @@ -457,10 +457,10 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_FIRST); - scheme_add_global_constant("unsafe-flsqrt", p, env); + scheme_addto_prim_instance("unsafe-flsqrt", p, env); } -void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) +void scheme_init_extfl_unsafe_numarith(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -474,7 +474,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl+", p, env); + scheme_addto_prim_instance("unsafe-extfl+", p, env); p = scheme_make_folding_prim(unsafe_extfl_minus, "unsafe-extfl-", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -485,7 +485,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl-", p, env); + scheme_addto_prim_instance("unsafe-extfl-", p, env); p = scheme_make_folding_prim(unsafe_extfl_mult, "unsafe-extfl*", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -496,7 +496,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl*", p, env); + scheme_addto_prim_instance("unsafe-extfl*", p, env); p = scheme_make_folding_prim(unsafe_extfl_div, "unsafe-extfl/", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -507,7 +507,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl/", p, env); + scheme_addto_prim_instance("unsafe-extfl/", p, env); p = scheme_make_folding_prim(unsafe_extfl_abs, "unsafe-extflabs", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -518,7 +518,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("unsafe-extflabs", p, env); + scheme_addto_prim_instance("unsafe-extflabs", p, env); p = scheme_make_folding_prim(unsafe_extfl_sqrt, "unsafe-extflsqrt", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE)) @@ -529,7 +529,7 @@ void scheme_init_extfl_unsafe_numarith(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST); - scheme_add_global_constant("unsafe-extflsqrt", p, env); + scheme_addto_prim_instance("unsafe-extflsqrt", p, env); } Scheme_Object * diff --git a/racket/src/racket/src/number.c b/racket/src/racket/src/number.c index 3ed3d2d47c..71f42aaf3c 100644 --- a/racket/src/racket/src/number.c +++ b/racket/src/racket/src/number.c @@ -345,7 +345,7 @@ void scheme_configure_floating_point(void) void -scheme_init_number (Scheme_Env *env) +scheme_init_number (Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -479,69 +479,81 @@ scheme_init_number (Scheme_Env *env) p = scheme_make_folding_prim(number_p, "number?", 1, 1, 1); scheme_number_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("number?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("number?", p, env); p = scheme_make_folding_prim(complex_p, "complex?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("complex?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("complex?", p, env); REGISTER_SO(scheme_real_p_proc); p = scheme_make_folding_prim(real_p, "real?", 1, 1, 1); scheme_real_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("real?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("real?", p, env); p = scheme_make_folding_prim(rational_p, "rational?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("rational?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("rational?", p, env); p = scheme_make_folding_prim(integer_p, "integer?", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("integer?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("integer?", p, env); p = scheme_make_folding_prim(exact_integer_p, "exact-integer?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("exact-integer?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("exact-integer?", p, env); p = scheme_make_folding_prim(exact_nonnegative_integer_p, "exact-nonnegative-integer?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("exact-nonnegative-integer?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("exact-nonnegative-integer?", p, env); p = scheme_make_folding_prim(exact_positive_integer_p, "exact-positive-integer?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("exact-positive-integer?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("exact-positive-integer?", p, env); REGISTER_SO(scheme_fixnum_p_proc); p = scheme_make_immed_prim(fixnum_p, "fixnum?", 1, 1); scheme_fixnum_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("fixnum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fixnum?", p, env); p = scheme_make_folding_prim(inexact_real_p, "inexact-real?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("inexact-real?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("inexact-real?", p, env); REGISTER_SO(scheme_flonum_p_proc); p = scheme_make_folding_prim(flonum_p, "flonum?", 1, 1, 1); scheme_flonum_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("flonum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("flonum?", p, env); p = scheme_make_folding_prim(single_flonum_p, "single-flonum?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("single-flonum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("single-flonum?", p, env); p = scheme_make_folding_prim(real_to_single_flonum, "real->single-flonum", 1, 1, 1); - scheme_add_global_constant("real->single-flonum", p, env); + scheme_addto_prim_instance("real->single-flonum", p, env); p = scheme_make_folding_prim(real_to_double_flonum, "real->double-flonum", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -549,14 +561,14 @@ scheme_init_number (Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("real->double-flonum", p, env); + scheme_addto_prim_instance("real->double-flonum", p, env); - scheme_add_global_constant("exact?", + scheme_addto_prim_instance("exact?", scheme_make_folding_prim(exact_p, "exact?", 1, 1, 1), env); - scheme_add_global_constant("inexact?", + scheme_addto_prim_instance("inexact?", scheme_make_folding_prim(scheme_inexact_p, "inexact?", 1, 1, 1), @@ -564,36 +576,40 @@ scheme_init_number (Scheme_Env *env) p = scheme_make_folding_prim(scheme_odd_p, "odd?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("odd?", p, env); + scheme_addto_prim_instance("odd?", p, env); p = scheme_make_folding_prim(scheme_even_p, "even?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("even?", p, env); + scheme_addto_prim_instance("even?", p, env); p = scheme_make_folding_prim(scheme_bitwise_and, "bitwise-and", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bitwise-and", p, env); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-and", p, env); p = scheme_make_folding_prim(bitwise_or, "bitwise-ior", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bitwise-ior", p, env); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-ior", p, env); p = scheme_make_folding_prim(bitwise_xor, "bitwise-xor", 0, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bitwise-xor", p, env); + | SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-xor", p, env); p = scheme_make_folding_prim(bitwise_not, "bitwise-not", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("bitwise-not", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bitwise-not", p, env); p = scheme_make_folding_prim(bitwise_bit_set_p, "bitwise-bit-set?", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("bitwise-bit-set?", p, env); + scheme_addto_prim_instance("bitwise-bit-set?", p, env); - scheme_add_global_constant("bitwise-bit-field", + scheme_addto_prim_instance("bitwise-bit-field", scheme_make_folding_prim(bitwise_bit_field, "bitwise-bit-field", 3, 3, 1), @@ -601,109 +617,109 @@ scheme_init_number (Scheme_Env *env) p = scheme_make_folding_prim(scheme_bitwise_shift, "arithmetic-shift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("arithmetic-shift", p, env); + scheme_addto_prim_instance("arithmetic-shift", p, env); p = scheme_make_folding_prim(integer_length, "integer-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("integer-length", p, env); + scheme_addto_prim_instance("integer-length", p, env); - scheme_add_global_constant("gcd", + scheme_addto_prim_instance("gcd", scheme_make_folding_prim(gcd, "gcd", 0, -1, 1), env); - scheme_add_global_constant("lcm", + scheme_addto_prim_instance("lcm", scheme_make_folding_prim(lcm, "lcm", 0, -1, 1), env); - scheme_add_global_constant("floor", + scheme_addto_prim_instance("floor", scheme_make_folding_prim(scheme_floor, "floor", 1, 1, 1), env); - scheme_add_global_constant("ceiling", + scheme_addto_prim_instance("ceiling", scheme_make_folding_prim(ceiling, "ceiling", 1, 1, 1), env); - scheme_add_global_constant("truncate", + scheme_addto_prim_instance("truncate", scheme_make_folding_prim(sch_truncate, "truncate", 1, 1, 1), env); - scheme_add_global_constant("round", + scheme_addto_prim_instance("round", scheme_make_folding_prim(sch_round, "round", 1, 1, 1), env); - scheme_add_global_constant("numerator", + scheme_addto_prim_instance("numerator", scheme_make_folding_prim(numerator, "numerator", 1, 1, 1), env); - scheme_add_global_constant("denominator", + scheme_addto_prim_instance("denominator", scheme_make_folding_prim(denominator, "denominator", 1, 1, 1), env); - scheme_add_global_constant("exp", + scheme_addto_prim_instance("exp", scheme_make_folding_prim(exp_prim, "exp", 1, 1, 1), env); - scheme_add_global_constant("log", - scheme_make_folding_prim(log_prim, + scheme_addto_prim_instance("log", + scheme_make_folding_prim(log_prim, "log", 1, 2, 1), env); - scheme_add_global_constant("sin", + scheme_addto_prim_instance("sin", scheme_make_folding_prim(sin_prim, "sin", 1, 1, 1), env); - scheme_add_global_constant("cos", + scheme_addto_prim_instance("cos", scheme_make_folding_prim(cos_prim, "cos", 1, 1, 1), env); - scheme_add_global_constant("tan", + scheme_addto_prim_instance("tan", scheme_make_folding_prim(tan_prim, "tan", 1, 1, 1), env); - scheme_add_global_constant("asin", + scheme_addto_prim_instance("asin", scheme_make_folding_prim(asin_prim, "asin", 1, 1, 1), env); - scheme_add_global_constant("acos", + scheme_addto_prim_instance("acos", scheme_make_folding_prim(acos_prim, "acos", 1, 1, 1), env); - scheme_add_global_constant("atan", + scheme_addto_prim_instance("atan", scheme_make_folding_prim(atan_prim, "atan", 1, 2, 1), env); - scheme_add_global_constant("sqrt", + scheme_addto_prim_instance("sqrt", scheme_make_folding_prim(scheme_sqrt, "sqrt", 1, 1, 1), env); - scheme_add_global_constant("integer-sqrt", + scheme_addto_prim_instance("integer-sqrt", scheme_make_folding_prim(int_sqrt, "integer-sqrt", 1, 1, 1), env); - scheme_add_global_constant("integer-sqrt/remainder", + scheme_addto_prim_instance("integer-sqrt/remainder", scheme_make_prim_w_arity2(int_sqrt_rem, "integer-sqrt/remainder", 1, 1, 2, 2), env); - scheme_add_global_constant("expt", + scheme_addto_prim_instance("expt", scheme_make_folding_prim(scheme_expt, "expt", 2, 2, 1), @@ -711,9 +727,9 @@ scheme_init_number (Scheme_Env *env) p = scheme_make_folding_prim(scheme_checked_make_rectangular, "make-rectangular", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("make-rectangular", p, env); + scheme_addto_prim_instance("make-rectangular", p, env); - scheme_add_global_constant("make-polar", + scheme_addto_prim_instance("make-polar", scheme_make_folding_prim(scheme_make_polar, "make-polar", 2, 2, 1), @@ -721,18 +737,18 @@ scheme_init_number (Scheme_Env *env) p = scheme_make_folding_prim(scheme_checked_real_part, "real-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("real-part", p, env); + scheme_addto_prim_instance("real-part", p, env); p = scheme_make_folding_prim(scheme_checked_imag_part, "imag-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("imag-part", p, env); + scheme_addto_prim_instance("imag-part", p, env); - scheme_add_global_constant("angle", + scheme_addto_prim_instance("angle", scheme_make_folding_prim(angle, "angle", 1, 1, 1), env); - scheme_add_global_constant("magnitude", + scheme_addto_prim_instance("magnitude", scheme_make_folding_prim(magnitude, "magnitude", 1, 1, 1), @@ -744,41 +760,41 @@ scheme_init_number (Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("exact->inexact", p, env); + scheme_addto_prim_instance("exact->inexact", p, env); p = scheme_make_folding_prim(scheme_inexact_to_exact, "inexact->exact", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("inexact->exact", p, env); + scheme_addto_prim_instance("inexact->exact", p, env); } -void scheme_init_flfxnum_number(Scheme_Env *env) +void scheme_init_flfxnum_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; - scheme_add_global_constant("flvector", + scheme_addto_prim_instance("flvector", scheme_make_prim_w_arity(flvector, "flvector", 0, -1), env); - scheme_add_global_constant("flvector?", + scheme_addto_prim_instance("flvector?", scheme_make_folding_prim(flvector_p, "flvector?", 1, 1, 1), env); - scheme_add_global_constant("make-flvector", + scheme_addto_prim_instance("make-flvector", scheme_make_immed_prim(make_flvector, "make-flvector", 1, 2), env); - GLOBAL_PRIM_W_ARITY("shared-flvector", shared_flvector, 0, -1, env); - GLOBAL_PRIM_W_ARITY("make-shared-flvector", make_shared_flvector, 1, 2, env); + ADD_PRIM_W_ARITY("shared-flvector", shared_flvector, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-flvector", make_shared_flvector, 1, 2, env); p = scheme_make_immed_prim(flvector_length, "flvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("flvector-length", p, env); + scheme_addto_prim_instance("flvector-length", p, env); p = scheme_make_immed_prim(scheme_checked_flvector_ref, "flvector-ref", @@ -789,51 +805,51 @@ void scheme_init_flfxnum_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flvector-ref", p, env); + scheme_addto_prim_instance("flvector-ref", p, env); p = scheme_make_immed_prim(scheme_checked_flvector_set, "flvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_FLONUM_THIRD); - scheme_add_global_constant("flvector-set!", p, env); + scheme_addto_prim_instance("flvector-set!", p, env); - scheme_add_global_constant("fxvector", + scheme_addto_prim_instance("fxvector", scheme_make_prim_w_arity(fxvector, "fxvector", 0, -1), env); - scheme_add_global_constant("fxvector?", + scheme_addto_prim_instance("fxvector?", scheme_make_folding_prim(fxvector_p, "fxvector?", 1, 1, 1), env); - scheme_add_global_constant("make-fxvector", + scheme_addto_prim_instance("make-fxvector", scheme_make_immed_prim(make_fxvector, "make-fxvector", 1, 2), env); - GLOBAL_PRIM_W_ARITY("shared-fxvector", shared_fxvector, 0, -1, env); - GLOBAL_PRIM_W_ARITY("make-shared-fxvector", make_shared_fxvector, 1, 2, env); + ADD_PRIM_W_ARITY("shared-fxvector", shared_fxvector, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-fxvector", make_shared_fxvector, 1, 2, env); p = scheme_make_immed_prim(fxvector_length, "fxvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxvector-length", p, env); + scheme_addto_prim_instance("fxvector-length", p, env); p = scheme_make_immed_prim(scheme_checked_fxvector_ref, "fxvector-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxvector-ref", p, env); + scheme_addto_prim_instance("fxvector-ref", p, env); p = scheme_make_immed_prim(scheme_checked_fxvector_set, "fxvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("fxvector-set!", p, env); + scheme_addto_prim_instance("fxvector-set!", p, env); p = scheme_make_folding_prim(integer_to_fl, "->fl", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -842,7 +858,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("->fl", p, env); + scheme_addto_prim_instance("->fl", p, env); p = scheme_make_folding_prim(fl_to_integer, "fl->exact-integer", 1, 1, 1); if (scheme_can_inline_fp_comp()) @@ -850,37 +866,41 @@ void scheme_init_flfxnum_number(Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("fl->exact-integer", p, env); + scheme_addto_prim_instance("fl->exact-integer", p, env); p = scheme_make_folding_prim(fx_and, "fxand", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxand", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxand", p, env); p = scheme_make_folding_prim(fx_or, "fxior", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxior", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxior", p, env); p = scheme_make_folding_prim(fx_xor, "fxxor", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxxor", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxxor", p, env); p = scheme_make_folding_prim(fx_not, "fxnot", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxnot", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxnot", p, env); p = scheme_make_folding_prim(fx_lshift, "fxlshift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxlshift", p, env); + scheme_addto_prim_instance("fxlshift", p, env); p = scheme_make_folding_prim(fx_rshift, "fxrshift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxrshift", p, env); + scheme_addto_prim_instance("fxrshift", p, env); p = scheme_make_folding_prim(fx_to_fl, "fx->fl", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -889,7 +909,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fx->fl", p, env); + scheme_addto_prim_instance("fx->fl", p, env); p = scheme_make_folding_prim(fl_to_fx, "fl->fx", 1, 1, 1); if (scheme_can_inline_fp_comp()) @@ -899,7 +919,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fl->fx", p, env); + scheme_addto_prim_instance("fl->fx", p, env); p = scheme_make_folding_prim(fl_truncate, "fltruncate", 1, 1, 1); @@ -910,7 +930,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fltruncate", p, env); + scheme_addto_prim_instance("fltruncate", p, env); p = scheme_make_folding_prim(fl_round, "flround", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -920,7 +940,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flround", p, env); + scheme_addto_prim_instance("flround", p, env); p = scheme_make_folding_prim(fl_ceiling, "flceiling", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -930,7 +950,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flceiling", p, env); + scheme_addto_prim_instance("flceiling", p, env); p = scheme_make_folding_prim(fl_floor, "flfloor", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -940,7 +960,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flfloor", p, env); + scheme_addto_prim_instance("flfloor", p, env); p = scheme_make_folding_prim(fl_sin, "flsin", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -950,7 +970,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flsin", p, env); + scheme_addto_prim_instance("flsin", p, env); p = scheme_make_folding_prim(fl_cos, "flcos", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -960,7 +980,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flcos", p, env); + scheme_addto_prim_instance("flcos", p, env); p = scheme_make_folding_prim(fl_tan, "fltan", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -970,7 +990,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fltan", p, env); + scheme_addto_prim_instance("fltan", p, env); p = scheme_make_folding_prim(fl_asin, "flasin", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -980,7 +1000,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flasin", p, env); + scheme_addto_prim_instance("flasin", p, env); p = scheme_make_folding_prim(fl_acos, "flacos", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -990,7 +1010,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flacos", p, env); + scheme_addto_prim_instance("flacos", p, env); p = scheme_make_folding_prim(fl_atan, "flatan", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -1000,7 +1020,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flatan", p, env); + scheme_addto_prim_instance("flatan", p, env); p = scheme_make_folding_prim(fl_log, "fllog", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -1010,7 +1030,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("fllog", p, env); + scheme_addto_prim_instance("fllog", p, env); p = scheme_make_folding_prim(fl_exp, "flexp", 1, 1, 1); if (scheme_can_inline_fp_op()) @@ -1020,7 +1040,7 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flexp", p, env); + scheme_addto_prim_instance("flexp", p, env); p = scheme_make_folding_prim(fl_expt, "flexpt", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -1030,24 +1050,24 @@ void scheme_init_flfxnum_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flexpt", p, env); + scheme_addto_prim_instance("flexpt", p, env); p = scheme_make_folding_prim(scheme_checked_make_rectangular, "make-flrectangular", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("make-flrectangular", p, env); + scheme_addto_prim_instance("make-flrectangular", p, env); p = scheme_make_folding_prim(scheme_checked_flreal_part, "flreal-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flreal-part", p, env); + scheme_addto_prim_instance("flreal-part", p, env); p = scheme_make_folding_prim(scheme_checked_flimag_part, "flimag-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("flimag-part", p, env); + scheme_addto_prim_instance("flimag-part", p, env); } -void scheme_init_extfl_number(Scheme_Env *env) +void scheme_init_extfl_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -1056,38 +1076,39 @@ void scheme_init_extfl_number(Scheme_Env *env) p = scheme_make_folding_prim(extflonum_p, "extflonum?", 1, 1, 1); scheme_extflonum_p_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("extflonum?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("extflonum?", p, env); - scheme_add_global_constant("extflonum-available?", + scheme_addto_prim_instance("extflonum-available?", scheme_make_noncm_prim(extflonum_available_p, "extflonum-available?", 0, 0), env); - scheme_add_global_constant("extflvector", + scheme_addto_prim_instance("extflvector", scheme_make_prim_w_arity(extflvector, "extflvector", 0, -1), env); - scheme_add_global_constant("extflvector?", + scheme_addto_prim_instance("extflvector?", scheme_make_folding_prim(extflvector_p, "extflvector?", 1, 1, 1), env); - scheme_add_global_constant("make-extflvector", + scheme_addto_prim_instance("make-extflvector", scheme_make_immed_prim(make_extflvector, "make-extflvector", 1, 2), env); - GLOBAL_PRIM_W_ARITY("shared-extflvector", shared_extflvector, 0, -1, env); - GLOBAL_PRIM_W_ARITY("make-shared-extflvector", make_shared_extflvector, 1, 2, env); + ADD_PRIM_W_ARITY("shared-extflvector", shared_extflvector, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-extflvector", make_shared_extflvector, 1, 2, env); p = scheme_make_immed_prim(extflvector_length, "extflvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("extflvector-length", p, env); + scheme_addto_prim_instance("extflvector-length", p, env); p = scheme_make_immed_prim(scheme_checked_extflvector_ref, "extflvector-ref", 2, 2); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1096,7 +1117,7 @@ void scheme_init_extfl_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflvector-ref", p, env); + scheme_addto_prim_instance("extflvector-ref", p, env); p = scheme_make_immed_prim(scheme_checked_extflvector_set, "extflvector-set!", 3, 3); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1105,7 +1126,7 @@ void scheme_init_extfl_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_THIRD); - scheme_add_global_constant("extflvector-set!", p, env); + scheme_addto_prim_instance("extflvector-set!", p, env); p = scheme_make_folding_prim(integer_to_extfl, "->extfl", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1114,7 +1135,7 @@ void scheme_init_extfl_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("->extfl", p, env); + scheme_addto_prim_instance("->extfl", p, env); p = scheme_make_folding_prim(extfl_to_integer, "extfl->exact-integer", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -1122,7 +1143,7 @@ void scheme_init_extfl_number(Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("extfl->exact-integer", p, env); + scheme_addto_prim_instance("extfl->exact-integer", p, env); p = scheme_make_folding_prim(real_to_long_double_flonum, "real->extfl", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1131,7 +1152,7 @@ void scheme_init_extfl_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("real->extfl", p, env); + scheme_addto_prim_instance("real->extfl", p, env); p = scheme_make_folding_prim(extfl_to_exact, "extfl->exact", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1139,7 +1160,7 @@ void scheme_init_extfl_number(Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("extfl->exact", p, env); + scheme_addto_prim_instance("extfl->exact", p, env); p = scheme_make_folding_prim(extfl_to_inexact, "extfl->inexact", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1147,7 +1168,7 @@ void scheme_init_extfl_number(Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags); - scheme_add_global_constant("extfl->inexact", p, env); + scheme_addto_prim_instance("extfl->inexact", p, env); p = scheme_make_folding_prim(fx_to_extfl, "fx->extfl", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1156,7 +1177,7 @@ void scheme_init_extfl_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("fx->extfl", p, env); + scheme_addto_prim_instance("fx->extfl", p, env); p = scheme_make_folding_prim(extfl_to_fx, "extfl->fx", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -1166,7 +1187,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("extfl->fx", p, env); + scheme_addto_prim_instance("extfl->fx", p, env); p = scheme_make_folding_prim(extfl_truncate, "extfltruncate", 1, 1, 1); @@ -1177,7 +1198,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extfltruncate", p, env); + scheme_addto_prim_instance("extfltruncate", p, env); p = scheme_make_folding_prim(extfl_round, "extflround", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1187,7 +1208,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflround", p, env); + scheme_addto_prim_instance("extflround", p, env); p = scheme_make_folding_prim(extfl_ceiling, "extflceiling", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1197,7 +1218,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflceiling", p, env); + scheme_addto_prim_instance("extflceiling", p, env); p = scheme_make_folding_prim(extfl_floor, "extflfloor", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1207,7 +1228,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflfloor", p, env); + scheme_addto_prim_instance("extflfloor", p, env); p = scheme_make_folding_prim(extfl_sin, "extflsin", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1217,7 +1238,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflsin", p, env); + scheme_addto_prim_instance("extflsin", p, env); p = scheme_make_folding_prim(extfl_cos, "extflcos", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1227,7 +1248,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflcos", p, env); + scheme_addto_prim_instance("extflcos", p, env); p = scheme_make_folding_prim(extfl_tan, "extfltan", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1237,7 +1258,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extfltan", p, env); + scheme_addto_prim_instance("extfltan", p, env); p = scheme_make_folding_prim(extfl_asin, "extflasin", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1247,7 +1268,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflasin", p, env); + scheme_addto_prim_instance("extflasin", p, env); p = scheme_make_folding_prim(extfl_acos, "extflacos", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1257,7 +1278,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflacos", p, env); + scheme_addto_prim_instance("extflacos", p, env); p = scheme_make_folding_prim(extfl_atan, "extflatan", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1267,7 +1288,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflatan", p, env); + scheme_addto_prim_instance("extflatan", p, env); p = scheme_make_folding_prim(extfl_log, "extfllog", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1277,7 +1298,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extfllog", p, env); + scheme_addto_prim_instance("extfllog", p, env); p = scheme_make_folding_prim(extfl_exp, "extflexp", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1287,7 +1308,7 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflexp", p, env); + scheme_addto_prim_instance("extflexp", p, env); p = scheme_make_folding_prim(extfl_expt, "extflexpt", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -1297,10 +1318,10 @@ void scheme_init_extfl_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("extflexpt", p, env); + scheme_addto_prim_instance("extflexpt", p, env); } -void scheme_init_unsafe_number(Scheme_Env *env) +void scheme_init_unsafe_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -1309,7 +1330,7 @@ void scheme_init_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxand", p, env); + scheme_addto_prim_instance("unsafe-fxand", p, env); REGISTER_SO(scheme_unsafe_fxand_proc); scheme_unsafe_fxand_proc = p; @@ -1317,7 +1338,7 @@ void scheme_init_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxior", p, env); + scheme_addto_prim_instance("unsafe-fxior", p, env); REGISTER_SO(scheme_unsafe_fxior_proc); scheme_unsafe_fxior_proc = p; @@ -1325,7 +1346,7 @@ void scheme_init_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxxor", p, env); + scheme_addto_prim_instance("unsafe-fxxor", p, env); REGISTER_SO(scheme_unsafe_fxxor_proc); scheme_unsafe_fxxor_proc = p; @@ -1333,7 +1354,7 @@ void scheme_init_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxnot", p, env); + scheme_addto_prim_instance("unsafe-fxnot", p, env); REGISTER_SO(scheme_unsafe_fxnot_proc); scheme_unsafe_fxnot_proc = p; @@ -1341,13 +1362,13 @@ void scheme_init_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxlshift", p, env); + scheme_addto_prim_instance("unsafe-fxlshift", p, env); p = scheme_make_folding_prim(unsafe_fx_rshift, "unsafe-fxrshift", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxrshift", p, env); + scheme_addto_prim_instance("unsafe-fxrshift", p, env); REGISTER_SO(scheme_unsafe_fxrshift_proc); scheme_unsafe_fxrshift_proc = p; @@ -1359,14 +1380,14 @@ void scheme_init_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-fx->fl", p, env); + scheme_addto_prim_instance("unsafe-fx->fl", p, env); p = scheme_make_folding_prim(unsafe_fl_to_fx, "unsafe-fl->fx", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fl->fx", p, env); + scheme_addto_prim_instance("unsafe-fl->fx", p, env); p = scheme_make_immed_prim(fl_ref, "unsafe-f64vector-ref", 2, 2); @@ -1378,7 +1399,7 @@ void scheme_init_unsafe_number(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-f64vector-ref", p, env); + scheme_addto_prim_instance("unsafe-f64vector-ref", p, env); p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!", 3, 3); @@ -1388,14 +1409,14 @@ void scheme_init_unsafe_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_THIRD); - scheme_add_global_constant("unsafe-f64vector-set!", p, env); + scheme_addto_prim_instance("unsafe-f64vector-set!", p, env); p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-flvector-length", p, env); + scheme_addto_prim_instance("unsafe-flvector-length", p, env); p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref", 2, 2); @@ -1407,20 +1428,20 @@ void scheme_init_unsafe_number(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flvector-ref", p, env); + scheme_addto_prim_instance("unsafe-flvector-ref", p, env); p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_FLONUM_THIRD); - scheme_add_global_constant("unsafe-flvector-set!", p, env); + scheme_addto_prim_instance("unsafe-flvector-set!", p, env); p = scheme_make_immed_prim(unsafe_fxvector_length, "unsafe-fxvector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxvector-length", p, env); + scheme_addto_prim_instance("unsafe-fxvector-length", p, env); p = scheme_make_immed_prim(unsafe_fxvector_ref, "unsafe-fxvector-ref", 2, 2); @@ -1428,24 +1449,24 @@ void scheme_init_unsafe_number(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxvector-ref", p, env); + scheme_addto_prim_instance("unsafe-fxvector-ref", p, env); p = scheme_make_immed_prim(unsafe_fxvector_set, "unsafe-fxvector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-fxvector-set!", p, env); + scheme_addto_prim_instance("unsafe-fxvector-set!", p, env); p = scheme_make_immed_prim(s16_ref, "unsafe-s16vector-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-s16vector-ref", p, env); + scheme_addto_prim_instance("unsafe-s16vector-ref", p, env); p = scheme_make_immed_prim(s16_set, "unsafe-s16vector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-s16vector-set!", p, env); + scheme_addto_prim_instance("unsafe-s16vector-set!", p, env); p = scheme_make_immed_prim(u16_ref, "unsafe-u16vector-ref", 2, 2); @@ -1453,29 +1474,29 @@ void scheme_init_unsafe_number(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-u16vector-ref", p, env); + scheme_addto_prim_instance("unsafe-u16vector-ref", p, env); p = scheme_make_immed_prim(u16_set, "unsafe-u16vector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-u16vector-set!", p, env); + scheme_addto_prim_instance("unsafe-u16vector-set!", p, env); p = scheme_make_folding_prim(unsafe_make_flrectangular, "unsafe-make-flrectangular", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-make-flrectangular", p, env); + scheme_addto_prim_instance("unsafe-make-flrectangular", p, env); p = scheme_make_folding_prim(unsafe_flreal_part, "unsafe-flreal-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flreal-part", p, env); + scheme_addto_prim_instance("unsafe-flreal-part", p, env); p = scheme_make_folding_prim(unsafe_flimag_part, "unsafe-flimag-part", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flimag-part", p, env); + scheme_addto_prim_instance("unsafe-flimag-part", p, env); p = scheme_make_immed_prim(unsafe_flrandom, "unsafe-flrandom", 1, 1); if (scheme_can_inline_fp_op()) @@ -1484,10 +1505,10 @@ void scheme_init_unsafe_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM); - scheme_add_global_constant("unsafe-flrandom", p, env); + scheme_addto_prim_instance("unsafe-flrandom", p, env); } -void scheme_init_extfl_unsafe_number(Scheme_Env *env) +void scheme_init_extfl_unsafe_number(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -1500,7 +1521,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("unsafe-fx->extfl", p, env); + scheme_addto_prim_instance("unsafe-fx->extfl", p, env); p = scheme_make_folding_prim(unsafe_extfl_to_fx, "unsafe-extfl->fx", 1, 1, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(1)) @@ -1511,7 +1532,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-extfl->fx", p, env); + scheme_addto_prim_instance("unsafe-extfl->fx", p, env); p = scheme_make_immed_prim(unsafe_extflvector_length, "unsafe-extflvector-length", 1, 1); @@ -1522,7 +1543,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-extflvector-length", p, env); + scheme_addto_prim_instance("unsafe-extflvector-length", p, env); p = scheme_make_immed_prim(unsafe_extflvector_ref, "unsafe-extflvector-ref", 2, 2); @@ -1534,7 +1555,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("unsafe-extflvector-ref", p, env); + scheme_addto_prim_instance("unsafe-extflvector-ref", p, env); p = scheme_make_immed_prim(unsafe_extflvector_set, "unsafe-extflvector-set!", 3, 3); @@ -1544,7 +1565,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_THIRD); - scheme_add_global_constant("unsafe-extflvector-set!", p, env); + scheme_addto_prim_instance("unsafe-extflvector-set!", p, env); p = scheme_make_immed_prim(extfl_ref, "unsafe-f80vector-ref", 2, 2); @@ -1556,7 +1577,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_EXTFLONUM); - scheme_add_global_constant("unsafe-f80vector-ref", p, env); + scheme_addto_prim_instance("unsafe-f80vector-ref", p, env); p = scheme_make_immed_prim(extfl_set, "unsafe-f80vector-set!", 3, 3); @@ -1566,7 +1587,7 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_THIRD); - scheme_add_global_constant("unsafe-f80vector-set!", p, env); + scheme_addto_prim_instance("unsafe-f80vector-set!", p, env); } #ifdef _MSC_VER diff --git a/racket/src/racket/src/numcomp.c b/racket/src/racket/src/numcomp.c index 957854000e..9b6cd8f9eb 100644 --- a/racket/src/racket/src/numcomp.c +++ b/racket/src/racket/src/numcomp.c @@ -98,7 +98,7 @@ static Scheme_Object *unsafe_extfl_max (int argc, Scheme_Object *argv[]); #define zeroi scheme_exact_zero -void scheme_init_numcomp(Scheme_Env *env) +void scheme_init_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; @@ -106,96 +106,121 @@ void scheme_init_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_NUMBER - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("=", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("=", p, env); p = scheme_make_folding_prim(lt, "<", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("<", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("<", p, env); p = scheme_make_folding_prim(gt, ">", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant(">", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance(">", p, env); p = scheme_make_folding_prim(lt_eq, "<=", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("<=", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("<=", p, env); p = scheme_make_folding_prim(gt_eq, ">=", 2, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant(">=", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance(">=", p, env); p = scheme_make_folding_prim(zero_p, "zero?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_WANTS_NUMBER - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("zero?", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("zero?", p, env); p = scheme_make_folding_prim(positive_p, "positive?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("positive?", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("positive?", p, env); p = scheme_make_folding_prim(negative_p, "negative?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_WANTS_REAL - | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS); - scheme_add_global_constant("negative?", p, env); + | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("negative?", p, env); p = scheme_make_folding_prim(sch_max, "max", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS - | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("max", p, env); + | SCHEME_PRIM_PRODUCES_REAL + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("max", p, env); p = scheme_make_folding_prim(sch_min, "min", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_WANTS_REAL | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS - | SCHEME_PRIM_PRODUCES_REAL); - scheme_add_global_constant("min", p, env); + | SCHEME_PRIM_PRODUCES_REAL + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("min", p, env); } -void scheme_init_flfxnum_numcomp(Scheme_Env *env) +void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; p = scheme_make_folding_prim(fx_eq, "fx=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx=", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx=", p, env); p = scheme_make_folding_prim(fx_lt, "fx<", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx<", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx<", p, env); p = scheme_make_folding_prim(fx_gt, "fx>", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx>", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx>", p, env); p = scheme_make_folding_prim(fx_lt_eq, "fx<=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx<=", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx<=", p, env); p = scheme_make_folding_prim(fx_gt_eq, "fx>=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("fx>=", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("fx>=", p, env); p = scheme_make_folding_prim(fx_min, "fxmin", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -203,8 +228,9 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxmin", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxmin", p, env); p = scheme_make_folding_prim(fx_max, "fxmax", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -212,8 +238,9 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) else flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("fxmax", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("fxmax", p, env); p = scheme_make_folding_prim(fl_eq, "fl=", 2, 2, 1); @@ -223,7 +250,7 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl=", p, env); + scheme_addto_prim_instance("fl=", p, env); p = scheme_make_folding_prim(fl_lt, "fl<", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -232,7 +259,7 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl<", p, env); + scheme_addto_prim_instance("fl<", p, env); p = scheme_make_folding_prim(fl_gt, "fl>", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -241,7 +268,7 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl>", p, env); + scheme_addto_prim_instance("fl>", p, env); p = scheme_make_folding_prim(fl_lt_eq, "fl<=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -250,7 +277,7 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl<=", p, env); + scheme_addto_prim_instance("fl<=", p, env); p = scheme_make_folding_prim(fl_gt_eq, "fl>=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -259,7 +286,7 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("fl>=", p, env); + scheme_addto_prim_instance("fl>=", p, env); p = scheme_make_folding_prim(fl_min, "flmin", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -269,7 +296,7 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("flmin", p, env); + scheme_addto_prim_instance("flmin", p, env); p = scheme_make_folding_prim(fl_max, "flmax", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -279,10 +306,10 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("flmax", p, env); + scheme_addto_prim_instance("flmax", p, env); } -void scheme_init_extfl_numcomp(Scheme_Env *env) +void scheme_init_extfl_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -294,7 +321,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl=", p, env); + scheme_addto_prim_instance("extfl=", p, env); p = scheme_make_folding_prim(extfl_lt, "extfl<", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -303,7 +330,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl<", p, env); + scheme_addto_prim_instance("extfl<", p, env); p = scheme_make_folding_prim(extfl_gt, "extfl>", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -312,7 +339,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl>", p, env); + scheme_addto_prim_instance("extfl>", p, env); p = scheme_make_folding_prim(extfl_lt_eq, "extfl<=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -321,7 +348,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl<=", p, env); + scheme_addto_prim_instance("extfl<=", p, env); p = scheme_make_folding_prim(extfl_gt_eq, "extfl>=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -330,7 +357,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env) flags = SCHEME_PRIM_SOMETIMES_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extfl>=", p, env); + scheme_addto_prim_instance("extfl>=", p, env); p = scheme_make_folding_prim(extfl_min, "extflmin", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -340,7 +367,7 @@ void scheme_init_extfl_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extflmin", p, env); + scheme_addto_prim_instance("extflmin", p, env); p = scheme_make_folding_prim(extfl_max, "extflmax", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -350,10 +377,10 @@ void scheme_init_extfl_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("extflmax", p, env); + scheme_addto_prim_instance("extflmax", p, env); } -void scheme_init_unsafe_numcomp(Scheme_Env *env) +void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -362,35 +389,35 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) p = scheme_make_folding_prim(unsafe_fx_eq, "unsafe-fx=", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx=", p, env); + scheme_addto_prim_instance("unsafe-fx=", p, env); scheme_unsafe_fx_eq_proc = p; REGISTER_SO(scheme_unsafe_fx_lt_proc); p = scheme_make_folding_prim(unsafe_fx_lt, "unsafe-fx<", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx<", p, env); + scheme_addto_prim_instance("unsafe-fx<", p, env); scheme_unsafe_fx_lt_proc = p; REGISTER_SO(scheme_unsafe_fx_gt_proc); p = scheme_make_folding_prim(unsafe_fx_gt, "unsafe-fx>", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx>", p, env); + scheme_addto_prim_instance("unsafe-fx>", p, env); scheme_unsafe_fx_gt_proc = p; REGISTER_SO(scheme_unsafe_fx_lt_eq_proc); p = scheme_make_folding_prim(unsafe_fx_lt_eq, "unsafe-fx<=", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx<=", p, env); + scheme_addto_prim_instance("unsafe-fx<=", p, env); scheme_unsafe_fx_lt_eq_proc = p; REGISTER_SO(scheme_unsafe_fx_gt_eq_proc); p = scheme_make_folding_prim(unsafe_fx_gt_eq, "unsafe-fx>=", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); - scheme_add_global_constant("unsafe-fx>=", p, env); + scheme_addto_prim_instance("unsafe-fx>=", p, env); scheme_unsafe_fx_gt_eq_proc = p; REGISTER_SO(scheme_unsafe_fx_min_proc); @@ -398,7 +425,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxmin", p, env); + scheme_addto_prim_instance("unsafe-fxmin", p, env); scheme_unsafe_fx_min_proc = p; REGISTER_SO(scheme_unsafe_fx_max_proc); @@ -406,7 +433,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-fxmax", p, env); + scheme_addto_prim_instance("unsafe-fxmax", p, env); scheme_unsafe_fx_max_proc = p; p = scheme_make_folding_prim(unsafe_fl_eq, "unsafe-fl=", 2, 2, 1); @@ -417,7 +444,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl=", p, env); + scheme_addto_prim_instance("unsafe-fl=", p, env); p = scheme_make_folding_prim(unsafe_fl_lt, "unsafe-fl<", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -427,7 +454,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl<", p, env); + scheme_addto_prim_instance("unsafe-fl<", p, env); p = scheme_make_folding_prim(unsafe_fl_gt, "unsafe-fl>", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -437,7 +464,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl>", p, env); + scheme_addto_prim_instance("unsafe-fl>", p, env); p = scheme_make_folding_prim(unsafe_fl_lt_eq, "unsafe-fl<=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -447,7 +474,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl<=", p, env); + scheme_addto_prim_instance("unsafe-fl<=", p, env); p = scheme_make_folding_prim(unsafe_fl_gt_eq, "unsafe-fl>=", 2, 2, 1); if (scheme_can_inline_fp_comp()) @@ -457,7 +484,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-fl>=", p, env); + scheme_addto_prim_instance("unsafe-fl>=", p, env); p = scheme_make_folding_prim(unsafe_fl_min, "unsafe-flmin", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -468,7 +495,7 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-flmin", p, env); + scheme_addto_prim_instance("unsafe-flmin", p, env); p = scheme_make_folding_prim(unsafe_fl_max, "unsafe-flmax", 2, 2, 1); if (scheme_can_inline_fp_op()) @@ -479,10 +506,10 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FLONUM | SCHEME_PRIM_WANTS_FLONUM_BOTH); - scheme_add_global_constant("unsafe-flmax", p, env); + scheme_addto_prim_instance("unsafe-flmax", p, env); } -void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) +void scheme_init_extfl_unsafe_numcomp(Scheme_Startup_Env *env) { Scheme_Object *p; int flags; @@ -495,7 +522,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl=", p, env); + scheme_addto_prim_instance("unsafe-extfl=", p, env); p = scheme_make_folding_prim(unsafe_extfl_lt, "unsafe-extfl<", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -505,7 +532,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl<", p, env); + scheme_addto_prim_instance("unsafe-extfl<", p, env); p = scheme_make_folding_prim(unsafe_extfl_gt, "unsafe-extfl>", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -515,7 +542,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl>", p, env); + scheme_addto_prim_instance("unsafe-extfl>", p, env); p = scheme_make_folding_prim(unsafe_extfl_lt_eq, "unsafe-extfl<=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -525,7 +552,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl<=", p, env); + scheme_addto_prim_instance("unsafe-extfl<=", p, env); p = scheme_make_folding_prim(unsafe_extfl_gt_eq, "unsafe-extfl>=", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp())) @@ -535,7 +562,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extfl>=", p, env); + scheme_addto_prim_instance("unsafe-extfl>=", p, env); p = scheme_make_folding_prim(unsafe_extfl_min, "unsafe-extflmin", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -546,7 +573,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extflmin", p, env); + scheme_addto_prim_instance("unsafe-extflmin", p, env); p = scheme_make_folding_prim(unsafe_extfl_max, "unsafe-extflmax", 2, 2, 1); if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op())) @@ -557,7 +584,7 @@ void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_EXTFLONUM | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH); - scheme_add_global_constant("unsafe-extflmax", p, env); + scheme_addto_prim_instance("unsafe-extflmax", p, env); } /* Prototype needed for 3m conversion: */ diff --git a/racket/src/racket/src/numstr.c b/racket/src/racket/src/numstr.c index cb735abbb8..9001a275d0 100644 --- a/racket/src/racket/src/numstr.c +++ b/racket/src/racket/src/numstr.c @@ -96,7 +96,7 @@ SHARED_OK static Scheme_Object *num_limits[3]; #define zeroi scheme_exact_zero -void scheme_init_numstr(Scheme_Env *env) +void scheme_init_numstr(Scheme_Startup_Env *env) { REGISTER_SO(decimal_as_inexact_symbol); REGISTER_SO(decimal_as_exact_symbol); @@ -108,89 +108,89 @@ void scheme_init_numstr(Scheme_Env *env) read_symbol = scheme_intern_symbol("read"); number_or_false_symbol = scheme_intern_symbol("number-or-false"); - scheme_add_global_constant("number->string", + scheme_addto_prim_instance("number->string", scheme_make_immed_prim(number_to_string, "number->string", 1, 2), env); - scheme_add_global_constant("string->number", + scheme_addto_prim_instance("string->number", scheme_make_folding_prim(string_to_number, "string->number", 1, 4, 1), env); - scheme_add_global_constant("integer-bytes->integer", + scheme_addto_prim_instance("integer-bytes->integer", scheme_make_immed_prim(bytes_to_integer, "integer-bytes->integer", 2, 5), env); - scheme_add_global_constant("integer->integer-bytes", + scheme_addto_prim_instance("integer->integer-bytes", scheme_make_immed_prim(integer_to_bytes, "integer->integer-bytes", 3, 6), env); - scheme_add_global_constant("floating-point-bytes->real", + scheme_addto_prim_instance("floating-point-bytes->real", scheme_make_immed_prim(bytes_to_real, "floating-point-bytes->real", 1, 4), env); - scheme_add_global_constant("real->floating-point-bytes", + scheme_addto_prim_instance("real->floating-point-bytes", scheme_make_immed_prim(real_to_bytes, "real->floating-point-bytes", 2, 5), env); - scheme_add_global_constant("system-big-endian?", + scheme_addto_prim_instance("system-big-endian?", scheme_make_immed_prim(system_big_endian_p, "system-big-endian?", 0, 0), env); - scheme_add_global_constant("random", + scheme_addto_prim_instance("random", scheme_make_immed_prim(sch_random, "random", 0, 2), env); - scheme_add_global_constant("random-seed", + scheme_addto_prim_instance("random-seed", scheme_make_immed_prim(random_seed, "random-seed", 1, 1), env); - scheme_add_global_constant("make-pseudo-random-generator", + scheme_addto_prim_instance("make-pseudo-random-generator", scheme_make_immed_prim(make_pseudo_random_generator, "make-pseudo-random-generator", 0, 0), env); - scheme_add_global_constant("vector->pseudo-random-generator", + scheme_addto_prim_instance("vector->pseudo-random-generator", scheme_make_immed_prim(sch_pack, "vector->pseudo-random-generator", 1, 1), env); - scheme_add_global_constant("vector->pseudo-random-generator!", + scheme_addto_prim_instance("vector->pseudo-random-generator!", scheme_make_immed_prim(sch_pack_bang, "vector->pseudo-random-generator!", 2, 2), env); - scheme_add_global_constant("pseudo-random-generator->vector", + scheme_addto_prim_instance("pseudo-random-generator->vector", scheme_make_immed_prim(sch_unpack, "pseudo-random-generator->vector", 1, 1), env); - scheme_add_global_constant("pseudo-random-generator-vector?", + scheme_addto_prim_instance("pseudo-random-generator-vector?", scheme_make_immed_prim(sch_check_pack, "pseudo-random-generator-vector?", 1, 1), env); - scheme_add_global_constant("pseudo-random-generator?", + scheme_addto_prim_instance("pseudo-random-generator?", scheme_make_immed_prim(pseudo_random_generator_p, "pseudo-random-generator?", 1, 1), env); - scheme_add_global_constant("current-pseudo-random-generator", + scheme_addto_prim_instance("current-pseudo-random-generator", scheme_register_parameter(current_pseudo_random_generator, "current-pseudo-random-generator", MZCONFIG_RANDOM_STATE), env); - scheme_add_global_constant("current-evt-pseudo-random-generator", + scheme_addto_prim_instance("current-evt-pseudo-random-generator", scheme_register_parameter(current_sched_pseudo_random_generator, "current-evt-pseudo-random-generator", MZCONFIG_SCHEDULER_RANDOM_STATE), @@ -217,14 +217,14 @@ void scheme_init_numstr(Scheme_Env *env) #endif } -void scheme_init_extfl_numstr(Scheme_Env *env) +void scheme_init_extfl_numstr(Scheme_Startup_Env *env) { - scheme_add_global_constant("floating-point-bytes->extfl", + scheme_addto_prim_instance("floating-point-bytes->extfl", scheme_make_immed_prim(bytes_to_long_double, "floating-point-bytes->extfl", 1, 4), env); - scheme_add_global_constant("extfl->floating-point-bytes", + scheme_addto_prim_instance("extfl->floating-point-bytes", scheme_make_immed_prim(long_double_to_bytes, "extfl->floating-point-bytes", 1, 4), @@ -520,12 +520,29 @@ static Scheme_Object *do_CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl, #define DISALLOW_EXTFLONUM(special, other) \ if ((special && SCHEME_LONG_DBLP(special)) || (other && SCHEME_LONG_DBLP(other))) { \ if (report) \ - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, \ + return scheme_numr_err(complain, \ "cannot combine extflonum into complex number: %u", \ str, len); \ return scheme_false; \ } +/* + The scheme_read-number() parser could be simplified somewhat, + because it only has to work for: + + - `string->number` when called on a well-formed fixnum, bignum, + {double-,single-,ext}flonum; + + - reading S-expression literals from bytes, where numbers will be + in a canonical form (no `#`), but where symbols still must be + distinguished from numbers; and + + - printing symbols, to detect when they need to be escaped. + + For those purposes, it doesn't need to provide good error messages, + deal with non-default exactness, or handle non-base-10 + representations for non-real numbers. +*/ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, int is_float, int is_not_float, @@ -533,9 +550,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, int radix, int radix_set, Scheme_Object *complain, int *div_by_zero, - int test_only, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *indentation) + int test_only) { int i, has_decimal, must_parse, has_slash; int report, delta; @@ -557,8 +572,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (str[delta+1] != 'E' && str[delta+1] != 'e' && str[delta+1] != 'I' && str[delta+1] != 'i') { if (radix_set) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad radix specification: %u", + return scheme_numr_err(complain, + "bad radix specification in `%u`", str, len); else return scheme_false; @@ -567,8 +582,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else { if (is_float || is_not_float) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad exactness specification: %u", + return scheme_numr_err(complain, + "bad exactness specification in `%u`", str, len); else return scheme_false; @@ -602,8 +617,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, break; default: if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad `#' indicator `%c': %u", + return scheme_numr_err(complain, + "bad `#` indicator `%c` in `%u`", str[delta+1], str, len); return scheme_false; } @@ -617,8 +632,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (!(len - delta)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "no digits"); + return scheme_numr_err(complain, "no digits"); return scheme_false; } @@ -630,7 +644,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (!is_not_float) return special; if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", special); return scheme_false; @@ -675,7 +689,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (is_not_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", special); return scheme_false; @@ -684,9 +698,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, other = scheme_read_number(s2, len - delta - 6 + 4, is_float, is_not_float, 1, radix, 1, 0, - &dbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &dbz, test_only); if (SCHEME_CHAR_STRINGP(other)) return other; @@ -697,8 +709,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -718,7 +730,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (is_not_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", special); return scheme_false; @@ -771,16 +783,14 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (s2[i]) other = scheme_false; - else { + else other = scheme_read_number(s2, len - delta - 7, is_float, is_not_float, 1, radix, 1, 0, - &dbz, test_only, - stxsrc, line, col, pos, span, - indentation); - if (SCHEME_CHAR_STRINGP(other)) - return other; - } + &dbz, test_only); + + if (SCHEME_CHAR_STRINGP(other)) + return other; DISALLOW_EXTFLONUM(special, other); @@ -788,8 +798,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -835,8 +845,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, mzchar ch = str[i]; if (!ch) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "embedded null character: %u", + return scheme_numr_err(complain, + "embedded null character in `%u`", str, len); return scheme_false; } else if (isinexactmark(ch) && ((radix <= 10) || !isbaseNdigit(radix, ch))) { @@ -846,8 +856,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if ((ch == '+') || (ch == '-')) { if ((has_sign > delta) || ((has_sign == delta) && (i == delta+1))) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "too many signs: %u", + return scheme_numr_err(complain, + "too many signs in `%u`", str, len); return scheme_false; } @@ -855,15 +865,15 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (((ch == 'I') || (ch == 'i')) && (has_sign >= delta)) { if (has_at) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot mix `@' and `i': %u", + return scheme_numr_err(complain, + "cannot mix `@` and `i` in `%u`", str, len); return scheme_false; } if (i + 1 < len) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "`i' must be at the end: %u", + return scheme_numr_err(complain, + "`i' must be at the end in `%u`", str, len); return scheme_false; } @@ -871,15 +881,15 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (ch == '@') { if (has_at) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "too many `@'s: %u", + return scheme_numr_err(complain, + "too many `@`s in `%u`", str, len); return scheme_false; } if (i == delta) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "`@' cannot be at start: %u", + return scheme_numr_err(complain, + "`@` cannot be at start in `%u`", str, len); return scheme_false; } @@ -912,9 +922,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, n1 = scheme_read_number(first, has_sign - delta, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, - &fdbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &fdbz, test_only); if (SCHEME_CHAR_STRINGP(n1)) return n1; } else @@ -933,9 +941,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, n2 = scheme_read_number(second, has_i - has_sign, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, - &sdbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &sdbz, test_only); if (SCHEME_CHAR_STRINGP(n2)) return n2; } else if (str[has_sign] == '-') @@ -958,8 +964,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -1002,11 +1008,10 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, n2 = scheme_read_number(second, len - has_at - 1, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, - &fdbz, test_only, - stxsrc, line, col, pos, span, - indentation); + &fdbz, test_only); + if (SCHEME_CHAR_STRINGP(n2)) - return n2; + return n2; if (!fdbz) { if (SCHEME_FALSEP(n2)) @@ -1018,9 +1023,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, is_float, is_not_float, decimal_means_float, radix, 1, complain, div_by_zero, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); if (!SCHEME_LONG_DBLP(n2)) { n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */ @@ -1037,9 +1040,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, is_float, is_not_float, decimal_means_float, radix, 1, next_complain, &sdbz, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); if (SCHEME_CHAR_STRINGP(n1)) return n1; @@ -1061,8 +1062,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero in %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); return scheme_false; } @@ -1101,16 +1102,16 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (ch == '.') { if (has_decimal) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "multiple decimal points: %u", + return scheme_numr_err(complain, + "multiple decimal points in `%u`", str, len); return scheme_false; } if (has_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "decimal points and fractions " - "cannot be mixed: %u", + "cannot be mixed in `%u`", str, len); return scheme_false; } @@ -1119,8 +1120,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, && ((radix <= 10) || !isbaseNdigit(radix, ch))) { if (i == delta) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot begin with `%c' in %u", + return scheme_numr_err(complain, + "cannot begin with `%c` in `%u`", ch, str, len); return scheme_false; } @@ -1129,23 +1130,23 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (ch == '/') { if (i == delta) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot have slash at start: %u", + return scheme_numr_err(complain, + "cannot have slash at start in `%u`", str, len); return scheme_false; } if (has_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "multiple slashes: %u", + return scheme_numr_err(complain, + "multiple slashes in `%u`", str, len); return scheme_false; } if (has_decimal) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "decimal points and fractions " - "cannot be mixed: %u", + "cannot be mixed in `%u`", str, len); return scheme_false; } @@ -1155,16 +1156,16 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if ((ch == '-') || (ch == '+')) { if (has_slash || has_decimal || has_hash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced sign: %u", + return scheme_numr_err(complain, + "misplaced sign in `%u`", str, len); return scheme_false; } } else if (ch == '#') { if (!saw_digit_since_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced hash: %u", + return scheme_numr_err(complain, + "misplaced hash in `%u`", str, len); return scheme_false; } @@ -1173,15 +1174,15 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (!isAdigit(ch) && !((radix > 10) && isbaseNdigit(radix, ch))) { if (has_decimal) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad decimal number: %u", + return scheme_numr_err(complain, + "bad decimal number in `%u`", str, len); return scheme_false; } if (has_hash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced hash: %u", + return scheme_numr_err(complain, + "misplaced hash in `%u`", str, len); return scheme_false; } @@ -1192,8 +1193,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, saw_nonzero_digit = 1; if (has_hash_since_slash) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "misplaced hash: %u", + return scheme_numr_err(complain, + "misplaced hash in `%u`", str, len); return scheme_false; } @@ -1243,8 +1244,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (has_expt && !(str[has_expt + 1])) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "no digits after \"%c\": %u", + return scheme_numr_err(complain, + "no digits after `%c` in `%u`", str[has_expt], str, len); return scheme_false; } @@ -1282,8 +1283,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if ((ptr XFORM_OK_MINUS ffl_buf) < (len - delta)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad decimal number %u", + return scheme_numr_err(complain, + "bad decimal number `%u`", str, len); return scheme_false; } @@ -1291,8 +1292,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (is_long_double && is_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot convert extflonum to inexact: %u", + return scheme_numr_err(complain, + "cannot convert extflonum to inexact in `%u`", str, len); return scheme_false; } @@ -1352,8 +1353,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (!str[has_expt + 1]) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "no digits after \"%c\": %u", + return scheme_numr_err(complain, + "no digits after `%c` in `%u`", str[has_expt], str, len); return scheme_false; } @@ -1372,8 +1373,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, exponent = scheme_read_bignum(substr, 0, radix); if (SCHEME_FALSEP(exponent)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad exponent: %u", + return scheme_numr_err(complain, + "bad exponent in `%u`", str, len); return scheme_false; } @@ -1396,9 +1397,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, is_float, is_not_float, 1, radix, 1, next_complain, &dbz, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); if (SCHEME_CHAR_STRINGP(mantissa)) return mantissa; @@ -1408,13 +1407,13 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (div_by_zero) *div_by_zero = 1; if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); } if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad number: %u", + return scheme_numr_err(complain, + "bad number `%u`", str, len); return scheme_false; } @@ -1467,16 +1466,16 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, || !dcp || (dcp == 1 && !(isAdigit(digits[0]) || ((radix > 10) && isbaseNdigit(radix, digits[0]))))) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad decimal number %u", + return scheme_numr_err(complain, + "bad decimal number `%u`", str, len); return scheme_false; } if (is_long_double && is_float) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot convert extflonum to inexact: %u", + return scheme_numr_err(complain, + "cannot convert extflonum to inexact in `%u`", str, len); return scheme_false; } @@ -1562,8 +1561,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else { if (is_long_double) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "cannot convert extflonum to exact: %u", + return scheme_numr_err(complain, + "cannot convert extflonum to exact in `%u`", str, len); return scheme_false; } @@ -1600,13 +1599,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, 0, is_not_float, 1, radix, 1, next_complain, div_by_zero, - test_only, - stxsrc, line, col, pos, span, - indentation); - + test_only); if (SCHEME_CHAR_STRINGP(n1)) return n1; - if (SAME_OBJ(n1, scheme_false)) return scheme_false; @@ -1629,21 +1624,18 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, 0, is_not_float, 1, radix, 1, next_complain, div_by_zero, - test_only, - stxsrc, line, col, pos, span, - indentation); + test_only); } if (SCHEME_CHAR_STRINGP(n2)) return n2; - if (SAME_OBJ(n2, scheme_false)) return scheme_false; if (SCHEME_EXACT_REALP(n2) && scheme_is_zero(n2)) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "division by zero: %u", + return scheme_numr_err(complain, + "division by zero in `%u`", str, len); if (div_by_zero) *div_by_zero = 1; @@ -1661,7 +1653,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (SCHEME_FLOATP(n1)) { if (!scheme_check_double(NULL, SCHEME_FLOAT_VAL(n1), NULL)) { if (complain) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, + return scheme_numr_err(complain, "no exact representation for %V", n1); return scheme_false; @@ -1677,8 +1669,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, o = scheme_read_bignum(str, delta, radix); if (SAME_OBJ(o, scheme_false)) { if (report) - return scheme_numr_err(complain, stxsrc, line, col, pos, span, indentation, - "bad number: %u", + return scheme_numr_err(complain, + "bad number `%u`", str, len); } else if (is_float) { /* Special case: "#i-0" => -0. */ @@ -1802,8 +1794,7 @@ string_to_number (int argc, Scheme_Object *argv[]) ESCAPED_BEFORE_HERE; } } else { - decimal_inexact = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), - MZCONFIG_READ_DECIMAL_INEXACT)); + decimal_inexact = 1; } mzstr = SCHEME_CHAR_STR_VAL(argv[0]); @@ -1812,8 +1803,7 @@ string_to_number (int argc, Scheme_Object *argv[]) v = scheme_read_number(mzstr, len, 0, 0, decimal_inexact, radix, 0, reader_mode, &div_by_zero, - 0, NULL, 0, 0, 0, 0, - NULL); + 0); if (!reader_mode && SCHEME_LONG_DBLP(v)) return scheme_false; diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 6837217418..d2df15af60 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -37,10 +37,10 @@ #define OPT_LIMIT_FUNCTION_RESIZE 0 #define OPT_BRANCH_ADDS_NO_SIZE 1 #define OPT_DELAY_GROUP_PROPAGATE 0 -#define OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(size_override) (size_override) +#define OPT_PRE_OPTIMIZE_FOR_CROSS_LINKLET(size_override) (size_override) #define MAX_PROC_INLINE_SIZE 256 -#define CROSS_MODULE_INLINE_SIZE 8 +#define CROSS_LINKLET_INLINE_SIZE 8 /* Various kinds of fuel ensure that the compiler doesn't go into a loop @@ -48,6 +48,23 @@ #define INITIAL_INLINING_FUEL 32 #define INITIAL_FLATTENING_FUEL 16 + +#define SCHEME_LAMBDA_FRAME 1 + +typedef struct Cross_Linklet_Info +{ + /* Must be all pointers; allocated with scheme_malloc() */ + Scheme_Object *get_import; /* NULL or (key -> linklet (vector key ...)) */ + Scheme_Hash_Tree *import_keys; /* import-position -> key */ + Scheme_Hash_Tree *rev_import_keys; /* key -> import-position */ + Scheme_Hash_Tree *linklets; /* key -> linklet-or-instance */ + Scheme_Hash_Tree *import_next_keys; /* key -> (vector key ...) */ + Scheme_Hash_Tree *inline_variants; /* key -> symbol -> value */ + Scheme_Hash_Tree *import_syms; /* import-position -> ((symbol -> variable-position) + . + (variable-position -> symbol)) */ + int used_import_shape; +} Cross_Linklet_Info; + /* Clasification for predicates. Each one implies the smaller. */ #define RLV_IS_RELEVANT 1 /* The predicate is remembered by the optimizer */ @@ -60,14 +77,14 @@ struct Optimize_Info MZTAG_IF_REQUIRED short flags; struct Optimize_Info *next; - int original_frame, new_frame; - Scheme_Object *consts; - Comp_Prefix *cp; + struct Scheme_Linklet *linklet; int init_kclock; - /* Compilation context, used for unresolving for cross-module inlining: */ - Scheme_Env *env; - Scheme_Object *insp; + /* For cross-linklet inlining: */ + Cross_Linklet_Info *cross; + + /* Track which imports are still used after optimization */ + Scheme_Hash_Tree **imports_used; /* import position -> variable position -> true */ /* Propagated up and down the chain: */ int size; @@ -87,7 +104,7 @@ struct Optimize_Info int sclock; /* virtual clock that ticks when space consumption is potentially observed */ int psize; short inline_fuel, flatten_fuel; - char letrec_not_twice, enforce_const, use_psize, has_nonleaf; + char letrec_not_twice, enforce_const, unsafe_mode, use_psize, has_nonleaf; Scheme_Hash_Table *top_level_consts; int maybe_values_argument; /* triggers an approximation for clock increments */ @@ -116,6 +133,8 @@ typedef struct Optimize_Info_Sequence { int init_flatten_fuel, min_flatten_fuel; } Optimize_Info_Sequence; +static Scheme_Object *optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context); + static int get_rator_flags(Scheme_Object *rator, int num_args, Optimize_Info *info); Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, int argc); static void merge_lambda_arg_types(Scheme_Lambda *lam1, Scheme_Lambda *lam2); @@ -150,7 +169,9 @@ static int env_uses_toplevel(Optimize_Info *frame); static Scheme_IR_Local *clone_variable(Scheme_IR_Local *var); static void increment_use_count(Scheme_IR_Local *var, int as_rator); -static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags); +static Optimize_Info *optimize_info_create(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode); +static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int flags); static void optimize_info_done(Optimize_Info *info, Optimize_Info *parent); static void register_transitive_uses(Scheme_IR_Local *var, Optimize_Info *info); @@ -168,6 +189,12 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in static Scheme_Object *optimize_clone(int single_use, Scheme_Object *obj, Optimize_Info *info, Scheme_Hash_Tree *var_map, int as_rator); +static Scheme_Object *get_import_shape(Optimize_Info *info, Scheme_IR_Toplevel *var); +static Scheme_Object *get_import_inline(Optimize_Info *info, Scheme_IR_Toplevel *var, int argc, int case_ok); +static void register_import_used(Optimize_Info *info, Scheme_IR_Toplevel *expr); +static void record_optimize_shapes(Optimize_Info *info, Scheme_Linklet *linklet, Scheme_Object **_import_keys); +static Scheme_Object *get_value_shape(Scheme_Object *v, int imprecise); + XFORM_NONGCING static int relevant_predicate(Scheme_Object *pred); XFORM_NONGCING static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2); XFORM_NONGCING static int predicate_implies_not(Scheme_Object *pred1, Scheme_Object *pred2); @@ -250,20 +277,20 @@ char *scheme_optimize_context_to_string(Scheme_Object *context) /* Convert a context to a string that is suitable for use in logging */ { if (context) { - Scheme_Object *mod, *func; + Scheme_Object *linklet, *func; const char *ctx, *prefix, *mctx, *mprefix; char *all; int clen, plen, mclen, mplen, len; if (SCHEME_PAIRP(context)) { func = SCHEME_CAR(context); - mod = SCHEME_CDR(context); - } else if (SAME_TYPE(SCHEME_TYPE(context), scheme_module_type)) { + linklet = SCHEME_CDR(context); + } else if (SAME_TYPE(SCHEME_TYPE(context), scheme_linklet_type)) { func = scheme_false; - mod = context; + linklet = context; } else { func = context; - mod = scheme_false; + linklet = scheme_false; } if (SAME_TYPE(SCHEME_TYPE(func), scheme_ir_lambda_type)) { @@ -299,8 +326,8 @@ char *scheme_optimize_context_to_string(Scheme_Object *context) prefix = ""; } - if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) { - mctx = scheme_display_to_string(((Scheme_Module *)mod)->modsrc, NULL); + if (SAME_TYPE(SCHEME_TYPE(linklet), scheme_linklet_type)) { + mctx = scheme_display_to_string(((Scheme_Linklet *)linklet)->name, NULL); mprefix = " in module: "; } else { mctx = ""; @@ -369,25 +396,35 @@ int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args return 0; } +static Scheme_Object *get_defn_shape(Optimize_Info *info, Scheme_IR_Toplevel *var) +{ + Scheme_Object *v; + + if (info->top_level_consts && (var->instance_pos == -1)) { + v = scheme_hash_get(info->top_level_consts, scheme_make_integer(var->variable_pos)); + if (v) return v; + + v = scheme_hash_get(info->top_level_consts, scheme_false); + if (v && scheme_hash_get((Scheme_Hash_Table *)v, scheme_make_integer(var->variable_pos))) + return scheme_fixed_key; + } + + return NULL; +} + static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info, int prop_ok) /* Determines whether `rator` is known to be a struct accessor, etc. */ { Scheme_Object *c; - if (info - && (info->top_level_consts || info->cp->inline_variants) - && SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) { - int pos; - pos = SCHEME_TOPLEVEL_POS(rator); - c = NULL; - if (info->top_level_consts) - c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - if (!c && info->cp->inline_variants) - c = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos)); + if (info && SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) { + c = get_defn_shape(info, (Scheme_IR_Toplevel *)rator); + if (!c) + c = get_import_shape(info, (Scheme_IR_Toplevel *)rator); + if (c && (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type) - || (prop_ok && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)))) { + || (prop_ok && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)))) return c; - } } return NULL; @@ -439,10 +476,10 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, /* Checks whether the bytecode `o` returns `vals` values with no side-effects and without pushing and using continuation marks. A -1 for `vals` means that any return count is ok. - Also used with fully resolved expression by `module' to check + Also used with fully resolved expression by `linklet` to check for "functional" bodies, in which case `flags` includes `OMITTABLE_RESOLVED`. - The `opt_info` argument is used only to access module-level + The `opt_info` argument is used only to access linklet-level information, not local bindings. If `warn_info` is supplied, complain when a mismatch is detected. We rely on the letrec-check pass to avoid omitting early references @@ -475,9 +512,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, || (vtype == scheme_ir_lambda_type) || (vtype == scheme_inline_variant_type) || (vtype == scheme_case_lambda_sequence_type) - || (vtype == scheme_quote_syntax_type) - || (vtype == scheme_varref_form_type) - || (vtype == scheme_ir_quote_syntax_type)) { + || (vtype == scheme_varref_form_type)) { note_match(1, vals, warn_info); return ((vals == 1) || (vals < 0)); } @@ -496,9 +531,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (!(flags & OMITTABLE_KEEP_VARS) - && ((SCHEME_TOPLEVEL_FLAGS(o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_READY)) + && ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_READY)) return 1; - else if ((SCHEME_TOPLEVEL_FLAGS(o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) + else if ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)o) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) return 1; else return 0; @@ -662,9 +697,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, | CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK), &auto_e_depth, NULL, NULL, - (opt_info ? opt_info->top_level_consts : NULL), - ((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL), - NULL, NULL, 0, NULL, NULL, NULL, + opt_info, + NULL, NULL, 0, NULL, NULL, 5); if (auto_e) { if (scheme_omittable_expr(auto_e, 1, fuel - 1, flags, opt_info, warn_info)) @@ -678,9 +712,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, (((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0) | CHECK_STRUCT_TYPE_ALWAYS_SUCCEED), NULL, - (opt_info ? opt_info->top_level_consts : NULL), - ((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL), - NULL, NULL, 0, NULL, NULL, + opt_info, + NULL, NULL, 0, NULL, 5)) return 1; } @@ -1206,6 +1239,8 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int && is_local_ref(app->args[2], delta+1, 1, vars) && is_local_ref(app->args[3], delta+2, 1, vars)) { int i, num_gets = 0, num_sets = 0, normal_ops = 1; + int setter_fields = 0, normal_sets = 1; + int prev_setter_pos = app->num_args; /* bigger than any setter index can be */ for (i = app->num_args; i > 3; i--) { if (is_local_ref(app->args[i], delta, 5, vars)) { normal_ops = 0; @@ -1218,11 +1253,22 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int delta2, _stinfo->field_count, vars)) break; if (SAME_OBJ(app3->args[0], scheme_make_struct_field_mutator_proc)) { + int pos = SCHEME_INT_VAL(app3->args[2]); if (num_gets) { - /* Since we're alking backwards, it's not normal to hit a mutator + /* Since we're walking backwards, it's not normal to hit a mutator after (i.e., before in argument order) a selector */ normal_ops = 0; } + if (normal_sets) { + if (pos >= prev_setter_pos) { + /* setters are not in the usual order; zero out the mask */ + normal_sets = 0; + setter_fields = 0; + } else if (pos < (31 - STRUCT_PROC_SHAPE_SHIFT)) { + setter_fields |= (1 << pos); + prev_setter_pos = pos; + } + } num_sets++; } else { if (SCHEME_INT_VAL(app3->args[2]) != (i - 4)) { @@ -1255,6 +1301,7 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int _stinfo->indexed_ops = 1; _stinfo->num_gets = num_gets; _stinfo->num_sets = num_sets; + _stinfo->setter_fields = setter_fields; return 1; } } @@ -1288,26 +1335,22 @@ typedef int (*Ok_Value_Callback)(void *data, Scheme_Object *v, int mode); #define OK_CONSTANT_VALUE 5 static int is_ok_value(Ok_Value_Callback ok_value, void *data, - Scheme_Object *arg, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Scheme_Object *arg, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) + Scheme_Linklet *enclosing_linklet) /* Does `arg` produce a value that satisfies `ok_value`? */ { int pos; Scheme_Object *v; if (SAME_TYPE(SCHEME_TYPE(arg), scheme_ir_toplevel_type)) { - pos = SCHEME_TOPLEVEL_POS(arg); - if (top_level_consts || inline_variants) { + if (info) { /* This is optimize mode */ - v = NULL; - if (top_level_consts) - v = scheme_hash_get(top_level_consts, scheme_make_integer(pos)); - if (!v && inline_variants) - v = scheme_hash_get(inline_variants, scheme_make_integer(pos)); + v = get_defn_shape(info, (Scheme_IR_Toplevel *)arg); + if (!v) + v = get_import_shape(info, (Scheme_IR_Toplevel *)arg); if (v) return ok_value(data, v, OK_CONSTANT_SHAPE); } @@ -1322,22 +1365,23 @@ static int is_ok_value(Ok_Value_Callback ok_value, void *data, b = (Scheme_Bucket *)toplevels->a[pos]; if (b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) return ok_value(data, b->val, OK_CONSTANT_VALUE); - } - if (symbols) { - /* This is module-export mode; conceptually, this code belongs in - setup_accessible_table() */ - Scheme_Object *name; - name = symbols[pos]; - if (SCHEME_SYMBOLP(name)) { - v = scheme_hash_get(symbol_table, name); + } else if (enclosing_linklet) { + /* This is linklet-export mode; conceptually, this code belongs in + linklet_setup_constants() */ + if (pos > enclosing_linklet->num_total_imports) { + Scheme_Object *name; + pos -= (enclosing_linklet->num_total_imports + 1); + name = SCHEME_VEC_ELS(enclosing_linklet->defns)[pos]; + v = scheme_hash_get(enclosing_linklet->constants, name); if (v) return ok_value(data, v, OK_CONSTANT_VARIANT); - } else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_variable_type)) { - if (((Module_Variable *)name)->shape) - return ok_value(data, ((Module_Variable *)name)->shape, OK_CONSTANT_ENCODED_SHAPE); + } else if (pos >= 1 + && (pos <= enclosing_linklet->num_total_imports) + && enclosing_linklet->import_shapes) { + pos -= 1; + return ok_value(data, SCHEME_VEC_ELS(enclosing_linklet->import_shapes)[pos], OK_CONSTANT_ENCODED_SHAPE); } - } - if (top_level_table) { + } else if (top_level_table) { /* This is validate mode; conceptually, this code belongs in define_values_validate() */ v = scheme_hash_get(top_level_table, scheme_make_integer(pos)); @@ -1346,7 +1390,7 @@ static int is_ok_value(Ok_Value_Callback ok_value, void *data, } } } - + return 0; } @@ -1399,21 +1443,20 @@ static int ok_constant_super_value(void *data, Scheme_Object *v, int mode) return 0; } -static int is_constant_super(Scheme_Object *arg, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, +static int is_constant_super(Scheme_Object *arg, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, Scheme_Object **_parent_identity) /* Does `arg` produce another structure type (which can serve as a supertype)? */ { return is_ok_value(ok_constant_super_value, _parent_identity, arg, - top_level_consts, - inline_variants, top_level_table, + info, + top_level_table, runstack, rs_delta, - symbols, symbol_table); + enclosing_linklet); } static int ok_constant_property_with_guard(void *data, Scheme_Object *v, int mode) @@ -1449,28 +1492,26 @@ static int ok_constant_property_with_guard(void *data, Scheme_Object *v, int mod return (k == STRUCT_PROP_PROC_SHAPE_PROP); } -static int is_struct_type_property_without_guard(Scheme_Object *arg, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, +static int is_struct_type_property_without_guard(Scheme_Object *arg, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) + Scheme_Linklet *enclosing_linklet) /* Does `arg` produce a structure type property that has no guard (so that any value is ok)? */ { return is_ok_value(ok_constant_property_with_guard, NULL, arg, - top_level_consts, - inline_variants, top_level_table, + info, + top_level_table, runstack, rs_delta, - symbols, symbol_table); + enclosing_linklet); } static int is_simple_property_list(Scheme_Object *a, int resolved, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, int just_for_authentic, int *_authentic) /* Does `a` produce a property list that always lets `make-struct-type` succeed? */ { @@ -1515,10 +1556,10 @@ static int is_simple_property_list(Scheme_Object *a, int resolved, *_authentic = 1; if (!just_for_authentic) { if (is_struct_type_property_without_guard(a3->rand1, - top_level_consts, - inline_variants, top_level_table, + info, + top_level_table, runstack, rs_delta, - symbols, symbol_table)) { + enclosing_linklet)) { if (!scheme_omittable_expr(a3->rand2, 1, 3, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)) return 0; } else @@ -1534,15 +1575,14 @@ static int is_simple_property_list(Scheme_Object *a, int resolved, return 1; } -Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int flags, +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int flags, GC_CAN_IGNORE int *_auto_e_depth, Simple_Struct_Type_Info *_stinfo, Scheme_Object **_parent_identity, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, Scheme_Object **_name, int fuel) /* Checks whether it's a `make-struct-type' call --- that, if `flags` includes @@ -1571,9 +1611,9 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in *_parent_identity = scheme_null; if (!SCHEME_FALSEP(app->args[2])) super_count_plus_one = is_constant_super(app->args[2], - top_level_consts, inline_variants, top_level_table, runstack, + info, top_level_table, runstack, rs_delta + app->num_args, - symbols, symbol_table, _parent_identity); + enclosing_linklet, _parent_identity); else super_count_plus_one = 0; @@ -1600,10 +1640,10 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in && scheme_omittable_expr(app->args[6], 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)) || ((flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED) && is_simple_property_list(app->args[6], resolved, - top_level_consts, inline_variants, + info, top_level_table, runstack, rs_delta, - symbols, symbol_table, + enclosing_linklet, 0, NULL))) && ((app->num_args < 7) /* inspector: */ @@ -1647,10 +1687,10 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in _stinfo->authentic = 0; if ((app->num_args > 6) && is_simple_property_list(app->args[6], resolved, - top_level_consts, inline_variants, + info, top_level_table, runstack, rs_delta, - symbols, symbol_table, + enclosing_linklet, 1, &authentic)) _stinfo->authentic = authentic; _stinfo->num_gets = 1; @@ -1675,9 +1715,9 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in if (!_stinfo) _stinfo = &stinfo; auto_e = scheme_is_simple_make_struct_type(lv->value, 5, flags, _auto_e_depth, _stinfo, _parent_identity, - top_level_consts, inline_variants, top_level_table, + info, top_level_table, runstack, rs_delta, - symbols, symbol_table, + enclosing_linklet, _name, fuel-1); if (auto_e) { @@ -1707,9 +1747,9 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in if (!_stinfo) _stinfo = &stinfo; auto_e = scheme_is_simple_make_struct_type(e2, 5, flags, _auto_e_depth, _stinfo, _parent_identity, - top_level_consts, inline_variants, top_level_table, + info, top_level_table, runstack, rs_delta + lvd->count, - symbols, symbol_table, + enclosing_linklet, _name, fuel-1); if (auto_e) { @@ -1732,11 +1772,10 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, in int scheme_is_simple_make_struct_type_property(Scheme_Object *e, int vals, int flags, int *_has_guard, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, int fuel) /* Reports whether `app` is a call to `make-struct-type-property` to produce a propert with no guard. */ @@ -1800,10 +1839,30 @@ intptr_t scheme_get_struct_proc_shape(int k, Simple_Struct_Type_Info *stinfo) return (STRUCT_PROC_SHAPE_GETTER | (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0) | ((stinfo->super_field_count + (k - 3)) << STRUCT_PROC_SHAPE_SHIFT)); - } else + } else { + int idx = (k - 3 - stinfo->num_gets), setter_fields = stinfo->setter_fields, pos = 0; + + /* setter_fields is a bitmap for first (31-STRUCT_PROC_SHAPE_SHIFT) fields that may have a setter */ + while ((idx > 0) || !(setter_fields & 1)) { + if (setter_fields & 1) { + idx--; + } + setter_fields = setter_fields >> 1; + pos++; + if (!setter_fields) break; + } + + if (!idx && (setter_fields & 1)) + pos += stinfo->super_field_count + 1; + else { + /* represent "unknown" by zero */ + pos = 0; + } + return (STRUCT_PROC_SHAPE_SETTER | (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0) - | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT)); + | (pos << STRUCT_PROC_SHAPE_SHIFT)); + } } } @@ -1851,7 +1910,7 @@ Scheme_Object *scheme_make_struct_property_proc_shape(intptr_t k) XFORM_NONGCING static int is_struct_identity_subtype(Scheme_Object *sub, Scheme_Object *sup) { - /* A structure identity is a list of symbols, but the symbols are + /* A structure identity is typically a list of symbols, but the symbols are just for debugging. Instead, the address of each pair forming the list represents an identiity. */ while (SCHEME_PAIRP(sub)) { @@ -2045,8 +2104,6 @@ static int movable_expression(Scheme_Object *expr, Optimize_Info *info, switch (SCHEME_TYPE(expr)) { case scheme_toplevel_type: return ((SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED); - case scheme_ir_quote_syntax_type: - return 1; case scheme_ir_local_type: { /* Ok if not mutable */ @@ -2170,33 +2227,33 @@ XFORM_NONGCING static int small_inline_number(Scheme_Object *o) #define STR_INLINE_LIMIT 256 -int scheme_ir_duplicate_ok(Scheme_Object *fb, int cross_module) +int scheme_ir_duplicate_ok(Scheme_Object *fb, int cross_linklet) /* Is the constant a value that we can "copy" in the code? */ { return (SCHEME_VOIDP(fb) || SAME_OBJ(fb, scheme_true) || SCHEME_FALSEP(fb) || (SCHEME_SYMBOLP(fb) - && (!cross_module || (!SCHEME_SYM_WEIRDP(fb) + && (!cross_linklet || (!SCHEME_SYM_WEIRDP(fb) && (SCHEME_SYM_LEN(fb) < STR_INLINE_LIMIT)))) || (SCHEME_KEYWORDP(fb) - && (!cross_module || (SCHEME_KEYWORD_LEN(fb) < STR_INLINE_LIMIT))) + && (!cross_linklet || (SCHEME_KEYWORD_LEN(fb) < STR_INLINE_LIMIT))) || SCHEME_EOFP(fb) || SCHEME_INTP(fb) || SCHEME_NULLP(fb) - || (!cross_module && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_toplevel_type)) - || (!cross_module && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_local_type)) + || (!cross_linklet && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_toplevel_type)) + || (!cross_linklet && SAME_TYPE(SCHEME_TYPE(fb), scheme_ir_local_type)) || SCHEME_PRIMP(fb) /* Values that are hashed by the printer and/or interned on read to avoid duplication: */ || SCHEME_CHARP(fb) || (SCHEME_CHAR_STRINGP(fb) - && (!cross_module || (SCHEME_CHAR_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) + && (!cross_linklet || (SCHEME_CHAR_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) || (SCHEME_BYTE_STRINGP(fb) - && (!cross_module || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) + && (!cross_linklet || (SCHEME_BYTE_STRLEN_VAL(fb) < STR_INLINE_LIMIT))) || SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type) || (SCHEME_NUMBERP(fb) - && (!cross_module || small_inline_number(fb))) + && (!cross_linklet || small_inline_number(fb))) || SAME_TYPE(SCHEME_TYPE(fb), scheme_ctype_type)); } @@ -2357,7 +2414,6 @@ static int estimate_expr_size(Scheme_Object *expr, int sz, int fuel) break; } case scheme_ir_toplevel_type: - case scheme_ir_quote_syntax_type: /* FIXME: other syntax types not covered */ default: sz += 1; @@ -2407,10 +2463,10 @@ static Scheme_Object *apply_inlined(Scheme_Lambda *lam, Optimize_Info *info, if (!expected) { /* No arguments, so no need for a `let` wrapper: */ - sub_info = optimize_info_add_frame(info, 0, 0, 0); + sub_info = optimize_info_add_frame(info, 0); if (!single_use || lam->ir_info->is_dup) sub_info->inline_fuel >>= 1; - p = scheme_optimize_expr(p, sub_info, context); + p = optimize_expr(p, sub_info, context); info->single_result = sub_info->single_result; info->preserves_marks = sub_info->preserves_marks; optimize_info_done(sub_info, NULL); @@ -2473,7 +2529,7 @@ static Scheme_Object *apply_inlined(Scheme_Lambda *lam, Optimize_Info *info, else lh->body = p; - sub_info = optimize_info_add_frame(info, 0, 0, 0); + sub_info = optimize_info_add_frame(info, 0); if (!single_use || lam->ir_info->is_dup) sub_info->inline_fuel >>= 1; @@ -2562,16 +2618,15 @@ int check_potential_size(Scheme_Object *var) } Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, - int argc, int for_inline, int *_single_use) + int argc, int for_inline, int for_props, int *_single_use) /* Return a known procedure, if any. - When argc == -1 it may return a case-lambda. Else, it will check the arity - and split a case-lambda to extact the relevant lambda. If the arity is - wrong the result is scheme_true. - If for_inline, it may return a potential size. Else, it will go inside - potential sizes, noinline procedures, lets, begins and other construction, + When argc == -1, the result may be a case-lambda or `scheme_constant_key`; + otherwise, unless `for_props`, the arity is used to split a case-lambda to extact + the relevant lambda, and if the arity is wrong, the result is `scheme_true`. + If `for_inline`, the result may be a potential size, otherwise this function + goes inside potential sizes, noinline procedures, lets, begins and other construction, so the result can't be inlined and must be used only to get the properties - of the actual procedure. It may also return a struct_(prop_)proc_shape.*/ - + of the actual procedure. */ { Scheme_Object *prev = NULL; @@ -2601,51 +2656,16 @@ Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, return NULL; } - while (SAME_TYPE(SCHEME_TYPE(le), scheme_ir_toplevel_type)) { - int pos; - pos = SCHEME_TOPLEVEL_POS(le); + if (SAME_TYPE(SCHEME_TYPE(le), scheme_ir_toplevel_type)) { + Scheme_Object *inl; *_single_use = 0; - if (info->cp->inline_variants) { - Scheme_Object *iv; - iv = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos)); - if (iv && SCHEME_TRUEP(iv)) { - Scheme_Hash_Table *iv_ht = NULL; - if (SCHEME_HASHTP(iv)) { - iv_ht = (Scheme_Hash_Table *)iv; - iv = scheme_hash_get(iv_ht, scheme_make_integer(argc)); - if (!iv) - iv = scheme_hash_get(iv_ht, scheme_false); - } - if (SAME_TYPE(SCHEME_TYPE(iv), scheme_vector_type)) { /* inline variant + shift info */ - int has_cases = 0; - Scheme_Object *orig_iv = iv; - MZ_ASSERT(SAME_TYPE(scheme_inline_variant_type, SCHEME_TYPE(SCHEME_VEC_ELS(iv)[0]))); - /* unresolving may add new top-levels to `info->cp`: */ - iv = scheme_unresolve(SCHEME_VEC_ELS(iv)[0], argc, &has_cases, - info->cp, info->env, info->insp, SCHEME_INT_VAL(SCHEME_VEC_ELS(iv)[3]), - SCHEME_VEC_ELS(iv)[1], SCHEME_VEC_ELS(iv)[2]); - if (has_cases) { - if (!iv_ht) { - iv_ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(iv_ht, scheme_false, orig_iv); - scheme_hash_set(info->cp->inline_variants, scheme_make_integer(pos), (Scheme_Object *)iv_ht); - } - scheme_hash_set(iv_ht, scheme_make_integer(argc), iv ? iv : scheme_false); - } else - scheme_hash_set(info->cp->inline_variants, scheme_make_integer(pos), iv ? iv : scheme_false); - } - if (iv && SCHEME_TRUEP(iv)) { - le = iv; - break; - } - } - } - if (info->top_level_consts) { - le = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - if (!le) - return NULL; - } else - break; + do { + inl = get_import_inline(info, (Scheme_IR_Toplevel *)le, argc, for_props); + if ((argc < 0) && SAME_OBJ(inl, scheme_constant_key)) + return inl; + if (!inl) inl = get_defn_shape(info, (Scheme_IR_Toplevel *)le); + if (inl) le = inl; + } while (inl && SAME_TYPE(SCHEME_TYPE(le), scheme_ir_toplevel_type)); } if (SCHEME_WILL_BE_LAMBDAP(le)) { @@ -2679,9 +2699,10 @@ Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, } if (ok_arity || (argc == -1)) { return for_inline ? NULL : le; - } else { + } else if (for_props) + return le; + else return scheme_true; - } } if (SAME_TYPE(SCHEME_TYPE(le), scheme_struct_prop_proc_shape_type)) { @@ -2698,9 +2719,10 @@ Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, } if (ok_arity || (argc == -1)) { return for_inline ? NULL : le; - } else { + } else if (for_props) + return le; + else return scheme_true; - } } if (SAME_TYPE(SCHEME_TYPE(le), scheme_case_lambda_sequence_type)) { @@ -2708,7 +2730,7 @@ Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, Scheme_Object *cp; int i, count; - if (argc == -1) + if ((argc == -1) || for_props) return le; count = cl->count; @@ -2733,7 +2755,7 @@ Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, if (SAME_TYPE(SCHEME_TYPE(le), scheme_ir_lambda_type)) { Scheme_Lambda *lam = (Scheme_Lambda *)le; - if (argc == -1) + if ((argc == -1) || for_props) return le; if ((lam->num_params == argc) @@ -2748,7 +2770,7 @@ Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, if (SCHEME_PROCP(le)) { Scheme_Object *a[1]; - if (argc == -1) + if ((argc == -1) || for_props) return le; a[0] = le; @@ -2758,13 +2780,19 @@ Scheme_Object *do_lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, return scheme_true; } + if (for_props + && le + && (SAME_TYPE(SCHEME_TYPE(le), scheme_lambda_type) + || SAME_TYPE(SCHEME_TYPE(le), scheme_case_lambda_sequence_type))) + return le; + return NULL; } Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *le, int argc) { int single_use = 0; - return do_lookup_constant_proc(info, le, argc, 0, &single_use); + return do_lookup_constant_proc(info, le, argc, 0, 0, &single_use); } #if 0 @@ -2803,7 +2831,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a } le2 = le; - le = do_lookup_constant_proc(info, le, argc, 1, &single_use); + le = do_lookup_constant_proc(info, le, argc, 1, 0, &single_use); if (!le) { info->has_nonleaf = 1; @@ -2826,7 +2854,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a int len; const char *pname = NULL, *context; info->escapes = 1; - le2 = lookup_constant_proc(info, le2, -1); + le2 = do_lookup_constant_proc(info, le2, argc, 1, 1, &single_use); if (!SAME_TYPE(SCHEME_TYPE(le2), scheme_struct_proc_shape_type) && !SAME_TYPE(SCHEME_TYPE(le2), scheme_struct_prop_proc_shape_type)){ pname = scheme_get_proc_name(le2, &len, 0); @@ -2865,40 +2893,43 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a if (le) { LOG_INLINE(fprintf(stderr, "Inline %d[%d]<=%d@%d %d %s\n", sz, is_leaf, threshold, info->inline_fuel, single_use, scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL))); - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "inlining %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - threshold, - scheme_optimize_context_to_string(info->context)); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + "inlining %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + threshold, + scheme_optimize_context_to_string(info->context)); le = apply_inlined((Scheme_Lambda *)le, sub_info, argc, app, app2, app3, context, orig_le, prev, single_use); return le; } else { LOG_INLINE(fprintf(stderr, "No inline %s\n", scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL))); - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "no-inlining %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - threshold, - scheme_optimize_context_to_string(info->context)); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + "no-inlining %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + threshold, + scheme_optimize_context_to_string(info->context)); } } else { LOG_INLINE(fprintf(stderr, "No fuel %s %d[%d]>%d@%d %d\n", scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), sz, is_leaf, threshold, info->inline_fuel, info->use_psize)); - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "out-of-fuel %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - threshold, - scheme_optimize_context_to_string(info->context)); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + "out-of-fuel %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + threshold, + scheme_optimize_context_to_string(info->context)); } } @@ -3071,7 +3102,7 @@ static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rat reset_rator(app, rator); orig_rator = replace_tail_inside(app, inside, orig_rator); - return scheme_optimize_expr(orig_rator, info, context); + return optimize_expr(orig_rator, info, context); } static int is_nonmutating_nondependant_primitive(Scheme_Object *rator, int n) @@ -3226,6 +3257,8 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, Optimize_Inf return scheme_real_p_proc; else if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_NUMBER) return scheme_number_p_proc; + else if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_BOOL) + return scheme_boolean_p_proc; else if (SAME_OBJ(rator, scheme_cons_proc)) return scheme_pair_p_proc; else if (SAME_OBJ(rator, scheme_unsafe_cons_list_proc)) @@ -3272,65 +3305,12 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, Optimize_Inf || IS_NAMED_PRIM(rator, "bytes-set!") || IS_NAMED_PRIM(rator, "set-box!")) return scheme_void_p_proc; - else if (IS_NAMED_PRIM(rator, "vector-set!") - || IS_NAMED_PRIM(rator, "string-set!") - || IS_NAMED_PRIM(rator, "bytes-set!")) - return scheme_void_p_proc; else if (IS_NAMED_PRIM(rator, "string->symbol") || IS_NAMED_PRIM(rator, "gensym")) return scheme_symbol_p_proc; else if (IS_NAMED_PRIM(rator, "string->keyword")) return scheme_keyword_p_proc; - else if (IS_NAMED_PRIM(rator, "pair?") - || IS_NAMED_PRIM(rator, "mpair?") - || IS_NAMED_PRIM(rator, "list?") - || IS_NAMED_PRIM(rator, "list-pair?") - || IS_NAMED_PRIM(rator, "vector?") - || IS_NAMED_PRIM(rator, "box?") - || IS_NAMED_PRIM(rator, "number?") - || IS_NAMED_PRIM(rator, "real?") - || IS_NAMED_PRIM(rator, "complex?") - || IS_NAMED_PRIM(rator, "rational?") - || IS_NAMED_PRIM(rator, "integer?") - || IS_NAMED_PRIM(rator, "exact-integer?") - || IS_NAMED_PRIM(rator, "exact-nonnegative-integer?") - || IS_NAMED_PRIM(rator, "exact-positive-integer?") - || IS_NAMED_PRIM(rator, "inexact-real?") - || IS_NAMED_PRIM(rator, "fixnum?") - || IS_NAMED_PRIM(rator, "flonum?") - || IS_NAMED_PRIM(rator, "single-flonum?") - || IS_NAMED_PRIM(rator, "null?") - || IS_NAMED_PRIM(rator, "void?") - || IS_NAMED_PRIM(rator, "symbol?") - || IS_NAMED_PRIM(rator, "keyword?") - || IS_NAMED_PRIM(rator, "string?") - || IS_NAMED_PRIM(rator, "bytes?") - || IS_NAMED_PRIM(rator, "path?") - || IS_NAMED_PRIM(rator, "char?") - || IS_NAMED_PRIM(rator, "interned-char?") - || IS_NAMED_PRIM(rator, "boolean?") - || IS_NAMED_PRIM(rator, "chaperone?") - || IS_NAMED_PRIM(rator, "impersonator?") - || IS_NAMED_PRIM(rator, "procedure?") - || IS_NAMED_PRIM(rator, "eof-object?") - || IS_NAMED_PRIM(rator, "immutable?") - || IS_NAMED_PRIM(rator, "not") - || IS_NAMED_PRIM(rator, "true-object?") - || IS_NAMED_PRIM(rator, "zero?") - || IS_NAMED_PRIM(rator, "procedure-arity-includes?") - || IS_NAMED_PRIM(rator, "variable-reference-constant?") - || IS_NAMED_PRIM(rator, "eq?") - || IS_NAMED_PRIM(rator, "eqv?") - || IS_NAMED_PRIM(rator, "equal?") - || IS_NAMED_PRIM(rator, "string=?") - || IS_NAMED_PRIM(rator, "bytes=?") - || IS_NAMED_PRIM(rator, "char=?") - || IS_NAMED_PRIM(rator, "free-identifier=?") - || IS_NAMED_PRIM(rator, "bound-identifier=?") - || IS_NAMED_PRIM(rator, "procedure-closure-contents-eq?")) { - return scheme_boolean_p_proc; - } - + { Scheme_Object *p; p = local_type_to_predicate(produces_local_type(rator, argc)); @@ -3372,7 +3352,7 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In switch (SCHEME_TYPE(expr)) { case scheme_ir_local_type: { - if (scheme_hash_tree_get(ignore_vars, expr)) + if (scheme_eq_hash_tree_get(ignore_vars, expr)) return NULL; if (!SCHEME_VAR(expr)->mutated) { @@ -3424,7 +3404,7 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In break; case scheme_application3_type: { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; + Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; if (SCHEME_PRIMP(app->rator) && (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED) && IS_NAMED_PRIM(app->rator, "bitwise-and")) { @@ -3514,9 +3494,6 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In case scheme_case_lambda_sequence_type: return scheme_procedure_p_proc; break; - case scheme_ir_quote_syntax_type: - return scheme_syntax_p_proc; - break; case scheme_branch_type: { Scheme_Object *l, *r; @@ -3575,24 +3552,26 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In return scheme_box_p_proc; break; default: - if (SCHEME_FLOATP(expr)) - return scheme_flonum_p_proc; - if (SCHEME_LONG_DBLP(expr)) - return scheme_extflonum_p_proc; - if (SCHEME_INTP(expr) - && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr))) - return scheme_fixnum_p_proc; - if (SCHEME_REALP(expr)) - return scheme_real_p_proc; - if (SCHEME_NUMBERP(expr)) + if (SCHEME_NUMBERP(expr)) { + if (SCHEME_FLOATP(expr)) + return scheme_flonum_p_proc; + if (SCHEME_LONG_DBLP(expr)) + return scheme_extflonum_p_proc; + if (SCHEME_INTP(expr) + && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr))) + return scheme_fixnum_p_proc; + if (SCHEME_REALP(expr)) + return scheme_real_p_proc; return scheme_number_p_proc; + } if (SCHEME_NULLP(expr)) return scheme_null_p_proc; - if (scheme_is_list(expr)) - return scheme_list_pair_p_proc; - if (SCHEME_PAIRP(expr)) + if (SCHEME_PAIRP(expr)) { + if (scheme_is_list(expr)) + return scheme_list_pair_p_proc; return scheme_pair_p_proc; + } if (SCHEME_MPAIRP(expr)) return scheme_mpair_p_proc; if (SCHEME_CHAR_STRINGP(expr)) @@ -3607,10 +3586,11 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In return scheme_keyword_p_proc; if (SCHEME_SYMBOLP(expr)) return scheme_symbol_p_proc; - if (SCHEME_CHARP(expr) && SCHEME_CHAR_VAL(expr) < 256) - return scheme_interned_char_p_proc; - if (SCHEME_CHARP(expr)) + if (SCHEME_CHARP(expr)) { + if (SCHEME_CHAR_VAL(expr) < 256) + return scheme_interned_char_p_proc; return scheme_char_p_proc; + } if (SAME_OBJ(expr, scheme_true)) return scheme_true_object_p_proc; if (SCHEME_FALSEP(expr)) @@ -3764,12 +3744,12 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info /* Check for (apply ... (list ...)) early: */ le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args], info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); if (app->num_args == 3) { le = call_with_immed_mark(app->args[0], app->args[1], app->args[2], app->args[3], info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); } le = check_app_let_rator(o, app->args[0], info, app->num_args, context); @@ -3796,7 +3776,7 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info } optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->args[i], info, sub_context); + le = optimize_expr(app->args[i], info, sub_context); app->args[i] = le; if (info->escapes) { int j; @@ -3858,22 +3838,18 @@ static int appn_flags(Scheme_Object *rator, Optimize_Info *info) /* Record some properties of an application that are useful to the SFS pass. */ { if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_toplevel_type)) { - if (info->top_level_consts) { - int pos; - pos = SCHEME_TOPLEVEL_POS(rator); - rator = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - rator = no_potential_size(rator); - if (!rator) return 0; - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_proc_shape_type)) { - return APPN_FLAG_SFS_TAIL; - } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_struct_proc_shape_type)) { - int ps = SCHEME_PROC_SHAPE_MODE(rator); - if ((ps == STRUCT_PROC_SHAPE_PRED) - || (ps == STRUCT_PROC_SHAPE_GETTER) - || (ps == STRUCT_PROC_SHAPE_SETTER)) - return (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); - return 0; - } + rator = get_defn_shape(info, (Scheme_IR_Toplevel *)rator); + rator = no_potential_size(rator); + if (!rator) return 0; + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_proc_shape_type)) { + return APPN_FLAG_SFS_TAIL; + } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_struct_proc_shape_type)) { + int ps = SCHEME_PROC_SHAPE_MODE(rator); + if ((ps == STRUCT_PROC_SHAPE_PRED) + || (ps == STRUCT_PROC_SHAPE_GETTER) + || (ps == STRUCT_PROC_SHAPE_SETTER)) + return (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); + return 0; } } @@ -3891,9 +3867,12 @@ static int appn_flags(Scheme_Object *rator, Optimize_Info *info) return 0; } +#define CHECK_PRIM_AD_HOC_OPT_FLAGS 0 + static int check_known_variant(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe, + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode, Scheme_Object *implies_pred) /* Replace the rator with an unsafe version if we know that it's ok: if the argument is consistent with `expect_pred`; if `unsafe` is @@ -3905,10 +3884,30 @@ static int check_known_variant(Optimize_Info *info, Scheme_Object *app, generate an error. If unsafe is NULL then rator has no unsafe version, so only check the type. */ { - if (SCHEME_PRIMP(rator) && (!who || IS_NAMED_PRIM(rator, who))) { +#if CHECK_PRIM_AD_HOC_OPT_FLAGS + if (who) { + Scheme_Object *p; + p = scheme_builtin_value(who); + if (!p) { + printf("bad primitive name: %s\n", who); + abort(); + } + if (!(SCHEME_PRIM_PROC_OPT_FLAGS(p) & SCHEME_PRIM_AD_HOC_OPT)) { + printf("missing SCHEME_PRIM_AD_HOC_OPT: %s\n", who); + abort(); + } + } +#endif + + MZ_ASSERT(SCHEME_PRIMP(rator)); + if (!who || IS_NAMED_PRIM(rator, who)) { Scheme_Object *pred; - pred = expr_implies_predicate(rand, info); + if (unsafe_mode) + pred = expect_pred; + else + pred = expr_implies_predicate(rand, info); + if (pred) { if (predicate_implies(pred, expect_pred)) { if (unsafe) { @@ -3932,10 +3931,11 @@ static int check_known_variant(Optimize_Info *info, Scheme_Object *app, static void check_known(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) /* When the expected predicate for unsafe substitution is the same as the implied predicate. */ { - (void)check_known_variant(info, app, rator, rand, who, expect_pred, unsafe, expect_pred); + (void)check_known_variant(info, app, rator, rand, who, expect_pred, unsafe, unsafe_mode, expect_pred); } static void check_known_rator(Optimize_Info *info, Scheme_Object *rator) @@ -3955,18 +3955,24 @@ static void check_known_rator(Optimize_Info *info, Scheme_Object *rator) static void check_known_both_try(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) /* Replace the rator with an unsafe version if both rands have the right type. If not, don't save the type, nor mark this as an error */ { - if (SCHEME_PRIMP(rator) && (!who || IS_NAMED_PRIM(rator, who))) { + MZ_ASSERT(SCHEME_PRIMP(rator)); + if (!who || IS_NAMED_PRIM(rator, who)) { Scheme_Object *pred1, *pred2; - - pred1 = expr_implies_predicate(rand1, info); - if (pred1 && SAME_OBJ(pred1, expect_pred)) { - pred2 = expr_implies_predicate(rand2, info); - if (pred2 && SAME_OBJ(pred2, expect_pred)) { + + if (info->unsafe_mode) { + reset_rator(app, unsafe); + } else { + pred1 = expr_implies_predicate(rand1, info); + if (pred1 && SAME_OBJ(pred1, expect_pred)) { + pred2 = expr_implies_predicate(rand2, info); + if (pred2 && SAME_OBJ(pred2, expect_pred)) { reset_rator(app, unsafe); + } } } } @@ -3974,26 +3980,30 @@ static void check_known_both_try(Optimize_Info *info, Scheme_Object *app, static void check_known_both_variant(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe, + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode, Scheme_Object *implies_pred) { - if (SCHEME_PRIMP(rator) && (!who || IS_NAMED_PRIM(rator, who))) { + MZ_ASSERT(SCHEME_PRIMP(rator)); + if (!who || IS_NAMED_PRIM(rator, who)) { int ok1; - ok1 = check_known_variant(info, app, rator, rand1, who, expect_pred, NULL, implies_pred); - check_known_variant(info, app, rator, rand2, who, expect_pred, (ok1 ? unsafe : NULL), implies_pred); + ok1 = check_known_variant(info, app, rator, rand1, who, expect_pred, NULL, unsafe_mode, implies_pred); + check_known_variant(info, app, rator, rand2, who, expect_pred, (ok1 ? unsafe : NULL), unsafe_mode, implies_pred); } } static void check_known_both(Optimize_Info *info, Scheme_Object *app, Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) { - check_known_both_variant(info, app, rator, rand1, rand2, who, expect_pred, unsafe, expect_pred); + check_known_both_variant(info, app, rator, rand1, rand2, who, expect_pred, unsafe, unsafe_mode, expect_pred); } static void check_known_all(Optimize_Info *info, Scheme_Object *_app, int skip_head, int skip_tail, - const char *who, Scheme_Object *expect_pred, Scheme_Object *unsafe) + const char *who, Scheme_Object *expect_pred, + Scheme_Object *unsafe, int unsafe_mode) { Scheme_App_Rec *app = (Scheme_App_Rec *)_app; if (SCHEME_PRIMP(app->args[0]) && (!who || IS_NAMED_PRIM(app->args[0], who))) { @@ -4001,7 +4011,7 @@ static void check_known_all(Optimize_Info *info, Scheme_Object *_app, int skip_h for (i = skip_head; i < app->num_args - skip_tail; i++) { if (!check_known_variant(info, _app, app->args[0], app->args[i+1], who, expect_pred, - NULL, expect_pred)) + NULL, unsafe_mode, expect_pred)) ok_so_far = 0; } @@ -4118,40 +4128,49 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_ if (app->num_args >= 3) rand3 = app->args[3]; - check_known(info, app_o, rator, rand1, "vector-set!", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand2, "vector-set!", scheme_fixnum_p_proc, NULL); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known(info, app_o, rator, rand1, "vector-set!", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "vector*-set!", scheme_vector_p_proc, + (info->unsafe_mode ? scheme_unsafe_vector_star_set_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector*-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "map", scheme_list_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "for-each", scheme_list_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "andmap", scheme_list_p_proc, NULL); - check_known_all(info, app_o, 1, 0, "ormap", scheme_list_p_proc, NULL); + check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "map", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "for-each", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "andmap", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known_all(info, app_o, 1, 0, "ormap", scheme_list_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand1, "string-set!", scheme_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "string-set!", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand3, "string-set!", scheme_char_p_proc, NULL); - check_known(info, app_o, rator, rand1, "bytes-set!", scheme_byte_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "bytes-set!", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand3, "bytes-set!", scheme_fixnum_p_proc, NULL); + check_known(info, app_o, rator, rand1, "string-set!", scheme_string_p_proc, + (info->unsafe_mode ? scheme_unsafe_string_set_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "string-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand3, "string-set!", scheme_char_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "bytes-set!", scheme_byte_string_p_proc, + (info->unsafe_mode ? scheme_unsafe_bytes_set_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "bytes-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand3, "bytes-set!", scheme_fixnum_p_proc, NULL, info->unsafe_mode); - check_known_all(info, app_o, 0, 0, "string-append", scheme_string_p_proc, scheme_true); - check_known_all(info, app_o, 0, 0, "bytes-append", scheme_byte_string_p_proc, scheme_true); + check_known_all(info, app_o, 0, 0, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known_all(info, app_o, 0, 0, "bytes-append", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); - check_known_all(info, app_o, 0, 1, "append", scheme_list_p_proc, scheme_true); + check_known_all(info, app_o, 0, 1, "append", scheme_list_p_proc, scheme_true, info->unsafe_mode); + } if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL) check_known_all(info, app_o, 0, 0, NULL, scheme_real_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_NUMBER) check_known_all(info, app_o, 0, 0, NULL, scheme_number_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); - /* Some of these may have changed app->rator. */ + /* Some of these may have changed app->rator. */ rator = app->args[0]; } @@ -4227,7 +4246,7 @@ static Scheme_Object *check_ignored_call_cc(Scheme_Object *rator, Scheme_Object expr = (Scheme_Object *)seq; } - return scheme_optimize_expr(expr, info, context); + return optimize_expr(expr, info, context); } } } @@ -4274,7 +4293,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf sub_context = OPT_CONTEXT_SINGLED; - le = scheme_optimize_expr(app->rator, info, sub_context); + le = optimize_expr(app->rator, info, sub_context); app->rator = le; if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -4299,7 +4318,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->rand, info, sub_context); + le = optimize_expr(app->rand, info, sub_context); app->rand = le; optimize_info_seq_done(info, &info_seq); if (info->escapes) { @@ -4490,81 +4509,114 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } - if (SAME_OBJ(scheme_varref_from_unsafe_p_proc, rator) + /* We can resolve (variable-reference-from-unsafe (#%variable-reference)) + to a specific boolean result */ + if (SAME_OBJ(scheme_varref_unsafe_p_proc, rator) && SAME_TYPE(SCHEME_TYPE(rand), scheme_varref_form_type)) { - return replace_tail_inside(scheme_false, inside, app->rand); + Scheme_Object *result = (info->unsafe_mode ? scheme_true : scheme_false); + return replace_tail_inside(result, inside, app->rand); } - if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, "zero?")) { + if (SCHEME_PRIMP(rator) + && (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_BOOL) + && (IS_NAMED_PRIM(rator, "zero?") + || IS_NAMED_PRIM(rator, "positive?") + || IS_NAMED_PRIM(rator, "negative?"))) { Scheme_Object* pred; Scheme_App3_Rec *new; pred = expr_implies_predicate(rand, info); if (pred && SAME_OBJ(pred, scheme_fixnum_p_proc)) { - new = (Scheme_App3_Rec *)make_application_3(scheme_unsafe_fx_eq_proc, app->rand, scheme_make_integer(0), info); + Scheme_Object *cmp; + if (IS_NAMED_PRIM(rator, "positive?")) + cmp = scheme_unsafe_fx_gt_proc; + else if (IS_NAMED_PRIM(rator, "negative?")) + cmp = scheme_unsafe_fx_lt_proc; + else + cmp = scheme_unsafe_fx_eq_proc; + new = (Scheme_App3_Rec *)make_application_3(cmp, app->rand, scheme_make_integer(0), info); SCHEME_APPN_FLAGS(new) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); return finish_optimize_application3(new, info, context); } } + if (SAME_OBJ(rator, scheme_system_type_proc) + && SCHEME_SYMBOLP(rand) + && !SCHEME_SYM_WEIRDP(rand) + && !strcmp(SCHEME_SYM_VAL(rand), "vm")) { + /* For the expander's benefit, optimize `(system-type 'vm)` to `'racket` + to effectively select backend details statically. */ + return scheme_intern_symbol("racket"); + } + { /* Try to check the argument's type, and use the unsafe versions if possible. */ Scheme_Object *app_o = (Scheme_Object *)app; - check_known_variant(info, app_o, rator, rand, "bitwise-not", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, scheme_real_p_proc); - check_known_variant(info, app_o, rator, rand, "fxnot", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, scheme_real_p_proc); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known_variant(info, app_o, rator, rand, "bitwise-not", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, 0, scheme_real_p_proc); + check_known_variant(info, app_o, rator, rand, "fxnot", scheme_fixnum_p_proc, scheme_unsafe_fxnot_proc, info->unsafe_mode, scheme_real_p_proc); - check_known(info, app_o, rator, rand, "car", scheme_pair_p_proc, scheme_unsafe_car_proc); - check_known(info, app_o, rator, rand, "unsafe-car", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc); - check_known(info, app_o, rator, rand, "unsafe-cdr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc); - check_known(info, app_o, rator, rand, "unsafe-mcar", scheme_mpair_p_proc, NULL); - check_known(info, app_o, rator, rand, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc); - check_known(info, app_o, rator, rand, "unsafe-mcdr", scheme_mpair_p_proc, NULL); - check_known(info, app_o, rator, rand, "string-length", scheme_string_p_proc, scheme_unsafe_string_length_proc); - check_known(info, app_o, rator, rand, "bytes-length", scheme_byte_string_p_proc, scheme_unsafe_byte_string_length_proc); - /* It's not clear that these are useful, since a chaperone check is needed anyway: */ - check_known(info, app_o, rator, rand, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc); - check_known(info, app_o, rator, rand, "unsafe-unbox", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand, "unsafe-unbox*", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc); + check_known(info, app_o, rator, rand, "car", scheme_pair_p_proc, scheme_unsafe_car_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-car", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-cdr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-mcar", scheme_mpair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-mcdr", scheme_mpair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string-length", scheme_string_p_proc, scheme_unsafe_string_length_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "bytes-length", scheme_byte_string_p_proc, scheme_unsafe_byte_string_length_proc, info->unsafe_mode); + /* It's not clear that these are useful, since a chaperone check is needed anyway: */ + check_known(info, app_o, rator, rand, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unbox*", scheme_box_p_proc, + (info->unsafe_mode ? scheme_unsafe_unbox_star_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-unbox", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "unsafe-unbox*", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector*-length", scheme_vector_p_proc, + (info->unsafe_mode ? scheme_unsafe_vector_star_length_proc : NULL), info->unsafe_mode); - check_known(info, app_o, rator, rand, "length", scheme_list_p_proc, scheme_true); + check_known(info, app_o, rator, rand, "length", scheme_list_p_proc, scheme_true, info->unsafe_mode); - check_known(info, app_o, rator, rand, "string-append", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "bytes-append", scheme_byte_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "string->immutable-string", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "bytes->immutable-bytes", scheme_byte_string_p_proc, scheme_true); - - check_known(info, app_o, rator, rand, "string->symbol", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "symbol->string", scheme_symbol_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "string->keyword", scheme_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "keyword->string", scheme_keyword_p_proc, scheme_true); + check_known(info, app_o, rator, rand, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "bytes-append", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string->immutable-string", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "bytes->immutable-bytes", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string->symbol", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "symbol->string", scheme_symbol_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "string->keyword", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "keyword->string", scheme_keyword_p_proc, scheme_true, info->unsafe_mode); + } + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL) check_known(info, app_o, rator, rand, NULL, scheme_real_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_NUMBER) check_known(info, app_o, rator, rand, NULL, scheme_number_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); - /* These operation don't have an unsafe replacement. Check to record types and detect errors: */ - check_known(info, app_o, rator, rand, "caar", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cadr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cdar", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cddr", scheme_pair_p_proc, NULL); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + /* These operation don't have an unsafe replacement. Check to record types and detect errors: */ + check_known(info, app_o, rator, rand, "caar", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cadr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cdar", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cddr", scheme_pair_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand, "caddr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cdddr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cadddr", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand, "cddddr", scheme_pair_p_proc, NULL); + check_known(info, app_o, rator, rand, "caddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cdddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cadddr", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "cddddr", scheme_pair_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand, "list->vector", scheme_list_p_proc, scheme_true); - check_known(info, app_o, rator, rand, "vector->list", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand, "vector->values", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand, "vector->immutable-vector", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand, "make-vector", scheme_fixnum_p_proc, NULL); + check_known(info, app_o, rator, rand, "list->vector", scheme_list_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector->list", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector->values", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "vector->immutable-vector", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand, "make-vector", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + } /* Some of these may have changed app->rator. */ rator = app->rator; @@ -4579,12 +4631,19 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz if ((mode == STRUCT_PROC_SHAPE_PRED) || (mode == STRUCT_PROC_SHAPE_GETTER)) { Scheme_Object *pred; - pred = expr_implies_predicate(rand, info); + int unsafe = 0; - if (pred - && SAME_TYPE(SCHEME_TYPE(pred), scheme_struct_proc_shape_type) - && is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred), - SCHEME_PROC_SHAPE_IDENTITY(alt))) { + if (info->unsafe_mode && (mode == STRUCT_PROC_SHAPE_GETTER)) { + pred = NULL; + unsafe = 1; + } else + pred = expr_implies_predicate(rand, info); + + if (unsafe + || (pred + && SAME_TYPE(SCHEME_TYPE(pred), scheme_struct_proc_shape_type) + && is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred), + SCHEME_PROC_SHAPE_IDENTITY(alt)))) { if (mode == STRUCT_PROC_SHAPE_PRED) { /* We know that the predicate will succeed */ return replace_tail_inside(make_discarding_sequence(rand, scheme_true, info), @@ -4606,7 +4665,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz /* Register type based on getter succeeding: */ if ((mode == STRUCT_PROC_SHAPE_GETTER) - && SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(alt)) + && !SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(alt)) && SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type)) add_type(info, rand, scheme_make_struct_proc_shape(STRUCT_PROC_SHAPE_PRED, SCHEME_PROC_SHAPE_IDENTITY(alt))); @@ -4642,22 +4701,23 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf if (SAME_OBJ(app->rator, scheme_check_not_undefined_proc) && SCHEME_SYMBOLP(app->rand2)) { - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "warning%s: use-before-definition check inserted on variable: %S", - scheme_optimize_context_to_string(info->context), - app->rand2); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + "warning%s: use-before-definition check inserted on variable: %S", + scheme_optimize_context_to_string(info->context), + app->rand2); } /* Check for (apply ... (list ...)) early: */ le = direct_apply((Scheme_Object *)app, app->rator, app->rand2, info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); le = call_with_immed_mark(app->rator, app->rand1, app->rand2, NULL, info); if (le) - return scheme_optimize_expr(le, info, context); + return optimize_expr(le, info, context); le = check_app_let_rator(o, app->rator, info, 2, context); if (le) @@ -4671,7 +4731,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf sub_context = OPT_CONTEXT_SINGLED; - le = scheme_optimize_expr(app->rator, info, sub_context); + le = optimize_expr(app->rator, info, sub_context); app->rator = le; if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -4698,7 +4758,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->rand1, info, sub_context); + le = optimize_expr(app->rand1, info, sub_context); app->rand1 = le; if (info->escapes) { info->size += 1; @@ -4715,7 +4775,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(app->rand2, info, sub_context); + le = optimize_expr(app->rand2, info, sub_context); app->rand2 = le; optimize_info_seq_done(info, &info_seq); if (info->escapes) { @@ -4972,74 +5032,142 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz if (SCHEME_PRIMP(app->rator)) { Scheme_Object *app_o = (Scheme_Object *)app, *rator = app->rator, *rand1 = app->rand1, *rand2 = app->rand2; - - check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-and", scheme_fixnum_p_proc, scheme_unsafe_fxand_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-ior", scheme_fixnum_p_proc, scheme_unsafe_fxior_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-xor", scheme_fixnum_p_proc, scheme_unsafe_fxxor_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "fxand", scheme_fixnum_p_proc, scheme_unsafe_fxand_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "fxior", scheme_fixnum_p_proc, scheme_unsafe_fxior_proc, scheme_real_p_proc); - check_known_both_variant(info, app_o, rator, rand1, rand2, "fxxor", scheme_fixnum_p_proc, scheme_unsafe_fxxor_proc, scheme_real_p_proc); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-and", scheme_fixnum_p_proc, + scheme_unsafe_fxand_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-ior", scheme_fixnum_p_proc, + scheme_unsafe_fxior_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "bitwise-xor", scheme_fixnum_p_proc, + scheme_unsafe_fxxor_proc, info->unsafe_mode, scheme_real_p_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, ">", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, ">=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "min", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "max", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "fxand", scheme_fixnum_p_proc, + scheme_unsafe_fxand_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "fxior", scheme_fixnum_p_proc, + scheme_unsafe_fxior_proc, info->unsafe_mode, scheme_real_p_proc); + check_known_both_variant(info, app_o, rator, rand1, rand2, "fxxor", scheme_fixnum_p_proc, + scheme_unsafe_fxxor_proc, info->unsafe_mode, scheme_real_p_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx>", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fx>=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fxmin", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc); - check_known_both_try(info, app_o, rator, rand1, rand2, "fxmax", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc); + check_known_both_try(info, app_o, rator, rand1, rand2, "=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, ">", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, ">=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "min", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc, 0); + check_known_both_try(info, app_o, rator, rand1, rand2, "max", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc, 0); - rator = app->rator; /* in case it was updated */ + check_known_both_try(info, app_o, rator, rand1, rand2, "fx=", scheme_fixnum_p_proc, scheme_unsafe_fx_eq_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx<", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx>", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx<=", scheme_fixnum_p_proc, scheme_unsafe_fx_lt_eq_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fx>=", scheme_fixnum_p_proc, scheme_unsafe_fx_gt_eq_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fxmin", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc, info->unsafe_mode); + check_known_both_try(info, app_o, rator, rand1, rand2, "fxmax", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc, info->unsafe_mode); - check_known_both(info, app_o, rator, rand1, rand2, "string-append", scheme_string_p_proc, scheme_true); - check_known_both(info, app_o, rator, rand1, rand2, "bytes-append", scheme_byte_string_p_proc, scheme_true); - check_known(info, app_o, rator, rand1, "string-ref", scheme_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "string-ref", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand1, "bytes-ref", scheme_byte_string_p_proc, NULL); - check_known(info, app_o, rator, rand2, "bytes-ref", scheme_fixnum_p_proc, NULL); + rator = app->rator; /* in case it was updated */ - check_known(info, app_o, rator, rand1, "append", scheme_list_p_proc, scheme_true); - check_known(info, app_o, rator, rand1, "list-ref", scheme_pair_p_proc, NULL); - check_known(info, app_o, rator, rand2, "list-ref", scheme_fixnum_p_proc, NULL); + check_known_both(info, app_o, rator, rand1, rand2, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode); + check_known_both(info, app_o, rator, rand1, rand2, "bytes-append", scheme_byte_string_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "string-ref", scheme_string_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "string-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "bytes-ref", scheme_byte_string_p_proc, + (info->unsafe_mode ? scheme_unsafe_bytes_ref_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "bytes-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + + check_known(info, app_o, rator, rand1, "append", scheme_list_p_proc, scheme_true, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "list-ref", scheme_pair_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "list-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + } if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL) check_known_both(info, app_o, rator, rand1, rand2, NULL, scheme_real_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_NUMBER) check_known_both(info, app_o, rator, rand1, rand2, NULL, scheme_number_p_proc, - (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL); + (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS) ? scheme_true : NULL, + info->unsafe_mode); - check_known(info, app_o, rator, rand1, "vector-ref", scheme_vector_p_proc, NULL); - check_known(info, app_o, rator, rand2, "vector-ref", scheme_fixnum_p_proc, NULL); - check_known(info, app_o, rator, rand1, "make-vector", scheme_fixnum_p_proc, NULL); + if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) { + check_known(info, app_o, rator, rand1, "vector-ref", scheme_vector_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "vector*-ref", scheme_vector_p_proc, + (info->unsafe_mode ? scheme_unsafe_vector_star_ref_proc: NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand2, "vector*-ref", scheme_fixnum_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "make-vector", scheme_fixnum_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand1, "set-box!", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand1, "unsafe-set-box!", scheme_box_p_proc, NULL); - check_known(info, app_o, rator, rand1, "unsafe-set-box*!", scheme_box_p_proc, NULL); + check_known(info, app_o, rator, rand1, "set-box!", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "set-box*!", scheme_box_p_proc, + (info->unsafe_mode ? scheme_unsafe_set_box_star_proc : NULL), info->unsafe_mode); + check_known(info, app_o, rator, rand1, "unsafe-set-box!", scheme_box_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "unsafe-set-box*!", scheme_box_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand1, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand2, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL); + check_known(info, app_o, rator, rand1, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "procedure-closure-contents-eq?", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "procedure-arity-includes?", scheme_procedure_p_proc, NULL, info->unsafe_mode); - check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL); - check_known(info, app_o, rator, rand2, "map", scheme_list_p_proc, NULL); - check_known(info, app_o, rator, rand2, "for-each", scheme_list_p_proc, NULL); - check_known(info, app_o, rator, rand2, "andmap", scheme_list_p_proc, NULL); - check_known(info, app_o, rator, rand2, "ormap", scheme_list_p_proc, NULL); + check_known(info, app_o, rator, rand1, "map", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "for-each", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "andmap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand1, "ormap", scheme_procedure_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "map", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "for-each", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "andmap", scheme_list_p_proc, NULL, info->unsafe_mode); + check_known(info, app_o, rator, rand2, "ormap", scheme_list_p_proc, NULL, info->unsafe_mode); + } rator = app->rator; /* in case it was updated */ } + + /* Using a struct mutator? */ + { + Scheme_Object *alt; + alt = get_struct_proc_shape(app->rator, info, 0); + if (alt) { + int mode = (SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_MASK); + + if (mode == STRUCT_PROC_SHAPE_SETTER) { + Scheme_Object *pred; + int unsafe = 0; + + if (info->unsafe_mode) { + pred = NULL; + unsafe = 1; + } else + pred = expr_implies_predicate(app->rand1, info); + + if ((unsafe + || (pred + && SAME_TYPE(SCHEME_TYPE(pred), scheme_struct_proc_shape_type) + && is_struct_identity_subtype(SCHEME_PROC_SHAPE_IDENTITY(pred), + SCHEME_PROC_SHAPE_IDENTITY(alt)))) + /* Only if the field position is known: */ + && ((SCHEME_PROC_SHAPE_MODE(alt) >> STRUCT_PROC_SHAPE_SHIFT) != 0)) { + /* Struct type matches, so use `unsafe-struct-set!` */ + Scheme_Object *l; + Scheme_App_Rec *new_app; + int pos = (SCHEME_PROC_SHAPE_MODE(alt) >> STRUCT_PROC_SHAPE_SHIFT) - 1; + l = scheme_make_pair(scheme_make_integer(pos), + scheme_make_pair(app->rand2, + scheme_null)); + l = scheme_make_pair(app->rand1, l); + l = scheme_make_pair(((SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_AUTHENTIC) + ? scheme_unsafe_struct_star_set_proc + : scheme_unsafe_struct_set_proc), + l); + new_app = (Scheme_App_Rec *)scheme_make_application(l, info); + SCHEME_APPN_FLAGS(new_app) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); + return finish_optimize_application(new_app, info, context); + } + } + + /* Register type based on setter succeeding: */ + if (!SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(alt)) + && SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type)) + add_type(info, app->rand1, scheme_make_struct_proc_shape(STRUCT_PROC_SHAPE_PRED, + SCHEME_PROC_SHAPE_IDENTITY(alt))); + } + } increment_clocks_for_application(info, app->rator, 2); @@ -5143,9 +5271,6 @@ static Scheme_Object *flatten_sequence(Scheme_Object *o, Optimize_Info *info, in Scheme_Object *o3; int i, j, k, count, extra = 0, split = 0, b0, new_count; - if (SAME_TYPE(SCHEME_TYPE(o), scheme_splice_sequence_type)) - return o; - if (!info->flatten_fuel) return o; @@ -5226,10 +5351,10 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i if (sub_opt) { optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(s->array[i], info, - ((i + 1 == count) - ? scheme_optimize_tail_context(context) - : 0)); + le = optimize_expr(s->array[i], info, + ((i + 1 == count) + ? scheme_optimize_tail_context(context) + : 0)); } else le = s->array[i]; @@ -5344,7 +5469,8 @@ static Scheme_Object *equivalent_exprs(Scheme_Object *a, Scheme_Object *b, if (SAME_TYPE(SCHEME_TYPE(a), scheme_ir_toplevel_type) && SAME_TYPE(SCHEME_TYPE(b), scheme_ir_toplevel_type) - && (SCHEME_TOPLEVEL_POS(a) == SCHEME_TOPLEVEL_POS(b))) + && (SCHEME_IR_TOPLEVEL_INSTANCE(a) == SCHEME_IR_TOPLEVEL_INSTANCE(b)) + && (SCHEME_IR_TOPLEVEL_POS(a) == SCHEME_IR_TOPLEVEL_POS(b))) return a; if (b_info @@ -5495,7 +5621,7 @@ static void merge_branchs_types(Optimize_Info *t_info, Optimize_Info *f_info, i = scheme_hash_tree_next(f_types, -1); while (i != -1) { scheme_hash_tree_index(f_types, i, &var, &f_pred); - t_pred = scheme_hash_tree_get(t_types, var); + t_pred = scheme_eq_hash_tree_get(t_types, var); if (t_pred) { if (predicate_implies(f_pred, t_pred)) add_type(base_info, var, t_pred); @@ -5665,7 +5791,7 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu shape = get_struct_proc_shape(app->rator, info, 0); if (shape && ((SCHEME_PROC_SHAPE_MODE(shape) & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED) - && SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(shape))) { + && !SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(shape))) { add_type(info, app->rand, shape); } } @@ -5777,7 +5903,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int optimize_info_seq_init(info, &info_seq); - t = scheme_optimize_expr(t, info, OPT_CONTEXT_BOOLEAN | OPT_CONTEXT_SINGLED); + t = optimize_expr(t, info, OPT_CONTEXT_BOOLEAN | OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -5846,9 +5972,9 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int info->size -= 1; if (SCHEME_FALSEP(t2)) - xb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); + xb = optimize_expr(fb, info, scheme_optimize_tail_context(context)); else - xb = scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); + xb = optimize_expr(tb, info, scheme_optimize_tail_context(context)); optimize_info_seq_done(info, &info_seq); return replace_tail_inside(xb, inside, t); @@ -5864,10 +5990,10 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int init_kclock = info->kclock; init_sclock = info->sclock; - then_info = optimize_info_add_frame(info, 0, 0, 0); + then_info = optimize_info_add_frame(info, 0); add_types_for_t_branch(t, then_info, 5); - then_info_init = optimize_info_add_frame(then_info, 0, 0, 0); - tb = scheme_optimize_expr(tb, then_info, scheme_optimize_tail_context(context)); + then_info_init = optimize_info_add_frame(then_info, 0); + tb = optimize_expr(tb, then_info, scheme_optimize_tail_context(context)); optimize_info_done(then_info, NULL); info->escapes = 0; @@ -5878,10 +6004,10 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int optimize_info_seq_step(info, &info_seq); - else_info = optimize_info_add_frame(info, 0, 0, 0); + else_info = optimize_info_add_frame(info, 0); add_types_for_f_branch(t, else_info, 5); - else_info_init = optimize_info_add_frame(else_info, 0, 0, 0); - fb = scheme_optimize_expr(fb, else_info, scheme_optimize_tail_context(context)); + else_info_init = optimize_info_add_frame(else_info, 0); + fb = optimize_expr(fb, else_info, scheme_optimize_tail_context(context)); optimize_info_done(else_info, NULL); if (then_info->escapes && else_info->escapes) { @@ -6048,7 +6174,7 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co optimize_info_seq_init(info, &info_seq); - k = scheme_optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); + k = optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6057,7 +6183,7 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co optimize_info_seq_step(info, &info_seq); - v = scheme_optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); + v = optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6073,7 +6199,7 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co optimize_info_seq_step(info, &info_seq); - b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); + b = optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); if (init_vclock == info->vclock) { /* body has no effect itself, so we can rewind the clock */ @@ -6120,14 +6246,12 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co static Scheme_Object * define_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) { - Scheme_Object *vars = SCHEME_VEC_ELS(data)[0]; - Scheme_Object *val = SCHEME_VEC_ELS(data)[1]; + Scheme_Object *val = SCHEME_DEFN_RHS(data); optimize_info_used_top(info); - val = scheme_optimize_expr(val, info, 0); + val = optimize_expr(val, info, 0); - SCHEME_VEC_ELS(data)[0] = vars; - SCHEME_VEC_ELS(data)[1] = val; + SCHEME_DEFN_RHS(data) = val; return data; } @@ -6141,7 +6265,7 @@ set_optimize(Scheme_Object *data, Optimize_Info *info, int context) var = sb->var; val = sb->val; - val = scheme_optimize_expr(val, info, OPT_CONTEXT_SINGLED); + val = optimize_expr(val, info, OPT_CONTEXT_SINGLED); if (info->escapes) return ensure_noncm(val, info); @@ -6152,6 +6276,7 @@ set_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { register_use(SCHEME_VAR(var), info); } else { + MZ_ASSERT(((Scheme_IR_Toplevel *)var)->instance_pos == -1); optimize_info_used_top(info); } @@ -6199,28 +6324,14 @@ ref_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) { SCHEME_PTR1_VAL(data) = (SCHEME_VAR(v)->mutated ? scheme_false : scheme_true); } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)) { - /* Knowing whether a top-level variable is fixed lets up optimize + /* Knowing whether a top-level variable is fixed lets us optimize uses of `variable-reference-constant?` */ - if (info->top_level_consts) { - int pos = SCHEME_TOPLEVEL_POS(v); - int fixed = 0; - - if (scheme_hash_get(info->top_level_consts, scheme_make_integer(pos))) - fixed = 1; - else { - GC_CAN_IGNORE Scheme_Object *t; - t = scheme_hash_get(info->top_level_consts, scheme_false); - if (t) { - if (scheme_hash_get((Scheme_Hash_Table *)t, scheme_make_integer(pos))) - fixed = 1; - } - } - - if (fixed) { - v = scheme_toplevel_to_flagged_toplevel(v, SCHEME_TOPLEVEL_FIXED); - SCHEME_PTR1_VAL(data) = v; - } + if (get_defn_shape(info, (Scheme_IR_Toplevel *)v) + || get_import_shape(info, (Scheme_IR_Toplevel *)v)) { + v = scheme_ir_toplevel_to_flagged_toplevel(v, SCHEME_TOPLEVEL_FIXED); + SCHEME_PTR1_VAL(data) = v; } + register_import_used(info, (Scheme_IR_Toplevel *)v); } info->preserves_marks = 1; @@ -6263,7 +6374,7 @@ apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) optimize_info_seq_init(info, &info_seq); - f = scheme_optimize_expr(f, info, OPT_CONTEXT_SINGLED); + f = optimize_expr(f, info, OPT_CONTEXT_SINGLED); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6271,7 +6382,7 @@ apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) } optimize_info_seq_step(info, &info_seq); - e = scheme_optimize_expr(e, info, 0); + e = optimize_expr(e, info, 0); optimize_info_seq_done(info, &info_seq); @@ -6320,14 +6431,14 @@ with_immed_mark_optimize(Scheme_Object *data, Optimize_Info *info, int context) optimize_info_seq_init(info, &info_seq); - key = scheme_optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); + key = optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED); optimize_info_seq_step(info, &info_seq); if (info->escapes) { optimize_info_seq_done(info, &info_seq); return ensure_noncm(key, info); } - val = scheme_optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); + val = optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED); optimize_info_seq_step(info, &info_seq); if (info->escapes) { optimize_info_seq_done(info, &info_seq); @@ -6336,14 +6447,14 @@ with_immed_mark_optimize(Scheme_Object *data, Optimize_Info *info, int context) optimize_info_seq_done(info, &info_seq); - body_info = optimize_info_add_frame(info, 1, 1, 0); + body_info = optimize_info_add_frame(info, 0); var = SCHEME_VAR(SCHEME_CAR(wcm->body)); set_optimize_mode(var); var->optimize.lambda_depth = body_info->lambda_depth; var->optimize_used = 0; var->optimize.init_kclock = info->kclock; - body = scheme_optimize_expr(SCHEME_CDR(wcm->body), body_info, 0); + body = optimize_expr(SCHEME_CDR(wcm->body), body_info, 0); optimize_info_done(body_info, NULL); @@ -6393,7 +6504,7 @@ case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context) for (i = 0; i < seq->count; i++) { le = seq->array[i]; - le = scheme_optimize_expr(le, info, 0); + le = optimize_expr(le, info, 0); seq->array[i] = le; } @@ -6442,11 +6553,11 @@ static Scheme_Object *begin0_optimize(Scheme_Object *obj, Optimize_Info *info, i optimize_info_seq_step(info, &info_seq); - le = scheme_optimize_expr(s->array[i], - info, - (!i - ? scheme_optimize_result_context(context) - : 0)); + le = optimize_expr(s->array[i], + info, + (!i + ? scheme_optimize_result_context(context) + : 0)); if (!i) { single_result = info->single_result; @@ -6581,53 +6692,6 @@ static Scheme_Object *begin0_optimize(Scheme_Object *obj, Optimize_Info *info, i return replace_tail_inside(expr, inside, orig_first); } -static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info) -{ - Scheme_Object *val; - Optimize_Info *einfo; - - val = SCHEME_VEC_ELS(data)[3]; - - einfo = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); - if (info->inline_fuel < 0) - einfo->inline_fuel = -1; - einfo->logger = info->logger; - - val = scheme_optimize_expr(val, einfo, 0); - - SCHEME_VEC_ELS(data)[3] = val; - - return data; -} - -static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - return do_define_syntaxes_optimize(data, info); -} - -static Scheme_Object *begin_for_syntax_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - Scheme_Object *l, *a; - Optimize_Info *einfo; - - l = SCHEME_VEC_ELS(data)[2]; - - while (!SCHEME_NULLP(l)) { - einfo = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); - if (info->inline_fuel < 0) - einfo->inline_fuel = -1; - einfo->logger = info->logger; - - a = SCHEME_CAR(l); - a = scheme_optimize_expr(a, einfo, 0); - SCHEME_CAR(l) = a; - - l = SCHEME_CDR(l); - } - - return data; -} - /*========================================================================*/ /* let, let-values, letrec, etc. */ /*========================================================================*/ @@ -6667,7 +6731,7 @@ int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fue case scheme_ir_toplevel_type: return 1; case scheme_ir_local_type: - if (!scheme_hash_tree_get(exclude_vars, o)) + if (!scheme_eq_hash_tree_get(exclude_vars, o)) return 1; break; case scheme_branch_type: @@ -6757,27 +6821,29 @@ int ir_propagate_ok(Scheme_Object *value, Optimize_Info *info, int used_once, Sc } return 1; } else { - Scheme_Lambda *lam = (Scheme_Lambda *)value; - if (sz < 0) - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - /* contains non-copyable body elements that prevent inlining */ - "non-copyable %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - 0, /* no sensible threshold here */ - scheme_optimize_context_to_string(info->context)); - else - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - /* too large to be an inlining candidate */ - "too-large %s size: %d threshold: %d#%s", - scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), - sz, - 0, /* no sensible threshold here */ - scheme_optimize_context_to_string(info->context)); + if (scheme_log_level_p(info->logger, SCHEME_LOG_DEBUG)) { + Scheme_Lambda *lam = (Scheme_Lambda *)value; + if (sz < 0) + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + /* contains non-copyable body elements that prevent inlining */ + "non-copyable %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + 0, /* no sensible threshold here */ + scheme_optimize_context_to_string(info->context)); + else + scheme_log(info->logger, + SCHEME_LOG_DEBUG, + 0, + /* too large to be an inlining candidate */ + "too-large %s size: %d threshold: %d#%s", + scheme_write_to_string(lam->name ? lam->name : scheme_false, NULL), + sz, + 0, /* no sensible threshold here */ + scheme_optimize_context_to_string(info->context)); + } return 0; } } @@ -6793,20 +6859,20 @@ int ir_propagate_ok(Scheme_Object *value, Optimize_Info *info, int used_once, Sc } if (SAME_TYPE(SCHEME_TYPE(value), scheme_ir_toplevel_type)) { - if ((SCHEME_TOPLEVEL_FLAGS(value) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) + if ((SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)value) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_FIXED) return 1; - if (info->top_level_consts) { - int pos; - pos = SCHEME_TOPLEVEL_POS(value); - value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - value = no_potential_size(value); - if (SAME_OBJ(value, scheme_constant_key) - || (value && SAME_TYPE(SCHEME_TYPE(value), scheme_struct_proc_shape_type))) - return 0; - if (value) - return 1; - } - return 0; + if (get_import_shape(info, (Scheme_IR_Toplevel *)value)) + return 1; + + value = get_defn_shape(info, (Scheme_IR_Toplevel *)value); + value = no_potential_size(value); + if (SAME_OBJ(value, scheme_constant_key) + || (value && SAME_TYPE(SCHEME_TYPE(value), scheme_struct_proc_shape_type))) + return 0; + else if (value) + return 1; + else + return 0; } /* Test this after the specific cases, @@ -6910,7 +6976,7 @@ static int is_values_apply(Scheme_Object *e, int n, Optimize_Info *info, Scheme_ } else if (fuel && SAME_TYPE(SCHEME_TYPE(e), scheme_branch_type)) { Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e; if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_ir_local_type) - && !scheme_hash_tree_get(except_vars, b->test) + && !scheme_eq_hash_tree_get(except_vars, b->test) && !SCHEME_VAR(b->test)->mutated) { return (is_values_apply(b->tbranch, n, info, except_vars, 0) && is_values_apply(b->fbranch, n, info, except_vars, 0)); @@ -7330,6 +7396,47 @@ static void end_transitive_use_record(Optimize_Info *info) } } +/* Convert up to `c` clauses for `let-values` into a `begin`, where + the converted clauses have zero bindings. The `head` argument will + be non-NULL if there's a possibility of remaining clauses. */ +static Scheme_Object *convert_leading_zero_bindings_to_begin(Scheme_IR_Let_Header *head, + Scheme_Object *start_body, + int c) +{ + Scheme_Object *body; + Scheme_IR_Let_Value *irlv; + Scheme_Sequence *seq; + int i, n = 0; + + body = start_body; + for (i = 0; i < c; i++) { + irlv = (Scheme_IR_Let_Value *)body; + if (irlv->count) + break; + n++; + body = irlv->body; + } + + seq = scheme_malloc_sequence(n + 1); + seq->so.type = scheme_sequence_type; + seq->count = n + 1; + body = start_body; + for (i = 0; i < n; i++) { + irlv = (Scheme_IR_Let_Value *)body; + seq->array[i] = irlv->value; + body = irlv->body; + } + + if (n < c) { + head->num_clauses -= n; + head->body = body; + seq->array[n] = (Scheme_Object *)head; + } else + seq->array[n] = body; + + return (Scheme_Object *)seq; +} + static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, int context) /* This is the main entry point for optimizing a `let[rec]-values` form. */ { @@ -7376,7 +7483,7 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in b3->tbranch = scheme_true; b3->fbranch = b->fbranch; - form = scheme_optimize_expr((Scheme_Object *)b3, info, context); + form = optimize_expr((Scheme_Object *)b3, info, context); return form; } @@ -7394,10 +7501,18 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in if (SAME_OBJ((Scheme_Object *)irlv->vars[0], irlv->body)) { body = irlv->value; body = ensure_single_value_noncm(body, info); - return scheme_optimize_expr(body, info, context); + return optimize_expr(body, info, context); } } + /* Zero leading bindings in unsafe mode => convert to `begin`, since + we can unsafely drop the check on the number of results */ + if (!is_rec && info->unsafe_mode && head->num_clauses + && !((Scheme_IR_Let_Value *)head->body)->count) { + body = convert_leading_zero_bindings_to_begin(head, head->body, head->num_clauses); + return optimize_expr(body, info, context); + } + if (!is_rec) { int try_again; do { @@ -7431,13 +7546,13 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in irlv->value = seq->array[seq->count - 1]; seq->array[seq->count - 1] = (Scheme_Object *)head; - return scheme_optimize_expr((Scheme_Object *)seq, info, context); + return optimize_expr((Scheme_Object *)seq, info, context); } } } while (try_again); } - body_info = optimize_info_add_frame(info, head->count, head->count, 0); + body_info = optimize_info_add_frame(info, 0); rhs_info = body_info; merge_skip_vars = scheme_make_hash_tree(SCHEME_hashtr_eq); @@ -7525,14 +7640,14 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in pre_sclock = rhs_info->sclock; if (!found_escapes) { optimize_info_seq_step(rhs_info, &info_seq); - value = scheme_optimize_expr(pre_body->value, rhs_info, - (((pre_body->count == 1) - ? OPT_CONTEXT_SINGLED - : 0) - | (((pre_body->count == 1) - && !pre_body->vars[0]->non_app_count) - ? (pre_body->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) - : 0))); + value = optimize_expr(pre_body->value, rhs_info, + (((pre_body->count == 1) + ? OPT_CONTEXT_SINGLED + : 0) + | (((pre_body->count == 1) + && !pre_body->vars[0]->non_app_count) + ? (pre_body->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) + : 0))); pre_body->value = value; if (rhs_info->escapes) found_escapes = 1; @@ -7864,14 +7979,14 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in rhs_info->use_psize = info->use_psize; optimize_info_seq_step(rhs_info, &info_seq); - value = scheme_optimize_expr(self_value, rhs_info, - (((irlv->count == 1) - ? OPT_CONTEXT_SINGLED - : 0) - | (((irlv->count == 1) - && !irlv->vars[0]->non_app_count) - ? (irlv->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) - : 0))); + value = optimize_expr(self_value, rhs_info, + (((irlv->count == 1) + ? OPT_CONTEXT_SINGLED + : 0) + | (((irlv->count == 1) + && !irlv->vars[0]->non_app_count) + ? (irlv->vars[0]->use_count << OPT_CONTEXT_APP_COUNT_SHIFT) + : 0))); if (!OPT_DISCOURAGE_EARLY_INLINE) --rhs_info->letrec_not_twice; @@ -7988,7 +8103,7 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in optimize_info_seq_done(body_info, &info_seq); if (!found_escapes) { - body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context)); + body = optimize_expr(body, body_info, scheme_optimize_tail_context(context)); } else { body = ensure_noncm(escape_body, body_info); body_info->single_result = 1; @@ -8221,6 +8336,36 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in form = optimize_sequence(form, info, context, 0); } + if (!is_rec && info->unsafe_mode) { + /* Peel zero-binding clauses off the end in unsafe mode? */ + if (SAME_TYPE(SCHEME_TYPE(form), scheme_ir_let_header_type)) { + int i, c, n; + head = (Scheme_IR_Let_Header *)form; + c = head->num_clauses; + n = head->count; + prev_body = NULL; + body = head->body; + for (i = 0; i < c; i++) { + if (!n) { + /* We've seen as many bindings as exist, to the rest + must be clauses with zero bindings */ + body = convert_leading_zero_bindings_to_begin(NULL, body, c - i); + if (prev_body) { + prev_body->body = body; + head->num_clauses = i; + } else + form = body; + break; + } else { + irlv = (Scheme_IR_Let_Value *)body; + n -= irlv->count; + prev_body = irlv; + body = irlv->body; + } + } + } + } + return form; } @@ -8243,8 +8388,7 @@ optimize_lambda(Scheme_Object *_lam, Optimize_Info *info, int context) info->single_result = 1; info->preserves_marks = 1; - info = optimize_info_add_frame(info, lam->num_params, lam->num_params, - SCHEME_LAMBDA_FRAME); + info = optimize_info_add_frame(info, SCHEME_LAMBDA_FRAME); ht = scheme_make_hash_table(SCHEME_hash_ptr); info->uses = ht; @@ -8284,7 +8428,7 @@ optimize_lambda(Scheme_Object *_lam, Optimize_Info *info, int context) } } - code = scheme_optimize_expr(lam->body, info, 0); + code = optimize_expr(lam->body, info, 0); propagate_used_variables(info); @@ -8459,7 +8603,7 @@ static Scheme_Object *clone_lambda(int single_use, Scheme_Object *_lam, Optimize ht = scheme_make_hash_table(SCHEME_hash_ptr); for (i = 0; i < cl->base_closure->size; i++) { if (cl->base_closure->vals[i]) { - var = scheme_hash_tree_get(var_map, cl->base_closure->keys[i]); + var = scheme_eq_hash_tree_get(var_map, cl->base_closure->keys[i]); scheme_hash_set(ht, (var ? var @@ -8501,7 +8645,7 @@ static int lambda_has_top_level(Scheme_Lambda *lam) } /*========================================================================*/ -/* modules */ +/* linklets */ /*========================================================================*/ static int set_code_closure_flags(Scheme_Object *clones, @@ -8532,11 +8676,11 @@ static int set_code_closure_flags(Scheme_Object *clones, return flags; } -static Scheme_Object *is_cross_module_inline_candidiate(Scheme_Object *e, Optimize_Info *info, +static Scheme_Object *is_cross_linklet_inline_candidiate(Scheme_Object *e, Optimize_Info *info, int size_override) { if (SCHEME_LAMBDAP(e)) { - if (size_override || (lambda_body_size(e, 1) < CROSS_MODULE_INLINE_SIZE)) + if (size_override || (lambda_body_size(e, 1) < CROSS_LINKLET_INLINE_SIZE)) return optimize_clone(0, e, info, empty_eq_hash_tree, 0); } @@ -8577,21 +8721,22 @@ static int is_general_lambda(Scheme_Object *e, Optimize_Info *info) return 0; } -void install_definition(Scheme_Object *vec, int pos, Scheme_Object *var, Scheme_Object *rhs) +void install_definition(Scheme_Object *bodies, int pos, Scheme_Object *old_defn, int name_pos, Scheme_Object *rhs) { Scheme_Object *def; - var = scheme_make_pair(var, scheme_null); def = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(def)[0] = var; - SCHEME_VEC_ELS(def)[1] = rhs; + SCHEME_DEFN_RHS(def) = rhs; + SCHEME_DEFN_VAR_(def, 0) = SCHEME_DEFN_VAR_(old_defn, name_pos); def->type = scheme_define_values_type; - SCHEME_VEC_ELS(vec)[pos] = def; + SCHEME_VEC_ELS(bodies)[pos] = def; } -int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Object *vec, int offset) +int split_define_values(Scheme_Object *defn, int n, Scheme_Object *bodies, int offset) { + Scheme_Object *e = SCHEME_DEFN_RHS(defn); + if (SAME_TYPE(SCHEME_TYPE(e), scheme_ir_let_header_type)) { /* This is a tedious case to recognize the pattern (let ([x rhs] ...) (values x ...)) @@ -8620,11 +8765,10 @@ int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Obj if (SAME_OBJ(app->rator, scheme_values_proc) && SAME_OBJ(app->rand1, (Scheme_Object *)lv->vars[0]) && SAME_OBJ(app->rand2, (Scheme_Object *)((Scheme_IR_Let_Value *)lv->body)->vars[0])) { - if (vars) { - install_definition(vec, offset, SCHEME_CAR(vars), lv->value); - vars = SCHEME_CDR(vars); + if (bodies) { + install_definition(bodies, offset, defn, 0, lv->value); lv = (Scheme_IR_Let_Value *)lv->body; - install_definition(vec, offset+1, SCHEME_CAR(vars), lv->value); + install_definition(bodies, offset+1, defn, 1, lv->value); } return 1; } @@ -8639,12 +8783,11 @@ int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Obj return 0; lv = (Scheme_IR_Let_Value *)lv->body; } - if (vars) { + if (bodies) { body = lh->body; for (i = 0; i < n; i++) { Scheme_IR_Let_Value *lv2 = (Scheme_IR_Let_Value *)body; - install_definition(vec, offset+i, SCHEME_CAR(vars), lv2->value); - vars = SCHEME_CDR(vars); + install_definition(bodies, offset+i, defn, i, lv2->value); body = lv2->body; } } @@ -8657,10 +8800,9 @@ int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Obj if (SAME_OBJ(app->rator, scheme_values_proc) && scheme_omittable_expr(app->rand1, 1, 5, 0, NULL, NULL) && scheme_omittable_expr(app->rand2, 1, 5, 0, NULL, NULL)) { - if (vars) { - install_definition(vec, offset, SCHEME_CAR(vars), app->rand1); - vars = SCHEME_CDR(vars); - install_definition(vec, offset+1, SCHEME_CAR(vars), app->rand2); + if (bodies) { + install_definition(bodies, offset, defn, 0, app->rand1); + install_definition(bodies, offset+1, defn, 1, app->rand2); } return 1; } @@ -8673,10 +8815,9 @@ int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Obj if (!scheme_omittable_expr(app->args[i+1], 1, 5, 0, NULL, NULL)) return 0; } - if (vars) { + if (bodies) { for (i = 0; i < n; i++) { - install_definition(vec, offset+i, SCHEME_CAR(vars), app->args[i+1]); - vars = SCHEME_CDR(vars); + install_definition(bodies, offset+i, defn, i, app->args[i+1]); } } return 1; @@ -8703,123 +8844,136 @@ static Scheme_Hash_Table *set_as_fixed(Scheme_Hash_Table *fixed_table, Optimize_ return fixed_table; } -static Scheme_Object * -module_optimize(Scheme_Object *data, Optimize_Info *info, int context) +Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode, + Scheme_Object **_import_keys, Scheme_Object *get_import) { - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *e, *vars, *old_context; + Scheme_Object *e; int start_simultaneous = 0, i_m, cnt; Scheme_Object *cl_first = NULL, *cl_last = NULL; Scheme_Hash_Table *consts = NULL, *fixed_table = NULL, *re_consts = NULL; Scheme_Hash_Table *originals = NULL; - int cont, next_pos_ready = -1, inline_fuel, is_proc_def; - Comp_Prefix *prev_cp; + int cont, inline_fuel, is_proc_def, any_defns = 0; + Optimize_Info *info; Optimize_Info *limited_info; Optimize_Info_Sequence info_seq; + Scheme_Hash_Tree **iu; - if (!m->comp_prefix) { - /* already resolved */ - return (Scheme_Object *)m; + info = optimize_info_create(linklet, enforce_const, can_inline, unsafe_mode); + info->context = (Scheme_Object *)linklet; + + /* Less inlining for a large module: */ + if (SCHEME_VEC_SIZE(linklet->bodies) > 128) + info->inline_fuel >>= 1; + + if (_import_keys) { + Cross_Linklet_Info *cross; + Scheme_Hash_Tree *ht; + int i; + + iu = MALLOC_N(Scheme_Hash_Tree*, 1); + *iu = empty_eq_hash_tree; + info->imports_used = iu; + + cross = (Cross_Linklet_Info *)scheme_malloc(sizeof(Cross_Linklet_Info)); + info->cross = cross; + + cross->get_import = get_import; + + cross->import_keys = empty_eq_hash_tree; + cross->rev_import_keys = empty_eq_hash_tree; + for (i = 0; i < SCHEME_VEC_SIZE(*_import_keys); i++) { + ht = scheme_hash_tree_set(cross->import_keys, + scheme_make_integer(i), + SCHEME_VEC_ELS(*_import_keys)[i]); + cross->import_keys = ht; + ht = scheme_hash_tree_set(cross->rev_import_keys, + SCHEME_VEC_ELS(*_import_keys)[i], + scheme_make_integer(i)); + cross->rev_import_keys = ht; + } + cross->linklets = empty_eq_hash_tree; + cross->import_next_keys = empty_eq_hash_tree; + cross->inline_variants = empty_eq_hash_tree; + cross->import_syms = empty_eq_hash_tree; } - if (m->phaseless) { - scheme_log(info->logger, - SCHEME_LOG_DEBUG, - 0, - "compilation of cross-phase persistent module: %D", - m->modname); - } - - old_context = info->context; - info->context = (Scheme_Object *)m; - optimize_info_seq_init(info, &info_seq); - prev_cp = info->cp; - info->cp = m->comp_prefix; - - /* Use `limited_info` for optimization decisions that need to be - rediscovered by the validator. The validator knows shape - information for imported variables, and it knows about structure - bindings for later forms. */ - limited_info = MALLOC_ONE_RT(Optimize_Info); -#ifdef MZTAG_REQUIRED - limited_info->type = scheme_rt_optimize_info; -#endif - limited_info->cp = info->cp; - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); + cnt = SCHEME_VEC_SIZE(linklet->bodies); /* First, flatten `(define-values (x ...) (values e ...))' to `(define (x) e) ...' when possible. */ { int inc = 0; for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; - vars = SCHEME_VEC_ELS(e)[0]; - n = scheme_list_length(vars); + n = SCHEME_DEFN_VAR_COUNT(e); if (n > 1) { - e = SCHEME_VEC_ELS(e)[1]; - if (split_define_values(e, n, NULL, NULL, 0)) + if (split_define_values(e, n, NULL, 0)) inc += (n - 1); } + any_defns = 1; } } if (inc > 0) { - Scheme_Object *new_vec; + Scheme_Object *new_bodies; int j = 0; - new_vec = scheme_make_vector(cnt+inc, NULL); + new_bodies = scheme_make_vector(cnt+inc, scheme_false); for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; - vars = SCHEME_VEC_ELS(e)[0]; - n = scheme_list_length(vars); + n = SCHEME_DEFN_VAR_COUNT(e); if (n > 1) { - if (split_define_values(SCHEME_VEC_ELS(e)[1], n, vars, new_vec, j)) { + if (split_define_values(e, n, new_bodies, j)) { j += n; } else - SCHEME_VEC_ELS(new_vec)[j++] = e; + SCHEME_VEC_ELS(new_bodies)[j++] = e; } else - SCHEME_VEC_ELS(new_vec)[j++] = e; + SCHEME_VEC_ELS(new_bodies)[j++] = e; } else - SCHEME_VEC_ELS(new_vec)[j++] = e; + SCHEME_VEC_ELS(new_bodies)[j++] = e; } cnt += inc; - m->bodies[0] = new_vec; + linklet->bodies = new_bodies; } } - if (OPT_ESTIMATE_FUTURE_SIZES) { + if (any_defns) { + /* Use `limited_info` for optimization decisions that need to be + rediscovered by the validator. The validator knows shape + information for imported variables, and it knows about structure + bindings for later forms. */ + limited_info = MALLOC_ONE_RT(Optimize_Info); +#ifdef MZTAG_REQUIRED + limited_info->type = scheme_rt_optimize_info; +#endif + limited_info->linklet = info->linklet; + } else + limited_info = NULL; + + if (OPT_ESTIMATE_FUTURE_SIZES && any_defns) { if (info->enforce_const) { /* For each identifier bound to a procedure, register an initial size estimate, which is used to discourage early loop unrolling at the expense of later inlining. */ for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; - vars = SCHEME_VEC_ELS(e)[0]; - e = SCHEME_VEC_ELS(e)[1]; + n = SCHEME_DEFN_VAR_COUNT(e); + if ((n == 1) && SCHEME_LAMBDAP(SCHEME_DEFN_RHS(e))) { + Scheme_IR_Toplevel *var = SCHEME_DEFN_VAR(e, 0); - n = scheme_list_length(vars); - if ((n == 1) && SCHEME_LAMBDAP(e)) { - Scheme_Toplevel *tl; - - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - int pos; + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { if (!consts) consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, - scheme_make_integer(pos), - estimate_closure_size(e)); + scheme_hash_set(consts, scheme_make_integer(var->variable_pos), estimate_closure_size(e)); } } } @@ -8834,32 +8988,31 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; is_proc_def = 0; if (OPT_DISCOURAGE_EARLY_INLINE && info->enforce_const) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { Scheme_Object *e2; - e2 = SCHEME_VEC_ELS(e)[1]; + e2 = SCHEME_DEFN_RHS(e); if (is_general_lambda(e2, info)) is_proc_def = 1; } } + inline_fuel = info->inline_fuel; if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { info->use_psize = 1; - inline_fuel = info->inline_fuel; if (inline_fuel > 2) info->inline_fuel = 2; - } else - inline_fuel = 0; + } optimize_info_seq_step(info, &info_seq); - e = scheme_optimize_expr(e, info, 0); + e = optimize_expr(e, info, 0); if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { info->use_psize = 0; - info->inline_fuel = inline_fuel; } - SCHEME_VEC_ELS(m->bodies[0])[i_m] = e; + info->inline_fuel = inline_fuel; + SCHEME_VEC_ELS(linklet->bodies)[i_m] = e; if (info->enforce_const) { /* If this expression/definition can't have any side effect @@ -8869,11 +9022,12 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) int n, cnst = 0, sproc = 0, sprop = 0, has_guard = 0; Scheme_Object *sstruct = NULL, *parent_identity = NULL; Simple_Struct_Type_Info stinfo; + Scheme_Object *defn = e; - vars = SCHEME_VEC_ELS(e)[0]; - e = SCHEME_VEC_ELS(e)[1]; + n = SCHEME_DEFN_VAR_COUNT(defn); + e = SCHEME_DEFN_RHS(defn); - n = scheme_list_length(vars); + limited_info->cross = info->cross; cont = scheme_omittable_expr(e, n, -1, /* ignore APPN_FLAG_OMITTABLE, because the validator won't be able to reconstruct it @@ -8889,6 +9043,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) optimization time: */ limited_info, info); + info->cross = limited_info->cross; if (n == 1) { if (ir_propagate_ok(e, info, 0, NULL)) @@ -8899,18 +9054,16 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } } else if (scheme_is_simple_make_struct_type(e, n, 0, NULL, &stinfo, &parent_identity, - info->top_level_consts, - info->cp->inline_variants, - NULL, NULL, 0, NULL, NULL, + info, + NULL, NULL, 0, NULL, &sstruct, 5)) { sstruct = scheme_make_pair(sstruct, parent_identity); cnst = 1; } else if (scheme_is_simple_make_struct_type_property(e, n, 0, &has_guard, - info->top_level_consts, - info->cp->inline_variants, - NULL, NULL, 0, NULL, NULL, + info, + NULL, NULL, 0, NULL, 5)) { sprop = 1; cnst = 1; @@ -8924,14 +9077,18 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cont = scheme_omittable_expr(e, n, 5, OMITTABLE_IGNORE_APPN_OMIT, limited_info, NULL); } + if (cont) { + /* Record for the resolve pass's pruning that definition is omittable */ + SCHEME_SET_DEFN_CAN_OMIT(defn); + } + if (cnst) { - Scheme_Toplevel *tl; + Scheme_IR_Toplevel *var; int i; for (i = 0; i < n; i++) { - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - vars = SCHEME_CDR(vars); + var = SCHEME_DEFN_VAR(defn, i); - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { Scheme_Object *e2; if (sstruct) { @@ -8958,15 +9115,12 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } if (e2) { - int pos; - pos = tl->position; - consts = info->top_level_consts; if (!consts) { consts = scheme_make_hash_table(SCHEME_hash_ptr); info->top_level_consts = consts; } - scheme_hash_set(consts, scheme_make_integer(pos), e2); + scheme_hash_set(consts, scheme_make_integer(var->variable_pos), e2); if (sstruct || sprop) { /* include in `limited_info` */ @@ -8975,7 +9129,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) limited_consts = scheme_make_hash_table(SCHEME_hash_ptr); limited_info->top_level_consts = limited_consts; } - scheme_hash_set(limited_consts, scheme_make_integer(pos), e2); + scheme_hash_set(limited_consts, scheme_make_integer(var->variable_pos), e2); } if (sstruct || (SCHEME_TYPE(e2) > _scheme_ir_values_types_)) { @@ -8983,46 +9137,45 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } else { if (!re_consts) re_consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(re_consts, scheme_make_integer(i_m), - scheme_make_integer(pos)); + scheme_hash_set(re_consts, scheme_make_integer(i_m), scheme_make_integer(var->variable_pos)); } } else { /* At least mark it as fixed */ - fixed_table = set_as_fixed(fixed_table, info, tl->position); + fixed_table = set_as_fixed(fixed_table, info, SCHEME_IR_TOPLEVEL_POS(var)); } } } - } else { + } else if (cont) { /* The binding is not inlinable/propagatable, but unless it's set!ed, it is constant after evaluating the definition. We map the top-level position to indicate constantness --- immediately if `cont`, and later if not. */ - Scheme_Object *l, *a; - int pos; - - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - - /* Test for set!: */ - if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) { - pos = SCHEME_TOPLEVEL_POS(a); - - if (cont) - fixed_table = set_as_fixed(fixed_table, info, pos); - else - next_pos_ready = pos; - } - } - } + int i, n = SCHEME_DEFN_VAR_COUNT(defn); + Scheme_IR_Toplevel *var; + + for (i = 0; i < n; i++) { + var = SCHEME_DEFN_VAR(defn, i); + + /* Test for set!: */ + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { + if (!info->top_level_consts + || !scheme_hash_get(info->top_level_consts, (Scheme_Object *)var)) { + fixed_table = set_as_fixed(fixed_table, info, var->variable_pos); + } + } + } + } } else { - cont = scheme_omittable_expr(e, -1, -1, 0, NULL, NULL); + if (i_m + 1 == cnt) + cont = 0; + else + cont = scheme_omittable_expr(e, -1, -1, 0, NULL, NULL); } - if (i_m + 1 == cnt) - cont = 0; - } else + } else { cont = 1; + } - if (!cont) { + if (!cont || (i_m + 1 == cnt)) { Scheme_Object *prop_later = NULL; /* If we have new constants, re-optimize to inline: */ if (consts) { @@ -9038,14 +9191,14 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) while (1) { /* Re-optimize this expression. */ - int old_sz, new_sz; + int old_sz, new_sz, orig_fuel; - e = SCHEME_VEC_ELS(m->bodies[0])[start_simultaneous]; + e = SCHEME_VEC_ELS(linklet->bodies)[start_simultaneous]; if (OPT_DELAY_GROUP_PROPAGATE || OPT_LIMIT_FUNCTION_RESIZE) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { Scheme_Object *sub_e; - sub_e = SCHEME_VEC_ELS(e)[1]; + sub_e = SCHEME_DEFN_RHS(e); old_sz = lambda_body_size(sub_e, 0); } else old_sz = 0; @@ -9053,8 +9206,10 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) old_sz = 0; optimize_info_seq_step(info, &info_seq); - e = scheme_optimize_expr(e, info, 0); - SCHEME_VEC_ELS(m->bodies[0])[start_simultaneous] = e; + orig_fuel = info->inline_fuel; + e = optimize_expr(e, info, 0); + info->inline_fuel = orig_fuel; + SCHEME_VEC_ELS(linklet->bodies)[start_simultaneous] = e; if (re_consts) { /* Install optimized closures into constant table --- @@ -9064,10 +9219,10 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (rpos) { Scheme_Object *old_e; - e = SCHEME_VEC_ELS(e)[1]; + e = SCHEME_DEFN_RHS(e); old_e = scheme_hash_get(info->top_level_consts, rpos); - if (old_e && SCHEME_LAMBDAP(old_e) && OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(1)) { + if (old_e && SCHEME_LAMBDAP(old_e) && OPT_PRE_OPTIMIZE_FOR_CROSS_LINKLET(1)) { if (!originals) originals = scheme_make_hash_table(SCHEME_hash_ptr); scheme_hash_set(originals, scheme_make_integer(start_simultaneous), old_e); @@ -9124,9 +9279,26 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } } - if (next_pos_ready > -1) { - fixed_table = set_as_fixed(fixed_table, info, next_pos_ready); - next_pos_ready = -1; + if (!cont) { + /* Now that the definition is evaluated, its variables are + certainly fixed if they're not `set!`ed. */ + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + int i, n = SCHEME_DEFN_VAR_COUNT(e); + Scheme_IR_Toplevel *var; + + for (i = 0; i < n; i++) { + var = SCHEME_DEFN_VAR(e, i); + + /* Test for set!: */ + if (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_IR_TOPLEVEL_MUTATED)) { + if (!info->top_level_consts + || !scheme_hash_get(info->top_level_consts, (Scheme_Object *)var)) { + fixed_table = set_as_fixed(fixed_table, info, var->variable_pos); + } + } + } + } } } @@ -9135,21 +9307,20 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (info->enforce_const) { for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int size_override; - size_override = SCHEME_IMMUTABLEP(e); - vars = SCHEME_VEC_ELS(e)[0]; - if (SCHEME_PAIRP(vars) && SCHEME_NULLP(SCHEME_CDR(vars))) { + size_override = SCHEME_DEFN_ALWAYS_INLINEP(e); + if (SCHEME_DEFN_VAR_COUNT(e) == 1) { Scheme_Object *sub_e, *alt_e; - sub_e = SCHEME_VEC_ELS(e)[1]; - alt_e = is_cross_module_inline_candidiate(sub_e, info, 0); - if (!alt_e && originals && OPT_PRE_OPTIMIZE_FOR_CROSS_MODULE(size_override)) { + sub_e = SCHEME_DEFN_RHS(e); + alt_e = is_cross_linklet_inline_candidiate(sub_e, info, 0); + if (!alt_e && originals && OPT_PRE_OPTIMIZE_FOR_CROSS_LINKLET(size_override)) { alt_e = scheme_hash_get(originals, scheme_make_integer(i_m)); if (SAME_OBJ(alt_e, sub_e) && !size_override) alt_e = NULL; else if (alt_e) - alt_e = is_cross_module_inline_candidiate(alt_e, info, size_override); + alt_e = is_cross_linklet_inline_candidiate(alt_e, info, size_override); } if (alt_e) { Scheme_Object *iv; @@ -9157,7 +9328,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) iv->type = scheme_inline_variant_type; SCHEME_VEC_ELS(iv)[0] = sub_e; SCHEME_VEC_ELS(iv)[1] = alt_e; - SCHEME_VEC_ELS(e)[1] = iv; + SCHEME_DEFN_RHS(e) = iv; } } } @@ -9169,59 +9340,33 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) int can_omit = 0; for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; + if ((i_m < (cnt - 1)) && scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { can_omit++; } } if (can_omit) { - Scheme_Object *vec; + Scheme_Object *new_bodies; int j = 0; - vec = scheme_make_vector(cnt - can_omit, NULL); + new_bodies = scheme_make_vector(cnt - can_omit, scheme_false); for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (!scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { - SCHEME_VEC_ELS(vec)[j++] = e; + e = SCHEME_VEC_ELS(linklet->bodies)[i_m]; + if ((i_m == (cnt-1)) || !scheme_omittable_expr(e, -1, -1, 0, info, NULL)) { + SCHEME_VEC_ELS(new_bodies)[j++] = e; } } - m->bodies[0] = vec; + linklet->bodies = new_bodies; } cnt -= can_omit; } - info->context = old_context; - info->cp = prev_cp; + /* Record shapes, if any, of imports as used for optimization; also + reflect import usage, so that the resolve pass can remove unused + imports */ + record_optimize_shapes(info, linklet, _import_keys); - /* Exp-time body was optimized during compilation */ - - { - /* optimize submodules */ - int k; - Scheme_Object *p; - for (k = 0; k < 2; k++) { - p = (k ? m->post_submodules : m->pre_submodules); - if (p) { - while (!SCHEME_NULLP(p)) { - optimize_info_seq_step(info, &info_seq); - scheme_optimize_expr(SCHEME_CAR(p), info, 0); - p = SCHEME_CDR(p); - } - } - } - } - - optimize_info_seq_done(info, &info_seq); - - info->escapes = 0; - - return data; -} - -static Scheme_Object * -top_level_require_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - return data; + return linklet; } /*========================================================================*/ @@ -9238,10 +9383,10 @@ static Scheme_Object *optimize_k(void) p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return scheme_optimize_expr(expr, info, context); + return optimize_expr(expr, info, context); } -Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context) +Scheme_Object *optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context) { Scheme_Type type = SCHEME_TYPE(expr); @@ -9278,7 +9423,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in val = optimize_info_propagate_local(expr); if (val) { info->size -= 1; - return scheme_optimize_expr(val, info, context); + return optimize_expr(val, info, context); } val = collapse_local(expr, info, context); @@ -9319,7 +9464,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in o->moved = 1; - val = scheme_optimize_expr(o->expr, info, context); + val = optimize_expr(o->expr, info, context); if (info->maybe_values_argument) { /* Although `val` could be counted as taking 0 time, we advance @@ -9357,7 +9502,6 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in case scheme_application3_type: return optimize_application3(expr, info, context); case scheme_sequence_type: - case scheme_splice_sequence_type: return optimize_sequence(expr, info, context, 1); case scheme_branch_type: return optimize_branch(expr, info, context); @@ -9372,19 +9516,35 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in return optimize_lets(expr, info, context); case scheme_ir_toplevel_type: info->size += 1; - if (info->top_level_consts) { - int pos; + { Scheme_Object *c; while (1) { - pos = SCHEME_TOPLEVEL_POS(expr); - c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + c = get_import_inline(info, (Scheme_IR_Toplevel *)expr, -1, 0); + if (!c) + c = get_defn_shape(info, (Scheme_IR_Toplevel *)expr); c = no_potential_size(c); if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_ir_toplevel_type)) expr = c; else break; } + + if (c) { + if (SAME_OBJ(c, scheme_constant_key)) { + /* can't copy, but constant across instantiations */ + expr = scheme_ir_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); + if (context & OPT_CONTEXT_BOOLEAN) + c = scheme_true; + else + c = NULL; + } else if (SAME_OBJ(c, scheme_fixed_key)) { + /* not constant across instantiations, but at least fixed */ + expr = scheme_ir_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_FIXED); + c = NULL; + } + } else + info->vclock += 1; if (c) { if (context & OPT_CONTEXT_BOOLEAN) @@ -9395,38 +9555,14 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in /* We can't inline, but mark the top level as a constant, so we can direct-jump and avoid null checks in JITed code: */ - expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); - } else { - /* false is mapped to a table of non-constant ready values: */ - c = scheme_hash_get(info->top_level_consts, scheme_false); - if (c) { - c = scheme_hash_get((Scheme_Hash_Table *)c, scheme_make_integer(pos)); - - if (c) { - /* We can't inline, but mark the top level as ready and fixed, - so we can avoid null checks in JITed code, etc: */ - expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_FIXED); - } - } - if (!c) - info->vclock += 1; + expr = scheme_ir_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); } - } else { - info->vclock += 1; } optimize_info_used_top(info); - return expr; - case scheme_ir_quote_syntax_type: - if (context & OPT_CONTEXT_BOOLEAN) - return scheme_true; - else { - info->size += 1; - optimize_info_used_top(info); - } + register_import_used(info, (Scheme_IR_Toplevel *)expr); return expr; case scheme_variable_type: - case scheme_module_variable_type: - scheme_signal_error("got top-level in wrong place"); + scheme_signal_error("got toplevel in wrong place"); return 0; case scheme_define_values_type: return define_values_optimize(expr, info, context); @@ -9434,10 +9570,6 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in return ref_optimize(expr, info, context); case scheme_set_bang_type: return set_optimize(expr, info, context); - case scheme_define_syntaxes_type: - return define_syntaxes_optimize(expr, info, context); - case scheme_begin_for_syntax_type: - return begin_for_syntax_optimize(expr, info, context); case scheme_case_lambda_sequence_type: if (context & OPT_CONTEXT_BOOLEAN) return scheme_true; @@ -9449,10 +9581,6 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in return apply_values_optimize(expr, info, context); case scheme_with_immed_mark_type: return with_immed_mark_optimize(expr, info, context); - case scheme_require_form_type: - return top_level_require_optimize(expr, info, context); - case scheme_module_type: - return module_optimize(expr, info, context); default: info->size += 1; if ((context & OPT_CONTEXT_BOOLEAN) @@ -9488,7 +9616,7 @@ Scheme_Object *optimize_clone(int single_use, Scheme_Object *expr, Optimize_Info case scheme_ir_local_type: { Scheme_Object *v; - v = scheme_hash_tree_get(var_map, expr); + v = scheme_eq_hash_tree_get(var_map, expr); if (v) return v; else if (!single_use) @@ -9624,7 +9752,6 @@ Scheme_Object *optimize_clone(int single_use, Scheme_Object *expr, Optimize_Info } case scheme_sequence_type: case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: { Scheme_Sequence *seq = (Scheme_Sequence *)expr, *seq2; int i; @@ -9686,15 +9813,10 @@ Scheme_Object *optimize_clone(int single_use, Scheme_Object *expr, Optimize_Info case scheme_ir_lambda_type: return clone_lambda(single_use, expr, info, var_map); case scheme_ir_toplevel_type: - case scheme_ir_quote_syntax_type: return expr; case scheme_define_values_type: - case scheme_define_syntaxes_type: - case scheme_begin_for_syntax_type: case scheme_boxenv_type: return NULL; - case scheme_require_form_type: - return NULL; case scheme_varref_form_type: return ref_clone(single_use, expr, info, var_map); case scheme_set_bang_type: @@ -9705,8 +9827,6 @@ Scheme_Object *optimize_clone(int single_use, Scheme_Object *expr, Optimize_Info return with_immed_mark_clone(single_use, expr, info, var_map); case scheme_case_lambda_sequence_type: return case_lambda_clone(single_use, expr, info, var_map); - case scheme_module_type: - return NULL; default: if (t > _scheme_ir_values_types_) { if (single_use || scheme_ir_duplicate_ok(expr, 0)) @@ -9721,7 +9841,8 @@ Scheme_Object *optimize_clone(int single_use, Scheme_Object *expr, Optimize_Info /* compile-time env for optimization */ /*========================================================================*/ -Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, int get_logger) +static Optimize_Info *optimize_info_allocate(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode) { Optimize_Info *info; @@ -9731,16 +9852,27 @@ Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, Scheme_Env *env, Sch #endif info->inline_fuel = INITIAL_INLINING_FUEL; info->flatten_fuel = INITIAL_FLATTENING_FUEL; - info->cp = cp; - info->env = env; - info->insp = insp; + info->linklet = linklet; - if (get_logger) { - Scheme_Logger *logger; - logger = (Scheme_Logger *)scheme_get_param(scheme_current_config(), MZCONFIG_LOGGER); - logger = scheme_make_logger(logger, scheme_intern_symbol("optimizer")); - info->logger = logger; - } + info->enforce_const = enforce_const; + if (!can_inline) + info->inline_fuel = -1; + info->unsafe_mode = unsafe_mode; + + return info; +} + +static Optimize_Info *optimize_info_create(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode) +{ + Optimize_Info *info; + Scheme_Logger *logger; + + info = optimize_info_allocate(linklet, enforce_const, can_inline, unsafe_mode); + + logger = (Scheme_Logger *)scheme_get_param(scheme_current_config(), MZCONFIG_LOGGER); + logger = scheme_make_logger(logger, scheme_intern_symbol("optimizer")); + info->logger = logger; return info; } @@ -9764,21 +9896,6 @@ static void optimize_info_seq_done(Optimize_Info *info, Optimize_Info_Sequence * info->flatten_fuel = info_seq->min_flatten_fuel; } -void scheme_optimize_info_enforce_const(Optimize_Info *oi, int enforce_const) -{ - oi->enforce_const = enforce_const; -} - -void scheme_optimize_info_set_context(Optimize_Info *oi, Scheme_Object *ctx) -{ - oi->context = ctx; -} - -void scheme_optimize_info_never_inline(Optimize_Info *oi) -{ - oi->inline_fuel = -1; -} - static void propagate_used_variables(Optimize_Info *info) { Scheme_Hash_Table *ht; @@ -9860,6 +9977,7 @@ static int optimize_any_uses(Optimize_Info *info, Scheme_IR_Let_Value *at_irlv, Scheme_IR_Let_Value *irlv = at_irlv; while (n--) { + MZ_ASSERT(SAME_TYPE(irlv->iso.so.type, scheme_ir_let_value_type)); for (i = irlv->count; i--; ) { if (irlv->vars[i]->optimize_used) return 1; @@ -10005,7 +10123,7 @@ Scheme_Object *optimize_get_predicate(Optimize_Info *info, Scheme_Object *var, i while (info) { if (info->types) { - pred = scheme_hash_tree_get(info->types, var); + pred = scheme_eq_hash_tree_get(info->types, var); if (pred) return pred; } @@ -10015,19 +10133,18 @@ Scheme_Object *optimize_get_predicate(Optimize_Info *info, Scheme_Object *var, i return NULL; } -static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags) +static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int flags) { Optimize_Info *naya; - naya = scheme_optimize_info_create(info->cp, info->env, info->insp, 0); + naya = optimize_info_allocate(info->linklet, 0, 0, 0); naya->flags = (short)flags; naya->next = info; - naya->original_frame = orig; - naya->new_frame = current; naya->inline_fuel = info->inline_fuel; naya->flatten_fuel = info->flatten_fuel; naya->letrec_not_twice = info->letrec_not_twice; naya->enforce_const = info->enforce_const; + naya->unsafe_mode = info->unsafe_mode; naya->top_level_consts = info->top_level_consts; naya->context = info->context; naya->vclock = info->vclock; @@ -10043,6 +10160,8 @@ static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int naya->lambda_depth = info->lambda_depth + ((flags & SCHEME_LAMBDA_FRAME) ? 1 : 0); naya->uses = info->uses; naya->transitive_use_var = info->transitive_use_var; + naya->cross = info->cross; + naya->imports_used = info->imports_used; return naya; } @@ -10063,6 +10182,611 @@ static void optimize_info_done(Optimize_Info *info, Optimize_Info *parent) parent->has_nonleaf = 1; } + +/*========================================================================*/ +/* shapes from linklet imports */ +/*========================================================================*/ + +static int is_procedure_expression(Scheme_Object *e) +{ + Scheme_Type t; + + if (SCHEME_PROCP(e)) + return 1; + + t = SCHEME_TYPE(e); + + return ((t == scheme_lambda_type) + || (t == scheme_case_lambda_sequence_type)); +} + +static void linklet_setup_constants(Scheme_Linklet *linklet) +{ + int i, cnt, k, defns_start; + Scheme_Object *form, *tl; + Scheme_Hash_Table *ht; + + if (linklet->constants) + return; + + /* find constants: */ + ht = scheme_make_hash_table(SCHEME_hash_ptr); + linklet->constants = ht; + + defns_start = 1 + linklet->num_total_imports; + + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for (i = 0; i < cnt; i++) { + form = SCHEME_VEC_ELS(linklet->bodies)[i]; + + if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { + int checked_st = 0, is_st_prop = 0, has_guard = 0; + Scheme_Object *is_st = NULL; + Simple_Struct_Type_Info stinfo; + Scheme_Object *parent_identity; + + for (k = SCHEME_DEFN_VAR_COUNT(form); k--; ) { + tl = (Scheme_Object *)SCHEME_DEFN_VAR(form, k); + if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { + int pos = SCHEME_TOPLEVEL_POS(tl) - defns_start; + + if (pos < linklet->num_exports) { + Scheme_Object *v; + + if (SCHEME_DEFN_VAR_COUNT(form) == 1) { + if (scheme_ir_duplicate_ok(SCHEME_DEFN_RHS(form), 1)) { + /* record simple constant for cross-linklet propagation: */ + v = SCHEME_DEFN_RHS(form); + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_DEFN_RHS(form)), scheme_inline_variant_type)) { + /* record a potentially inlineable function */ + v = SCHEME_DEFN_RHS(form); + } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { + /* record that it's a procedure: */ + v = scheme_make_vector(2, scheme_false); + SCHEME_VEC_ELS(v)[0] = SCHEME_DEFN_RHS(form); + } else { + /* record that it's fixed for any given instantiation: */ + v = scheme_fixed_key; + } + } else { + if (!checked_st) { + if (scheme_is_simple_make_struct_type(SCHEME_DEFN_RHS(form), + SCHEME_DEFN_VAR_COUNT(form), + CHECK_STRUCT_TYPE_RESOLVED, + NULL, &stinfo, &parent_identity, + NULL, NULL, NULL, 0, linklet, + &is_st, + 5)) { + is_st = scheme_make_pair(is_st, parent_identity); + } else { + is_st = NULL; + if (scheme_is_simple_make_struct_type_property(SCHEME_VEC_ELS(form)[0], + SCHEME_VEC_SIZE(form)-1, + CHECK_STRUCT_TYPE_RESOLVED, + &has_guard, + NULL, NULL, NULL, 0, linklet, + 5)) + is_st_prop = 1; + } + checked_st = 1; + } + if (is_st) { + intptr_t shape; + shape = scheme_get_struct_proc_shape(k, &stinfo); + /* Vector of size 3 => struct shape */ + v = scheme_make_vector(3, scheme_false); + SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); + SCHEME_VEC_ELS(v)[2] = is_st; + } else if (is_st_prop) { + intptr_t shape; + shape = scheme_get_struct_property_proc_shape(k, has_guard); + /* Vector of size 4 => struct property shape */ + v = scheme_make_vector(4, scheme_false); + SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); + } else + v = NULL; + } + if (v) + scheme_hash_set(ht, SCHEME_VEC_ELS(linklet->defns)[pos], v); + } + } + } + } + } +} + +static Scheme_Object *get_linklet_or_instance_for_import_key(Optimize_Info *info, Scheme_Object *key) +{ + Scheme_Object *v, *next_keys, *a[1]; + Cross_Linklet_Info *cross = info->cross; + Scheme_Hash_Tree *ht; + + if (!cross || !cross->get_import) + return NULL; + + v = scheme_hash_tree_get(cross->linklets, key); + if (!v) { + a[0] = key; + v = scheme_apply_multi(cross->get_import, 1, a); + if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES) + && (scheme_current_thread->ku.multiple.count == 2)) { + v = scheme_current_thread->ku.multiple.array[0]; + next_keys = scheme_current_thread->ku.multiple.array[1]; + } else { + scheme_wrong_return_arity("compile-linklet", + 2, + (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES) + ? scheme_current_thread->ku.multiple.count + : 1), + (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES) + ? (Scheme_Object **)v + : scheme_current_thread->ku.multiple.array), + ""); + return NULL; + } + + ht = scheme_hash_tree_set(cross->linklets, key, v); + cross->linklets = ht; + + if (!SCHEME_FALSEP(v)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type) + && !SAME_TYPE(SCHEME_TYPE(v), scheme_instance_type)) + scheme_wrong_contract("compile-linklet", "(or/c linklet? instance? #f)", -1, 0, &v); + + if (!SCHEME_FALSEP(next_keys) + && (!SCHEME_VECTORP(next_keys) + || !SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type) + || SCHEME_VEC_SIZE(next_keys) != SCHEME_VEC_SIZE(((Scheme_Linklet *)v)->importss))) + scheme_contract_error("compile-linklet", + "result is not #f or a vector of keys that match the result linklet's import count", + (SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type) ? "linklet" : "instance"), 1, v, + "import count", 1, scheme_make_integer(SCHEME_VEC_SIZE(((Scheme_Linklet *)v)->importss)), + "invalid as vector of keys", 1, next_keys, + NULL); + + if (SCHEME_TRUEP(next_keys)) { + ht = scheme_hash_tree_set(cross->import_next_keys, key, next_keys); + cross->import_next_keys = ht; + } + } + } + + if (SCHEME_FALSEP(v)) + return NULL; + + return v; +} + +static Scheme_Object *get_import_inline_or_shape(Optimize_Info *info, Scheme_IR_Toplevel *var, + int argc, int want_shape, int for_props) +/* Returns either a procedure shape, a value to inline, or (when `for_props`) + a function to be used just for its properties. The + special values scheme_constant_key and scheme_fixed_key may be + returned. If `argc` is less than 0, then scheme_constant_key is + returned for procedures. If `want_shape` or `argc` is less than 0 + and a non-NULL value is returned, then `info` records the fact that + shape information is used. */ +{ + Scheme_Object *key, *v, *name, *l_or_i; + Scheme_Hash_Table *iv_ht; + Scheme_Linklet *linklet; + + if (!info->cross || (var->instance_pos < 0)) + return NULL; + + key = scheme_hash_tree_get(info->cross->import_keys, scheme_make_integer(var->instance_pos)); + if (!key) + return NULL; + + l_or_i = get_linklet_or_instance_for_import_key(info, key); + + if (!l_or_i) + return NULL; + + if ((var->instance_pos < SCHEME_VEC_SIZE(info->linklet->importss)) + && (var->variable_pos < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(info->linklet->importss)[var->instance_pos]))) + name = SCHEME_VEC_ELS(SCHEME_VEC_ELS(info->linklet->importss)[var->instance_pos])[var->variable_pos]; + else { + Scheme_Hash_Tree *ht; + ht = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(info->cross->import_syms, + scheme_make_integer(var->instance_pos)); + MZ_ASSERT(ht); + name = scheme_eq_hash_tree_get(ht, scheme_make_integer(var->variable_pos)); + } + MZ_ASSERT(name); + MZ_ASSERT(SCHEME_SYMBOLP(name)); + + if (SAME_TYPE(SCHEME_TYPE(l_or_i), scheme_linklet_type)) { + linklet = (Scheme_Linklet *)l_or_i; + + if (!linklet->constants) + linklet_setup_constants(linklet); + + if (!want_shape && !for_props && (argc >= 0)) { + /* check for previously unresolved for this linklet: */ + iv_ht = (Scheme_Hash_Table *)scheme_eq_hash_tree_get(info->cross->inline_variants, key); + if (iv_ht) { + v = scheme_hash_get(iv_ht, name); + if (v) { + /* We have previously unresolved to `v` */ + if (SCHEME_HASHTP(v)) { + /* It's a `case-lambda`, so try to get the right clause */ + v = scheme_hash_get((Scheme_Hash_Table *)v, scheme_make_integer(argc)); + if (v) + return v; + /* Try to unresolve the right arity */ + } else if (SCHEME_FALSEP(v)) { + /* previous unresove attempt failed */ + return NULL; + } else + return v; + } + } + /* Otherwise, not yet unresolved (maybe because it doesn't need to be) */ + } else + iv_ht = NULL; + + v = scheme_hash_get(linklet->constants, name); + + if (!v) + return NULL; + + if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 2)) { + /* a procedure */ + if (want_shape) + v = scheme_get_or_check_procedure_shape(SCHEME_VEC_ELS(v)[0], NULL, 0); + else if (for_props) + return SCHEME_VEC_ELS(v)[0]; + else if (argc < 0) + v = scheme_constant_key; + else + v = NULL; + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_inline_variant_type)) { + /* a procedure that can be inlined (if unresolve succeeds) */ + if (for_props) { + return SCHEME_VEC_ELS(v)[0]; + } else if (want_shape) { + v = scheme_get_or_check_procedure_shape(v, NULL, 0); + if (v) + info->cross->used_import_shape = 1; + } else if (argc >= 0) { + int has_cases = 0; + + v = scheme_unresolve(v, argc, &has_cases, linklet, key, info); + + if (!iv_ht) { + Scheme_Hash_Tree *ht; + iv_ht = scheme_make_hash_table(SCHEME_hash_ptr); + ht = scheme_hash_tree_set(info->cross->inline_variants, key, (Scheme_Object *)iv_ht); + info->cross->inline_variants = ht; + } + + /* Save unresolved */ + if (has_cases) { + Scheme_Hash_Table *cl_ht; + cl_ht = (Scheme_Hash_Table *)scheme_hash_get(iv_ht, name); + if (!cl_ht) { + cl_ht = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(iv_ht, name, (Scheme_Object *)cl_ht); + } + scheme_hash_set(cl_ht, scheme_make_integer(argc), v); + } else if (v) + scheme_hash_set(iv_ht, name, v); + else + scheme_hash_set(iv_ht, name, scheme_false); /* record that it won't work */ + } else + v = scheme_constant_key; + } else if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) { + if (want_shape) + v = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1]), + SCHEME_VEC_ELS(v)[2]); + else if ((argc < 0) || for_props) + v = scheme_constant_key; + else + v = NULL; + } else if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 4)) { + if (want_shape) + v = scheme_make_struct_property_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1])); + else if ((argc < 0) || for_props) + v = scheme_constant_key; + else + v = NULL; + } + } else { + Scheme_Bucket *b; + int imprecise = SCHEME_INSTANCE_FLAGS((Scheme_Instance *)l_or_i) & SCHEME_INSTANCE_USE_IMPRECISE; + b = scheme_instance_variable_bucket_or_null(name, (Scheme_Instance *)l_or_i); + if (b && b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) { + v = b->val; + if (want_shape) + v = get_value_shape(v, imprecise); + else if (argc < 0) + v = scheme_constant_key; + else + v = NULL; + } else + v = NULL; + } + + if (v && (want_shape || (argc < 0))) + info->cross->used_import_shape = 1; + + return v; +} + +Scheme_Object *scheme_optimize_add_import_variable(Optimize_Info *info, Scheme_Object *linklet_key, Scheme_Object *symbol) +/* Called from unresolver (for cross-linklet inlining) to find or add + an imported variable from an existing instance import */ +{ + Scheme_Object *pos, *var_pos, *vec; + Scheme_Hash_Tree *syms, *ht; + int i; + + if (SCHEME_FALSEP(linklet_key)) + return NULL; + + pos = scheme_hash_tree_get(info->cross->rev_import_keys, linklet_key); + MZ_ASSERT(pos); + + syms = (Scheme_Hash_Tree *)scheme_hash_tree_get(info->cross->import_syms, pos); + if (!syms) { + syms = empty_eq_hash_tree; + if (SCHEME_INT_VAL(pos) < SCHEME_VEC_SIZE(info->linklet->importss)) { + /* initialize from the linklet that we're optimizing */ + vec = SCHEME_VEC_ELS(info->linklet->importss)[SCHEME_INT_VAL(pos)]; + for (i = SCHEME_VEC_SIZE(vec); i--; ) { + syms = scheme_hash_tree_set(syms, SCHEME_VEC_ELS(vec)[i], scheme_make_integer(i)); + syms = scheme_hash_tree_set(syms, scheme_make_integer(i), SCHEME_VEC_ELS(vec)[i]); + } + } else { + /* must not have imported anything, yet, so the empty table is correct */ + } + ht = scheme_hash_tree_set(info->cross->import_syms, pos, (Scheme_Object *)syms); + info->cross->import_syms = ht; + } + + var_pos = scheme_hash_tree_get(syms, symbol); + if (!var_pos) { + var_pos = scheme_make_integer(syms->count >> 1); + syms = scheme_hash_tree_set(syms, symbol, var_pos); + syms = scheme_hash_tree_set(syms, var_pos, symbol); + ht = scheme_hash_tree_set(info->cross->import_syms, pos, (Scheme_Object *)syms); + info->cross->import_syms = ht; + } + + /* SCHEME_TOPLEVEL_READY is conservative; optimizer can compute a refinement later */ + return (Scheme_Object *)scheme_make_ir_toplevel(SCHEME_INT_VAL(pos), SCHEME_INT_VAL(var_pos), SCHEME_TOPLEVEL_READY); +} + +Scheme_Object *scheme_optimize_get_import_key(Optimize_Info *info, Scheme_Object *linklet_key, int instance_pos) +/* Called from unresolver (for cross-linklet inlining) to find or add + an imported instance */ +{ + Scheme_Object *next_keys, *key, *pos; + Scheme_Hash_Tree *ht; + + next_keys = scheme_hash_tree_get(info->cross->import_next_keys, linklet_key); + if (!next_keys) { + /* chaining is not supported by the compilation client */ + return NULL; + } + + MZ_ASSERT(instance_pos < SCHEME_VEC_SIZE(next_keys)); + + key = SCHEME_VEC_ELS(next_keys)[instance_pos]; + pos = scheme_hash_tree_get(info->cross->rev_import_keys, key); + if (!pos) { + /* Add this linklet as an import */ + pos = scheme_make_integer(info->cross->import_keys->count); + + ht = scheme_hash_tree_set(info->cross->import_keys, pos, key); + info->cross->import_keys = ht; + + ht = scheme_hash_tree_set(info->cross->rev_import_keys, key, pos); + info->cross->rev_import_keys = ht; + } + + return key; +} + +static Scheme_Object *get_import_shape(Optimize_Info *info, Scheme_IR_Toplevel *var) +{ + return get_import_inline_or_shape(info, var, -1, 1, 0); +} + +static Scheme_Object *get_import_inline(Optimize_Info *info, Scheme_IR_Toplevel *var, int argc, int for_props) +/* argc < 0 => scheme_constant_key for non-copyable procedures */ +{ + return get_import_inline_or_shape(info, var, argc, 0, for_props); +} + +static void register_import_used(Optimize_Info *info, Scheme_IR_Toplevel *var) +{ + if ((var->instance_pos >= 0) && info->imports_used) { + /* Record that the import is used. The resolve pass can + drop references that have been optimized away. */ + Scheme_Hash_Tree *ht; + ht = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(*info->imports_used, scheme_make_integer(var->instance_pos)); + if (!ht) + ht = empty_eq_hash_tree; + if (!scheme_eq_hash_tree_get(ht, scheme_make_integer(var->variable_pos))) { + ht = scheme_hash_tree_set(ht, scheme_make_integer(var->variable_pos), scheme_true); + ht = scheme_hash_tree_set(*info->imports_used, scheme_make_integer(var->instance_pos), (Scheme_Object *)ht); + (*info->imports_used) = ht; + } + } +} + +static void record_optimize_shapes(Optimize_Info *info, Scheme_Linklet *linklet, Scheme_Object **_import_keys) +{ + int i, j, k, used, total, added_imports = 0, dropped_imports = 0, total_used; + Scheme_Object *shapes, *v, *name; + Scheme_Linklet *in_linklet; + Scheme_Instance *in_instance; + Scheme_Hash_Tree *ht; + Scheme_Bucket *b; + + if (info->cross) { + /* Add new imported instances */ + if (info->cross->import_keys->count > SCHEME_VEC_SIZE(linklet->importss)) { + added_imports = SCHEME_VEC_SIZE(linklet->importss) - info->cross->import_keys->count; + v = scheme_make_vector(info->cross->import_keys->count, scheme_make_vector(0, NULL)); + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + SCHEME_VEC_ELS(v)[i] = SCHEME_VEC_ELS(linklet->importss)[i]; + } + linklet->importss = v; + } + + /* Add imported variables for each instance */ + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + ht = (Scheme_Hash_Tree *)scheme_hash_tree_get(info->cross->import_syms, scheme_make_integer(i)); + if (ht && ((ht->count >> 1) > SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]))) { + Scheme_Object *sym; + v = scheme_make_vector((ht->count >> 1), NULL); + SCHEME_VEC_ELS(linklet->importss)[i] = v; + + for (j = ht->count >> 1; j--; ) { + sym = scheme_eq_hash_tree_get(ht, scheme_make_integer(j)); + MZ_ASSERT(sym); + SCHEME_VEC_ELS(v)[j] = sym; + } + } + } + } + + /* Prune unused imports (or, more precisely, tell the resolver how to prune) */ + total_used = 0; + total = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + used = 0; + k = SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); + total += k; + if (info->imports_used) { + ht = (Scheme_Hash_Tree *)scheme_eq_hash_tree_get(*info->imports_used, scheme_make_integer(i)); + if (!ht) ht = empty_eq_hash_tree; + for (j = 0; j < k; j++) { + if (!scheme_eq_hash_tree_get(ht, scheme_make_integer(j))) { + /* Set symbol to #f to communicate non-use to the resolve pass: */ + SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j] = scheme_false; + } else + used++; + } + } else + used += k; + total_used += used; + if (!used && _import_keys + /* When a key is #f or an instance, then dropping is not allowed */ + && ((i >= SCHEME_VEC_SIZE(*_import_keys)) + || (SCHEME_TRUEP(SCHEME_VEC_ELS(*_import_keys)[i]) + && !SAME_TYPE(scheme_instance_type, SCHEME_TYPE(SCHEME_VEC_ELS(*_import_keys)[i]))))) { + dropped_imports++; + /* A number commuicates to the resolve pass that the import + instance had that many variables, but we can drop it + entirely */ + SCHEME_VEC_ELS(linklet->importss)[i] = scheme_make_integer(k); + } + } + linklet->num_total_imports = total; + + if (dropped_imports || added_imports) { + /* Report a revised set of imports back to the client */ + v = scheme_make_vector(SCHEME_VEC_SIZE(linklet->importss) - dropped_imports, NULL); + *_import_keys = v; + used = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + if (!SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) { + v = scheme_hash_tree_get(info->cross->import_keys, scheme_make_integer(i)); + MZ_ASSERT(v); + SCHEME_VEC_ELS((*_import_keys))[used++] = v; + } + } + MZ_ASSERT(used == (SCHEME_VEC_SIZE(linklet->importss) - dropped_imports)); + } + + if (info->cross && info->cross->used_import_shape) { + /* The import-shapes vector needs only the imports that will be kept */ + shapes = scheme_make_vector(total_used, scheme_false); + linklet->import_shapes = shapes; + k = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + if (!SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) { + v = scheme_hash_tree_get(info->cross->import_keys, scheme_make_integer(i)); + if (v) + v = scheme_hash_tree_get(info->cross->linklets, v); + in_linklet = ((v && SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_type)) ? (Scheme_Linklet *)v : NULL); + in_instance = ((v && SAME_TYPE(SCHEME_TYPE(v), scheme_instance_type)) ? (Scheme_Instance *)v : NULL); + MZ_ASSERT(!in_linklet || SAME_TYPE(in_linklet->so.type, scheme_linklet_type)); + MZ_ASSERT(!in_instance || SAME_TYPE(in_instance->iso.so.type, scheme_instance_type)); + for (j = 0; j < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j++) { + name = SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j]; + if (SCHEME_TRUEP(name)) { + if (in_linklet && in_linklet->constants) { + v = scheme_hash_get(in_linklet->constants, name); + if (v) { + if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) { + v = scheme_intern_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1])); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 4)) { + v = scheme_intern_struct_prop_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[1])); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SCHEME_VECTORP(v)) { + MZ_ASSERT(SCHEME_VEC_SIZE(v) == 2); + v = scheme_get_or_check_procedure_shape(SCHEME_VEC_ELS(v)[0], NULL, 0); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_inline_variant_type)) { + v = scheme_get_or_check_procedure_shape(v, NULL, 0); + SCHEME_VEC_ELS(shapes)[k] = v; + } else if (SAME_OBJ(v, scheme_fixed_key)) { + SCHEME_VEC_ELS(shapes)[k] = scheme_void; + } else { + /* anything else is constant-propagated or irrelevant */ + } + } + } else if (in_instance) { + b = scheme_instance_variable_bucket_or_null(name, in_instance); + if (b && b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) { + int imprecise = SCHEME_INSTANCE_FLAGS(in_instance) & SCHEME_INSTANCE_USE_IMPRECISE; + v = get_value_shape(b->val, imprecise); + if (v) { + if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) + v = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(v)); + else if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_prop_proc_shape_type)) + v = scheme_intern_struct_prop_proc_shape(SCHEME_PROP_PROC_SHAPE_MODE(v)); + SCHEME_VEC_ELS(shapes)[k] = v; + } else + SCHEME_VEC_ELS(shapes)[k] = scheme_void; + } + } + k++; + } + } + } + } + MZ_ASSERT(k == total_used); + } +} + +static Scheme_Object *get_value_shape(Scheme_Object *v, int imprecise) +{ + intptr_t s; + Scheme_Object *identity; + + s = scheme_get_or_check_structure_shape(v, NULL); + if (s != -1) { + if (SCHEME_STRUCT_TYPEP(v)) + identity = v; + else + identity = SCHEME_PRIM_CLOSURE_ELS(v)[0]; + return scheme_make_struct_proc_shape(s, identity); + } + + s = scheme_get_or_check_structure_property_shape(v, NULL); + if (s != -1) + return scheme_make_struct_property_proc_shape(s); + + return scheme_get_or_check_procedure_shape(v, NULL, imprecise); +} + /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff --git a/racket/src/racket/src/place.c b/racket/src/racket/src/place.c index e8b7c954a1..07cc1f1ffd 100644 --- a/racket/src/racket/src/place.c +++ b/racket/src/racket/src/place.c @@ -100,13 +100,13 @@ static void register_traversers(void); static void *place_start_proc(void *arg); MZ_DO_NOT_INLINE(static void *place_start_proc_after_stack(void *data_arg, void *stack_base)); -# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) +# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) ADD_PRIM_W_ARITY(name, func, a1, a2, env) #else SHARED_OK static int scheme_places_enabled = 0; -# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, not_implemented, a1, a2, env) +# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) ADD_PRIM_W_ARITY(name, not_implemented, a1, a2, env) static Scheme_Object *not_implemented(int argc, Scheme_Object **argv) { @@ -124,39 +124,35 @@ static void register_traversers(void) { } /* initialization */ /*========================================================================*/ -void scheme_init_place(Scheme_Env *env) +void scheme_init_place(Scheme_Startup_Env *env) { - Scheme_Env *plenv; - #ifdef MZ_PRECISE_GC register_traversers(); #endif - - plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env); - GLOBAL_PRIM_W_ARITY("place-enabled?", scheme_place_enabled, 0, 0, plenv); - GLOBAL_PRIM_W_ARITY("place-shared?", scheme_place_shared, 1, 1, plenv); - PLACE_PRIM_W_ARITY("dynamic-place", scheme_place, 5, 5, plenv); - PLACE_PRIM_W_ARITY("place-pumper-threads", place_pumper_threads, 1, 2, plenv); - PLACE_PRIM_W_ARITY("place-sleep", place_sleep, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-wait", place_wait, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-kill", place_kill, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-break", place_break, 1, 2, plenv); - PLACE_PRIM_W_ARITY("place?", place_p, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-channel", place_channel, 0, 0, plenv); - PLACE_PRIM_W_ARITY("place-channel-put", place_send, 2, 2, plenv); - PLACE_PRIM_W_ARITY("place-channel-get", place_receive, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-channel?", place_channel_p, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-message-allowed?", place_allowed_p, 1, 1, plenv); - PLACE_PRIM_W_ARITY("place-dead-evt", make_place_dead, 1, 1, plenv); + scheme_switch_prim_instance(env, "#%place"); - scheme_finish_primitive_module(plenv); + ADD_PRIM_W_ARITY("place-enabled?", scheme_place_enabled, 0, 0, env); + ADD_PRIM_W_ARITY("place-shared?", scheme_place_shared, 1, 1, env); + PLACE_PRIM_W_ARITY("dynamic-place", scheme_place, 5, 5, env); + PLACE_PRIM_W_ARITY("place-pumper-threads", place_pumper_threads, 1, 2, env); + PLACE_PRIM_W_ARITY("place-sleep", place_sleep, 1, 1, env); + PLACE_PRIM_W_ARITY("place-wait", place_wait, 1, 1, env); + PLACE_PRIM_W_ARITY("place-kill", place_kill, 1, 1, env); + PLACE_PRIM_W_ARITY("place-break", place_break, 1, 2, env); + PLACE_PRIM_W_ARITY("place?", place_p, 1, 1, env); + PLACE_PRIM_W_ARITY("place-channel", place_channel, 0, 0, env); + PLACE_PRIM_W_ARITY("place-channel-put", place_send, 2, 2, env); + PLACE_PRIM_W_ARITY("place-channel-get", place_receive, 1, 1, env); + PLACE_PRIM_W_ARITY("place-channel?", place_channel_p, 1, 1, env); + PLACE_PRIM_W_ARITY("place-message-allowed?", place_allowed_p, 1, 1, env); + PLACE_PRIM_W_ARITY("place-dead-evt", make_place_dead, 1, 1, env); - /* Treat place creation as "unsafe", since the new place starts with - permissive guards that can access unsafe features that affect - existing places. */ - scheme_protect_primitive_provide(plenv, scheme_intern_symbol("dynamic-place")); + scheme_restore_prim_instance(env); +} +void scheme_init_place_per_place() +{ #ifdef MZ_USE_PLACES REGISTER_SO(all_child_places); @@ -264,6 +260,12 @@ static void close_six_fds(rktio_fd_t **rw) { } } +static int is_predefined_module_path(Scheme_Object *v) +{ + /* Every table of primitives should have a corresponding predefined module */ + return !!scheme_hash_get(scheme_startup_env->primitive_tables, v); +} + Scheme_Object *place_pumper_threads(int argc, Scheme_Object *args[]) { Scheme_Place *place; Scheme_Object *tmp; @@ -343,7 +345,7 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { out_arg = args[3]; err_arg = args[4]; - if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0]) && !SCHEME_MODNAMEP(args[0])) { + if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0]) && !scheme_is_resolved_module_path(args[0])) { scheme_wrong_contract("dynamic-place", "(or/c module-path? path? resolved-module-path?)", 0, argc, args); } if (!SCHEME_SYMBOLP(args[1])) { @@ -361,7 +363,7 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { if (SCHEME_PAIRP(args[0]) && SAME_OBJ(SCHEME_CAR(args[0]), quote_symbol) - && !scheme_is_predefined_module_p(args[0])) { + && !is_predefined_module_path(args[0])) { scheme_contract_error("dynamic-place", "not a filesystem or predefined module-path", "module path", 1, args[0], NULL); @@ -2358,13 +2360,10 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) { saved_error_buf = p->error_buf; p->error_buf = &new_error_buf; if (!scheme_setjmp(new_error_buf)) { - Scheme_Object *dynamic_require; - if (!scheme_rktio) scheme_signal_error("place: I/O manager initialization failed"); - dynamic_require = scheme_builtin_value("dynamic-require"); - place_main = scheme_apply(dynamic_require, 2, a); + place_main = scheme_dynamic_require(2, a); a[0] = channel; (void)scheme_apply(place_main, 1, a); rc = scheme_make_integer(0); diff --git a/racket/src/racket/src/port.c b/racket/src/racket/src/port.c index 062d8f16eb..39e33639e7 100644 --- a/racket/src/racket/src/port.c +++ b/racket/src/racket/src/port.c @@ -296,7 +296,7 @@ typedef struct Scheme_Filesystem_Change_Evt { /*========================================================================*/ void -scheme_init_port (Scheme_Env *env) +scheme_init_port (Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -385,17 +385,17 @@ scheme_init_port (Scheme_Env *env) scheme_null_output_port_type = scheme_make_port_type(""); scheme_redirect_output_port_type = scheme_make_port_type(""); - scheme_add_global_constant("subprocess", scheme_make_prim_w_arity2(subprocess, "subprocess", 4, -1, 4, 4), env); - scheme_add_global_constant("subprocess-status", scheme_make_prim_w_arity(subprocess_status, "subprocess-status", 1, 1), env); - scheme_add_global_constant("subprocess-kill", scheme_make_prim_w_arity(subprocess_kill, "subprocess-kill", 2, 2), env); - scheme_add_global_constant("subprocess-pid", scheme_make_prim_w_arity(subprocess_pid, "subprocess-pid", 1, 1), env); - scheme_add_global_constant("subprocess?", scheme_make_prim_w_arity(subprocess_p, "subprocess?", 1, 1), env); - scheme_add_global_constant("subprocess-wait", scheme_make_prim_w_arity(subprocess_wait, "subprocess-wait", 1, 1), env); + scheme_addto_prim_instance("subprocess", scheme_make_prim_w_arity2(subprocess, "subprocess", 4, -1, 4, 4), env); + scheme_addto_prim_instance("subprocess-status", scheme_make_prim_w_arity(subprocess_status, "subprocess-status", 1, 1), env); + scheme_addto_prim_instance("subprocess-kill", scheme_make_prim_w_arity(subprocess_kill, "subprocess-kill", 2, 2), env); + scheme_addto_prim_instance("subprocess-pid", scheme_make_prim_w_arity(subprocess_pid, "subprocess-pid", 1, 1), env); + scheme_addto_prim_instance("subprocess?", scheme_make_prim_w_arity(subprocess_p, "subprocess?", 1, 1), env); + scheme_addto_prim_instance("subprocess-wait", scheme_make_prim_w_arity(subprocess_wait, "subprocess-wait", 1, 1), env); - GLOBAL_PARAMETER("subprocess-group-enabled", subproc_group_on, MZCONFIG_SUBPROC_GROUP_ENABLED, env); - GLOBAL_PARAMETER("current-subprocess-custodian-mode", current_subproc_cust_mode, MZCONFIG_SUBPROC_CUSTODIAN_MODE, env); + ADD_PARAMETER("subprocess-group-enabled", subproc_group_on, MZCONFIG_SUBPROC_GROUP_ENABLED, env); + ADD_PARAMETER("current-subprocess-custodian-mode", current_subproc_cust_mode, MZCONFIG_SUBPROC_CUSTODIAN_MODE, env); - scheme_add_global_constant("shell-execute", scheme_make_prim_w_arity(sch_shell_execute, "shell-execute", 5, 5), env); + scheme_addto_prim_instance("shell-execute", scheme_make_prim_w_arity(sch_shell_execute, "shell-execute", 5, 5), env); } void scheme_init_port_wait() @@ -410,15 +410,15 @@ void scheme_init_port_wait() filesystem_change_evt_need_wakeup, NULL, 1); } -void scheme_init_unsafe_port (Scheme_Env *env) +void scheme_init_unsafe_port (Scheme_Startup_Env *env) { - GLOBAL_PRIM_W_ARITY("unsafe-file-descriptor->port", unsafe_fd_to_port, 3, 3, env); - GLOBAL_PRIM_W_ARITY("unsafe-port->file-descriptor", unsafe_port_to_fd, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-file-descriptor->semaphore", unsafe_fd_to_semaphore, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-file-descriptor->port", unsafe_fd_to_port, 3, 3, env); + ADD_PRIM_W_ARITY("unsafe-port->file-descriptor", unsafe_port_to_fd, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-file-descriptor->semaphore", unsafe_fd_to_semaphore, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-socket->port", unsafe_socket_to_port, 3, 3, env); - GLOBAL_PRIM_W_ARITY("unsafe-port->socket", unsafe_port_to_socket, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-socket->semaphore", unsafe_socket_to_semaphore, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-socket->port", unsafe_socket_to_port, 3, 3, env); + ADD_PRIM_W_ARITY("unsafe-port->socket", unsafe_port_to_socket, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-socket->semaphore", unsafe_socket_to_semaphore, 2, 2, env); } void scheme_init_port_places(void) @@ -2672,7 +2672,6 @@ Scheme_Object *scheme_get_special(Scheme_Object *port, int cnt; Scheme_Object *a[4], *special; Scheme_Input_Port *ip; - Scheme_Cont_Frame_Data cframe; SCHEME_USE_FUEL(1); @@ -2698,8 +2697,6 @@ Scheme_Object *scheme_get_special(Scheme_Object *port, if (peek) { /* do location increment, since read didn't */ - if (line > 0) - line++; if (col >= 0) col++; if (pos > 0) @@ -2717,13 +2714,8 @@ Scheme_Object *scheme_get_special(Scheme_Object *port, a[3] = (pos > 0) ? scheme_make_integer(pos) : scheme_false; } - scheme_push_continuation_frame(&cframe); - scheme_set_in_read_mark(src, for_read); - special = scheme_apply(special, cnt, a); - scheme_pop_continuation_frame(&cframe); - return special; } @@ -2740,11 +2732,7 @@ static Scheme_Object *do_get_ready_special(Scheme_Object *port, stxsrc = ip->name; } - /* Don't use scheme_tell_all(), because we always want the - Racket-computed values here. */ - line = scheme_tell_line(port); - col = scheme_tell_column(port); - pos = scheme_tell(port); + scheme_tell_all(port, &line, &col, &pos); return scheme_get_special(port, stxsrc, line, col, pos, peek, ht); } @@ -2771,7 +2759,6 @@ void scheme_bad_time_for_special(const char *who, Scheme_Object *port) static Scheme_Object *check_special_args(void *sbox, int argc, Scheme_Object **argv) { Scheme_Object *special; - Scheme_Cont_Frame_Data cframe; if (SCHEME_TRUEP(argv[1])) if (!scheme_nonneg_exact_p(argv[1]) || (SAME_OBJ(argv[1], scheme_make_integer(0)))) @@ -2789,13 +2776,8 @@ static Scheme_Object *check_special_args(void *sbox, int argc, Scheme_Object **a "read-special: cannot be called a second time"); *(Scheme_Object **)sbox = NULL; - scheme_push_continuation_frame(&cframe); - scheme_set_in_read_mark(NULL, NULL); - special = _scheme_apply(special, 4, argv); - scheme_pop_continuation_frame(&cframe); - return special; } @@ -3658,12 +3640,27 @@ Scheme_Object *scheme_terminal_port_p(int argc, Scheme_Object *argv[]) return is_fd_terminal(fd) ? scheme_true : scheme_false; } +static void maybe_raise_missing_module(char *name, char *filename, char *pre, char *rel, char *post, char *errstr) +{ + Scheme_Object *proc, *a[6]; + + proc = scheme_get_startup_export("maybe-raise-missing-module"); + + a[0] = scheme_make_utf8_string(name); + a[1] = scheme_make_utf8_string(filename); + a[2] = scheme_make_utf8_string(pre); + a[3] = scheme_make_utf8_string(rel); + a[4] = scheme_make_utf8_string(post); + a[5] = scheme_make_utf8_string(errstr); + + scheme_apply_multi(proc, 6, a); +} + static void filename_exn(char *name, char *msg, char *filename, int maybe_module_errno) { char *dir, *drive; int len; char *pre, *rel, *post; - Scheme_Object *mod_path, *mp; len = strlen(filename); @@ -3683,38 +3680,10 @@ static void filename_exn(char *name, char *msg, char *filename, int maybe_module post = dir ? "" : ""; if (maybe_module_errno && scheme_last_error_is_racket(maybe_module_errno)) { - mod_path = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_LOAD_PATH); - if (SCHEME_TRUEP(mod_path)) { - if (SCHEME_STXP(mod_path)) { - char *srcloc; - intptr_t srcloc_len; - mp = scheme_syntax_to_datum(mod_path, 0, NULL); - srcloc = scheme_make_srcloc_string(mod_path, &srcloc_len); - scheme_raise_exn(MZEXN_FAIL_SYNTAX_MISSING_MODULE, - scheme_make_pair(mod_path, scheme_null), - mp, - "%t%s: %s\n" - " module path: %W\n" - " path: %q%s%q%s\n" - " system error: %R", - srcloc, srcloc_len, - srcloc_len ? "" : name, - "cannot open module file", - mp, filename, - pre, rel, post); - } else { - scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, - mod_path, - "%s: %s\n" - " module path: %W\n" - " path: %q%s%q%s\n" - " system error: %R", - name, "cannot open module file", - mod_path, filename, - pre, rel, post); - } - return; - } + char buffer[256]; + scheme_sprintf(buffer, sizeof(buffer)-1, "%R"); + buffer[sizeof(buffer)-1] = 0; + maybe_raise_missing_module(name, filename, pre, rel, post, buffer); } scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, diff --git a/racket/src/racket/src/portfun.c b/racket/src/racket/src/portfun.c index ff43a5f46f..0ebbeb21d5 100644 --- a/racket/src/racket/src/portfun.c +++ b/racket/src/racket/src/portfun.c @@ -47,11 +47,6 @@ static Scheme_Object *call_with_output_file (int, Scheme_Object *[]); static Scheme_Object *call_with_input_file (int, Scheme_Object *[]); static Scheme_Object *with_input_from_file (int, Scheme_Object *[]); static Scheme_Object *with_output_to_file (int, Scheme_Object *[]); -static Scheme_Object *read_f (int, Scheme_Object *[]); -static Scheme_Object *read_recur_f (int, Scheme_Object *[]); -static Scheme_Object *read_syntax_f (int, Scheme_Object *[]); -static Scheme_Object *read_syntax_recur_f (int, Scheme_Object *[]); -static Scheme_Object *read_language (int, Scheme_Object *[]); static Scheme_Object *read_char (int, Scheme_Object *[]); static Scheme_Object *read_char_spec (int, Scheme_Object *[]); static Scheme_Object *read_byte (int, Scheme_Object *[]); @@ -99,15 +94,11 @@ static Scheme_Object *sch_print (int, Scheme_Object *[]); static Scheme_Object *newline (int, Scheme_Object *[]); static Scheme_Object *write_char (int, Scheme_Object *[]); static Scheme_Object *write_byte (int, Scheme_Object *[]); -static Scheme_Object *load (int, Scheme_Object *[]); -static Scheme_Object *current_load (int, Scheme_Object *[]); -static Scheme_Object *current_load_use_compiled (int, Scheme_Object *[]); static Scheme_Object *current_load_directory(int argc, Scheme_Object *argv[]); static Scheme_Object *current_write_directory(int argc, Scheme_Object *argv[]); #ifdef LOAD_ON_DEMAND static Scheme_Object *load_on_demand_enabled(int argc, Scheme_Object *argv[]); #endif -static Scheme_Object *default_load (int, Scheme_Object *[]); static Scheme_Object *flush_output (int, Scheme_Object *[]); static Scheme_Object *open_input_char_string (int, Scheme_Object *[]); static Scheme_Object *open_input_byte_string (int, Scheme_Object *[]); @@ -168,6 +159,15 @@ READ_ONLY Scheme_Object *scheme_print_proc; SHARED_OK Scheme_Object *initial_compiled_file_paths; SHARED_OK Scheme_Object *initial_compiled_file_roots; +SHARED_OK static int compiled_file_check = SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS; +ROSYM static Scheme_Object *initial_compiled_file_check_symbol; + +SHARED_OK int scheme_ignore_user_paths; +void scheme_set_ignore_user_paths(int v) { scheme_ignore_user_paths = v; } + +SHARED_OK int scheme_ignore_link_paths; +void scheme_set_ignore_link_paths(int v) { scheme_ignore_link_paths = v; } + THREAD_LOCAL_DECL(static Scheme_Object *dummy_input_port); THREAD_LOCAL_DECL(static Scheme_Object *dummy_output_port); @@ -178,7 +178,7 @@ THREAD_LOCAL_DECL(static Scheme_Object *dummy_output_port); /*========================================================================*/ void -scheme_init_port_fun(Scheme_Env *env) +scheme_init_port_fun(Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -220,161 +220,146 @@ scheme_init_port_fun(Scheme_Env *env) default_write_handler = scheme_make_prim_w_arity(sch_default_write_handler, "default-port-write-handler", 2, 2); default_print_handler = scheme_make_prim_w_arity(sch_default_print_handler, "default-port-print-handler", 2, 3); - scheme_add_global_constant("eof", scheme_eof, env); + scheme_addto_prim_instance("eof", scheme_eof, env); - GLOBAL_PARAMETER("current-input-port", current_input_port, MZCONFIG_INPUT_PORT, env); - GLOBAL_PARAMETER("current-output-port", current_output_port, MZCONFIG_OUTPUT_PORT, env); - GLOBAL_PARAMETER("current-error-port", current_error_port, MZCONFIG_ERROR_PORT, env); - GLOBAL_PARAMETER("current-load", current_load, MZCONFIG_LOAD_HANDLER, env); - GLOBAL_PARAMETER("current-load/use-compiled", current_load_use_compiled, MZCONFIG_LOAD_COMPILED_HANDLER, env); - GLOBAL_PARAMETER("current-load-relative-directory", current_load_directory, MZCONFIG_LOAD_DIRECTORY, env); - GLOBAL_PARAMETER("current-write-relative-directory", current_write_directory, MZCONFIG_WRITE_DIRECTORY, env); - GLOBAL_PARAMETER("global-port-print-handler", global_port_print_handler, MZCONFIG_PORT_PRINT_HANDLER, env); + ADD_PARAMETER("current-input-port", current_input_port, MZCONFIG_INPUT_PORT, env); + ADD_PARAMETER("current-output-port", current_output_port, MZCONFIG_OUTPUT_PORT, env); + ADD_PARAMETER("current-error-port", current_error_port, MZCONFIG_ERROR_PORT, env); + ADD_PARAMETER("current-load-relative-directory", current_load_directory, MZCONFIG_LOAD_DIRECTORY, env); + ADD_PARAMETER("current-write-relative-directory", current_write_directory, MZCONFIG_WRITE_DIRECTORY, env); + ADD_PARAMETER("global-port-print-handler", global_port_print_handler, MZCONFIG_PORT_PRINT_HANDLER, env); #ifdef LOAD_ON_DEMAND - GLOBAL_PARAMETER("load-on-demand-enabled", load_on_demand_enabled, MZCONFIG_LOAD_DELAY_ENABLED, env); + ADD_PARAMETER("load-on-demand-enabled", load_on_demand_enabled, MZCONFIG_LOAD_DELAY_ENABLED, env); #endif - GLOBAL_PARAMETER("port-count-lines-enabled", global_port_count_lines, MZCONFIG_PORT_COUNT_LINES, env); + ADD_PARAMETER("port-count-lines-enabled", global_port_count_lines, MZCONFIG_PORT_COUNT_LINES, env); - GLOBAL_FOLDING_PRIM("input-port?", input_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("output-port?", output_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("file-stream-port?", scheme_file_stream_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("string-port?", string_port_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("terminal-port?", scheme_terminal_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("input-port?", input_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("output-port?", output_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("file-stream-port?", scheme_file_stream_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("string-port?", string_port_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("terminal-port?", scheme_terminal_port_p, 1, 1, 1, env); - GLOBAL_NONCM_PRIM("port-closed?", port_closed_p, 1, 1, env); - GLOBAL_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env); - GLOBAL_NONCM_PRIM("open-input-bytes", open_input_byte_string, 1, 2, env); - GLOBAL_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env); - GLOBAL_NONCM_PRIM("open-output-file", open_output_file, 1, 3, env); - GLOBAL_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env); - GLOBAL_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env); - GLOBAL_NONCM_PRIM("get-output-bytes", get_output_byte_string, 1, 4, env); - GLOBAL_NONCM_PRIM("get-output-string", get_output_char_string, 1, 1, env); - GLOBAL_NONCM_PRIM("open-input-output-file", open_input_output_file, 1, 3, env); - GLOBAL_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env); - GLOBAL_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env); - GLOBAL_NONCM_PRIM("make-input-port", make_input_port, 4, 10, env); - GLOBAL_NONCM_PRIM("make-output-port", make_output_port, 4, 11, env); + ADD_NONCM_PRIM("port-closed?", port_closed_p, 1, 1, env); + ADD_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env); + ADD_NONCM_PRIM("open-input-bytes", open_input_byte_string, 1, 2, env); + ADD_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env); + ADD_NONCM_PRIM("open-output-file", open_output_file, 1, 3, env); + ADD_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env); + ADD_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env); + ADD_NONCM_PRIM("get-output-bytes", get_output_byte_string, 1, 4, env); + ADD_NONCM_PRIM("get-output-string", get_output_char_string, 1, 1, env); + ADD_NONCM_PRIM("open-input-output-file", open_input_output_file, 1, 3, env); + ADD_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env); + ADD_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env); + ADD_NONCM_PRIM("make-input-port", make_input_port, 4, 10, env); + ADD_NONCM_PRIM("make-output-port", make_output_port, 4, 11, env); - GLOBAL_PRIM_W_ARITY2("call-with-output-file", call_with_output_file, 2, 4, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("call-with-input-file", call_with_input_file, 2, 3, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("with-output-to-file", with_output_to_file, 2, 4, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("with-input-from-file", with_input_from_file, 2, 3, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("load", load, 1, 1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, env); - GLOBAL_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env); - GLOBAL_NONCM_PRIM("set-port-next-location!", set_port_next_location, 4, 4, env); + ADD_PRIM_W_ARITY2("call-with-output-file", call_with_output_file, 2, 4, 0, -1, env); + ADD_PRIM_W_ARITY2("call-with-input-file", call_with_input_file, 2, 3, 0, -1, env); + ADD_PRIM_W_ARITY2("with-output-to-file", with_output_to_file, 2, 4, 0, -1, env); + ADD_PRIM_W_ARITY2("with-input-from-file", with_input_from_file, 2, 3, 0, -1, env); + ADD_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, env); + ADD_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env); + ADD_NONCM_PRIM("set-port-next-location!", set_port_next_location, 4, 4, env); - GLOBAL_PRIM_W_ARITY("filesystem-change-evt", filesystem_change_evt, 1, 2, env); - GLOBAL_NONCM_PRIM("filesystem-change-evt?", filesystem_change_evt_p, 1, 1, env); - GLOBAL_NONCM_PRIM("filesystem-change-evt-cancel", filesystem_change_evt_cancel, 1, 1, env); + ADD_PRIM_W_ARITY("filesystem-change-evt", filesystem_change_evt, 1, 2, env); + ADD_NONCM_PRIM("filesystem-change-evt?", filesystem_change_evt_p, 1, 1, env); + ADD_NONCM_PRIM("filesystem-change-evt-cancel", filesystem_change_evt_cancel, 1, 1, env); - GLOBAL_NONCM_PRIM("read", read_f, 0, 1, env); - GLOBAL_NONCM_PRIM("read/recursive", read_recur_f, 0, 4, env); - GLOBAL_NONCM_PRIM("read-syntax", read_syntax_f, 0, 2, env); - GLOBAL_NONCM_PRIM("read-syntax/recursive", read_syntax_recur_f, 0, 5, env); - GLOBAL_PRIM_W_ARITY2("read-language", read_language, 0, 2, 0, -1, env); - GLOBAL_NONCM_PRIM("read-char", read_char, 0, 1, env); - GLOBAL_PRIM_W_ARITY2("read-char-or-special", read_char_spec, 0, 3, 0, -1, env); - GLOBAL_NONCM_PRIM("read-byte", read_byte, 0, 1, env); - GLOBAL_PRIM_W_ARITY2("read-byte-or-special", read_byte_spec, 0, 3, 0, -1, env); - GLOBAL_NONCM_PRIM("read-bytes-line", read_byte_line, 0, 2, env); - GLOBAL_NONCM_PRIM("read-line", read_line, 0, 2, env); - GLOBAL_NONCM_PRIM("read-string", sch_read_string, 1, 2, env); - GLOBAL_NONCM_PRIM("read-string!", sch_read_string_bang, 1, 4, env); - GLOBAL_NONCM_PRIM("peek-string", sch_peek_string, 2, 3, env); - GLOBAL_NONCM_PRIM("peek-string!", sch_peek_string_bang, 2, 5, env); - GLOBAL_NONCM_PRIM("read-bytes", sch_read_bytes, 1, 2, env); - GLOBAL_NONCM_PRIM("read-bytes!", sch_read_bytes_bang, 1, 4, env); - GLOBAL_NONCM_PRIM("peek-bytes", sch_peek_bytes, 2, 3, env); - GLOBAL_NONCM_PRIM("peek-bytes!", sch_peek_bytes_bang, 2, 5, env); - GLOBAL_NONCM_PRIM("read-bytes-avail!", read_bytes_bang, 1, 4, env); - GLOBAL_NONCM_PRIM("read-bytes-avail!*", read_bytes_bang_nonblock, 1, 4, env); - GLOBAL_NONCM_PRIM("read-bytes-avail!/enable-break", read_bytes_bang_break, 1, 4, env); - GLOBAL_NONCM_PRIM("peek-bytes-avail!", peek_bytes_bang, 2, 6, env); - GLOBAL_NONCM_PRIM("peek-bytes-avail!*", peek_bytes_bang_nonblock, 2, 6, env); - GLOBAL_NONCM_PRIM("peek-bytes-avail!/enable-break", peek_bytes_bang_break, 2, 6, env); - GLOBAL_NONCM_PRIM("port-provides-progress-evts?", can_provide_progress_evt, 1, 1, env); - GLOBAL_NONCM_PRIM("write-bytes", write_bytes, 1, 4, env); - GLOBAL_NONCM_PRIM("write-string", write_string, 1, 4, env); - GLOBAL_NONCM_PRIM("write-bytes-avail", write_bytes_avail, 1, 4, env); - GLOBAL_NONCM_PRIM("write-bytes-avail*", write_bytes_avail_nonblock, 1, 4, env); - GLOBAL_NONCM_PRIM("write-bytes-avail/enable-break", write_bytes_avail_break, 1, 4, env); - GLOBAL_NONCM_PRIM("port-writes-atomic?", can_write_atomic, 1, 1, env); - GLOBAL_NONCM_PRIM("port-writes-special?", can_write_special, 1, 1, env); - GLOBAL_NONCM_PRIM("write-special", scheme_write_special, 1, 2, env); - GLOBAL_NONCM_PRIM("write-special-avail*", scheme_write_special_nonblock, 1, 2, env); - GLOBAL_NONCM_PRIM("peek-char", peek_char, 0, 2, env); - GLOBAL_PRIM_W_ARITY2("peek-char-or-special", peek_char_spec, 0, 4, 0, -1, env); - GLOBAL_NONCM_PRIM("peek-byte", peek_byte, 0, 2, env); - GLOBAL_PRIM_W_ARITY2("peek-byte-or-special", peek_byte_spec, 0, 5, 0, -1, env); - GLOBAL_NONCM_PRIM("byte-ready?", byte_ready_p, 0, 1, env); - GLOBAL_NONCM_PRIM("char-ready?", char_ready_p, 0, 1, env); - GLOBAL_NONCM_PRIM("newline", newline, 0, 1, env); - GLOBAL_NONCM_PRIM("write-char", write_char, 1, 2, env); - GLOBAL_NONCM_PRIM("write-byte", write_byte, 1, 2, env); - GLOBAL_NONCM_PRIM("port-commit-peeked", peeked_read, 3, 4, env); - GLOBAL_NONCM_PRIM("port-progress-evt", progress_evt, 0, 1, env); - GLOBAL_NONCM_PRIM("progress-evt?", is_progress_evt, 1, 2, env); - GLOBAL_NONCM_PRIM("port-closed-evt", closed_evt, 0, 1, env); - GLOBAL_NONCM_PRIM("write-bytes-avail-evt", write_bytes_avail_evt, 1, 4, env); - GLOBAL_NONCM_PRIM("write-special-evt", write_special_evt, 2, 2, env); - GLOBAL_NONCM_PRIM("port-read-handler", port_read_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("port-display-handler", port_display_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("port-write-handler", port_write_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("port-print-handler", port_print_handler, 1, 2, env); - GLOBAL_NONCM_PRIM("flush-output", flush_output, 0, 1, env); - GLOBAL_NONCM_PRIM("file-position", scheme_file_position, 1, 2, env); - GLOBAL_NONCM_PRIM("file-position*", scheme_file_position_star, 1, 1, env); - GLOBAL_NONCM_PRIM("file-truncate", scheme_file_truncate, 2, 2, env); - GLOBAL_NONCM_PRIM("file-stream-buffer-mode", scheme_file_buffer, 1, 2, env); - GLOBAL_NONCM_PRIM("port-try-file-lock?", scheme_file_try_lock, 2, 2, env); - GLOBAL_NONCM_PRIM("port-file-unlock", scheme_file_unlock, 1, 1, env); - GLOBAL_NONCM_PRIM("port-file-identity", scheme_file_identity, 1, 1, env); - GLOBAL_NONCM_PRIM("port-count-lines!", port_count_lines, 1, 1, env); - GLOBAL_NONCM_PRIM("port-counts-lines?", port_counts_lines_p, 1, 1, env); + ADD_NONCM_PRIM("read-char", read_char, 0, 1, env); + ADD_PRIM_W_ARITY2("read-char-or-special", read_char_spec, 0, 3, 0, -1, env); + ADD_NONCM_PRIM("read-byte", read_byte, 0, 1, env); + ADD_PRIM_W_ARITY2("read-byte-or-special", read_byte_spec, 0, 3, 0, -1, env); + ADD_NONCM_PRIM("read-bytes-line", read_byte_line, 0, 2, env); + ADD_NONCM_PRIM("read-line", read_line, 0, 2, env); + ADD_NONCM_PRIM("read-string", sch_read_string, 1, 2, env); + ADD_NONCM_PRIM("read-string!", sch_read_string_bang, 1, 4, env); + ADD_NONCM_PRIM("peek-string", sch_peek_string, 2, 3, env); + ADD_NONCM_PRIM("peek-string!", sch_peek_string_bang, 2, 5, env); + ADD_NONCM_PRIM("read-bytes", sch_read_bytes, 1, 2, env); + ADD_NONCM_PRIM("read-bytes!", sch_read_bytes_bang, 1, 4, env); + ADD_NONCM_PRIM("peek-bytes", sch_peek_bytes, 2, 3, env); + ADD_NONCM_PRIM("peek-bytes!", sch_peek_bytes_bang, 2, 5, env); + ADD_NONCM_PRIM("read-bytes-avail!", read_bytes_bang, 1, 4, env); + ADD_NONCM_PRIM("read-bytes-avail!*", read_bytes_bang_nonblock, 1, 4, env); + ADD_NONCM_PRIM("read-bytes-avail!/enable-break", read_bytes_bang_break, 1, 4, env); + ADD_NONCM_PRIM("peek-bytes-avail!", peek_bytes_bang, 2, 6, env); + ADD_NONCM_PRIM("peek-bytes-avail!*", peek_bytes_bang_nonblock, 2, 6, env); + ADD_NONCM_PRIM("peek-bytes-avail!/enable-break", peek_bytes_bang_break, 2, 6, env); + ADD_NONCM_PRIM("port-provides-progress-evts?", can_provide_progress_evt, 1, 1, env); + ADD_NONCM_PRIM("write-bytes", write_bytes, 1, 4, env); + ADD_NONCM_PRIM("write-string", write_string, 1, 4, env); + ADD_NONCM_PRIM("write-bytes-avail", write_bytes_avail, 1, 4, env); + ADD_NONCM_PRIM("write-bytes-avail*", write_bytes_avail_nonblock, 1, 4, env); + ADD_NONCM_PRIM("write-bytes-avail/enable-break", write_bytes_avail_break, 1, 4, env); + ADD_NONCM_PRIM("port-writes-atomic?", can_write_atomic, 1, 1, env); + ADD_NONCM_PRIM("port-writes-special?", can_write_special, 1, 1, env); + ADD_NONCM_PRIM("write-special", scheme_write_special, 1, 2, env); + ADD_NONCM_PRIM("write-special-avail*", scheme_write_special_nonblock, 1, 2, env); + ADD_NONCM_PRIM("peek-char", peek_char, 0, 2, env); + ADD_PRIM_W_ARITY2("peek-char-or-special", peek_char_spec, 0, 4, 0, -1, env); + ADD_NONCM_PRIM("peek-byte", peek_byte, 0, 2, env); + ADD_PRIM_W_ARITY2("peek-byte-or-special", peek_byte_spec, 0, 5, 0, -1, env); + ADD_NONCM_PRIM("byte-ready?", byte_ready_p, 0, 1, env); + ADD_NONCM_PRIM("char-ready?", char_ready_p, 0, 1, env); + ADD_NONCM_PRIM("newline", newline, 0, 1, env); + ADD_NONCM_PRIM("write-char", write_char, 1, 2, env); + ADD_NONCM_PRIM("write-byte", write_byte, 1, 2, env); + ADD_NONCM_PRIM("port-commit-peeked", peeked_read, 3, 4, env); + ADD_NONCM_PRIM("port-progress-evt", progress_evt, 0, 1, env); + ADD_NONCM_PRIM("progress-evt?", is_progress_evt, 1, 2, env); + ADD_NONCM_PRIM("port-closed-evt", closed_evt, 0, 1, env); + ADD_NONCM_PRIM("write-bytes-avail-evt", write_bytes_avail_evt, 1, 4, env); + ADD_NONCM_PRIM("write-special-evt", write_special_evt, 2, 2, env); + ADD_NONCM_PRIM("port-read-handler", port_read_handler, 1, 2, env); + ADD_NONCM_PRIM("port-display-handler", port_display_handler, 1, 2, env); + ADD_NONCM_PRIM("port-write-handler", port_write_handler, 1, 2, env); + ADD_NONCM_PRIM("port-print-handler", port_print_handler, 1, 2, env); + ADD_NONCM_PRIM("flush-output", flush_output, 0, 1, env); + ADD_NONCM_PRIM("file-position", scheme_file_position, 1, 2, env); + ADD_NONCM_PRIM("file-position*", scheme_file_position_star, 1, 1, env); + ADD_NONCM_PRIM("file-truncate", scheme_file_truncate, 2, 2, env); + ADD_NONCM_PRIM("file-stream-buffer-mode", scheme_file_buffer, 1, 2, env); + ADD_NONCM_PRIM("port-try-file-lock?", scheme_file_try_lock, 2, 2, env); + ADD_NONCM_PRIM("port-file-unlock", scheme_file_unlock, 1, 1, env); + ADD_NONCM_PRIM("port-file-identity", scheme_file_identity, 1, 1, env); + ADD_NONCM_PRIM("port-count-lines!", port_count_lines, 1, 1, env); + ADD_NONCM_PRIM("port-counts-lines?", port_counts_lines_p, 1, 1, env); REGISTER_SO(scheme_eof_object_p_proc); scheme_eof_object_p_proc = scheme_make_folding_prim(eof_object_p, "eof-object?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(scheme_eof_object_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("eof-object?", scheme_eof_object_p_proc, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("eof-object?", scheme_eof_object_p_proc, env); - scheme_add_global_constant("write", scheme_write_proc, env); - scheme_add_global_constant("display", scheme_display_proc, env); - scheme_add_global_constant("print", scheme_print_proc, env); + scheme_addto_prim_instance("write", scheme_write_proc, env); + scheme_addto_prim_instance("display", scheme_display_proc, env); + scheme_addto_prim_instance("print", scheme_print_proc, env); - GLOBAL_IMMED_PRIM("pipe-content-length", pipe_length, 1, 1, env); + ADD_IMMED_PRIM("pipe-content-length", pipe_length, 1, 1, env); REGISTER_SO(scheme_default_global_print_handler); scheme_default_global_print_handler = scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 3); } +void scheme_init_param_symbol() +{ + REGISTER_SO(initial_compiled_file_check_symbol); + if (compiled_file_check == SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS) + initial_compiled_file_check_symbol = scheme_intern_symbol("modify-seconds"); + else + initial_compiled_file_check_symbol = scheme_intern_symbol("exists"); +} void scheme_init_port_fun_config(void) { scheme_set_root_param(MZCONFIG_LOAD_DIRECTORY, scheme_false); scheme_set_root_param(MZCONFIG_WRITE_DIRECTORY, scheme_false); - if (initial_compiled_file_paths) - scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND, initial_compiled_file_paths); - else - scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND, scheme_make_pair(scheme_make_path("compiled"), scheme_null)); - if (initial_compiled_file_roots) - scheme_set_root_param(MZCONFIG_USE_COMPILED_ROOTS, initial_compiled_file_roots); - else - scheme_set_root_param(MZCONFIG_USE_COMPILED_ROOTS, scheme_make_pair(scheme_intern_symbol("same"), scheme_null)); - scheme_set_root_param(MZCONFIG_USE_USER_PATHS, (scheme_ignore_user_paths ? scheme_false : scheme_true)); - scheme_set_root_param(MZCONFIG_USE_LINK_PATHS, (scheme_ignore_link_paths ? scheme_false : scheme_true)); - - { - Scheme_Object *dlh; - dlh = scheme_make_prim_w_arity2(default_load, "default-load-handler", 2, 2, 0, -1); - scheme_set_root_param(MZCONFIG_LOAD_HANDLER, dlh); - } scheme_set_root_param(MZCONFIG_PORT_PRINT_HANDLER, scheme_default_global_print_handler); - + /* Use dummy port: */ REGISTER_SO(dummy_input_port); REGISTER_SO(dummy_output_port); @@ -382,6 +367,63 @@ void scheme_init_port_fun_config(void) dummy_output_port = scheme_make_null_output_port(1); } +static void set_param(const char *name, Scheme_Object *val) +{ + Scheme_Object *param, *a[1]; + param = scheme_get_startup_export(name); + a[0] = val; + (void)_scheme_apply_multi(param, 1, a); +} + +static Scheme_Object *get_param(const char *name) +{ + Scheme_Object *param; + param = scheme_get_startup_export(name); + return _scheme_apply(param, 0, NULL); +} + +void scheme_init_resolver_config(void) +{ + set_param("use-compiled-file-check", initial_compiled_file_check_symbol); + if (initial_compiled_file_paths) + set_param("use-compiled-file-paths", initial_compiled_file_paths); + else + set_param("use-compiled-file-paths", scheme_make_pair(scheme_make_path("compiled"), scheme_null)); + if (initial_compiled_file_roots) + set_param("current-compiled-file-roots", initial_compiled_file_roots); + else + set_param("current-compiled-file-roots", scheme_make_pair(scheme_intern_symbol("same"), scheme_null)); + set_param("use-user-specific-search-paths", (scheme_ignore_user_paths ? scheme_false : scheme_true)); + set_param("use-collection-link-paths", (scheme_ignore_link_paths ? scheme_false : scheme_true)); +} + +Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]) +{ + if (argc) { + set_param("current-library-collection-paths", argv[0]); + return scheme_void; + } else + return get_param("current-library-collection-paths"); +} + +Scheme_Object *scheme_current_library_collection_links(int argc, Scheme_Object *argv[]) +{ + if (argc) { + set_param("current-library-collection-links", argv[0]); + return scheme_void; + } else + return get_param("current-library-collection-links"); +} + +Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]) +{ + if (argc) { + set_param("current-compiled-file-roots", argv[0]); + return scheme_void; + } else + return get_param("current-compiled-file-roots"); +} + void scheme_set_compiled_file_paths(Scheme_Object *list) { if (!initial_compiled_file_paths) @@ -396,6 +438,11 @@ void scheme_set_compiled_file_roots(Scheme_Object *list) initial_compiled_file_roots = list; } +void scheme_set_compiled_file_check(int c) +{ + compiled_file_check = c; +} + /*========================================================================*/ /* port records */ /*========================================================================*/ @@ -2876,162 +2923,10 @@ static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Ob else src = NULL; - return scheme_internal_read(argv[0], src, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); -} - -static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, int delta, - Scheme_Object **_readtable, int *_recur_graph) -{ - int pre_char = -1; - - if (argc > delta + 1) { - if (SCHEME_TRUEP(argv[delta + 1])) { - if (!SCHEME_CHARP(argv[delta + 1])) - scheme_wrong_contract(who, "(or/c char? #f)", delta + 1, argc, argv); - pre_char = SCHEME_CHAR_VAL(argv[delta + 1]); - } - if (argc > delta + 2) { - Scheme_Object *readtable; - readtable = argv[delta + 2]; - if (SCHEME_TRUEP(readtable) && !SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(readtable))) { - scheme_wrong_contract(who, "(or/c readtable? #f)", delta + 2, argc, argv); - } - *_readtable = readtable; - if (argc > delta + 3) { - *_recur_graph = SCHEME_TRUEP(argv[delta + 3]); - } - } - } - - return pre_char; -} - -static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[], int recur) -{ - Scheme_Object *port, *readtable = NULL; - int pre_char = -1, recur_graph = recur; - Scheme_Input_Port *ip; - - if (argc && !SCHEME_INPUT_PORTP(argv[0])) - scheme_wrong_contract(who, "input-port?", 0, argc, argv); - - if (argc) - port = argv[0]; + if (src) + return scheme_read_syntax(argv[0], src); else - port = CURRENT_INPUT_PORT(scheme_current_config()); - - if (recur) { - pre_char = extract_recur_args(who, argc, argv, 0, &readtable, &recur_graph); - } - - ip = scheme_input_port_record(port); - - if (ip->read_handler && !recur) { - Scheme_Object *o[1]; - o[0] = port; - return _scheme_apply(ip->read_handler, 1, o); - } else { - if (port == scheme_orig_stdin_port) - scheme_flush_orig_outputs(); - - return scheme_internal_read(port, NULL, -1, 0, - recur_graph, recur, - pre_char, readtable, - NULL, NULL, NULL); - } -} - -static Scheme_Object *read_f(int argc, Scheme_Object *argv[]) -{ - return do_read_f("read", argc, argv, 0); -} - -static Scheme_Object *read_recur_f(int argc, Scheme_Object *argv[]) -{ - return do_read_f("read/recursive", argc, argv, 1); -} - -static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object *argv[], int recur) -{ - Scheme_Object *port, *readtable = NULL; - int pre_char = -1, recur_graph = recur; - Scheme_Input_Port *ip; - - if ((argc > 1) && !SCHEME_INPUT_PORTP(argv[1])) - scheme_wrong_contract(who, "input-port?", 1, argc, argv); - - if (argc > 1) - port = argv[1]; - else - port = CURRENT_INPUT_PORT(scheme_current_config()); - - if (recur) { - pre_char = extract_recur_args(who, argc, argv, 1, &readtable, &recur_graph); - } - - ip = scheme_input_port_record(port); - - if (ip->read_handler && !recur) { - Scheme_Object *o[2], *result; - o[0] = port; - o[1] = (argc ? argv[0] : ip->name); - - result = _scheme_apply(ip->read_handler, 2, o); - if (SCHEME_STXP(result) || SCHEME_EOFP(result)) - return result; - else { - o[0] = result; - /* -1 for argument count indicates "result" */ - scheme_wrong_contract("read handler for read-syntax", "syntax?", 0, -1, o); - return NULL; - } - } else { - Scheme_Object *src; - - src = (argc ? argv[0] : ip->name); - - if (port == scheme_orig_stdin_port) - scheme_flush_orig_outputs(); - - return scheme_internal_read(port, src, -1, 0, - recur, recur_graph, - pre_char, readtable, - NULL, NULL, NULL); - } -} - -static Scheme_Object *read_syntax_f(int argc, Scheme_Object *argv[]) -{ - return do_read_syntax_f("read-syntax", argc, argv, 0); -} - -static Scheme_Object *read_syntax_recur_f(int argc, Scheme_Object *argv[]) -{ - return do_read_syntax_f("read-syntax/recursive", argc, argv, 1); -} - -static Scheme_Object *read_language(int argc, Scheme_Object **argv) -{ - Scheme_Object *port, *v, *fail_thunk = NULL; - - if (argc > 0) { - port = argv[0]; - if (!SCHEME_INPUT_PORTP(port)) - scheme_wrong_contract("read-language", "input-port?", 0, argc, argv); - if (argc > 1) { - scheme_check_proc_arity("read-language", 0, 1, argc, argv); - fail_thunk = argv[1]; - } - } else { - port = CURRENT_INPUT_PORT(scheme_current_config()); - } - - v = scheme_read_language(port, !!fail_thunk); - - if (SCHEME_VOIDP(v)) - return _scheme_tail_apply(fail_thunk, 0, NULL); - - return v; + return scheme_read(argv[0]); } static Scheme_Object * @@ -3090,14 +2985,12 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in else if (!scheme_fast_check_arity(spec_wrap, 1)) scheme_check_proc_arity2(name, 1, pos, argc, argv, 1); pos++; - if (argc > pos) { + if (argc > pos) src = argv[pos++]; - if (SCHEME_FALSEP(src)) - src = NULL; - } else - src = NULL; + else + src = scheme_false; } else { - src = NULL; + src = scheme_false; spec_wrap = NULL; } @@ -4490,555 +4383,6 @@ static Scheme_Object *filesystem_change_evt_cancel(int argc, Scheme_Object **arg return scheme_void; } -static intptr_t get_number(Scheme_Object *port, intptr_t pos) -{ - unsigned char buffer[4]; - intptr_t got, orig; - - orig = scheme_set_file_position(port, -1); - scheme_set_file_position(port, pos); - - got = scheme_get_byte_string("default-load-handler", - port, - (char *)buffer, 0, 4, - 0, 0, scheme_make_integer(0)); - - (void)scheme_set_file_position(port, orig); - - if (got != 4) - return 0; - - return (buffer[0] | (buffer[1] << 8) | (buffer[2] << 16) | (buffer[3] << 24)); -} - -static char *get_bytes(Scheme_Object *port, intptr_t pos, intptr_t len) -{ - char *s; - intptr_t orig; - - s = scheme_malloc_atomic(len + 1); - s[len] = 0; - - orig = scheme_set_file_position(port, -1); - scheme_set_file_position(port, pos); - - scheme_get_byte_string("default-load-handler", - port, - (char *)s, 0, len, - 0, 0, scheme_make_integer(0)); - - (void)scheme_set_file_position(port, orig); - - return s; -} - -typedef struct { - MZTAG_IF_REQUIRED - Scheme_Config *config; - Scheme_Object *port; - Scheme_Thread *p; - Scheme_Object *stxsrc; - Scheme_Object *expected_module; -} LoadHandlerData; - -static void post_load_handler(void *data) -{ - LoadHandlerData *lhd = (LoadHandlerData *)data; - - scheme_close_input_port((Scheme_Object *)lhd->port); -} - -static Scheme_Object *do_load_handler(void *data) -{ - LoadHandlerData *lhd = (LoadHandlerData *)data; - Scheme_Object *port = lhd->port; - Scheme_Thread *p = lhd->p; - Scheme_Config *config = lhd->config; - Scheme_Object *last_val = scheme_void, *obj, **save_array = NULL, *modname; - Scheme_Env *genv; - int save_count = 0, got_one = 0, as_module, check_module_name = 0, skip_no_more_check = 0; - - modname = lhd->expected_module; - - if (SCHEME_TRUEP(modname)) { - /* Look for a module directory: */ - intptr_t got; - int vers_size, dir_header_size; -# define DIR_HEADER_SIZE (3 + 20 + 16) - char buffer[DIR_HEADER_SIZE]; - - vers_size = strlen(MZSCHEME_VERSION); - dir_header_size = 4 + vers_size; - if (dir_header_size >= DIR_HEADER_SIZE) - scheme_signal_error("internal error: buffer size mismatch"); - got = scheme_get_byte_string("default-load-handler", - port, - buffer, 0, dir_header_size, - 0, 1, scheme_make_integer(0)); - - if ((got == dir_header_size) - && (buffer[0] == '#') - && (buffer[1] == '~') - && (buffer[2] == vers_size) - && (!scheme_strncmp(buffer + 3, MZSCHEME_VERSION, vers_size)) - && (buffer[3 + vers_size] == 'D')) { - /* File starts with a directory. The directory is a balanced binary search tree, - where each node has the shape - - and a 0 position for or means no child. */ - char *find_name, *s; - intptr_t namelen, i, name_size, pos, offset = 0, rellen; - - if (SCHEME_PAIRP(modname)) - find_name = scheme_submodule_path_to_string(SCHEME_CDR(modname), &namelen); - else { - find_name = ""; - namelen = 0; - } - - pos = dir_header_size + 4 /* skip total-module count */; - - while (pos) { - name_size = get_number(port, pos); - s = get_bytes(port, pos + 4, name_size); - if ((name_size == namelen) && !strncmp(find_name, s, name_size)) { - /* found it */ - offset = get_number(port, pos + 4 + name_size); - break; - } - /* try left or right? */ - rellen = namelen; - for (i = 0; (i < rellen) && (i < name_size); i++) { - if (find_name[i] != s[i]) { - if (((unsigned char *)find_name)[i] < ((unsigned char *)s)[i]) - rellen = 0; - else - rellen = name_size + 1; - break; - } - } - if (rellen < name_size) - pos = get_number(port, pos + 12 + name_size); - else - pos = get_number(port, pos + 16 + name_size); - } - - if (offset) { - scheme_set_file_position(port, offset); - if (!SCHEME_SYMBOLP(modname)) - modname = SCHEME_CAR(SCHEME_CDR(modname)); - skip_no_more_check = 1; - } else if (SCHEME_PAIRP(modname)) { - /* don't complain if a submodule isn't found */ - return scheme_void; - } - } - } - - if (SCHEME_PAIRP(modname)) { - modname = SCHEME_CAR(modname); - - if (SCHEME_FALSEP(modname)) { - /* caller says the main module is already loaded, - so don't reload for submodules */ - return scheme_void; - } - } - - if (scheme_module_code_cache && SCHEME_TRUEP(modname)) { - intptr_t got; - int vers_size, hash_header_size; -# define HASH_HEADER_SIZE (4 + 20 + 16) - char buffer[HASH_HEADER_SIZE]; - - vers_size = strlen(MZSCHEME_VERSION); - hash_header_size = 4 + vers_size + 20; - if (hash_header_size >= HASH_HEADER_SIZE) - scheme_signal_error("internal error: buffer size mismatch"); - got = scheme_get_byte_string("default-load-handler", - port, - buffer, 0, hash_header_size, - 0, 1, scheme_make_integer(0)); - - obj = NULL; - if ((got == hash_header_size) - && (buffer[0] == '#') - && (buffer[1] == '~') - && (buffer[2] == vers_size) - && (!scheme_strncmp(buffer + 3, MZSCHEME_VERSION, vers_size)) - && (buffer[3 + vers_size] == 'T')) { - int i; - for (i = 0; i < 20; i++) { - if (buffer[4 + vers_size + i]) - break; - } - if (i < 20) { - obj = scheme_make_sized_byte_string(buffer + 4 + vers_size, 20, 1); - } - } - - - if (obj) { - Scheme_Object *dir; - dir = scheme_get_param(config, MZCONFIG_LOAD_DIRECTORY); - if (SCHEME_TRUEP(dir)) - dir = scheme_path_to_directory_path(dir); - obj = scheme_make_pair(obj, dir); - obj = scheme_lookup_in_table(scheme_module_code_cache, (const char *)obj); - if (obj) - obj = scheme_ephemeron_value(obj); - if (obj) { - /* Synthesize a wrapper to pass through `eval': */ - Scheme_Compilation_Top *top; - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->code = obj; - top->prefix = NULL; /* indicates a wrapper */ - - obj = (Scheme_Object *)top; - - return _scheme_apply_multi(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), - 1, &obj); - } - } - } - - while ((obj = scheme_internal_read(port, lhd->stxsrc, -1, 0, 0, 0, -1, NULL, - NULL, NULL, NULL)) - && !SCHEME_EOFP(obj)) { - save_array = NULL; - got_one = 1; - - /* ... begin special support for module loading ... */ - - genv = scheme_get_env(config); - as_module = 0; - - if (SCHEME_SYMBOLP(modname)) { - /* Must be of the form `(module ...)',possibly compiled. */ - /* Also, file should have no more expressions. */ - Scheme_Object *a, *d, *other = NULL; - Scheme_Module *m; - - d = obj; - - m = scheme_extract_compiled_module(SCHEME_STX_VAL(d)); - if (m) { - if (check_module_name) { - if (!scheme_resolved_module_path_value_matches(m->modname, modname)) { - other = m->modname; - d = NULL; - } - } - } else { - if (!SCHEME_STX_PAIRP(d)) - d = NULL; - else { - a = SCHEME_STX_CAR(d); - if (!SAME_OBJ(SCHEME_STX_VAL(a), module_symbol)) - d = NULL; - else { - d = SCHEME_STX_CDR(d); - if (!SCHEME_STX_PAIRP(d)) - d = NULL; - else { - a = SCHEME_STX_CAR(d); - other = SCHEME_STX_VAL(a); - if (check_module_name) { - if (!SAME_OBJ(other, modname)) - d = NULL; - } - } - } - } - } - - /* If d is NULL, shape was wrong */ - if (!d) { - Scheme_Object *err_msg; - if (!other || !SCHEME_SYMBOLP(other)) - err_msg = scheme_make_byte_string("something else"); - else { - char *s, *t; - intptr_t len, slen; - - t = "declaration for `"; - len = strlen(t); - slen = SCHEME_SYM_LEN(other); - - s = (char *)scheme_malloc_atomic(len + slen + 2); - memcpy(s, t, len); - memcpy(s + len, SCHEME_SYM_VAL(other), slen); - s[len + slen] = '\''; - s[len + slen + 1]= 0; - - err_msg = scheme_make_sized_byte_string(s, len + slen + 1, 0); - } - - { - Scheme_Input_Port *ip; - ip = scheme_input_port_record(port); - scheme_raise_exn(MZEXN_FAIL, - "default-load-handler: expected a `module' declaration\n" - " found: %T\n" - " in: %V", - err_msg, - ip->name); - } - - return NULL; - } - - /* Check no more expressions: */ - if (!skip_no_more_check) { - d = scheme_internal_read(port, lhd->stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); - if (!SCHEME_EOFP(d)) { - Scheme_Input_Port *ip; - ip = scheme_input_port_record(port); - scheme_raise_exn(MZEXN_FAIL, - "default-load-handler: expected only a `module' declaration;\n" - " found an extra form\n" - " in: %V", - modname, - ip->name); - - return NULL; - } - } - - if (!m) { - /* Replace `module' in read expression with one bound to #%kernel's `module': */ - a = SCHEME_STX_CAR(obj); - d = SCHEME_STX_CDR(obj); - a = scheme_datum_to_syntax(module_symbol, a, - scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), - 0, 1); - d = scheme_make_pair(a, d); - obj = scheme_datum_to_syntax(d, obj, scheme_false, 0, 1); - as_module = 1; - } - } else { - /* Add #%top-interaction, since we're in non-module mode: */ - Scheme_Object *a; - a = scheme_make_pair(scheme_intern_symbol("#%top-interaction"), obj); - obj = scheme_datum_to_syntax(a, obj, scheme_false, 0, 0); - } - - /* ... end special support for module loading ... */ - - if (!as_module && genv->stx_context) - obj = scheme_top_introduce(obj, genv); - - last_val = _scheme_apply_multi_with_prompt(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), - 1, &obj); - - /* If multi, we must save then: */ - if (last_val == SCHEME_MULTIPLE_VALUES) { - save_array = p->ku.multiple.array; - save_count = p->ku.multiple.count; - - if (SAME_OBJ(save_array, p->values_buffer)) - p->values_buffer = NULL; - } - - if (SCHEME_SYMBOLP(modname)) - break; - } - - if (SCHEME_SYMBOLP(modname) && !got_one) { - Scheme_Input_Port *ip; - ip = scheme_input_port_record(port); - scheme_raise_exn(MZEXN_FAIL, - "default-load-handler: expected a `module' declaration;\n" - " found end-of-file\n" - " in: %V", - modname, - ip->name); - - return NULL; - } - - if (save_array) { - p->ku.multiple.array = save_array; - p->ku.multiple.count = save_count; - } - - return last_val; -} - -static int nonempty_symbol_list(Scheme_Object *p) -{ - if (!SCHEME_PAIRP(p)) return 0; - while (SCHEME_PAIRP(p)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return 0; - p = SCHEME_CDR(p); - } - return SCHEME_NULLP(p); -} - -static Scheme_Object *default_load(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *port, *name, *expected_module, *v; - int use_delay_load; - Scheme_Thread *p = scheme_current_thread; - Scheme_Config *config; - LoadHandlerData *lhd; - Scheme_Cont_Frame_Data cframe; - - if (!SCHEME_PATH_STRINGP(argv[0])) - scheme_wrong_contract("default-load-handler", "path-string?", 0, argc, argv); - expected_module = argv[1]; - if (!SCHEME_FALSEP(expected_module) - && !SCHEME_SYMBOLP(expected_module) - && (!SCHEME_PAIRP(expected_module) - || (!SCHEME_FALSEP(SCHEME_CAR(expected_module)) - && !SCHEME_SYMBOLP(SCHEME_CAR(expected_module))) - || !nonempty_symbol_list(SCHEME_CDR(expected_module)))) - scheme_wrong_contract("default-load-handler", - "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))", - 1, argc, argv); - - port = scheme_do_open_input_file("default-load-handler", 0, 1, argv, 0, SCHEME_TRUEP(expected_module)); - - /* Turn on line/column counting, unless it's a .zo file: */ - if (SCHEME_PATHP(argv[0])) { - intptr_t len; - - len = SCHEME_BYTE_STRLEN_VAL(argv[0]); - if ((len < 3) - || (SCHEME_BYTE_STR_VAL(argv[0])[len - 3] != '.') - || (SCHEME_BYTE_STR_VAL(argv[0])[len - 2] != 'z') - || (SCHEME_BYTE_STR_VAL(argv[0])[len - 1] != 'o')) - scheme_count_lines(port); - } else { - intptr_t len; - - len = SCHEME_CHAR_STRLEN_VAL(argv[0]); - if ((len < 3) - || (SCHEME_CHAR_STR_VAL(argv[0])[len - 3] != '.') - || (SCHEME_CHAR_STR_VAL(argv[0])[len - 2] != 'z') - || (SCHEME_CHAR_STR_VAL(argv[0])[len - 1] != 'o')) - scheme_count_lines(port); - } - - config = scheme_current_config(); - - v = scheme_get_param(config, MZCONFIG_LOAD_DELAY_ENABLED); - use_delay_load = SCHEME_TRUEP(v); - - if (SCHEME_TRUEP(expected_module)) { - config = scheme_extend_config(config, MZCONFIG_CASE_SENS, - (scheme_case_sensitive ? scheme_true : scheme_false)); /* for legacy code */ - config = scheme_extend_config(config, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CURLY_BRACES_ARE_PARENS, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_GRAPH, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_COMPILED, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_BOX, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_PIPE_QUOTE, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_DOT, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_INFIX_DOT, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_QUASI, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_true); - config = scheme_extend_config(config, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true); - config = scheme_extend_config(config, MZCONFIG_READTABLE, scheme_false); - config = scheme_extend_config(config, MZCONFIG_READ_CDOT, scheme_false); - config = scheme_extend_config(config, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, scheme_false); - config = scheme_extend_config(config, MZCONFIG_CURLY_BRACES_ARE_TAGGED, scheme_false); - } else { - config = scheme_extend_config(config, MZCONFIG_CAN_READ_COMPILED, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); - config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_true); - } - - if (use_delay_load) { - v = scheme_path_to_complete_path(argv[0], NULL); - config = scheme_extend_config(config, MZCONFIG_DELAY_LOAD_INFO, v); - } - - lhd = MALLOC_ONE_RT(LoadHandlerData); -#ifdef MZTAG_REQUIRED - lhd->type = scheme_rt_load_handler_data; -#endif - lhd->p = p; - lhd->config = config; - lhd->port = port; - name = scheme_input_port_record(port)->name; - lhd->stxsrc = name; - lhd->expected_module = expected_module; - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - v = scheme_dynamic_wind(NULL, do_load_handler, post_load_handler, - NULL, (void *)lhd); - - scheme_pop_continuation_frame(&cframe); - - return v; -} - -Scheme_Object *scheme_load_with_clrd(int argc, Scheme_Object *argv[], - char *who, int handler_param) -{ - const char *filename; - Scheme_Object *load_dir, *a[2], *filename_path, *v; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - if (!SCHEME_PATH_STRINGP(argv[0])) - scheme_wrong_contract(who, "path-string?", 0, argc, argv); - - filename = scheme_expand_string_filename(argv[0], - who, - NULL, - SCHEME_GUARD_FILE_READ); - - /* Calculate load directory */ - load_dir = scheme_get_file_directory(filename); - - filename_path = scheme_make_sized_path((char *)filename, -1, 0); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_LOAD_DIRECTORY, - load_dir); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - a[0] = filename_path; - a[1] = scheme_false; - v = _scheme_apply_multi(scheme_get_param(config, handler_param), 2, a); - - scheme_pop_continuation_frame(&cframe); - - return v; -} - -static Scheme_Object *load(int argc, Scheme_Object *argv[]) -{ - return scheme_load_with_clrd(argc, argv, "load", MZCONFIG_LOAD_HANDLER); -} - -static Scheme_Object * -current_load(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("current-load", - scheme_make_integer(MZCONFIG_LOAD_HANDLER), - argc, argv, - 2, NULL, NULL, 0); -} - -static Scheme_Object * -current_load_use_compiled(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config("current-load/use-compiled", - scheme_make_integer(MZCONFIG_LOAD_COMPILED_HANDLER), - argc, argv, - 2, NULL, NULL, 0); -} - static Scheme_Object *abs_directory_p(const char *name, Scheme_Object *d) { if (!SCHEME_FALSEP(d)) { @@ -5132,7 +4476,7 @@ load_on_demand_enabled(int argc, Scheme_Object *argv[]) Scheme_Object *scheme_load(const char *file) { - Scheme_Object *p[1]; + Scheme_Object *p[1], *load_proc; mz_jmp_buf newbuf, * volatile savebuf; Scheme_Object * volatile val; @@ -5142,8 +4486,8 @@ Scheme_Object *scheme_load(const char *file) if (scheme_setjmp(newbuf)) { val = NULL; } else { - val = scheme_apply_multi(scheme_make_prim((Scheme_Prim *)load), - 1, p); + load_proc = scheme_get_startup_export("load"); + val = scheme_apply_multi(load_proc, 1, p); } scheme_current_thread->error_buf = savebuf; @@ -5181,7 +4525,6 @@ START_XFORM_SKIP; static void register_traversers(void) { GC_REG_TRAV(scheme_rt_indexed_string, mark_indexed_string); - GC_REG_TRAV(scheme_rt_load_handler_data, mark_load_handler_data); GC_REG_TRAV(scheme_rt_user_input, mark_user_input); GC_REG_TRAV(scheme_rt_user_output, mark_user_output); } diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index 0881bb2426..ed6decde2e 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -48,7 +48,6 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *cache_ht); /* read-only globals */ SHARED_OK static char compacts[_CPT_COUNT_]; -SHARED_OK static Scheme_Hash_Table *global_constants_ht; ROSYM Scheme_Object *quote_symbol; ROSYM Scheme_Object *quasiquote_symbol; @@ -186,7 +185,7 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin #define make_hash_table_symtab() scheme_make_hash_table_eqv() -void scheme_init_print(Scheme_Env *env) +void scheme_init_print(Scheme_Startup_Env *env) { int i; @@ -218,12 +217,6 @@ void scheme_init_print(Scheme_Env *env) #endif } -void scheme_init_print_global_constants() -{ - REGISTER_SO(global_constants_ht); - global_constants_ht = scheme_map_constants_to_globals(); -} - void scheme_init_print_buffers_places() { REGISTER_SO(quick_buffer); @@ -1453,8 +1446,7 @@ static int compare_keys(const void *a, const void *b) || SCHEME_CHAR_STRINGP(v) \ || SCHEME_BYTE_STRINGP(v) \ || SCHEME_CHARP(v) \ - || SCHEME_NUMBERP(v) \ - || SAME_TYPE(SCHEME_TYPE(v), scheme_module_index_type)) + || SCHEME_NUMBERP(v)) av = ((Scheme_Object **)a)[0]; bv = ((Scheme_Object **)b)[0]; if (SCHEME_FIRSTP(av)) { @@ -1500,7 +1492,7 @@ static void print_table_keys(int notdisplay, int compact, Scheme_Hash_Table *ht, PrintParams *pp) { intptr_t j, size, offset; - Scheme_Object **keys, *key, *obj; + Scheme_Object **keys, *key; size = mt->sorted_keys_count; keys = mt->sorted_keys; @@ -1509,15 +1501,8 @@ static void print_table_keys(int notdisplay, int compact, Scheme_Hash_Table *ht, offset = pp->print_offset; mt->shared_offsets[j] = offset; key = keys[j << 1]; - if (mt->rn_saved) { - obj = scheme_hash_get(mt->rn_saved, key); - } else { - obj = NULL; - } - if (!obj) - obj = key; mt->print_now = j + 1; - print(obj ? obj : key, notdisplay, compact, ht, mt, pp); + print(key, notdisplay, compact, ht, mt, pp); mt->print_now = 0; } } @@ -1665,120 +1650,6 @@ static void print_symtab_set(PrintParams *pp, Scheme_Marshal_Tables *mt, Scheme_ print_compact_number(pp, l); } -Scheme_Object *scheme_marshal_wrap_set(Scheme_Marshal_Tables *mt, Scheme_Object *obj, Scheme_Object *val) -{ - int l; - l = add_symtab(mt, obj); - if (l) { - if (!mt->rn_saved) { - Scheme_Hash_Table *rn_saved; - rn_saved = scheme_make_hash_table(SCHEME_hash_ptr); - mt->rn_saved = rn_saved; - } - if (mt->pass >= 2) { - /* Done already */ - } else - scheme_hash_set(mt->rn_saved, obj, val); - - if (mt->pass) - return scheme_make_integer(l); - } - return val; -} - -Scheme_Object *scheme_marshal_lookup(Scheme_Marshal_Tables *mt, Scheme_Object *obj) -{ - return get_symtab_idx(mt, obj); -} - -void scheme_marshal_using_key(Scheme_Marshal_Tables *mt, Scheme_Object *obj) -{ - set_symtab_shared(mt, obj); -} - -void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt) -{ - Scheme_Object *p; - Scheme_Hash_Table *st_refs; - - if (mt->pass >= 0) { - p = scheme_make_pair((Scheme_Object *)mt->st_refs, - mt->st_ref_stack); - mt->st_ref_stack = p; - - st_refs = make_hash_table_symtab(); - - mt->st_refs = st_refs; - } -} - -void scheme_marshal_pop_refs(Scheme_Marshal_Tables *mt, int keep) -{ - Scheme_Hash_Table *st_refs = mt->st_refs; - - if (mt->pass >= 0) { - mt->st_refs = (Scheme_Hash_Table *)SCHEME_CAR(mt->st_ref_stack); - mt->st_ref_stack = SCHEME_CDR(mt->st_ref_stack); - - if (keep) { - if (!mt->st_refs->count) - mt->st_refs = st_refs; - else { - intptr_t i; - for (i = 0; i < st_refs->size; i++) { - if (st_refs->vals[i]) { - scheme_hash_set(mt->st_refs, st_refs->keys[i], st_refs->vals[i]); - } - } - } - } - } -} - -Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v) -{ - Scheme_Object *b; - - b = scheme_alloc_small_object(); - b->type = scheme_marshal_share_type; - SCHEME_PTR_VAL(b) = v; - - return b; -} - -static Scheme_Object *intern_modidx(Scheme_Hash_Table *interned, Scheme_Object *modidx) -{ - Scheme_Object *l = scheme_null; - Scheme_Modidx *midx; - - while (SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type)) { - midx = (Scheme_Modidx *)modidx; - modidx = scheme_hash_get(interned, modidx); - if (!modidx) { - modidx = (Scheme_Object *)midx; - if (SCHEME_FALSEP(midx->path)) { - scheme_hash_set(interned, modidx, modidx); - break; - } else { - l = scheme_make_pair(modidx, l); - modidx = midx->base; - } - } else - break; - } - - while (!SCHEME_NULLP(l)) { - midx = (Scheme_Modidx *)SCHEME_CAR(l); - modidx = scheme_make_modidx(midx->path, - modidx, - midx->resolved); - scheme_hash_set(interned, modidx, modidx); - l = SCHEME_CDR(l); - } - - return modidx; -} - static void print_escaped(PrintParams *pp, int notdisplay, Scheme_Object *obj, Scheme_Hash_Table *ht, Scheme_Marshal_Tables *mt, int shared) @@ -1877,98 +1748,87 @@ static int is_graph_point(Scheme_Hash_Table *ht, Scheme_Object *obj) return 0; } -static Scheme_Object *write_modules_to_strings_k(void); +static Scheme_Object *write_bundles_to_strings_k(void); -static Scheme_Object *write_modules_to_strings(Scheme_Object *l, - Scheme_Module *m, - Resolve_Prefix *prefix) +/* Bundles are written so that all of the link subdirectories content + of a link directory are together and terminated by a bundle or + #f (i.e., post-order traversal) */ +static Scheme_Object *write_bundles_to_strings(Scheme_Object *accum_l, + Scheme_Object *ld, + Scheme_Object *name_list) { - Scheme_Compilation_Top *top; - char *ns, *s; - intptr_t nlen, len; - Scheme_Object *pr; - Scheme_Module *m2; + Scheme_Hash_Tree *ht; + mzlonglong pos; + Scheme_Object *k, *v, *bundle = scheme_false; #ifdef DO_STACK_CHECK #include "mzstkchk.h" { Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = l; - p->ku.k.p2 = m; - p->ku.k.p3 = prefix; + p->ku.k.p1 = accum_l; + p->ku.k.p2 = ld; + p->ku.k.p3 = name_list; - return scheme_handle_stack_overflow(write_modules_to_strings_k); + return scheme_handle_stack_overflow(write_bundles_to_strings_k); } #endif - if ((m->pre_submodules && !SCHEME_NULLP(m->pre_submodules)) - || (m->post_submodules && !SCHEME_NULLP(m->post_submodules))) { - /* clone module to one without submodules: */ - m2 = MALLOC_ONE_TAGGED(Scheme_Module); - memcpy(m2, m, sizeof(Scheme_Module)); - m2->pre_submodules = scheme_null; - m2->post_submodules = scheme_null; - } else - m2 = m; + ht = (Scheme_Hash_Tree *)SCHEME_PTR_VAL(ld); - pr = m->pre_submodules; - if (pr) { - pr = scheme_reverse(pr); - while (!SCHEME_NULLP(pr)) { - l = write_modules_to_strings(l, (Scheme_Module *)SCHEME_CAR(pr), prefix); - pr = SCHEME_CDR(pr); + pos = scheme_hash_tree_next(ht, -1); + while (pos != -1) { + scheme_hash_tree_index(ht, pos, &k, &v); + if (SCHEME_SYMBOLP(k)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_directory_type)); + + accum_l = write_bundles_to_strings(accum_l, v, scheme_make_pair(k, name_list)); + } else { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + bundle = v; } + pos = scheme_hash_tree_next(ht, pos); } - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->iso.so.type = scheme_compilation_top_type; - top->code = (Scheme_Object *)m2; - top->max_let_depth = m->max_let_depth; - top->prefix = prefix; - - ns = scheme_submodule_path_to_string(m->submodule_path, &nlen); - s = scheme_write_to_string((Scheme_Object *)top, &len); - - l = scheme_make_pair(scheme_make_pair(scheme_make_sized_byte_string(ns, nlen, 0), - scheme_make_sized_byte_string(s, len, 0)), - l); - - pr = m->post_submodules; - if (pr) { - pr = scheme_reverse(pr); - while (!SCHEME_NULLP(pr)) { - l = write_modules_to_strings(l, (Scheme_Module *)SCHEME_CAR(pr), prefix); - pr = SCHEME_CDR(pr); - } + /* write root bundle, if any, or #f */ + { + intptr_t len, nlen; + char *s, *ns; + + ns = scheme_symbol_path_to_string(scheme_reverse(name_list), &nlen); + s = scheme_write_to_string(bundle, &len); + + accum_l = scheme_make_pair(scheme_make_pair(scheme_make_sized_byte_string(ns, nlen, 0), + scheme_make_sized_byte_string(s, len, 0)), + accum_l); } - return l; + return accum_l; } -static Scheme_Object *write_modules_to_strings_k(void) +static Scheme_Object *write_bundles_to_strings_k(void) { Scheme_Thread *p = scheme_current_thread; - Scheme_Object *l = (Scheme_Object *)p->ku.k.p1; - Scheme_Module *m = (Scheme_Module *)p->ku.k.p2; - Resolve_Prefix *pf = (Resolve_Prefix *)p->ku.k.p3; + Scheme_Object *accum_l = (Scheme_Object *)p->ku.k.p1; + Scheme_Object *ld = (Scheme_Object *)p->ku.k.p2; + Scheme_Object *name_list = (Scheme_Object *)p->ku.k.p3; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; - return write_modules_to_strings(l, m, pf); + return write_bundles_to_strings(accum_l, ld, name_list); } -typedef struct Module_And_Offset { - Scheme_Object *mod; +typedef struct Bundle_And_Offset { + Scheme_Object *bundle; Scheme_Object *offset; -} Module_And_Offset; +} Bundle_And_Offset; -static int compare_modules(const void *_am, const void *_bm) +static int compare_bundles(const void *_am, const void *_bm) { - Scheme_Object *a = ((Module_And_Offset *)_am)->mod; - Scheme_Object *b = ((Module_And_Offset *)_bm)->mod; + Scheme_Object *a = ((Bundle_And_Offset *)_am)->bundle; + Scheme_Object *b = ((Bundle_And_Offset *)_bm)->bundle; intptr_t i, alen, blen; unsigned char *as, *bs; @@ -1988,41 +1848,40 @@ static int compare_modules(const void *_am, const void *_bm) return (alen - blen); } -static intptr_t compute_module_subtrees(Module_And_Offset *a, intptr_t *subtrees, +static intptr_t compute_bundle_subtrees(Bundle_And_Offset *a, intptr_t *subtrees, int start, int count, intptr_t offset) { int midpt = start + (count / 2); - Scheme_Object *o = SCHEME_CAR(a[midpt].mod); + Scheme_Object *o = SCHEME_CAR(a[midpt].bundle); intptr_t len; len = SCHEME_BYTE_STRLEN_VAL(o); offset += 4 + len + 16; if (midpt > start) - offset = compute_module_subtrees(a, subtrees, start, midpt - start, offset); + offset = compute_bundle_subtrees(a, subtrees, start, midpt - start, offset); subtrees[midpt] = offset; count -= (midpt - start + 1); if (count) - return compute_module_subtrees(a, subtrees, midpt + 1, count, offset); + return compute_bundle_subtrees(a, subtrees, midpt + 1, count, offset); else return offset; } - -static intptr_t write_module_tree(PrintParams *pp, Module_And_Offset *a, +static intptr_t write_bundle_tree(PrintParams *pp, Bundle_And_Offset *a, intptr_t *subtrees, int start, int count, intptr_t offset) { int midpt = start + (count / 2); - Scheme_Object *o = SCHEME_CAR(a[midpt].mod); + Scheme_Object *o = SCHEME_CAR(a[midpt].bundle); intptr_t len; len = SCHEME_BYTE_STRLEN_VAL(o); print_number(pp, len); print_this_string(pp, SCHEME_BYTE_STR_VAL(o), 0, len); print_number(pp, SCHEME_INT_VAL(a[midpt].offset)); - print_number(pp, SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[midpt].mod))); + print_number(pp, SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[midpt].bundle))); offset += 20 + len; if (midpt > start) @@ -2036,9 +1895,9 @@ static intptr_t write_module_tree(PrintParams *pp, Module_And_Offset *a, print_number(pp, 0); if (midpt > start) - offset = write_module_tree(pp, a, subtrees, start, midpt - start, offset); + offset = write_bundle_tree(pp, a, subtrees, start, midpt - start, offset); if (count) - offset = write_module_tree(pp, a, subtrees, midpt + 1, count, offset); + offset = write_bundle_tree(pp, a, subtrees, midpt + 1, count, offset); return offset; } @@ -2088,6 +1947,9 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, || SCHEME_STRUCT_TYPEP(obj) || SCHEME_EOFP(obj) || SAME_OBJ(scheme_undefined, obj) + || SAME_OBJ(scheme_parameterization_key, obj) + || SAME_OBJ(scheme_break_enabled_key, obj) + || SAME_OBJ(scheme_exn_handler_key, obj) || SAME_TYPE(scheme_always_evt_type, SCHEME_TYPE(obj)) || SAME_TYPE(scheme_never_evt_type, SCHEME_TYPE(obj)) || SAME_TYPE(scheme_struct_property_type, SCHEME_TYPE(obj)) @@ -2095,10 +1957,11 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, || SAME_OBJ(scheme_app_mark_impersonator_property, obj))) { /* Check whether this is a global constant */ Scheme_Object *val; - val = scheme_hash_get(global_constants_ht, obj); + val = scheme_hash_get(scheme_startup_env->primitive_ids_table, obj); if (val) { - /* val is a scheme_variable_type object, instead of something else */ - obj = val; + print_compact(pp, CPT_REFERENCE); + print_compact_number(pp, SCHEME_INT_VAL(val)); + return 1; } } @@ -2697,44 +2560,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, } } } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)) - { - if (compact || !pp->print_unreadable) { - cannot_print(pp, notdisplay, obj, ht, compact); - } else { - int is_sym, is_sub; - Scheme_Object *rp; - - if (notdisplay) - print_utf8_string(pp, "#", 0, 1); - } - closed = notdisplay; - } else if (SCHEME_PRIMP(obj) && ((Scheme_Primitive_Proc *)obj)->name) { if (compact || !pp->print_unreadable) { @@ -2847,7 +2672,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, } else { print_utf8_string(pp, "struct-type-property", 0, 21); } - PRINTADDRESS(pp, obj); + PRINTADDRESS(pp, obj); print_utf8_string(pp, ">", 0, 1); } } @@ -2862,34 +2687,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print_utf8_string(pp, ">", 0, 1); } } - else if (SCHEME_NAMESPACEP(obj)) - { - if (compact || !pp->print_unreadable) { - cannot_print(pp, notdisplay, obj, ht, compact); - } else { - char s[10]; - - print_utf8_string(pp, "#module) { - Scheme_Object *modname; - int is_sym; - - modname = ((Scheme_Env *)obj)->module->modname; - is_sym = !SCHEME_PATHP(SCHEME_PTR_VAL(modname)); - print_utf8_string(pp, (is_sym ? "'" : "\""), 0, 1); - print(SCHEME_PTR_VAL(modname), 0, 0, ht, mt, pp); - PRINTADDRESS(pp, modname); - if (!is_sym) - print_utf8_string(pp, "\"" , 0, 1); - print_utf8_string(pp, ":", 0, 1); - } - - sprintf(s, "%" PRIdPTR "", ((Scheme_Env *)obj)->phase); - print_utf8_string(pp, s, 0, -1); - print_utf8_string(pp, ">", 0, 1); - } - } else if (SCHEME_INPORTP(obj)) { if (compact || !pp->print_unreadable) { @@ -2998,16 +2795,10 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, } else if (SCHEME_STXP(obj)) { - if (compact && !pp->printing_quoted) { - print_compact(pp, CPT_STX); - - /* "2" in scheme_syntax_to_datum() call preserves wraps. */ - closed = print(scheme_syntax_to_datum(obj, 2, mt), - notdisplay, 1, ht, mt, pp); - } else if (pp->print_unreadable) { + if (pp->print_unreadable) { Scheme_Stx *stx = (Scheme_Stx *)obj; if (stx->srcloc && ((stx->srcloc->line >= 0) || (stx->srcloc->pos >= 0))) { - print_utf8_string(pp, "#srcloc->src && SCHEME_PATHP(stx->srcloc->src)) { print_utf8_string(pp, SCHEME_BYTE_STR_VAL(stx->srcloc->src), 0, SCHEME_BYTE_STRLEN_VAL(stx->srcloc->src)); print_utf8_string(pp, ":", 0, 1); @@ -3022,13 +2813,13 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, stx->srcloc->pos); print_utf8_string(pp, quick_buffer, 0, -1); } else - print_utf8_string(pp, "#print_syntax) { intptr_t slen; char *str; int rel; print_utf8_string(pp, " ", 0, 1); - str = print_to_string(scheme_syntax_to_datum((Scheme_Object *)stx, 0, NULL), + str = print_to_string(scheme_syntax_to_datum((Scheme_Object *)stx), &slen, 1, NULL, pp->print_syntax, NULL, &rel); print_utf8_string(pp, str, 0, slen); if (rel && !quick_print_buffer) @@ -3039,151 +2830,20 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, cannot_print(pp, notdisplay, obj, ht, compact); } } - else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_inspector_type)) + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_toplevel_type))) { - /* For use by syntax objects, we map each inspector to an uninterned symbol */ - Scheme_Object *sym; - if (!mt->identity_map) { - Scheme_Hash_Table *id_map; - id_map = scheme_make_hash_table(SCHEME_hash_ptr); - mt->identity_map = id_map; - } - sym = scheme_hash_get(mt->identity_map, obj); - if (!sym) { - int id = mt->inspector_counter++; - char buf[32]; - sprintf(buf, "insp%d", id); - sym = scheme_make_symbol(buf); /* uninterned */ - scheme_hash_set(mt->identity_map, obj, sym); - } - closed = print(sym, notdisplay, 1, ht, mt, pp); - } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_scope_type) - && (compact || pp->print_unreadable)) - { - if (compact) { - Scheme_Object *idx; + int flags, pos, depth; - idx = scheme_stx_root_scope(); - if (SAME_OBJ(idx, obj)) { - print_compact(pp, CPT_ROOT_SCOPE); - } else { - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); - } else { - print_compact(pp, CPT_SCOPE); - print_symtab_set(pp, mt, obj); - idx = get_symtab_idx(mt, obj); - if (mt->reachable_scopes) { - idx = scheme_hash_get(mt->reachable_scopes, obj); - if (!idx) - scheme_signal_error("internal error: found supposedly unreachable scope"); - } else - idx = scheme_make_integer(0); - print_compact_number(pp, SCHEME_INT_VAL(idx)); - print(scheme_scope_marshal_content(obj, mt), notdisplay, 1, ht, mt, pp); - } - } - } else { - print_utf8_string(pp, "#", 0, 1); - } - } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) - { - Scheme_Object *idx; + print_compact(pp, CPT_TOPLEVEL); - if (compact) { - obj = intern_modidx(mt->intern_map, obj); - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); - } else { - print_compact(pp, CPT_MODULE_INDEX); - print(((Scheme_Modidx *)obj)->path, notdisplay, 1, ht, mt, pp); - print(((Scheme_Modidx *)obj)->base, notdisplay, 1, ht, mt, pp); - if (SCHEME_FALSEP(((Scheme_Modidx *)obj)->path) - && SCHEME_FALSEP(((Scheme_Modidx *)obj)->base)) - print(scheme_modidx_submodule(obj), notdisplay, 1, ht, mt, pp); - symtab_set(pp, mt, obj); - } - } else { - Scheme_Object *l = scheme_null; - Scheme_Modidx *modidx = (Scheme_Modidx *)obj; - print_utf8_string(pp, "#path)) { - l = scheme_make_pair(modidx->path, l); - if (SCHEME_FALSEP(modidx->base)) - break; - else if (SAME_TYPE(SCHEME_TYPE(modidx->base), scheme_resolved_module_path_type)) { - l = scheme_make_pair(modidx->base, l); - break; - } - modidx = (Scheme_Modidx *)modidx->base; - } - if (0 && SCHEME_FALSEP(modidx->path)) { - /* use hash code as identity of ending "self": */ - uintptr_t key; - key = scheme_hash_key((Scheme_Object *)modidx); - l = scheme_make_pair(scheme_make_integer_value_from_unsigned(key), - l); - } - l = scheme_reverse(l); - print(l, 1, 0, ht, mt, pp); - print_utf8_string(pp, ">", 0, 1); - } - } - else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type)) - { - Scheme_Object *idx; + flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK); + pos = SCHEME_TOPLEVEL_POS(obj); + depth = SCHEME_TOPLEVEL_DEPTH(obj); - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); - } else { - Module_Variable *mv = (Module_Variable *)obj; - int flags = SCHEME_MODVAR_FLAGS(mv); - - print_compact(pp, CPT_MODULE_VAR); - if (SAME_TYPE(SCHEME_TYPE(mv->modidx), scheme_resolved_module_path_type) - && SCHEME_SYMBOLP(SCHEME_PTR_VAL(mv->modidx))) { - print(SCHEME_PTR_VAL(mv->modidx), notdisplay, 1, ht, mt, pp); - } else { - print(mv->modidx, notdisplay, 1, ht, mt, pp); - } - print(mv->sym, notdisplay, 1, ht, mt, pp); - print(mv->shape ? mv->shape : scheme_false, notdisplay, 1, ht, mt, pp); - if (flags & 0x3) { - print_compact_number(pp, -3-(flags&0x3)); - } - if (mv->mod_phase) { - print_compact_number(pp, -2); - print_compact_number(pp, mv->mod_phase); - } - print_compact_number(pp, mv->pos); - - symtab_set(pp, mt, obj); - } - } - else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_variable_type) - && (((Scheme_Bucket_With_Flags *)obj)->flags & GLOB_HAS_REF_ID)) - { - int pos; - pos = ((Scheme_Bucket_With_Ref_Id *)obj)->id; - print_compact(pp, CPT_REFERENCE); + print_compact_number(pp, flags); print_compact_number(pp, pos); - } + print_compact_number(pp, depth); + } else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_local_unbox_type))) @@ -3255,6 +2915,61 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print(scheme_protect_quote(app->rand1), notdisplay, 1, NULL, mt, pp); closed = print(scheme_protect_quote(app->rand2), notdisplay, 1, NULL, mt, pp); } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type) + || SAME_TYPE(SCHEME_TYPE(obj), scheme_begin0_sequence_type))) + { + int i, count; + + print_compact(pp, (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type) + ? CPT_BEGIN + : CPT_BEGIN0)); + count = ((Scheme_Sequence *)obj)->count; + print_compact_number(pp, count); + + for (i = 0; i < count; i++) { + closed = print(scheme_protect_quote(((Scheme_Sequence *)obj)->array[i]), notdisplay, 1, NULL, mt, pp); + } + } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_let_value_type))) + { + Scheme_Let_Value *lv; + + lv = (Scheme_Let_Value *)obj; + + print_compact(pp, CPT_LET_VALUE); + print_compact_number(pp, lv->count); + print_compact_number(pp, lv->position); + print_compact_number(pp, (SCHEME_LET_VALUE_AUTOBOX(lv) ? 1 : 0)); + print(scheme_protect_quote(lv->value), notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(lv->body), notdisplay, 1, NULL, mt, pp); + } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_let_void_type))) + { + Scheme_Let_Void *lv; + + lv = (Scheme_Let_Void *)obj; + + print_compact(pp, CPT_LET_VOID); + print_compact_number(pp, lv->count); + print_compact_number(pp, (SCHEME_LET_VOID_AUTOBOX(lv) ? 1 : 0)); + closed = print(scheme_protect_quote(lv->body), notdisplay, 1, NULL, mt, pp); + } + else if (compact && (SAME_TYPE(SCHEME_TYPE(obj), scheme_letrec_type))) + { + Scheme_Letrec *lr = (Scheme_Letrec *)obj; + int i, count; + + count = lr->count; + + print_compact(pp, CPT_LETREC); + print_compact_number(pp, count); + + for (i = 0; i < count; i++) { + print(scheme_protect_quote(lr->procs[i]), notdisplay, 1, NULL, mt, pp); + } + + closed = print(scheme_protect_quote(lr->body), notdisplay, 1, NULL, mt, pp); + } else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_let_one_type)) { Scheme_Let_One *lo; @@ -3283,6 +2998,134 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print(scheme_protect_quote(b->tbranch), notdisplay, 1, NULL, mt, pp); closed = print(scheme_protect_quote(b->fbranch), notdisplay, 1, NULL, mt, pp); } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_with_cont_mark_type)) + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj; + + print_compact(pp, CPT_WCM); + print(scheme_protect_quote(wcm->key), notdisplay, 1, NULL, mt, pp); + print(scheme_protect_quote(wcm->val), notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(wcm->body), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_define_values_type)) + { + Scheme_Object *e; + + print_compact(pp, CPT_DEFINE_VALUES); + + obj = scheme_clone_vector(obj, 0, 0); + e = scheme_protect_quote(SCHEME_VEC_ELS(obj)[0]); + SCHEME_VEC_ELS(obj)[0] = e; + + closed = print(obj, notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_set_bang_type)) + { + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj; + + print_compact(pp, CPT_SET_BANG); + print_compact_number(pp, sb->set_undef ? 1 : 0); + print(sb->var, notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(sb->val), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_boxenv_type)) + { + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_boxenv_type); + + print(SCHEME_PTR1_VAL(obj), notdisplay, 1, NULL, mt, pp); + closed = print(SCHEME_PTR2_VAL(obj), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_varref_form_type)) + { + print_compact(pp, CPT_VARREF); + + print_compact_number(pp, SCHEME_VARREF_FLAGS(obj) & VARREF_FLAGS_MASK); + print(SCHEME_PTR1_VAL(obj), notdisplay, 1, NULL, mt, pp); + closed = print(SCHEME_PTR2_VAL(obj), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_apply_values_type)) + { + print_compact(pp, CPT_APPLY_VALUES); + + print(scheme_protect_quote(SCHEME_PTR1_VAL(obj)), notdisplay, 1, NULL, mt, pp); + closed = print(scheme_protect_quote(SCHEME_PTR2_VAL(obj)), notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_with_immed_mark_type)) + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)obj; + + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_with_immed_mark_type); + + print(wcm->key, notdisplay, 1, NULL, mt, pp); + print(wcm->val, notdisplay, 1, NULL, mt, pp); + closed = print(wcm->body, notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_inline_variant_type)) + { + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_inline_variant_type); + + print(SCHEME_VEC_ELS(obj)[0], notdisplay, 1, NULL, mt, pp); + closed = print(SCHEME_VEC_ELS(obj)[1], notdisplay, 1, NULL, mt, pp); + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_case_lambda_sequence_type)) + { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)obj; + int i, count; + + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_case_lambda_sequence_type); + + count = cl->count; + print_compact_number(pp, count); + + print(scheme_closure_marshal_name(cl->name), notdisplay, 1, NULL, mt, pp); + + for (i = 0; i < count; i++) { + closed = print(cl->array[i], notdisplay, 1, NULL, mt, pp); + } + } + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_lambda_type)) + { + Scheme_Lambda *data = (Scheme_Lambda *)obj; + Scheme_Object *name, *ds, *closure_map, *tl_map; + + print_compact(pp, CPT_OTHER_FORM); + print_compact_number(pp, scheme_lambda_type); + + scheme_write_lambda(obj, &name, &ds, &closure_map, &tl_map); + + print_compact_number(pp, SCHEME_LAMBDA_FLAGS(data) & 0x7F); + if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) + print_compact_number(pp, data->closure_size); + print_compact_number(pp, data->num_params); + print_compact_number(pp, data->max_let_depth); + + print(name, notdisplay, 1, NULL, mt, pp); + print(ds, notdisplay, 1, NULL, mt, pp); + print(closure_map, notdisplay, 1, NULL, mt, pp); + closed = print(tl_map, notdisplay, 1, NULL, mt, pp); + } +#ifdef MZ_PRECISE_GC + else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_rt_delay_load_info)) + { + Scheme_Load_Delay *ld; + int l; + ld = (Scheme_Load_Delay *)obj; + print_utf8_string(pp, "#path)) { + l = SCHEME_PATH_LEN(ld->path); + print_this_string(pp, SCHEME_PATH_VAL(ld->path), 0, l); + } + else { + print_utf8_string(pp, "???", 0, 3); + } + print_utf8_string(pp, ">", 0, 1); + + } +#endif else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_quote_compilation_type)) { Scheme_Hash_Table *q_ht; @@ -3378,161 +3221,93 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, set_symtab_shared(mt, obj); } } - else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_marshal_share_type)) + else if (!compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_directory_type)) { - if (compact) { - Scheme_Object *idx; - - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); - } else { - int l; - l = add_symtab(mt, obj); - obj = SCHEME_PTR_VAL(obj); - if (l) - print_general_symtab_ref(pp, scheme_make_integer(l), CPT_SHARED); - print(obj, notdisplay, 1, ht, mt, pp); - } - } else { - print(SCHEME_PTR_VAL(obj), notdisplay, 0, ht, mt, pp); - } - } - else if (!compact - && SAME_TYPE(SCHEME_TYPE(obj), scheme_compilation_top_type) - && SAME_TYPE(SCHEME_TYPE(((Scheme_Compilation_Top *)obj)->code), scheme_module_type) - && ((((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->pre_submodules - && !SCHEME_NULLP(((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->pre_submodules)) - || (((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->post_submodules - && !SCHEME_NULLP(((Scheme_Module *)((Scheme_Compilation_Top *)obj)->code)->post_submodules)))) - { - /* Write a module group with an initial directory */ - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj; - Scheme_Object *mods, *p; - Module_And_Offset *a, *orig_a; + /* Write directory content with an index at the beginning */ + Scheme_Object *p, *accum_l; + Bundle_And_Offset *a; intptr_t *subtrees, offset, init_offset; int count, i; init_offset = 2 + 1 + strlen(MZSCHEME_VERSION) + 1 + 4; - mods = write_modules_to_strings(scheme_null, - (Scheme_Module *)top->code, - top->prefix); - mods = scheme_reverse(mods); /* write order == valid declaration order */ + accum_l = write_bundles_to_strings(scheme_null, obj, scheme_null); - for (p = mods, count = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { + for (p = accum_l, count = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { count++; } - a = MALLOC_N(Module_And_Offset, count); - orig_a = MALLOC_N(Module_And_Offset, count); - for (p = mods, i = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p), i++) { - a[i].mod = SCHEME_CAR(p); - orig_a[i].mod = a[i].mod; + a = MALLOC_N(Bundle_And_Offset, count); + for (p = accum_l, i = 0; !SCHEME_NULLP(p); p = SCHEME_CDR(p), i++) { + a[i].bundle = SCHEME_CAR(p); } + my_qsort(a, count, sizeof(Bundle_And_Offset), compare_bundles); offset = init_offset; for (i = 0; i < count; i++) { - offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(a[i].mod)) + 20; + offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(a[i].bundle)) + 20; } for (i = 0; i < count; i++) { a[i].offset = scheme_make_integer(offset); - offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].mod)); + offset += SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].bundle)); } - my_qsort(a, count, sizeof(Module_And_Offset), compare_modules); - /* orig_a is in declaration order, a in sorted (for btree) order */ + /* a is in sorted (for btree) order */ subtrees = MALLOC_N_ATOMIC(intptr_t, count); - (void)compute_module_subtrees(a, subtrees, 0, count, init_offset); + (void)compute_bundle_subtrees(a, subtrees, 0, count, init_offset); print_this_string(pp, "#~", 0, 2); print_one_byte(pp, strlen(MZSCHEME_VERSION)); print_this_string(pp, MZSCHEME_VERSION, 0, -1); - /* "D" means "directory": */ + /* "D" means "linklet directory": */ print_this_string(pp, "D", 0, 1); print_number(pp, count); - /* Write the module directory as a binary search tree. */ - (void)write_module_tree(pp, a, subtrees, 0, count, init_offset); + /* Write the bundle directory as a binary search tree. */ + (void)write_bundle_tree(pp, a, subtrees, 0, count, init_offset); - /* Write the modules: */ + /* Write the bundles: */ for (i = 0; i < count; i++) { print_this_string(pp, - SCHEME_BYTE_STR_VAL(SCHEME_CDR(orig_a[i].mod)), + SCHEME_BYTE_STR_VAL(SCHEME_CDR(a[i].bundle)), 0, - SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(orig_a[i].mod))); + SCHEME_BYTE_STRLEN_VAL(SCHEME_CDR(a[i].bundle))); } } - else if (SCHEME_TYPE(obj) <= _scheme_last_type_ && scheme_type_writers[SCHEME_TYPE(obj)] - && (compact || SAME_TYPE(SCHEME_TYPE(obj), scheme_compilation_top_type))) + else if ((compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_type)) + || SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_bundle_type)) { - Scheme_Type t = SCHEME_TYPE(obj); - Scheme_Object *v; - intptr_t slen; - - if (t >= _scheme_last_type_) { - /* Doesn't happen: */ - scheme_signal_error("internal error: bad type with writer"); - return 0; - } - if (compact) { - if (t < CPT_RANGE(SMALL_MARSHALLED)) { - unsigned char s[1]; - s[0] = t + CPT_SMALL_MARSHALLED_START; - print_this_string(pp, (char *)s, 0, 1); - } else { - print_compact(pp, CPT_MARSHALLED); - print_compact_number(pp, t); - } - } else { - print_this_string(pp, "#~", 0, 2); - } + Scheme_Object *v; - { - Scheme_Type_Writer writer; - writer = scheme_type_writers[t]; - v = writer(obj); - } - - if (compact) + print_compact(pp, CPT_LINKLET); + v = scheme_write_linklet(obj); + closed = print(v, notdisplay, 1, NULL, mt, pp); - else { - Scheme_Hash_Table *st_refs, *symtab, *reachable_scopes, *intern_map, *path_cache; + } else { + Scheme_Hash_Table *st_refs, *symtab, *intern_map, *path_cache; + Scheme_Object *v; intptr_t *shared_offsets; intptr_t st_len, j, shared_offset, start_offset; + intptr_t slen; + + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(obj), scheme_linklet_bundle_type)); + v = SCHEME_PTR_VAL(obj); /* extract hash table from a linklet bundle */ + + print_this_string(pp, "#~", 0, 2); mt = MALLOC_ONE_RT(Scheme_Marshal_Tables); SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info); scheme_current_thread->current_mt = mt; - - /* We need to compare a modidx using `eq?`, because shifting - is based on `eq`ness. */ - intern_map = scheme_make_hash_table_equal_modix_eq(); + + intern_map = scheme_make_hash_table(SCHEME_hash_ptr); mt->intern_map = intern_map; - /* "Print" the string once to find out which scopes are reachable; - dropping unreachable scopes drops potentialy large binding tables. */ - mt->pass = -1; - reachable_scopes = scheme_make_hash_table(SCHEME_hash_ptr); - mt->conditionally_reachable_scopes = reachable_scopes; - reachable_scopes = scheme_make_hash_table(SCHEME_hash_ptr); - mt->reachable_scopes = reachable_scopes; - mt->reachable_scope_stack = scheme_null; symtab = make_hash_table_symtab(); mt->symtab = symtab; path_cache = scheme_make_hash_table_equal(); mt->path_cache = path_cache; - print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL); - scheme_iterate_reachable_scopes(mt); - mt->pending_reachable_ids = NULL; - - mt = MALLOC_ONE_RT(Scheme_Marshal_Tables); - SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info); scheme_current_thread->current_mt = mt; - mt->reachable_scopes = reachable_scopes; - mt->intern_map = intern_map; - mt->path_cache = path_cache; /* Track which shared values are referenced: */ st_refs = make_hash_table_symtab(); @@ -3551,7 +3326,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL); sort_referenced_keys(mt); - mt->rn_saved = NULL; /* "Print" again, now that we know which values are actually shared. On this pass, shared values that reference other shared values @@ -3560,7 +3334,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, mt->shared_offsets = shared_offsets; symtab = make_hash_table_symtab(); mt->symtab = symtab; - mt->top_map = NULL; mt->pass = 1; print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 1, &st_len); @@ -3568,7 +3341,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, /* "Print" the string again to get a measurement and symtab size. */ symtab = make_hash_table_symtab(); mt->symtab = symtab; - mt->top_map = NULL; mt->pass = 2; print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, -1, &st_len); @@ -3577,7 +3349,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print_one_byte(pp, strlen(MZSCHEME_VERSION)); print_this_string(pp, MZSCHEME_VERSION, 0, -1); - print_this_string(pp, "T", 0, 1); /* "T" means "top" */ + print_this_string(pp, "B", 0, 1); /* "B" means "bundle" */ /* Leave space for a module hash code */ print_this_string(pp, "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 0, 20); @@ -3608,7 +3380,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, for the final print: */ symtab = make_hash_table_symtab(); mt->symtab = symtab; - mt->top_map = NULL; mt->pass = 3; start_offset = pp->print_offset; diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index ef0b46063b..c0fd6aff7a 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -62,11 +62,9 @@ SHARED_OK int scheme_curly_braces_are_parens = 1; /* global flag set from environment variable */ SHARED_OK static int use_perma_cache = 1; -THREAD_LOCAL_DECL(int scheme_num_read_syntax_objects); - +THREAD_LOCAL_DECL(int scheme_num_read_syntax_objects = 0); /* read-only global symbols */ -SHARED_OK static char *builtin_fast; SHARED_OK static unsigned char delim[128]; SHARED_OK static unsigned char cpt_branch[256]; @@ -82,33 +80,13 @@ ROSYM static Scheme_Object *syntax_symbol; ROSYM static Scheme_Object *unsyntax_symbol; ROSYM static Scheme_Object *unsyntax_splicing_symbol; ROSYM static Scheme_Object *quasisyntax_symbol; -ROSYM static Scheme_Object *brackets_symbol; -ROSYM static Scheme_Object *braces_symbol; -ROSYM static Scheme_Object *dot_symbol; -ROSYM static Scheme_Object *terminating_macro_symbol; -ROSYM static Scheme_Object *non_terminating_macro_symbol; -ROSYM static Scheme_Object *dispatch_macro_symbol; -/* For recoginizing unresolved hash tables and commented-out graph introductions: */ -ROSYM static Scheme_Object *unresolved_uninterned_symbol; -ROSYM static Scheme_Object *tainted_uninterned_symbol; +ROSYM static Scheme_Object *hash_code_symbol; +ROSYM static Scheme_Object *pre_symbol; +ROSYM static Scheme_Object *post_symbol; /* local function prototypes */ static Scheme_Object *read_case_sensitive(int, Scheme_Object *[]); -static Scheme_Object *read_bracket_as_paren(int, Scheme_Object *[]); -static Scheme_Object *read_brace_as_paren(int, Scheme_Object *[]); -static Scheme_Object *read_bracket_with_tag(int, Scheme_Object *[]); -static Scheme_Object *read_brace_with_tag(int, Scheme_Object *[]); -static Scheme_Object *read_cdot(int, Scheme_Object *[]); -static Scheme_Object *read_accept_graph(int, Scheme_Object *[]); -static Scheme_Object *read_accept_compiled(int, Scheme_Object *[]); -static Scheme_Object *read_accept_box(int, Scheme_Object *[]); static Scheme_Object *read_accept_pipe_quote(int, Scheme_Object *[]); -static Scheme_Object *read_decimal_as_inexact(int, Scheme_Object *[]); -static Scheme_Object *read_accept_dot(int, Scheme_Object *[]); -static Scheme_Object *read_accept_infix_dot(int, Scheme_Object *[]); -static Scheme_Object *read_accept_quasi(int, Scheme_Object *[]); -static Scheme_Object *read_accept_reader(int, Scheme_Object *[]); -static Scheme_Object *read_accept_lang(int, Scheme_Object *[]); #ifdef LOAD_ON_DEMAND static Scheme_Object *read_delay_load(int, Scheme_Object *[]); #endif @@ -127,28 +105,10 @@ static Scheme_Object *print_long_bool(int, Scheme_Object *[]); #define NOT_EOF_OR_SPECIAL(x) ((x) >= 0) -#define mzSPAN(port, pos) () - -#define NOT_ENABLED_str " not enabled in the current context" - #define isdigit_ascii(n) ((n >= '0') && (n <= '9')) #define scheme_isxdigit(n) (isdigit_ascii(n) || ((n >= 'a') && (n <= 'f')) || ((n >= 'A') && (n <= 'F'))) -#define RETURN_FOR_SPECIAL_COMMENT 0x1 -#define RETURN_FOR_HASH_COMMENT 0x2 -#define RETURN_FOR_DELIM 0x4 -#define RETURN_FOR_COMMENT 0x8 - -static MZ_INLINE intptr_t SPAN(Scheme_Object *port, intptr_t pos) { - intptr_t cpos; - scheme_tell_all(port, NULL, NULL, &cpos); - return cpos - pos + 1; -} - -/* For cases where we'd rather report the location as just the relevant prefix: */ -#define MINSPAN(port, pos, span) (span) - #define mz_shape_cons 0 #define mz_shape_vec 1 #define mz_shape_hash_list 2 @@ -157,250 +117,77 @@ static MZ_INLINE intptr_t SPAN(Scheme_Object *port, intptr_t pos) { #define mz_shape_fl_vec 5 #define mz_shape_fx_vec 6 -typedef struct Readtable { - Scheme_Object so; - Scheme_Hash_Table *mapping; /* pos int -> (cons int proc-or-char); neg int -> proc */ - char *fast_mapping; - Scheme_Object *symbol_parser; /* NULL or a Racket function */ - char **names; /* error-message names */ -} Readtable; +#define MAX_GRAPH_ID_DIGITS 8 typedef struct ReadParams { MZTAG_IF_REQUIRED - char can_read_compiled; - char can_read_unsafe; - char can_read_pipe_quote; - char can_read_box; - char can_read_graph; - char can_read_reader; - char can_read_lang; - char case_sensitive; - char square_brackets_are_parens; - char curly_braces_are_parens; - char square_brackets_are_tagged; - char curly_braces_are_tagged; - char read_cdot; - char read_decimal_inexact; - char can_read_dot; - char can_read_infix_dot; - char can_read_quasi; char skip_zo_vers_check; - Readtable *table; - Scheme_Object *magic_sym, *magic_val; + char can_read_unsafe; Scheme_Object *delay_load_info; Scheme_Object *read_relative_path; + Scheme_Hash_Table *graph_ht; } ReadParams; #define THREAD_FOR_LOCALS scheme_current_thread -static Scheme_Object *read_list(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_list(Scheme_Object *port, int opener, int closer, int shape, int use_stack, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); + ReadParams *params); static Scheme_Object *read_string(int is_byte, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, + Scheme_Object *port, + ReadParams *params, int err_ok); -static Scheme_Object *read_here_string(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params); static Scheme_Object *read_quote(char *who, Scheme_Object *quote_symbol, int len, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, + Scheme_Object *port, ReadParams *params); -static Scheme_Object *read_vector(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_vector(Scheme_Object *port, int opener, char closer, - intptr_t reqLen, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, + ReadParams *params, int allow_infix); -static Scheme_Object *read_flvector (Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int opener, char closer, - intptr_t requestLength, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - int allow_infix); -static Scheme_Object *read_fxvector (Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int opener, char closer, - intptr_t requestLength, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - int allow_infix); +static Scheme_Object *read_number_or_symbol(int init_ch, Scheme_Object *port, + int is_float, int is_not_float, + int radix, int radix_set, + int is_symbol, int is_kw, + ReadParams *params); static Scheme_Object *read_number(int init_ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, + Scheme_Object *port, int, int, int, int, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); -static Scheme_Object *read_symbol(int init_ch, int skip_rt, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); + ReadParams *params); +static Scheme_Object *read_symbol(int init_ch, + Scheme_Object *port, + ReadParams *params); static Scheme_Object *read_keyword(int init_ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - Readtable *table); + Scheme_Object *port, + ReadParams *params); static Scheme_Object *read_delimited_constant(int ch, const mzchar *str, Scheme_Object *v, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params, Readtable *table); -static Scheme_Object *read_character(Scheme_Object *port, Scheme_Object *stcsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, + ReadParams *params); +static Scheme_Object *read_character(Scheme_Object *port, ReadParams *params); -static Scheme_Object *read_box(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, +static Scheme_Object *read_box(Scheme_Object *port, ReadParams *params); -static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_hash(Scheme_Object *port, int opener, char closer, int kind, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table); -static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params); -static Scheme_Object *read_lang(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int init_ch); -static Scheme_Object *read_compiled(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, + ReadParams *params); +static Scheme_Object *read_compiled(Scheme_Object *port, ReadParams *params); static void unexpected_closer(int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params); -static Scheme_Object *expected_lang(const char *prefix, int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int get_info); -static void pop_indentation(Scheme_Object *indentation); -static int next_is_delim(Scheme_Object *port, - ReadParams *params, - int brackets, - int braces); - -static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - Scheme_Object **prefetched); - -static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, Scheme_Object *modpath_stx); -static Scheme_Object *read_flonum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); -static Scheme_Object *read_fixnum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); -static Scheme_Object *read_number_literal(Scheme_Object *port, - Scheme_Object *stxsrc, - int is_float, int is_not_float, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); - -#define READTABLE_WHITESPACE 0x1 -#define READTABLE_CONTINUING 0x2 -#define READTABLE_TERMINATING 0x4 -#define READTABLE_SINGLE_ESCAPE 0x8 -#define READTABLE_MULTIPLE_ESCAPE 0x10 -#define READTABLE_MAPPED 0x20 -static int readtable_kind(Readtable *t, int ch, ReadParams *params); -static Scheme_Object *readtable_handle(Readtable *t, int *_ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht); -static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht); -static int readtable_effective_char(Readtable *t, int ch); -static Scheme_Object *make_readtable(int argc, Scheme_Object **argv); -static Scheme_Object *readtable_p(int argc, Scheme_Object **argv); -static Scheme_Object *readtable_mapping(int argc, Scheme_Object **argv); -static Scheme_Object *current_readtable(int argc, Scheme_Object **argv); -static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv); + Scheme_Object *port); +static int next_is_delim(Scheme_Object *port); +static int read_graph_index(Scheme_Object *port, int *ch); +static int skip_whitespace_comments(Scheme_Object *port, + ReadParams *params); static Scheme_Object *read_intern(int argc, Scheme_Object **argv); -/* A list stack is used to speed up the creation of intermediate lists - during .zo reading. */ - -#define NUM_CELLS_PER_STACK 500 - #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -typedef struct { - Scheme_Type type; - char closer; /* expected close parent, bracket, etc. */ - char suspicious_closer; /* expected closer when suspicious line found */ - char multiline; /* set to 1 if the match attempt spans a line */ - intptr_t start_line; /* opener's line */ - intptr_t last_line; /* current line, already checked the identation */ - intptr_t suspicious_line; /* non-0 => first suspicious line since opener */ - intptr_t max_indent; /* max indentation encountered so far since opener, - not counting indentation brackets by a more neseted - opener */ - intptr_t suspicious_quote; /* non-0 => first suspicious quote whose closer - is on a different line */ -} Scheme_Indent; - #define SCHEME_OK 0x1 -#define is_lang_nonsep_char(ch) (scheme_isalpha(ch) \ - || scheme_isdigit(ch) \ - || ((ch) == '-') \ - || ((ch) == '+') \ - || ((ch) == '_')) - #define NEXT_LINE_CHAR 0x85 #define LINE_SEPARATOR_CHAR 0x2028 #define PARAGRAPH_SEPARATOR_CHAR 0x2029 @@ -413,7 +200,7 @@ typedef struct { /* initialization */ /*========================================================================*/ -void scheme_init_read(Scheme_Env *env) +void scheme_init_read(Scheme_Startup_Env *env) { REGISTER_SO(quote_symbol); REGISTER_SO(quasiquote_symbol); @@ -424,16 +211,9 @@ void scheme_init_read(Scheme_Env *env) REGISTER_SO(unsyntax_splicing_symbol); REGISTER_SO(quasisyntax_symbol); - REGISTER_SO(brackets_symbol); - REGISTER_SO(braces_symbol); - REGISTER_SO(dot_symbol); - - REGISTER_SO(unresolved_uninterned_symbol); - REGISTER_SO(tainted_uninterned_symbol); - REGISTER_SO(terminating_macro_symbol); - REGISTER_SO(non_terminating_macro_symbol); - REGISTER_SO(dispatch_macro_symbol); - REGISTER_SO(builtin_fast); + REGISTER_SO(hash_code_symbol); + REGISTER_SO(pre_symbol); + REGISTER_SO(post_symbol); quote_symbol = scheme_intern_symbol("quote"); quasiquote_symbol = scheme_intern_symbol("quasiquote"); @@ -444,40 +224,9 @@ void scheme_init_read(Scheme_Env *env) unsyntax_splicing_symbol = scheme_intern_symbol("unsyntax-splicing"); quasisyntax_symbol = scheme_intern_symbol("quasisyntax"); - brackets_symbol = scheme_intern_symbol("#%brackets"); - braces_symbol = scheme_intern_symbol("#%braces"); - dot_symbol = scheme_intern_symbol("#%dot"); - - unresolved_uninterned_symbol = scheme_make_symbol("unresolved"); - tainted_uninterned_symbol = scheme_make_symbol("tainted"); - - terminating_macro_symbol = scheme_intern_symbol("terminating-macro"); - non_terminating_macro_symbol = scheme_intern_symbol("non-terminating-macro"); - dispatch_macro_symbol = scheme_intern_symbol("dispatch-macro"); - - /* initialize builtin_fast */ - { - int i; - builtin_fast = scheme_malloc_atomic(128); - memset(builtin_fast, READTABLE_CONTINUING, 128); - for (i = 0; i < 128; i++) { - if (scheme_isspace(i)) - builtin_fast[i] = READTABLE_WHITESPACE; - } - builtin_fast[';'] = READTABLE_TERMINATING; - builtin_fast['\''] = READTABLE_TERMINATING; - builtin_fast['`'] = READTABLE_TERMINATING; - builtin_fast[','] = READTABLE_TERMINATING; - builtin_fast['"'] = READTABLE_TERMINATING; - builtin_fast['|'] = READTABLE_MULTIPLE_ESCAPE; - builtin_fast['\\'] = READTABLE_SINGLE_ESCAPE; - builtin_fast['('] = READTABLE_TERMINATING; - builtin_fast['['] = READTABLE_TERMINATING; - builtin_fast['{'] = READTABLE_TERMINATING; - builtin_fast[')'] = READTABLE_TERMINATING; - builtin_fast[']'] = READTABLE_TERMINATING; - builtin_fast['}'] = READTABLE_TERMINATING; - } + hash_code_symbol = scheme_intern_symbol("hash-code"); + pre_symbol = scheme_intern_symbol("pre"); + post_symbol = scheme_intern_symbol("post"); /* initialize cpt_branch */ { @@ -493,7 +242,6 @@ void scheme_init_read(Scheme_Env *env) } FILL_IN(SMALL_NUMBER); FILL_IN(SMALL_SYMBOL); - FILL_IN(SMALL_MARSHALLED); FILL_IN(SMALL_LIST); FILL_IN(SMALL_PROPER_LIST); FILL_IN(SMALL_LOCAL); @@ -528,45 +276,25 @@ void scheme_init_read(Scheme_Env *env) register_traversers(); #endif - GLOBAL_PARAMETER("current-readtable", current_readtable, MZCONFIG_READTABLE, env); - GLOBAL_PARAMETER("current-reader-guard", current_reader_guard, MZCONFIG_READER_GUARD, env); - GLOBAL_PARAMETER("read-case-sensitive", read_case_sensitive, MZCONFIG_CASE_SENS, env); - GLOBAL_PARAMETER("read-square-bracket-as-paren", read_bracket_as_paren, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, env); - GLOBAL_PARAMETER("read-curly-brace-as-paren", read_brace_as_paren, MZCONFIG_CURLY_BRACES_ARE_PARENS, env); - GLOBAL_PARAMETER("read-square-bracket-with-tag", read_bracket_with_tag, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, env); - GLOBAL_PARAMETER("read-curly-brace-with-tag", read_brace_with_tag, MZCONFIG_CURLY_BRACES_ARE_TAGGED, env); - GLOBAL_PARAMETER("read-cdot", read_cdot, MZCONFIG_READ_CDOT, env); - GLOBAL_PARAMETER("read-accept-graph", read_accept_graph, MZCONFIG_CAN_READ_GRAPH, env); - GLOBAL_PARAMETER("read-accept-compiled", read_accept_compiled, MZCONFIG_CAN_READ_COMPILED, env); - GLOBAL_PARAMETER("read-accept-box", read_accept_box, MZCONFIG_CAN_READ_BOX, env); - GLOBAL_PARAMETER("read-accept-bar-quote", read_accept_pipe_quote, MZCONFIG_CAN_READ_PIPE_QUOTE, env); - GLOBAL_PARAMETER("read-decimal-as-inexact", read_decimal_as_inexact,MZCONFIG_READ_DECIMAL_INEXACT, env); - GLOBAL_PARAMETER("read-accept-dot", read_accept_dot, MZCONFIG_CAN_READ_DOT, env); - GLOBAL_PARAMETER("read-accept-infix-dot", read_accept_infix_dot, MZCONFIG_CAN_READ_INFIX_DOT, env); - GLOBAL_PARAMETER("read-accept-quasiquote", read_accept_quasi, MZCONFIG_CAN_READ_QUASI, env); - GLOBAL_PARAMETER("read-accept-reader", read_accept_reader, MZCONFIG_CAN_READ_READER, env); - GLOBAL_PARAMETER("read-accept-lang", read_accept_lang, MZCONFIG_CAN_READ_LANG, env); + ADD_PARAMETER("read-case-sensitive", read_case_sensitive, MZCONFIG_CASE_SENS, env); + ADD_PARAMETER("read-accept-bar-quote", read_accept_pipe_quote, MZCONFIG_CAN_READ_PIPE_QUOTE, env); #ifdef LOAD_ON_DEMAND - GLOBAL_PARAMETER("read-on-demand-source", read_delay_load, MZCONFIG_DELAY_LOAD_INFO, env); + ADD_PARAMETER("read-on-demand-source", read_delay_load, MZCONFIG_DELAY_LOAD_INFO, env); #endif - GLOBAL_PARAMETER("print-graph", print_graph, MZCONFIG_PRINT_GRAPH, env); - GLOBAL_PARAMETER("print-struct", print_struct, MZCONFIG_PRINT_STRUCT, env); - GLOBAL_PARAMETER("print-box", print_box, MZCONFIG_PRINT_BOX, env); - GLOBAL_PARAMETER("print-vector-length", print_vec_shorthand, MZCONFIG_PRINT_VEC_SHORTHAND, env); - GLOBAL_PARAMETER("print-hash-table", print_hash_table, MZCONFIG_PRINT_HASH_TABLE, env); - GLOBAL_PARAMETER("print-unreadable", print_unreadable, MZCONFIG_PRINT_UNREADABLE, env); - GLOBAL_PARAMETER("print-pair-curly-braces", print_pair_curly, MZCONFIG_PRINT_PAIR_CURLY, env); - GLOBAL_PARAMETER("print-mpair-curly-braces", print_mpair_curly, MZCONFIG_PRINT_MPAIR_CURLY, env); - GLOBAL_PARAMETER("print-syntax-width", print_syntax_width, MZCONFIG_PRINT_SYNTAX_WIDTH, env); - GLOBAL_PARAMETER("print-reader-abbreviations", print_reader, MZCONFIG_PRINT_READER, env); - GLOBAL_PARAMETER("print-boolean-long-form", print_long_bool, MZCONFIG_PRINT_LONG_BOOLEAN, env); - GLOBAL_PARAMETER("print-as-expression", print_as_qq, MZCONFIG_PRINT_AS_QQ, env); + ADD_PARAMETER("print-graph", print_graph, MZCONFIG_PRINT_GRAPH, env); + ADD_PARAMETER("print-struct", print_struct, MZCONFIG_PRINT_STRUCT, env); + ADD_PARAMETER("print-box", print_box, MZCONFIG_PRINT_BOX, env); + ADD_PARAMETER("print-vector-length", print_vec_shorthand, MZCONFIG_PRINT_VEC_SHORTHAND, env); + ADD_PARAMETER("print-hash-table", print_hash_table, MZCONFIG_PRINT_HASH_TABLE, env); + ADD_PARAMETER("print-unreadable", print_unreadable, MZCONFIG_PRINT_UNREADABLE, env); + ADD_PARAMETER("print-pair-curly-braces", print_pair_curly, MZCONFIG_PRINT_PAIR_CURLY, env); + ADD_PARAMETER("print-mpair-curly-braces", print_mpair_curly, MZCONFIG_PRINT_MPAIR_CURLY, env); + ADD_PARAMETER("print-syntax-width", print_syntax_width, MZCONFIG_PRINT_SYNTAX_WIDTH, env); + ADD_PARAMETER("print-reader-abbreviations", print_reader, MZCONFIG_PRINT_READER, env); + ADD_PARAMETER("print-boolean-long-form", print_long_bool, MZCONFIG_PRINT_LONG_BOOLEAN, env); + ADD_PARAMETER("print-as-expression", print_as_qq, MZCONFIG_PRINT_AS_QQ, env); - GLOBAL_PRIM_W_ARITY("make-readtable", make_readtable, 1, -1, env); - GLOBAL_FOLDING_PRIM("readtable?", readtable_p, 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY2("readtable-mapping", readtable_mapping, 2, 2, 3, 3, env); - - GLOBAL_NONCM_PRIM("datum-intern-literal", read_intern, 1, 1, env); + ADD_NONCM_PRIM("datum-intern-literal", read_intern, 1, 1, env); if (getenv("PLT_DELAY_FROM_ZO")) { use_perma_cache = 0; @@ -579,27 +307,12 @@ void scheme_init_variable_references_constants() variable_references = scheme_make_builtin_references_table(&unsafe_variable_references_start); } - -static void track_indentation(Scheme_Object *indentation, int line, int col) +Scheme_Object *scheme_position_to_builtin(int l) { - if (!SCHEME_NULLP(indentation)) { - Scheme_Indent *indt = (Scheme_Indent *)SCHEME_CAR(indentation); - /* Already checked this line? */ - if (line > indt->last_line) { - indt->last_line = line; - indt->multiline = 1; - /* At least as indented as before? */ - if (col >= indt->max_indent) - indt->max_indent = col; - else if (!indt->suspicious_line) { - /* Not as indented, and no suspicious line found - already. Suspect that the closer should have - appeared earlier. */ - indt->suspicious_closer = indt->closer; - indt->suspicious_line = line; - } - } - } + if (l < EXPECTED_PRIM_COUNT) + return variable_references[l]; + else + return NULL; } /*========================================================================*/ @@ -615,96 +328,12 @@ read_case_sensitive(int argc, Scheme_Object *argv[]) DO_CHAR_PARAM("read-case-sensitive", MZCONFIG_CASE_SENS); } -static Scheme_Object * -read_bracket_as_paren(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-square-bracket-as-paren", MZCONFIG_SQUARE_BRACKETS_ARE_PARENS); -} - -static Scheme_Object * -read_brace_as_paren(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-curly-brace-as-paren", MZCONFIG_CURLY_BRACES_ARE_PARENS); -} - -static Scheme_Object * -read_bracket_with_tag(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-square-bracket-with-tag", MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED); -} - -static Scheme_Object * -read_brace_with_tag(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-curly-brace-with-tag", MZCONFIG_CURLY_BRACES_ARE_TAGGED); -} - -static Scheme_Object * -read_cdot(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-cdot", MZCONFIG_READ_CDOT); -} - -static Scheme_Object * -read_accept_graph(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-graph", MZCONFIG_CAN_READ_GRAPH); -} - -static Scheme_Object * -read_accept_compiled(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-compiled", MZCONFIG_CAN_READ_COMPILED); -} - -static Scheme_Object * -read_accept_box(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-box", MZCONFIG_CAN_READ_BOX); -} - static Scheme_Object * read_accept_pipe_quote(int argc, Scheme_Object *argv[]) { DO_CHAR_PARAM("read-accept-pipe-quote", MZCONFIG_CAN_READ_PIPE_QUOTE); } -static Scheme_Object * -read_decimal_as_inexact(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-decimal-as-inexact", MZCONFIG_READ_DECIMAL_INEXACT); -} - -static Scheme_Object * -read_accept_dot(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-dot", MZCONFIG_CAN_READ_DOT); -} - -static Scheme_Object * -read_accept_infix_dot(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-infix-dot", MZCONFIG_CAN_READ_INFIX_DOT); -} - -static Scheme_Object * -read_accept_quasi(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-quasiquote", MZCONFIG_CAN_READ_QUASI); -} - -static Scheme_Object * -read_accept_reader(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-reader", MZCONFIG_CAN_READ_READER); -} - -static Scheme_Object * -read_accept_lang(int argc, Scheme_Object *argv[]) -{ - DO_CHAR_PARAM("read-accept-lang", MZCONFIG_CAN_READ_LANG); -} - static Scheme_Object * print_graph(int argc, Scheme_Object *argv[]) { @@ -828,172 +457,29 @@ read_delay_load(int argc, Scheme_Object *argv[]) /* main read loop */ /*========================================================================*/ -#ifdef DO_STACK_CHECK +static Scheme_Object *read_inner(Scheme_Object *port, ReadParams *params, int pre_char); -static Scheme_Object *read_inner_inner_inner(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode, - int pre_char, - Readtable *init_readtable, - int get_info); -static Scheme_Object *read_inner_inner(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode, - int pre_char, - Readtable *init_readtable, - int get_info); -static Scheme_Object *read_inner(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode); - -static void set_need_copy(Scheme_Hash_Table **ht) -{ - /* Set indicator in *ht that we need to copy: */ - if (!*ht) { - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *ht = tht; - } - scheme_hash_set(*ht, tainted_uninterned_symbol, scheme_true); -} - -static Scheme_Object *read_inner_inner_inner_k(void) +static Scheme_Object *read_inner_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Hash_Table **ht = (Scheme_Hash_Table **)p->ku.k.p2; - Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *indentation = SCHEME_CAR((Scheme_Object *)p->ku.k.p4); ReadParams *params = (ReadParams *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4); - Readtable *table = (Readtable *)p->ku.k.p5; p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - return read_inner_inner_inner(o, stxsrc, ht, indentation, params, p->ku.k.i1, p->ku.k.i2, - table, p->ku.k.i3); -} -#endif - -#define MAX_GRAPH_ID_DIGITS 8 - -static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mzchar *tagbuf, mzchar *vecbuf, int *vector_length, int *digits, int *overflow) -{ - int i = 0, j = 0, nch; - *vector_length = -1; - *overflow = 0; - *digits = 0; - - while (NOT_EOF_OR_SPECIAL((*ch)) && isdigit_ascii((*ch))) { - if (*digits <= MAX_GRAPH_ID_DIGITS) - (*digits)++; - - /* For vector error msgs, want to drop leading zeros: */ - if (j || ((*ch) != '0')) { - if (j < 60) { - vecbuf[j++] = (*ch); - } else if (j == 60) { - vecbuf[j++] = '.'; - vecbuf[j++] = '.'; - vecbuf[j++] = '.'; - vecbuf[j] = 0; - } - } - - /* For tag error msgs, want to keep zeros: */ - if (i < 60) { - tagbuf[i++] = (*ch); - } else if (i == 60) { - tagbuf[i++] = '.'; - tagbuf[i++] = '.'; - tagbuf[i++] = '.'; - tagbuf[i] = 0; - } - - if (!(*overflow)) { - uintptr_t old_len; - uintptr_t new_len; - - if (*vector_length < 0) - *vector_length = 0; - - old_len = *vector_length; - new_len = *vector_length; - new_len = ((new_len) * 10) + ((*ch) - 48); - *vector_length = new_len; - if ((*vector_length < 0) || ((new_len / 10) != old_len)) { - *overflow = 1; - } - } - nch = scheme_getc_special_ok(port); - (*ch) = nch; - } - - if (*overflow) - *vector_length = -2; - vecbuf[j] = 0; - tagbuf[i] = 0; - - if (!j) { - vecbuf[j] = '0'; - vecbuf[0] = 0; - } - - return readtable_effective_char(table, (*ch)); + return read_inner(o, params, p->ku.k.i2); } -static Scheme_Object * -read_plus_minus_period_leading_number(Scheme_Object *port, Scheme_Object *stxsrc, - int ch, intptr_t line, intptr_t col, intptr_t pos, - int is_float, int is_not_float, - Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params, - Readtable *table) +static Scheme_Object *read_inner(Scheme_Object *port, ReadParams *params, int pre_char) { - int ch2; - Scheme_Object *special_value; - ch2 = scheme_peekc_special_ok(port); - if ((NOT_EOF_OR_SPECIAL(ch2) && isdigit_ascii(ch2)) || (ch2 == '.') - || ((ch2 == 'i') || (ch2 == 'I') /* Maybe inf */ - || (ch2 == 'n') || (ch2 == 'N') /* Maybe nan*/ )) { - /* read_number tries to get a number, but produces a symbol if number parsing doesn't work, - unless `is_float' or `is_not_float': */ - special_value = read_number(ch, port, stxsrc, line, col, pos, - is_float, is_not_float, 10, 0, ht, indentation, params, table); - } else { - special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table); - } - return special_value; -} - - -static Scheme_Object * -read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int comment_mode, int pre_char, Readtable *table, - int get_info) -{ - int ch, ch2, depth, dispatch_ch, special_value_need_copy = 0; - intptr_t line = 0, col = 0, pos = 0; - Scheme_Object *special_value; + int ch, ch2; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" { Scheme_Thread *p = scheme_current_thread; - Scheme_Object *pr; ReadParams *params2; /* params may be on the stack, so move it to the heap: */ @@ -1004,18 +490,9 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T #endif p->ku.k.p1 = (void *)port; - p->ku.k.p2 = (void *)ht; - p->ku.k.p3 = (void *)stxsrc; - - pr = scheme_make_pair(indentation, (Scheme_Object *)params2); - p->ku.k.p4 = (void *)pr; - - p->ku.k.p5 = (void *)table; - - p->ku.k.i1 = comment_mode; + p->ku.k.p4 = (void *)params2; p->ku.k.i2 = pre_char; - p->ku.k.i3 = get_info; - return scheme_handle_stack_overflow(read_inner_inner_inner_k); + return scheme_handle_stack_overflow(read_inner_k); } } #endif @@ -1024,406 +501,139 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T SCHEME_USE_FUEL(1); + /* Skip whitespace */ while (1) { if (pre_char >= 0) { ch = pre_char; pre_char = -1; } else - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch)) { - if (table) { - if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE)) - break; - } else if (!scheme_isspace(ch)) + if (!scheme_isspace(ch)) break; } else break; } - scheme_tell_all(port, &line, &col, &pos); - - /* Found non-whitespace. Track indentation: */ - if (col >= 0) { - if (SCHEME_PAIRP(indentation)) { - int effective_ch; - effective_ch = readtable_effective_char(table, ch); - /* Ignore if it's a comment start or spurious closer: */ - if ((effective_ch != ';') - && !((effective_ch == '#') && (scheme_peekc_special_ok(port) == '|')) - && (effective_ch != ')') - && ((effective_ch != '}') || !params->curly_braces_are_parens) - && ((effective_ch != ']') || !params->square_brackets_are_parens)) { - track_indentation(indentation, line, col); - } - } - } - - special_value = NULL; - if (table && NOT_EOF_OR_SPECIAL(ch)) { - Scheme_Object *v; - int use_default, ch2 = ch; - v = readtable_handle(table, &ch2, &use_default, params, - port, stxsrc, line, col, pos, ht); - if (!use_default) { - dispatch_ch = SCHEME_SPECIAL; - special_value = v; - } else - dispatch_ch = ch2; - } else - dispatch_ch = ch; - - if (get_info && (dispatch_ch != '#') && (dispatch_ch != ';')) { - /* If ch is EOF, then col or pos wasn't incremented by reading ch. - The col and pos might be used in an error message, which expects - to subtract one from each --- so counteract by adding one here. */ - if (ch == EOF) { - if (pos >= 0) pos++; - if (col >= 0) col++; - } - return expected_lang("", ch, port, stxsrc, line, col, pos, get_info); - } - - switch ( dispatch_ch ) + switch (ch) { case EOF: return scheme_eof; - case SCHEME_SPECIAL: - { - if (!special_value) { - special_value = scheme_get_special(port, stxsrc, line, col, pos, 0, ht); - special_value_need_copy = 1; - } - break; - } case ']': - if (!params->square_brackets_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of close square bracket"); - return NULL; - } else { - unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params); - return NULL; - } + unexpected_closer(ch, port); + return NULL; case '}': - if (!params->curly_braces_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of close curly brace"); - return NULL; - } else { - unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params); - return NULL; - } + unexpected_closer(ch, port); + return NULL; case ')': - unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params); + unexpected_closer(ch, port); return NULL; case '(': - return read_list(port, stxsrc, line, col, pos, ch, ')', mz_shape_cons, 0, ht, indentation, params, table); + return read_list(port, ch, ')', mz_shape_cons, 0, params); case '[': - if (!params->square_brackets_are_parens && !params->square_brackets_are_tagged) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open square bracket"); - return NULL; - } else - return read_list(port, stxsrc, line, col, pos, ch, ']', mz_shape_cons, 0, ht, indentation, params, table); + return read_list(port, ch, ']', mz_shape_cons, 0, params); case '{': - if (!params->curly_braces_are_parens && !params->curly_braces_are_tagged) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open curly brace"); - return NULL; - } else - return read_list(port, stxsrc, line, col, pos, ch, '}', mz_shape_cons, 0, ht, indentation, params, table); + return read_list(port, ch, '}', mz_shape_cons, 0, params); case '|': - special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; + return read_symbol(ch, port, params); case '"': - return read_string(0, port, stxsrc, line, col, pos, ht, indentation, params, table, 1); + return read_string(0, port, params, 1); case '\'': - return read_quote("quoting '", quote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("quoting '", quote_symbol, 1, port, params); case '`': - if (!params->can_read_quasi) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of backquote"); - return NULL; - } else - return read_quote("quasiquoting `", quasiquote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("quasiquoting `", quasiquote_symbol, 1, port, params); case ',': - if (!params->can_read_quasi) { - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of comma"); - return NULL; - } else { - if (scheme_peekc_special_ok(port) == '@') { + { + if (scheme_peekc(port) == '@') { ch = scheme_getc(port); /* must be '@' */ - return read_quote("unquoting ,@", unquote_splicing_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("unquoting ,@", unquote_splicing_symbol, 2, port, params); } else - return read_quote("unquoting ,", unquote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("unquoting ,", unquote_symbol, 1, port, params); } case ';': { - while (((ch = scheme_getc_special_ok(port)) != '\n') + while (((ch = scheme_getc(port)) != '\n') && !is_line_comment_end(ch)) { - if (ch == EOF) { - if (comment_mode & RETURN_FOR_COMMENT) - return NULL; - if (get_info) - return expected_lang("", ch, port, stxsrc, line, col, pos, get_info); - return scheme_eof; - } - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); + if (ch == EOF) + return scheme_eof; } - if ((table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT)) - || (comment_mode & RETURN_FOR_COMMENT)) - return NULL; goto start_over; } - case '+': - case '-': - case '.': /* ^^^ fallthrough ^^^ */ - special_value = read_plus_minus_period_leading_number(port, stxsrc, ch, line, col, pos, 0, 0, ht, indentation, params, table); - break; case '#': - ch = scheme_getc_special_ok(port); - - if (get_info && (ch != '|') && (ch != '!') && (ch != 'l') && (ch != ';')) { - return expected_lang("#", ch, port, stxsrc, line, col, pos, get_info); - } - - if (table) { - Scheme_Object *v; - int use_default; - v = readtable_handle_hash(table, ch, &use_default, params, - port, stxsrc, line, col, pos, ht); - if (!use_default) { - if (v) - return v; - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - } - - special_value = NULL; + ch = scheme_getc(port); switch (ch) { case EOF: - case SCHEME_SPECIAL: - scheme_read_err(port, stxsrc, line, col, pos, 1, ch, indentation, "read: bad syntax `#'"); - break; + scheme_read_err(port, "read: bad syntax `#'"); + return NULL; case ';': { Scheme_Object *skipped; - skipped = read_inner(port, stxsrc, ht, indentation, params, 0); + skipped = read_inner(port, params, -1); if (SCHEME_EOFP(skipped)) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: expected a commented-out element for `#;' (found end-of-file)"); - /* For resolving graphs introduced in #; : */ - if (*ht) { - Scheme_Object *v; - v = scheme_hash_get(*ht, unresolved_uninterned_symbol); - if (!v) - v = scheme_null; - v = scheme_make_pair(skipped, v); - scheme_hash_set(*ht, unresolved_uninterned_symbol, v); - } - - if ((comment_mode & RETURN_FOR_HASH_COMMENT) - || (table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT)) - || (comment_mode & RETURN_FOR_COMMENT)) - return NULL; - + scheme_read_err(port, "read: expected a commented-out element for `#;' (found end-of-file)"); goto start_over; } - break; case '%': scheme_ungetc('%', port); - special_value = read_symbol('#', 1, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; + return read_symbol('#', port, params); case ':': - return read_keyword(-1, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; + return read_keyword(-1, port, params); case '(': - return read_vector(port, stxsrc, line, col, pos, ch, ')', -1, NULL, ht, indentation, params, table, 0); - break; + return read_vector(port, ch, ')', params, 0); case '[': - if (!params->square_brackets_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#['"); - return NULL; - } else - return read_vector(port, stxsrc, line, col, pos, ch, ']', -1, NULL, ht, indentation, params, table, 0); - break; + return read_vector(port, ch, ']', params, 0); case '{': - if (!params->curly_braces_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#{'"); - return NULL; - } else - return read_vector(port, stxsrc, line, col, pos, ch, '}', -1, NULL, ht, indentation, params, table, 0); + return read_vector(port, ch, '}', params, 0); case '\\': - { - Scheme_Object *chr; - chr = read_character(port, stxsrc, line, col, pos, ht, indentation, params); - if (stxsrc) - chr = scheme_make_stx_w_offset(chr, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return chr; - } - break; + return read_character(port, params); case 'T': case 't': - if (next_is_delim(port, params, 1, 1)) { + if (next_is_delim(port)) { /* found delimited `#t' */ - return (stxsrc - ? scheme_make_stx_w_offset(scheme_true, line, col, pos, 2, stxsrc, STX_SRCTAG) - : scheme_true); + return scheme_true; } else { GC_CAN_IGNORE const mzchar str[] = { 't', 'r', 'u', 'e', 0 }; - return read_delimited_constant(ch, str, scheme_true, port, stxsrc, line, col, pos, - indentation, params, table); + return read_delimited_constant(ch, str, scheme_true, port, params); } case 'F': case 'f': - if (next_is_delim(port, params, 1, 1)) { + if (next_is_delim(port)) { /* found delimited `#f' */ - return (stxsrc - ? scheme_make_stx_w_offset(scheme_false, line, col, pos, 2, stxsrc, STX_SRCTAG) - : scheme_false); + return scheme_false; } else { - int next; - next = scheme_peekc_special_ok(port); - switch (next) { - case 'l': - case 'x': - { - int vector_length = -1; - int overflow = 0, digits = 0, effective_ch; - mzchar tagbuf[64], vecbuf[64]; /* just for errors */ - int ch; - - if (stxsrc) { - scheme_read_err(port, stxsrc, line, col, pos, 3, 0, indentation, - "read-syntax: literal f%cvectors not allowed", next); - return NULL; - } - - ch = scheme_getc_special_ok(port); - ch = scheme_getc_special_ok(port); - if (isdigit_ascii(ch)) - effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow); - else - effective_ch = ch; - switch (effective_ch) { - case '(': - if (next == 'l') - return read_flvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0); - else - return read_fxvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0); - break; - case '[': - if (!params->square_brackets_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, effective_ch, indentation, "read: bad syntax `#f%c['", next); - return NULL; - } else - if (next == 'l') - return read_flvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0); - else - return read_fxvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0); - break; - case '{': - if (!params->curly_braces_are_parens) { - scheme_read_err(port, stxsrc, line, col, pos, 2, effective_ch, indentation, "read: bad syntax `#f%c{'", next); - return NULL; - } else - if (next == 'l') - return read_flvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0); - else - return read_fxvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0); - break; - default: - scheme_read_err(port, stxsrc, line, col, pos, 3, effective_ch, indentation, - "read: expected `(' `[' or `{' after #f%c", next); - } - } - default: - { - GC_CAN_IGNORE const mzchar str[] = { 'f', 'a', 'l', 's', 'e', 0 }; - return read_delimited_constant(ch, str, scheme_false, port, stxsrc, line, col, pos, - indentation, params, table); - } - } + GC_CAN_IGNORE const mzchar str[] = { 'f', 'a', 'l', 's', 'e', 0 }; + return read_delimited_constant(ch, str, scheme_false, port, params); } - case 'c': - case 'C': - { - Scheme_Object *v; - int sens = 0; - int save_sens; - - ch = scheme_getc_special_ok(port); - switch ( ch ) { - case 'i': - case 'I': - sens = 0; - break; - case 's': - case 'S': - sens = 1; - break; - default: - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: expected `s' or `i' after #c"); - return NULL; - } - - - save_sens = params->case_sensitive; - params->case_sensitive = sens; - - v = read_inner(port, stxsrc, ht, indentation, params, 0); - - params->case_sensitive = save_sens; - - if (SCHEME_EOFP(v)) { - scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation, - "read: end-of-file after #c%c", - sens ? 's' : 'i'); - return NULL; - } - - return v; - } - break; case 's': case 'S': { - int orig_ch = ch, effective_ch; - ch = scheme_getc_special_ok(port); - if (NOT_EOF_OR_SPECIAL(ch)) - effective_ch = readtable_effective_char(params->table, ch); - else - effective_ch = ch; + int orig_ch = ch; + ch = scheme_getc(port); if ((orig_ch == 's') - && ((effective_ch == '(') - || (effective_ch == '[' && params->square_brackets_are_parens) - || (effective_ch == '{' && params->curly_braces_are_parens))) { + && ((ch == '(') + || (ch == '[') + || (ch == '{'))) { Scheme_Object *v; Scheme_Struct_Type *st; - if (effective_ch == '(') + if (ch == '(') ch = ')'; - else if (effective_ch == '[') + else if (ch == '[') ch = ']'; - else if (effective_ch == '{') + else if (ch == '{') ch = '}'; - v = read_vector(port, stxsrc, line, col, pos, orig_ch, ch, -1, NULL, ht, indentation, params, table, 1); - if (stxsrc) - v = SCHEME_STX_VAL(v); - - if (SCHEME_VEC_SIZE(v)) { - Scheme_Object *key; - key = SCHEME_VEC_ELS(v)[0]; - if (stxsrc) - key = scheme_syntax_to_datum(key, 0, NULL); - st = scheme_lookup_prefab_type(key, SCHEME_VEC_SIZE(v) - 1); - } else + v = read_vector(port, orig_ch, ch, params, 1); + + if (SCHEME_VEC_SIZE(v)) + st = scheme_lookup_prefab_type(SCHEME_VEC_ELS(v)[0], SCHEME_VEC_SIZE(v) - 1); + else st = NULL; if (!st || (st->num_slots != (SCHEME_VEC_SIZE(v) - 1))) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, (SCHEME_VEC_SIZE(v) ? (st ? ("read: mismatch between structure description" @@ -1433,19 +643,11 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T return NULL; } - if (stxsrc && !(MZ_OPT_HASH_KEY(&st->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: cannot read mutable `#s' form as syntax"); - } - v = scheme_make_prefab_struct_instance(st, v); - if (stxsrc) - v = scheme_make_stx_w_offset(v, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return v; } else { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, + scheme_read_err(port, "read: expected `x'%s after `#%c'", (orig_ch == 's' ? "or `('" : ""), orig_ch); @@ -1454,66 +656,43 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T } case 'X': case 'x': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 16, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 16, 1, params); case 'B': case 'b': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 2, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 2, 1, params); case 'O': case 'o': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 8, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 8, 1, params); case 'D': case 'd': - return read_number(-1, port, stxsrc, line, col, pos, 0, 0, 10, 1, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 0, 10, 1, params); case 'E': case 'e': - return read_number(-1, port, stxsrc, line, col, pos, 0, 1, 10, 0, ht, indentation, params, table); - break; + return read_number(-1, port, 0, 1, 10, 0, params); case 'I': case 'i': - return read_number(-1, port, stxsrc, line, col, pos, 1, 0, 10, 0, ht, indentation, params, table); - break; + return read_number(-1, port, 1, 0, 10, 0, params); case '\'': - return read_quote("quoting #'", syntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); - break; + return read_quote("quoting #'", syntax_symbol, 2, port, params); case '`': - return read_quote("quasiquoting #`", quasisyntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); - break; + return read_quote("quasiquoting #`", quasisyntax_symbol, 2, port, params); case ',': - if (scheme_peekc_special_ok(port) == '@') { + if (scheme_peekc(port) == '@') { ch = scheme_getc(port); /* must be '@' */ - return read_quote("unquoting #`@", unsyntax_splicing_symbol, 3, port, stxsrc, line, col, pos, ht, indentation, params); + return read_quote("unquoting #`@", unsyntax_splicing_symbol, 3, port, params); } else - return read_quote("unquoting #`", unsyntax_symbol, 2, port, stxsrc, line, col, pos, ht, indentation, params); - break; + return read_quote("unquoting #`", unsyntax_symbol, 2, port, params); case '~': - if (params->can_read_compiled) { - Scheme_Object *cpld; - cpld = read_compiled(port, stxsrc, line, col, pos, ht, params); - if (stxsrc) - cpld = scheme_make_stx_w_offset(cpld, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return cpld; - } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, - "read: #~ compiled expressions" NOT_ENABLED_str); - return NULL; - } - break; + return read_compiled(port, params); case '^': - if (params->read_relative_path) { - ch = scheme_getc_special_ok(port); + { + ch = scheme_getc(port); if (ch == '#') { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == '"') { Scheme_Object *str; - intptr_t sline = 0, scol = 0, spos = 0; - scheme_tell_all(port, &sline, &scol, &spos); - - str = read_string(1, port, stxsrc, sline, scol, spos, ht, indentation, params, table, 1); + str = read_string(1, port, params, 1); str->type = SCHEME_PLATFORM_PATH_KIND; @@ -1530,39 +709,29 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T } return str; + } else { + scheme_read_err(port, "read: bad syntax `#^#%c'", ch); + return NULL; } } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: bad syntax `#^#%c'", - ch); + scheme_read_err(port, "read: bad syntax `#^%c'", ch); + return NULL; } - } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: bad syntax `#^%c'", - ch); } break; case '|': { - /* FIXME: integer overflow possible */ - depth = 0; + intptr_t depth = 0; ch2 = 0; do { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == EOF) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: end of file in #| comment"); - else if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); + scheme_read_err(port, "read: end of file in #| comment"); if ((ch2 == '|') && (ch == '#')) { - if (!(depth--)) { - if ((table && (comment_mode & RETURN_FOR_SPECIAL_COMMENT)) - || (comment_mode & RETURN_FOR_COMMENT)) - return NULL; + if (!(depth--)) goto start_over; - } ch = 0; /* So we don't count '#' toward an opening "#|" */ } else if ((ch2 == '#') && (ch == '|')) { depth++; @@ -1573,64 +742,7 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T } break; case '&': - if (params->can_read_box) - return read_box(port, stxsrc, line, col, pos, ht, indentation, params); - else { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, - "read: #& expressions" NOT_ENABLED_str); - return NULL; - } - break; - case 'l': - { - mzchar found[5]; - int fl = 1; - found[0] = 'l'; - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == 'a') { - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == 'n') { - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == 'g') { - ch = scheme_getc_special_ok(port); - found[fl++] = ch; - if (ch == ' ') { - /* #lang */ - Scheme_Object *v; - if (!params->can_read_reader - || !params->can_read_lang) { - scheme_read_err(port, stxsrc, line, col, pos, 6, 0, indentation, - "read: #lang" NOT_ENABLED_str); - return NULL; - } - v = read_lang(port, stxsrc, line, col, pos, get_info, ht, indentation, params, 0); - if (!v) { - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - return v; - } else { - if (ch == EOF) --fl; - scheme_read_err(port, stxsrc, line, col, pos, 6, ch, indentation, - "read%s: expected a single space after `#lang'", - (get_info ? "-language" : "")); - return NULL; - } - } - } - } - if (ch == EOF) --fl; - scheme_read_err(port, stxsrc, line, col, pos, fl, ch, indentation, - "read%s: bad input: `#%u'", - (get_info ? "-language" : ""), - found, (intptr_t)fl); - return NULL; - } - break; + return read_box(port, params); case 'r': case 'p': { @@ -1638,73 +750,33 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T int cnt = 0, is_byte = 0; char *expect; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == 'x') { expect = "x#"; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); cnt++; if (ch == '#') { is_byte = 1; cnt++; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); } if (ch == '"') { Scheme_Object *str; int is_err; - intptr_t sline = 0, scol = 0, spos = 0; - /* Skip #rx[#]: */ - scheme_tell_all(port, &sline, &scol, &spos); - - str = read_string(is_byte, port, stxsrc, sline, scol, spos, ht, indentation, params, table, 1); - - if (stxsrc) - str = SCHEME_STX_VAL(str); + str = read_string(is_byte, port, params, 1); str = scheme_make_regexp(str, is_byte, (orig_ch == 'p'), &is_err); if (is_err) { - scheme_read_err(port, stxsrc, sline, scol, spos, 2, 0, indentation, - "read: bad %sregexp string: %s", + scheme_read_err(port, "read: bad %sregexp string `%s`", (orig_ch == 'r') ? "" : "p", (char *)str); return NULL; } - if (stxsrc) { - str = scheme_intern_literal_string(str); - str = scheme_make_stx_w_offset(str, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } - return str; } - } else if ((orig_ch == 'r') && (ch == 'e')) { - expect = "eader"; - cnt++; - while (expect[cnt]) { - ch = scheme_getc_special_ok(port); - if (ch != expect[cnt]) - break; - cnt++; - } - if (!expect[cnt]) { - /* Found #reader. Read an S-exp. */ - Scheme_Object *v; - - if (!params->can_read_reader) { - scheme_read_err(port, stxsrc, line, col, pos, 7, 0, indentation, - "read: #reader" NOT_ENABLED_str); - return NULL; - } - - v = read_reader(port, stxsrc, line, col, pos, ht, indentation, params); - if (!v) { - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - return v; - } } else expect = ""; @@ -1719,9 +791,7 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T a[cnt++] = ch; } - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), - ch, indentation, - "read: bad syntax `#%c%u'", + scheme_read_err(port, "read: bad syntax `#%c%u`", orig_ch, a, (intptr_t)cnt); return NULL; } @@ -1729,26 +799,23 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T break; case 'h': { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch != 'a') { - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, - "read: expected `a' after #h"); + scheme_read_err(port, "read: expected `a` after `#h`"); return NULL; } else { GC_CAN_IGNORE const mzchar str[] = { 's', 'h', 'e', 'q', 'v', 0 }; int scanpos = 0, failed = 0; do { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if ((mzchar)ch == str[scanpos]) { scanpos++; } else { if ((scanpos == 2) || (scanpos == 4)) { - int effective_ch; - effective_ch = readtable_effective_char(table, ch); - if (!(effective_ch == '(') - && !(effective_ch == '[' && params->square_brackets_are_parens) - && !(effective_ch == '{' && params->curly_braces_are_parens)) + if (!(ch == '(') + && !(ch == '[') + && !(ch == '{')) failed = 1; } else failed = 1; @@ -1758,13 +825,11 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T if (!failed) { /* Found recognized tag. Look for open paren... */ - int effective_ch, kind; + int kind; if (scanpos > 4) - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); - effective_ch = readtable_effective_char(table, ch); - if (scanpos == 4) kind = 0; else if (scanpos == 2) @@ -1772,12 +837,12 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T else kind = 2; - if (effective_ch == '(') - return read_hash(port, stxsrc, line, col, pos, ch, ')', kind, ht, indentation, params, table); - if (effective_ch == '[' && params->square_brackets_are_parens) - return read_hash(port, stxsrc, line, col, pos, ch, ']', kind, ht, indentation, params, table); - if (effective_ch == '{' && params->curly_braces_are_parens) - return read_hash(port, stxsrc, line, col, pos, ch, '}', kind, ht, indentation, params, table); + if (ch == '(') + return read_hash(port, ch, ')', kind, params); + if (ch == '[') + return read_hash(port, ch, ']', kind, params); + if (ch == '{') + return read_hash(port, ch, '}', kind, params); } /* Report an error. So far, we read 'ha', then scanpos chars of str, then ch. */ @@ -1792,9 +857,7 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T } else one_more[0] = 0; - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), - ch, indentation, - "read: bad syntax `#ha%5%u'", + scheme_read_err(port, "read: bad syntax `#ha%5%u'", str_part, one_more, (intptr_t)(NOT_EOF_OR_SPECIAL(ch) ? 1 : 0)); return NULL; @@ -1803,294 +866,63 @@ read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_T } break; case '"': - return read_string(1, port, stxsrc, line, col, pos, ht, indentation, params, table, 1); - break; - case '<': - if (scheme_peekc_special_ok(port) == '<') { - /* Here-string */ - ch = scheme_getc_special_ok(port); - return read_here_string(port, stxsrc, line, col, pos,indentation, params); - } else { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#<'"); - return NULL; - } - break; - case '!': - ch = scheme_getc_special_ok(port); - if ((ch == ' ') || (ch == '/')) { - /* line comment, with '\' as a continuation */ - int was_backslash = 0, was_backslash_cr = 0; - while(1) { - was_backslash_cr = 0; - ch = scheme_getc_special_ok(port); - if (ch == EOF) { - break; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - } else if (ch == '\r') { - if (was_backslash) { - was_backslash_cr = 1; - } else - break; - } else if (ch == '\n') { - if (!was_backslash && !was_backslash_cr) - break; - } - was_backslash = (ch == '\\'); - } - if (comment_mode & RETURN_FOR_COMMENT) - return NULL; - goto start_over; - } else if ((ch < 128) && is_lang_nonsep_char(ch)) { - Scheme_Object *v; - if (!params->can_read_reader - || !params->can_read_lang) { - scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, - "read: #!" NOT_ENABLED_str); - return NULL; - } - v = read_lang(port, stxsrc, line, col, pos, get_info, ht, indentation, params, ch); - if (!v) { - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - goto start_over; - } - return v; - } else { - if (NOT_EOF_OR_SPECIAL(ch)) - scheme_read_err(port, stxsrc, line, col, pos, 3, - ch, indentation, "read: bad syntax `#!%c'", ch); - else - scheme_read_err(port, stxsrc, line, col, pos, 2, - ch, indentation, "read: bad syntax `#!'", ch); - return NULL; - } - break; + return read_string(1, port, params, 1); default: - { - int vector_length = -1; - int overflow = 0, digits = 0, effective_ch; - mzchar tagbuf[64], vecbuf[64]; /* just for errors */ - effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow); + if (ch == '(') + return read_vector(port, ch, ')', params, 0); + else if (ch == '[') + return read_vector(port, ch, ']', params, 0); + else if (ch == '{') + return read_vector(port, ch, '}', params, 0); + else if (isdigit_ascii(ch)) { + /* graph definition or reference */ + int nch = ch, index; + Scheme_Object *val; - if (effective_ch == '(') - return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0); - if (effective_ch == '[' && params->square_brackets_are_parens) - return read_vector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0); - if (effective_ch == '{' && params->curly_braces_are_parens) - return read_vector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0); - - if (ch == '#' && (vector_length != -1)) { - /* Not a vector after all: a graph reference */ - Scheme_Object *ph; - - if (stxsrc) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..# expressions not allowed in read-syntax mode"); - - if (!params->can_read_graph) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..# expressions" NOT_ENABLED_str); - - if (digits > MAX_GRAPH_ID_DIGITS) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: graph id too long in #%5#", - tagbuf); - - if (*ht) - ph = (Scheme_Object *)scheme_hash_get(*ht, scheme_make_integer(vector_length)); - else - ph = NULL; - - if (!ph) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: no #%d= preceding #%d#", - vector_length, vector_length); - return scheme_void; - } - return ph; - } - if (ch == '=' && (vector_length != -1)) { - /* Not a vector after all: a graph definition */ - Scheme_Object *v, *ph; - intptr_t in_pos; - - if (stxsrc) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..= expressions not allowed in read-syntax mode"); - - if (!params->can_read_graph) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: #..= expressions" NOT_ENABLED_str); - - if (digits > MAX_GRAPH_ID_DIGITS) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: graph id too long in #%s=", - tagbuf); - - if (*ht) { - if (scheme_hash_get(*ht, scheme_make_integer(vector_length))) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: multiple #%d= tags", - vector_length); - return NULL; - } - } else { - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *ht = tht; - } - ph = scheme_alloc_small_object(); - ph->type = scheme_placeholder_type; - - scheme_hash_set(*ht, scheme_make_integer(vector_length), (void *)ph); - - scheme_tell_all(port, NULL, NULL, &in_pos); - - v = read_inner(port, stxsrc, ht, indentation, params, 0); - if (SCHEME_EOFP(v)) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, in_pos-pos), EOF, indentation, - "read: expected an element for graph (found end-of-file)"); - SCHEME_PTR_VAL(ph) = v; - - return v; - } - - { - char *lbuffer; - int pch = ch, ulen, blen; - - if ((pch == EOF) || (pch == SCHEME_SPECIAL)) - pch = 0; - - ulen = scheme_char_strlen(tagbuf); - blen = scheme_utf8_encode_all(tagbuf, ulen, NULL); - lbuffer = (char *)scheme_malloc_atomic(blen + MAX_UTF8_CHAR_BYTES + 1); - scheme_utf8_encode_all(tagbuf, ulen, (unsigned char *)lbuffer); - blen += scheme_utf8_encode((mzchar *)&pch, 0, 1, - (unsigned char *)lbuffer, blen, - 0); - lbuffer[blen] = 0; - - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: bad syntax `#%s'", - lbuffer); - - return NULL; - } - } - break; + index = read_graph_index(port, &nch); + switch (nch) { + case '#': + if (params->graph_ht) + val = scheme_hash_get(params->graph_ht, scheme_make_integer(index)); + else + val = NULL; + if (!val) + scheme_read_err(port, + "read: no value for `#%d#`", + index); + return val; + case '=': + if (!params->graph_ht) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + params->graph_ht = ht; + } + if (scheme_hash_get(params->graph_ht, scheme_make_integer(index))) + scheme_read_err(port, + "read: duplicate `#%d=` definition", + index); + val = read_inner(port, params, -1); + scheme_hash_set(params->graph_ht, scheme_make_integer(index), val); + return val; + default: + scheme_read_err(port, + "read: expected `=` or `#` after `#%d`, found `%c`", + index, nch); + return NULL; + } + + } else { + scheme_read_err(port, "read: bad syntax `#%c`", ch); + return NULL; + } } - break; default: - if (isdigit_ascii(ch)) - special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table); - else - special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table); - break; + return read_number_or_symbol(ch, port, 0, 0, 10, 0, 0, 0, params); } - - /* We get here after reading a "symbol". Check for a comment. */ - { - Scheme_Object *v = special_value; - - if (scheme_special_comment_value(v)) { - /* a "comment" */ - if (comment_mode & RETURN_FOR_SPECIAL_COMMENT) - return NULL; - else { - special_value_need_copy = 0; - goto start_over; - } - } else if (SCHEME_STXP(v)) { - if (!stxsrc) - v = scheme_syntax_to_datum(v, 0, NULL); - } else if (stxsrc) { - Scheme_Object *s; - s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - v = scheme_datum_to_syntax(v, s, scheme_false, 1, 0); - } - if (special_value_need_copy && !stxsrc) { - set_need_copy(ht); - } - return v; - } -} - -static Scheme_Object * -read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int comment_mode, int pre_char, Readtable *table, - int get_info) -{ - intptr_t rline = 0, rcol = 0, rpos = 0; - intptr_t dline = 0, dcol = 0, dpos = 0; - Scheme_Object *ret; - int read_cdot, next, found_dot; - - read_cdot = params->read_cdot; - - scheme_tell_all(port, &rline, &rcol, &rpos); - ret = read_inner_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, pre_char, table, get_info); - - if (!read_cdot) { return ret; } - - // read in zero or more . sequences in a left-associative way - // X.Y should be read as (#%dot X Y) - // X.Y.Z should be read as (#%dot (#%dot X Y) Z) - while ( 1 ) { - found_dot = 0; - while ( 1 ) { - next = scheme_peekc_special_ok(port); - if ( next == EOF ) { break; } - if ( (table && readtable_kind(table, next, params) & READTABLE_WHITESPACE) - || (!table && scheme_isspace(next)) ) { - scheme_getc_special_ok(port); continue; } - if ( (table && readtable_effective_char(table, next) == '.') - || (!table && next == '.') ) { - scheme_getc_special_ok(port); found_dot = 1; break; } - break; - } - - if ( !found_dot ) { - return ret; - } else { - Scheme_Object *dot, *next; - - scheme_tell_all(port, &dline, &dcol, &dpos); - dot = dot_symbol; - if (stxsrc) { - dot = scheme_make_stx_w_offset(dot, dline, dcol, dpos, SPAN(port,dpos), stxsrc, STX_SRCTAG); - } - next = read_inner_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, pre_char, table, get_info); - if (SCHEME_EOFP(next)) { - scheme_read_err(port, stxsrc, dline, dcol, dpos, 1, EOF, indentation, - "read: expected a datum after cdot, found end-of-file"); - return NULL; - } else { - ret = scheme_make_pair( dot, scheme_make_pair( ret, scheme_make_pair( next, scheme_null ) ) ); - } - if (stxsrc) { - ret = scheme_make_stx_w_offset(ret, rline, rcol, rpos, SPAN(port,rpos), stxsrc, STX_SRCTAG); - } - } - - // look for more dots after this - continue; - } -} - -static Scheme_Object * -read_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int comment_mode) -{ - return read_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, -1, params->table, 0); } #ifdef DO_STACK_CHECK static Scheme_Object *resolve_references(Scheme_Object *obj, - Scheme_Object *port, Scheme_Object *top, Scheme_Hash_Table *dht, Scheme_Hash_Table *tht, @@ -2102,24 +934,21 @@ static Scheme_Object *resolve_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Object *port = (Scheme_Object *)p->ku.k.p2; Scheme_Object *top = (Scheme_Object *)p->ku.k.p5; Scheme_Hash_Table *dht = (Scheme_Hash_Table *)p->ku.k.p3; Scheme_Hash_Table *tht = (Scheme_Hash_Table *)SCHEME_CAR((Scheme_Object *)p->ku.k.p4); Scheme_Hash_Table *self_contained_ht = (Scheme_Hash_Table *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4); p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - return resolve_references(o, port, top, dht, tht, self_contained_ht, p->ku.k.i1, p->ku.k.i2); + return resolve_references(o, top, dht, tht, self_contained_ht, p->ku.k.i1, p->ku.k.i2); } #endif static Scheme_Object *resolve_references(Scheme_Object *obj, - Scheme_Object *port, Scheme_Object *top, Scheme_Hash_Table *dht, Scheme_Hash_Table *tht, @@ -2135,7 +964,6 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, { Scheme_Thread *p = scheme_current_thread; p->ku.k.p1 = (void *)obj; - p->ku.k.p2 = (void *)port; p->ku.k.p5 = (void *)top; p->ku.k.p3 = (void *)dht; result = scheme_make_pair((Scheme_Object *)tht, @@ -2155,15 +983,10 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, while (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) { obj = (Scheme_Object *)SCHEME_PTR_VAL(obj); if (SAME_OBJ(start, obj)) { - if (port) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read: illegal placeholder cycle"); - else { - scheme_contract_error("make-reader-graph", - "illegal placeholder cycle in value", - "value", 1, top, - NULL); - } + scheme_contract_error("make-reader-graph", + "illegal placeholder cycle in value", + "value", 1, top, + NULL); return NULL; } } @@ -2192,13 +1015,13 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, result = scheme_make_pair(scheme_false, scheme_false); scheme_hash_set(dht, obj, result); - rr = resolve_references(SCHEME_CAR(obj), port, top, dht, tht, self_contained_ht, + rr = resolve_references(SCHEME_CAR(obj), top, dht, tht, self_contained_ht, clone, tail_depth + 1); SCHEME_CAR(result) = rr; scheme_hash_set(tht, result, scheme_make_integer(tail_depth)); - rr = resolve_references(SCHEME_CDR(obj), port, top, dht, tht, self_contained_ht, + rr = resolve_references(SCHEME_CDR(obj), top, dht, tht, self_contained_ht, clone, tail_depth); SCHEME_CDR(result) = rr; @@ -2221,7 +1044,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, } scheme_hash_set(dht, obj, result); - rr = resolve_references(SCHEME_BOX_VAL(obj), port, top, dht, tht, self_contained_ht, + rr = resolve_references(SCHEME_BOX_VAL(obj), top, dht, tht, self_contained_ht, clone, tail_depth + 1); SCHEME_BOX_VAL(result) = rr; @@ -2254,7 +1077,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, rr = prev_rr; } else { prev_v = SCHEME_VEC_ELS(obj)[i]; - rr = resolve_references(prev_v, port, top, dht, tht, self_contained_ht, + rr = resolve_references(prev_v, top, dht, tht, self_contained_ht, clone, tail_depth + 1); if (!SAME_OBJ(prev_v, rr)) diff = 1; @@ -2308,7 +1131,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, result = (Scheme_Object *)t; scheme_hash_set(dht, obj, result); - lst = resolve_references(lst, port, top, dht, tht, self_contained_ht, + lst = resolve_references(lst, top, dht, tht, self_contained_ht, clone, tail_depth + 1); for (; SCHEME_PAIRP(lst); lst = SCHEME_CDR(lst)) { @@ -2341,7 +1164,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, } orig_l = l; - l = resolve_references(l, port, top, dht, tht, self_contained_ht, + l = resolve_references(l, top, dht, tht, self_contained_ht, clone, tail_depth + 1); if (SAME_OBJ(l, orig_l)) { @@ -2377,7 +1200,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, diff = 0; for (i = 0; i < c; i++) { prev_v = ((Scheme_Structure *)result)->slots[i]; - v = resolve_references(prev_v, port, top, dht, tht, self_contained_ht, + v = resolve_references(prev_v, top, dht, tht, self_contained_ht, clone, tail_depth + 1); if (!SAME_OBJ(prev_v, v)) diff = 1; @@ -2395,152 +1218,37 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, } static Scheme_Object * -_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cant_fail, - int recur, int expose_comment, int extra_char, - Scheme_Object *init_readtable, - Scheme_Object *magic_sym, Scheme_Object *magic_val, - Scheme_Object *delay_load_info, int get_info) +_internal_read(Scheme_Object *port, int crc, int cant_fail, + int extra_char, + Scheme_Object *delay_load_info) { Scheme_Object *v, *v2; - Scheme_Config *config; - Scheme_Hash_Table **ht = NULL; ReadParams params; - config = scheme_current_config(); - - if (get_info) { - params.table = NULL; - } else { - v = scheme_get_param(config, MZCONFIG_READTABLE); - if (SCHEME_TRUEP(v)) - params.table = (Readtable *)v; - else - params.table = NULL; - } if (crc >= 0) { - params.can_read_compiled = crc; params.can_read_unsafe = 1; } else { - v = scheme_get_param(scheme_current_config(), MZCONFIG_CAN_READ_COMPILED); - params.can_read_compiled = SCHEME_TRUEP(v); - if (v) { - v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - v2 = scheme_get_initial_inspector(); - params.can_read_unsafe = SAME_OBJ(v, v2); - } else - params.can_read_unsafe = 0; + v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + v2 = scheme_get_initial_inspector(); + params.can_read_unsafe = SAME_OBJ(v, v2); } - v = scheme_get_param(config, MZCONFIG_CAN_READ_PIPE_QUOTE); - params.can_read_pipe_quote = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_BOX); - params.can_read_box = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_GRAPH); - params.can_read_graph = SCHEME_TRUEP(v); - if ((crc > 0) || get_info) { - params.can_read_reader = 1; - params.can_read_lang = 1; - } else { - v = scheme_get_param(config, MZCONFIG_CAN_READ_READER); - params.can_read_reader = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_LANG); - params.can_read_lang = SCHEME_TRUEP(v); - } - v = scheme_get_param(config, MZCONFIG_CASE_SENS); - params.case_sensitive = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS); - params.square_brackets_are_parens = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CURLY_BRACES_ARE_PARENS); - params.curly_braces_are_parens = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED); - params.square_brackets_are_tagged = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CURLY_BRACES_ARE_TAGGED); - params.curly_braces_are_tagged = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_READ_CDOT); - params.read_cdot = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_READ_DECIMAL_INEXACT); - params.read_decimal_inexact = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_QUASI); - params.can_read_quasi = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_DOT); - params.can_read_dot = SCHEME_TRUEP(v); - v = scheme_get_param(config, MZCONFIG_CAN_READ_INFIX_DOT); - params.can_read_infix_dot = SCHEME_TRUEP(v); params.read_relative_path = NULL; if (!delay_load_info) - delay_load_info = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO); + delay_load_info = scheme_get_param(scheme_current_config(), MZCONFIG_DELAY_LOAD_INFO); if (SCHEME_TRUEP(delay_load_info)) params.delay_load_info = delay_load_info; else params.delay_load_info = NULL; params.skip_zo_vers_check = cant_fail; - params.magic_sym = magic_sym; - params.magic_val = magic_val; + params.graph_ht = NULL; - ht = NULL; - if (recur) { - /* Check whether this is really a recursive call. If so, - we get a pointer to a hash table for cycles: */ - v = scheme_extract_one_cc_mark(NULL, unresolved_uninterned_symbol); - if (v && SCHEME_RPAIRP(v)) { - if (SCHEME_FALSEP(SCHEME_CDR(v)) == !stxsrc) - ht = (Scheme_Hash_Table **)SCHEME_CAR(v); - } - } - if (!ht) { - ht = MALLOC_N(Scheme_Hash_Table *, 1); - recur = 0; - } - - do { - v = read_inner_inner(port, stxsrc, ht, scheme_null, ¶ms, - (RETURN_FOR_HASH_COMMENT - | (expose_comment ? (RETURN_FOR_COMMENT | RETURN_FOR_SPECIAL_COMMENT) : 0)), - extra_char, - (init_readtable - ? (SCHEME_FALSEP(init_readtable) - ? NULL - : (Readtable *)init_readtable) - : params.table), - get_info); - - extra_char = -1; - - if (*ht && !recur) { - /* Resolve placeholders: */ - int clone = 0; - Scheme_Hash_Table *dht, *tht; - - if (stxsrc) - scheme_signal_error("internal error: read-syntax has graph references"); - - /* If we ever called an external reader, - then we need to clone everything. */ - if (scheme_hash_get(*ht, tainted_uninterned_symbol)) - clone = 1; - - dht = scheme_make_hash_table(SCHEME_hash_ptr); - tht = scheme_make_hash_table(SCHEME_hash_ptr); - - if (v) - v = resolve_references(v, port, NULL, dht, tht, NULL, clone, 0); - - /* In case some placeholders were introduced by #;: */ - v2 = scheme_hash_get(*ht, unresolved_uninterned_symbol); - if (v2) - resolve_references(v2, port, NULL, dht, tht, NULL, clone, 0); - - if (!v) - *ht = NULL; - } - - if (!v && expose_comment) { - /* Return to indicate comment: */ - v = scheme_alloc_small_object(); - v->type = scheme_special_comment_type; - SCHEME_PTR_VAL(v) = scheme_false; - return v; - } - } while (!v); + v = read_inner(port, ¶ms, extra_char); + + if (params.graph_ht) + v = resolve_references(v, NULL, + scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + NULL, 0, 0); return v; } @@ -2549,52 +1257,28 @@ static void *scheme_internal_read_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *port = (Scheme_Object *)p->ku.k.p1; - Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p2; - Scheme_Object *init_readtable = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *magic_sym = (Scheme_Object *)p->ku.k.p4; - Scheme_Object *magic_val = NULL; Scheme_Object *delay_load_info = (Scheme_Object *)p->ku.k.p5; p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - if (magic_sym) { - magic_val = SCHEME_CDR(magic_sym); - magic_sym = SCHEME_CAR(magic_sym); - } - - return (void *)_internal_read(port, stxsrc, p->ku.k.i1, 0, - p->ku.k.i3 & 0x2, p->ku.k.i3 & 0x1, - p->ku.k.i4, init_readtable, - magic_sym, magic_val, delay_load_info, 0); + return (void *)_internal_read(port, p->ku.k.i1, 0, p->ku.k.i4, delay_load_info); } Scheme_Object * -scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, - int recur, int expose_comment, int pre_char, - Scheme_Object *init_readtable, - Scheme_Object *magic_sym, Scheme_Object *magic_val, +scheme_internal_read(Scheme_Object *port, int crc, int cantfail, + int pre_char, Scheme_Object *delay_load_info) { Scheme_Thread *p = scheme_current_thread; if (cantfail) { - return _internal_read(port, stxsrc, crc, cantfail, recur, expose_comment, -1, NULL, - magic_sym, magic_val, delay_load_info, 0); + return _internal_read(port, crc, cantfail, -1, delay_load_info); } else { - if (magic_sym) - magic_sym = scheme_make_pair(magic_sym, magic_val); - p->ku.k.p1 = (void *)port; - p->ku.k.p2 = (void *)stxsrc; p->ku.k.i1 = crc; - p->ku.k.i3 = ((recur ? 0x2 : 0) | (expose_comment ? 0x1 : 0)); p->ku.k.i4 = pre_char; - p->ku.k.p3 = (void *)init_readtable; - p->ku.k.p4 = (void *)magic_sym; p->ku.k.p5 = (void *)delay_load_info; return (Scheme_Object *)scheme_top_level_do(scheme_internal_read_k, 0); @@ -2603,17 +1287,24 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca Scheme_Object *scheme_read(Scheme_Object *port) { - return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); + Scheme_Object *read_proc, *a[1]; + read_proc = scheme_get_startup_export("read"); + a[0] = port; + return scheme_apply(read_proc, 1, a); } Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc) { - return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL); + Scheme_Object *read_syntax_proc, *a[2]; + read_syntax_proc = scheme_get_startup_export("read-syntax"); + a[0] = stxsrc; + a[1] = port; + return scheme_apply(read_syntax_proc, 2, a); } Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj) { - return resolve_references(obj, NULL, obj, + return resolve_references(obj, obj, scheme_make_hash_table(SCHEME_hash_ptr), scheme_make_hash_table(SCHEME_hash_ptr), NULL, @@ -2624,312 +1315,80 @@ Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj) /* list reader */ /*========================================================================*/ -static Scheme_Object *attach_shape_property(Scheme_Object *list, - Scheme_Object *stxsrc, - ReadParams *params, - int closer); - -static Scheme_Object *attach_shape_tag(Scheme_Object *list, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *stxsrc, - ReadParams *params, - int closer, int shape); - -static int next_is_delim(Scheme_Object *port, - ReadParams *params, - int brackets, - int braces) +static int next_is_delim(Scheme_Object *port) { int next; - next = scheme_peekc_special_ok(port); + next = scheme_peekc(port); return ((next == EOF) || (next == SCHEME_SPECIAL) - || (!params->table - && (scheme_isspace(next) - || (next == '(') - || (next == ')') - || (next == '"') - || (next == ';') - || (next == '\'') - || (next == '`') - || (next == ',') - || ((next == '[') && brackets) - || ((next == '{') && braces) - || ((next == ']') && brackets) - || ((next == '}') && braces))) - || (params->table - && (readtable_kind(params->table, next, params) - & (READTABLE_WHITESPACE | READTABLE_TERMINATING)))); -} - -static const char *mapping_name(ReadParams *params, int ch, const char *def, int name_pos) -{ - if (params->table) { - int i; - char *buf = ""; - Scheme_Object *v; - Scheme_Hash_Table *mapping; - - if (params->table->names) { - if (params->table->names[name_pos]) - return params->table->names[name_pos]; - } - - mapping = params->table->mapping; - if (!scheme_hash_get(mapping, scheme_make_integer(ch))) { - buf = (char *)scheme_malloc_atomic(4); - sprintf(buf, "`%c'", ch); - } - - for (i = mapping->size; i--; ) { - if (mapping->vals[i]) { - v = mapping->vals[i]; - if ((SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED) - && (SCHEME_INT_VAL(SCHEME_CDR(v)) == ch)) { - int len; - mzchar a[2]; - char *naya, utf8_buf[MAX_UTF8_CHAR_BYTES + 1]; - - v = mapping->keys[i]; - a[0] = (mzchar)SCHEME_INT_VAL(v); - len = scheme_utf8_encode_all(a, 1, (unsigned char *)utf8_buf); - utf8_buf[len] = 0; - - naya = (char *)scheme_malloc_atomic(len + 5 + strlen(buf)); - sprintf(naya, "`%s'", utf8_buf); - if (*buf) { - sprintf(naya XFORM_OK_PLUS len + 2, " or %s", buf); - } - buf = naya; - } - } - } - - if (!params->table->names) { - char **a; - a = MALLOC_N(char*, 7); - params->table->names = a; - } - params->table->names[name_pos] = buf; - - return buf; - } else - return def; -} - -static const char *closer_name(ReadParams *params, int closer) -{ - int pos; - const char *def; - - switch (closer) { - case ')': - pos = 0; - def = "`)'"; - break; - case ']': - pos = 1; - def = "`]'"; - break; - case '}': - default: - pos = 2; - def = "`}'"; - break; - } - - return mapping_name(params, closer, def, pos); -} - -static const char *opener_name(ReadParams *params, int opener) -{ - int pos; - const char *def; - - switch (opener) { - case '(': - pos = 3; - def = "`('"; - break; - case '[': - pos = 4; - def = "`['"; - break; - case '{': - default: - pos = 5; - def = "`{'"; - break; - } - - return mapping_name(params, opener, def, pos); -} - -static const char *dot_name(ReadParams *params) -{ - return mapping_name(params, '.', "`.'", 6); + || (scheme_isspace(next) + || (next == '(') + || (next == ')') + || (next == '"') + || (next == ';') + || (next == '\'') + || (next == '`') + || (next == ',') + || ((next == '[')) + || ((next == '{')) + || ((next == ']')) + || ((next == '}')))); } /* "(" (or other opener) has already been read */ static Scheme_Object * read_list(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, int opener, int closer, int shape, int use_stack, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table) + ReadParams *params) { - Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL, *prefetched = NULL; - int ch = 0, got_ch_already = 0, effective_ch; - int brackets = params->square_brackets_are_parens || params->square_brackets_are_tagged; - int braces = params->curly_braces_are_parens || params->curly_braces_are_tagged; - intptr_t start, startcol, startline, dotpos, dotcol, dotline, dot2pos, dot2line, dot2col, init_span; - - scheme_tell_all(port, &startline, &startcol, &start); - init_span = 1; - - if (stxsrc) { - /* Push onto the indentation stack: */ - Scheme_Indent *indt; - indt = (Scheme_Indent *)scheme_malloc_atomic_tagged(sizeof(Scheme_Indent)); - indt->type = scheme_indent_type; - - indt->closer = closer; - indt->max_indent = startcol + 1; - indt->multiline = 0; - indt->suspicious_line = 0; - indt->suspicious_quote = 0; - indt->start_line = startline; - indt->last_line = startline; - - indentation = scheme_make_pair((Scheme_Object *)indt, indentation); - } + Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL; + int ch = 0, got_ch_already = 0; while (1) { - if (prefetched) - ch = 0; - else if (got_ch_already) + if (got_ch_already) got_ch_already = 0; else - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); + ch = skip_whitespace_comments(port, params); if ((ch == EOF) && (closer != EOF)) { - char *suggestion = ""; - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - if (indt->suspicious_line) { - suggestion = scheme_malloc_atomic(100); - sprintf(suggestion, - "\n possible cause: indentation suggests a missing %s before line %" PRIdPTR, - closer_name(params, indt->suspicious_closer), - indt->suspicious_line); - } - } - - scheme_read_err(port, stxsrc, startline, startcol, start, MINSPAN(port, start, init_span), EOF, indentation, - "read: expected a %s to close `%c'%s", - closer_name(params, closer), - opener, - suggestion); + scheme_read_err(port, "read: expected a `%s` to close `%c`", closer, opener); return NULL; } - effective_ch = readtable_effective_char(table, ch); - - if (effective_ch == closer) { + if (ch == closer) { if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected hash pair (with key and value separated by %s) before `%c'", - dot_name(params), - ch); + scheme_read_err(port, "read: expected hash pair (with key and value separated by `.`) before `%c`", ch); return NULL; } if (!list) list = scheme_null; - pop_indentation(indentation); - list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer, shape); - list = (stxsrc - ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : list); - list = attach_shape_property(list, stxsrc, params, closer); return list; } if (shape == mz_shape_hash_list) { /* Make sure we found a parenthesized something. */ - if (!(effective_ch == '(') - && !(effective_ch == '[' && params->square_brackets_are_parens) - && !(effective_ch == '{' && params->curly_braces_are_parens)) { - intptr_t xl, xc, xp; - const char *sbname, *cbname; - - /* If it's a special or we have a readtable, we need to read ahead - to make sure that it's not a comment. For consistency, always - read ahead. */ - scheme_ungetc(ch, port); - prefetched = read_inner(port, stxsrc, ht, indentation, params, - RETURN_FOR_SPECIAL_COMMENT); - if (!prefetched) - continue; /* It was a comment; try again. */ - - sbname = (params->square_brackets_are_parens ? opener_name(params, '[') : ""); - cbname = (params->curly_braces_are_parens ? opener_name(params, '{') : ""); - - scheme_tell_all(port, &xl, &xc, &xp); - scheme_read_err(port, stxsrc, xl, xc, xp, 1, - ch, indentation, - "read: expected %s%s%s%s%s to start a hash pair", - opener_name(params, '('), - params->square_brackets_are_parens ? " or " : "", - sbname, - params->curly_braces_are_parens ? " or " : "", - cbname); + if (!(ch == '(') + && !(ch == '[') + && !(ch == '{')) { + scheme_read_err(port, "read: expected `(`, `[`, or `{` to start a hash pair"); return NULL; } else { /* Found paren. Use read_list directly so we can specify mz_shape_hash_elem. */ - intptr_t xl, xc, xp; - scheme_tell_all(port, &xl, &xc, &xp); - car = read_list(port, stxsrc, xl, xc, xp, - ch, ((effective_ch == '(') ? ')' : ((effective_ch == '[') ? ']' : '}')), - mz_shape_hash_elem, use_stack, ht, indentation, params, table); + car = read_list(port, + ch, ((ch == '(') ? ')' : ((ch == '[') ? ']' : '}')), + mz_shape_hash_elem, use_stack, params); /* car is guaranteed to have an appropriate shape */ } } else { - if (prefetched) { - car = prefetched; - prefetched = NULL; - } else { - scheme_ungetc(ch, port); - switch (shape) { - case mz_shape_fl_vec: - car = read_flonum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); - MZ_ASSERT(SCHEME_DBLP(car)); - break; - case mz_shape_fx_vec: - car = read_fixnum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); - MZ_ASSERT(SCHEME_INTP(car)); - break; - default: - car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); - } - if (!car) continue; /* special was a comment */ - } + car = read_inner(port, params, ch); /* can't be eof, due to check above */ } pair = scheme_make_pair(car, scheme_null); - retry_before_dot: - - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == closer) { + ch = skip_whitespace_comments(port, params); + if (ch == closer) { if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected %s and value for hash before `%c'", - dot_name(params), - ch); + scheme_read_err(port, "read: expected `.` and value for hash before `%c`", ch); return NULL; } @@ -2940,58 +1399,32 @@ read_list(Scheme_Object *port, SCHEME_CDR(last) = cdr; if (infixed) { - /* Assert: we're not using the list stack */ list = scheme_make_pair(infixed, list); } - - pop_indentation(indentation); - list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer, shape); - list = (stxsrc - ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : list); - list = attach_shape_property(list, stxsrc, params, closer); return list; - } else if (params->can_read_dot - && (effective_ch == '.') - && next_is_delim(port, params, brackets, braces)) { - int dot_ch = ch; - - scheme_tell_all(port, &dotline, &dotcol, &dotpos); - - track_indentation(indentation, dotline, dotcol); - + } else if ((ch == '.') + && next_is_delim(port)) { if (((shape != mz_shape_cons) && (shape != mz_shape_hash_elem) && (shape != mz_shape_vec_plus_infix)) || infixed) { - scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, 0, indentation, - "read: illegal use of `%c'", - dot_ch); + scheme_read_err(port, "read: illegal use of `.`"); return NULL; } /* can't be eof, due to check above: */ - cdr = read_inner(port, stxsrc, ht, indentation, params, 0); - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); - effective_ch = readtable_effective_char(table, ch); - if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) { - if (params->can_read_infix_dot - && (effective_ch == '.') - && next_is_delim(port, params, brackets, braces)) { + cdr = read_inner(port, params, -1); + ch = skip_whitespace_comments(port, params); + if ((ch != closer) || (shape == mz_shape_vec_plus_infix)) { + if ((ch == '.') + && next_is_delim(port)) { /* Parse as infix: */ if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected %s after hash value", - closer_name(params, closer)); + scheme_read_err(port, "read: expected `%c` after hash value", closer); return NULL; } - { - scheme_tell_all(port, &dot2line, &dot2col, &dot2pos); - track_indentation(indentation, dot2line, dot2col); - } - infixed = cdr; if (!list) @@ -3001,19 +1434,14 @@ read_list(Scheme_Object *port, last = pair; /* Make sure there's not a closing paren immediately after the dot: */ - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); - effective_ch = readtable_effective_char(table, ch); - if ((effective_ch == closer) || (ch == EOF)) { - scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, - "read: illegal use of `%c'", ch); + ch = skip_whitespace_comments(port, params); + if ((ch == closer) || (ch == EOF)) { + scheme_read_err(port, "read: illegal use of `%c`", ch); return NULL; } - if (!prefetched) - got_ch_already = 1; + got_ch_already = 1; } else { - scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, - "read: illegal use of `%c'", - dot_ch); + scheme_read_err(port, "read: illegal use of `.`"); return NULL; } } else { @@ -3025,43 +1453,13 @@ read_list(Scheme_Object *port, SCHEME_CDR(last) = cdr; /* Assert: infixed is NULL (otherwise we raised an exception above) */ - - pop_indentation(indentation); - list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer, shape); - list = (stxsrc - ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : list); - list = attach_shape_property(list, stxsrc, params, closer); return list; } } else { - if ((ch == SCHEME_SPECIAL) - || (table - && (ch != EOF) - && (shape != mz_shape_hash_list) - && (shape != mz_shape_fl_vec) - && (shape != mz_shape_fx_vec))) { - /* We have to try the read, because it might be a comment. */ - scheme_ungetc(ch, port); - prefetched = read_inner(port, stxsrc, ht, indentation, params, - RETURN_FOR_SPECIAL_COMMENT); - if (!prefetched) - goto retry_before_dot; - if ((shape == mz_shape_fl_vec) && !SCHEME_DBLP(prefetched)) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: stream produced a non-flonum for flvector"); - } else if ((shape == mz_shape_fx_vec) && !SCHEME_INTP(prefetched)) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: stream produced a non-fixnum for fxvector"); - } - } else { - got_ch_already = 1; - } + got_ch_already = 1; if (shape == mz_shape_hash_elem) { - scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, - "read: expected %s and value for hash", - dot_name(params)); + scheme_read_err(port, "read: expected `.` and value for hash"); return NULL; } @@ -3075,196 +1473,40 @@ read_list(Scheme_Object *port, } } -static Scheme_Object *attach_shape_property(Scheme_Object *list, - Scheme_Object *stxsrc, - ReadParams *params, - int closer) -{ - if ((closer != ')') && stxsrc) { - Scheme_Object *opener; - opener = ((closer == '}') - ? scheme_paren_shape_preserve_curly - : scheme_paren_shape_preserve_square); - return scheme_stx_property(list, scheme_paren_shape_symbol, opener); - } - return list; -} - -static Scheme_Object *attach_shape_tag(Scheme_Object *list, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *stxsrc, - ReadParams *params, - int closer, int shape) -{ - Scheme_Object *tag; - tag = NULL; - - if (params->square_brackets_are_tagged && closer == ']') { - tag = brackets_symbol; - } else if (params->curly_braces_are_tagged && closer == '}') { - tag = braces_symbol; - } - - if (tag && shape == mz_shape_cons) { - if (stxsrc) { - tag = scheme_make_stx_w_offset(tag, line, col, pos, span, stxsrc, STX_SRCTAG); - } - list = scheme_make_pair(tag, list); - } - - return list; -} - -static Scheme_Object *read_flonum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode) -{ - intptr_t line = 0, col = 0, pos = 0; - intptr_t line2 = 0, col2 = 0, pos2 = 0; - Scheme_Object *n; - scheme_tell_all(port, &line, &col, &pos); - n = read_number_literal(port, stxsrc, 1, 0, ht, indentation, params, comment_mode); - if (SCHEME_DBLP(n)) - return n; - scheme_tell_all(port, &line2, &col2, &pos2); - scheme_read_err(port, stxsrc, line, col, pos, pos2-pos, -1, indentation, "read: expected flonum, got %V", n); - return NULL; -} - -static Scheme_Object *read_fixnum(Scheme_Object *port, - Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode) -{ - intptr_t line = 0, col = 0, pos = 0; - intptr_t line2 = 0, col2 = 0, pos2 = 0; - Scheme_Object *n; - scheme_tell_all(port, &line, &col, &pos); - n = read_number_literal(port, stxsrc, 0, 1, ht, indentation, params, comment_mode); - if (SCHEME_INTP(n)) - return n; - scheme_tell_all(port, &line2, &col2, &pos2); - scheme_read_err(port, stxsrc, line, col, pos, pos2-pos, -1, indentation, "read: expected fixnum, got %V", n); - return NULL; -} - -static Scheme_Object *read_number_literal(Scheme_Object *port, - Scheme_Object *stxsrc, - int is_float, int is_not_float, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, - int comment_mode) -{ - int ch; - intptr_t line = 0, col = 0, pos = 0; - Scheme_Object *special_value = NULL; - Readtable *table; - - table = params->table; - scheme_tell_all(port, &line, &col, &pos); - ch = scheme_getc_special_ok(port); - switch (ch) { - case '+': - case '-': - case '.': /* ^^^ fallthrough ^^^ */ - special_value = read_plus_minus_period_leading_number(port, stxsrc, ch, line, col, pos, is_float, is_not_float, ht, indentation, params, table); - break; - case '#': - ch = scheme_getc_special_ok(port); - switch (ch ) { - case 'X': - case 'x': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 16, 1, ht, indentation, params, table); - break; - case 'B': - case 'b': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 2, 1, ht, indentation, params, table); - break; - case 'O': - case 'o': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 8, 1, ht, indentation, params, table); - break; - case 'D': - case 'd': - return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 1, ht, indentation, params, table); - break; - default: - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, "read: expected `x', `X', `b', `B', `o', `O', `d', or `D'"); - } - default: - if (isdigit_ascii(ch)) - special_value = read_number(ch, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 0, ht, indentation, params, table); - else - scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, "read: expected a digit, `+', `-', `.', or `#'"); - } - return special_value; -} - /*========================================================================*/ /* string reader */ /*========================================================================*/ /* '"' has already been read */ static Scheme_Object * -read_string(int is_byte, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table, - int err_ok) +read_string(int is_byte, Scheme_Object *port, ReadParams *params, int err_ok) { mzchar *buf, *oldbuf, onstack[32]; - int i, j, n, n1, ch, effective_ch, closer = '"'; - intptr_t size = 31, oldsize, in_pos, init_span; + int i, j, n, n1, ch, closer = '"'; + intptr_t size = 31, oldsize; Scheme_Object *result; - scheme_tell_all(port, NULL, NULL, &in_pos); - init_span = in_pos - pos + 1; - i = 0; buf = onstack; while (1) { - ch = scheme_getc_special_ok(port); - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == closer) + ch = scheme_getc(port); + if (ch == closer) break; if (ch == EOF) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), ch, indentation, - "read: expected a closing %s%s", + scheme_read_err(port, "read: expected a closing %s%s", "'\"'", (ch == EOF) ? "" : " after one character"); return NULL; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: found non-character while reading a %s", - "string"); - return NULL; } /* Note: errors will tend to leave junk on the port, with an open \". */ /* Escape-sequence handling by Eli Barzilay. */ if (ch == '\\') { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == EOF) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation, - "read: expected a closing %s", - "'\"'"); - return NULL; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: found non-character while reading a %s", - "string"); + scheme_read_err(port, "read: expected a closing %s", "'\"'"); return NULL; } switch ( ch ) { @@ -3278,28 +1520,24 @@ read_string(int is_byte, Scheme_Object *port, case 't': ch = '\t'; break; case 'v': ch = '\v'; break; case '\r': - if (scheme_peekc_special_ok(port) == '\n') + if (scheme_peekc(port) == '\n') scheme_getc(port); continue; /* <---------- !!!! */ case '\n': continue; /* <---------- !!!! */ case 'x': - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10); - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { n = n*16 + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); scheme_getc(port); /* must be ch */ } ch = n; } else { - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: no hex digit following \\x in %s", - "string"); + scheme_read_err(port, "read: no hex digit following \\x in string"); return NULL; } break; @@ -3308,13 +1546,13 @@ read_string(int is_byte, Scheme_Object *port, if (!is_byte) { int maxc = ((ch == 'u') ? 4 : 8); char initial[9]; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { int count = 1; initial[0] = ch; n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10); while (count < maxc) { - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { initial[count] = ch; n = ((unsigned)n<<4) + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); @@ -3329,26 +1567,26 @@ read_string(int is_byte, Scheme_Object *port, the next part is "\uD..." */ int n2 = -1, sndp = 0; mzchar snd[7]; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == '\\') { snd[sndp++] = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == 'u') { snd[sndp++] = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if ((ch == 'd') || (ch == 'D')) { snd[sndp++] = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { snd[sndp++] = ch; n2 = (scheme_toupper(ch)-'A'+10); if ((n2 >= 12) && (n2 <= 15)) { n2 = 0xD000 | (n2 << 8); - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { snd[sndp++] = ch; n2 |= ((ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)) << 4); - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { n2 |= (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); n = (((n - 0xD800) << 10) + (n2 - 0xDC00)) + 0x10000; @@ -3363,13 +1601,11 @@ read_string(int is_byte, Scheme_Object *port, } } if (n2 < 0) { - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); - else if (NOT_EOF_OR_SPECIAL(ch)) + if (NOT_EOF_OR_SPECIAL(ch)) snd[sndp++] = ch; snd[sndp] = 0; if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, + scheme_read_err(port, "read: bad or incomplete surrogate-style encoding at `\\u%s%5'", initial, snd); @@ -3384,10 +1620,8 @@ read_string(int is_byte, Scheme_Object *port, ch = n; } } else { - if (ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, + scheme_read_err(port, "read: no hex digit following \\%c in %s", ((maxc == 4) ? 'u' : 'U'), "string"); @@ -3401,14 +1635,14 @@ read_string(int is_byte, Scheme_Object *port, n1 = 8*n + ch - '0'; if (n1 > 255) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: escape sequence \\%o out of range in %s", n1, "string"); return NULL; } n = n1; if (j < 2) { - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (!((ch >= '0') && (ch <= '7'))) { break; } else { @@ -3419,7 +1653,7 @@ read_string(int is_byte, Scheme_Object *port, ch = n; } else { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: unknown escape sequence \\%c in %s%s", ch, is_byte ? "byte " : "", "string"); @@ -3427,21 +1661,9 @@ read_string(int is_byte, Scheme_Object *port, } break; } - } else if ((ch == '\n') || (ch == '\r')) { - /* Suspicious string... remember the line */ - if (line > 0) { - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - /* Only remember if there's no earlier suspcious string line: */ - if (!indt->suspicious_quote) { - indt->suspicious_quote = line; - } - } - } } else if (is_byte && (ch > 255)) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: out-of-range character in byte string: %c", ch); return NULL; @@ -3449,7 +1671,7 @@ read_string(int is_byte, Scheme_Object *port, if (ch < 0) { if (err_ok) - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + scheme_read_err(port, "read: out-of-range character in %sstring", is_byte ? "byte " : ""); return NULL; @@ -3480,10 +1702,6 @@ read_string(int is_byte, Scheme_Object *port, s[i] = 0; result = scheme_make_immutable_sized_byte_string(s, i, 0); } - if (stxsrc) { - result = scheme_intern_literal_string(result); - result = scheme_make_stx_w_offset(result, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } return result; } @@ -3491,168 +1709,40 @@ read_string(int is_byte, Scheme_Object *port, Scheme_Object *scheme_read_byte_string(Scheme_Object *port) /* used by GRacket */ { - return read_string(1, port, - NULL, 0, 0, 0, - NULL, - NULL, NULL, NULL, - 0); -} - -static Scheme_Object * -read_here_string(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params) - /* #<< has been read already */ -{ - int tlen = 0, len = 0, size = 12; - mzchar *tag, *naya, *s, buf[12], c; - intptr_t in_pos, init_span; - Scheme_Object *str; - - scheme_tell_all(port, NULL, NULL, &in_pos); - init_span = in_pos - pos + 1; - - tag = buf; - while (1) { - c = scheme_getc(port); - if (c == '\n') { - break; - } else if (c == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, 3 + tlen, EOF, indentation, - "read: found end-of-file after #<< and before first and-of-line"); - return NULL; - } else { - if (tlen >= size) { - size *= 2; - naya = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar)); - memcpy(naya, tag, tlen * sizeof(mzchar)); - tag = naya; - } - tag[tlen++] = c; - } - } - if (!tlen) { - scheme_read_err(port, stxsrc, line, col, pos, 3, 0, indentation, - "read: no characters after #<< before and-of-line"); - return NULL; - } - - size = 10 + tlen; - s = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar)); - while (1) { - c = scheme_getc(port); - if (c == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation, - "read: found end-of-file before terminating %u%s", - tag, - (intptr_t)((tlen > 50) ? 50 : tlen), - (tlen > 50) ? "..." : ""); - return NULL; - } - if (len >= size) { - size *= 2; - naya = (mzchar *)scheme_malloc_atomic(size * sizeof(mzchar)); - memcpy(naya, s, len * sizeof(mzchar)); - s = naya; - } - s[len++] = c; - if ((len >= tlen) - && ((len == tlen) - || (s[len - tlen - 1] == '\n')) - && !memcmp(s XFORM_OK_PLUS (len - tlen), tag, sizeof(mzchar) * tlen)) { - c = scheme_peekc(port); - if ((c == '\r') || (c == '\n') || (c == EOF)) - break; - } - } - - len -= (tlen + 1); - if (len < 0) - len = 0; - - str = scheme_make_immutable_sized_char_string(s, len, 1); - - if (stxsrc) { - str = scheme_intern_literal_string(str); - str = scheme_make_stx_w_offset(str, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } - - return str; -} - -char *scheme_extract_indentation_suggestions(Scheme_Object *indentation) -{ - intptr_t suspicious_quote = 0; - char *suspicions = ""; - - /* search back through indentation records to find the - first suspicious quote */ - while (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - indentation = SCHEME_CDR(indentation); - if (indt->suspicious_quote) { - suspicious_quote = indt->suspicious_quote; - } - } - - if (suspicious_quote) { - suspicions = (char *)scheme_malloc_atomic(64); - sprintf(suspicions, - "newline within %s suggests a missing %s on line %" PRIdPTR, - "string", - "'\"'", - suspicious_quote); - } - - return suspicions; + return read_string(1, port, NULL, 0); } /*========================================================================*/ /* vector reader */ /*========================================================================*/ -#define FUNC_NAME read_vector -#define VTYPE_STR "vector" -#define VEC_TYPE Scheme_Object -#define ELMS_TYPE Scheme_Object ** -#define ELM_TYPE Scheme_Object * -#define MZ_SHAPE allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec -#define MK_VEC() (Scheme_Object *) scheme_make_vector(requestLength, NULL) -#define ELMS_SELECTOR SCHEME_VEC_ELS -#define ELM_SELECTOR -#define ELM_MAKE_ZERO scheme_make_integer(0) -#define ELM_STX(elm) scheme_make_stx_w_offset(elm, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); -#define VEC_SIZE SCHEME_VEC_SIZE -#include "read_vector.inc" -#define FUNC_NAME read_fxvector -#define VTYPE_STR "fxvector" -#define VEC_TYPE Scheme_Object -#define ELMS_TYPE Scheme_Object ** -#define ELM_TYPE Scheme_Object * -#define MZ_SHAPE mz_shape_fx_vec -#define MK_VEC() (Scheme_Object *) scheme_alloc_fxvector(requestLength) -#define ELMS_SELECTOR SCHEME_FXVEC_ELS -#define ELM_SELECTOR -#define ELM_MAKE_ZERO scheme_make_integer(0) -#define ELM_STX(elm) elm -#define VEC_SIZE SCHEME_FXVEC_SIZE -#include "read_vector.inc" +/* "#(" has been read */ +static Scheme_Object * +read_vector (Scheme_Object *port, + int opener, char closer, + ReadParams *params, + int allow_infix) +{ + Scheme_Object *lresult, *obj; + Scheme_Object *vec; + int len, i; -#define FUNC_NAME read_flvector -#define VTYPE_STR "flvector" -#define VEC_TYPE Scheme_Double_Vector -#define ELMS_TYPE double * -#define ELM_TYPE double -#define MZ_SHAPE mz_shape_fl_vec -#define MK_VEC() scheme_alloc_flvector(requestLength) -#define ELMS_SELECTOR SCHEME_FLVEC_ELS -#define ELM_SELECTOR SCHEME_DBL_VAL -#define ELM_MAKE_ZERO 0.0 -#define ELM_STX(elm) elm -#define VEC_SIZE SCHEME_FLVEC_SIZE -#include "read_vector.inc" + lresult = read_list(port, opener, closer, + (allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec), + 1, params); + + obj = lresult; + + len = scheme_list_length(obj); + + vec = (Scheme_Object *) scheme_make_vector(len, NULL); + for (i = 0; i < len ; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + } + + return vec; +} /*========================================================================*/ /* symbol reader */ @@ -3665,85 +1755,51 @@ typedef int (*Getc_Fun_r)(Scheme_Object *port); /* nothing has been read, except maybe some flags */ static Scheme_Object * -read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, +read_number_or_symbol(int init_ch, Scheme_Object *port, int is_float, int is_not_float, int radix, int radix_set, - int is_symbol, int is_kw, int pipe_quote, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + int is_symbol, int is_kw, + ReadParams *params) { mzchar *buf, *oldbuf, onstack[MAX_QUICK_SYMBOL_SIZE]; int size, oldsize; - int i, ch, quoted, quoted_ever = 0, running_quote = 0; + int i, ch, quoted_ever = 0, running_quote = 0; int running_quote_ch = 0; - intptr_t rq_pos = 0, rq_col = 0, rq_line = 0; - int case_sens = params->case_sensitive; - int decimal_inexact = params->read_decimal_inexact; - int read_cdot = params->read_cdot; Scheme_Object *o; int delim_ok; int ungetc_ok; int far_char_ok; - int single_escape, multiple_escape, norm_count = 0; - Getc_Fun_r getc_special_ok_fun; - - if (!skip_rt && table) { - /* If the readtable provides a "symbol" reader, then use it: */ - if (table->symbol_parser) { - return readtable_call(1, init_ch, table->symbol_parser, params, - port, stxsrc, line, col, pos, 0, ht, NULL); - /* Special-comment result is handled in main loop. */ - } - } + int single_escape, multiple_escape; + Getc_Fun_r getc_fun; ungetc_ok = scheme_peekc_is_ungetc(port); - if (ungetc_ok) { - getc_special_ok_fun = scheme_getc_special_ok; - } else { - getc_special_ok_fun = scheme_peekc_special_ok; - } + if (ungetc_ok) + getc_fun = scheme_getc; + else + getc_fun = scheme_peekc; i = 0; size = MAX_QUICK_SYMBOL_SIZE - 1; buf = onstack; if (init_ch < 0) - ch = getc_special_ok_fun(port); + ch = getc_fun(port); else { /* Assert: this one won't need to be ungotten */ ch = init_ch; } - if (table) { - far_char_ok = 0; - delim_ok = 0; - } else { - delim_ok = SCHEME_OK; - far_char_ok = 1; - } + delim_ok = SCHEME_OK; + far_char_ok = 1; while (NOT_EOF_OR_SPECIAL(ch) && (running_quote - || (!table - && !scheme_isspace(ch) + || (!scheme_isspace(ch) && (((ch < 128) && (delim[ch] & delim_ok)) - || ((ch >= 128) && far_char_ok)) - && !(!is_float && !is_not_float && !radix_set && read_cdot && ch == '.')) - || (table - && !(!is_float && !is_not_float && !radix_set && read_cdot && readtable_effective_char(table, ch) == '.')))) { - if (table) { - int v; - v = readtable_kind(table, ch, params); - if (!running_quote && (v & (READTABLE_TERMINATING | READTABLE_WHITESPACE))) - break; - single_escape = (v & READTABLE_SINGLE_ESCAPE); - multiple_escape = (v & READTABLE_MULTIPLE_ESCAPE); - } else { - single_escape = (ch == '\\'); - multiple_escape = ((ch == '|') && pipe_quote); - } + || ((ch >= 128) && far_char_ok))))) { + single_escape = (ch == '\\'); + multiple_escape = (ch == '|'); if (!ungetc_ok) { if (init_ch < 0) scheme_getc(port); /* must be a character */ @@ -3752,31 +1808,20 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, } if (single_escape && !running_quote) { int esc_ch = ch; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if (ch == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation, - "read: EOF following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol"); - return NULL; - } else if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: non-character following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol"); + scheme_read_err(port, "read: EOF following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol"); return NULL; } - quoted = 1; quoted_ever = 1; } else if (multiple_escape && (!running_quote || (ch == running_quote_ch))) { quoted_ever = 1; running_quote = !running_quote; running_quote_ch = ch; - quoted = 0; - scheme_tell_all(port, &rq_line, &rq_col, &rq_pos); - - ch = getc_special_ok_fun(port); + ch = getc_fun(port); continue; /* <-- !!! */ - } else - quoted = 0; + } if (i >= size) { oldsize = size; @@ -3787,76 +1832,25 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, memcpy(buf, oldbuf, oldsize * sizeof(mzchar)); } - if (!case_sens && !quoted && !running_quote) - norm_count++; - else if (norm_count) { - /* case-normalize the last norm_count characters */ - mzchar *s; - int newlen; - s = scheme_string_recase(buf, i - norm_count, norm_count, 3, 1, &newlen); - if (s != buf) { - if ((i + newlen - norm_count) >= size) { - oldsize = size; - oldbuf = buf; - - size *= 2; - if (size <= (i + newlen - norm_count)) - size = 2 * (i + (newlen - norm_count)); - buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar)); - memcpy(buf, oldbuf, oldsize * sizeof(mzchar)); - } - memcpy(buf + i - norm_count, s, sizeof(mzchar) * newlen); - } - i += (newlen - norm_count); - norm_count = 0; - } - buf[i++] = ch; - ch = getc_special_ok_fun(port); - } - - if (running_quote && (ch == SCHEME_SPECIAL)) { - scheme_get_ready_read_special(port, stxsrc, ht); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: non-character following `%c' in %s", running_quote_ch, - is_kw ? "keyword" : "symbol"); + ch = getc_fun(port); } if (ungetc_ok) scheme_ungetc(ch, port); if (running_quote) { - scheme_read_err(port, stxsrc, rq_line, rq_col, rq_pos, SPAN(port, rq_pos), EOF, indentation, - "read: unbalanced `%c'", running_quote_ch); + scheme_read_err(port, "read: unbalanced `%c`", running_quote_ch); return NULL; } - if (norm_count) { - /* case-normalize the last norm_count characters */ - mzchar *s; - int newlen; - s = scheme_string_recase(buf, i - norm_count, norm_count, 3, 1, &newlen); - if (s != buf) { - oldsize = size; - oldbuf = buf; - size = i + (newlen - norm_count) + 1; - buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar)); - memcpy(buf, oldbuf, oldsize * sizeof(mzchar)); - memcpy(buf + i - norm_count, s, sizeof(mzchar) * newlen); - } - i += (newlen - norm_count); - } - buf[i] = '\0'; - if (!quoted_ever && (i == 1) - && (readtable_effective_char(params->table, buf[0]) == '.')) { + if (!quoted_ever && (i == 1) && (buf[0] == '.')) { intptr_t xl, xc, xp; scheme_tell_all(port, &xl, &xc, &xp); - scheme_read_err(port, stxsrc, xl, xc, xp, - 1, 0, indentation, - "read: illegal use of `.'"); + scheme_read_err(port, "read: illegal use of `.'"); return NULL; } @@ -3864,13 +1858,9 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, o = scheme_false; else { o = scheme_read_number(buf, i, - is_float, is_not_float, decimal_inexact, + is_float, is_not_float, 1 /* decimal_inexact */, radix, radix_set, - port, NULL, 0, - stxsrc, line, col, pos, SPAN(port, pos), - indentation); - if (!SCHEME_INTP(o) && stxsrc) - o = scheme_intern_literal_number(o); + port, NULL, 0); } if (SAME_OBJ(o, scheme_false)) { @@ -3880,72 +1870,57 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, o = scheme_intern_exact_char_symbol(buf, i); } - if (stxsrc) - o = scheme_make_stx_w_offset(o, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - return o; } static Scheme_Object * read_number(int init_ch, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, int is_float, int is_not_float, int radix, int radix_set, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + ReadParams *params) { - return read_number_or_symbol(init_ch, init_ch < 0, - port, stxsrc, line, col, pos, + return read_number_or_symbol(init_ch, + port, is_float, is_not_float, radix, radix_set, 0, 0, - params->can_read_pipe_quote, - ht, indentation, params, table); + params); } static Scheme_Object * read_symbol(int init_ch, - int skip_rt, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + ReadParams *params) { - return read_number_or_symbol(init_ch, skip_rt, - port, stxsrc, line, col, pos, + return read_number_or_symbol(init_ch, + port, 0, 0, 10, 0, 1, 0, - params->can_read_pipe_quote, - ht, indentation, params, table); + params); } static Scheme_Object * read_keyword(int init_ch, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, Readtable *table) + ReadParams *params) { - return read_number_or_symbol(init_ch, 1, - port, stxsrc, line, col, pos, + return read_number_or_symbol(init_ch, + port, 0, 0, 10, 0, 1, 1, - params->can_read_pipe_quote, - ht, indentation, params, table); + params); } static Scheme_Object * read_delimited_constant(int ch, const mzchar *str, Scheme_Object *v, Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params, Readtable *table) + ReadParams *params) { int first_ch = ch; int scanpos = 1; if (ch == str[0]) { /* might be `T' instead of `t', for example */ do { - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); if ((mzchar)ch == str[scanpos]) { scanpos++; } else { @@ -3954,16 +1929,16 @@ read_delimited_constant(int ch, const mzchar *str, } while (str[scanpos]); } else { /* need to show next character to show why it's wrong: */ - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); } if (str[scanpos] - || !next_is_delim(port, params, 1, 1)) { + || !next_is_delim(port)) { mzchar str_part[7], one_more[2]; if (!str[scanpos]) { /* get non-delimiter again: */ - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); } memcpy(str_part, str XFORM_OK_PLUS 1, (scanpos - 1) * sizeof(mzchar)); @@ -3974,8 +1949,7 @@ read_delimited_constant(int ch, const mzchar *str, } else one_more[0] = 0; - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), - ch, indentation, + scheme_read_err(port, "read: bad syntax `#%c%5%u'", first_ch, str_part, @@ -3984,9 +1958,7 @@ read_delimited_constant(int ch, const mzchar *str, return NULL; } - return (stxsrc - ? scheme_make_stx_w_offset(v, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) - : v); + return v; } /*========================================================================*/ @@ -4005,12 +1977,10 @@ static int u_strcmp(mzchar *s, const char *_t) return 0; } -static Scheme_Object *make_interned_char(int ch, Scheme_Object *stxsrc) +static Scheme_Object *make_interned_char(int ch) { if (ch < 256) return scheme_make_character(ch); - else if (stxsrc) - return scheme_intern_literal_number(scheme_make_char(ch)); else return scheme_make_char(ch); } @@ -4018,34 +1988,25 @@ static Scheme_Object *make_interned_char(int ch, Scheme_Object *stxsrc) /* "#\" has been read */ static Scheme_Object * read_character(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) + ReadParams *params) { int ch, next; - ch = scheme_getc_special_ok(port); + ch = scheme_getc(port); - if (ch == SCHEME_SPECIAL) { - scheme_get_ready_read_special(port, stxsrc, ht); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), SCHEME_SPECIAL, indentation, - "read: found non-character after #\\"); - return NULL; - } - - next = scheme_peekc_special_ok(port); + next = scheme_peekc(port); if ((ch >= '0' && ch <= '7') && (next >= '0' && next <= '7')) { /* a is the same as next */ int last; - last = (scheme_getc(port) /* is char */, scheme_peekc_special_ok(port)); + last = (scheme_getc(port) /* is char */, scheme_peekc(port)); if (last != SCHEME_SPECIAL) scheme_getc(port); /* must be last */ if (last < '0' || last > '7' || ch > '3') { - scheme_read_err(port, stxsrc, line, col, pos, ((last == EOF) || (last == SCHEME_SPECIAL)) ? 3 : 4, last, indentation, + scheme_read_err(port, "read: bad character constant #\\%c%c%c", ch, next, ((last == EOF) || (last == SCHEME_SPECIAL)) ? ' ' : last); return NULL; @@ -4053,13 +2014,13 @@ read_character(Scheme_Object *port, ch = ((ch - '0') << 6) + ((next - '0') << 3) + (last - '0'); - return make_interned_char(ch, stxsrc); + return make_interned_char(ch); } if (((ch == 'u') || (ch == 'U')) && NOT_EOF_OR_SPECIAL(next) && scheme_isxdigit(next)) { int count = 0, n = 0, nbuf[10], maxc = ((ch == 'u') ? 4 : 8); while (count < maxc) { - ch = scheme_peekc_special_ok(port); + ch = scheme_peekc(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { nbuf[count] = ch; n = ((unsigned)n<<4) + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)); @@ -4072,7 +2033,7 @@ read_character(Scheme_Object *port, if ((n < 0) || ((n >= 0xD800) && (n <= 0xDFFF)) || (n > 0x10FFFF)) { - scheme_read_err(port, stxsrc, line, col, pos, count + 2, 0, indentation, + scheme_read_err(port, "read: bad character constant #\\%c%u", (maxc == 4) ? 'u' : 'U', nbuf, (intptr_t)count); @@ -4088,7 +2049,7 @@ read_character(Scheme_Object *port, i = 1; buf = onstack; buf[0] = ch; - while ((ch = scheme_peekc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isalpha(ch))) { + while ((ch = scheme_peekc(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isalpha(ch))) { scheme_getc(port); /* is alpha character */ if (i >= size) { oldsize = size; @@ -4143,17 +2104,13 @@ read_character(Scheme_Object *port, break; } - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: bad character constant: #\\%5", - buf); + scheme_read_err(port, "read: bad character constant: #\\%5", buf); } - if (ch == EOF) { - scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation, - "read: expected a character after #\\"); - } + if (ch == EOF) + scheme_read_err(port, "read: expected a character after #\\"); - return make_interned_char(ch, stxsrc); + return make_interned_char(ch); } /*========================================================================*/ @@ -4163,49 +2120,30 @@ read_character(Scheme_Object *port, /* "'", etc. has been read */ static Scheme_Object * read_quote(char *who, Scheme_Object *quote_symbol, int len, - Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) + Scheme_Object *port, ReadParams *params) { Scheme_Object *obj, *ret; - obj = read_inner(port, stxsrc, ht, indentation, params, 0); + obj = read_inner(port, params, -1); if (SCHEME_EOFP(obj)) - scheme_read_err(port, stxsrc, line, col, pos, len, EOF, indentation, - "read: expected an element for %s (found end-of-file)", - who); - ret = (stxsrc - ? scheme_make_stx_w_offset(quote_symbol, line, col, pos, len, stxsrc, STX_SRCTAG) - : quote_symbol); + scheme_read_err(port, "read: expected an element for %s (found end-of-file)", who); + ret = quote_symbol; ret = scheme_make_pair(ret, scheme_make_pair(obj, scheme_null)); - if (stxsrc) { - ret = scheme_make_stx_w_offset(ret, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } return ret; } /* "#&" has been read */ -static Scheme_Object *read_box(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) +static Scheme_Object *read_box(Scheme_Object *port, ReadParams *params) { Scheme_Object *o, *bx; - o = read_inner(port, stxsrc, ht, indentation, params, 0); + o = read_inner(port, params, -1); if (SCHEME_EOFP(o)) - scheme_read_err(port, stxsrc, line, col, pos, 2, EOF, indentation, - "read: expected an element for #& box (found end-of-file)"); + scheme_read_err(port, "read: expected an element for #& box (found end-of-file)"); bx = scheme_box(o); - if (stxsrc) { - SCHEME_SET_BOX_IMMUTABLE(bx); - bx = scheme_make_stx_w_offset(bx, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } - return bx; } @@ -4214,53 +2152,30 @@ static Scheme_Object *read_box(Scheme_Object *port, /*========================================================================*/ /* "(" has been read */ -static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, +static Scheme_Object *read_hash(Scheme_Object *port, int opener, char closer, int kind, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table) + ReadParams *params) { Scheme_Object *l; + Scheme_Object *key, *val; + Scheme_Hash_Tree *t; /* using mz_shape_hash_list ensures that l is a list of pairs */ - l = read_list(port, stxsrc, line, col, pos, opener, closer, mz_shape_hash_list, 0, ht, indentation, params, table); + l = read_list(port, opener, closer, mz_shape_hash_list, 0, params); - if (stxsrc) { - Scheme_Object *key, *val; - Scheme_Hash_Tree *t; + t = scheme_make_hash_tree(kind); - t = scheme_make_hash_tree(kind); - - for (; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - val = SCHEME_STX_CAR(l); - key = SCHEME_STX_CAR(val); - key = scheme_syntax_to_datum(key, 0, NULL); - val = SCHEME_STX_CDR(val); - - t = scheme_hash_tree_set(t, key, val); - } + for (; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + val = SCHEME_STX_CAR(l); + key = SCHEME_STX_CAR(val); + key = scheme_syntax_to_datum(key); + key = scheme_expander_syntax_to_datum(key); + val = SCHEME_STX_CDR(val); - return scheme_make_stx_w_offset((Scheme_Object *)t, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } else { - /* Wait for placeholders to be resolved before mapping keys to - values, because a placeholder may be used in a key. */ - Scheme_Object *ph; - - ph = scheme_alloc_object(); - ph->type = scheme_table_placeholder_type; - SCHEME_IPTR_VAL(ph) = l; - SCHEME_PINT_VAL(ph) = kind; - - if (!*ht) { - /* So that resolve_references is called to build the table: */ - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *ht = tht; - } - - return ph; + t = scheme_hash_tree_set(t, key, val); } + + return (Scheme_Object *)t; } /*========================================================================*/ @@ -4301,112 +2216,56 @@ Scheme_Object *scheme_read_intern(Scheme_Object *o) /*========================================================================*/ static int -skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, - Scheme_Hash_Table **ht, Scheme_Object *indentation, - ReadParams *params, Readtable *table, - Scheme_Object **_prefetched) -/* If `_prefetched` is non_NULL, then a SCHEME_SPECIAL result means that - the special value has already been read, and it wasn't a comment. */ +skip_whitespace_comments(Scheme_Object *port, + ReadParams *params) { - int ch, effective_ch; - int blockc_1, blockc_2; - - blockc_1 = '#'; - blockc_2 = '|'; + int ch; start_over: - if (table) { - while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch))) { - if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE)) - break; - } - } else { - while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {} - } + while ((ch = scheme_getc(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {} - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == ';') { + if (ch == ';') { do { - ch = scheme_getc_special_ok(port); - effective_ch = readtable_effective_char(table, ch); - if (effective_ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); - } while (!is_line_comment_end(effective_ch) && (effective_ch != EOF)); + ch = scheme_getc(port); + } while (!is_line_comment_end(ch) && (ch != EOF)); goto start_over; } - if ((effective_ch == blockc_1) - && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == blockc_2)) { + if ((ch == '#') + && (scheme_peekc(port) == '|')) { int depth = 0; int ch2 = 0; - intptr_t col, pos, line; - - scheme_tell_all(port, &line, &col, &pos); (void)scheme_getc(port); /* re-read '|' */ do { - ch = scheme_getc_special_ok(port); - effective_ch = readtable_effective_char(table, ch); + ch = scheme_getc(port); - if (effective_ch == EOF) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: end of file in #| comment"); - else if (effective_ch == SCHEME_SPECIAL) - scheme_get_ready_read_special(port, stxsrc, ht); + if (ch == EOF) + scheme_read_err(port, "read: end of file in #| comment"); - if ((ch2 == blockc_2) && (effective_ch == blockc_1)) { + if ((ch2 == '|') && (ch == '#')) { if (!(depth--)) goto start_over; - effective_ch = 0; /* So we don't count '#' toward an opening "#|" */ - } else if ((ch2 == blockc_1) && (ch == blockc_2)) { + ch = 0; /* So we don't count '#' toward an opening "#|" */ + } else if ((ch2 == '#') && (ch == '|')) { depth++; - effective_ch = 0; /* So we don't count '|' toward a closing "|#" */ + ch = 0; /* So we don't count '|' toward a closing "|#" */ } - ch2 = effective_ch; + ch2 = ch; } while (1); goto start_over; } - if ((effective_ch == '#') - && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == ';')) { + if ((ch == '#') + && (scheme_peekc(port) == ';')) { Scheme_Object *skipped; - intptr_t col, pos, line; - - scheme_tell_all(port, &line, &col, &pos); - - track_indentation(indentation, line, col); (void)scheme_getc(port); /* re-read ';' */ - skipped = read_inner(port, stxsrc, ht, indentation, params, 0); + skipped = read_inner(port, params, -1); if (SCHEME_EOFP(skipped)) - scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, - "read: expected a commented-out element for `#;' (found end-of-file)"); - - /* For resolving graphs introduced in #; : */ - if (*ht) { - Scheme_Object *v; - v = scheme_hash_get(*ht, unresolved_uninterned_symbol); - if (!v) - v = scheme_null; - v = scheme_make_pair(skipped, v); - scheme_hash_set(*ht, unresolved_uninterned_symbol, v); - } - - goto start_over; - } - - if ((ch == SCHEME_SPECIAL) && _prefetched) { - Scheme_Object *v; - intptr_t col, pos, line; - - scheme_tell_all(port, &line, &col, &pos); - v = scheme_get_special(port, stxsrc, line, col, pos, 0, ht); - if (!scheme_special_comment_value(v)) { - *_prefetched = v; - return SCHEME_SPECIAL; - } + scheme_read_err(port, "read: expected a commented-out element for `#;' (found end-of-file)"); goto start_over; } @@ -4414,125 +2273,32 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, return ch; } -static void unexpected_closer(int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Object *indentation, - ReadParams *params) +static void unexpected_closer(int ch, Scheme_Object *port) { - char *suggestion = "", *found = "unexpected"; - - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - int opener; - char *missing; - - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - - found = scheme_malloc_atomic(100); - - if (indt->closer == '}') - opener = '{'; - else if (indt->closer == ']') - opener = '['; - else - opener = '('; - - /* Missing intermediate closers, or just need something else entirely? */ - { - Scheme_Object *l; - Scheme_Indent *indt2; - - missing = "expected"; - for (l = SCHEME_CDR(indentation); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - indt2 = (Scheme_Indent *)SCHEME_CAR(l); - if (indt2->closer == ch) { - missing = "missing"; - } - } - } - - if (ch == indt->closer) { - sprintf(found, "unexpected"); - } else if (indt->multiline) { - sprintf(found, - "%s %s to close %s on line %" PRIdPTR ", found instead", - missing, - closer_name(params, indt->closer), - opener_name(params, opener), - indt->start_line); - } else { - sprintf(found, - "%s %s to close preceding %s, found instead", - missing, - closer_name(params, indt->closer), - opener_name(params, opener)); - } - - if (indt->suspicious_line) { - suggestion = scheme_malloc_atomic(100); - sprintf(suggestion, - "; indentation suggests a missing %s before line %" PRIdPTR, - closer_name(params, indt->suspicious_closer), - indt->suspicious_line); - } - } - - scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: %s `%c'%s", - found, ch, suggestion); + scheme_read_err(port, "read: unexpected `%c`", ch); } -static void pop_indentation(Scheme_Object *indentation) +static int read_graph_index(Scheme_Object *port, int *ch) { - /* Pop off indentation stack, and propagate - suspicions if none found earlier. */ - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *indt; - indt = (Scheme_Indent *)SCHEME_CAR(indentation); - indentation = SCHEME_CDR(indentation); - if (SCHEME_PAIRP(indentation)) { - Scheme_Indent *old_indt; - old_indt = (Scheme_Indent *)SCHEME_CAR(indentation); + int digits = 0, val = 0, nch; - if (!old_indt->suspicious_line) { - if (indt->suspicious_line) { - old_indt->suspicious_line = indt->suspicious_line; - old_indt->suspicious_closer = indt->suspicious_closer; - } - } - if (!old_indt->suspicious_quote) { - if (indt->suspicious_quote) { - old_indt->suspicious_quote = indt->suspicious_quote; - } - } - } + while (NOT_EOF_OR_SPECIAL((*ch)) && isdigit_ascii((*ch))) { + if (digits >= MAX_GRAPH_ID_DIGITS) + scheme_read_err(port, "too many digits after `#%d`", val); + digits++; + + val = ((val) * 10) + ((*ch) - 48); + nch = scheme_getc(port); + (*ch) = nch; } + + return val; } /*========================================================================*/ /* .zo reader */ /*========================================================================*/ -typedef struct Scheme_Load_Delay { - MZTAG_IF_REQUIRED - Scheme_Object *path; - intptr_t file_offset, size; - uintptr_t symtab_size; - Scheme_Object **symtab; - intptr_t *shared_offsets; - Scheme_Hash_Table *symtab_entries; /* `symtab` content to be skipped by resolve_references */ - Scheme_Object *relto; - Scheme_Unmarshal_Tables *ut; - struct CPort *current_rp; - int perma_cache; - unsigned char *cached; - Scheme_Object *cached_port; - struct Scheme_Load_Delay *clear_bytes_prev; - struct Scheme_Load_Delay *clear_bytes_next; - int unsafe_ok; - mzlonglong bytecode_hash; -} Scheme_Load_Delay; - #define ZO_CHECK(x) if (!(x)) scheme_ill_formed_code(port); #define RANGE_CHECK(x, y) ZO_CHECK (x y) #define RANGE_POS_CHECK(x, y) ZO_CHECK ((x > 0) && (x y)) @@ -4551,7 +2317,6 @@ typedef struct CPort { Scheme_Unmarshal_Tables *ut; Scheme_Object **symtab; Scheme_Hash_Table *symtab_entries; - Scheme_Object *magic_sym, *magic_val; Scheme_Object *relto; intptr_t *shared_offsets; Scheme_Load_Delay *delay_info; @@ -4560,7 +2325,6 @@ typedef struct CPort { #define CP_GETC(cp) ((int)(cp->start[cp->pos++])) #define CP_TELL(port) (port->pos + port->base) -static Scheme_Object *read_marshalled(int type, CPort *port); static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port); static Scheme_Object *read_compact_quote(CPort *port, int embedded); @@ -4571,7 +2335,6 @@ void scheme_ill_formed(struct CPort *port ) { scheme_read_err(port ? port->orig_port : NULL, - NULL, -1, -1, port ? CP_TELL(port) : 0, -1, 0, NULL, "read (compiled): ill-formed code" #if TRACK_ILL_FORMED_CATCH_LINES " [%s:%d]", file, line @@ -4582,14 +2345,12 @@ void scheme_ill_formed(struct CPort *port static void unsafe_disallowed(struct CPort *port) { scheme_read_err(port ? port->orig_port : NULL, - NULL, -1, -1, port ? CP_TELL(port) : 0, -1, 0, NULL, "read (compiled): unsafe values disallowed"); } static void make_ut(CPort *port) { Scheme_Unmarshal_Tables *ut; - Scheme_Hash_Table *rht; char *decoded; ut = MALLOC_ONE_RT(Scheme_Unmarshal_Tables); @@ -4604,40 +2365,6 @@ static void make_ut(CPort *port) ut->decoded = decoded; ut->bytecode_hash = port->bytecode_hash; - - rht = scheme_make_hash_table(SCHEME_hash_ptr); - port->ut->rns = rht; - - rht = scheme_make_hash_table(SCHEME_hash_ptr); - port->ut->multi_scope_pairs = rht; -} - -static void prepare_current_unmarshal(Scheme_Unmarshal_Tables *ut) -{ - /* in case a previous unmarshal was interrupted: */ - ut->current_rns = NULL; - ut->current_multi_scope_pairs = NULL; -} - -static void merge_ht(Scheme_Hash_Table *f, Scheme_Hash_Table *t) -{ - int i; - for (i = f->size; i--; ) { - if (f->vals[i]) - scheme_hash_set(t, f->keys[i], f->vals[i]); - } -} - -static void complete_current_unmarshal(Scheme_Unmarshal_Tables *ut) -{ - if (ut->current_rns) { - merge_ht(ut->current_rns, ut->rns); - ut->current_rns = NULL; - } - if (ut->current_multi_scope_pairs) { - merge_ht(ut->current_multi_scope_pairs, ut->multi_scope_pairs); - ut->current_multi_scope_pairs = NULL; - } } /* Since read_compact_number is called often, we want it to be @@ -4746,34 +2473,32 @@ static int valid_utf8(const char *s, int l) static Scheme_Object *read_escape_from_string(char *s, intptr_t len, Scheme_Object *rel_to, - Scheme_Hash_Table **ht) + Scheme_Hash_Table **ht, + Scheme_Object *orig_port) { - Scheme_Object *ep; + Scheme_Object *ep, *v; ReadParams params; + Scheme_Input_Port *ep_ip; ep = scheme_make_sized_byte_string_input_port(s, len); - - params.can_read_compiled = 1; - params.can_read_pipe_quote = 1; - params.can_read_box = 1; - params.can_read_graph = 1; - /* Use startup value of case sensitivity so legacy code will work. */ - params.case_sensitive = scheme_case_sensitive; - params.square_brackets_are_parens = 1; - params.curly_braces_are_parens = 1; - params.square_brackets_are_tagged = 0; - params.curly_braces_are_tagged = 0; - params.read_cdot = 0; - params.read_decimal_inexact = 1; - params.can_read_dot = 1; - params.can_read_infix_dot = 1; - params.can_read_quasi = 1; + + if (orig_port) { + v = scheme_input_port_record(orig_port)->name; + if (v) { + ep_ip = scheme_input_port_record(ep); + ep_ip->name = v; + } + } + params.skip_zo_vers_check = 0; - params.table = NULL; - params.read_relative_path = rel_to; + params.graph_ht = *ht; - return read_inner(ep, NULL, ht, scheme_null, ¶ms, 0); + v = read_inner(ep, ¶ms, -1); + + *ht = params.graph_ht; + + return v; } static Scheme_Object *read_compact_escape(CPort *port) @@ -4799,7 +2524,7 @@ static Scheme_Object *read_compact_escape(CPort *port) len = -len; /* no alloc in sized_byte_string_input_port */ #endif - return read_escape_from_string(s, len, port->relto, port->ht); + return read_escape_from_string(s, len, port->relto, port->ht, port->orig_port); } static void record_symtab_self_contained(Scheme_Hash_Table *symtab_entries, Scheme_Object *v) @@ -4826,12 +2551,12 @@ static Scheme_Object *resolve_symtab_refs(Scheme_Object *v, CPort *port) if (v) { v = scheme_make_pair(v, port->symtab_refs); - v = resolve_references(v, port->orig_port, NULL, + v = resolve_references(v, port->orig_port, scheme_make_hash_table(SCHEME_hash_ptr), scheme_make_hash_table(SCHEME_hash_ptr), port->symtab_entries, 0, 0); - + l = SCHEME_CDR(v); } else l = port->symtab_refs; @@ -4904,9 +2629,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) if (!valid_utf8(s, l)) scheme_ill_formed_code(port); v = scheme_intern_exact_symbol(s, l); - - if (SAME_OBJ(v, port->magic_sym)) - v = port->magic_val; break; case CPT_SYMREF: l = read_compact_number(port); @@ -4984,7 +2706,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) break; case CPT_CHAR: l = read_compact_number(port); - return make_interned_char(l, scheme_true); + return make_interned_char(l); break; case CPT_INT: return scheme_make_integer(read_compact_number(port)); @@ -5039,88 +2761,56 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) break; case CPT_HASH_TABLE: { - Scheme_Object *l; + Scheme_Hash_Tree *ht; int kind, len; Scheme_Object *k; kind = read_compact_number(port); len = read_compact_number(port); - - l = scheme_null; + + ht = scheme_make_hash_tree(kind); while (len--) { k = read_compact(port, 0); v = read_compact(port, 0); - /* We can't always hash directly, because a key or value - might have a graph reference inside it. */ - l = scheme_make_pair(scheme_make_pair(k, v), l); + ht = scheme_hash_tree_set(ht, k, v); } - if (!(*port->ht)) { - /* So that resolve_references is called to build the table: */ - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *(port->ht) = tht; - } - - /* Let resolve_references complete the table construction: */ - v = scheme_alloc_object(); - v->type = scheme_table_placeholder_type; - SCHEME_PINT_VAL(v) = kind; - SCHEME_IPTR_VAL(v) = l; + v = (Scheme_Object *)ht; } break; - case CPT_STX: + case CPT_LINKLET: { - Scheme_Hash_Table *save_ht; - - if (!port->ut) - make_ut(port); - - save_ht = *port->ht; - *port->ht = NULL; - - prepare_current_unmarshal(port->ut); - v = read_compact(port, 1); - - if (!SCHEME_NULLP(port->symtab_refs)) - v = resolve_symtab_refs(v, port); - else if (*port->ht) { - *port->ht = NULL; - v = resolve_references(v, port->orig_port, NULL, - scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), - port->symtab_entries, - 0, 0); - } - - *port->ht = save_ht; - - v = scheme_unmarshal_datum_to_syntax(v, port->ut, 0); - scheme_num_read_syntax_objects++; - if (!v) - scheme_ill_formed_code(port); - complete_current_unmarshal(port->ut); + v = read_compact(port, 1); + v = scheme_read_linklet(v); + if (!v) scheme_ill_formed_code(port); + return v; } break; - case CPT_MARSHALLED: - v = read_marshalled(read_compact_number(port), port); - break; case CPT_QUOTE: v = read_compact_quote(port, 1); break; case CPT_REFERENCE: l = read_compact_number(port); - RANGE_CHECK(l, < (EXPECTED_PRIM_COUNT - + EXPECTED_UNSAFE_COUNT - + EXPECTED_FLFXNUM_COUNT - + EXPECTED_EXTFL_COUNT - + EXPECTED_FUTURES_COUNT - + EXPECTED_FOREIGN_COUNT)); + RANGE_CHECK(l, < EXPECTED_PRIM_COUNT); if ((l >= unsafe_variable_references_start) && !port->unsafe_ok) unsafe_disallowed(port); return variable_references[l]; break; + case CPT_TOPLEVEL: + { + int flags, pos, depth; + + flags = read_compact_number(port); + pos = read_compact_number(port); + depth = read_compact_number(port); + + if ((depth < 0) || (pos < 0)) + scheme_ill_formed_code(port); + + return scheme_make_toplevel(depth, pos, flags); + } + break; case CPT_LOCAL: { int p, flags; @@ -5169,6 +2859,102 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) return (Scheme_Object *)a; } break; + case CPT_BEGIN: + case CPT_BEGIN0: + { + Scheme_Sequence *seq; + int i, count; + + count = read_compact_number(port); + if (count <= 0) scheme_ill_formed_code(port); + seq = scheme_malloc_sequence(count); + seq->so.type = ((ch == CPT_BEGIN) ? scheme_sequence_type : scheme_begin0_sequence_type); + seq->count = count; + + for (i = 0; i < count; i++) { + v = read_compact(port, 1); + seq->array[i] = v; + } + + return (Scheme_Object *)seq; + } + break; + case CPT_LET_VALUE: + { + Scheme_Let_Value *lv; + int c, p; + + lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value)); + lv->iso.so.type = scheme_let_value_type; + + c = read_compact_number(port); + p = read_compact_number(port); + if ((c < 0) || (p < 0)) scheme_ill_formed_code(port); + + lv->count = c; + lv->position = p; + if (read_compact_number(port)) + SCHEME_LET_VALUE_AUTOBOX(lv) = 1; + v = read_compact(port, 1); + lv->value = v; + v = read_compact(port, 1); + lv->body = v; + + return (Scheme_Object *)lv; + } + break; + case CPT_LET_VOID: + { + Scheme_Let_Void *lv; + int c; + + lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void)); + lv->iso.so.type = scheme_let_void_type; + + c = read_compact_number(port); + if (c < 0) scheme_ill_formed_code(port); + + lv->count = c; + if (read_compact_number(port)) + SCHEME_LET_VOID_AUTOBOX(lv) = 1; + v = read_compact(port, 1); + lv->body = v; + + return (Scheme_Object *)lv; + } + break; + case CPT_LETREC: + { + Scheme_Letrec *lr; + Scheme_Object **sa; + int i, c; + + lr = MALLOC_ONE_TAGGED(Scheme_Letrec); + lr->so.type = scheme_letrec_type; + + c = read_compact_number(port); + if (c < 0) scheme_ill_formed_code(port); + + lr->count = c; + if (c < 4096) + sa = MALLOC_N(Scheme_Object*, c); + else { + sa = scheme_malloc_fail_ok(scheme_malloc, scheme_check_overflow(c, sizeof(Scheme_Object *), 0)); + if (!sa) scheme_signal_error("out of memory allocating letrec bytecode"); + } + lr->procs = sa; + + for (i = 0; i < c; i++) { + v = read_compact(port, 1); + sa[i] = v; + } + + v = read_compact(port, 1); + lr->body = v; + + return (Scheme_Object *)lr; + } + break; case CPT_LET_ONE: case CPT_LET_ONE_TYPED: case CPT_LET_ONE_UNUSED: @@ -5204,55 +2990,203 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) return scheme_make_branch(test, tbranch, fbranch); } break; - case CPT_MODULE_INDEX: - { - Scheme_Object *path, *base; - - path = read_compact(port, 0); - base = read_compact(port, 0); - if (SCHEME_FALSEP(path) - && SCHEME_FALSEP(base)) { - path = read_compact(port, 0); - if (SCHEME_FALSEP(path)) - return scheme_make_modidx(scheme_false, scheme_false, scheme_false); - else - return scheme_get_submodule_empty_self_modidx(path, 0); - } else - return scheme_make_modidx(path, base, scheme_false); - } - break; - case CPT_MODULE_VAR: + case CPT_WCM: { - Module_Variable *mv; - Scheme_Object *mod, *var, *shape; - int pos; + Scheme_With_Continuation_Mark *wcm; + + wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + wcm->so.type = scheme_with_cont_mark_type; - mod = read_compact(port, 0); - var = read_compact(port, 0); - shape = read_compact(port, 0); - pos = read_compact_number(port); + v = read_compact(port, 1); + wcm->key = v; + v = read_compact(port, 1); + wcm->val = v; + v = read_compact(port, 1); + wcm->body = v; - mv = MALLOC_ONE_TAGGED(Module_Variable); - mv->iso.so.type = scheme_module_variable_type; - if (SCHEME_SYMBOLP(mod)) - mod = scheme_intern_resolved_module_path(mod); - mv->modidx = mod; - mv->sym = var; - mv->shape = shape; - if (pos < -3) { - pos = -(pos + 3); - SCHEME_MODVAR_FLAGS(mv) = pos; - pos = read_compact_number(port); + return (Scheme_Object *)wcm; + } + break; + case CPT_DEFINE_VALUES: + { + v = read_compact(port, 1); + if (!SCHEME_VECTORP(v)) scheme_ill_formed_code(port); + v->type = scheme_define_values_type; + return v; + } + break; + case CPT_SET_BANG: + { + Scheme_Set_Bang *sb; + + sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); + sb->so.type = scheme_set_bang_type; + + if (read_compact_number(port)) + sb->set_undef = 1; + + v = read_compact(port, 1); + sb->var = v; + v = read_compact(port, 1); + sb->val = v; + + return (Scheme_Object *)sb; + } + break; + case CPT_OTHER_FORM: + { + switch (read_compact_number(port)) { + case scheme_boxenv_type: + { + Scheme_Object *data; + + data = scheme_alloc_object(); + data->type = scheme_boxenv_type; + + v = read_compact(port, 1); + SCHEME_PTR1_VAL(data) = v; + v = read_compact(port, 1); + SCHEME_PTR2_VAL(data) = v; + + return data; + } + break; + case scheme_with_immed_mark_type: + { + Scheme_With_Continuation_Mark *wcm; + + wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + wcm->so.type = scheme_with_immed_mark_type; + + v = read_compact(port, 1); + wcm->key = v; + v = read_compact(port, 1); + wcm->val = v; + v = read_compact(port, 1); + wcm->body = v; + + return (Scheme_Object *)wcm; + } + case scheme_inline_variant_type: + { + Scheme_Object *data; + + data = scheme_make_vector(3, scheme_false); + data->type = scheme_inline_variant_type; + + v = read_compact(port, 1); + SCHEME_VEC_ELS(data)[0] = v; + v = read_compact(port, 1); + SCHEME_VEC_ELS(data)[1] = v; + /* third slot is filled when linklet->accessible table is made */ + + return data; + } + case scheme_case_lambda_sequence_type: + { + int count, i, all_closed = 1; + Scheme_Case_Lambda *cl; + + count = read_compact_number(port); + if (count < 0) scheme_ill_formed_code(port); + + cl = (Scheme_Case_Lambda *) + scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + + (count - mzFLEX_DELTA) * sizeof(Scheme_Object *)); + cl->so.type = scheme_case_lambda_sequence_type; + cl->count = count; + + v = read_compact(port, 1); + if (SCHEME_NULLP(v)) + cl->name = NULL; + else + cl->name = v; + + for (i = 0; i < count; i++) { + v = read_compact(port, 1); + cl->array[i] = v; + if (!SCHEME_PROCP(v)) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type)) + scheme_ill_formed_code(port); + all_closed = 0; + } else if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type)) + scheme_ill_formed_code(port); + } + + if (all_closed) { + /* Empty closure: produce procedure value directly. + (We assume that this was generated by a direct write of + a case-lambda data record in print.c, and that it's not + in a CASE_LAMBDA_EXPD syntax record.) */ + return scheme_case_lambda_execute((Scheme_Object *)cl); + } + + return (Scheme_Object *)cl; + } + break; + case scheme_lambda_type: + { + Scheme_Object *name, *ds, *closure_map, *tl_map; + int flags, closure_size, num_params, max_let_depth; + + flags = read_compact_number(port); + if (flags & LAMBDA_HAS_TYPED_ARGS) + closure_size = read_compact_number(port); + else + closure_size = -1; + num_params = read_compact_number(port); + max_let_depth = read_compact_number(port); + + name = read_compact(port, 1); + ds = read_compact(port, 1); + closure_map = read_compact(port, 1); + tl_map = read_compact(port, 1); + + v = scheme_read_lambda(flags, closure_size, num_params, max_let_depth, + name, ds, closure_map, tl_map); + if (!v) scheme_ill_formed_code(port); + + return v; + } + default: + scheme_ill_formed_code(port); + return NULL; + break; } - if (pos == -2) { - pos = read_compact_number(port); - mv->mod_phase = pos; - pos = read_compact_number(port); - mv->pos = pos; - } else - mv->pos = pos; + } + break; + case CPT_VARREF: + { + Scheme_Object *data; + int flags; - return (Scheme_Object *)mv; + data = scheme_alloc_object(); + data->type = scheme_varref_form_type; + + flags = read_compact_number(port); + SCHEME_VARREF_FLAGS(data) |= (flags & VARREF_FLAGS_MASK); + + v = read_compact(port, 1); + SCHEME_PTR1_VAL(data) = v; + v = read_compact(port, 1); + SCHEME_PTR2_VAL(data) = v; + + return data; + } + break; + case CPT_APPLY_VALUES: + { + Scheme_Object *data; + + data = scheme_alloc_object(); + data->type = scheme_apply_values_type; + + v = read_compact(port, 1); + SCHEME_PTR1_VAL(data) = v; + v = read_compact(port, 1); + SCHEME_PTR2_VAL(data) = v; + + return data; } break; case CPT_PATH: @@ -5303,7 +3237,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) if (!v) { if (port->delay_info) { /* This is where we construct information for - loading the syntax object on demand. */ + loading the lamda form on demand. */ v = scheme_make_raw_pair(scheme_make_integer(l), (Scheme_Object *)port->delay_info); } else { @@ -5352,12 +3286,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) return scheme_make_local(type, ch, 0); } break; - case CPT_SMALL_MARSHALLED_START: - { - l = ch - CPT_SMALL_MARSHALLED_START; - v = read_marshalled(l, port); - } - break; case CPT_SMALL_SYMBOL_START: { l = ch - CPT_SMALL_SYMBOL_START; @@ -5366,9 +3294,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) if (!valid_utf8(s, l)) scheme_ill_formed_code(port); v = scheme_intern_exact_symbol(s, l); - - if (SAME_OBJ(v, port->magic_sym)) - v = port->magic_val; } break; case CPT_SMALL_NUMBER_START: @@ -5463,32 +3388,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) return (Scheme_Object *)app; } break; - case CPT_SCOPE: - { - Scheme_Object *v2; - - if (!port->ut) - make_ut(port); - - v = scheme_box(scheme_false); - l = read_compact_number(port); - - if (l) { - RANGE_POS_CHECK(l, < port->symtab_size); - port->symtab[l] = v; - } - - l = read_compact_number(port); - - v2 = read_compact(port, 0); - v2 = scheme_make_pair(scheme_make_integer(l), v2); - SCHEME_BOX_VAL(v) = v2; - - return v; - } - break; - case CPT_ROOT_SCOPE: - return scheme_stx_root_scope(); case CPT_SHARED: { Scheme_Object *ph; @@ -5574,7 +3473,7 @@ static Scheme_Object *read_compact_quote(CPort *port, int embedded) port->ht = old_ht; if (*q_ht) - v = resolve_references(v, port->orig_port, NULL, + v = resolve_references(v, port->orig_port, scheme_make_hash_table(SCHEME_hash_ptr), scheme_make_hash_table(SCHEME_hash_ptr), port->symtab_entries, @@ -5583,31 +3482,6 @@ static Scheme_Object *read_compact_quote(CPort *port, int embedded) return v; } -static Scheme_Object *read_marshalled(int type, CPort *port) -{ - Scheme_Object *l; - Scheme_Type_Reader reader; - - l = read_compact(port, 1); - - if ((type < 0) || (type >= _scheme_last_type_)) { - scheme_ill_formed_code(port); - } - - reader = scheme_type_readers[type]; - - if (!reader) { - scheme_ill_formed_code(port); - } - - l = reader(l); - - if (!l) - scheme_ill_formed_code(port); - - return l; -} - static intptr_t read_simple_number_from_port(Scheme_Object *port) { intptr_t a, b, c, d; @@ -5642,7 +3516,7 @@ static void install_byecode_hash_code(CPort *rp, char *hash_code) rp->bytecode_hash = l; } -char *scheme_submodule_path_to_string(Scheme_Object *p, intptr_t *_len) +char *scheme_symbol_path_to_string(Scheme_Object *p, intptr_t *_len) { Scheme_Object *pr; intptr_t len = 0, l; @@ -5679,7 +3553,7 @@ char *scheme_submodule_path_to_string(Scheme_Object *p, intptr_t *_len) return (char *)s; } -Scheme_Object *scheme_string_to_submodule_path(char *_s, intptr_t len) +Scheme_Object *scheme_string_to_symbol_path(char *_s, intptr_t len) { unsigned char *s = (unsigned char *)_s; char *e, buffer[32]; @@ -5716,21 +3590,20 @@ Scheme_Object *scheme_string_to_submodule_path(char *_s, intptr_t len) return first ? first : scheme_null; } -static void read_module_directory(Scheme_Object *port, Scheme_Hash_Table *ht, int depth) +/* Installs into `ht` a mapping of offset -> (listof symbol) */ +static void read_linklet_directory(Scheme_Object *port, Scheme_Hash_Table *ht, int depth, intptr_t bundle_pos) { char *s; Scheme_Object *v, *p; int len, left, right; - intptr_t got; + intptr_t got, offset; if (depth > 32) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): multi-module directory tree is imbalanced"); + scheme_read_err(port, "read (compiled): linklet-module directory tree is imbalanced"); len = read_simple_number_from_port(port); if (len < 0) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): directory module name read failed"); + scheme_read_err(port, "read (compiled): linklet-bundle name read failed"); s = scheme_malloc_atomic(len + 1); got = scheme_get_bytes(port, len, s, 0); @@ -5739,7 +3612,7 @@ static void read_module_directory(Scheme_Object *port, Scheme_Hash_Table *ht, in v = NULL; else { s[len] = 0; - v = scheme_string_to_submodule_path(s, len); + v = scheme_string_to_symbol_path(s, len); for (p = v; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) { v = NULL; @@ -5751,33 +3624,109 @@ static void read_module_directory(Scheme_Object *port, Scheme_Hash_Table *ht, in } if (!v) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): directory module name read failed"); + scheme_read_err(port, "read (compiled): linklet-bundle name read failed"); - scheme_hash_set(ht, v, scheme_null); - - (void)read_simple_number_from_port(port); /* offset */ + offset = read_simple_number_from_port(port); /* offset */ (void)read_simple_number_from_port(port); /* length */ + scheme_hash_set(ht, scheme_make_integer(offset+bundle_pos), v); + left = read_simple_number_from_port(port); right = read_simple_number_from_port(port); if (left) - read_module_directory(port, ht, depth+1); + read_linklet_directory(port, ht, depth+1, bundle_pos); if (right) - read_module_directory(port, ht, depth+1); + read_linklet_directory(port, ht, depth+1, bundle_pos); +} + +Scheme_Object *wrap_as_linklet_directory(Scheme_Hash_Tree *ht) +{ + Scheme_Object *v; + v = scheme_alloc_small_object(); + v->type = scheme_linklet_directory_type; + SCHEME_PTR_VAL(v) = (Scheme_Object *)ht; + return v; +} + +static Scheme_Object *bundle_list_to_hierarchical_directory(Scheme_Object *bundles) +{ + Scheme_Hash_Tree *accum, *next; + Scheme_Object *p, *v, *path, *stack; + int len, prev_len, i; + + /* The bundles list is in post-order, so we can build directories + bottom-up */ + + prev_len = 0; + stack = scheme_null; + accum = scheme_make_hash_tree(0); + + while (1) { + MZ_ASSERT(SCHEME_PAIRP(bundles)); + p = SCHEME_CAR(bundles); + path = SCHEME_CAR(p); + v = SCHEME_CDR(p); + + MZ_ASSERT(SCHEME_FALSEP(v) || SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + + len = scheme_list_length(path); + + if (len < prev_len) + return NULL; + + while (len > prev_len + 1) { + stack = scheme_make_pair((Scheme_Object *)accum, stack); + prev_len++; + accum = scheme_make_hash_tree(0); + } + + for (i = 0; i < prev_len - 1; i++) { + path = SCHEME_CDR(path); + } + + if (len == prev_len) { + if (!SCHEME_FALSEP(v)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + accum = scheme_hash_tree_set(accum, scheme_false, v); + } + + if (!len) + return wrap_as_linklet_directory(accum); + + next = (Scheme_Hash_Tree *)SCHEME_CAR(stack); + stack = SCHEME_CDR(stack); + next = scheme_hash_tree_set(next, SCHEME_CAR(path), wrap_as_linklet_directory(accum)); + prev_len--; + accum = next; + } else { + MZ_ASSERT(len == prev_len + 1); + if (prev_len) + path = SCHEME_CDR(path); + next = scheme_make_hash_tree(0); + if (!SCHEME_FALSEP(v)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_linklet_bundle_type)); + next = scheme_hash_tree_set(next, scheme_false, v); + } + accum = scheme_hash_tree_set(accum, SCHEME_CAR(path), wrap_as_linklet_directory(next)); + } + + bundles = SCHEME_CDR(bundles); + if (SCHEME_NULLP(bundles)) + return NULL; + } } /* "#~" has been read */ static Scheme_Object *read_compiled(Scheme_Object *port, - Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, ReadParams *params) { - Scheme_Hash_Table *directory = NULL; + Scheme_Hash_Table *directory = NULL; /* position -> symbol-path */ + Scheme_Object *bundles = scheme_null; /* list of (cons symbol-path bundle-or-#f) */ + intptr_t bundle_pos; + int bundles_to_read = 0; Scheme_Object *result; - intptr_t size, shared_size, got, offset, directory_count = 0; + intptr_t size, shared_size, got, offset; CPort *rp; intptr_t symtabsize; Scheme_Object **symtab; @@ -5791,6 +3740,8 @@ static Scheme_Object *read_compiled(Scheme_Object *port, char hash_code[20]; while (1) { + bundle_pos = SCHEME_INT_VAL(scheme_file_position(1, &port)) - 2; /* -2 for "#~" */ + /* Check version: */ size = scheme_get_byte(port); { @@ -5804,7 +3755,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port, if (!params->skip_zo_vers_check) if (strcmp(buf, MZSCHEME_VERSION)) - scheme_read_err(port, stxsrc, line, col, pos, got, 0, NULL, + scheme_read_err(port, "read (compiled): wrong version for compiled code\n" " compiled version: %s\n" " expected version: %s", @@ -5813,16 +3764,17 @@ static Scheme_Object *read_compiled(Scheme_Object *port, mode = scheme_get_byte(port); if (mode == 'D') { - /* a module with submodules, starting with a directory */ + /* a linklet directory */ if (directory) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found multi-module directory after directory"); + scheme_read_err(port, + "read (compiled): found unexpected linklet directory nesting"); (void)read_simple_number_from_port(port); /* count */ directory = scheme_make_hash_table_equal(); - read_module_directory(port, directory, 0); - } else if (mode == 'T') { + read_linklet_directory(port, directory, 0, bundle_pos); + bundles_to_read = directory->count; + } else if (mode == 'B') { /* single module or other top-level form */ - + /* Allow delays? */ if (params->delay_load_info) { delay_info = MALLOC_ONE_RT(Scheme_Load_Delay); @@ -5845,12 +3797,12 @@ static Scheme_Object *read_compiled(Scheme_Object *port, so = (intptr_t *)scheme_malloc_fail_ok(scheme_malloc_atomic, scheme_check_overflow(symtabsize, sizeof(intptr_t), 0)); if (!so) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): could not allocate symbol table of size %" PRIdPTR, symtabsize); if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0)) != ((all_short ? 2 : 4) * (symtabsize - 1))) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): ill-formed code (bad table count: %" PRIdPTR " != %" PRIdPTR ")", got, (all_short ? 2 : 4) * (symtabsize - 1)); { @@ -5878,7 +3830,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port, size = read_simple_number_from_port(port); if (shared_size >= size) { - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): ill-formed code (shared size %ld >= total size %ld)", shared_size, size); } @@ -5900,7 +3852,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port, rp->orig_port = port; rp->size = size; if ((got = scheme_get_bytes(port, size, (char *)rp->start, 0)) != size) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "read (compiled): ill-formed code (bad count: %ld != %ld" ", started at %ld)", got, size, rp->base); @@ -5928,9 +3880,6 @@ static Scheme_Object *read_compiled(Scheme_Object *port, dir = scheme_path_to_directory_path(dir); rp->relto = dir; - rp->magic_sym = params->magic_sym; - rp->magic_val = params->magic_val; - install_byecode_hash_code(rp, hash_code); rp->shared_offsets = so; @@ -5981,29 +3930,33 @@ static Scheme_Object *read_compiled(Scheme_Object *port, } /* Read main body: */ - result = read_marshalled(scheme_compilation_top_type, rp); + result = read_compact(rp, 1); if (delay_info) if (delay_info->ut) delay_info->ut->rp = NULL; /* clean up */ - if (*local_ht) { - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): ill-formed code (unexpected graph structure)"); - return NULL; - } + if (*local_ht) + scheme_read_err(port, "read (compiled): unexpected graph structure"); - if (SAME_TYPE(SCHEME_TYPE(result), scheme_compilation_top_type)) { - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)result; + if (!SCHEME_HASHTRP(result)) + scheme_read_err(port, "read (compiled): bundle content is not an immutable hash"); - scheme_validate_code(rp, top->code, - top->max_let_depth, - top->prefix->num_toplevels, - top->prefix->num_stxes, - top->prefix->num_lifts, - NULL, - NULL, - 0); + { + mzlonglong i; + Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)result; + Scheme_Object *key, *val; + + if (!scheme_starting_up) { + i = scheme_hash_tree_next(t, -1); + while (i != -1) { + scheme_hash_tree_index(t, i, &key, &val); + if (SAME_TYPE(SCHEME_TYPE(val), scheme_linklet_type)) + scheme_validate_linklet(rp, (Scheme_Linklet *)val); + i = scheme_hash_tree_next(t, i); + } + } + /* If no exception, the resulting code is ok. */ /* Install module hash code, if any. This code is used to register @@ -6016,90 +3969,114 @@ static Scheme_Object *read_compiled(Scheme_Object *port, } if (i < 20) { - Scheme_Module *m; - m = scheme_extract_compiled_module(result); - if (m) { - Scheme_Object *hc; - hc = scheme_make_sized_byte_string(hash_code, 20, 1); - hc = scheme_make_pair(hc, dir); - - m->code_key = hc; - } + result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, + hash_code_symbol, + scheme_make_sized_byte_string(hash_code, 20, 1)); } } - } else - scheme_ill_formed_code(rp); - - if (directory) { - Scheme_Module *m, *m2; - Scheme_Object *v; - m = scheme_extract_compiled_module(result); - if (m) { - v = scheme_hash_get(directory, m->submodule_path); - if (v && (SCHEME_NULLP(v) || SCHEME_PAIRP(v))) { - directory_count++; - v = scheme_reverse(v); - m->pre_submodules = v; - scheme_hash_set(directory, m->submodule_path, result); - if (!SCHEME_NULLP(m->submodule_path)) { - /* find parent: */ - v = scheme_reverse(m->submodule_path); - v = scheme_reverse(SCHEME_CDR(v)); - result = scheme_hash_get(directory, v); - if (!result) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): no parent module found in multi-module stream"); - if (SCHEME_NULLP(result) || SCHEME_PAIRP(result)) { - /* this is a pre-submodule */ - result = scheme_make_pair((Scheme_Object *)m, result); - scheme_hash_set(directory, v, result); - } else { - /* this is a post-submodule */ - m2 = scheme_extract_compiled_module(result); - v = m2->post_submodules ? m2->post_submodules : scheme_null; - v = scheme_make_pair((Scheme_Object *)m, v); - m2->post_submodules = v; - } - } - if (directory->count == directory_count) { - /* need to reverse post-submodule lists in all modules: */ - int i; - for (i = 0; i < directory->size; i++) { - if (directory->vals[i]) { - m = scheme_extract_compiled_module(directory->vals[i]); - if (m->post_submodules) { - v = scheme_reverse(m->post_submodules); - m->post_submodules = v; - } - } - } + } - /* return the root module: */ - return scheme_hash_get(directory, scheme_null); - } - /* otherwise, keep reading modules */ - } else - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found unrecognized or duplicate module after multi-module directory: %V", - m->submodule_path); - } else - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found non-module code after multi-module directory"); + if (!directory) { + /* Since we're loading an individual bundle, strip submodule references */ + result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, pre_symbol, NULL); + result = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)result, post_symbol, NULL); + } + + { + Scheme_Object *v; + v = scheme_alloc_small_object(); + v->type = scheme_linklet_bundle_type; + SCHEME_PTR_VAL(v) = result; + result = v; + } + + if (directory) { + Scheme_Object *v; + + /* Find bundle's symbol path by its starting position */ + v = scheme_hash_get(directory, scheme_make_integer(bundle_pos)); + if (!v) + scheme_read_err(port, "read (compiled): cannot match bundle position to linklet-directory path"); + + bundles = scheme_make_pair(scheme_make_pair(v, result), bundles); + bundles_to_read--; + + if (!bundles_to_read) { + /* convert flattened directory into hierarchical form */ + v = bundle_list_to_hierarchical_directory(bundles); + if (!v) + scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree"); + return v; + } + /* otherwise, continue reading bundles */ } else return result; } else { - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): found bad mode"); + scheme_read_err(port, "read (compiled): found bad mode"); + } + + + while (1) { + int c1, c2; + + c1 = scheme_get_byte(port); + c2 = scheme_get_byte(port); + + if ((c1 != '#') || ((c2 != '~') && (c2 != 'f'))) + scheme_read_err(port, + "read (compiled): no `#~' for next linklet (%d to go) in a linklet directory", + bundles_to_read); + + if (c2 == 'f') { + /* Got #f in place of a bundle */ + Scheme_Object *v; + + bundle_pos = SCHEME_INT_VAL(scheme_file_position(1, &port)) - 2; /* -2 for "#f" */ + v = scheme_hash_get(directory, scheme_make_integer(bundle_pos)); + if (!v) + scheme_read_err(port, "read (compiled): cannot match empty-bundle position to linklet-directory path"); + + bundles = scheme_make_pair(scheme_make_pair(v, scheme_false), bundles); + bundles_to_read--; + + if (!bundles_to_read) { + /* convert flattened directory into hierarchical form */ + v = bundle_list_to_hierarchical_directory(bundles); + if (!v) + scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree"); + return v; + } + } else { + /* continue outer loop to read next bundle */ + break; + } } - - - if ((scheme_get_byte(port) != '#') - || (scheme_get_byte(port) != '~')) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, - "read (compiled): no `#~' for next module in multi-module stream"); } } +Scheme_Object *scheme_read_compiled(Scheme_Object *port) +{ + Scheme_Config *config; + Scheme_Object *v, *v2; + ReadParams params; + + config = scheme_current_config(); + + params.skip_zo_vers_check = 0; + + v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + v2 = scheme_get_initial_inspector(); + params.can_read_unsafe = SAME_OBJ(v, v2); + + v = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO); + if (SCHEME_TRUEP(v)) + params.delay_load_info = v; + else + params.delay_load_info = NULL; + + return read_compiled(port, ¶ms); +} + THREAD_LOCAL_DECL(static Scheme_Load_Delay *clear_bytes_chain); @@ -6170,7 +4147,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in scheme_set_file_position(port, delay_info->file_offset); if ((got = scheme_get_bytes(port, size, (char *)st, 0)) != size) - scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL, + scheme_read_err(port, "on-demand load: ill-formed code (bad count: %ld != %ld" ", started at %ld)", got, size, 0); @@ -6224,9 +4201,6 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in rp->pos = delay_info->shared_offsets[which - 1]; - if (delay_info->ut) - prepare_current_unmarshal(delay_info->ut); - /* Perform the read, catching escapes so we can clean up: */ savebuf = scheme_current_thread->error_buf; scheme_current_thread->error_buf = &newbuf; @@ -6237,6 +4211,9 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in } else { v = read_compact(rp, 0); v_exn = NULL; + if (*ht) { + scheme_read_err(rp->orig_port, "read (compiled): unexpected graph structure"); + } } scheme_current_thread->error_buf = savebuf; scheme_current_thread->reading_delayed = NULL; @@ -6245,10 +4222,8 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in v = resolve_symtab_refs(v, rp); delay_info->current_rp = old_rp; - if (delay_info->ut) { + if (delay_info->ut) delay_info->ut->rp = old_rp; - complete_current_unmarshal(delay_info->ut); - } if (!old_rp && !delay_info->perma_cache) { /* No one using the cache, to register it to be cleaned up */ @@ -6261,17 +4236,10 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in scheme_end_atomic_no_swap(); if (v) { - if (*ht) { - v = resolve_references(v, port, NULL, - scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), - delay_info->symtab_entries, - 0, 0); - } - - delay_info->symtab[which] = v; - record_symtab_self_contained(delay_info->symtab_entries, v); - + /* Although `which` is a symbol-table index for `v`, + we don't actually record v, because the delayed + reference is now complete (and we'd like to be + able to GC it if it's otherwise unused). */ return v; } else { if (v_exn && !scheme_current_thread->cjs.is_kill) @@ -6322,738 +4290,6 @@ void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, ut->decoded[l] = 1; } -/*========================================================================*/ -/* readtable support */ -/*========================================================================*/ - -Scheme_Object *scheme_make_default_readtable() -{ - return scheme_false; -} - -static int readtable_kind(Readtable *t, int ch, ReadParams *params) -{ - int k; - Scheme_Object *v; - - if (ch < 128) - k = t->fast_mapping[ch]; - else { - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - if (!v) { - if (scheme_isspace(ch)) - k = READTABLE_WHITESPACE; - else - k = READTABLE_CONTINUING; - } else - k = SCHEME_INT_VAL(SCHEME_CAR(v)); - } - - if (k == READTABLE_MAPPED) { - /* ch is mapped to a default behavior: */ - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - ch = SCHEME_INT_VAL(SCHEME_CDR(v)); - if (ch < 128) - k = builtin_fast[ch]; - else if (scheme_isspace(ch)) - k = READTABLE_WHITESPACE; - else - k = READTABLE_CONTINUING; - } - - if (k == READTABLE_MULTIPLE_ESCAPE) { - /* This is the only one sensitive to params. */ - if (!params->can_read_pipe_quote) - return READTABLE_CONTINUING; - } - - return k; -} - -static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, Scheme_Object *modpath_stx) -{ - int cnt, add_srcloc = 0; - Scheme_Object *a[7], *v; - Scheme_Cont_Frame_Data cframe; - - if (w_char) { - a[0] = scheme_make_character(ch); - a[1] = port; - a[2] = proc; - if (!src && scheme_check_proc_arity(NULL, 2, 2, 3, a)) { - cnt = 2; - } else { - cnt = 6; - a[2] = (src ? src : scheme_false); - add_srcloc = 3; - } - } else { - if (src) { - a[0] = src; - a[1] = port; - if (modpath_stx) { - a[2] = modpath_stx; - add_srcloc = 3; - cnt = 6; - } else - cnt = 2; - } else { - a[0] = port; - if (modpath_stx) { - a[1] = modpath_stx; - add_srcloc = 2; - cnt = 5; - } else - cnt = 1; - } - } - - if (add_srcloc) { - a[add_srcloc + 0] = (line > 0) ? scheme_make_integer(line) : scheme_false; - a[add_srcloc + 1] = (col > 0) ? scheme_make_integer(col-1) : scheme_false; - a[add_srcloc + 2] = (pos > 0) ? scheme_make_integer(pos) : scheme_false; - } - - if (src) { - /* fresh ht in case nested uses recursive `read' instead of recursive `read-syntax': */ - ht = MALLOC_N(Scheme_Hash_Table *, 1); - } - - if (!get_info) { - scheme_push_continuation_frame(&cframe); - scheme_set_in_read_mark(src, ht); - } - - v = scheme_apply(proc, cnt, a); - - if (get_info) { - a[0] = v; - if (!scheme_check_proc_arity(NULL, 2, 0, 1, a)) { - scheme_wrong_contract("read-language", "(any/c any/c . -> . any)", -1, -1, a); - } - } - - if (!get_info) { - scheme_pop_continuation_frame(&cframe); - } - - if (!get_info && !scheme_special_comment_value(v)) { - if (SCHEME_STXP(v)) { - if (!src) - v = scheme_syntax_to_datum(v, 0, NULL); - } else if (src) { - Scheme_Object *s; - - if (*ht) { - /* resolve references from recursive `read': */ - v = resolve_references(v, port, NULL, - scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), - NULL, - 1, 0); - } - - s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), src, STX_SRCTAG); - v = scheme_datum_to_syntax(v, s, scheme_false, 1, 1); - } - - if (!src) - set_need_copy(ht); - } - - return v; -} - -void scheme_set_in_read_mark(Scheme_Object *src, Scheme_Hash_Table **ht) -{ - Scheme_Object *v; - - if (ht) - v = scheme_make_raw_pair((Scheme_Object *)ht, - (src ? scheme_true : scheme_false)); - else - v = scheme_false; - scheme_set_cont_mark(unresolved_uninterned_symbol, v); -} - -static Scheme_Object *readtable_handle(Readtable *t, int *_ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht) -{ - int ch = *_ch; - Scheme_Object *v; - - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - - if (!v) { - *_use_default = 1; - return NULL; - } - - if (SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED) { - *_ch = SCHEME_INT_VAL(SCHEME_CDR(v)); - *_use_default = 1; - return NULL; - } - - *_use_default = 0; - - v = SCHEME_CDR(v); - - v = readtable_call(1, ch, v, params, port, src, line, col, pos, 0, ht, NULL); - - return v; -} - -static int readtable_effective_char(Readtable *t, int ch) -{ - Scheme_Object *v; - - if (!t) return ch; - - v = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - - if (v) { - if (SCHEME_INT_VAL(SCHEME_CAR(v)) == READTABLE_MAPPED) - return SCHEME_INT_VAL(SCHEME_CDR(v)); - return 0; /* not equivalent to any standard char mapping */ - } else - return ch; -} - -static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_default, ReadParams *params, - Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht) -{ - Scheme_Object *v; - - v = scheme_hash_get(t->mapping, scheme_make_integer(-ch)); - - if (!v) { - *_use_default = 1; - return NULL; - } - - *_use_default = 0; - - v = readtable_call(1, ch, v, params, port, src, line, col, pos, 0, ht, NULL); - - if (scheme_special_comment_value(v)) - return NULL; - else - return v; -} - -static void check_proc_either_arity(const char *who, int a1, int a2, int which, int argc, Scheme_Object **argv) -{ - if (!scheme_check_proc_arity(NULL, a1, which, argc, argv) - && !scheme_check_proc_arity(NULL, a2, which, argc, argv)) { - char buffer[256]; - sprintf(buffer, "(or (procedure-arity-includes/c %d) (procedure-arity-includes/c %d))", a1, a2); - scheme_wrong_contract(who, buffer, which, argc, argv); - } -} - -static Scheme_Object *make_readtable(int argc, Scheme_Object **argv) -{ - Scheme_Object *sym, *val; - Readtable *t, *orig_t; - Scheme_Hash_Table *ht; - char *fast; - int i, ch; - - if (SCHEME_FALSEP(argv[0])) - orig_t = NULL; - else { - if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0]))) { - scheme_wrong_contract("make-readtable", "(or/c readtable? #f)", 0, argc, argv); - return NULL; - } - orig_t = (Readtable *)argv[0]; - } - - t = MALLOC_ONE_TAGGED(Readtable); - t->so.type = scheme_readtable_type; - if (orig_t) - ht = scheme_clone_hash_table(orig_t->mapping); - else - ht = scheme_make_hash_table(SCHEME_hash_ptr); - t->mapping = ht; - fast = scheme_malloc_atomic(128); - memcpy(fast, (orig_t ? orig_t->fast_mapping : builtin_fast), 128); - t->fast_mapping = fast; - t->symbol_parser = (orig_t ? orig_t->symbol_parser : NULL); - - for (i = 1; i < argc; i += 3) { - if (!SCHEME_FALSEP(argv[i]) && !SCHEME_CHARP(argv[i])) { - scheme_wrong_contract("make-readtable", "(or/c char? #f)", i, argc, argv); - return NULL; - } - - if (i + 1 >= argc) { - if (SCHEME_FALSEP(argv[i])) - scheme_contract_error("make-readtable", - "expected 'non-terminating-macro after #f", - NULL); - else - scheme_contract_error("make-readtable", - "expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro," - " or character argument after character argument", - "character", 1, argv[i], - NULL); - } - - sym = argv[i + 1]; - if (!SAME_OBJ(sym, terminating_macro_symbol) - && !SAME_OBJ(sym, non_terminating_macro_symbol) - && !SAME_OBJ(sym, dispatch_macro_symbol) - && !SCHEME_CHARP(sym)) { - scheme_wrong_contract("make-readtable", - "(or/c 'terminating-macro 'non-terminating-macro 'dispatch-macro char?)", - i+1, argc, argv); - return NULL; - } - if (SCHEME_FALSEP(argv[i]) - && !SAME_OBJ(sym, non_terminating_macro_symbol)) { - scheme_contract_error("make-readtable", - "expected 'non-terminating-macro after #f", - "given", 1, sym, - NULL); - } - - if (i + 2 >= argc) { - scheme_contract_error("make-readtable", - (SCHEME_CHARP(sym) - ? "expected readtable or #f argument after character argument" - : "expected procedure argument after symbol argument"), - "given", 1, argv[i+1], - NULL); - } - - if (SCHEME_FALSEP(argv[i])) { - check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv); - t->symbol_parser = argv[i + 2]; - } else if (SAME_OBJ(sym, dispatch_macro_symbol)) { - ch = SCHEME_CHAR_VAL(argv[i]); - check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv); - scheme_hash_set(t->mapping, scheme_make_integer(-ch), argv[i+2]); - } else { - if (SCHEME_CHARP(sym)) { - Readtable *src; - int sch; - - if (SCHEME_FALSEP(argv[i+2])) { - src = NULL; - } else { - if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[i+2]))) { - scheme_wrong_contract("make-readtable", "(or/c readtable? #f)", i+2, argc, argv); - return NULL; - } - src = (Readtable *)(argv[i+2]); - } - sch = SCHEME_CHAR_VAL(argv[i+1]); - if (!src) - val = NULL; /* use default */ - else - val = scheme_hash_get(src->mapping, scheme_make_integer(sch)); - if (!val) - val = scheme_make_pair(scheme_make_integer(READTABLE_MAPPED), scheme_make_integer(sch)); - } else { - int kind; - check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv); - kind = (SAME_OBJ(sym, non_terminating_macro_symbol) - ? READTABLE_CONTINUING - : READTABLE_TERMINATING); - val = scheme_make_pair(scheme_make_integer(kind), argv[i+2]); - } - - ch = SCHEME_CHAR_VAL(argv[i]); - if (!val) { - scheme_hash_set(t->mapping, scheme_make_integer(ch), NULL); - if (ch < 128) - t->fast_mapping[ch] = 0; - } else { - scheme_hash_set(t->mapping, scheme_make_integer(ch), val); - if (ch < 128) - t->fast_mapping[ch] = (char)SCHEME_INT_VAL(SCHEME_CAR(val)); - } - } - } - - return (Scheme_Object *)t; -} - -static Scheme_Object *readtable_mapping(int argc, Scheme_Object **argv) -{ - Scheme_Object *v1, *v2, *a[3]; - Readtable *t; - int ch; - - if (!SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0]))) { - scheme_wrong_contract("readtable-mapping", "readtable?", 0, argc, argv); - return NULL; - } - if (!SCHEME_CHARP(argv[1])) { - scheme_wrong_contract("readtable-mapping", "character?", 1, argc, argv); - return NULL; - } - - t = (Readtable *)argv[0]; - ch = SCHEME_CHAR_VAL(argv[1]); - - v1 = scheme_hash_get(t->mapping, scheme_make_integer(ch)); - v2 = scheme_hash_get(t->mapping, scheme_make_integer(-ch)); - - a[0] = argv[1]; - a[1] = scheme_false; - if (v1) { - int v; - v = SCHEME_INT_VAL(SCHEME_CAR(v1)); - if (v & READTABLE_MAPPED) { - v = SCHEME_INT_VAL(SCHEME_CDR(v1)); - a[0] = scheme_make_character(v); - a[1] = scheme_false; - } else if (v & READTABLE_CONTINUING) { - a[0] = non_terminating_macro_symbol; - a[1] = SCHEME_CDR(v1); - } else if (v & READTABLE_TERMINATING) { - a[0] = terminating_macro_symbol; - a[1] = SCHEME_CDR(v1); - } - } - a[2] = scheme_false; - if (v2) { - a[2] = v2; - } - - return scheme_values(3, a); -} - -static Scheme_Object *readtable_p(int argc, Scheme_Object **argv) -{ - return (SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(argv[0])) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *readtable_or_false_p(int argc, Scheme_Object **argv) -{ - if (SCHEME_FALSEP(argv[0])) - return scheme_true; - return readtable_p(argc, argv); -} - -static Scheme_Object *current_readtable(int argc, Scheme_Object **argv) -{ - return scheme_param_config2("current-readtable", - scheme_make_integer(MZCONFIG_READTABLE), - argc, argv, - -1, readtable_or_false_p, "readtable?", 0); -} - -static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv) -{ - return scheme_param_config2("current-reader-guard", - scheme_make_integer(MZCONFIG_READER_GUARD), - argc, argv, - 1, NULL, NULL, 0); -} - -static Scheme_Object *no_val_thunk(void *d, int argc, Scheme_Object **argv) -{ - return (Scheme_Object *)d; -} - -static Scheme_Object *do_reader(Scheme_Object *try_modpath, - Scheme_Object *modpath_stx, - Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) -{ - Scheme_Object *modpath, *name, *a[3], *proc, *v, *no_val; - int num_a; - Scheme_Env *env; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - int pop_frame; - - if (stxsrc) - modpath = scheme_syntax_to_datum(modpath_stx, 0, NULL); - else - modpath = modpath_stx; - - proc = scheme_get_param(scheme_current_config(), MZCONFIG_READER_GUARD); - - if (try_modpath) { - a[0] = try_modpath; - try_modpath = scheme_apply(proc, 1, a); - - if (scheme_module_is_declared(try_modpath, 1)) - modpath = try_modpath; - else - try_modpath = NULL; - } - - if (!try_modpath) { - a[0] = modpath; - modpath = scheme_apply(proc, 1, a); - } - - a[0] = modpath; - if (get_info) - name = scheme_intern_symbol("get-info"); - else if (stxsrc) - name = scheme_intern_symbol("read-syntax"); - else - name = scheme_intern_symbol("read"); - a[1] = name; - if (get_info) { - no_val = scheme_make_pair(scheme_false, scheme_false); - a[2] = scheme_make_closed_prim(no_val_thunk, no_val); - num_a = 3; - } else { - no_val = NULL; - num_a = 2; - } - - if (get_info) - pop_frame = 0; - else { - config = scheme_current_config(); - env = scheme_get_env(config); - - if (env->reader_env) { - config = scheme_extend_config(config, - MZCONFIG_ENV, - (Scheme_Object *)env->reader_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - pop_frame = 1; - } else - pop_frame = 0; - } - - proc = scheme_dynamic_require(num_a, a); - if (get_info) { - proc = scheme_force_value(proc); - } - - if (get_info && SAME_OBJ(proc, no_val)) { - v = scheme_false; - } else { - a[0] = proc; - if (scheme_check_proc_arity(NULL, stxsrc ? 6 : 5, 0, 1, a)) { - /* provide modpath_stx to reader */ - } else if (!get_info && scheme_check_proc_arity(NULL, stxsrc ? 2 : 1, 0, 1, a)) { - /* don't provide modpath_stx to reader */ - modpath_stx = NULL; - } else { - scheme_wrong_contract("#reader", - (stxsrc ? "(or/c (any/c any/c . -> . any) (procedure-arity-includes/c 6))" - : (get_info - ? "(procedure-arity-includes/c 5)" - : "(or/c (any/c . -> . any) (procedure-arity-includes/c 5))")), - -1, -1, a); - return NULL; - } - - v = readtable_call(0, 0, proc, params, - port, stxsrc, line, col, pos, - get_info, ht, modpath_stx); - - if (!get_info && scheme_special_comment_value(v)) - v = NULL; - } - - if (pop_frame) - scheme_pop_continuation_frame(&cframe); - - return v; -} - -/* "#reader" has been read */ -static Scheme_Object *read_reader(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params) -{ - Scheme_Object *modpath; - - if (stxsrc) - modpath = scheme_read_syntax(port, stxsrc); - else - modpath = scheme_read(port); - - if (SCHEME_EOFP(modpath)) { - scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation, - "read: expected a datum after #reader, found end-of-file"); - return NULL; - } - - return do_reader(NULL, modpath, port, stxsrc, line, col, pos, 0, ht, indentation, params); -} - -/* "#lang " has been read */ -static Scheme_Object *read_lang(Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - int get_info, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, - int init_ch) -{ - int size, len; - GC_CAN_IGNORE char *sfx; - char *buf, *naya; - int ch = 0; - Scheme_Object *modpath, *subm_modpath; - intptr_t name_line = -1, name_col = -1, name_pos = -1; - - size = 32; - buf = MALLOC_N_ATOMIC(char, size); - len = 0; - - if (init_ch) { - ch = init_ch; - } else { - ch = scheme_getc_special_ok(port); - } - scheme_tell_all(port, &name_line, &name_col, &name_pos); - - while (1) { - /* ch was only peeked at this point (except for the first iteration), so we - can leave the input immediately after the language spec */ - if (ch == EOF) { - break; - } else if (ch == SCHEME_SPECIAL) { - ch = scheme_getc_special_ok(port); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: found non-character while reading `#lang'"); - } else if (scheme_isspace(ch)) { - break; - } else { - if (len) ch = scheme_getc_special_ok(port); - if ((ch < 128) - && (is_lang_nonsep_char(ch) - || (ch == '/'))) { - if (len + 1 >= size) { - size *= 2; - naya = MALLOC_N_ATOMIC(char, size); - memcpy(naya, buf, len * sizeof(char)); - buf = naya; - } - buf[len++] = ch; - } else { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: expected only alphanumeric, `-', `+', `_', or `/'" - " characters for `#%s', found %c", - init_ch ? "!" : "lang", - ch); - return NULL; - } - } - ch = scheme_peekc_special_ok(port); - } - - if (!len) { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - (((ch == ' ') && !init_ch) - ? "read: expected a single space after `#lang'" - : "read: expected a non-empty sequence of alphanumeric, `-', `+', `_', or `/' after `#%s'"), - init_ch ? "!" : "lang "); - return NULL; - } - if (buf[0] == '/') { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: expected a name that does not start `/' after `#lang'"); - return NULL; - } - if (buf[len - 1] == '/') { - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, - "read: expected a name that does not end `/' after `#%s'", - init_ch ? "!" : "lang"); - return NULL; - } - - if (len + 16 >= size) { - size += 16; - naya = MALLOC_N_ATOMIC(char, size * sizeof(char)); - memcpy(naya, buf, len * sizeof(char)); - buf = naya; - } - buf[len] = 0; - subm_modpath = scheme_intern_symbol(buf); - - sfx = "/lang/reader"; - while (*sfx) { - buf[len++] = *(sfx++); - } - buf[len] = 0; - - modpath = scheme_intern_symbol(buf); - if (stxsrc) { - intptr_t span; - span = SPAN(port, name_pos); - modpath = scheme_make_stx_w_offset(modpath, name_line, name_col, name_pos, - span, - stxsrc, STX_SRCTAG); - } - - subm_modpath = scheme_make_pair(scheme_intern_symbol("submod"), - scheme_make_pair(subm_modpath, - scheme_make_pair(scheme_intern_symbol("reader"), - scheme_null))); - - return do_reader(subm_modpath, modpath, port, stxsrc, line, col, pos, get_info, ht, indentation, params); -} - -Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok) -{ - return _internal_read(port, NULL, 0, 0, 0, 0, -1, - NULL, NULL, NULL, NULL, nonlang_ok ? 2 : 1); -} - -static Scheme_Object *expected_lang(const char *prefix, int ch, - Scheme_Object *port, Scheme_Object *stxsrc, - intptr_t line, intptr_t col, intptr_t pos, - int get_lang) -{ - if (get_lang > 1) { - return scheme_void; - } else { - mzchar chs[2]; - char *more; - - chs[0] = 0; - chs[1] = 0; - - if (ch == EOF) - more = "an end-of-file"; - else if (ch == SCHEME_SPECIAL) - more = "a non-character"; - else { - chs[0] = ch; - more = ""; - } - - scheme_read_err(port, stxsrc, line, col, pos, 1, ch, NULL, - "read-language: expected (after whitespace and comments)" - " `#lang ' or `#!' followed" - " immediately by a language name, found %s%s%5%s%s%s", - (*prefix || *chs) ? "`" : "", - prefix, chs, - (*prefix || *chs) ? "`" : "", - ((*prefix || *chs) && *more) ? " followed by " : "", - more); - - return NULL; - } -} - /*========================================================================*/ /* precise GC traversers g*/ /*========================================================================*/ @@ -7068,7 +4304,6 @@ static void register_traversers(void) { GC_REG_TRAV(scheme_indent_type, mark_indent); GC_REG_TRAV(scheme_rt_compact_port, mark_cport); - GC_REG_TRAV(scheme_readtable_type, mark_readtable); GC_REG_TRAV(scheme_rt_read_params, mark_read_params); GC_REG_TRAV(scheme_rt_delay_load_info, mark_delay_load); GC_REG_TRAV(scheme_rt_unmarshal_info, mark_unmarshal_tables); diff --git a/racket/src/racket/src/read_vector.inc b/racket/src/racket/src/read_vector.inc deleted file mode 100644 index 52d1d1c1b3..0000000000 --- a/racket/src/racket/src/read_vector.inc +++ /dev/null @@ -1,97 +0,0 @@ -/* "#(" has been read */ -/* or "#fl(" has been read */ -/* or "#fx(" has been read */ -static Scheme_Object * -FUNC_NAME (Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - int opener, char closer, - intptr_t requestLength, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, - ReadParams *params, Readtable *table, - int allow_infix) -/* requestLength == -1 => no request - requestLength == -2 => overflow */ -{ - Scheme_Object *lresult, *obj; - VEC_TYPE *vec; - ELMS_TYPE els; - ELM_TYPE elm; - int len, i; - char *vtype_str; - - vtype_str = VTYPE_STR; - - lresult = read_list(port, stxsrc, line, col, pos, opener, closer, - MZ_SHAPE, - 1, ht, indentation, params, table); - - if (requestLength == -2) { - scheme_raise_out_of_memory("read", "making %s of size %5", vtype_str, reqBuffer); - return NULL; - } - - if (stxsrc) - obj = ((Scheme_Stx *)lresult)->val; - else - obj = lresult; - - len = scheme_list_length(obj); - if (requestLength >= 0 && len > requestLength) { - char buffer[20]; - sprintf(buffer, "%" PRIdPTR, requestLength); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: %s length %ld is too small, " - "%d values provided", - vtype_str, requestLength, len); - return NULL; - } - if (requestLength < 0) - requestLength = len; - - vec = MK_VEC(); - els = ELMS_SELECTOR(vec); - for (i = 0; i < len ; i++) { - els[i] = ELM_SELECTOR(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - } - els = NULL; - if (i < requestLength) { - if (len) - elm = ELMS_SELECTOR(vec)[len - 1]; - else { - elm = ELM_MAKE_ZERO; - if (stxsrc) - elm = ELM_STX(elm); - } - - els = ELMS_SELECTOR(vec); - for (; i < requestLength; i++) { - els[i] = elm; - } - els = NULL; - } - - if (stxsrc) { - if (VEC_SIZE(vec) > 0) - SCHEME_SET_VECTOR_IMMUTABLE(vec); - ((Scheme_Stx *)lresult)->val = (Scheme_Object *) vec; - return lresult; - } else - return (Scheme_Object *) vec; -} -#undef FUNC_NAME -#undef VTYPE_STR -#undef VEC_TYPE -#undef ELMS_TYPE -#undef ELM_TYPE -#undef MZ_SHAPE -#undef MK_VEC -#undef ELMS_SELECTOR -#undef ELM_SELECTOR -#undef ELM_MAKE_ZERO -#undef ELM_STX -#undef VEC_SIZE - -/* vim: ft=c -*/ diff --git a/racket/src/racket/src/regexp.c b/racket/src/racket/src/regexp.c index a31f39c760..6d2fd22a11 100644 --- a/racket/src/racket/src/regexp.c +++ b/racket/src/racket/src/regexp.c @@ -6032,7 +6032,7 @@ START_XFORM_SKIP; END_XFORM_SKIP; #endif -void scheme_regexp_initialize(Scheme_Env *env) +void scheme_regexp_initialize(Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC GC_REG_TRAV(scheme_regexp_type, mark_regexp); @@ -6043,30 +6043,30 @@ void scheme_regexp_initialize(Scheme_Env *env) REGISTER_SO(empty_byte_string); empty_byte_string = scheme_alloc_byte_string(0, 0); - GLOBAL_PRIM_W_ARITY("byte-regexp", make_regexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("regexp", make_utf8_regexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("byte-pregexp", make_pregexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("pregexp", make_utf8_pregexp, 1, 2, env); - GLOBAL_PRIM_W_ARITY("regexp-match", compare, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match/end", compare_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-match-positions", positions, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-positions/end", positions_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-match?", compare_bool, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek", compare_peek, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions", positions_peek, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions/end", positions_peek_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-immediate", compare_peek_nonblock, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions-immediate", positions_peek_nonblock, 2, 6, env); - GLOBAL_PRIM_W_ARITY("regexp-match-peek-positions-immediate/end", positions_peek_nonblock_end, 2, 7, env); - GLOBAL_PRIM_W_ARITY("regexp-replace", replace, 3, 4, env); - GLOBAL_PRIM_W_ARITY("regexp-replace*", replace_star, 3, 4, env); + ADD_PRIM_W_ARITY("byte-regexp", make_regexp, 1, 2, env); + ADD_PRIM_W_ARITY("regexp", make_utf8_regexp, 1, 2, env); + ADD_PRIM_W_ARITY("byte-pregexp", make_pregexp, 1, 2, env); + ADD_PRIM_W_ARITY("pregexp", make_utf8_pregexp, 1, 2, env); + ADD_PRIM_W_ARITY("regexp-match", compare, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match/end", compare_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-match-positions", positions, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-positions/end", positions_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-match?", compare_bool, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek", compare_peek, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions", positions_peek, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions/end", positions_peek_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-match-peek-immediate", compare_peek_nonblock, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions-immediate", positions_peek_nonblock, 2, 6, env); + ADD_PRIM_W_ARITY("regexp-match-peek-positions-immediate/end", positions_peek_nonblock_end, 2, 7, env); + ADD_PRIM_W_ARITY("regexp-replace", replace, 3, 4, env); + ADD_PRIM_W_ARITY("regexp-replace*", replace_star, 3, 4, env); - GLOBAL_FOLDING_PRIM("regexp?", regexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("byte-regexp?", byte_regexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("pregexp?", pregexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("byte-pregexp?", byte_pregexp_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("regexp?", regexp_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("byte-regexp?", byte_regexp_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("pregexp?", pregexp_p, 1, 1, 1, env); + ADD_FOLDING_PRIM("byte-pregexp?", byte_pregexp_p, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("regexp-max-lookbehind", regexp_lookbehind, 1, 1, 1, env); + ADD_FOLDING_PRIM("regexp-max-lookbehind", regexp_lookbehind, 1, 1, 1, env); } void scheme_init_regexp_places() diff --git a/racket/src/racket/src/resolve.c b/racket/src/racket/src/resolve.c index 2016ba4dd3..4bd31ffac6 100644 --- a/racket/src/racket/src/resolve.c +++ b/racket/src/racket/src/resolve.c @@ -44,7 +44,7 @@ struct Resolve_Info { MZTAG_IF_REQUIRED - char use_jit, in_module, in_proc, enforce_const, no_lift; + char in_module, in_proc, enforce_const, no_lift, need_instance_access; int current_depth; /* tracks the stack depth, so variables can be resolved relative to it; this depth is reset on entry to `lambda` forms */ @@ -53,25 +53,46 @@ struct Resolve_Info for sorting */ int max_let_depth; /* filled in by sub-expressions to track the maximum stack depth experienced so far */ - Resolve_Prefix *prefix; - Scheme_Hash_Table *stx_map; /* compile offset => resolve offset; prunes prefix-recored stxes */ + Scheme_Linklet *linklet; mzshort toplevel_pos; /* tracks where the run-time prefix will be, relative to the current stack depth */ void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */ - int stx_count; /* tracks the number of literal syntax objects used */ + struct Resolve_Info *top; /* for merging tl_map from lifted uses */ + Scheme_Hash_Tree *redirects; /* maps variables that will be from the closure to their stack depths for the enclosing `lambda` */ Scheme_Object *lifts; /* tracks functions lifted by closure conversion */ struct Resolve_Info *next; + + int num_toplevels; /* number of toplevels, initially, in `linklet`, + taking into account that some imports may be + dropped; lifting adds more */ + int *toplevel_starts; /* position within toplevels array where an + import instance or set of definitions + starts; add 1 to an import instance + position, and use 0 for definitions (which, + both cases, corresponds to adding 1 to + `instance_pos` in an + `Scheme_IR_Topelevel`). */ + int *toplevel_deltas; /* shifts for toplevels in the import range to + accomodate removals */ + + Scheme_Hash_Table *toplevel_defns; /* for pruning unused definitions, if + some definitions are unexported + resolved position -> definition + definition -> #f - not yet used + #t - enqueued + list - resolved with lifts + NULL - used or has side effect */ }; #define cons(a,b) scheme_make_pair(a,b) -static Scheme_Object * -resolve_lambda(Scheme_Object *_lam, Resolve_Info *info, - int can_lift, int convert, int just_compute_lift, - Scheme_Object *precomputed_lift); +static Scheme_Object *resolve_expr(Scheme_Object *expr, Resolve_Info *info); +static Scheme_Object *resolve_lambda(Scheme_Object *_lam, Resolve_Info *info, + int can_lift, int convert, int just_compute_lift, + Scheme_Object *precomputed_lift); static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambda); static void resolve_info_add_mapping(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object *v); static int resolve_info_lookup(Resolve_Info *resolve, Scheme_IR_Local *var, Scheme_Object **lifted, @@ -79,10 +100,9 @@ static int resolve_info_lookup(Resolve_Info *resolve, Scheme_IR_Local *var, Sche static Scheme_Object *resolve_info_lift_added(Resolve_Info *resolve, Scheme_Object *var, int convert_shift); static void resolve_info_set_toplevel_pos(Resolve_Info *info, int pos); static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info); +static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info); static Scheme_Object *resolve_generate_stub_lift(void); static int resolve_toplevel_pos(Resolve_Info *info); -static int resolve_quote_syntax_offset(int i, Resolve_Info *info); -static int resolve_quote_syntax_pos(Resolve_Info *info); static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready); static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info); static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl); @@ -92,6 +112,13 @@ static int is_nonconstant_procedure(Scheme_Object *lam, Resolve_Info *info, Sche static int resolve_is_inside_proc(Resolve_Info *info); static int resolve_has_toplevel(Resolve_Info *info); static void set_tl_pos_used(Resolve_Info *info, int pos); +static Scheme_Object *generate_lifted_name(Scheme_Hash_Table *used_names, int search_start); +static void enable_expression_resolve_lifts(Resolve_Info *ri); +static void extend_linklet_defns(Scheme_Linklet *linklet, int num_lifts); +static void prune_unused_imports(Scheme_Linklet *linklet); +static void prepare_definition_queue(Scheme_Linklet *linklet, Resolve_Info *rslv); +static void remove_definition_names(Scheme_Object *defn, Scheme_Linklet *linklet); +static Resolve_Info *resolve_info_create(Scheme_Linklet *rp, int enforce_const); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -232,7 +259,7 @@ static Scheme_Object *resolve_application(Scheme_Object *o, Resolve_Info *orig_i if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->args[i], info); + le = resolve_expr(app->args[i], info); app->args[i] = le; } } @@ -315,13 +342,13 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_ info = resolve_info_extend(orig_info, 1, 0); if (!already_resolved_arg_count) { - le = scheme_resolve_expr(app->rator, info); + le = resolve_expr(app->rator, info); app->rator = le; } else already_resolved_arg_count--; if (!already_resolved_arg_count) { - le = scheme_resolve_expr(app->rand, info); + le = resolve_expr(app->rand, info); app->rand = le; } else already_resolved_arg_count--; @@ -422,21 +449,21 @@ static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_ if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->rator, info); + le = resolve_expr(app->rator, info); app->rator = le; } if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->rand1, info); + le = resolve_expr(app->rand1, info); app->rand1 = le; } if (already_resolved_arg_count) { already_resolved_arg_count--; } else { - le = scheme_resolve_expr(app->rand2, info); + le = resolve_expr(app->rand2, info); app->rand2 = le; } @@ -469,9 +496,9 @@ static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info) b = (Scheme_Branch_Rec *)o; - t = scheme_resolve_expr(b->test, info); - tb = scheme_resolve_expr(b->tbranch, info); - fb = scheme_resolve_expr(b->fbranch, info); + t = resolve_expr(b->test, info); + tb = resolve_expr(b->tbranch, info); + fb = resolve_expr(b->fbranch, info); b->test = t; b->tbranch = tb; @@ -485,9 +512,9 @@ static Scheme_Object *resolve_wcm(Scheme_Object *o, Resolve_Info *info) Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - k = scheme_resolve_expr(wcm->key, info); - v = scheme_resolve_expr(wcm->val, info); - b = scheme_resolve_expr(wcm->body, info); + k = resolve_expr(wcm->key, info); + v = resolve_expr(wcm->val, info); + b = resolve_expr(wcm->body, info); wcm->key = k; wcm->val = v; wcm->body = b; @@ -562,7 +589,7 @@ static Scheme_Object *resolve_sequence(Scheme_Object *o, Resolve_Info *info) for (i = s->count; i--; ) { Scheme_Object *le; - le = scheme_resolve_expr(s->array[i], info); + le = resolve_expr(s->array[i], info); s->array[i] = le; } @@ -576,50 +603,37 @@ static Scheme_Object *resolve_sequence(Scheme_Object *o, Resolve_Info *info) static Scheme_Object * define_values_resolve(Scheme_Object *data, Resolve_Info *rslv) { - intptr_t cnt = 0; - Scheme_Object *vars = SCHEME_VEC_ELS(data)[0], *l, *a; - Scheme_Object *val = SCHEME_VEC_ELS(data)[1], *vec; + intptr_t i, cnt = SCHEME_DEFN_VAR_COUNT(data); + Scheme_Object *val, *a; + Scheme_IR_Toplevel *var; - /* If this is a module-level definition: for each variable, if the - defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then + /* If a defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then resolve to a top-level reference with SCHEME_TOPLEVEL_SEAL, so - that we know to set GLOS_IS_IMMUTATED at run time. */ - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (rslv->in_module - && rslv->enforce_const - && (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) { + that we know to set GLOB_IS_IMMUTATED at run time. */ + + for (i = 0; i < cnt; i++) { + var = SCHEME_DEFN_VAR(data, i); + a = resolve_toplevel(rslv, (Scheme_Object *)var, 0); + if (rslv->enforce_const + && (!(SCHEME_IR_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_MUTATED))) a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_SEAL); - } - a = resolve_toplevel(rslv, a, 0); - SCHEME_CAR(l) = a; - cnt++; + SCHEME_DEFN_VAR_(data, i) = a; } - vec = scheme_make_vector(cnt + 1, NULL); - cnt = 1; - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - SCHEME_VEC_ELS(vec)[cnt++] = SCHEME_CAR(l); - } + val = resolve_expr(SCHEME_DEFN_RHS(data), rslv); + SCHEME_DEFN_RHS(data) = val; - val = scheme_resolve_expr(val, rslv); - SCHEME_VEC_ELS(vec)[0] = val; - - vec->type = scheme_define_values_type; - return vec; + return data; } static void resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs) { Scheme_Object *decl, *vec, *pr; - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = rhs; - SCHEME_VEC_ELS(vec)[1] = var; - - vec->type = scheme_define_values_type; - - decl = vec; + decl = scheme_make_vector(2, NULL); + decl->type = scheme_define_values_type; + SCHEME_DEFN_RHS(decl) = rhs; + SCHEME_DEFN_VAR_(decl, 0) = var; vec = info->lifts; pr = cons(decl, SCHEME_VEC_ELS(vec)[0]); @@ -633,7 +647,7 @@ inline_variant_resolve(Scheme_Object *data, Resolve_Info *rslv) char no_lift; a = SCHEME_VEC_ELS(data)[0]; - a = scheme_resolve_expr(a, rslv); + a = resolve_expr(a, rslv); SCHEME_VEC_ELS(data)[0] = a; /* Don't lift closures in the inline variant, since that @@ -642,7 +656,7 @@ inline_variant_resolve(Scheme_Object *data, Resolve_Info *rslv) a = SCHEME_VEC_ELS(data)[1]; no_lift = rslv->no_lift; rslv->no_lift = 1; - a = scheme_resolve_expr(a, rslv); + a = resolve_expr(a, rslv); rslv->no_lift = no_lift; SCHEME_VEC_ELS(data)[1] = a; @@ -658,7 +672,7 @@ set_resolve(Scheme_Object *data, Resolve_Info *rslv) var = sb->var; val = sb->val; - val = scheme_resolve_expr(val, rslv); + val = resolve_expr(val, rslv); if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) { Scheme_Let_Value *lv; @@ -681,7 +695,7 @@ set_resolve(Scheme_Object *data, Resolve_Info *rslv) return (Scheme_Object *)lv; } - var = scheme_resolve_expr(var, rslv); + var = resolve_expr(var, rslv); sb->var = var; sb->val = val; @@ -694,22 +708,22 @@ ref_resolve(Scheme_Object *data, Resolve_Info *rslv) { Scheme_Object *v; - v = scheme_resolve_expr(SCHEME_PTR2_VAL(data), rslv); + v = resolve_expr(SCHEME_PTR2_VAL(data), rslv); SCHEME_PTR2_VAL(data) = v; v = SCHEME_PTR1_VAL(data); - if (SAME_OBJ(v, scheme_true) - || SAME_OBJ(v, scheme_false)) { + if (SCHEME_SYMBOLP(v) /* => primitive instance */ + || SAME_OBJ(v, scheme_false) /* => anonymous variable */ + || SAME_OBJ(v, scheme_true)) { /* simplified local */ if (SCHEME_TRUEP(v)) SCHEME_VARREF_FLAGS(data) |= 0x1; /* => constant */ - v = SCHEME_PTR2_VAL(data); } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_ir_local_type)) { - v = scheme_resolve_expr(v, rslv); + v = resolve_expr(v, rslv); if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)) SCHEME_VARREF_FLAGS(data) |= 0x1; /* because mutable would be unbox */ - v = SCHEME_PTR2_VAL(data); + v = scheme_true; } else - v = scheme_resolve_expr(v, rslv); + v = resolve_expr(v, rslv); SCHEME_PTR1_VAL(data) = v; return data; @@ -723,8 +737,8 @@ apply_values_resolve(Scheme_Object *data, Resolve_Info *rslv) f = SCHEME_PTR1_VAL(data); e = SCHEME_PTR2_VAL(data); - f = scheme_resolve_expr(f, rslv); - e = scheme_resolve_expr(e, rslv); + f = resolve_expr(f, rslv); + e = resolve_expr(e, rslv); SCHEME_PTR1_VAL(data) = f; SCHEME_PTR2_VAL(data) = e; @@ -747,10 +761,10 @@ with_immed_mark_resolve(Scheme_Object *data, Resolve_Info *orig_rslv) Scheme_IR_Local *var; Resolve_Info *rslv = orig_rslv; - e = scheme_resolve_expr(wcm->key, rslv); + e = resolve_expr(wcm->key, rslv); wcm->key = e; - e = scheme_resolve_expr(wcm->val, rslv); + e = resolve_expr(wcm->val, rslv); wcm->val = e; rslv = resolve_info_extend(rslv, 1, 0); @@ -760,7 +774,7 @@ with_immed_mark_resolve(Scheme_Object *data, Resolve_Info *orig_rslv) var->resolve.co_depth = rslv->current_depth; var->resolve.lex_depth = rslv->current_lex_depth; - e = scheme_resolve_expr(SCHEME_CDR(wcm->body), rslv); + e = resolve_expr(SCHEME_CDR(wcm->body), rslv); wcm->body = e; merge_resolve(orig_rslv, rslv); @@ -791,95 +805,6 @@ case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv) return expr; } -static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) -{ - Comp_Prefix *cp; - Resolve_Prefix *rp; - Scheme_Object *names, *val, *base_stack_depth, *dummy, *vec; - Resolve_Info *einfo; - int len; - - cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; - dummy = SCHEME_VEC_ELS(data)[1]; - names = SCHEME_VEC_ELS(data)[2]; - val = SCHEME_VEC_ELS(data)[3]; - - rp = scheme_resolve_prefix(1, cp, info->prefix->src_insp_desc); - - dummy = scheme_resolve_expr(dummy, info); - - einfo = scheme_resolve_info_create(rp); - - val = scheme_resolve_expr(val, einfo); - - rp = scheme_remap_prefix(rp, einfo); - - base_stack_depth = scheme_make_integer(einfo->max_let_depth); - - len = scheme_list_length(names); - - vec = scheme_make_vector(len + 4, NULL); - SCHEME_VEC_ELS(vec)[0] = val; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vec)[2] = base_stack_depth; - SCHEME_VEC_ELS(vec)[3] = dummy; - - len = 4; - while (SCHEME_PAIRP(names)) { - SCHEME_VEC_ELS(vec)[len++] = SCHEME_CAR(names); - names = SCHEME_CDR(names); - } - - vec->type = scheme_define_syntaxes_type; - - return vec; -} - -static Scheme_Object *define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) -{ - return do_define_syntaxes_resolve(data, info); -} - -static Scheme_Object *begin_for_syntax_resolve(Scheme_Object *data, Resolve_Info *info) -{ - Comp_Prefix *cp; - Resolve_Prefix *rp; - Scheme_Object *l, *p, *a, *base_stack_depth, *dummy, *vec; - Resolve_Info *einfo; - - cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; - dummy = SCHEME_VEC_ELS(data)[1]; - l = SCHEME_VEC_ELS(data)[2]; - - rp = scheme_resolve_prefix(1, cp, info->prefix->src_insp_desc); - - dummy = scheme_resolve_expr(dummy, info); - - einfo = scheme_resolve_info_create(rp); - - p = scheme_null; - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - a = scheme_resolve_expr(a, einfo); - p = scheme_make_pair(a, p); - l = SCHEME_CDR(l); - } - l = scheme_reverse(p); - - rp = scheme_remap_prefix(rp, einfo); - - base_stack_depth = scheme_make_integer(einfo->max_let_depth); - - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = l; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vec)[2] = base_stack_depth; - SCHEME_VEC_ELS(vec)[3] = dummy; - vec->type = scheme_begin_for_syntax_type; - - return vec; -} - /*========================================================================*/ /* let, let-values, letrec, etc. */ /*========================================================================*/ @@ -1075,7 +1000,7 @@ static Scheme_Object *build_let_one_chain(Scheme_IR_Let_Header *head, Scheme_Obj && SAME_TYPE(SCHEME_TYPE(irlv->value), scheme_ir_lambda_type)) le = resolve_lambda(irlv->value, linfo, 1, 1, 0, NULL); else - le = scheme_resolve_expr(irlv->value, linfo); + le = resolve_expr(irlv->value, linfo); if (is_lifted_reference(le)) { MZ_ASSERT(!info->no_lift); @@ -1108,7 +1033,7 @@ static Scheme_Object *build_let_one_chain(Scheme_IR_Let_Header *head, Scheme_Obj } } - body = scheme_resolve_expr(body, linfo); + body = resolve_expr(body, linfo); if (last) ((Scheme_Let_One *)last)->body = body; else @@ -1390,7 +1315,7 @@ Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) `resolve_omittable` fields. */ if (all_unused_and_omittable(head)) { /* All unused and omittable */ - return scheme_resolve_expr(body, info); + return resolve_expr(body, info); } } } @@ -1473,7 +1398,7 @@ Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) /* Change a `[() (begin expr (values))]' clause, which can be generated by internal-definition expansion, into a `begin' */ - expr = scheme_resolve_expr(expr, linfo); + expr = resolve_expr(expr, linfo); expr = scheme_make_sequence_compilation(scheme_make_pair(expr, scheme_make_pair(scheme_false, scheme_null)), @@ -1492,7 +1417,7 @@ Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) last_body = NULL; last_seq = expr; } else { - expr = scheme_resolve_expr(irlv->value, linfo); + expr = resolve_expr(irlv->value, linfo); lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); if (last) @@ -1554,7 +1479,7 @@ Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } /* Resolve body: */ - body = scheme_resolve_expr((Scheme_Object *)irlv, linfo); + body = resolve_expr((Scheme_Object *)irlv, linfo); while (SCHEME_PAIRP(boxes)) { /* See bangboxenv... */ @@ -1961,7 +1886,7 @@ resolve_lambda(Scheme_Object *_lam, Resolve_Info *info, /* Resolve the closure body: */ { Scheme_Object *code; - code = scheme_resolve_expr(lam->body, new_info); + code = resolve_expr(lam->body, new_info); lam->body = code; } @@ -2037,6 +1962,7 @@ resolve_lambda(Scheme_Object *_lam, Resolve_Info *info, if (has_tl) closure_map[0] = 0; /* globals for closure creation will be at 0 after lifting */ result = tl; + merge_resolve_tl_map(new_info->top, new_info); } } else if (!just_compute_lift) { merge_resolve(info, new_info); @@ -2075,157 +2001,279 @@ resolve_lambda(Scheme_Object *_lam, Resolve_Info *info, } /*========================================================================*/ -/* module */ +/* linklet */ /*========================================================================*/ -static int has_syntax_constants(Scheme_Module *m) +Scheme_Linklet *scheme_resolve_linklet(Scheme_Linklet *linklet, int enforce_const) { - int i, j; - Scheme_Object *e; - Resolve_Prefix *rp; - - if (m->prefix->num_stxes) - return 1; - - for (j = m->num_phases; j-- > 1; ) { - for (i = SCHEME_VEC_SIZE(m->bodies[j]); i--; ) { - e = SCHEME_VEC_ELS(m->bodies[j])[i]; - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - if (rp->num_stxes) - return 1; - } - } - - return 0; -} - -static Scheme_Object * -module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *b, *lift_vec, *body = scheme_null; - Resolve_Prefix *rp; + Scheme_Object *lift_vec, *body = scheme_null, *new_bodies; Resolve_Info *rslv; - int i, cnt; + int i, cnt, num_lifts; - if (!m->comp_prefix) { - /* already resolved */ - return (Scheme_Object *)m; + rslv = resolve_info_create(linklet, enforce_const); + enable_expression_resolve_lifts(rslv); + + if (linklet->num_exports < SCHEME_VEC_SIZE(linklet->defns)) { + /* Some definitions are not exported, so resolve in a way + that lets us GC unused definitions */ + prepare_definition_queue(linklet, rslv); } - rp = scheme_resolve_prefix(0, m->comp_prefix, m->insp); - m->comp_prefix = NULL; - - b = scheme_resolve_expr(m->dummy, old_rslv); - m->dummy = b; - - rslv = scheme_resolve_info_create(rp); - rslv->enforce_const = old_rslv->enforce_const; - rslv->in_module = 1; - scheme_enable_expression_resolve_lifts(rslv); - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); + cnt = SCHEME_VEC_SIZE(linklet->bodies); for (i = 0; i < cnt; i++) { Scheme_Object *e; - e = scheme_resolve_expr(SCHEME_VEC_ELS(m->bodies[0])[i], rslv); - - /* add lift just before the expression that introduced it; - this ordering is needed for bytecode validation of - constantness for top-level references */ - lift_vec = rslv->lifts; - if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { - body = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], body); - SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; + + e = SCHEME_VEC_ELS(linklet->bodies)[i]; + + if (!rslv->toplevel_defns || !scheme_hash_get(rslv->toplevel_defns, e)) { + e = resolve_expr(e, rslv); + + /* add lift just before the expression that introduced it; + this ordering is needed for bytecode validation of + constantness for top-level references */ + lift_vec = rslv->lifts; + if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { + body = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], body); + SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; + } } body = scheme_make_pair(e, body); } - m->max_let_depth = rslv->max_let_depth; + /* If we're pruning unused definitions, handle the stack of pending definitions */ + if (rslv->toplevel_defns) { + Scheme_Object *l, *e; + + /* Loop while the definition stack is non-empty */ + while (1) { + l = scheme_hash_get(rslv->toplevel_defns, scheme_null); + if (SCHEME_NULLP(l)) + break; + scheme_hash_set(rslv->toplevel_defns, scheme_null, SCHEME_CDR(l)); + + l = SCHEME_CAR(l); + e = scheme_make_pair(resolve_expr(l, rslv), scheme_null); + lift_vec = rslv->lifts; + if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { + e = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], e); + SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; + } + scheme_hash_set(rslv->toplevel_defns, l, e); + } + + /* Update the body list, flattening lifts as we go */ + for (l = body, body = scheme_null; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + e = scheme_hash_get(rslv->toplevel_defns, SCHEME_CAR(l)); + if (e) { + if (SCHEME_PAIRP(e)) + body = scheme_append(e, body); + else { + /* Never reached, so just drop it */ + remove_definition_names(SCHEME_CAR(l), linklet); + } + } else + body = scheme_make_pair(SCHEME_CAR(l), body); + } + } else + body = scheme_reverse(body); + + linklet->max_let_depth = rslv->max_let_depth; + linklet->need_instance_access = rslv->need_instance_access; lift_vec = rslv->lifts; - rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); + num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); - body = scheme_list_to_vector(scheme_reverse(body)); - m->bodies[0] = body; + /* Recompute body array: */ + cnt = scheme_list_length(body); + new_bodies = scheme_make_vector(cnt, scheme_false); + for (i = 0; i < cnt; i++, body = SCHEME_CDR(body)) { + SCHEME_VEC_ELS(new_bodies)[i] = SCHEME_CAR(body); + } - rp = scheme_remap_prefix(rp, rslv); + linklet->bodies = new_bodies; - m->prefix = rp; + if (num_lifts) { + /* Adjust the `exports` array to take into account lifted + definitions */ + extend_linklet_defns(linklet, num_lifts); + } - /* Exp-time body was resolved during compilation */ + /* Adjust the imports vector of vectors to drop unused imports at + the level of variables */ + prune_unused_imports(linklet); - /* If there are no syntax objects in the module, then there are no - macros that can reach bindings in the bindings table whose marks - are not a subset of the module context. */ - if (m->rn_stx && SCHEME_STXP(m->rn_stx) && !has_syntax_constants(m)) { - if (m->binding_names) { - b = scheme_prune_bindings_table(m->binding_names, m->rn_stx, scheme_make_integer(0)); - m->binding_names = b; - } - if (m->et_binding_names) { - b = scheme_prune_bindings_table(m->et_binding_names, m->rn_stx, scheme_make_integer(1)); - m->et_binding_names = b; - } - if (m->other_binding_names) { - intptr_t i; - Scheme_Object *k, *val; - Scheme_Hash_Tree *ht; + return linklet; +} - ht = scheme_make_hash_tree(SCHEME_hashtr_equal); +static void prepare_definition_queue(Scheme_Linklet *linklet, Resolve_Info *rslv) +{ + Scheme_Hash_Table *ht; + Scheme_Object *e, *var; + int i, j, cnt, vcnt; - if (SCHEME_HASHTRP(m->other_binding_names)) { - Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)m->other_binding_names; - for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) { - scheme_hash_tree_index(t, i, &k, &val); - val = scheme_prune_bindings_table(val, m->rn_stx, k); - ht = scheme_hash_tree_set(ht, k, val); + ht = scheme_make_hash_table(SCHEME_hash_ptr); + rslv->toplevel_defns = ht; + + /* Queue is initially empty: */ + scheme_hash_set(rslv->toplevel_defns, scheme_null, scheme_null); + + cnt = SCHEME_VEC_SIZE(linklet->bodies); + + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(linklet->bodies)[i]; + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + vcnt = SCHEME_DEFN_VAR_COUNT(e); + if (SCHEME_DEFN_CAN_OMITP(e) + || scheme_omittable_expr(SCHEME_DEFN_RHS(e), vcnt, 5, 0, NULL, NULL)) { + for (j = 0; j < vcnt; j++) { + var = SCHEME_DEFN_VAR_(e, j); + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)); + if (SCHEME_IR_TOPLEVEL_POS(var) < (SCHEME_LINKLET_PREFIX_PREFIX + + linklet->num_total_imports + + linklet->num_exports)) { + /* variable is exported */ + break; + } } - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)m->other_binding_names; - for (i = t->size; i--; ) { - if (t->vals[i]) { - k = t->keys[i]; - val = t->vals[i]; - val = scheme_prune_bindings_table(val, m->rn_stx, k); - ht = scheme_hash_tree_set(ht, k, val); + if (j >= vcnt) { + scheme_hash_set(rslv->toplevel_defns, e, scheme_true); + for (j = 0; j < vcnt; j++) { + int tl_pos; + var = SCHEME_DEFN_VAR_(e, j); + tl_pos = SCHEME_IR_TOPLEVEL_POS(var) + 1 + linklet->num_total_imports; + scheme_hash_set(rslv->toplevel_defns, scheme_make_integer(tl_pos), e); } } } - - m->other_binding_names = (Scheme_Object *)ht; } } - - - { - /* resolve submodules */ - int k; - Scheme_Object *p; - for (k = 0; k < 2; k++) { - p = (k ? m->post_submodules : m->pre_submodules); - if (p) { - while (!SCHEME_NULLP(p)) { - scheme_resolve_expr(SCHEME_CAR(p), old_rslv); - p = SCHEME_CDR(p); - } - } - } - } - - return data; } -static Scheme_Object * -top_level_require_resolve(Scheme_Object *data, Resolve_Info *rslv) +static void remove_definition_names(Scheme_Object *defn, Scheme_Linklet *linklet) { - Scheme_Object *dummy = SCHEME_PTR1_VAL(data); + int i, cnt; + Scheme_Object *var, *name; + Scheme_Hash_Tree *source_names; - dummy = scheme_resolve_expr(dummy, rslv); + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(defn), scheme_define_values_type)); - SCHEME_PTR1_VAL(data) = dummy; + cnt = SCHEME_DEFN_VAR_COUNT(defn); + for (i = 0; i < cnt; i++) { + var = SCHEME_DEFN_VAR_(defn, i); + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)); - return data; + name = SCHEME_VEC_ELS(linklet->defns)[SCHEME_IR_TOPLEVEL_POS(var)]; + + if (linklet->source_names) { + source_names = scheme_hash_tree_set(linklet->source_names, name, NULL); + linklet->source_names = source_names; + } + + SCHEME_VEC_ELS(linklet->defns)[SCHEME_IR_TOPLEVEL_POS(var)] = scheme_false; + } +} + +static void extend_linklet_defns(Scheme_Linklet *linklet, int num_lifts) +{ + int cnt, i; + Scheme_Object *new_defns, *b; + Scheme_Hash_Table *names; + + linklet->num_lifts = num_lifts; + cnt = SCHEME_VEC_SIZE(linklet->defns) + num_lifts; + new_defns = scheme_make_vector(cnt, scheme_false); + names = scheme_make_hash_table(SCHEME_hash_ptr); + + for (i = 0; i < SCHEME_VEC_SIZE(linklet->defns); i++) { + SCHEME_VEC_ELS(new_defns)[i] = SCHEME_VEC_ELS(linklet->defns)[i]; + scheme_hash_set(names, SCHEME_VEC_ELS(new_defns)[i], scheme_true); + } + + for (; i < cnt; i++) { + b = generate_lifted_name(names, i - SCHEME_VEC_SIZE(linklet->defns)); + SCHEME_VEC_ELS(new_defns)[i] = b; + } + + linklet->defns = new_defns; +} + +static void prune_unused_imports(Scheme_Linklet *linklet) +{ + int i, new_i = 0, j; + int num_total_imports; + Scheme_Object *vec, *new_vec, *new_importss; + + for (i = SCHEME_VEC_SIZE(linklet->importss); i--; ) { + if (!SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) + new_i++; + } + if (new_i != SCHEME_VEC_SIZE(linklet->importss)) { + new_importss = scheme_make_vector(new_i, NULL); + new_i = 0; + } else + new_importss = NULL; + + num_total_imports = 0; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + int drop = 0, len, drop_all = 0; + vec = SCHEME_VEC_ELS(linklet->importss)[i]; + if (SCHEME_INTP(vec)) { + len = SCHEME_INT_VAL(vec); + num_total_imports += len; + drop = len; + drop_all = 1; + } else { + len = SCHEME_VEC_SIZE(vec); + num_total_imports += len; + for (j = 0; j < len; j++) { + if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[j])) + drop++; + } + } + if (drop) { + num_total_imports -= drop; + drop = len - drop; + if (!drop_all) { + new_vec = scheme_make_vector(drop, NULL); + for (j = len; j--; ) { + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[j])) { + SCHEME_VEC_ELS(new_vec)[--drop] = SCHEME_VEC_ELS(vec)[j]; + } + } + MZ_ASSERT(!drop); + SCHEME_VEC_ELS(linklet->importss)[i] = new_vec; + } + } + if (!drop_all && new_importss) + SCHEME_VEC_ELS(new_importss)[new_i++] = SCHEME_VEC_ELS(linklet->importss)[i]; + } + + if (new_importss) { + MZ_ASSERT(new_i == SCHEME_VEC_SIZE(new_importss)); + linklet->importss = new_importss; + } + + linklet->num_total_imports = num_total_imports; + + MZ_ASSERT(!linklet->import_shapes || (linklet->num_total_imports == SCHEME_VEC_SIZE(linklet->import_shapes))); +} + +static Scheme_Object *generate_lifted_name(Scheme_Hash_Table *used_names, int search_start) +{ + char buf[32]; + Scheme_Object *n; + + while (1) { + sprintf(buf, "?lifted.%d", search_start); + n = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + if (!scheme_hash_get(used_names, n)) { + scheme_hash_set(used_names, n, scheme_true); + return n; + } + search_start++; + } } /*========================================================================*/ @@ -2241,10 +2289,10 @@ static Scheme_Object *resolve_k(void) p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return scheme_resolve_expr(expr, info); + return resolve_expr(expr, info); } -Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) +Scheme_Object *resolve_expr(Scheme_Object *expr, Resolve_Info *info) { Scheme_Type type = SCHEME_TYPE(expr); @@ -2289,7 +2337,6 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) return resolve_application3(expr, info, 0); case scheme_sequence_type: case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: return resolve_sequence(expr, info); case scheme_branch_type: return resolve_branch(expr, info); @@ -2301,42 +2348,15 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) return scheme_resolve_lets(expr, info); case scheme_ir_toplevel_type: return resolve_toplevel(info, expr, 1); - case scheme_ir_quote_syntax_type: - { - Scheme_Quote_Syntax *qs; - int i, c, p; - - i = SCHEME_LOCAL_POS(expr); - i = resolve_quote_syntax_offset(i, info); - c = resolve_toplevel_pos(info); - p = resolve_quote_syntax_pos(info); - - set_tl_pos_used(info, i+p+1); - - qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); - qs->so.type = scheme_quote_syntax_type; - qs->depth = c; - qs->position = i; - qs->midpoint = p; - - return (Scheme_Object *)qs; - } case scheme_variable_type: - case scheme_module_variable_type: scheme_signal_error("got top-level in wrong place"); return 0; case scheme_define_values_type: return define_values_resolve(expr, info); case scheme_inline_variant_type: return inline_variant_resolve(expr, info); - case scheme_define_syntaxes_type: - return define_syntaxes_resolve(expr, info); - case scheme_begin_for_syntax_type: - return begin_for_syntax_resolve(expr, info); case scheme_set_bang_type: return set_resolve(expr, info); - case scheme_require_form_type: - return top_level_require_resolve(expr, info); case scheme_varref_form_type: return ref_resolve(expr, info); case scheme_apply_values_type: @@ -2345,8 +2365,6 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) return with_immed_mark_resolve(expr, info); case scheme_case_lambda_sequence_type: return case_lambda_resolve(expr, info); - case scheme_module_type: - return module_expr_resolve(expr, info); case scheme_boxenv_type: scheme_signal_error("internal error: no boxenv resolve"); default: @@ -2354,28 +2372,6 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) } } -Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info) -{ - Scheme_Object *first = scheme_null, *last = NULL; - - while (SCHEME_PAIRP(expr)) { - Scheme_Object *pr; - - pr = scheme_make_pair(scheme_resolve_expr(SCHEME_CAR(expr), info), - scheme_null); - - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - expr = SCHEME_CDR(expr); - } - - return first; -} - static Scheme_Object *resolve_info_lift_added(Resolve_Info *resolve, Scheme_Object *v, int convert_shift) { /* If a variable added as an argument for closure conversion is mutable, @@ -2407,15 +2403,10 @@ static Scheme_Object *shift_lifted_reference(Scheme_Object *tl, Resolve_Info *in depth = resolve_toplevel_pos(info); tl = scheme_make_toplevel(depth + delta, pos, - 1, SCHEME_TOPLEVEL_CONST); /* register if non-stub: */ - if (pos >= (info->prefix->num_toplevels - + info->prefix->num_stxes - + (info->prefix->num_stxes - ? 1 - : 0))) + if (pos >= info->num_toplevels) set_tl_pos_used(info, pos); return tl; @@ -2425,122 +2416,56 @@ static Scheme_Object *shift_lifted_reference(Scheme_Object *tl, Resolve_Info *in /* compile-time env for resolve */ /*========================================================================*/ -Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, Scheme_Object *insp_desc) -{ - Resolve_Prefix *rp; - Scheme_Object **tls, **stxes, *m; - Scheme_Hash_Table *ht; - int i; - - rp = MALLOC_ONE_TAGGED(Resolve_Prefix); - rp->so.type = scheme_resolve_prefix_type; - rp->num_toplevels = cp->num_toplevels; - rp->num_stxes = cp->num_stxes; - - if (rp->num_toplevels) - tls = MALLOC_N(Scheme_Object*, rp->num_toplevels); - else - tls = NULL; - if (rp->num_stxes) - stxes = MALLOC_N(Scheme_Object*, rp->num_stxes); - else - stxes = NULL; - - rp->toplevels = tls; - rp->stxes = stxes; - - ht = cp->toplevels; - if (ht) { - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - m = ht->keys[i]; - if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_variable_type)) { - if (SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->base) - && SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->path)) { - /* Reduce self-referece to just a symbol: */ - m = ((Module_Variable *)m)->sym; - } - } - tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m; - } - } - } - - ht = cp->stxes; - if (ht) { - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - stxes[SCHEME_LOCAL_POS(ht->vals[i])] = ht->keys[i]; - } - } - } - - rp->src_insp_desc = insp_desc; - - return rp; -} - -Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri) -{ - /* Rewrite stxes list based on actual uses at resolve pass. - If we have no lifts, we can just drop unused stxes. - Otherwise, if any stxes go unused, we just have to replace them - with NULL. */ - int i, cnt; - Scheme_Object **new_stxes, *v; - - if (!rp->num_stxes) - return rp; - - if (rp->num_lifts) - cnt = rp->num_stxes; - else - cnt = (int)ri->stx_map->count; - - new_stxes = MALLOC_N(Scheme_Object *, cnt); - - for (i = 0; i < rp->num_stxes; i++) { - if (ri->stx_map) - v = scheme_hash_get(ri->stx_map, scheme_make_integer(i)); - else - v = NULL; - if (v) { - new_stxes[SCHEME_INT_VAL(v)] = rp->stxes[i]; - } - } - - rp->stxes = new_stxes; - rp->num_stxes = cnt; - - return rp; -} - -Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp) +static Resolve_Info *resolve_info_create(Scheme_Linklet *linklet, int enforce_const) { Resolve_Info *naya; - Scheme_Object *b; - Scheme_Hash_Table *ht; - + int *toplevel_starts, pos, dpos, i, j; + int *toplevel_deltas; + naya = MALLOC_ONE_RT(Resolve_Info); #ifdef MZTAG_REQUIRED naya->type = scheme_rt_resolve_info; #endif - naya->prefix = rp; naya->current_depth = 1; /* initial slot for prefix */ naya->max_let_depth = naya->current_depth; naya->current_lex_depth = 0; naya->next = NULL; + naya->enforce_const = enforce_const; + naya->linklet = linklet; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - naya->stx_map = ht; + toplevel_starts = MALLOC_N_ATOMIC(int, SCHEME_VEC_SIZE(linklet->importss) + 1); + toplevel_deltas = MALLOC_N_ATOMIC(int, (linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX)); + pos = SCHEME_LINKLET_PREFIX_PREFIX; + dpos = pos; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + toplevel_starts[i+1] = pos; + if (SCHEME_INTP(SCHEME_VEC_ELS(linklet->importss)[i])) { + /* This import is getting dropped */ + pos += SCHEME_INT_VAL(SCHEME_VEC_ELS(linklet->importss)[i]); + } else { + for (j = 0; j < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j++) { + toplevel_deltas[pos] = (dpos - pos); + if (SCHEME_FALSEP(SCHEME_VEC_ELS(SCHEME_VEC_ELS(linklet->importss)[i])[j])) + toplevel_deltas[pos] = 0xFFFFFF; /* shouldn't be used */ + else + dpos++; + pos++; + } + } + } + toplevel_starts[0] = dpos; - b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); - naya->use_jit = SCHEME_TRUEP(b); + naya->num_toplevels = (dpos + SCHEME_VEC_SIZE(linklet->defns)); + + naya->toplevel_starts = toplevel_starts; + naya->toplevel_deltas = toplevel_deltas; + + naya->top = naya; return naya; } -void scheme_enable_expression_resolve_lifts(Resolve_Info *ri) +static void enable_expression_resolve_lifts(Resolve_Info *ri) { Scheme_Object *lift_vec; @@ -2550,46 +2475,6 @@ void scheme_enable_expression_resolve_lifts(Resolve_Info *ri) ri->lifts = lift_vec; } -Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri) -{ - Scheme_Object *lift_vec, *lifts; - Scheme_Sequence *s; - int n, i; - - lift_vec = ri->lifts; - n = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); - if (n) { - rp->num_lifts = n; - lifts = SCHEME_VEC_ELS(lift_vec)[0]; - - s = scheme_malloc_sequence(n + 1); - s->so.type = scheme_sequence_type; - s->count = n + 1; - for (i = 0; i < n; i++, lifts = SCHEME_CDR(lifts)) { - s->array[i] = SCHEME_CAR(lifts); - } - s->array[i] = expr; - - return (Scheme_Object *)s; - } else - return expr; -} - -void scheme_resolve_info_enforce_const(Resolve_Info *ri, int enforce_const) -{ - ri->enforce_const = enforce_const; -} - -int scheme_resolve_info_use_jit(Resolve_Info *ri) -{ - return ri->use_jit; -} - -int scheme_resolve_info_max_let_depth(Resolve_Info *ri) -{ - return ri->max_let_depth; -} - static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambda) /* size = number of appended items in run-time frame */ { @@ -2599,10 +2484,8 @@ static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambd #ifdef MZTAG_REQUIRED naya->type = scheme_rt_resolve_info; #endif - naya->prefix = info->prefix; - naya->stx_map = info->stx_map; + naya->linklet = info->linklet; naya->next = (lambda ? NULL : info); - naya->use_jit = info->use_jit; naya->enforce_const = info->enforce_const; naya->current_depth = (lambda ? 0 : info->current_depth) + size; naya->current_lex_depth = info->current_lex_depth + size; @@ -2616,6 +2499,11 @@ static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int lambd naya->max_let_depth = naya->current_depth; naya->in_proc = lambda || info->in_proc; naya->lifts = info->lifts; + naya->num_toplevels = info->num_toplevels; + naya->toplevel_starts = info->toplevel_starts; + naya->toplevel_deltas = info->toplevel_deltas; + naya->top = info->top; + naya->toplevel_defns = info->toplevel_defns; return naya; } @@ -2658,9 +2546,8 @@ static void *ensure_tl_map_len(void *old_tl_map, int new_len) return old_tl_map; } -static void set_tl_pos_used(Resolve_Info *info, int pos) +static void set_tl_pos_used(Resolve_Info *info, int tl_pos) { - int tl_pos; void *tl_map; /* Fixnum-like bit packing avoids allocation in the common case of a @@ -2669,13 +2556,6 @@ static void set_tl_pos_used(Resolve_Info *info, int pos) bit for each normal top-level, one bit for all syntax objects, and one bit for each lifted top-level. */ - if (pos > (info->prefix->num_toplevels + info->prefix->num_stxes)) - tl_pos = pos - info->prefix->num_stxes; /* lifted */ - else if (pos >= info->prefix->num_toplevels) - tl_pos = info->prefix->num_toplevels; /* any syntax object */ - else - tl_pos = pos; /* normal top level */ - tl_map = ensure_tl_map_len(info->tl_map, tl_pos + 1); info->tl_map = tl_map; @@ -2683,6 +2563,27 @@ static void set_tl_pos_used(Resolve_Info *info, int pos) info->tl_map = (void *)((uintptr_t)tl_map | ((uintptr_t)1 << (tl_pos + 1))); else ((int *)tl_map)[1 + (tl_pos / 32)] |= ((unsigned)1 << (tl_pos & 31)); + + /* If we're pruning unused definitions, then ensure a newly referenced definition */ + if (info->toplevel_defns + && (tl_pos >= (SCHEME_LINKLET_PREFIX_PREFIX + + info->linklet->num_total_imports + + info->linklet->num_exports))) { + Scheme_Object *defn; + defn = scheme_hash_get(info->toplevel_defns, scheme_make_integer(tl_pos)); + if (defn) { + if (SAME_OBJ(scheme_true, scheme_hash_get(info->toplevel_defns, defn))) { + /* Enqueue the defn for traversal: */ + scheme_hash_set(info->toplevel_defns, + scheme_null, + scheme_make_pair(defn, + scheme_hash_get(info->toplevel_defns, scheme_null))); + /* Add to indicate that it's enqueued */ + scheme_hash_set(info->toplevel_defns, defn, scheme_false); + } + scheme_hash_set(info->toplevel_defns, scheme_make_integer(tl_pos), NULL); + } + } } static void *merge_tl_map(void *tl_map, void *new_tl_map) @@ -2708,12 +2609,8 @@ static void *merge_tl_map(void *tl_map, void *new_tl_map) } } -static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info) +static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info) { - if (new_info->next /* NULL => lambda */ - && (new_info->max_let_depth > info->max_let_depth)) - info->max_let_depth = new_info->max_let_depth; - if (!new_info->tl_map) { /* nothing to do */ } else { @@ -2721,6 +2618,18 @@ static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info) tl_map = merge_tl_map(info->tl_map, new_info->tl_map); info->tl_map = tl_map; } + + if (new_info->need_instance_access) + info->need_instance_access = 1; +} + +static void merge_resolve(Resolve_Info *info, Resolve_Info *new_info) +{ + if (new_info->next /* NULL => lambda */ + && (new_info->max_let_depth > info->max_let_depth)) + info->max_let_depth = new_info->max_let_depth; + + merge_resolve_tl_map(info, new_info); } static void resolve_info_add_mapping(Resolve_Info *info, Scheme_IR_Local *var, Scheme_Object *v) @@ -2777,7 +2686,7 @@ static int resolve_info_lookup(Resolve_Info *info, Scheme_IR_Local *var, Scheme_ static Scheme_Object *resolve_generate_stub_lift() { - return scheme_make_toplevel(0, 0, 1, SCHEME_TOPLEVEL_CONST); + return scheme_make_toplevel(0, 0, SCHEME_TOPLEVEL_CONST); } static int resolve_toplevel_pos(Resolve_Info *info) @@ -2796,48 +2705,35 @@ static int resolve_has_toplevel(Resolve_Info *info) return info->toplevel_pos >= 0; } -static int resolve_quote_syntax_offset(int i, Resolve_Info *info) -{ - Scheme_Hash_Table *ht; - Scheme_Object *v; - - ht = info->stx_map; - - v = scheme_hash_get(ht, scheme_make_integer(i)); - if (!v) { - v = scheme_make_integer(ht->count); - scheme_hash_set(ht, scheme_make_integer(i), v); - } - - return (int)SCHEME_INT_VAL(v); -} - -static int resolve_quote_syntax_pos(Resolve_Info *info) -{ - return info->prefix->num_toplevels; -} - static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int as_reference) { int skip, pos; skip = resolve_toplevel_pos(info); - pos = SCHEME_TOPLEVEL_POS(expr); + if (SCHEME_IR_TOPLEVEL_INSTANCE(expr) == -1) { + if (SCHEME_IR_TOPLEVEL_POS(expr) == -1) { + /* (-1, -1) is the instance-access prefix slot */ + pos = 0; + info->need_instance_access = 1; + } else + pos = info->toplevel_starts[0] + SCHEME_IR_TOPLEVEL_POS(expr); + } else { + pos = (info->toplevel_starts[SCHEME_IR_TOPLEVEL_INSTANCE(expr) + 1] + SCHEME_IR_TOPLEVEL_POS(expr)); + pos += info->toplevel_deltas[pos]; + } - set_tl_pos_used(info, pos); + if (as_reference) + set_tl_pos_used(info, pos); - return scheme_make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */ - pos, - 1, - SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK); + return scheme_make_toplevel(skip, pos, + SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)expr) & SCHEME_TOPLEVEL_FLAGS_MASK); } static Scheme_Object *shift_toplevel(Scheme_Object *expr, int delta) { return scheme_make_toplevel(SCHEME_TOPLEVEL_DEPTH(expr) + delta, SCHEME_TOPLEVEL_POS(expr), - 1, SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK); } @@ -2849,10 +2745,7 @@ static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info) skip = resolve_toplevel_pos(info); count = SCHEME_VEC_ELS(info->lifts)[1]; - pos = (int)(SCHEME_INT_VAL(count) - + info->prefix->num_toplevels - + info->prefix->num_stxes - + (info->prefix->num_stxes ? 1 : 0)); + pos = (int)(SCHEME_INT_VAL(count) + info->num_toplevels); count = scheme_make_integer(SCHEME_INT_VAL(count) + 1); SCHEME_VEC_ELS(info->lifts)[1] = count; @@ -2860,7 +2753,6 @@ static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info) return scheme_make_toplevel(skip, pos, - 1, SCHEME_TOPLEVEL_CONST); } @@ -2868,7 +2760,6 @@ static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Sche { return scheme_make_toplevel(0, SCHEME_TOPLEVEL_POS(tl), - 1, SCHEME_TOPLEVEL_CONST); } @@ -2890,50 +2781,39 @@ static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Sche typedef struct Unresolve_Info { MZTAG_IF_REQUIRED + int comp_flags; int stack_pos; /* stack in resolved coordinates */ int depth; /* stack in unresolved coordinates */ int stack_size; Scheme_IR_Local **vars; - Resolve_Prefix *prefix; + + /* For cross-linklet inlining: */ + Scheme_Linklet *linklet; + Scheme_Object *linklet_key; + Optimize_Info *opt_info; + Scheme_Hash_Table *closures; /* handle cycles */ int has_non_leaf, has_tl, body_size; - int comp_flags; int inlining; - Scheme_Module *module; - Comp_Prefix *comp_prefix; /* Top-level and syntax-constant info for - top-level unresolved. This prefix is - the unresolved from of the original - resolved prefix. + int num_toplevels; /* compute imports + defns for linklet */ + int num_defns; /* initial defns for linklet */ + int num_extra_toplevels; /* created toplevels for cyclic lambdas */ - When unresolving a single lambda for - inlining, this prefix is NULL, and - tenattive additions are added to - `new_toplevels`, instead. */ - - Scheme_Hash_Table *new_toplevels; /* toplevels to add to an optimiation context */ - int new_toplevel_offset; /* the number of toplevels already registered in the - optimization context */ - Scheme_Object *from_modidx, *to_modidx; /* non-NULL => shift for adding to `new_toplevels` */ - intptr_t toplevel_ref_phase; - Scheme_Env *opt_env; - Scheme_Object *opt_insp; - Scheme_Object *inline_variants; - - Scheme_Hash_Table *toplevels; + Scheme_IR_Toplevel **toplevels; Scheme_Object *definitions; - int lift_offset, lift_to_local; + int lift_offset; Scheme_Hash_Table *ref_lifts; } Unresolve_Info; static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int as_rator); -static Comp_Prefix *unresolve_prefix(Resolve_Prefix *rp, Unresolve_Info *ui); static void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui); static Scheme_IR_Let_Header *make_let_header(int count); static Scheme_IR_Let_Value *make_ir_let_value(int count); -static Unresolve_Info *new_unresolve_info(Resolve_Prefix *prefix, int comp_flags) +static Unresolve_Info *new_unresolve_info(Scheme_Linklet *linklet, Scheme_Object *linklet_key, Optimize_Info *opt_info, + int comp_flags) { Unresolve_Info *ui; Scheme_IR_Local **vars; @@ -2942,15 +2822,15 @@ static Unresolve_Info *new_unresolve_info(Resolve_Prefix *prefix, int comp_flags ui = MALLOC_ONE_RT(Unresolve_Info); SET_REQUIRED_TAG(ui->type = scheme_rt_unresolve_info); - ui->prefix = prefix; + ui->linklet = linklet; + ui->linklet_key = linklet_key; + ui->opt_info = opt_info; ui->stack_pos = 0; ui->stack_size = 10; vars = MALLOC_N(Scheme_IR_Local *, ui->stack_size); ui->vars = vars; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ui->toplevels = ht; ui->definitions = scheme_null; ht = scheme_make_hash_table(SCHEME_hash_ptr); ui->ref_lifts = ht; @@ -2959,6 +2839,13 @@ static Unresolve_Info *new_unresolve_info(Resolve_Prefix *prefix, int comp_flags ui->comp_flags = comp_flags; + ui->num_defns = SCHEME_VEC_SIZE(linklet->defns); + ui->num_toplevels = (SCHEME_LINKLET_PREFIX_PREFIX + + linklet->num_total_imports + + ui->num_defns); + ui->lift_offset = (ui->num_toplevels + - linklet->num_lifts); + return ui; } @@ -3121,157 +3008,75 @@ static void check_nonleaf_rator(Scheme_Object *rator, Unresolve_Info *ui) ui->has_non_leaf = 1; } -static int unresolve_toplevel_pos(int pos, Unresolve_Info *ui) -{ - LOG_UNRESOLVE(printf("pos before = %d\n", pos)); - if (ui->prefix->num_stxes - && (pos > (ui->prefix->num_toplevels + ui->prefix->num_stxes))) { - /* shift lifted reference down to toplevel range */ - pos -= ui->prefix->num_stxes + 1; /* extra slot for lazy syntax */ - } - LOG_UNRESOLVE(printf("pos = %d\n", pos)); - - return pos; -} - static Scheme_Object *unresolve_toplevel(Scheme_Object *rdata, Unresolve_Info *ui) { Scheme_Object *v; - - if (ui->inlining) { - /* Create a reference that works for the optimization context. */ - int pos = SCHEME_TOPLEVEL_POS(rdata); - if (ui->prefix->num_stxes - && (pos > (ui->prefix->num_toplevels + ui->prefix->num_stxes))) { - /* Cannot refer to a lift across a module boundary. */ - return_NULL; - } else { - Scheme_Object *hv, *modidx, *mod_constant, *sym, *npos, *shape; - int flags, is_constant; - int sym_pos; - intptr_t mod_defn_phase; - - flags = SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK; - switch (flags) { - case SCHEME_TOPLEVEL_CONST: - is_constant = 2; - break; - case SCHEME_TOPLEVEL_FIXED: - is_constant = 1; - break; - case SCHEME_TOPLEVEL_READY: - default: - /* Since we're referencing from an imported context, the - variable is now at least ready: */ - flags = SCHEME_TOPLEVEL_READY; - is_constant = 0; - } - - v = ui->prefix->toplevels[pos]; - if (SCHEME_MPAIRP(v)) { - /* Simplified version was installed by link_module_variable; original is in CDR */ - v = SCHEME_CDR(v); - } - - if (SCHEME_SYMBOLP(v)) { - mod_defn_phase = ui->toplevel_ref_phase; - modidx = ui->to_modidx; - sym_pos = -1; - sym = v; - } else { - Module_Variable *mv = (Module_Variable *)v; - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_module_variable_type)); - mod_defn_phase = mv->mod_phase; - modidx = scheme_modidx_shift(mv->modidx, ui->from_modidx, ui->to_modidx); - sym = mv->sym; - sym_pos = mv->pos; - } - - mod_constant = NULL; - npos = scheme_check_accessible_in_module_name(modidx, mod_defn_phase, ui->opt_env, - sym, sym_pos, - ui->opt_insp, NULL, - &mod_constant); - if (!npos) - return_NULL; - - if (sym_pos < 0) - sym_pos = SCHEME_INT_VAL(npos); - - shape = NULL; - if (mod_constant) { - if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) - shape = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); - else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) - shape = scheme_get_or_check_procedure_shape(mod_constant, NULL); - } - - hv = scheme_hash_module_variable(ui->opt_env, modidx, - sym, ui->opt_insp, - sym_pos, mod_defn_phase, is_constant, - shape); - - /* Check whether this variable is already known in the optimzation context: */ - v = scheme_hash_get(ui->comp_prefix->toplevels, hv); - if (!v) { - /* Not already in optimization context; check/extend tentative additions */ - if (!ui->new_toplevels) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ui->new_toplevels = ht; - } - - v = scheme_hash_get(ui->new_toplevels, hv); - if (!v) { - int new_pos = ui->new_toplevel_offset + ui->new_toplevels->count; - v = scheme_make_toplevel(0, new_pos, 0, flags); - scheme_hash_set(ui->new_toplevels, hv, v); - - if (mod_constant - && ui->comp_prefix->inline_variants) { - if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { - Scheme_Object *shiftable; - shiftable = scheme_make_vector(4, scheme_false); - SCHEME_VEC_ELS(shiftable)[0] = mod_constant; - SCHEME_VEC_ELS(shiftable)[1] = ui->from_modidx; - SCHEME_VEC_ELS(shiftable)[2] = ui->to_modidx; - SCHEME_VEC_ELS(shiftable)[3] = scheme_make_integer(mod_defn_phase); - mod_constant = shiftable; - } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { - /* keep it */ - } else - mod_constant = NULL; - - if (mod_constant) { - mod_constant = scheme_make_pair(scheme_make_pair(scheme_make_integer(new_pos), - mod_constant), - ui->inline_variants); - ui->inline_variants = mod_constant; - } - } - } - } - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)); - } - } else { - /* If needed, shift top-level position to account for moving - lifts to toplevels. */ - Scheme_Object *opos; - int pos; - - pos = unresolve_toplevel_pos(SCHEME_TOPLEVEL_POS(rdata), ui); - opos = scheme_make_integer(pos); - v = scheme_hash_get(ui->toplevels, opos); - if (!v) { - v = scheme_make_toplevel(0, - pos, - 0, - SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK); - scheme_hash_set(ui->toplevels, opos, v); - } - LOG_UNRESOLVE(printf("flags for %d: %d\n", pos, SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK)); + int pos = SCHEME_TOPLEVEL_POS(rdata); + int flags; + + /* Create a reference that works for the optimization context. */ + + MZ_ASSERT(pos < ui->num_toplevels); + + if (ui->inlining && (pos > (SCHEME_LINKLET_PREFIX_PREFIX + + ui->linklet->num_total_imports + + ui->linklet->num_exports))) { + /* Cannot refer to an unexported variable across a module boundary. */ + return_NULL; } + if (ui->inlining) { + /* Can we introduce a new top-level reference while inlining + across a module boundary? */ + if (pos >= (ui->linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX)) { + /* no new instance needed, but maybe a new symbol from that instance */ + pos -= (ui->linklet->num_total_imports + SCHEME_LINKLET_PREFIX_PREFIX); + return scheme_optimize_add_import_variable(ui->opt_info, ui->linklet_key, + SCHEME_VEC_ELS(ui->linklet->defns)[pos]); + } else { + /* Find import: */ + int instance_pos = 0; + pos -= SCHEME_LINKLET_PREFIX_PREFIX; + while (pos >= SCHEME_VEC_SIZE(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos])) { + pos -= SCHEME_VEC_SIZE(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos]); + instance_pos++; + } + MZ_ASSERT(instance_pos < SCHEME_VEC_SIZE(ui->linklet->importss)); + + /* Getting this imported linklet's import's key may add an import to the + linklet being optimized: */ + v = scheme_optimize_get_import_key(ui->opt_info, ui->linklet_key, instance_pos); + if (v) { + /* Can add relevant linklet import (or already have it) */ + return scheme_optimize_add_import_variable(ui->opt_info, v, + SCHEME_VEC_ELS(SCHEME_VEC_ELS(ui->linklet->importss)[instance_pos])[pos]); + } + } + + return_NULL; + } + + flags = SCHEME_TOPLEVEL_FLAGS(rdata) & SCHEME_TOPLEVEL_FLAGS_MASK; + switch (flags) { + case SCHEME_TOPLEVEL_CONST: + break; + case SCHEME_TOPLEVEL_FIXED: + break; + case SCHEME_TOPLEVEL_READY: + default: + if (ui->inlining) { + /* Since we're referencing from an imported context, the + variable is now at least ready: */ + flags = SCHEME_TOPLEVEL_READY; + } + } + + v = (Scheme_Object *)ui->toplevels[pos]; + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)); + + if (flags) + v = scheme_ir_toplevel_to_flagged_toplevel(v, flags); + ui->has_tl = 1; return v; @@ -3300,120 +3105,22 @@ static Scheme_Object *unresolve_apply_values(Scheme_Object *e, Unresolve_Info *u static Scheme_Object *unresolve_define_values(Scheme_Object *e, Unresolve_Info *ui) { - Scheme_Object *vars = scheme_null; Scheme_Object *vec, *val, *tl; int i; + vec = scheme_make_vector(SCHEME_VEC_SIZE(e), NULL); + vec->type = scheme_define_values_type; + LOG_UNRESOLVE(printf("define-values-size!!!: %d\n", (int)SCHEME_VEC_SIZE(e))); for (i = SCHEME_VEC_SIZE(e); --i;) { LOG_UNRESOLVE(printf("define-values: %d\n", SCHEME_TYPE(SCHEME_VEC_ELS(e)[i]))); tl = unresolve_toplevel(SCHEME_VEC_ELS(e)[i], ui); - if (!tl) return_NULL; /* TODO: does this check need to be here? */ - vars = cons(tl, vars); + if (!tl) return_NULL; + SCHEME_VEC_ELS(vec)[i] = tl; } val = unresolve_expr(SCHEME_VEC_ELS(e)[0], ui, 0); if (!val) return_NULL; - - vec = scheme_make_vector(2, NULL); - vec->type = scheme_define_values_type; - SCHEME_VEC_ELS(vec)[0] = vars; - SCHEME_VEC_ELS(vec)[1] = val; - return vec; -} - -static Scheme_Object *unresolve_define_or_begin_syntaxes(int def, Scheme_Object *e, Unresolve_Info *ui) -{ - Resolve_Prefix *prefix; - Comp_Prefix *comp_prefix; - Scheme_Object *names, *dummy, *val, *vec; - Unresolve_Info *nui; - int i, closures_count; - - prefix = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[1]; - dummy = SCHEME_VEC_ELS(e)[3]; - val = SCHEME_VEC_ELS(e)[0]; - - if (def) { - names = scheme_null; - for (i = SCHEME_VEC_SIZE(e); i-- > 4; ) { - names = scheme_make_pair(SCHEME_VEC_ELS(e)[i], names); - } - } else - names = NULL; - - nui = new_unresolve_info(prefix, ui->comp_flags); - nui->lift_to_local = 1; - - dummy = unresolve_expr(dummy, ui, 0); - comp_prefix = unresolve_prefix(prefix, nui); - nui->comp_prefix = comp_prefix; - - if (def) { - locate_cyclic_closures(val, nui); - val = unresolve_expr(val, nui, 0); - } else { - for (e = val; !SCHEME_NULLP(e); e = SCHEME_CDR(e)) { - locate_cyclic_closures(SCHEME_CAR(e), nui); - } - e = val; - val = scheme_null; - for (; !SCHEME_NULLP(e); e = SCHEME_CDR(e)) { - val = scheme_make_pair(unresolve_expr(SCHEME_CAR(e), nui, 0), - val); - } - val = scheme_reverse(val); - } - - vec = scheme_make_vector(4, NULL); - vec->type = (def ? scheme_define_syntaxes_type : scheme_begin_for_syntax_type); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)comp_prefix; - SCHEME_VEC_ELS(vec)[1] = dummy; - if (def) { - SCHEME_VEC_ELS(vec)[2] = names; - SCHEME_VEC_ELS(vec)[3] = val; - } else { - SCHEME_VEC_ELS(vec)[2] = val; - } - - closures_count = 0; - if (nui->closures && nui->closures->count) { - for (i = 0; i < nui->closures->size; i++) { - if (nui->closures->vals[i] && !SAME_OBJ(nui->closures->vals[i], scheme_true)) - closures_count++; - } - } - - if (closures_count) { - Scheme_IR_Let_Header *head; - Scheme_IR_Let_Value *irlv, *prev_irlv = NULL; - Scheme_IR_Local **vars; - - head = make_let_header(closures_count); - head->num_clauses = closures_count; - SCHEME_LET_FLAGS(head) = SCHEME_LET_RECURSIVE; - - for (i = 0; i < nui->closures->size; i++) { - if (nui->closures->vals[i] && !SAME_OBJ(nui->closures->vals[i], scheme_true)) { - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(nui->closures->vals[i]), scheme_ir_local_type)); - irlv = make_ir_let_value(1); - vars = MALLOC_N(Scheme_IR_Local *, 1); - vars[0] = SCHEME_VAR(nui->closures->vals[i]); - irlv->vars = vars; - - if (prev_irlv) - prev_irlv->body = (Scheme_Object *)irlv; - else - head->body = (Scheme_Object *)irlv; - prev_irlv = irlv; - } - } - - MZ_ASSERT(prev_irlv); - prev_irlv->body = vec; - - return (Scheme_Object *)head; - } - + SCHEME_VEC_ELS(vec)[0] = val; return vec; } @@ -3591,26 +3298,6 @@ static Scheme_Object *unresolve_let_void(Scheme_Object *e, Unresolve_Info *ui) return (Scheme_Object *)lh; } -static Scheme_Object *unresolve_prefix_symbol(Scheme_Object *s, Unresolve_Info *ui) -{ - if (!ui->module) { - return s; - } else { - Module_Variable *mv; - - mv = MALLOC_ONE_TAGGED(Module_Variable); - mv->iso.so.type = scheme_module_variable_type; - - mv->modidx = ui->module->self_modidx; - mv->sym = s; - mv->insp = ui->module->insp; - mv->pos = -1; - mv->mod_phase = 0; - SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_FIXED; - return (Scheme_Object *)mv; - } -} - static Scheme_Object *unresolve_closure(Scheme_Object *e, Unresolve_Info *ui) { Scheme_Object *r, *c; @@ -3642,345 +3329,6 @@ static Scheme_Object *unresolve_closure(Scheme_Object *e, Unresolve_Info *ui) return r; } -static Comp_Prefix *unresolve_prefix(Resolve_Prefix *rp, Unresolve_Info *ui) -{ - Comp_Prefix *cp; - Scheme_Object *o; - int i; - cp = MALLOC_ONE_TAGGED(Comp_Prefix); - SET_REQUIRED_TAG(cp->type = scheme_rt_comp_prefix); - cp->num_toplevels = 0; - cp->toplevels = NULL; - ui->lift_offset = rp->num_toplevels; - for (i = 0; i < rp->num_toplevels; i++) { - if (SCHEME_SYMBOLP(rp->toplevels[i])) { - Scheme_Object *mv; - mv = unresolve_prefix_symbol(rp->toplevels[i], ui); - o = scheme_register_toplevel_in_comp_prefix(mv, cp, 0, NULL); - } else { - o = scheme_register_toplevel_in_comp_prefix(rp->toplevels[i], cp, ui->module ? 1 : 0, NULL); - } - scheme_hash_set(ui->toplevels, scheme_make_integer(SCHEME_TOPLEVEL_POS(o)), o); - } - for (i = 0; i < rp->num_lifts; i++) { - Scheme_Object *mv, *sym; - sym = scheme_make_symbol("lift"); - sym = scheme_gensym(sym); - mv = unresolve_prefix_symbol(sym, ui); - o = scheme_register_toplevel_in_comp_prefix(mv, cp, 0, NULL); - scheme_hash_set(ui->toplevels, scheme_make_integer(SCHEME_TOPLEVEL_POS(o)), o); - } - cp->stxes = NULL; - for (i = 0; i < rp->num_stxes; i++) { - if (rp->stxes[i]) { - scheme_register_stx_in_comp_prefix(rp->stxes[i], cp); - } else { - cp->num_stxes++; - } - } - cp->inline_variants = NULL; - cp->unbound = NULL; - return cp; -} - -void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui) -{ - switch(SCHEME_TYPE(e)) { - case scheme_sequence_type: - case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: - { - Scheme_Sequence *seq = (Scheme_Sequence *)e; - int i; - for (i = 0; i < seq->count; i++) { - locate_cyclic_closures(seq->array[i], ui); - } - } - break; - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)e; - int i; - for (i = 0; i < app->num_args + 1; i++) { - locate_cyclic_closures(app->args[i], ui); - } - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; - locate_cyclic_closures(app->rator, ui); - locate_cyclic_closures(app->rand, ui); - } - break; - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; - locate_cyclic_closures(app->rator, ui); - locate_cyclic_closures(app->rand1, ui); - locate_cyclic_closures(app->rand2, ui); - } - break; - case scheme_branch_type: - { - Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e; - locate_cyclic_closures(b->test, ui); - locate_cyclic_closures(b->tbranch, ui); - locate_cyclic_closures(b->fbranch, ui); - } - break; - case scheme_with_cont_mark_type: - case scheme_with_immed_mark_type: - { - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)e; - locate_cyclic_closures(wcm->key, ui); - locate_cyclic_closures(wcm->val, ui); - locate_cyclic_closures(wcm->body, ui); - } - break; - case scheme_let_void_type: - { - Scheme_Let_Void *lv = (Scheme_Let_Void *)e; - locate_cyclic_closures(lv->body, ui); - } - break; - case scheme_letrec_type: - { - Scheme_Letrec *lr = (Scheme_Letrec *)e; - int i; - for (i = 0; i < lr->count; i++) { - locate_cyclic_closures(lr->procs[i], ui); - } - locate_cyclic_closures(lr->body, ui); - } - break; - case scheme_let_one_type: - { - Scheme_Let_One *lo = (Scheme_Let_One *)e; - locate_cyclic_closures(lo->value, ui); - locate_cyclic_closures(lo->body, ui); - } - break; - case scheme_closure_type: - { - Scheme_Object *c; - c = scheme_hash_get(ui->closures, e); - - if (SAME_OBJ(c, scheme_true)) { - Scheme_Object *s, *mv, *tl; - s = scheme_make_symbol("cyclic"); - s = scheme_gensym(s); - if (!ui->lift_to_local) { - mv = unresolve_prefix_symbol(s, ui); - tl = scheme_register_toplevel_in_comp_prefix(mv, ui->comp_prefix, 0, NULL); - } else { - Scheme_IR_Local *var; - abort(); - var = MALLOC_ONE_TAGGED(Scheme_IR_Local); - var->so.type = scheme_ir_local_type; - var->name = s; - tl = (Scheme_Object *)var; - } - scheme_hash_set(ui->closures, e, tl); - } else if (c) { - /* do nothing */ - } else { - Scheme_Closure *cl = (Scheme_Closure *)e; - scheme_hash_set(ui->closures, e, scheme_true); - locate_cyclic_closures((Scheme_Object *)cl->code, ui); - } - } - break; - case scheme_lambda_type: - { - Scheme_Lambda *cd = (Scheme_Lambda *)e; - locate_cyclic_closures(cd->body, ui); - } - break; - case scheme_inline_variant_type: - { - Scheme_Object *a; - a = SCHEME_VEC_ELS(e)[0]; - locate_cyclic_closures(a, ui); - } - break; - case scheme_define_values_type: - { - if (SCHEME_VEC_SIZE(e) == 2) { - int pos = SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(e)[1]); - if (pos >= ui->lift_offset) { - Scheme_Lambda *lam = (Scheme_Lambda *)SCHEME_VEC_ELS(e)[0]; - if (SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_TYPED_ARGS) { - scheme_hash_set(ui->ref_lifts, scheme_make_integer(pos), (Scheme_Object *)lam); - } - } - } - - locate_cyclic_closures(SCHEME_VEC_ELS(e)[0], ui); - } - break; - case scheme_set_bang_type: - { - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e; - locate_cyclic_closures(sb->var, ui); - locate_cyclic_closures(sb->val, ui); - } - break; - case scheme_varref_form_type: - case scheme_apply_values_type: - { - Scheme_Object *a, *b; - a = SCHEME_PTR1_VAL(e); - locate_cyclic_closures(a, ui); - b = SCHEME_PTR2_VAL(e); - locate_cyclic_closures(b, ui); - } - break; - case scheme_boxenv_type: - { - locate_cyclic_closures(SCHEME_PTR2_VAL(e), ui); - } - break; - case scheme_case_lambda_sequence_type: - { - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)e; - int i; - for (i = 0; i < cl->count; i++) { - locate_cyclic_closures(cl->array[i], ui); - } - } - break; - case scheme_let_value_type: - { - Scheme_Let_Value *lv = (Scheme_Let_Value *)e; - locate_cyclic_closures(lv->value, ui); - locate_cyclic_closures(lv->body, ui); - } - break; - default: - break; - } -} - -static void convert_closures_to_definitions(Unresolve_Info *ui) -{ - Scheme_Object *d, *vars, *val; - Scheme_Lambda *lam; - int i; - - for (i = 0; i < ui->closures->size; i++) { - if (ui->closures->vals[i] && !SAME_OBJ(ui->closures->vals[i], scheme_true)) { - MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(ui->closures->vals[i]), scheme_ir_toplevel_type)); - d = scheme_make_vector(2, NULL); - d->type = scheme_define_values_type; - vars = cons(ui->closures->vals[i], scheme_null); - lam = SCHEME_CLOSURE_CODE(ui->closures->keys[i]); - val = unresolve_lambda(lam, ui); - SCHEME_VEC_ELS(d)[0] = vars; - SCHEME_VEC_ELS(d)[1] = val; - d = cons(d, ui->definitions); - ui->definitions = d; - } - } -} - -Scheme_Object *unresolve_module(Scheme_Object *e, Unresolve_Info *ui_in) -{ - Scheme_Module *m = (Scheme_Module *)e, *nm; - Scheme_Object *dummy, *bs, *bs2, *ds, **bss; - Comp_Prefix *cp; - Unresolve_Info *ui; - int i, cnt, len; - - ui = new_unresolve_info(m->prefix, ui_in->comp_flags); - - ui->module = m; - cp = unresolve_prefix(m->prefix, ui); - if (!cp) return_NULL; - ui->comp_prefix = cp; - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - bs = scheme_make_vector(cnt, NULL); - - for (i = 0; i < cnt; i++) { - locate_cyclic_closures(SCHEME_VEC_ELS(m->bodies[0])[i], ui); - } - - convert_closures_to_definitions(ui); - - for (i = 0; i < cnt; i++) { - Scheme_Object *b; - b = unresolve_expr(SCHEME_VEC_ELS(m->bodies[0])[i], ui, 0); - if (!b) return_NULL; - SCHEME_VEC_ELS(bs)[i] = b; - } - len = scheme_list_length(ui->definitions); - ds = ui->definitions; - bs2 = scheme_make_vector(cnt + len, NULL); - for (i = 0; SCHEME_PAIRP(ds); ds = SCHEME_CDR(ds), i++) { - SCHEME_VEC_ELS(bs2)[i] = SCHEME_CAR(ds); - } - for (i = 0; i < cnt; i++) { - SCHEME_VEC_ELS(bs2)[i + len] = SCHEME_VEC_ELS(bs)[i]; - } - - dummy = unresolve_expr(m->dummy, ui_in, 0); - - nm = MALLOC_ONE_TAGGED(Scheme_Module); - nm->so.type = scheme_module_type; - nm->predefined = m->predefined; - - nm->modname = m->modname; - nm->modsrc = m->modsrc; - - nm->et_requires = m->et_requires; - nm->requires = m->requires; - nm->tt_requires = m->tt_requires; - nm->dt_requires = m->dt_requires; - nm->other_requires = m->other_requires; - - bss = MALLOC_N(Scheme_Object*, m->num_phases); - nm->bodies = bss; - nm->bodies[0] = bs2; - /* Other phases are left as-is (and resolve doesn't traverse them): */ - for (i = 1; i < m->num_phases; i++) { - nm->bodies[i] = m->bodies[i]; - } - - nm->me = m->me; - - nm->num_phases = m->num_phases; - - nm->exp_infos = m->exp_infos; - - nm->self_modidx = m->self_modidx; - nm->insp = m->prefix->src_insp_desc; - - nm->lang_info = m->lang_info; - - nm->comp_prefix = cp; - nm->max_let_depth = 0; - nm->prefix = NULL; - nm->dummy = dummy; - nm->rn_stx = m->rn_stx; - - nm->phaseless = m->phaseless; - - nm->binding_names = m->binding_names; - nm->et_binding_names = m->et_binding_names; - nm->other_binding_names = m->other_binding_names; - - /* leave submodules alone (and resolve doesn't traverse them): */ - nm->submodule_path = m->submodule_path; - nm->pre_submodules = m->pre_submodules; - nm->post_submodules = m->post_submodules; - nm->pre_submodule_names = m->pre_submodule_names; - nm->submodule_ancestry = m->submodule_ancestry; - /* the `supermodule` field is only for instantiated modules */ - - return (Scheme_Object *)nm; -} - static Scheme_Object *unresolve_let_value(Scheme_Let_Value *lv, Unresolve_Info *ui, Scheme_Object* val, Scheme_Object *body) { Scheme_Set_Bang *sb; @@ -4229,7 +3577,6 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a } case scheme_sequence_type: case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: { Scheme_Sequence *seq = (Scheme_Sequence *)e, *seq2; int i; @@ -4461,22 +3808,10 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a if (!a) return_NULL; return a; } - case scheme_module_type: - { - return unresolve_module(e, ui); - } case scheme_define_values_type: { return unresolve_define_values(e, ui); } - case scheme_define_syntaxes_type: - { - return unresolve_define_or_begin_syntaxes(1, e, ui); - } - case scheme_begin_for_syntax_type: - { - return unresolve_define_or_begin_syntaxes(0, e, ui); - } case scheme_set_bang_type: { Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e, *sb2; @@ -4484,8 +3819,11 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a var = unresolve_expr(sb->var, ui, 0); if (!var) return_NULL; if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)) { - if (ui->module) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; + if (((Scheme_IR_Toplevel *)var)->instance_pos != -1) { + /* Cannot inline a `set!` of another linklet's variable */ + return_NULL; + } + SCHEME_IR_TOPLEVEL_FLAGS(((Scheme_IR_Toplevel *)var)) |= SCHEME_TOPLEVEL_MUTATED; } val = unresolve_expr(sb->val, ui, 0); if (!val) return_NULL; @@ -4508,12 +3846,17 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a LOG_UNRESOLVE(printf("unresolve_varref: (a) %d %d\n", e->type, a->type)); if (SAME_TYPE(SCHEME_TYPE(a), scheme_ir_toplevel_type)) { - SCHEME_TOPLEVEL_FLAGS(a) |= SCHEME_TOPLEVEL_MUTATED; + SCHEME_IR_TOPLEVEL_FLAGS((Scheme_IR_Toplevel *)a) |= SCHEME_TOPLEVEL_MUTATED; } b = SCHEME_PTR2_VAL(e); + MZ_ASSERT(SCHEME_FALSEP(b) || (SAME_TYPE(SCHEME_TYPE(b), scheme_toplevel_type) + && !SCHEME_TOPLEVEL_POS(b))); b = unresolve_expr(b, ui, 0); if (!b) return_NULL; + MZ_ASSERT(SCHEME_FALSEP(b) || (SAME_TYPE(SCHEME_TYPE(b), scheme_ir_toplevel_type) + && (((Scheme_IR_Toplevel *)b)->instance_pos == -1) + && (((Scheme_IR_Toplevel *)b)->variable_pos == -1))); LOG_UNRESOLVE(printf(" (b) %d\n", b->type)); o = scheme_alloc_object(); @@ -4576,32 +3919,6 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a return unresolve_let_value(lv, ui, val, body); } - case scheme_quote_syntax_type: - { - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)e; - Scheme_Local *cqs; - - if (ui->inlining) return_NULL; - - cqs = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - cqs->iso.so.type = scheme_ir_quote_syntax_type; - cqs->position = qs->position; - return (Scheme_Object *)cqs; - } - case scheme_require_form_type: - { - Scheme_Object *dummy = SCHEME_PTR1_VAL(e), *req; - - dummy = unresolve_expr(dummy, ui, 0); - - req = scheme_alloc_object(); - req->type = scheme_require_form_type; - SCHEME_PTR1_VAL(req) = dummy; - SCHEME_PTR2_VAL(req) = SCHEME_PTR2_VAL(e); - - return req; - } - break; default: if (SCHEME_TYPE(e) > _scheme_values_types_) { if (scheme_ir_duplicate_ok(e, 1) || !ui->inlining) @@ -4615,52 +3932,269 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int a } } -Scheme_Object *scheme_unresolve_top(Scheme_Object* o, Comp_Prefix **cp, int comp_flags) +void locate_cyclic_closures(Scheme_Object *e, Unresolve_Info *ui) +{ + switch(SCHEME_TYPE(e)) { + case scheme_sequence_type: + case scheme_begin0_sequence_type: + { + Scheme_Sequence *seq = (Scheme_Sequence *)e; + int i; + for (i = 0; i < seq->count; i++) { + locate_cyclic_closures(seq->array[i], ui); + } + } + break; + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + int i; + for (i = 0; i < app->num_args + 1; i++) { + locate_cyclic_closures(app->args[i], ui); + } + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; + locate_cyclic_closures(app->rator, ui); + locate_cyclic_closures(app->rand, ui); + } + break; + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; + locate_cyclic_closures(app->rator, ui); + locate_cyclic_closures(app->rand1, ui); + locate_cyclic_closures(app->rand2, ui); + } + break; + case scheme_branch_type: + { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e; + locate_cyclic_closures(b->test, ui); + locate_cyclic_closures(b->tbranch, ui); + locate_cyclic_closures(b->fbranch, ui); + } + break; + case scheme_with_cont_mark_type: + case scheme_with_immed_mark_type: + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)e; + locate_cyclic_closures(wcm->key, ui); + locate_cyclic_closures(wcm->val, ui); + locate_cyclic_closures(wcm->body, ui); + } + break; + case scheme_let_void_type: + { + Scheme_Let_Void *lv = (Scheme_Let_Void *)e; + locate_cyclic_closures(lv->body, ui); + } + break; + case scheme_letrec_type: + { + Scheme_Letrec *lr = (Scheme_Letrec *)e; + int i; + for (i = 0; i < lr->count; i++) { + locate_cyclic_closures(lr->procs[i], ui); + } + locate_cyclic_closures(lr->body, ui); + } + break; + case scheme_let_one_type: + { + Scheme_Let_One *lo = (Scheme_Let_One *)e; + locate_cyclic_closures(lo->value, ui); + locate_cyclic_closures(lo->body, ui); + } + break; + case scheme_closure_type: + { + Scheme_Object *c; + c = scheme_hash_get(ui->closures, e); + + if (SAME_OBJ(c, scheme_true)) { + Scheme_IR_Toplevel *tl; + + tl = scheme_make_ir_toplevel(-1, ui->num_defns + ui->num_extra_toplevels, 0); + ui->num_extra_toplevels++; + + scheme_hash_set(ui->closures, e, (Scheme_Object *)tl); + } else if (c) { + /* do nothing */ + } else { + Scheme_Closure *cl = (Scheme_Closure *)e; + scheme_hash_set(ui->closures, e, scheme_true); + locate_cyclic_closures((Scheme_Object *)cl->code, ui); + } + } + break; + case scheme_lambda_type: + { + Scheme_Lambda *cd = (Scheme_Lambda *)e; + locate_cyclic_closures(cd->body, ui); + } + break; + case scheme_inline_variant_type: + { + Scheme_Object *a; + a = SCHEME_VEC_ELS(e)[0]; + locate_cyclic_closures(a, ui); + } + break; + case scheme_define_values_type: + { + if (SCHEME_VEC_SIZE(e) == 2) { + int pos = SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(e)[1]); + if (pos >= ui->lift_offset) { + Scheme_Lambda *lam = (Scheme_Lambda *)SCHEME_VEC_ELS(e)[0]; + if (SCHEME_LAMBDA_FLAGS(lam) & LAMBDA_HAS_TYPED_ARGS) { + scheme_hash_set(ui->ref_lifts, scheme_make_integer(pos), (Scheme_Object *)lam); + } + } + } + + locate_cyclic_closures(SCHEME_VEC_ELS(e)[0], ui); + } + break; + case scheme_set_bang_type: + { + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)e; + locate_cyclic_closures(sb->var, ui); + locate_cyclic_closures(sb->val, ui); + } + break; + case scheme_varref_form_type: + case scheme_apply_values_type: + { + Scheme_Object *a, *b; + a = SCHEME_PTR1_VAL(e); + locate_cyclic_closures(a, ui); + b = SCHEME_PTR2_VAL(e); + locate_cyclic_closures(b, ui); + } + break; + case scheme_boxenv_type: + { + locate_cyclic_closures(SCHEME_PTR2_VAL(e), ui); + } + break; + case scheme_case_lambda_sequence_type: + { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)e; + int i; + for (i = 0; i < cl->count; i++) { + locate_cyclic_closures(cl->array[i], ui); + } + } + break; + case scheme_let_value_type: + { + Scheme_Let_Value *lv = (Scheme_Let_Value *)e; + locate_cyclic_closures(lv->value, ui); + locate_cyclic_closures(lv->body, ui); + } + break; + default: + break; + } +} + +static void convert_closures_to_definitions(Unresolve_Info *ui) +{ + Scheme_Object *d, *var, *val; + Scheme_Lambda *lam; + int i; + + for (i = 0; i < ui->closures->size; i++) { + if (ui->closures->vals[i] && !SAME_OBJ(ui->closures->vals[i], scheme_true)) { + MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(ui->closures->vals[i]), scheme_ir_toplevel_type)); + d = scheme_make_vector(2, NULL); + d->type = scheme_define_values_type; + var = ui->closures->vals[i]; + lam = SCHEME_CLOSURE_CODE(ui->closures->keys[i]); + val = unresolve_lambda(lam, ui); + SCHEME_VEC_ELS(d)[0] = val; + SCHEME_VEC_ELS(d)[1] = var; + d = cons(d, ui->definitions); + ui->definitions = d; + } + } +} + +Scheme_Linklet *scheme_unresolve_linklet(Scheme_Linklet *linklet, int comp_flags) /* Convert from "resolved" form back to the intermediate representation used by the optimizer. Unresolving generates an intermediate-representation prefix (for top levels and syntax literals) in addition to the code. */ { - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)o; - Scheme_Object *code = top->code, *defns; - Resolve_Prefix *rp = top->prefix; - Comp_Prefix *c; + Scheme_Linklet *new_linklet; + Scheme_Object *bs, *bs2, *ds, *imports; Unresolve_Info *ui; - int len, i; + Scheme_IR_Toplevel **toplevels, *tl; + int i, j, cnt, len; - ui = new_unresolve_info(rp, comp_flags); + new_linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); + memcpy(new_linklet, linklet, sizeof(Scheme_Linklet)); - c = unresolve_prefix(rp, ui); - ui->comp_prefix = c; - *cp = c; + ui = new_unresolve_info(new_linklet, NULL, NULL, comp_flags); - locate_cyclic_closures(code, ui); - convert_closures_to_definitions(ui); - - code = unresolve_expr(code, ui, 0); - if (!code) return_NULL; - - len = scheme_list_length(ui->definitions); - if (len) { - Scheme_Sequence *seq; - seq = scheme_malloc_sequence(len+1); - seq->so.type = scheme_sequence_type; - seq->count = len+1; - - defns = ui->definitions; - for (i = 0; i < len; i++) { - seq->array[i] = SCHEME_CAR(defns); - defns = SCHEME_CDR(defns); + cnt = ui->num_toplevels; + toplevels = MALLOC_N(Scheme_IR_Toplevel *, cnt); + tl = scheme_make_ir_toplevel(-1, -1, 0); + i = 0; + toplevels[i++] = tl; + for (j = 0; j < SCHEME_VEC_SIZE(linklet->importss); j++) { + int k; + imports = SCHEME_VEC_ELS(linklet->importss)[j]; + for (k = 0; k < SCHEME_VEC_SIZE(imports); k++) { + tl = scheme_make_ir_toplevel(j, k, 0); + toplevels[i++] = tl; } - seq->array[len] = code; - code = (Scheme_Object *)seq; + } + for (j = 0; i < cnt; j++) { + tl = scheme_make_ir_toplevel(-1, j, 0); + toplevels[i++] = tl; + } + ui->toplevels = toplevels; + + cnt = SCHEME_VEC_SIZE(linklet->bodies); + bs = scheme_make_vector(cnt, NULL); + + for (i = 0; i < cnt; i++) { + locate_cyclic_closures(SCHEME_VEC_ELS(linklet->bodies)[i], ui); } - return code; + convert_closures_to_definitions(ui); + + for (i = 0; i < cnt; i++) { + Scheme_Object *b; + b = unresolve_expr(SCHEME_VEC_ELS(linklet->bodies)[i], ui, 0); + if (!b) return_NULL; + SCHEME_VEC_ELS(bs)[i] = b; + } + len = scheme_list_length(ui->definitions); + ds = ui->definitions; + bs2 = scheme_make_vector(cnt + len, NULL); + for (i = 0; SCHEME_PAIRP(ds); ds = SCHEME_CDR(ds), i++) { + SCHEME_VEC_ELS(bs2)[i] = SCHEME_CAR(ds); + } + for (i = 0; i < cnt; i++) { + SCHEME_VEC_ELS(bs2)[i + len] = SCHEME_VEC_ELS(bs)[i]; + } + + new_linklet->bodies = bs2; + + if (ui->num_extra_toplevels) { + /* Extend defn-name array to extra toplevels: */ + extend_linklet_defns(new_linklet, ui->num_extra_toplevels); + } + + return new_linklet; } Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc, int *_has_cases, - Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, intptr_t ref_phase, - Scheme_Object *from_modidx, Scheme_Object *to_modidx) + Scheme_Linklet *linklet, Scheme_Object *linklet_key, Optimize_Info *opt_info) /* Convert a single function from "resolved" form back to the intermediate representation used by the optimizer. Unresolving can add new items to the intermediate-representation prefix for top levels. */ @@ -4704,43 +4238,12 @@ Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc, int *_has_cases, if (!lam) return_NULL; - ui = new_unresolve_info((Resolve_Prefix *)SCHEME_VEC_ELS(iv)[2], 0); + ui = new_unresolve_info(linklet, linklet_key, opt_info, 0); ui->inlining = 1; - ui->from_modidx = from_modidx; - ui->to_modidx = to_modidx; - ui->new_toplevel_offset = cp->num_toplevels; - ui->comp_prefix = cp; - ui->opt_env = env; - ui->opt_insp = insp; - ui->toplevel_ref_phase = ref_phase; - ui->inline_variants = scheme_null; /* convert an optimized & resolved closure back to compiled form: */ o = unresolve_lambda(lam, ui); - if (o) { - /* Added any toplevels? */ - if (ui->new_toplevels) { - int i; - Scheme_Object *l; - - for (i = ui->new_toplevels->size; i--; ) { - if (ui->new_toplevels->vals[i]) { - scheme_hash_set(cp->toplevels, - ui->new_toplevels->keys[i], - ui->new_toplevels->vals[i]); - cp->num_toplevels++; - } - } - - for (l = ui->inline_variants; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - scheme_hash_set(ui->comp_prefix->inline_variants, - SCHEME_CAR(SCHEME_CAR(l)), - SCHEME_CDR(SCHEME_CAR(l))); - } - } - } - return o; } diff --git a/racket/src/racket/src/salloc.c b/racket/src/racket/src/salloc.c index e7c3b10c52..7d20162aae 100644 --- a/racket/src/racket/src/salloc.c +++ b/racket/src/racket/src/salloc.c @@ -1984,6 +1984,35 @@ static void cons_onto_list(void *p) static int print_all_traced(void *p) { return 1; } +static int record_nth_counter, record_nth_target; +static GC_record_traced_filter_proc record_nth_traced_filter; +static int record_nth_traced(void *p) { + if (!record_nth_traced_filter(p)) + return 0; + record_nth_counter++; + if (record_nth_counter == record_nth_target) { + record_nth_counter = 0; + return 1; + } + return 0; +} + +/* A vector with keywords is interesting, because serialized + syntax-object literals have that shape. */ +static int vector_has_keywords(void *p) +{ + Scheme_Object *vec = (Scheme_Object *)p; + int i; + + for (i = SCHEME_VEC_SIZE(vec); i--; ) { + if (SCHEME_VEC_ELS(vec)[i]) + if (SCHEME_KEYWORDP(SCHEME_VEC_ELS(vec)[i])) + return 1; + } + + return 0; +} + static int traced_buffer_counter, traced_buffer_size; static void **traced_buffer; @@ -1996,7 +2025,8 @@ static int record_traced(void *p) : 512); if (!traced_buffer) REGISTER_SO(traced_buffer); b2 = scheme_malloc(sizeof(void*) * new_size); - memcpy(b2, traced_buffer, sizeof(void*)*traced_buffer_size); + if (traced_buffer) + memcpy(b2, traced_buffer, sizeof(void*)*traced_buffer_size); traced_buffer = b2; traced_buffer_size = new_size; } @@ -2018,6 +2048,16 @@ static int record_traced_and_print_new(void *p) return record_traced(p); } +static char struct_name_to_match[64]; +static int record_if_matching_struct_name(void *p) +{ + Scheme_Struct_Type *stype = ((Scheme_Structure *)p)->stype; + if (!strcmp(SCHEME_SYM_VAL(stype->name), struct_name_to_match)) + return 1; + else + return 0; +} + static void record_allocated_object(void *p, intptr_t size, int tagged, int atomic) { if (tagged) { @@ -2156,33 +2196,23 @@ static void print_tagged_value(const char *prefix, memcpy(t2 + len, buffer, len2 + 1); len += len2; type = t2; - } else if (!scheme_strncmp(type, "#phase, - ((Scheme_Env *)v)->mod_phase, - (((Scheme_Env *)v)->module - ? scheme_write_to_string(((Scheme_Env *)v)->module->modname, NULL) - : "(toplevel)")); - - len2 = strlen(buffer); - t2 = (char *)scheme_malloc_atomic(len + len2 + 1); - memcpy(t2, type, len); - memcpy(t2 + len, buffer, len2 + 1); - len += len2; - type = t2; } else if (!scheme_strncmp(type, "#key; char *t2; int len2; - len2 = SCHEME_SYM_LEN(bsym); + if (SCHEME_FALSEP(bsym)) + len2 = 2; + else + len2 = SCHEME_SYM_LEN(bsym); + t2 = scheme_malloc_atomic(len + len2 + 3); memcpy(t2, type, len); - memcpy(t2 + len + 1, SCHEME_SYM_VAL(bsym), len2); + if (SCHEME_FALSEP(bsym)) + memcpy(t2 + len + 1, "#f", len2); + else + memcpy(t2 + len + 1, SCHEME_SYM_VAL(bsym), len2); t2[len] = '['; t2[len + 1 + len2] = ']'; t2[len + 1 + len2 + 1] = 0; @@ -2304,6 +2334,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) int dump_flags = 0; GC_for_each_found_proc for_each_found = NULL; GC_print_traced_filter_proc maybe_print_traced_filter = NULL; + GC_record_traced_filter_proc record_traced_filter = NULL; # else # define skip_summary 0 # define dump_flags 0 @@ -2323,6 +2354,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) #if defined(MZ_PRECISE_GC) && MZ_PRECISE_GC_TRACE maybe_print_traced_filter = print_all_traced; + record_traced_filter = print_all_traced; #endif #if 0 @@ -2404,7 +2436,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) && SCHEME_SYMBOLP(p[1]) && !strcmp(SCHEME_SYM_VAL(p[1]), "objects")); - for (i = 0; i < maxpos; i++) { + for (i = maxpos; i--; ) { void *tn = scheme_get_type_name_or_null(i); if (tn && !strcmp(tn, s)) { if (just_objects) @@ -2591,7 +2623,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) && SCHEME_SYMBOLP(p[1])) { int i, maxpos; maxpos = scheme_num_types(); - for (i = 0; i < maxpos; i++) { + for (i = maxpos; i--; ) { void *tn; tn = scheme_get_type_name_or_null(i); if (tn && !strcmp(tn, SCHEME_SYM_VAL(p[1]))) { @@ -2619,20 +2651,22 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) maxpos = scheme_num_types(); - for (i = 0; i < maxpos; i++) { + for (i = maxpos; i--; ) { void *tn; tn = scheme_get_type_name_or_null(i); if (tn && !strcmp(tn, s)) { trace_for_tag = i; dump_flags |= GC_DUMP_SHOW_TRACE; - if ((c > 1) - && SCHEME_SYMBOLP(p[1]) - && !strcmp(SCHEME_SYM_VAL(p[1]), "new")) - maybe_print_traced_filter = record_traced_and_print_new; - break; + break; } } + if (!strcmp("kw-vec", s)) { + trace_for_tag = scheme_vector_type; + dump_flags |= GC_DUMP_SHOW_TRACE; + record_traced_filter = vector_has_keywords; + } + if (!strcmp("fnl", s)) dump_flags |= GC_DUMP_SHOW_FINALS; @@ -2671,6 +2705,17 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) scheme_end_atomic(); return scheme_make_integer_value((intptr_t)p[1]); } + } else if (c + && SCHEME_PAIRP(p[0]) + && SCHEME_PAIRP(SCHEME_CDR(p[0])) + && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(p[0]))) + && SCHEME_SYMBOLP(SCHEME_CAR(p[0])) + && SCHEME_SYMBOLP(SCHEME_CADR(p[0])) + && !strcmp(SCHEME_SYM_VAL(SCHEME_CAR(p[0])), "struct")) { + trace_for_tag = scheme_structure_type; + dump_flags |= GC_DUMP_SHOW_TRACE; + record_traced_filter = record_if_matching_struct_name; + strncpy(struct_name_to_match, SCHEME_SYM_VAL(SCHEME_CADR(p[0])), sizeof(struct_name_to_match)); } else if (c && SCHEME_INTP(p[0])) { trace_for_tag = SCHEME_INT_VAL(p[0]); dump_flags |= GC_DUMP_SHOW_TRACE; @@ -2703,13 +2748,25 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) return scheme_void; } - if ((c > 1) && SCHEME_INTP(p[1])) + + if ((c > 1) + && SCHEME_SYMBOLP(p[1]) + && !strcmp(SCHEME_SYM_VAL(p[1]), "new")) + maybe_print_traced_filter = record_traced_and_print_new; + else if ((c > 1) && SCHEME_INTP(p[1])) path_length_limit = SCHEME_INT_VAL(p[1]); else if ((c > 1) && SCHEME_SYMBOLP(p[1]) && !strcmp("cons", SCHEME_SYM_VAL(p[1]))) { for_each_found = cons_onto_list; cons_accum_result = scheme_null; dump_flags -= (dump_flags & GC_DUMP_SHOW_TRACE); } + + if ((c > 2) && SCHEME_INTP(p[2])) { + record_nth_target = SCHEME_INT_VAL(p[2]); + record_nth_counter = 0; + record_nth_traced_filter = record_traced_filter; + record_traced_filter = record_nth_traced; + } #endif if (!skip_summary) @@ -2720,6 +2777,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) scheme_get_type_name_or_null, for_each_found, trace_for_tag, trace_for_tag, + record_traced_filter, maybe_print_traced_filter, print_tagged_value, path_length_limit, @@ -2732,6 +2790,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) #if MZ_PRECISE_GC_TRACE if (for_each_struct) { scheme_console_printf("Begin Struct\n"); + cons_accum_result = scheme_add_builtin_struct_types(cons_accum_result); while (SCHEME_PAIRP(cons_accum_result)) { Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_CAR(cons_accum_result); if (stype->total_instance_count) { @@ -2795,11 +2854,11 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) } scheme_console_printf("Begin Help\n"); - scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n"); - scheme_console_printf(" Examples: (dump-memory-stats '), (dump-memory-stats 'frame).\n"); - scheme_console_printf(" If sym is 'stack, prints paths to thread stacks.\n"); - scheme_console_printf(" (dump-memory-stats sym 'objects) - prints all instances of type named by sym.\n"); - scheme_console_printf(" (dump-memory-stats sym 'from from-v) - prints paths, paths through from-v first.\n"); + scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym\n"); + scheme_console_printf(" Examples: (dump-memory-stats '), (dump-memory-stats 'frame)\n"); + scheme_console_printf(" If sym is 'stack, prints paths to thread stacks\n"); + scheme_console_printf(" (dump-memory-stats sym 'objects) - prints all instances of type named by sym\n"); + scheme_console_printf(" (dump-memory-stats sym 'from from-v) - prints paths, paths through from-v first\n"); scheme_console_printf("End Help\n"); if (obj_type >= 0) { @@ -2813,22 +2872,28 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) if (!skip_summary) { #ifdef MZ_PRECISE_GC scheme_console_printf("Begin Help\n"); - scheme_console_printf(" (dump-memory-stats 'count sym) - return number of instances of type named by sym.\n"); +# if MZ_PRECISE_GC_TRACE + scheme_console_printf(" (dump-memory-stats 'struct) - show counts for specific structure types\n"); + scheme_console_printf(" (dump-memory-stats spec) - prints path to instances, where spec is\n"); + scheme_console_printf(" sym : prints paths to objects of type named by sym\n"); + scheme_console_printf(" Example: (dump-memory-stats ')\n"); + scheme_console_printf(" num : prints paths to objects with tag num\n"); + scheme_console_printf(" -num : prints paths to objects of size num\n"); + scheme_console_printf(" (list 'struct sym) : print paths to structs of type named by sym\n"); + scheme_console_printf(" ** Backtraces depend on the most recent major GC **\n"); + scheme_console_printf(" (dump-memory-stats spec 'new) - show only objects new since last dump\n"); + scheme_console_printf(" (dump-memory-stats spec num) - limits backtrace path length to num\n"); + scheme_console_printf(" (dump-memory-stats spec 'cons) - builds list instead of showing paths\n"); + scheme_console_printf(" (dump-memory-stats spec any num) - record only each numth object\n"); +#endif + scheme_console_printf(" (dump-memory-stats 'count sym) - return number of instances of type named by sym\n"); scheme_console_printf(" Example: (dump-memory-stats 'count ')\n"); # if MZ_PRECISE_GC_TRACE - scheme_console_printf(" (dump-memory-stats sym ['new]) - prints paths to instances of type named by sym.\n"); - scheme_console_printf(" Example: (dump-memory-stats ')\n"); - scheme_console_printf(" If 'new, all will be retrined, only new paths will be shown\n"); - scheme_console_printf(" (dump-memory-stats 'struct) - show counts for specific structure types.\n"); - scheme_console_printf(" (dump-memory-stats 'fnl) - prints not-yet-finalized objects.\n"); - scheme_console_printf(" (dump-memory-stats num) - prints paths to objects with tag num.\n"); - scheme_console_printf(" (dump-memory-stats -num) - prints paths to objects of size num.\n"); - scheme_console_printf(" (dump-memory-stats sym/num len) - limits path to size len.\n"); - scheme_console_printf(" (dump-memory-stats sym/num 'cons) - builds list instead of showing paths.\n"); - scheme_console_printf(" (dump-memory-stats 'peek num v) - returns value if num is address of object, v otherwise.\n"); - scheme_console_printf(" (dump-memory-stats 'next v) - next tagged object after v, #f if none; start with #f.\n"); - scheme_console_printf(" (dump-memory-stats 'addr v) - returns the address of v.\n"); - scheme_console_printf(" (dump-memory-stats thread) - shows information about the thread.\n"); + scheme_console_printf(" (dump-memory-stats 'peek num v) - returns value if num is address of object, else v\n"); + scheme_console_printf(" (dump-memory-stats 'fnl) - prints not-yet-finalized objects\n"); + scheme_console_printf(" (dump-memory-stats 'next v) - next tagged object after v, #f if none; start with #f\n"); + scheme_console_printf(" (dump-memory-stats 'addr v) - returns the address of v\n"); + scheme_console_printf(" (dump-memory-stats thread) - shows information about the thread\n"); # endif scheme_console_printf("End Help\n"); #endif @@ -3208,33 +3273,6 @@ intptr_t scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht) } } break; - case scheme_namespace_type: - { - Scheme_Env *env = (Scheme_Env *)root; - - s = sizeof(Scheme_Env); -#if FORCE_KNOWN_SUBPARTS - e = COUNT(env->toplevel); -#endif - } - break; - case scheme_config_type: - { - s = sizeof(Scheme_Config) + (sizeof(Scheme_Object *) * __MZCONFIG_BUILTIN_COUNT__); -#if FORCE_SUBPARTS - { - Scheme_Config *c = (Scheme_Config *)root; - int i; - - e = COUNT(c->extensions) + COUNT(c->base); - - for (i = 0; i < __MZCONFIG_BUILTIN_COUNT__; i++) { - e += COUNT(*c->configs[i]); - } - } -#endif - } - break; case scheme_proc_struct_type: case scheme_structure_type: { @@ -3266,9 +3304,6 @@ intptr_t scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht) case scheme_sema_type: s = sizeof(Scheme_Sema); break; - case scheme_compilation_top_type: - s = sizeof(Scheme_Compilation_Top); - break; case scheme_hash_table_type: { Scheme_Hash_Table *ht = (Scheme_Hash_Table *)root; diff --git a/racket/src/racket/src/schcpt.h b/racket/src/racket/src/schcpt.h index b6026b206d..bf8c184d14 100644 --- a/racket/src/racket/src/schcpt.h +++ b/racket/src/racket/src/schcpt.h @@ -18,10 +18,9 @@ enum { CPT_LIST, CPT_VECTOR, CPT_HASH_TABLE, - CPT_STX, CPT_LET_ONE_TYPED, - CPT_MARSHALLED, /* 20 */ - CPT_QUOTE, + CPT_LINKLET, + CPT_QUOTE, /* 20 */ CPT_REFERENCE, CPT_LOCAL, CPT_LOCAL_UNBOX, @@ -29,27 +28,32 @@ enum { CPT_APPLICATION, CPT_LET_ONE, CPT_BRANCH, - CPT_MODULE_INDEX, - CPT_MODULE_VAR, /* 30 */ CPT_PATH, CPT_CLOSURE, - CPT_DELAY_REF, + CPT_DELAY_REF, /* 30 */ CPT_PREFAB, CPT_LET_ONE_UNUSED, - CPT_SCOPE, - CPT_ROOT_SCOPE, CPT_SHARED, + CPT_TOPLEVEL, + CPT_BEGIN, + CPT_BEGIN0, + CPT_LET_VALUE, + CPT_LET_VOID, + CPT_LETREC, + CPT_WCM, /* 40 */ + CPT_DEFINE_VALUES, + CPT_SET_BANG, + CPT_VARREF, + CPT_APPLY_VALUES, + CPT_OTHER_FORM, _CPT_COUNT_ }; -#define CPT_SMALL_NUMBER_START 39 -#define CPT_SMALL_NUMBER_END 62 +#define CPT_SMALL_NUMBER_START 46 +#define CPT_SMALL_NUMBER_END 74 -#define CPT_SMALL_SYMBOL_START 62 -#define CPT_SMALL_SYMBOL_END 80 - -#define CPT_SMALL_MARSHALLED_START 80 -#define CPT_SMALL_MARSHALLED_END 92 +#define CPT_SMALL_SYMBOL_START 74 +#define CPT_SMALL_SYMBOL_END 92 #define _SMALL_LIST_MAX_ 50 diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index 895fa6bc55..72cc12c74d 100644 --- a/racket/src/racket/src/schemef.h +++ b/racket/src/racket/src/schemef.h @@ -386,17 +386,6 @@ MZ_EXTERN Scheme_Object *scheme_extract_one_cc_mark_to_tag(Scheme_Object *mark_s /* Internal */ MZ_EXTERN Scheme_Object *scheme_do_eval(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val); - -MZ_EXTERN Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *env, - intptr_t shift, Scheme_Object *modidx); -MZ_EXTERN Scheme_Object *scheme_load_compiled_stx_string(const char *str, intptr_t len); -MZ_EXTERN Scheme_Object *scheme_compiled_stx_symbol(Scheme_Object *stx); - -MZ_EXTERN Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env); -MZ_EXTERN Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int len, Scheme_Env *env, - Scheme_Object *magic_symbol, Scheme_Object *magic_val, - int multi_ok); - MZ_EXTERN void scheme_detach_multple_array(Scheme_Object **a); /*========================================================================*/ @@ -1023,39 +1012,36 @@ MZ_EXTERN Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[]); MZ_EXTERN void scheme_add_global(const char *name, Scheme_Object *val, Scheme_Env *env); MZ_EXTERN void scheme_add_global_symbol(Scheme_Object *name, Scheme_Object *val, - Scheme_Env *env); + Scheme_Env *env); MZ_EXTERN Scheme_Object *scheme_make_envunbox(Scheme_Object *value); MZ_EXTERN Scheme_Object *scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env); MZ_EXTERN Scheme_Bucket *scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env); -MZ_EXTERN Scheme_Bucket *scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env); MZ_EXTERN Scheme_Bucket *scheme_module_bucket(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env); MZ_EXTERN Scheme_Object *scheme_builtin_value(const char *name); /* convenience */ MZ_EXTERN void scheme_set_global_bucket(char *proc, Scheme_Bucket *var, Scheme_Object *val, int set_undef); -MZ_EXTERN void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v); - -MZ_EXTERN void scheme_save_initial_module_set(Scheme_Env *env); MZ_EXTERN Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env); MZ_EXTERN void scheme_finish_primitive_module(Scheme_Env *env); MZ_EXTERN void scheme_set_primitive_module_phaseless(Scheme_Env *env, int phaseless); MZ_EXTERN void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name); MZ_EXTERN Scheme_Object *scheme_make_modidx(Scheme_Object *path, - Scheme_Object *base, - Scheme_Object *resolved); - -MZ_EXTERN Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *env); + Scheme_Object *base, + Scheme_Object *resolved); MZ_EXTERN Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]); +MZ_EXTERN Scheme_Object *scheme_dynamic_require_reader(int argc, Scheme_Object *argv[]); MZ_EXTERN Scheme_Object *scheme_namespace_require(Scheme_Object *); MZ_EXTERN int scheme_is_module_path(Scheme_Object *); +MZ_EXTERN int scheme_is_module_path_index(Scheme_Object *); +MZ_EXTERN int scheme_is_resolved_module_path(Scheme_Object *); MZ_EXTERN Scheme_Object *scheme_datum_to_kernel_stx(Scheme_Object *e); diff --git a/racket/src/racket/src/schemex.h b/racket/src/racket/src/schemex.h index 38aa701a54..e06c96fb02 100644 --- a/racket/src/racket/src/schemex.h +++ b/racket/src/racket/src/schemex.h @@ -300,14 +300,6 @@ Scheme_Object *(*scheme_extract_one_cc_mark_to_tag)(Scheme_Object *mark_set, Scheme_Object *prompt_tag); /* Internal */ Scheme_Object *(*scheme_do_eval)(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val); -Scheme_Object *(*scheme_eval_compiled_stx_string)(Scheme_Object *expr, Scheme_Env *env, - intptr_t shift, Scheme_Object *modidx); -Scheme_Object *(*scheme_load_compiled_stx_string)(const char *str, intptr_t len); -Scheme_Object *(*scheme_compiled_stx_symbol)(Scheme_Object *stx); -Scheme_Object *(*scheme_eval_compiled_sized_string)(const char *str, int len, Scheme_Env *env); -Scheme_Object *(*scheme_eval_compiled_sized_string_with_magic)(const char *str, int len, Scheme_Env *env, - Scheme_Object *magic_symbol, Scheme_Object *magic_val, - int multi_ok); void (*scheme_detach_multple_array)(Scheme_Object **a); /*========================================================================*/ /* memory management */ @@ -845,28 +837,23 @@ Scheme_Object *(*scheme_read_byte_string)(Scheme_Object *port); Scheme_Object *(*scheme_make_namespace)(int argc, Scheme_Object *argv[]); void (*scheme_add_global)(const char *name, Scheme_Object *val, Scheme_Env *env); void (*scheme_add_global_symbol)(Scheme_Object *name, Scheme_Object *val, - Scheme_Env *env); + Scheme_Env *env); Scheme_Object *(*scheme_make_envunbox)(Scheme_Object *value); Scheme_Object *(*scheme_lookup_global)(Scheme_Object *symbol, Scheme_Env *env); Scheme_Bucket *(*scheme_global_bucket)(Scheme_Object *symbol, Scheme_Env *env); -Scheme_Bucket *(*scheme_global_keyword_bucket)(Scheme_Object *symbol, Scheme_Env *env); Scheme_Bucket *(*scheme_module_bucket)(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env); Scheme_Object *(*scheme_builtin_value)(const char *name); /* convenience */ void (*scheme_set_global_bucket)(char *proc, Scheme_Bucket *var, Scheme_Object *val, int set_undef); -void (*scheme_install_macro)(Scheme_Bucket *b, Scheme_Object *v); -void (*scheme_save_initial_module_set)(Scheme_Env *env); -Scheme_Env *(*scheme_primitive_module)(Scheme_Object *name, Scheme_Env *for_env); -void (*scheme_finish_primitive_module)(Scheme_Env *env); -void (*scheme_set_primitive_module_phaseless)(Scheme_Env *env, int phaseless); -void (*scheme_protect_primitive_provide)(Scheme_Env *env, Scheme_Object *name); Scheme_Object *(*scheme_make_modidx)(Scheme_Object *path, - Scheme_Object *base, - Scheme_Object *resolved); -Scheme_Object *(*scheme_apply_for_syntax_in_env)(Scheme_Object *proc, Scheme_Env *env); + Scheme_Object *base, + Scheme_Object *resolved); Scheme_Object *(*scheme_dynamic_require)(int argc, Scheme_Object *argv[]); +Scheme_Object *(*scheme_dynamic_require_reader)(int argc, Scheme_Object *argv[]); Scheme_Object *(*scheme_namespace_require)(Scheme_Object *); int (*scheme_is_module_path)(Scheme_Object *); +int (*scheme_is_module_path_index)(Scheme_Object *); +int (*scheme_is_resolved_module_path)(Scheme_Object *); Scheme_Object *(*scheme_datum_to_kernel_stx)(Scheme_Object *e); int (*scheme_module_is_declared)(Scheme_Object *name, int try_load); /*========================================================================*/ diff --git a/racket/src/racket/src/schemex.inc b/racket/src/racket/src/schemex.inc index ee13468915..2018da2e59 100644 --- a/racket/src/racket/src/schemex.inc +++ b/racket/src/racket/src/schemex.inc @@ -211,11 +211,6 @@ scheme_extension_table->scheme_extract_one_cc_mark = scheme_extract_one_cc_mark; scheme_extension_table->scheme_extract_one_cc_mark_to_tag = scheme_extract_one_cc_mark_to_tag; scheme_extension_table->scheme_do_eval = scheme_do_eval; - scheme_extension_table->scheme_eval_compiled_stx_string = scheme_eval_compiled_stx_string; - scheme_extension_table->scheme_load_compiled_stx_string = scheme_load_compiled_stx_string; - scheme_extension_table->scheme_compiled_stx_symbol = scheme_compiled_stx_symbol; - scheme_extension_table->scheme_eval_compiled_sized_string = scheme_eval_compiled_sized_string; - scheme_extension_table->scheme_eval_compiled_sized_string_with_magic = scheme_eval_compiled_sized_string_with_magic; scheme_extension_table->scheme_detach_multple_array = scheme_detach_multple_array; #ifndef SCHEME_NO_GC # ifndef SCHEME_NO_GC_PROTO @@ -615,21 +610,16 @@ scheme_extension_table->scheme_make_envunbox = scheme_make_envunbox; scheme_extension_table->scheme_lookup_global = scheme_lookup_global; scheme_extension_table->scheme_global_bucket = scheme_global_bucket; - scheme_extension_table->scheme_global_keyword_bucket = scheme_global_keyword_bucket; scheme_extension_table->scheme_module_bucket = scheme_module_bucket; scheme_extension_table->scheme_builtin_value = scheme_builtin_value; scheme_extension_table->scheme_set_global_bucket = scheme_set_global_bucket; - scheme_extension_table->scheme_install_macro = scheme_install_macro; - scheme_extension_table->scheme_save_initial_module_set = scheme_save_initial_module_set; - scheme_extension_table->scheme_primitive_module = scheme_primitive_module; - scheme_extension_table->scheme_finish_primitive_module = scheme_finish_primitive_module; - scheme_extension_table->scheme_set_primitive_module_phaseless = scheme_set_primitive_module_phaseless; - scheme_extension_table->scheme_protect_primitive_provide = scheme_protect_primitive_provide; scheme_extension_table->scheme_make_modidx = scheme_make_modidx; - scheme_extension_table->scheme_apply_for_syntax_in_env = scheme_apply_for_syntax_in_env; scheme_extension_table->scheme_dynamic_require = scheme_dynamic_require; + scheme_extension_table->scheme_dynamic_require_reader = scheme_dynamic_require_reader; scheme_extension_table->scheme_namespace_require = scheme_namespace_require; scheme_extension_table->scheme_is_module_path = scheme_is_module_path; + scheme_extension_table->scheme_is_module_path_index = scheme_is_module_path_index; + scheme_extension_table->scheme_is_resolved_module_path = scheme_is_resolved_module_path; scheme_extension_table->scheme_datum_to_kernel_stx = scheme_datum_to_kernel_stx; scheme_extension_table->scheme_module_is_declared = scheme_module_is_declared; scheme_extension_table->scheme_intern_symbol = scheme_intern_symbol; diff --git a/racket/src/racket/src/schemexm.h b/racket/src/racket/src/schemexm.h index c66d4cc5b1..6c9b61095e 100644 --- a/racket/src/racket/src/schemexm.h +++ b/racket/src/racket/src/schemexm.h @@ -211,11 +211,6 @@ #define scheme_extract_one_cc_mark (scheme_extension_table->scheme_extract_one_cc_mark) #define scheme_extract_one_cc_mark_to_tag (scheme_extension_table->scheme_extract_one_cc_mark_to_tag) #define scheme_do_eval (scheme_extension_table->scheme_do_eval) -#define scheme_eval_compiled_stx_string (scheme_extension_table->scheme_eval_compiled_stx_string) -#define scheme_load_compiled_stx_string (scheme_extension_table->scheme_load_compiled_stx_string) -#define scheme_compiled_stx_symbol (scheme_extension_table->scheme_compiled_stx_symbol) -#define scheme_eval_compiled_sized_string (scheme_extension_table->scheme_eval_compiled_sized_string) -#define scheme_eval_compiled_sized_string_with_magic (scheme_extension_table->scheme_eval_compiled_sized_string_with_magic) #define scheme_detach_multple_array (scheme_extension_table->scheme_detach_multple_array) #ifndef SCHEME_NO_GC # ifndef SCHEME_NO_GC_PROTO @@ -615,21 +610,16 @@ #define scheme_make_envunbox (scheme_extension_table->scheme_make_envunbox) #define scheme_lookup_global (scheme_extension_table->scheme_lookup_global) #define scheme_global_bucket (scheme_extension_table->scheme_global_bucket) -#define scheme_global_keyword_bucket (scheme_extension_table->scheme_global_keyword_bucket) #define scheme_module_bucket (scheme_extension_table->scheme_module_bucket) #define scheme_builtin_value (scheme_extension_table->scheme_builtin_value) #define scheme_set_global_bucket (scheme_extension_table->scheme_set_global_bucket) -#define scheme_install_macro (scheme_extension_table->scheme_install_macro) -#define scheme_save_initial_module_set (scheme_extension_table->scheme_save_initial_module_set) -#define scheme_primitive_module (scheme_extension_table->scheme_primitive_module) -#define scheme_finish_primitive_module (scheme_extension_table->scheme_finish_primitive_module) -#define scheme_set_primitive_module_phaseless (scheme_extension_table->scheme_set_primitive_module_phaseless) -#define scheme_protect_primitive_provide (scheme_extension_table->scheme_protect_primitive_provide) #define scheme_make_modidx (scheme_extension_table->scheme_make_modidx) -#define scheme_apply_for_syntax_in_env (scheme_extension_table->scheme_apply_for_syntax_in_env) #define scheme_dynamic_require (scheme_extension_table->scheme_dynamic_require) +#define scheme_dynamic_require_reader (scheme_extension_table->scheme_dynamic_require_reader) #define scheme_namespace_require (scheme_extension_table->scheme_namespace_require) #define scheme_is_module_path (scheme_extension_table->scheme_is_module_path) +#define scheme_is_module_path_index (scheme_extension_table->scheme_is_module_path_index) +#define scheme_is_resolved_module_path (scheme_extension_table->scheme_is_resolved_module_path) #define scheme_datum_to_kernel_stx (scheme_extension_table->scheme_datum_to_kernel_stx) #define scheme_module_is_declared (scheme_extension_table->scheme_module_is_declared) #define scheme_intern_symbol (scheme_extension_table->scheme_intern_symbol) diff --git a/racket/src/racket/src/schexn.h b/racket/src/racket/src/schexn.h index 4027cee647..138a7160cb 100644 --- a/racket/src/racket/src/schexn.h +++ b/racket/src/racket/src/schexn.h @@ -10,9 +10,6 @@ enum { MZEXN_FAIL_CONTRACT_NON_FIXNUM_RESULT, MZEXN_FAIL_CONTRACT_CONTINUATION, MZEXN_FAIL_CONTRACT_VARIABLE, - MZEXN_FAIL_SYNTAX, - MZEXN_FAIL_SYNTAX_UNBOUND, - MZEXN_FAIL_SYNTAX_MISSING_MODULE, MZEXN_FAIL_READ, MZEXN_FAIL_READ_EOF, MZEXN_FAIL_READ_NON_CHAR, @@ -20,7 +17,6 @@ enum { MZEXN_FAIL_FILESYSTEM_EXISTS, MZEXN_FAIL_FILESYSTEM_VERSION, MZEXN_FAIL_FILESYSTEM_ERRNO, - MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, MZEXN_FAIL_NETWORK, MZEXN_FAIL_NETWORK_ERRNO, MZEXN_FAIL_OUT_OF_MEMORY, @@ -35,7 +31,7 @@ enum { #ifdef _MZEXN_TABLE -#define MZEXN_MAXARGS 4 +#define MZEXN_MAXARGS 3 #ifdef GLOBAL_EXN_ARRAY static exn_rec exn_table[] = { @@ -49,23 +45,19 @@ static exn_rec exn_table[] = { { 3, NULL, NULL, 0, NULL, 2 }, { 3, NULL, NULL, 0, NULL, 1 }, { 3, NULL, NULL, 0, NULL, 8 }, - { 4, NULL, NULL, 0, NULL, 8 }, - { 3, NULL, NULL, 0, NULL, 1 }, - { 3, NULL, NULL, 0, NULL, 11 }, + { 3, NULL, NULL, 0, NULL, 8 }, + { 2, NULL, NULL, 0, NULL, 1 }, + { 2, NULL, NULL, 0, NULL, 11 }, + { 2, NULL, NULL, 0, NULL, 11 }, { 3, NULL, NULL, 0, NULL, 11 }, { 2, NULL, NULL, 0, NULL, 1 }, - { 2, NULL, NULL, 0, NULL, 14 }, - { 2, NULL, NULL, 0, NULL, 14 }, - { 3, NULL, NULL, 0, NULL, 14 }, - { 3, NULL, NULL, 0, NULL, 14 }, - { 2, NULL, NULL, 0, NULL, 1 }, - { 3, NULL, NULL, 0, NULL, 19 }, + { 3, NULL, NULL, 0, NULL, 15 }, { 2, NULL, NULL, 0, NULL, 1 }, { 2, NULL, NULL, 0, NULL, 1 }, { 2, NULL, NULL, 0, NULL, 1 }, { 3, NULL, NULL, 0, NULL, 0 }, - { 3, NULL, NULL, 0, NULL, 24 }, - { 3, NULL, NULL, 0, NULL, 24 } + { 3, NULL, NULL, 0, NULL, 20 }, + { 3, NULL, NULL, 0, NULL, 20 } }; #else static exn_rec *exn_table; @@ -85,9 +77,6 @@ static exn_rec *exn_table; exn_table[MZEXN_FAIL_CONTRACT_NON_FIXNUM_RESULT].args = 2; exn_table[MZEXN_FAIL_CONTRACT_CONTINUATION].args = 2; exn_table[MZEXN_FAIL_CONTRACT_VARIABLE].args = 3; - exn_table[MZEXN_FAIL_SYNTAX].args = 3; - exn_table[MZEXN_FAIL_SYNTAX_UNBOUND].args = 3; - exn_table[MZEXN_FAIL_SYNTAX_MISSING_MODULE].args = 4; exn_table[MZEXN_FAIL_READ].args = 3; exn_table[MZEXN_FAIL_READ_EOF].args = 3; exn_table[MZEXN_FAIL_READ_NON_CHAR].args = 3; @@ -95,7 +84,6 @@ static exn_rec *exn_table; exn_table[MZEXN_FAIL_FILESYSTEM_EXISTS].args = 2; exn_table[MZEXN_FAIL_FILESYSTEM_VERSION].args = 2; exn_table[MZEXN_FAIL_FILESYSTEM_ERRNO].args = 3; - exn_table[MZEXN_FAIL_FILESYSTEM_MISSING_MODULE].args = 3; exn_table[MZEXN_FAIL_NETWORK].args = 2; exn_table[MZEXN_FAIL_NETWORK_ERRNO].args = 3; exn_table[MZEXN_FAIL_OUT_OF_MEMORY].args = 2; @@ -111,48 +99,38 @@ static exn_rec *exn_table; #ifdef _MZEXN_DECL_FIELDS static const char *MZEXN_FIELDS[2] = { "message", "continuation-marks" }; static const char *MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS[1] = { "id" }; - static const char *MZEXN_FAIL_SYNTAX_FIELDS[1] = { "exprs" }; - static const char *MZEXN_FAIL_SYNTAX_MISSING_MODULE_FIELDS[1] = { "path" }; static const char *MZEXN_FAIL_READ_FIELDS[1] = { "srclocs" }; static const char *MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS[1] = { "errno" }; - static const char *MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_FIELDS[1] = { "path" }; static const char *MZEXN_FAIL_NETWORK_ERRNO_FIELDS[1] = { "errno" }; static const char *MZEXN_BREAK_FIELDS[1] = { "continuation" }; #endif #ifdef _MZEXN_DECL_PROPS -# define MZEXN_FAIL_SYNTAX_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim(extract_syntax_locations)), scheme_null) -# define MZEXN_FAIL_SYNTAX_MISSING_MODULE_PROPS scheme_make_pair(scheme_make_pair(scheme_module_path_property, scheme_make_prim(extract_module_path_3)), scheme_null) -# define MZEXN_FAIL_READ_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim(extract_read_locations)), scheme_null) -# define MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_PROPS scheme_make_pair(scheme_make_pair(scheme_module_path_property, scheme_make_prim(extract_module_path_2)), scheme_null) +# define MZEXN_FAIL_READ_PROPS scheme_make_pair(scheme_make_pair(scheme_source_property, scheme_make_prim_w_arity(extract_read_locations, "extract_read_locations", 0, -1)), scheme_null) #endif #ifdef _MZEXN_SETUP - SETUP_STRUCT(MZEXN, NULL, "exn", 2, MZEXN_FIELDS, scheme_null, scheme_make_prim(exn_field_check)) + SETUP_STRUCT(MZEXN, NULL, "exn", 2, MZEXN_FIELDS, scheme_null, scheme_make_prim_w_arity(exn_field_check, "exn_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL, EXN_PARENT(MZEXN), "exn:fail", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT, EXN_PARENT(MZEXN_FAIL), "exn:fail:contract", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_ARITY, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:arity", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:divide-by-zero", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_NON_FIXNUM_RESULT, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:non-fixnum-result", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_CONTRACT_CONTINUATION, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:continuation", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_CONTRACT_VARIABLE, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:variable", 1, MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS, scheme_null, scheme_make_prim(variable_field_check)) - SETUP_STRUCT(MZEXN_FAIL_SYNTAX, EXN_PARENT(MZEXN_FAIL), "exn:fail:syntax", 1, MZEXN_FAIL_SYNTAX_FIELDS, MZEXN_FAIL_SYNTAX_PROPS, scheme_make_prim(syntax_field_check)) - SETUP_STRUCT(MZEXN_FAIL_SYNTAX_UNBOUND, EXN_PARENT(MZEXN_FAIL_SYNTAX), "exn:fail:syntax:unbound", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_SYNTAX_MISSING_MODULE, EXN_PARENT(MZEXN_FAIL_SYNTAX), "exn:fail:syntax:missing-module", 1, MZEXN_FAIL_SYNTAX_MISSING_MODULE_FIELDS, MZEXN_FAIL_SYNTAX_MISSING_MODULE_PROPS, scheme_make_prim(module_path_field_check_3)) - SETUP_STRUCT(MZEXN_FAIL_READ, EXN_PARENT(MZEXN_FAIL), "exn:fail:read", 1, MZEXN_FAIL_READ_FIELDS, MZEXN_FAIL_READ_PROPS, scheme_make_prim(read_field_check)) + SETUP_STRUCT(MZEXN_FAIL_CONTRACT_VARIABLE, EXN_PARENT(MZEXN_FAIL_CONTRACT), "exn:fail:contract:variable", 1, MZEXN_FAIL_CONTRACT_VARIABLE_FIELDS, scheme_null, scheme_make_prim_w_arity(variable_field_check, "variable_field_check" , 0, -1)) + SETUP_STRUCT(MZEXN_FAIL_READ, EXN_PARENT(MZEXN_FAIL), "exn:fail:read", 1, MZEXN_FAIL_READ_FIELDS, MZEXN_FAIL_READ_PROPS, scheme_make_prim_w_arity(read_field_check, "read_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL_READ_EOF, EXN_PARENT(MZEXN_FAIL_READ), "exn:fail:read:eof", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_READ_NON_CHAR, EXN_PARENT(MZEXN_FAIL_READ), "exn:fail:read:non-char", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM, EXN_PARENT(MZEXN_FAIL), "exn:fail:filesystem", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_EXISTS, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:exists", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_VERSION, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:version", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_ERRNO, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:errno", 1, MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS, scheme_null, scheme_make_prim(errno_field_check)) - SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_MISSING_MODULE, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:missing-module", 1, MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_FIELDS, MZEXN_FAIL_FILESYSTEM_MISSING_MODULE_PROPS, scheme_make_prim(module_path_field_check_2)) + SETUP_STRUCT(MZEXN_FAIL_FILESYSTEM_ERRNO, EXN_PARENT(MZEXN_FAIL_FILESYSTEM), "exn:fail:filesystem:errno", 1, MZEXN_FAIL_FILESYSTEM_ERRNO_FIELDS, scheme_null, scheme_make_prim_w_arity(errno_field_check, "errno_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL_NETWORK, EXN_PARENT(MZEXN_FAIL), "exn:fail:network", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_FAIL_NETWORK_ERRNO, EXN_PARENT(MZEXN_FAIL_NETWORK), "exn:fail:network:errno", 1, MZEXN_FAIL_NETWORK_ERRNO_FIELDS, scheme_null, scheme_make_prim(errno_field_check)) + SETUP_STRUCT(MZEXN_FAIL_NETWORK_ERRNO, EXN_PARENT(MZEXN_FAIL_NETWORK), "exn:fail:network:errno", 1, MZEXN_FAIL_NETWORK_ERRNO_FIELDS, scheme_null, scheme_make_prim_w_arity(errno_field_check, "errno_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_FAIL_OUT_OF_MEMORY, EXN_PARENT(MZEXN_FAIL), "exn:fail:out-of-memory", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_UNSUPPORTED, EXN_PARENT(MZEXN_FAIL), "exn:fail:unsupported", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_FAIL_USER, EXN_PARENT(MZEXN_FAIL), "exn:fail:user", 0, NULL, scheme_null, NULL) - SETUP_STRUCT(MZEXN_BREAK, EXN_PARENT(MZEXN), "exn:break", 1, MZEXN_BREAK_FIELDS, scheme_null, scheme_make_prim(break_field_check)) + SETUP_STRUCT(MZEXN_BREAK, EXN_PARENT(MZEXN), "exn:break", 1, MZEXN_BREAK_FIELDS, scheme_null, scheme_make_prim_w_arity(break_field_check, "break_field_check" , 0, -1)) SETUP_STRUCT(MZEXN_BREAK_HANG_UP, EXN_PARENT(MZEXN_BREAK), "exn:break:hang-up", 0, NULL, scheme_null, NULL) SETUP_STRUCT(MZEXN_BREAK_TERMINATE, EXN_PARENT(MZEXN_BREAK), "exn:break:terminate", 0, NULL, scheme_null, NULL) #endif diff --git a/racket/src/racket/src/schexpobs.h b/racket/src/racket/src/schexpobs.h deleted file mode 100644 index 65b4564644..0000000000 --- a/racket/src/racket/src/schexpobs.h +++ /dev/null @@ -1,204 +0,0 @@ - -#ifndef __mzscheme_expobs__ -#define __mzscheme_expobs__ - -#define SCHEME_EXPAND_OBSERVE_ENABLE - -extern void scheme_call_expand_observe(Scheme_Object *obs, int signal, Scheme_Object *argument); -extern Scheme_Object *scheme_expand_observe_renames(Scheme_Object *env_pair); -extern void scheme_init_expand_observe(Scheme_Env *); -extern Scheme_Object *scheme_get_expand_observe(); - - -#ifdef SCHEME_EXPAND_OBSERVE_ENABLE -# define _SCHEME_EXPOBS(observer, signal, argument) \ - if (observer) { scheme_call_expand_observe(observer, signal, argument); } else {} -#endif - -#ifndef SCHEME_EXPAND_OBSERVE_ENABLE -#define _SCHEME_EXPOBS(observer, signal, argument) \ - ((void)0) -#endif - -/* Individual signals */ - -#define SCHEME_EXPAND_OBSERVE_VISIT(observer,stx) _SCHEME_EXPOBS(observer,0,stx) -#define SCHEME_EXPAND_OBSERVE_RESOLVE(observer,stx) _SCHEME_EXPOBS(observer,1,stx) -#define SCHEME_EXPAND_OBSERVE_RETURN(observer,stx) _SCHEME_EXPOBS(observer,2,stx) -#define SCHEME_EXPAND_OBSERVE_NEXT(observer) _SCHEME_EXPOBS(observer,3,NULL) -#define SCHEME_EXPAND_OBSERVE_ENTER_LIST(observer,stx) _SCHEME_EXPOBS(observer,4,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_LIST(observer,stx) _SCHEME_EXPOBS(observer,5,stx) -#define SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer,stx) _SCHEME_EXPOBS(observer,6,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,stx) _SCHEME_EXPOBS(observer,7,stx) -#define SCHEME_EXPAND_OBSERVE_ENTER_MACRO(observer,stx) _SCHEME_EXPOBS(observer,8,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_MACRO(observer,stx) _SCHEME_EXPOBS(observer,9,stx) -#define SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(observer,stx) _SCHEME_EXPOBS(observer,10,stx) -#define SCHEME_EXPAND_OBSERVE_SPLICE(observer,stx) _SCHEME_EXPOBS(observer,11,stx) -#define SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(observer,stx) _SCHEME_EXPOBS(observer,12,stx) -#define SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer) _SCHEME_EXPOBS(observer,13,NULL) -#define SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(observer,stx) _SCHEME_EXPOBS(observer,14,stx) -#define SCHEME_EXPAND_OBSERVE_LET_RENAMES(observer,vars,body) \ - _SCHEME_EXPOBS(observer,16, scheme_make_pair(vars, body)) -#define SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(observer,vars,body) \ - _SCHEME_EXPOBS(observer,17, scheme_make_pair(vars, body)) -#define SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(observer,vars,body) \ - _SCHEME_EXPOBS(observer,18, scheme_make_pair(vars, body)) -#define SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(observer,sbinds,vbinds,body) \ - _SCHEME_EXPOBS(observer,19, scheme_make_pair(sbinds, scheme_make_pair(vbinds, body))) -#define SCHEME_EXPAND_OBSERVE_PHASE_UP(observer) _SCHEME_EXPOBS(observer,20,NULL) - -#define SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(observer,stx) _SCHEME_EXPOBS(observer,21,stx) -#define SCHEME_EXPAND_OBSERVE_MACRO_POST_X(observer,stx,orig_stx) \ - _SCHEME_EXPOBS(observer,22,scheme_make_pair(stx, orig_stx)) - -#define SCHEME_EXPAND_OBSERVE_MODULE_BODY(observer,list) _SCHEME_EXPOBS(observer,23,list) -#define SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(observer,old,new) \ - _SCHEME_EXPOBS(observer,24, scheme_make_pair(old, new)) - -/* Prim signals */ -#define SCHEME_EXPAND_OBSERVE_PRIM_STOP(observer) \ - _SCHEME_EXPOBS(observer,100,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_MODULE(observer) \ - _SCHEME_EXPOBS(observer,101,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(observer) \ - _SCHEME_EXPOBS(observer,102,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer) \ - _SCHEME_EXPOBS(observer,103,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer) \ - _SCHEME_EXPOBS(observer,104,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_IF(observer) \ - _SCHEME_EXPOBS(observer,105,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_WCM(observer) \ - _SCHEME_EXPOBS(observer,106,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(observer) \ - _SCHEME_EXPOBS(observer,107,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(observer) \ - _SCHEME_EXPOBS(observer,108,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_APP(observer) \ - _SCHEME_EXPOBS(observer,109,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(observer) \ - _SCHEME_EXPOBS(observer,110,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(observer) \ - _SCHEME_EXPOBS(observer,111,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(observer) \ - _SCHEME_EXPOBS(observer,112,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(observer) \ - _SCHEME_EXPOBS(observer,113,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(observer) \ - _SCHEME_EXPOBS(observer,114,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_DATUM(observer) \ - _SCHEME_EXPOBS(observer,115,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_TOP(observer) \ - _SCHEME_EXPOBS(observer,116,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(observer) \ - _SCHEME_EXPOBS(observer,117,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(observer) \ - _SCHEME_EXPOBS(observer,118,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer) \ - _SCHEME_EXPOBS(observer,119,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_SYNTAX(observer) \ - _SCHEME_EXPOBS(observer,120,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(observer) \ - _SCHEME_EXPOBS(observer,121,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer) \ - _SCHEME_EXPOBS(observer,122,NULL) - -#define SCHEME_EXPAND_OBSERVE_PRIM_SET(observer) \ - _SCHEME_EXPOBS(observer,123,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(observer) \ - _SCHEME_EXPOBS(observer,124,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(obs) \ - _SCHEME_EXPOBS(obs,138,scheme_false) -#define SCHEME_EXPAND_OBSERVE_PRIM_VARREF(obs) \ - _SCHEME_EXPOBS(obs,149,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(observer) \ - _SCHEME_EXPOBS(observer,155,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer) \ - _SCHEME_EXPOBS(observer,156,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer) \ - _SCHEME_EXPOBS(observer,158,scheme_false) -#define SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer) \ - _SCHEME_EXPOBS(observer,159,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \ - _SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2)) - -#define SCHEME_EXPAND_OBSERVE_ENTER_CHECK(observer,stx) \ - _SCHEME_EXPOBS(observer,126,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_CHECK(observer,stx) \ - _SCHEME_EXPOBS(observer,127,stx) - -#define SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,stx) \ - _SCHEME_EXPOBS(observer,128,stx) -#define SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(observer,stx) \ - _SCHEME_EXPOBS(observer,136,stx) -#define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer,stxs) \ - _SCHEME_EXPOBS(observer,137,stxs) -#define SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer,stx) \ - _SCHEME_EXPOBS(observer,135,stx) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(obs,ids,stx) \ - _SCHEME_EXPOBS(obs,129,scheme_make_pair(ids,stx)) -#define SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(obs,stx) \ - _SCHEME_EXPOBS(obs,134,stx) -#define SCHEME_EXPAND_OBSERVE_LIFT_REQUIRE(obs,req,form,mform) \ - _SCHEME_EXPOBS(obs,150,scheme_make_pair(req,scheme_make_pair(form,mform))) -#define SCHEME_EXPAND_OBSERVE_LIFT_PROVIDE(obs,form) \ - _SCHEME_EXPOBS(obs,151,form) - -#define SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(obs,stx) \ - _SCHEME_EXPOBS(obs,130,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(obs,stx) \ - _SCHEME_EXPOBS(obs,131,stx) -#define SCHEME_EXPAND_OBSERVE_LOCAL_PRE(obs,stx) \ - _SCHEME_EXPOBS(obs,132,stx) -#define SCHEME_EXPAND_OBSERVE_LOCAL_POST(obs,stx) \ - _SCHEME_EXPOBS(obs,133,stx) - -#define SCHEME_EXPAND_OBSERVE_ENTER_LOCAL_EXPR(obs,stx) \ - _SCHEME_EXPOBS(obs,139,stx) -#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_EXPR(obs,stx,opaque) \ - _SCHEME_EXPOBS(obs,140,scheme_make_pair(stx,opaque)) - -#define SCHEME_EXPAND_OBSERVE_START_EXPAND(obs) \ - _SCHEME_EXPOBS(obs,141,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_TAG(obs,stx) \ - _SCHEME_EXPOBS(obs,142,stx) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_BIND(obs,ids) \ - _SCHEME_EXPOBS(obs,143,ids) -#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_BIND(obs) \ - _SCHEME_EXPOBS(obs,160,scheme_false); -#define SCHEME_EXPAND_OBSERVE_ENTER_BIND(obs) \ - _SCHEME_EXPOBS(obs,144,scheme_false) -#define SCHEME_EXPAND_OBSERVE_EXIT_BIND(obs) \ - _SCHEME_EXPOBS(obs,145,scheme_false) - -#define SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(obs,val) \ - _SCHEME_EXPOBS(obs,146,val) - -#define SCHEME_EXPAND_OBSERVE_RENAME_LIST(obs,vals) \ - _SCHEME_EXPOBS(obs,147,vals) - -#define SCHEME_EXPAND_OBSERVE_RENAME_ONE(obs,val) \ - _SCHEME_EXPOBS(obs,148,val) - -#define SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(obs,pre,post) \ - _SCHEME_EXPOBS(obs,152,scheme_make_pair(pre,post)) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE(obs,id) \ - _SCHEME_EXPOBS(obs,153,id) - -#define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(obs,bound) \ - _SCHEME_EXPOBS(obs,154,bound) - -#define SCHEME_EXPAND_OBSERVE_PREPARE_ENV(obs) \ - _SCHEME_EXPOBS(obs,157,scheme_false) - -/* next: 161 */ - -#endif diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index cbec9f218f..6507b7fd6e 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -14,24 +14,9 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1162 -#define EXPECTED_UNSAFE_COUNT 162 -#define EXPECTED_FLFXNUM_COUNT 69 -#define EXPECTED_EXTFL_COUNT 45 -#define EXPECTED_FUTURES_COUNT 15 -#define EXPECTED_FOREIGN_COUNT 79 +#define EXPECTED_PRIM_COUNT 1430 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP # define USE_COMPILED_STARTUP 0 #endif - -#if defined(__MWERKS__) && !defined(powerc) -#define MZCOMPILED_STRING_FAR far -#else -#define MZCOMPILED_STRING_FAR /**/ -#endif - -#if USE_COMPILED_STARTUP -extern Scheme_Object *scheme_eval_compiled_sized_string(const char *str, int len, Scheme_Env *env); -#endif diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 2b5456ba6a..a470b8447f 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -123,8 +123,13 @@ /* indicates a primitive that produces a real number when given real-number arguments: */ #define SCHEME_PRIM_CLOSED_ON_REALS (1 << 21) +/* indicates the presence of an ad-hoc optimization + in one of the application optimization passes */ +#define SCHEME_PRIM_AD_HOC_OPT (1 << 22) +/* a primitive that produces a booeal or errors: */ +#define SCHEME_PRIM_PRODUCES_BOOL (1 << 23) -#define SCHEME_PRIM_OPT_TYPE_SHIFT 22 +#define SCHEME_PRIM_OPT_TYPE_SHIFT 24 #define SCHEME_PRIM_OPT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_PRIM_OPT_TYPE_SHIFT) #define SCHEME_PRIM_OPT_TYPE(x) ((x & SCHEME_PRIM_OPT_TYPE_MASK) >> SCHEME_PRIM_OPT_TYPE_SHIFT) @@ -300,6 +305,8 @@ void scheme_clear_ephemerons(void); THREAD_LOCAL_DECL(extern int scheme_starting_up); +typedef struct Scheme_Startup_Env Scheme_Startup_Env; + void scheme_init_finalization(void); void scheme_init_portable_case(void); void scheme_init_stack_check(void); @@ -315,7 +322,7 @@ Scheme_Thread *scheme_make_thread(void*); void scheme_init_process_globals(void); void scheme_init_true_false(void); void scheme_init_symbol_table(void); -void scheme_init_symbol_type(Scheme_Env *env); +void scheme_init_symbol_type(Scheme_Startup_Env *env); void scheme_init_type(); void scheme_init_custodian_extractors(); void scheme_init_bignum(); @@ -328,68 +335,68 @@ void scheme_init_validate(); void scheme_init_port_wait(); void scheme_init_logger_wait(); void scheme_init_struct_wait(); -void scheme_init_list(Scheme_Env *env); -void scheme_init_unsafe_list(Scheme_Env *env); -void scheme_init_unsafe_hash(Scheme_Env *env); -void scheme_init_stx(Scheme_Env *env); -void scheme_init_module(Scheme_Env *env); +void scheme_init_list(Scheme_Startup_Env *env); +void scheme_init_unsafe_list(Scheme_Startup_Env *env); +void scheme_init_unsafe_hash(Scheme_Startup_Env *env); +void scheme_init_stx(Scheme_Startup_Env *env); +void scheme_init_module(Scheme_Startup_Env *env); void scheme_init_module_path_table(void); -void scheme_init_port(Scheme_Env *env); -void scheme_init_port_fun(Scheme_Env *env); -void scheme_init_network(Scheme_Env *env); -void scheme_init_file(Scheme_Env *env); -void scheme_init_proc(Scheme_Env *env); -void scheme_init_vector(Scheme_Env *env); -void scheme_init_unsafe_vector(Scheme_Env *env); -void scheme_init_string(Scheme_Env *env); -void scheme_init_number(Scheme_Env *env); -void scheme_init_flfxnum_number(Scheme_Env *env); -void scheme_init_extfl_number(Scheme_Env *env); -void scheme_init_unsafe_number(Scheme_Env *env); -void scheme_init_extfl_unsafe_number(Scheme_Env *env); -void scheme_init_numarith(Scheme_Env *env); -void scheme_init_flfxnum_numarith(Scheme_Env *env); -void scheme_init_extfl_numarith(Scheme_Env *env); -void scheme_init_unsafe_numarith(Scheme_Env *env); -void scheme_init_extfl_unsafe_numarith(Scheme_Env *env); -void scheme_init_numcomp(Scheme_Env *env); -void scheme_init_flfxnum_numcomp(Scheme_Env *env); -void scheme_init_extfl_numcomp(Scheme_Env *env); -void scheme_init_unsafe_numcomp(Scheme_Env *env); -void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env); -void scheme_init_numstr(Scheme_Env *env); -void scheme_init_extfl_numstr(Scheme_Env *env); -void scheme_init_eval(Scheme_Env *env); -void scheme_init_promise(Scheme_Env *env); -void scheme_init_struct(Scheme_Env *env); -void scheme_init_reduced_proc_struct(Scheme_Env *env); -void scheme_init_fun(Scheme_Env *env); -void scheme_init_unsafe_fun(Scheme_Env *env); -void scheme_init_compile(Scheme_Env *env); -void scheme_init_symbol(Scheme_Env *env); +void scheme_init_port(Scheme_Startup_Env *env); +void scheme_init_port_fun(Scheme_Startup_Env *env); +void scheme_init_network(Scheme_Startup_Env *env); +void scheme_init_file(Scheme_Startup_Env *env); +void scheme_init_proc(Scheme_Startup_Env *env); +void scheme_init_vector(Scheme_Startup_Env *env); +void scheme_init_unsafe_vector(Scheme_Startup_Env *env); +void scheme_init_string(Scheme_Startup_Env *env); +void scheme_init_number(Scheme_Startup_Env *env); +void scheme_init_flfxnum_number(Scheme_Startup_Env *env); +void scheme_init_extfl_number(Scheme_Startup_Env *env); +void scheme_init_unsafe_number(Scheme_Startup_Env *env); +void scheme_init_extfl_unsafe_number(Scheme_Startup_Env *env); +void scheme_init_numarith(Scheme_Startup_Env *env); +void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env); +void scheme_init_extfl_numarith(Scheme_Startup_Env *env); +void scheme_init_unsafe_numarith(Scheme_Startup_Env *env); +void scheme_init_extfl_unsafe_numarith(Scheme_Startup_Env *env); +void scheme_init_numcomp(Scheme_Startup_Env *env); +void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env); +void scheme_init_extfl_numcomp(Scheme_Startup_Env *env); +void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env); +void scheme_init_extfl_unsafe_numcomp(Scheme_Startup_Env *env); +void scheme_init_numstr(Scheme_Startup_Env *env); +void scheme_init_extfl_numstr(Scheme_Startup_Env *env); +void scheme_init_eval(Scheme_Startup_Env *env); +void scheme_init_promise(Scheme_Startup_Env *env); +void scheme_init_struct(Scheme_Startup_Env *env); +void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env); +void scheme_init_fun(Scheme_Startup_Env *env); +void scheme_init_unsafe_fun(Scheme_Startup_Env *env); +void scheme_init_compile(Scheme_Startup_Env *env); +void scheme_init_symbol(Scheme_Startup_Env *env); void scheme_init_char_constants(void); -void scheme_init_char(Scheme_Env *env); -void scheme_init_bool(Scheme_Env *env); -void scheme_init_syntax(Scheme_Env *env); -void scheme_init_marshal(Scheme_Env *env); -void scheme_init_error(Scheme_Env *env); +void scheme_init_char(Scheme_Startup_Env *env); +void scheme_init_bool(Scheme_Startup_Env *env); +void scheme_init_syntax(Scheme_Startup_Env *env); +void scheme_init_marshal(Scheme_Startup_Env *env); +void scheme_init_error(Scheme_Startup_Env *env); #ifndef NO_SCHEME_EXNS -void scheme_init_exn(Scheme_Env *env); +void scheme_init_exn(Scheme_Startup_Env *env); #endif -void scheme_init_debug(Scheme_Env *env); -void scheme_init_thread(Scheme_Env *env); -void scheme_init_unsafe_thread(Scheme_Env *env); -void scheme_init_unsafe_port(Scheme_Env *env); -void scheme_init_read(Scheme_Env *env); -void scheme_init_print(Scheme_Env *env); +void scheme_init_debug(Scheme_Startup_Env *env); +void scheme_init_thread(Scheme_Startup_Env *env); +void scheme_init_unsafe_port(Scheme_Startup_Env *env); +void scheme_init_unsafe_thread(Scheme_Startup_Env *env); +void scheme_init_read(Scheme_Startup_Env *env); +void scheme_init_print(Scheme_Startup_Env *env); #ifndef NO_SCHEME_THREADS -void scheme_init_sema(Scheme_Env *env); +void scheme_init_sema(Scheme_Startup_Env *env); #endif -void scheme_init_dynamic_extension(Scheme_Env *env); +void scheme_init_dynamic_extension(Scheme_Startup_Env *env); #ifndef NO_REGEXP_UTILS -extern void scheme_regexp_initialize(Scheme_Env *env); +extern void scheme_regexp_initialize(Scheme_Startup_Env *env); #endif -void scheme_init_paramz(Scheme_Env *env); +void scheme_init_paramz(Scheme_Startup_Env *env); void scheme_init_parameterization(); void scheme_init_getenv(void); void scheme_init_inspector(void); @@ -400,18 +407,21 @@ void scheme_init_longdouble_fixup(void); #ifndef DONT_USE_FOREIGN void scheme_init_foreign_globals(); #endif -void scheme_init_foreign(Scheme_Env *env); -void scheme_init_place(Scheme_Env *env); +void scheme_init_foreign(Scheme_Startup_Env *env); +void scheme_init_place(Scheme_Startup_Env *env); +void scheme_init_place_per_place(); void scheme_init_places_once(); -void scheme_init_futures(Scheme_Env *env); +void scheme_init_futures(Scheme_Startup_Env *env); void scheme_init_futures_once(); void scheme_init_futures_per_place(); void scheme_end_futures_per_place(); -void scheme_init_linklet(Scheme_Env *env); +void scheme_init_linklet(Scheme_Startup_Env *env); +void scheme_init_unsafe_linklet(Scheme_Startup_Env *env); void scheme_init_print_buffers_places(void); void scheme_init_string_places(void); void scheme_init_thread_places(void); +void scheme_init_linklet_places(void); void scheme_init_eval_places(void); void scheme_init_compile_places(void); void scheme_init_compenv_places(void); @@ -421,7 +431,6 @@ void scheme_init_stx_places(int initial_main_os_thread); void scheme_init_fun_places(void); void scheme_init_sema_places(void); void scheme_init_gmp_places(void); -void scheme_init_print_global_constants(void); void scheme_init_variable_references_constants(void); void scheme_init_logger(void); void scheme_init_logging_once(void); @@ -442,12 +451,19 @@ void scheme_free_all_code(void); XFORM_NONGCING int scheme_is_multithreaded(int now); -/* Type readers & writers for compiled code data */ -typedef Scheme_Object *(*Scheme_Type_Reader)(Scheme_Object *list); -typedef Scheme_Object *(*Scheme_Type_Writer)(Scheme_Object *obj); - -extern Scheme_Type_Reader *scheme_type_readers; -extern Scheme_Type_Writer *scheme_type_writers; +Scheme_Object *scheme_closure_marshal_name(Scheme_Object *name); +void scheme_write_lambda(Scheme_Object *obj, + Scheme_Object **_name, + Scheme_Object **_ds, + Scheme_Object **_closure_map, + Scheme_Object **_tl_map); +Scheme_Object *scheme_read_lambda(int flags, int closure_size, int num_params, int max_let_depth, + Scheme_Object *name, + Scheme_Object *ds, + Scheme_Object *closure_map, + Scheme_Object *tl_map); +Scheme_Object *scheme_write_linklet(Scheme_Object *obj); +Scheme_Object *scheme_read_linklet(Scheme_Object *obj); extern Scheme_Equal_Proc *scheme_type_equals; extern Scheme_Primary_Hash_Proc *scheme_type_hash1s; @@ -455,6 +471,7 @@ extern Scheme_Secondary_Hash_Proc *scheme_type_hash2s; void scheme_init_port_config(void); void scheme_init_port_fun_config(void); +void scheme_init_resolver_config(void); Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *c); void scheme_init_error_config(void); #ifndef NO_SCHEME_EXNS @@ -465,7 +482,7 @@ void scheme_init_thread_memory(void); #endif void scheme_init_module_resolver(void); -void scheme_finish_kernel(Scheme_Env *env); +void scheme_finish_kernel(Scheme_Startup_Env *env); void scheme_init_syntax_bindings(void); @@ -480,16 +497,23 @@ extern int scheme_builtin_ref_counter; Scheme_Object **scheme_make_builtin_references_table(int *_unsafe_start); Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags); -void scheme_add_embedded_builtins(Scheme_Env *env); -void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, - Scheme_Object *obj, int constant, - int primitive); +Scheme_Object *scheme_position_to_builtin(int l); + +typedef struct Scheme_Instance Scheme_Instance; +typedef struct Scheme_Linklet Scheme_Linklet; + +void scheme_init_startup(void); /* across places */ +void scheme_init_startup_instance(Scheme_Instance *i); void *scheme_get_os_thread_like(); void scheme_init_os_thread_like(void *); void scheme_done_os_thread(); int scheme_is_place_main_os_thread(); +Scheme_Object *scheme_get_startup_export(const char *s); + +extern int scheme_init_load_on_demand; + /*========================================================================*/ /* constants */ /*========================================================================*/ @@ -522,6 +546,8 @@ extern Scheme_Object *scheme_unsafe_cdr_proc; extern Scheme_Object *scheme_unsafe_mcar_proc; extern Scheme_Object *scheme_unsafe_mcdr_proc; extern Scheme_Object *scheme_unsafe_unbox_proc; +extern Scheme_Object *scheme_unsafe_unbox_star_proc; +extern Scheme_Object *scheme_unsafe_set_box_star_proc; extern Scheme_Object *scheme_car_proc; extern Scheme_Object *scheme_cdr_proc; extern Scheme_Object *scheme_cons_proc; @@ -532,14 +558,24 @@ extern Scheme_Object *scheme_list_star_proc; extern Scheme_Object *scheme_list_pair_p_proc; extern Scheme_Object *scheme_vector_proc; extern Scheme_Object *scheme_vector_p_proc; +extern Scheme_Object *scheme_vector_length_proc; +extern Scheme_Object *scheme_vector_star_length_proc; extern Scheme_Object *scheme_make_vector_proc; extern Scheme_Object *scheme_vector_immutable_proc; extern Scheme_Object *scheme_vector_ref_proc; +extern Scheme_Object *scheme_vector_star_ref_proc; +extern Scheme_Object *scheme_unsafe_vector_star_ref_proc; +extern Scheme_Object *scheme_unsafe_vector_star_set_proc; extern Scheme_Object *scheme_vector_set_proc; +extern Scheme_Object *scheme_vector_star_set_proc; +extern Scheme_Object *scheme_vector_cas_proc; extern Scheme_Object *scheme_list_to_vector_proc; extern Scheme_Object *scheme_unsafe_vector_length_proc; +extern Scheme_Object *scheme_unsafe_vector_star_length_proc; extern Scheme_Object *scheme_unsafe_struct_ref_proc; extern Scheme_Object *scheme_unsafe_struct_star_ref_proc; +extern Scheme_Object *scheme_unsafe_struct_set_proc; +extern Scheme_Object *scheme_unsafe_struct_star_set_proc; extern Scheme_Object *scheme_hash_ref_proc; extern Scheme_Object *scheme_box_p_proc; extern Scheme_Object *scheme_box_proc; @@ -555,17 +591,22 @@ extern Scheme_Object *scheme_struct_type_p_proc; extern Scheme_Object *scheme_current_inspector_proc; extern Scheme_Object *scheme_make_inspector_proc; extern Scheme_Object *scheme_varref_const_p_proc; -extern Scheme_Object *scheme_varref_from_unsafe_p_proc; +extern Scheme_Object *scheme_varref_unsafe_p_proc; extern Scheme_Object *scheme_unsafe_fxnot_proc; extern Scheme_Object *scheme_unsafe_fxand_proc; extern Scheme_Object *scheme_unsafe_fxior_proc; extern Scheme_Object *scheme_unsafe_fxxor_proc; extern Scheme_Object *scheme_unsafe_fxrshift_proc; +extern Scheme_Object *scheme_unsafe_pure_proc; extern Scheme_Object *scheme_string_p_proc; extern Scheme_Object *scheme_unsafe_string_length_proc; +extern Scheme_Object *scheme_unsafe_string_set_proc; +extern Scheme_Object *scheme_unsafe_string_ref_proc; extern Scheme_Object *scheme_byte_string_p_proc; extern Scheme_Object *scheme_unsafe_byte_string_length_proc; +extern Scheme_Object *scheme_unsafe_bytes_ref_proc; +extern Scheme_Object *scheme_unsafe_bytes_set_proc; extern Scheme_Object *scheme_unsafe_real_add1_proc; extern Scheme_Object *scheme_unsafe_real_sub1_proc; @@ -594,10 +635,6 @@ extern Scheme_Object *scheme_unsafe_fx_gt_eq_proc; extern Scheme_Object *scheme_unsafe_fx_min_proc; extern Scheme_Object *scheme_unsafe_fx_max_proc; -extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax; -extern Scheme_Object *scheme_lambda_syntax; -extern Scheme_Object *scheme_begin_syntax; - extern Scheme_Object *scheme_not_proc; extern Scheme_Object *scheme_true_object_p_proc; extern Scheme_Object *scheme_boolean_p_proc; @@ -606,6 +643,9 @@ extern Scheme_Object *scheme_eqv_proc; extern Scheme_Object *scheme_equal_proc; extern Scheme_Object *scheme_def_exit_proc; +extern Scheme_Object *scheme_system_type_proc; + +extern Scheme_Object *scheme_unsafe_poller_proc; extern Scheme_Object *scheme_unsafe_poller_proc; @@ -621,17 +661,6 @@ extern Scheme_Object *scheme_raise_arity_error_proc; extern Scheme_Object *scheme_date; -extern Scheme_Object *scheme_liberal_def_ctx_type; - -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_module_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_modulestar_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_begin_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_module_begin_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_define_values_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_define_syntaxes_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_begin_for_syntax_stx); -THREAD_LOCAL_DECL(extern Scheme_Object *scheme_top_stx); - extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol; extern Scheme_Object *scheme_none_symbol, *scheme_line_symbol, *scheme_block_symbol; @@ -914,7 +943,7 @@ extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator); Scheme_Custodian* scheme_custodian_extract_reference(Scheme_Custodian_Reference *mr); /*========================================================================*/ -/* hash tables and globals */ +/* hash tables and linklet instances */ /*========================================================================*/ /* a primitive constant: */ @@ -941,12 +970,12 @@ typedef Scheme_Bucket_With_Flags Scheme_Bucket_With_Ref_Id; typedef struct { Scheme_Bucket_With_Ref_Id bucket; - Scheme_Object *home_link; /* weak to Scheme_Env *, except when GLOB_STRONG_HOME_LINK */ + Scheme_Object *home_link; /* weak to Scheme_Instance *, except when GLOB_STRONG_HOME_LINK */ } Scheme_Bucket_With_Home; -Scheme_Env *scheme_get_bucket_home(Scheme_Bucket *b); -void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Env *e); -Scheme_Object *scheme_get_home_weak_link(Scheme_Env *e); +XFORM_NONGCING Scheme_Instance *scheme_get_bucket_home(Scheme_Bucket *b); +void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Instance *e); +Scheme_Object *scheme_get_home_weak_link(Scheme_Instance *e); Scheme_Object * scheme_get_primitive_global(Scheme_Object *var, Scheme_Env *env, @@ -1015,6 +1044,11 @@ int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); int scheme_is_hash_tree_equal(Scheme_Object *o); int scheme_is_hash_tree_eqv(Scheme_Object *o); +Scheme_Object *scheme_chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key); +void scheme_chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *k, + Scheme_Object **_chap_key, Scheme_Object **_chap_val, + int ischap); + /*========================================================================*/ /* structs */ /*========================================================================*/ @@ -1142,7 +1176,7 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base, int num_islots, Scheme_Object *uninit_val, char *immutable_pos_list); -Scheme_Object *scheme_prefab_struct_key(Scheme_Object *s); +XFORM_NONGCING Scheme_Object *scheme_prefab_struct_key(Scheme_Object *s); #ifdef MZ_USE_PLACES Scheme_Object *scheme_make_serialized_struct_instance(Scheme_Object *s, int num_slots); #endif @@ -1156,6 +1190,10 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv); Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); +#if defined(MZ_GC_BACKTRACE) && defined(MZ_PRECISE_GC) +Scheme_Object *scheme_add_builtin_struct_types(Scheme_Object *accum); +#endif + typedef struct Scheme_Chaperone { Scheme_Inclhash_Object iso; /* 0x1 => impersonator, rather than a checking chaperone */ Scheme_Object *val; /* root object */ @@ -1237,7 +1275,8 @@ Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *pr /* syntax objects */ /*========================================================================*/ -#define MZ_LABEL_PHASE 30000 +/* The internal variant of a syntax object just has a source location + and other properties. */ typedef struct Scheme_Stx_Srcloc { MZTAG_IF_REQUIRED @@ -1245,40 +1284,13 @@ typedef struct Scheme_Stx_Srcloc { Scheme_Object *src; } Scheme_Stx_Srcloc; -#define STX_SUBSTX_FLAG 0x1 -#define STX_ARMED_FLAG 0x2 - -typedef struct Scheme_Scope_Set Scheme_Scope_Set; - -typedef struct Scheme_Scope_Table { - Scheme_Object so; /* scheme_scope_table_type or scheme_propagate_table_type */ - Scheme_Scope_Set *simple_scopes; /* scopes that span all phases */ - Scheme_Object *multi_scopes; /* list of (cons multi-scope phase-shift) or fallback chain */ -} Scheme_Scope_Table; - typedef struct Scheme_Stx { - Scheme_Inclhash_Object iso; /* 0x1 and 0x2 of keyex used */ + Scheme_Object so; Scheme_Object *val; Scheme_Stx_Srcloc *srcloc; - Scheme_Scope_Table *scopes; - union { - Scheme_Scope_Table *to_propagate; - Scheme_Object *cache; - } u; - Scheme_Object *shifts; /* or (vector ) */ - Scheme_Object *taints; /* taint or taint-arming */ Scheme_Hash_Tree *props; } Scheme_Stx; -typedef struct Scheme_Stx_Offset { - Scheme_Object so; - intptr_t line, col, pos; - Scheme_Object *src; -} Scheme_Stx_Offset; - -struct Scheme_Marshal_Tables; -struct Scheme_Unmarshal_Tables; - Scheme_Object *scheme_make_stx(Scheme_Object *val, Scheme_Stx_Srcloc *srcloc, Scheme_Hash_Tree *props); @@ -1287,188 +1299,19 @@ Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, Scheme_Object *src, Scheme_Hash_Tree *props); -Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int cangraph, int copyprops); -Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes, - struct Scheme_Marshal_Tables *mt); -Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, - struct Scheme_Unmarshal_Tables *ut, - int can_graph); +#define DTS_COPY_PROPS 0x1 +#define DTS_CAN_GRAPH 0x2 +#define DTS_RECUR 0x4 -Scheme_Object *scheme_stx_track(Scheme_Object *naya, - Scheme_Object *old, - Scheme_Object *origin); +Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src, int flags); -int scheme_stx_has_empty_wraps(Scheme_Object *stx, Scheme_Object *phase); +Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx); -int scheme_syntax_is_original(Scheme_Object *_stx); -Scheme_Object *scheme_syntax_remove_original(Scheme_Object *_stx); - -XFORM_NONGCING Scheme_Object *scheme_stx_root_scope(); -Scheme_Object *scheme_new_scope(int kind); -Scheme_Object *scheme_scope_printed_form(Scheme_Object *m); -Scheme_Object *scheme_stx_scope(Scheme_Object *o, Scheme_Object *m, int mode); - -#define SCHEME_STX_MODULE_SCOPE 0 -#define SCHEME_STX_MODULE_MULTI_SCOPE 1 -#define SCHEME_STX_MACRO_SCOPE 2 -#define SCHEME_STX_LOCAL_BIND_SCOPE 3 -#define SCHEME_STX_INTDEF_SCOPE 4 -#define SCHEME_STX_USE_SITE_SCOPE 5 - -#define SCHEME_STX_SCOPE_KIND_SHIFT 3 -#define SCHEME_STX_SCOPE_KIND_MASK ((1 << SCHEME_STX_SCOPE_KIND_SHIFT) - 1) - -#define SCHEME_STX_ADD 0 -#define SCHEME_STX_REMOVE 1 -#define SCHEME_STX_FLIP 2 -#define SCHEME_STX_PUSH 4 -#define SCHEME_STX_MUTATE 16 /* or'ed */ -#define SCHEME_STX_PROPONLY 32 /* or'ed, internal */ -Scheme_Object *scheme_stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode); -Scheme_Object *scheme_stx_add_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); -Scheme_Object *scheme_stx_remove_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); -Scheme_Object *scheme_stx_flip_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); -Scheme_Object *scheme_stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode); - -Scheme_Scope_Set *scheme_module_context_scopes(Scheme_Object *mc); -Scheme_Object *scheme_module_context_frame_scopes(Scheme_Object *mc, Scheme_Object *keep_intdef_scopes); -void scheme_module_context_add_use_site_scope(Scheme_Object *mc, Scheme_Object *use_site_scope); -Scheme_Object *scheme_stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); -Scheme_Object *scheme_stx_adjust_frame_bind_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); -Scheme_Object *scheme_stx_adjust_frame_use_site_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); - -Scheme_Object *scheme_make_frame_scopes(Scheme_Object *scope); -Scheme_Object *scheme_add_frame_use_site_scope(Scheme_Object *frame_scopes, Scheme_Object *use_site_scope); -Scheme_Object *scheme_add_frame_intdef_scope(Scheme_Object *frame_scopes, Scheme_Object *intdef_scope); - -Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp); -Scheme_Object *scheme_stx_add_shift(Scheme_Object *o, Scheme_Object *shift); -Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *shift); -Scheme_Object *scheme_stx_shift(Scheme_Object *stx, - Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp); - -Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); -int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv); - -struct Scheme_Module_Phase_Exports; /* forward declaration */ - -Scheme_Object *scheme_make_module_context(Scheme_Object *insp, - Scheme_Object *shift_or_shifts, - Scheme_Object *name); -Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *phase); - -Scheme_Object *scheme_stx_add_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_remove_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_add_module_frame_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Scheme_Object *mc, int mode); -Scheme_Object *scheme_stx_introduce_to_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_push_module_context(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_push_introduce_module_context(Scheme_Object *stx, Scheme_Object *mc); - -Scheme_Object *scheme_stx_from_module_context_to_generic(Scheme_Object *stx, Scheme_Object *mc); -Scheme_Object *scheme_stx_from_generic_to_module_context(Scheme_Object *stx, Scheme_Object *mc); - -Scheme_Object *scheme_module_context_to_stx(Scheme_Object *mc, Scheme_Object *orig_src); -Scheme_Object *scheme_stx_to_module_context(Scheme_Object *stx); - -Scheme_Object *scheme_module_context_use_site_frame_scopes(Scheme_Object *mc); -Scheme_Object *scheme_module_context_inspector(Scheme_Object *mc); - -void scheme_module_context_add_mapped_symbols(Scheme_Object *mc, Scheme_Hash_Table *mapped); - -XFORM_NONGCING void scheme_stx_set(Scheme_Object *q_stx, Scheme_Object *val, Scheme_Object *context); - -void scheme_extend_module_context(Scheme_Object *mc, Scheme_Object *ctx, Scheme_Object *modidx, - Scheme_Object *locname, Scheme_Object *exname, - Scheme_Object *nominal_src, Scheme_Object *nominal_ex, - intptr_t mod_phase, Scheme_Object *src_phase_index, - Scheme_Object *nom_export_phase); -void scheme_extend_module_context_with_shared(Scheme_Object *mc, Scheme_Object *modidx, - struct Scheme_Module_Phase_Exports *pt, - Scheme_Object *prefix, - Scheme_Hash_Tree *excepts, - Scheme_Object *src_phase_index, - Scheme_Object *context, - Scheme_Object *replace_at); - -void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *req_modidx, - Scheme_Object *context, - Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase, - Scheme_Object *prefix, - Scheme_Hash_Tree *excepts, - Scheme_Hash_Table *export_registry, - Scheme_Object *insp, Scheme_Object *req_insp, - Scheme_Object *replace_at); - -int scheme_stx_equal_module_context(Scheme_Object *stx, Scheme_Object *mc_as_stx); - -Scheme_Object *scheme_stx_content(Scheme_Object *o); -Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist); - -int scheme_stx_could_bind(Scheme_Object *bind_id, Scheme_Object *ref_id, Scheme_Object *phase); - -int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase); -int scheme_stx_free_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase); -int scheme_stx_free_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); -int scheme_stx_free_eq3(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase); -Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); - -void scheme_add_local_binding(Scheme_Object *o, Scheme_Object *phase, Scheme_Object *binding_sym); -void scheme_add_module_binding(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *inspector, - Scheme_Object *sym, Scheme_Object *defn_phase); -void scheme_add_module_binding_w_nominal(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *defn_name, Scheme_Object *defn_phase, - Scheme_Object *inspector, - Scheme_Object *nominal_mod, Scheme_Object *nominal_name, - Scheme_Object *nominal_import_phase, - Scheme_Object *nominal_export_phase, - struct Scheme_Module_Phase_Exports *from_pt, - Scheme_Hash_Table *collapse_table); -void scheme_add_binding_copy(Scheme_Object *o, Scheme_Object *from_o, Scheme_Object *phase); - -Scheme_Object *scheme_stx_lookup(Scheme_Object *o, Scheme_Object *phase); -Scheme_Object *scheme_stx_lookup_stop_at_free_eq(Scheme_Object *o, Scheme_Object *phase, int *_exact_match); -Scheme_Object *scheme_stx_lookup_exact(Scheme_Object *o, Scheme_Object *phase); -Scheme_Object *scheme_stx_lookup_w_nominal(Scheme_Object *o, Scheme_Object *phase, - int stop_at_free_eq, - int *_exact_match, int *_ambiguous, - Scheme_Scope_Set **_binding_scopes, - Scheme_Object **insp, /* access-granting inspector */ - Scheme_Object **nominal_modidx, /* how it was imported */ - Scheme_Object **nominal_name, /* imported as name */ - Scheme_Object **src_phase, /* phase level of import from nominal modidx */ - Scheme_Object **nominal_src_phase); /* phase level of export from nominal modidx */ - -int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); -int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); -int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase); - -Scheme_Object *scheme_stx_binding_union(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase); -Scheme_Object *scheme_stx_binding_subtract(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase); - -Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source); - -char *scheme_stx_describe_context(Scheme_Object *stx, Scheme_Object *phase, int always); +Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); Scheme_Object *scheme_stx_property(Scheme_Object *_stx, Scheme_Object *key, Scheme_Object *val); -Scheme_Object *scheme_stx_property2(Scheme_Object *_stx, - Scheme_Object *key, - Scheme_Object *val, - int preserve); int scheme_stx_list_length(Scheme_Object *list); int scheme_stx_proper_list_length(Scheme_Object *list); @@ -1478,55 +1321,22 @@ Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj); #define SCHEME_STX_VAL(s) ((Scheme_Stx *)s)->val #define SCHEME_STX_PAIRP(o) (SCHEME_PAIRP(o) || (SCHEME_STXP(o) && SCHEME_PAIRP(SCHEME_STX_VAL(o)))) -#define SCHEME_STX_SYMBOLP(o) (SCHEME_SYMBOLP(o) || (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o)))) +#define SCHEME_STX_SYMBOLP(o) (SCHEME_SYMBOLP(o) || ((SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))))) #define SCHEME_STX_NULLP(o) (SCHEME_NULLP(o) || (SCHEME_STXP(o) && SCHEME_NULLP(SCHEME_STX_VAL(o)))) -#define SCHEME_STX_CAR(o) (SCHEME_PAIRP(o) ? SCHEME_CAR(o) : SCHEME_CAR(scheme_stx_content(o))) -#define SCHEME_STX_CDR(o) (SCHEME_PAIRP(o) ? SCHEME_CDR(o) : SCHEME_CDR(scheme_stx_content(o))) +#define SCHEME_STX_CAR(o) (SCHEME_PAIRP(o) ? SCHEME_CAR(o) : SCHEME_CAR(SCHEME_STX_VAL(o))) +#define SCHEME_STX_CDR(o) (SCHEME_PAIRP(o) ? SCHEME_CDR(o) : SCHEME_CDR(SCHEME_STX_VAL(o))) +#define SCHEME_STX_CADR(o) (SCHEME_PAIRP(o) ? SCHEME_STX_CAR(SCHEME_CDR(o)) : SCHEME_STX_CAR(SCHEME_CDR(SCHEME_STX_VAL(o)))) #define SCHEME_STX_SYM(o) (SCHEME_STXP(o) ? SCHEME_STX_VAL(o) : o) Scheme_Object *scheme_source_to_name(Scheme_Object *code); #define STX_SRCTAG scheme_source_stx_props -Scheme_Object *scheme_stx_taint(Scheme_Object *o); -Scheme_Object *scheme_stx_taint_arm(Scheme_Object *o, Scheme_Object *insp); -Scheme_Object *scheme_stx_taint_rearm(Scheme_Object *o, Scheme_Object *arm_from); -int scheme_stx_is_tainted(Scheme_Object *id); -int scheme_stx_is_clean(Scheme_Object *id); -int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp); -Scheme_Object *scheme_stx_taint_disarm(Scheme_Object *o, Scheme_Object *insp); - -/* variants that use 'taint-mode and look up inspector: */ -Scheme_Object *scheme_syntax_taint_arm(Scheme_Object *stx, Scheme_Object *insp, int use_mode); -Scheme_Object *scheme_syntax_taint_rearm(Scheme_Object *o, Scheme_Object *arm_from); -Scheme_Object *scheme_syntax_taint_disarm(Scheme_Object *o, Scheme_Object *insp); - -Scheme_Object *scheme_delayed_shift(Scheme_Object **o, intptr_t i); - -struct Resolve_Prefix; -void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i); - -Scheme_Object *scheme_stx_force_delayed(Scheme_Object *stx); - -Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht); -void scheme_populate_pt_ht(struct Scheme_Module_Phase_Exports * pt); - Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from); int scheme_is_predefined_module_p(Scheme_Object *name); -Scheme_Object *scheme_get_kernel_modidx(void); - -Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, struct Scheme_Marshal_Tables *mt); -void scheme_iterate_reachable_scopes(struct Scheme_Marshal_Tables *mt); - -void scheme_stx_debug_print(Scheme_Object *stx, Scheme_Object *phase, int level); - -Scheme_Object *scheme_revert_use_site_scopes(Scheme_Object *o, struct Scheme_Comp_Env *env); - -Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv); - /*========================================================================*/ /* syntax run-time structures */ /*========================================================================*/ @@ -1594,6 +1404,11 @@ typedef struct Scheme_IR_Local /* `mode` determines which union is active: */ union { + struct { + /* To detect uses on right-hand sides in `letrec` */ + int *use_box; + int use_position; + } compile; struct { /* Maps the variable into the letrec-check pass's frames: */ struct Letrec_Check_Frame *frame; @@ -1644,6 +1459,30 @@ typedef struct Scheme_IR_Local #define SCHEME_VAR_MODE_OPTIMIZE 3 #define SCHEME_VAR_MODE_RESOLVE 4 +/* Definition and references share the same object during the + "compile" pass, and SCHEME_IR_TOPLEVEL_MUTATED is set in that pass. + During the "optimize" pass, references may be cloned to set + SCHEME_TOPLEVEL_CONST, etc. */ +typedef struct Scheme_IR_Toplevel +{ + Scheme_Inclhash_Object iso; /* scheme_import_export_variable_type; not hashable */ + int instance_pos; /* import instance position, or -1 for exported and internal */ + int variable_pos; /* position within import instance or definition sequence */ +} Scheme_IR_Toplevel; + +/* See also SCHEME_TOPLEVEL_... */ +#define SCHEME_IR_TOPLEVEL_MUTATED 0x4 + +#define SCHEME_IR_TOPLEVEL_FLAGS(var) MZ_OPT_HASH_KEY(&(var)->iso) +#define SCHEME_IR_TOPLEVEL_INSTANCE(var) (((Scheme_IR_Toplevel *)var)->instance_pos) +#define SCHEME_IR_TOPLEVEL_POS(var) (((Scheme_IR_Toplevel *)var)->variable_pos) + +/* Number of runstack slots before imports: */ +#define SCHEME_LINKLET_PREFIX_PREFIX 1 + +Scheme_IR_Toplevel *scheme_make_ir_toplevel(int instance_pos, int variable_pos, int flags); +Scheme_Object *scheme_ir_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags); + typedef struct { Scheme_Inclhash_Object iso; /* keyex used for flags */ mzshort num_args; /* doesn't include rator, so arguments are at args[1]...args[num_args] */ @@ -1704,15 +1543,6 @@ typedef struct { Scheme_Object *fbranch; } Scheme_Branch_Rec; -typedef struct { - Scheme_Inclhash_Object iso; /* keyex used to disable module table */ - mzshort max_let_depth; - Scheme_Object *code; - struct Resolve_Prefix *prefix; /* NULL => a wrapper for a JITted module in `code' */ - Scheme_Object *binding_namess; /* list of to hash of to ; - additions to the top-level bindings table */ -} Scheme_Compilation_Top; - /* A `let' or `letrec' form is compiled to the intermediate format (used during the optimization pass) as a Scheme_IR_Let_Header with a chain of Scheme_IR_Let_Value records as its body, @@ -1926,22 +1756,8 @@ void scheme_init_ephemerons(void); void scheme_flush_stack_copy_cache(void); #endif -typedef struct Scheme_Dynamic_State { - struct Scheme_Comp_Env * volatile current_local_env; - Scheme_Object * volatile scope; - Scheme_Object * volatile use_scope; - Scheme_Object * volatile name; - Scheme_Object * volatile modidx; - Scheme_Env * volatile menv; -} Scheme_Dynamic_State; - -void scheme_set_dynamic_state(Scheme_Dynamic_State *state, struct Scheme_Comp_Env *env, - Scheme_Object *scope, Scheme_Object *use_scope, - Scheme_Object *name, - Scheme_Env *menv, - Scheme_Object *modidx); void *scheme_top_level_do(void *(*k)(void), int eb); -void *scheme_top_level_do_worker(void *(*k)(void), int eb, int newthread, Scheme_Dynamic_State *dyn_state); +void *scheme_top_level_do_worker(void *(*k)(void), int eb, int newthread); Scheme_Object *scheme_call_ec(int argc, Scheme_Object *argv[]); @@ -2184,9 +2000,6 @@ Scheme_Object *scheme_all_current_continuation_marks(void); void scheme_about_to_move_C_stack(void); -Scheme_Object *scheme_apply_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state); -Scheme_Object *scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state); - Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object **old_runstack, int can_ec); @@ -2195,6 +2008,8 @@ Scheme_Object *scheme_chaperone_do_continuation_mark(const char *name, int is_ge XFORM_NONGCING Scheme_Object *scheme_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val); Scheme_Object *scheme_chaperone_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val); +void scheme_clear_prompt_cache(void); + /*========================================================================*/ /* semaphores and locks */ /*========================================================================*/ @@ -2604,9 +2419,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, int radix, int radix_set, Scheme_Object *port, int *div_by_zero, - int test_only, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *indentation); + int test_only); Scheme_Object *scheme_bin_gcd(const Scheme_Object *n1, const Scheme_Object *n2); Scheme_Object *scheme_bin_quotient(const Scheme_Object *n1, const Scheme_Object *n2); @@ -2725,7 +2538,7 @@ long_double scheme_long_double_expt(long_double x, long_double y); typedef struct Scheme_Prefix { Scheme_Inclhash_Object iso; /* scheme_prefix_type; 0x1 => incremental-mode fixup chain */ - int num_slots, num_toplevels, num_stxes; + int num_slots, saw_num_slots; #ifdef MZ_PRECISE_GC struct Scheme_Prefix *next_final; /* for special GC handling */ struct Scheme_Object *fixup_chain; /* for special GC handling */ @@ -2753,16 +2566,18 @@ void scheme_clear_delayed_load_cache(); Scheme_Object *scheme_eval_linked_expr(Scheme_Object *expr); Scheme_Object *scheme_eval_linked_expr_multi(Scheme_Object *expr); -Scheme_Object *scheme_eval_linked_expr_multi_with_dynamic_state(Scheme_Object *obj, Scheme_Dynamic_State *dyn_state); Scheme_Object *_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands); Scheme_Object *_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands); Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands); -Scheme_Object *scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, - int recur, int expose_comment, int pre_char, Scheme_Object *readtable, - Scheme_Object *magic_sym, Scheme_Object *magic_val, +Scheme_Object *scheme_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, + int num_instances, Scheme_Instance **instances, + int use_prompt); + +Scheme_Object *scheme_internal_read(Scheme_Object *port, int crc, int cantfail, + int pre_char, Scheme_Object *delay_load_info); void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port); void scheme_internal_write(Scheme_Object *obj, Scheme_Object *port); @@ -2770,6 +2585,8 @@ void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port, Scheme_Objec Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok); +Scheme_Object *scheme_read_compiled(Scheme_Object *port); + #define _scheme_eval_linked_expr(obj) scheme_do_eval(obj,-1,NULL,1) #define _scheme_eval_linked_expr_multi(obj) scheme_do_eval(obj,-1,NULL,-1) #define _scheme_eval_linked_expr_wp(obj, p) scheme_do_eval_w_thread(obj,-1,NULL,1,p) @@ -2783,8 +2600,6 @@ XFORM_NONGCING int scheme_strncmp(const char *a, const char *b, int len); #define _scheme_make_char(ch) scheme_make_character(ch) -Scheme_Object *scheme_default_eval_handler(int, Scheme_Object *[]); -Scheme_Object *scheme_default_compile_handler(int, Scheme_Object *[]); Scheme_Object *scheme_default_print_handler(int, Scheme_Object *[]); Scheme_Object *scheme_default_prompt_read_handler(int, Scheme_Object *[]); Scheme_Object *scheme_default_read_input_port_handler(int argc, Scheme_Object *[]); @@ -2793,10 +2608,6 @@ Scheme_Object *scheme_default_read_handler(int argc, Scheme_Object *[]); extern Scheme_Object *scheme_eof_object_p_proc; extern Scheme_Object *scheme_default_global_print_handler; -/* Type readers & writers for compiled code data */ -void scheme_install_type_reader(Scheme_Type type, Scheme_Type_Reader f); -void scheme_install_type_writer(Scheme_Type type, Scheme_Type_Writer f); - Scheme_Object *scheme_make_default_readtable(void); Scheme_Object *scheme_read_intern(Scheme_Object *o); @@ -2826,65 +2637,25 @@ intptr_t scheme_get_print_width(void); /* compile and link */ /*========================================================================*/ -typedef struct Comp_Prefix -{ - MZTAG_IF_REQUIRED - int num_toplevels, num_stxes, non_phaseless; - Scheme_Hash_Table *toplevels; /* buckets for toplevel/module variables */ - Scheme_Hash_Table *inline_variants; /* position -> inline_variant */ - Scheme_Object *unbound; /* identifiers (and lists of phase-1 shifted unbounds) that were unbound at compile */ - Scheme_Hash_Table *stxes; /* syntax objects */ -} Comp_Prefix; - -typedef Scheme_Object *(*Scheme_Expand_Result_Adjust_Proc)(Scheme_Object *stx, Scheme_Object *arg); - typedef struct Scheme_Comp_Env { MZTAG_IF_REQUIRED - short flags; /* used for expanding/compiling */ - Scheme_Env *genv; /* top-level environment */ - Scheme_Object *insp; /* code inspector for checking protected */ - Comp_Prefix *prefix; /* stack base info: globals and stxes */ - - Scheme_Object *scopes; /* can be NULL, a scope, a scope set, or (cons scope-set nobind-scope) */ - + int flags; + Scheme_Hash_Tree *vars; /* symbol -> Scheme_IR_Local */ Scheme_Object *value_name; /* propagated down */ - Scheme_Object *observer; /* parameter's value (to avoid looking up every time) */ - - /* local bindings; */ - mzshort num_bindings; /* number of `values' slots */ - Scheme_Object **binders; /* identifiers */ - Scheme_Object **bindings; /* symbols */ - Scheme_Object **vals; /* compile-time values */ - Scheme_Object **shadower_deltas; - Scheme_IR_Local **vars; - int *use; - int max_use, any_use; - - Scheme_Object *lifts; - - Scheme_Hash_Table *binding_namess; /* -> ( -> ); additions to the environment's - bindings table made during a particular compilation */ - - mzshort rename_var_count; /* number of non-NULL `values' when `renames' was computed */ - mzshort rename_rstart; /* leftover rstart from previous round; see env.c */ - Scheme_Hash_Table *dup_check; /* table for finding colliding symbols in `values' */ - - Scheme_Object *intdef_name; /* syntax-local-context name for INTDEF frames */ - - Scheme_Object *in_modidx; /* during lookup/expand in macro */ - - Scheme_Hash_Tree *skip_table; /* for jumping ahead in the chain */ - int skip_depth; /* depth in simple frames, used to trigger skip_table creation */ - - Scheme_Expand_Result_Adjust_Proc expand_result_adjust; - Scheme_Object *expand_result_adjust_arg; - - struct Scheme_Comp_Env *next; - struct Scheme_Comp_Env *use_scopes_next; /* fast-forward for use-site scope revert */ - struct Scheme_Comp_Env *intdef_next; /* when `next` = NULL, can be non-null to continue binding search */ + Scheme_Linklet *linklet; } Scheme_Comp_Env; +#define COMP_ENV_CHECKING_CONSTANT 0x1 +#define COMP_ENV_DONT_COUNT_AS_USE 0x2 +#define COMP_ENV_ALLOW_SET_UNDEFINED 0x4 + +Scheme_Comp_Env *scheme_new_comp_env(Scheme_Linklet *linklet, int flags); +Scheme_Comp_Env *scheme_extend_comp_env(Scheme_Comp_Env *env, Scheme_Object *id, Scheme_Object *var, + int mutate, int check_dups); +Scheme_Comp_Env *scheme_set_comp_env_flags(Scheme_Comp_Env *env, int flags); +Scheme_Comp_Env *scheme_set_comp_env_name(Scheme_Comp_Env *env, Scheme_Object *name); + #define LAMBDA_HAS_REST 1 #define LAMBDA_HAS_TYPED_ARGS 2 #define LAMBDA_PRESERVES_MARKS 4 @@ -2896,40 +2667,11 @@ typedef struct Scheme_Comp_Env #define LAMBDA_SFS 256 /* BITS 8-15 (overlaps LAMBDA_SFS) used by write_lambda() */ -typedef struct Scheme_Compile_Expand_Info -{ - /* allocated as atomic */ - short comp; - short comp_flags; - char dont_mark_local_use; - char resolve_module_ids; - char pre_unwrapped; - char testing_constantness; - char substitute_bindings; - int depth; - int env_already; -} Scheme_Compile_Expand_Info; - -#define COMP_ALLOW_SET_UNDEFINED 0x1 -#define COMP_CAN_INLINE 0x2 -#define COMP_ENFORCE_CONSTS 0x4 - -typedef Scheme_Compile_Expand_Info Scheme_Compile_Info; -typedef Scheme_Compile_Expand_Info Scheme_Expand_Info; - -typedef struct Resolve_Prefix -{ - Scheme_Object so; - int num_toplevels, num_stxes, num_lifts; - Scheme_Object **toplevels; - Scheme_Object **stxes; /* simplified */ - Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */ - /* An inspector or symbol to identify bindings that are created as - part of the module's expansion, so that a suitable inspector can - be associated with those bindings (through a syntax-object - "shift") when the code is re-loaded. */ - Scheme_Object *src_insp_desc; -} Resolve_Prefix; +#define COMP_ALLOW_SET_UNDEFINED 0x1 +#define COMP_CAN_INLINE 0x2 +#define COMP_ENFORCE_CONSTS 0x4 +#define COMP_TESTING_CONSTANTNESS 0x8 +#define RESOLVE_MODULE_IDS 0x10 typedef struct Resolve_Info Resolve_Info; @@ -2952,14 +2694,6 @@ typedef struct { typedef struct Optimize_Info Optimize_Info; -typedef struct Scheme_Object * -(Scheme_Syntax)(struct Scheme_Object *form, struct Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); - -typedef struct Scheme_Object * -(Scheme_Syntax_Expander)(struct Scheme_Object *form, struct Scheme_Comp_Env *env, - Scheme_Expand_Info *rec, int drec); - typedef struct CPort Mz_CPort; typedef struct Scheme_Lambda @@ -3115,15 +2849,7 @@ int scheme_push_marks_from_thread(Scheme_Thread *p2, Scheme_Cont_Frame_Data *d); int scheme_push_marks_from_lightweight_continuation(Scheme_Lightweight_Continuation *captured, Scheme_Cont_Frame_Data *d); -#define scheme_new_frame(n) scheme_new_special_frame(n, 0) -#define scheme_extend_env(f, e) (f->basic.next = e, f) -#define scheme_next_frame(e) ((e)->basic.next) -#define scheme_settable_frame(f, s) ((f)->basic.has_set_bang = (s)) -#define scheme_get_frame_settable(f) ((f)->basic.has_set_bang) -#define scheme_get_binding(f, n) ((f)->values[n]) - -int scheme_is_module_begin_env(Scheme_Comp_Env *env); -Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, int flags); +Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int flags); #define MAX_CONST_LOCAL_POS 64 #define MAX_CONST_LOCAL_TYPES 2 @@ -3134,63 +2860,19 @@ Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, i #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ -Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags); -Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags); +Scheme_IR_Local *scheme_make_ir_local(Scheme_Object *id); Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, Scheme_Object **_id, int *_use_map); -Scheme_Object *scheme_get_shadower(Scheme_Object *sym, Scheme_Comp_Env *env, int only_generated); -Scheme_Object *scheme_do_local_lift_expr(const char *who, int stx_pos, - int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_local_lift_context(Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, - intptr_t phase, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_scope, - Scheme_Comp_Env *env); -Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env); -void scheme_check_identifier(const char *formname, Scheme_Object *id, - const char *where, - Scheme_Comp_Env *env, - Scheme_Object *form); -Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, - Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *erec, int drec, - Scheme_Object **current_val, - int keep_name); +/* Flags used with scheme_compile_lookup */ +#define SCHEME_APP_POS 2 +#define SCHEME_SETTING 4 +#define SCHEME_NULL_FOR_UNBOUND 512 +#define SCHEME_REFERENCING 4096 -Scheme_Object *scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, - Scheme_Object *f, Scheme_Object *code, - Scheme_Comp_Env *env, Scheme_Object *boundname, - Scheme_Compile_Expand_Info *rec, int drec, - int for_set, - int scope_macro_use); - -Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, - Scheme_Object *scope, - Scheme_Comp_Env *env); -void scheme_add_compilation_binding(int index, Scheme_Object *val, - Scheme_Comp_Env *frame); -void scheme_add_compilation_frame_use_site_scope(Scheme_Comp_Env *frame, - Scheme_Object *use_site_scope); -void scheme_add_compilation_frame_intdef_scope(Scheme_Comp_Env *frame, - Scheme_Object *intdef_scope); -Scheme_Comp_Env *scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Object *scope, - Scheme_Comp_Env *env, int flags); - -Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env); - -Scheme_Object *scheme_compile_lookup(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags, - Scheme_Object *in_modidx, - Scheme_Env **_menv, int *_protected, - Scheme_Object **_local_binder, int *_need_macro_scope, - Scheme_Object **_inline_variant); +Scheme_Object *scheme_compile_lookup(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags); int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env); Scheme_Object *scheme_extract_unsafe(Scheme_Object *o); @@ -3199,36 +2881,6 @@ Scheme_Object *scheme_extract_extfl(Scheme_Object *o); Scheme_Object *scheme_extract_futures(Scheme_Object *o); Scheme_Object *scheme_extract_foreign(Scheme_Object *o); -typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *); -void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, - Scheme_Object *end_stmts, Scheme_Object *context_key, - Scheme_Object *require_lifts, Scheme_Object *provide_lifts, - Scheme_Object *module_lifts); -void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_end_modules(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env); -Scheme_Object *scheme_generate_lifts_key(void); -Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env); -Scheme_Comp_Env *scheme_get_env_for_lifts(Scheme_Comp_Env *env); - -Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, - intptr_t phase, - Scheme_Comp_Env *cenv, - Scheme_Object *scope); -Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, - intptr_t phase, - Scheme_Object *scope, - void *data, - Scheme_Object **_ref_expr, - struct Scheme_Comp_Env *cenv); - -void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env); -void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, - Scheme_Comp_Env *env, int replace_value); - Scheme_Object *scheme_clone_vector(Scheme_Object *data, int skip, int set_type); Scheme_Object *scheme_make_closure(Scheme_Thread *p, @@ -3246,48 +2898,13 @@ Scheme_Native_Lambda *scheme_generate_case_lambda(Scheme_Case_Lambda *cl); void scheme_delay_load_closure(Scheme_Lambda *data); -Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef); - -#define scheme_add_good_binding(i,v,f) (f->values[i] = v) - Scheme_Object *scheme_compiled_void(void); -int scheme_check_top_identifier_bound(Scheme_Object *symbol, Scheme_Env *genv, int disallow_unbound); - -Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int imported, Scheme_Object *inline_variant); -Scheme_Object *scheme_register_toplevel_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp, - int imported, Scheme_Object *inline_variant); -void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id); -Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -Scheme_Object *scheme_register_stx_in_comp_prefix(Scheme_Object *var, Comp_Prefix *cp); -void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - Scheme_Env *menv); void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env); -void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, - Scheme_Env *exp_env, Scheme_Object *insp, - Scheme_Compile_Expand_Info *rec, int drec, Scheme_Object *observer, - Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos, Scheme_Object *rename_rib, int replace_value); -int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env); - typedef struct SFS_Info SFS_Info; -SFS_Info *scheme_new_sfs_info(int depth); -Scheme_Object *scheme_sfs(Scheme_Object *expr, SFS_Info *info, int max_let_depth); -Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *si, int self_pos); - -void scheme_sfs_used(SFS_Info *info, int pos); -void scheme_sfs_push(SFS_Info *info, int count, int track); -void scheme_sfs_start_sequence(SFS_Info *si, int cnt, int last_is_tail); - -Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre); - -typedef struct Scheme_Object *(*Scheme_Syntax_SFSer)(Scheme_Object *data, SFS_Info *info); +Scheme_Linklet *scheme_sfs_linklet(Scheme_Linklet *linklet); typedef struct Scheme_Set_Bang { Scheme_Object so; @@ -3297,9 +2914,11 @@ typedef struct Scheme_Set_Bang { Scheme_Object *scheme_protect_quote(Scheme_Object *expr); -Scheme_Object *scheme_letrec_check_expr(Scheme_Object *); +Scheme_Linklet *scheme_letrec_check_linklet(Scheme_Linklet *linklet); -Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context); +Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet, + int enforce_const, int can_inline, int unsafe_mode, + Scheme_Object **_import_keys, Scheme_Object *get_import); /* Context uses result as a boolean: */ #define OPT_CONTEXT_BOOLEAN 0x1 @@ -3322,12 +2941,15 @@ XFORM_NONGCING int scheme_predicate_to_local_type(Scheme_Object *pred); Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e); Scheme_Object *scheme_optimize_extract_tail_inside(Scheme_Object *t2); -Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *); -Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *); +Scheme_Linklet *scheme_resolve_linklet(Scheme_Linklet *, int enforce_const); Scheme_Object *scheme_unresolve(Scheme_Object *, int argv, int *_has_cases, - Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, intptr_t ref_phase, - Scheme_Object *from_modidx, Scheme_Object *to_modidx); -Scheme_Object *scheme_unresolve_top(Scheme_Object *, Comp_Prefix **, int comp_flags); + Scheme_Linklet *linklet, Scheme_Object *linklet_key, + Optimize_Info *opt_info); +Scheme_Linklet *scheme_unresolve_linklet(Scheme_Linklet *, int comp_flags); + +/* Callbacks from unresolver to optimizer: */ +Scheme_Object *scheme_optimize_add_import_variable(Optimize_Info *info, Scheme_Object *linklet_key, Scheme_Object *symbol); +Scheme_Object *scheme_optimize_get_import_key(Optimize_Info *info, Scheme_Object *linklet_key, int instance_pos); int scheme_check_leaf_rator(Scheme_Object *le); @@ -3335,22 +2957,6 @@ int scheme_is_ir_lambda(Scheme_Object *o, int can_be_closed, int can_be_liftable Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info); -Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, Scheme_Object *insp_desc); -Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri); - -Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp); -void scheme_resolve_info_enforce_const(Resolve_Info *, int enforce_const); -int scheme_resolve_info_max_let_depth(Resolve_Info *ri); -int scheme_resolve_info_use_jit(Resolve_Info *ri); - -void scheme_enable_expression_resolve_lifts(Resolve_Info *ri); -Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri); - -Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, Scheme_Env *env, Scheme_Object *insp, int get_logger); -void scheme_optimize_info_enforce_const(Optimize_Info *, int enforce_const); -void scheme_optimize_info_set_context(Optimize_Info *, Scheme_Object *ctx); -void scheme_optimize_info_never_inline(Optimize_Info *); - char *scheme_optimize_info_context(Optimize_Info *); Scheme_Logger *scheme_optimize_info_logger(Optimize_Info *); @@ -3358,36 +2964,8 @@ Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags) int scheme_expr_produces_local_type(Scheme_Object *expr, int *_involves_k_cross); -Scheme_Object *scheme_make_primitive_syntax(Scheme_Syntax *syntax, - Scheme_Syntax_Expander *exp); - -Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); - -Scheme_Object *scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); - -Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, - Scheme_Comp_Env *env); -Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, - Scheme_Object *orig_form, int comp_rev); - -void scheme_add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env); - -void scheme_default_compile_rec(Scheme_Compile_Info *src, int drec); -void scheme_compile_rec_done_local(Scheme_Compile_Info *src, int drec); -void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n); -void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n); -void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec); -void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec); - - -void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, - Scheme_Expand_Info *dest, int n); +Scheme_Linklet *scheme_compile_and_optimize_linklet(Scheme_Object *form, Scheme_Object *name); +Scheme_Linklet *scheme_compile_linklet(Scheme_Object *form, int set_undef, Scheme_Object *import_keys); Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list, int strip_values, @@ -3398,7 +2976,7 @@ void scheme_finish_application(Scheme_App_Rec *app); Scheme_Sequence *scheme_malloc_sequence(int count); -Scheme_Object *scheme_jit_expr(Scheme_Object *); +Scheme_Linklet *scheme_jit_linklet(Scheme_Linklet *, int step); Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Object *context); void scheme_jit_fill_threadlocal_table(); @@ -3409,76 +2987,20 @@ void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Schem struct Start_Module_Args; #ifdef MZ_USE_JIT -void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name); -void *scheme_module_exprun_start(Scheme_Env *menv, int phase_plus_set_ns, Scheme_Object *name); -void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name); +Scheme_Object *scheme_linklet_run_start(Scheme_Linklet* linklet, Scheme_Instance *instance, Scheme_Object *name); #endif -void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env); -void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns); -void *scheme_module_start_finish(struct Start_Module_Args *a); +Scheme_Object *scheme_linklet_run_finish(Scheme_Linklet* linklet, Scheme_Instance *instance, int use_prompt); Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *env); -#define SCHEME_SYNTAX(obj) SCHEME_PTR1_VAL(obj) -#define SCHEME_SYNTAX_EXP(obj) SCHEME_PTR2_VAL(obj) - -int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame); -int scheme_env_max_use_above(Scheme_Comp_Env *frame, int pos); -void scheme_mark_all_use(Scheme_Comp_Env *frame); -void scheme_env_make_variables(Scheme_Comp_Env *frame); -void scheme_set_compilation_variables(Scheme_Comp_Env *frame, Scheme_IR_Local **vars, - int pos, int count); - /* flags reported by scheme_resolve_info_flags */ #define SCHEME_INFO_BOXED 0x1 #define SCHEME_INFO_TYPED_VAL_SHIFT 4 #define SCHEME_INFO_TYPED_VAL_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_INFO_TYPED_VAL_SHIFT) -/* flags used with scheme_new_frame */ -#define SCHEME_TOPLEVEL_FRAME (1 << 0) -#define SCHEME_MODULE_FRAME (1 << 1) -#define SCHEME_MODULE_BEGIN_FRAME (1 << 2) -#define SCHEME_LAMBDA_FRAME (1 << 3) -#define SCHEME_INTDEF_FRAME (1 << 4) -#define SCHEME_USE_SCOPES_TO_NEXT (1 << 5) -#define SCHEME_CAPTURE_WITHOUT_RENAME (1 << 6) -#define SCHEME_FOR_STOPS (1 << 7) -#define SCHEME_FOR_INTDEF (1 << 8) -#define SCHEME_CAPTURE_LIFTED (1 << 9) -#define SCHEME_INTDEF_SHADOW (1 << 10) -#define SCHEME_POST_BIND_FRAME (1 << 11) -#define SCHEME_NESTED_MODULE_FRAME (1 << 12) -#define SCHEME_KEEP_SCOPES_FRAME (1 << 13) -#define SCHEME_TMP_TL_BIND_FRAME (1 << 14) - -#define SCHEME_REC_BINDING_FRAME (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_BEGIN_FRAME \ - | SCHEME_INTDEF_FRAME | SCHEME_FOR_INTDEF) - -/* Flags used with scheme_static_distance */ -#define SCHEME_ELIM_CONST 1 -#define SCHEME_APP_POS 2 -#define SCHEME_SETTING 4 -#define SCHEME_ENV_CONSTANTS_OK 8 -#define SCHEME_GLOB_ALWAYS_REFERENCE 16 -#define SCHEME_MUST_INDRECT 32 -#define SCHEME_LINKING_REF 64 -#define SCHEME_DONT_MARK_USE 128 -#define SCHEME_OUT_OF_CONTEXT_OK 256 -#define SCHEME_NULL_FOR_UNBOUND 512 -#define SCHEME_RESOLVE_MODIDS 1024 -#define SCHEME_NO_CERT_CHECKS 2048 -#define SCHEME_REFERENCING 4096 -#define SCHEME_OUT_OF_CONTEXT_LOCAL 8192 -#define SCHEME_STOP_AT_FREE_EQ 16384 - Scheme_Hash_Table *scheme_map_constants_to_globals(void); const char *scheme_look_for_primitive(void *code); -Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); -Scheme_Object *scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); - Scheme_Object *scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto); Scheme_Object *scheme_make_svector(mzshort v, mzshort *a); @@ -3492,18 +3014,10 @@ Scheme_Object *scheme_make_branch(Scheme_Object *test, Scheme_Object *tbranch, Scheme_Object *fbranch); -int scheme_is_toplevel(Scheme_Comp_Env *env); -int scheme_is_nested_module(Scheme_Comp_Env *env); -Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env); - Scheme_Env *scheme_make_empty_env(void); void scheme_prepare_exp_env(Scheme_Env *env); void scheme_prepare_template_env(Scheme_Env *env); void scheme_prepare_label_env(Scheme_Env *env); -void scheme_prepare_env_stx_context(Scheme_Env *env); - -XFORM_NONGCING Scheme_Object *scheme_env_phase(Scheme_Env *env); -Scheme_Env *scheme_find_env_at_phase(Scheme_Env *env, Scheme_Object *phase); int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags, Optimize_Info *opt_info, Optimize_Info *warn_info); @@ -3526,26 +3040,25 @@ typedef struct { int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */ int authentic; /* conservatively 0 is ok */ int num_gets, num_sets; + int setter_fields; /* if indexed, bitmap for first 32 fields to indicate which have setters */ } Simple_Struct_Type_Info; Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int flags, int *_auto_e_depth, Simple_Struct_Type_Info *_stinfo, Scheme_Object **_parent_identity, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, Scheme_Object **_name, int fuel); int scheme_is_simple_make_struct_type_property(Scheme_Object *app, int vals, int flags, int *_has_guard, - Scheme_Hash_Table *top_level_consts, - Scheme_Hash_Table *inline_variants, + Optimize_Info *info, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, - Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + Scheme_Linklet *enclosing_linklet, int fuel); #define CHECK_STRUCT_TYPE_RESOLVED 0x1 #define CHECK_STRUCT_TYPE_ALWAYS_SUCCEED 0x2 @@ -3581,10 +3094,10 @@ Scheme_Object *scheme_make_struct_property_proc_shape(intptr_t k); #define STRUCT_PROP_PROC_SHAPE_GETTER 3 #define SCHEME_PROP_PROC_SHAPE_MODE(obj) ((Scheme_Small_Object *)obj)->u.int_val -Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected); -int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); +Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected, int imprecise); +intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v); -int scheme_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected); +intptr_t scheme_get_or_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected); int scheme_decode_struct_prop_shape(Scheme_Object *shape, intptr_t *_v); int scheme_closure_preserves_marks(Scheme_Object *p); int scheme_native_closure_preserves_marks(Scheme_Object *p); @@ -3596,48 +3109,18 @@ Scheme_Object *scheme_make_application(Scheme_Object *v, Optimize_Info *info); Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Optimize_Info *info); int scheme_is_foldable_prim(Scheme_Object *f); -Scheme_Object *scheme_get_stop_expander(void); - void scheme_define_parse(Scheme_Object *form, Scheme_Object **vars, Scheme_Object **val, - int defmacro, - Scheme_Comp_Env *env, - int no_toplevel_check); + Scheme_Comp_Env *env); -void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as_var); -void scheme_binding_names_from_module(Scheme_Env *menv); -void scheme_install_binding_names(Scheme_Object *binding_namess, Scheme_Env *env); -Scheme_Hash_Table *scheme_get_binding_names_table(Scheme_Env *env); - -int scheme_prefix_depth(Resolve_Prefix *rp); -Scheme_Object **scheme_push_prefix(Scheme_Env *genv, int already_linked, Resolve_Prefix *rp, - Scheme_Object *src_modix, Scheme_Object *now_modix, - int src_phase, int now_phase, - Scheme_Env *dummy_env, Scheme_Object *insp); -void scheme_pop_prefix(Scheme_Object **rs); -Scheme_Object *scheme_suspend_prefix(Scheme_Object **rs); -Scheme_Object **scheme_resume_prefix(Scheme_Object *v); - -Scheme_Object *scheme_eval_clone(Scheme_Object *expr); -Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp); -Scheme_Object *scheme_module_eval_clone(Scheme_Object *data); -Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *form); - -Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env); -Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy); - -void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, - int depth, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - Scheme_Object **toplevels, - int code_vec); +void scheme_validate_linklet(Mz_CPort *port, Scheme_Linklet *linklet); typedef mzshort **Validate_TLS; struct Validate_Clearing; void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, char *closure_stack, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int self_pos_in_closure, Scheme_Hash_Tree *procs, Scheme_Hash_Table **_st_ht); @@ -3651,8 +3134,6 @@ void scheme_ill_formed(Mz_CPort *port); # define scheme_ill_formed_code(port) scheme_ill_formed(port) #endif -Scheme_Object *scheme_check_name_property(Scheme_Object *stx, Scheme_Object *current_name); - Scheme_Object *scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Object *expr, Scheme_Comp_Env *env); typedef struct Scheme_Marshal_Tables { @@ -3661,62 +3142,47 @@ typedef struct Scheme_Marshal_Tables { Scheme_Hash_Table *symtab; Scheme_Hash_Table *st_refs; Scheme_Object *st_ref_stack; - Scheme_Hash_Table *reachable_scopes; /* filled on -1 pass */ - Scheme_Object *reachable_scope_stack; /* used on -1 pass */ - Scheme_Hash_Table *pending_reachable_ids; /* use on -1 pass */ - Scheme_Hash_Table *conditionally_reachable_scopes; /* filled/used on -1 pass */ Scheme_Hash_Table *intern_map; /* filled on first pass */ - Scheme_Hash_Table *identity_map; /* filled on first pass */ - Scheme_Hash_Table *top_map; /* used on every pass */ Scheme_Hash_Table *key_map; /* set after first pass, used on later passes */ Scheme_Hash_Table *delay_map; /* set during first pass, used on later passes */ - Scheme_Hash_Table *rn_saved; /* maps each original object to generated marshaling */ Scheme_Object **cdata_map; /* for delay-load wrappers */ int cdata_counter; /* used with cdata_map */ intptr_t *shared_offsets; /* set in second pass */ Scheme_Hash_Table *path_cache; /* cache for path-to-relative resolution */ intptr_t sorted_keys_count; - intptr_t inspector_counter; /* for deterministic symbol allocation */ Scheme_Object **sorted_keys; } Scheme_Marshal_Tables; -void scheme_marshal_using_key(Scheme_Marshal_Tables *mt, Scheme_Object *key); -Scheme_Object *scheme_marshal_lookup(Scheme_Marshal_Tables *mt, Scheme_Object *a); -Scheme_Object *scheme_marshal_wrap_set(Scheme_Marshal_Tables *mt, Scheme_Object *a, Scheme_Object *v); -void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt); -void scheme_marshal_pop_refs(Scheme_Marshal_Tables *mt, int keep); - typedef struct Scheme_Unmarshal_Tables { MZTAG_IF_REQUIRED - Scheme_Hash_Table *rns; - Scheme_Hash_Table *current_rns; /* in-progress unmarshal, commit to `rns` at end */ - Scheme_Hash_Table *multi_scope_pairs; /* records conversions */ - Scheme_Hash_Table *current_multi_scope_pairs; /* commit to `multi_scope_pairs` at end */ struct CPort *rp; char *decoded; mzlonglong bytecode_hash; } Scheme_Unmarshal_Tables; -Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut, - Scheme_Object *wraps_key, - int *_decoded); -void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, - Scheme_Object *wraps_key, - Scheme_Object *v); + +typedef struct Scheme_Load_Delay { + MZTAG_IF_REQUIRED + Scheme_Object *path; + intptr_t file_offset, size; + uintptr_t symtab_size; + Scheme_Object **symtab; + intptr_t *shared_offsets; + Scheme_Hash_Table *symtab_entries; /* `symtab` content to be skipped by resolve_references */ + Scheme_Object *relto; + Scheme_Unmarshal_Tables *ut; + struct CPort *current_rp; + int perma_cache; + unsigned char *cached; + Scheme_Object *cached_port; + struct Scheme_Load_Delay *clear_bytes_prev; + struct Scheme_Load_Delay *clear_bytes_next; + int unsafe_ok; + mzlonglong bytecode_hash; +} Scheme_Load_Delay; Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v); -int scheme_is_rename_transformer(Scheme_Object *o); -int scheme_is_binding_rename_transformer(Scheme_Object *o); -Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o, Scheme_Comp_Env *env); -int scheme_is_set_transformer(Scheme_Object *o); -Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o); - -int scheme_is_expansion_context_symbol(Scheme_Object *v); -int scheme_expansion_contexts_include(Scheme_Object *o, Scheme_Object *ctx); -Scheme_Object *scheme_frame_to_expansion_context_symbol(int flags); - -Scheme_Object *scheme_top_level_require_execute(Scheme_Object *data); Scheme_Object *scheme_case_lambda_execute(Scheme_Object *expr); Scheme_Object *scheme_module_jit(Scheme_Object *data); @@ -3724,344 +3190,137 @@ Scheme_Object *scheme_top_level_require_jit(Scheme_Object *data); Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr); /*========================================================================*/ -/* namespaces and modules */ +/* linklet instance and environment */ /*========================================================================*/ -typedef struct Scheme_Module_Registry { - Scheme_Object so; /* scheme_module_registry_type */ - Scheme_Hash_Table *loaded; /* symbol -> module ; loaded modules, - shared with modules in same space */ - Scheme_Hash_Table *exports; /* symbol -> module-exports */ -} Scheme_Module_Registry; - +/* A Scheme_Env acts as a wrapper for namespaces, which are externally + implemented (via `scheme_startup_instance`). */ struct Scheme_Env { - Scheme_Object so; /* scheme_namespace_type */ - - signed char disallow_unbound, rename_set_ready; - - struct Scheme_Module *module; /* NULL => top-level */ - - Scheme_Module_Registry *module_registry; - Scheme_Module_Registry *module_pre_registry; /* for expanding submodules */ - Scheme_Object *guard_insp; /* instantiation-time inspector, for granting - protected access */ - Scheme_Object *access_insp; /* for gaining protected access */ - - Scheme_Object *stx_context; /* encapsulates scopes, shifts, etc. */ - Scheme_Object *tmp_bind_scope; /* for compiling top-level definitions */ - - Scheme_Bucket_Table *syntax; - struct Scheme_Env *exp_env; - struct Scheme_Env *template_env; - struct Scheme_Env *label_env; - struct Scheme_Env *instance_env; /* shortcut to env where module is instantiated */ - struct Scheme_Env *reader_env; /* namespace to use for #reader or #lang */ - - Scheme_Hash_Table *shadowed_syntax; /* top level only */ - - Scheme_Object *lift_key; /* for `syntax-local-lift-context' */ - - /* Per-instance: */ - intptr_t phase, mod_phase; - Scheme_Object *link_midx; - Scheme_Object *require_names, *et_require_names, *tt_require_names, *dt_require_names; /* resolved */ - Scheme_Hash_Table *other_require_names; - char *running; /* array of size `num_phases' if `module' and `mod_phase==0' */ - char attached, ran; - Scheme_Object *did_starts; - Scheme_Object *available_next[2]; - - Scheme_Bucket_Table *toplevel; - Scheme_Object *modchain; /* Vector of: - 1. symbol -> env ; running modules, - shared with instances in same phase - 2. modchain for next phase (or #f) - 3. modchain for previous phase (or #f) */ - - Scheme_Hash_Table *modvars; /* for scheme_module_variable_type hashing */ - - Scheme_Object *weak_self_link; /* for Scheme_Bucket_With_Home */ - - /* The `binding_names` table can be an immutable or mutable hash table: */ - Scheme_Object *binding_names; /* maps symbols to identifiers */ - short binding_names_need_shift; /* => binding names are from module, and need a shift */ - short interactive_bindings; /* => module namespace is interactive and shadowing is needed */ - - int id_counter; + Scheme_Object so; /* scheme_env_type */ + Scheme_Object *namespace; + Scheme_Instance *instance; + /* Used for setting up "extensions" */ + int cross_phase; + Scheme_Hash_Tree *protected; }; -/* A module access path (or "idx") is a pair: sexp * symbol-or-#f - The symbol is the resolved module name, or #f if it's not - yet resolved. */ +/* A Scheme_Startup_Env holds tables of primitives */ +struct Scheme_Startup_Env { + Scheme_Object so; /* scheme_startup_env_type */ + Scheme_Hash_Table *current_table; /* used during startup */ + Scheme_Hash_Table *primitive_tables; /* symbol -> hash table */ + Scheme_Hash_Table *all_primitives_table; + Scheme_Hash_Table *primitive_ids_table; /* value -> integer */ +}; -/* A Scheme_Module corresponds to a module declaration. A module - instantiation is reprsented by a Scheme_Env */ +extern Scheme_Startup_Env * scheme_startup_env; -typedef struct Scheme_Module_Export_Info { - MZTAG_IF_REQUIRED - char *provide_protects; /* 1 => protected, 0 => not */ - Scheme_Object **indirect_provides; /* symbols (internal names) */ - int num_indirect_provides; +/* A Scheme_Instance is a linklet instance */ +struct Scheme_Instance { + Scheme_Inclhash_Object iso; /* 0x1 => inline only imprecise info into clients */ - /* Only if needed to reconstruct the renaming: */ - Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */ - int num_indirect_syntax_provides; + union { + Scheme_Bucket **a; /* for a small, predefined number of keys */ + Scheme_Bucket_Table *bt; /* general case */ + } variables; + int array_size; /* 0 => hash mode */ + + Scheme_Object *weak_self_link; /* for Scheme_Bucket_With_Home */ - Scheme_Hash_Table *accessible; /* (symbol -> ...) */ -} Scheme_Module_Export_Info; + Scheme_Hash_Tree *source_names; /* bucket symbol -> source symbol; initially copied from linklet */ + + Scheme_Object *name; /* for reporting purposes */ + Scheme_Object *data; +}; -typedef struct Scheme_Module +#define SCHEME_INSTANCE_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) +#define SCHEME_INSTANCE_USE_IMPRECISE 0x1 + +Scheme_Instance *scheme_make_instance(Scheme_Object *name, Scheme_Object *data); +Scheme_Bucket *scheme_instance_variable_bucket(Scheme_Object *symbol, Scheme_Instance *inst); +Scheme_Bucket *scheme_instance_variable_bucket_or_null(Scheme_Object *symbol, Scheme_Instance *inst); + +struct Scheme_Linklet { - Scheme_Object so; /* scheme_module_type */ - short predefined; + Scheme_Object so; /* scheme_linklet_type */ - Scheme_Object *phaseless; /* NULL, #t, or shared `toplevel' hash table */ + Scheme_Object *name; /* for reporting purposes; FIXME: doesn't belong here? */ - Scheme_Object *code_key; + Scheme_Object *importss; /* vector of vector of symbol (extenal names) */ + Scheme_Object *import_shapes; /* optional flattened vector of values; records compiler assumptions */ + int num_total_imports; /* total number of symbols in `importss` */ - Scheme_Object *modname; - Scheme_Object *modsrc; + /* The symbols in the `defns` arracy correspond to external names + for the first `num_exports` entries. The remaining (non-exported) + names should be adjusted on instantiation to avoid conflicts with + any existing names; a #f value indicates an unused variable whose + definition has been pruned. Unreadable symbols starting with "?" were + generated for resolve-pass lifts. */ + Scheme_Object *defns; /* vector of symbol-or-#f */ + int num_exports; /* this many in the prefix of `defns` are exported */ + int num_lifts; /* this many at the tail of `exports` are from resolve lifts */ - Scheme_Object *et_requires; /* list of symbol-or-module-path-index */ - Scheme_Object *requires; /* list of symbol-or-module-path-index */ - Scheme_Object *tt_requires; /* list of symbol-or-module-path-index */ - Scheme_Object *dt_requires; /* list of symbol-or-module-path-index */ - Scheme_Hash_Table *other_requires; /* phase to list of symbol-or-module-path-index */ - - Scheme_Invoke_Proc prim_body; - Scheme_Invoke_Proc prim_et_body; - - Scheme_Object **bodies; /* array `num_phases' long */ - - struct Scheme_Module_Exports *me; - - int num_phases; - Scheme_Module_Export_Info **exp_infos; /* array `num_phases' long */ - - Scheme_Object *self_modidx; - - /* These tables are unshifted, so they are relative to self_modidx - and must be shifted as they are installed into an environment. - The tables can be immutable or immutable hash tables, or they can - be a vectors that should be converted to an immutable hash - table. */ - Scheme_Object *binding_names; /* maps symbols to identifiers */ - Scheme_Object *et_binding_names; /* maps symbols to identifiers */ - Scheme_Object *other_binding_names; /* maps phases to maps symbols to identifiers */ - - Scheme_Object *insp; /* declaration-time inspector, for module instantiation - and enabling access to protected imports */ - - Scheme_Object *lang_info; /* NULL or vector */ - - Scheme_Object *hints; /* set by expansion; moved to properties */ - Scheme_Object *ii_src; /* set by compile, temporary */ - Comp_Prefix *comp_prefix; /* set by body compile, temporary */ - void **super_bxs_info; /* set by expansion; temporary */ - Scheme_Object **sub_iidx_ptrs; /* set by expansion; temporary */ + /* For error reporting, we can recover the source name from the + symbol that is used in the bucket; this table is merged to the + one in the instance, updating symbols as changed to avoid + conflicts. */ + Scheme_Hash_Tree *source_names; /* symbol (external name) -> symbol (internal or source name) */ + + Scheme_Object *bodies; /* vector of definition or expression */ int max_let_depth; - Resolve_Prefix *prefix; + int need_instance_access; /* whether the instance-access toplevel is needed */ - Scheme_Object *dummy; /* for accessing the environment */ + int jit_ready; /* true if the linklet is in has been prepared for the JIT */ - Scheme_Env *primitive; + Scheme_Hash_Table *constants; /* holds info about the linklet's body for inlining */ +}; - Scheme_Object *rn_stx; /* NULL, #t, a stx for a rename, a vector of stxes, or a pair to delay shifts */ +#define SCHEME_DEFN_VAR_COUNT(d) (SCHEME_VEC_SIZE(d)-1) +#define SCHEME_DEFN_RHS(d) (SCHEME_VEC_ELS(d)[0]) +#define SCHEME_DEFN_VAR_(d, pos) (SCHEME_VEC_ELS(d)[(pos)+1]) +#define SCHEME_DEFN_VAR(d, pos) ((Scheme_IR_Toplevel *)SCHEME_DEFN_VAR_(d, pos)) - Scheme_Object *submodule_path; /* path to this module relative to enclosing top-level module */ - Scheme_Object *pre_submodules, *post_submodules; /* list of modules (when compiled or loaded as a group) */ - Scheme_Object *pre_submodule_names; /* list of symbols (in expand mode) */ - Scheme_Object *supermodule; /* supermodule for which this is in {pre,post}_submodules */ - Scheme_Object *submodule_ancestry; /* set by compile/expand, temporary */ -} Scheme_Module; - -typedef struct Scheme_Module_Phase_Exports -{ - Scheme_Object so; - - Scheme_Object *phase_index; - - Scheme_Object *src_modidx; /* same as in enclosing Scheme_Module_Exports */ - - Scheme_Object **provides; /* symbols (extenal names) */ - Scheme_Object **provide_srcs; /* module access paths, #f for self */ - Scheme_Object **provide_src_names; /* symbols (original internal names) */ - Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */ - int *provide_src_phases; /* NULL, or src phase for for-syntax import */ - int num_provides; - int num_var_provides; /* non-syntax listed first in provides */ - - Scheme_Hash_Table *ht; /* maps external names to array indices; created lazily */ -} Scheme_Module_Phase_Exports; - -typedef struct Scheme_Module_Exports -{ - /* Scheme_Module_Exports is separate from Scheme_Module - so that we can create a global table mapping export - keys to exports. This mapping is used to lazily - unmarshal syntax-object context. */ - MZTAG_IF_REQUIRED - - /* Most common phases: */ - Scheme_Module_Phase_Exports *rt; /* run time? phase 0*/ - Scheme_Module_Phase_Exports *et; /* expansion time? phase 1 */ - Scheme_Module_Phase_Exports *dt; /* */ - - /* All others: */ - Scheme_Hash_Table *other_phases; - - Scheme_Object *src_modidx; /* the one used in marshalled syntax */ - Scheme_Object *modsrc; /* module source as loaded */ -} Scheme_Module_Exports; - -typedef struct Scheme_Modidx { - Scheme_Object so; /* scheme_module_index_type */ - - Scheme_Object *path; - Scheme_Object *base; - Scheme_Object *resolved; - Scheme_Object *shift_cache; /* vector */ - struct Scheme_Modidx *cache_next; -} Scheme_Modidx; - -typedef struct Module_Variable { - Scheme_Inclhash_Object iso; /* see SCHEME_MODVAR_... flags */ - Scheme_Object *modidx; - Scheme_Object *sym; - Scheme_Object *insp; /* for checking protected/unexported access */ - Scheme_Object *shape; /* NULL or a symbol encoding "type" information */ - int pos, mod_phase; -} Module_Variable; - -/* See SCHEME_TOPLEVEL_...: */ -#define SCHEME_MODVAR_CONST 0x1 -#define SCHEME_MODVAR_FIXED 0x2 - -#define SCHEME_MODVAR_FLAGS(pr) MZ_OPT_HASH_KEY(&((Module_Variable *)pr)->iso) +/* Recycle some vector flags to use on definitions for the compiler, + optimizer, and resolver to commuincate: */ +#define SCHEME_DEFN_ALWAYS_INLINEP(d) SCHEME_IMMUTABLEP(d) +#define SCHEME_SET_DEFN_ALWAYS_INLINE(d) SCHEME_SET_IMMUTABLE(d) +#define SCHEME_DEFN_CAN_OMITP(d) SHARED_ALLOCATEDP(d) +#define SCHEME_SET_DEFN_CAN_OMIT(d) SHARED_ALLOCATED_SET(d) #define SCHEME_VARREF_FLAGS(pr) MZ_OPT_HASH_KEY(&((Scheme_Simple_Object *)pr)->iso) +#define VARREF_IS_CONSTANT 0x1 +#define VARREF_FROM_UNSAFE 0x2 +#define VARREF_FLAGS_MASK (VARREF_IS_CONSTANT | VARREF_FROM_UNSAFE) -void scheme_add_global_keyword(const char *name, Scheme_Object *v, Scheme_Env *env); -void scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env); -void scheme_add_global_constant(const char *name, Scheme_Object *v, Scheme_Env *env); -void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env); +void scheme_addto_prim_instance(const char *name, Scheme_Object *obj, Scheme_Startup_Env *env); +void scheme_addto_primitive_instance_by_symbol(Scheme_Object *name, Scheme_Object *obj, Scheme_Startup_Env *env); +void scheme_switch_prim_instance(Scheme_Startup_Env *env, const char *name); +void scheme_restore_prim_instance(Scheme_Startup_Env *env); -#define GLOBAL_FOLDING_PRIM(name, func, a1, a2, a3, env) scheme_add_global_constant(name, scheme_make_folding_prim(func, name, a1, a2, a3), env) -#define GLOBAL_IMMED_PRIM(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_immed_prim(func, name, a1, a2), env) -#define GLOBAL_PARAMETER(name, func, constant, env) scheme_add_global_constant(name, scheme_register_parameter(func, name, constant), env) -#define GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_prim_w_arity(func, name, a1, a2), env) -#define GLOBAL_PRIM_W_ARITY2(name, func, a1, a2, a3, a4, env) scheme_add_global_constant(name, scheme_make_prim_w_arity2(func, name, a1, a2, a3, a4), env) -#define GLOBAL_NONCM_PRIM(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_noncm_prim(func, name, a1, a2), env) +#define ADD_FOLDING_PRIM(name, func, a1, a2, a3, env) scheme_addto_prim_instance(name, scheme_make_folding_prim(func, name, a1, a2, a3), env) +#define ADD_IMMED_PRIM(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_immed_prim(func, name, a1, a2), env) +#define ADD_PARAMETER(name, func, constant, env) scheme_addto_prim_instance(name, scheme_register_parameter(func, name, constant), env) +#define ADD_PRIM_W_ARITY(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_prim_w_arity(func, name, a1, a2), env) +#define ADD_PRIM_W_ARITY2(name, func, a1, a2, a3, a4, env) scheme_addto_prim_instance(name, scheme_make_prim_w_arity2(func, name, a1, a2, a3, a4), env) +#define ADD_NONCM_PRIM(name, func, a1, a2, env) scheme_addto_prim_instance(name, scheme_make_noncm_prim(func, name, a1, a2), env) -#define GLOBAL_FOLDING_PRIM_UNARY_INLINED(name, func, a1, a2, a3, env) do {\ +#define ADD_FOLDING_PRIM_UNARY_INLINED(name, func, a1, a2, a3, env) do {\ Scheme_Object *p; \ p = scheme_make_folding_prim(func, name, a1, a2, a3); \ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); \ - scheme_add_global_constant(name, p, env); \ + scheme_addto_prim_instance(name, p, env); \ } while(0) -Scheme_Object *scheme_global_binding(Scheme_Object *id, Scheme_Env *env, int for_top_level); -Scheme_Object *scheme_future_global_binding(Scheme_Object *id, Scheme_Env *env); +THREAD_LOCAL_DECL(extern Scheme_Bucket_Table *scheme_namespace_to_env); +Scheme_Env *scheme_get_current_namespace_as_env(); +void scheme_set_current_namespace_as_env(Scheme_Env *env); -Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env); -Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase); - -THREAD_LOCAL_DECL(extern Scheme_Bucket_Table *scheme_module_code_cache); -Scheme_Object *scheme_module_execute(Scheme_Object *data, Scheme_Env *genv); - -Scheme_Env *scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, - int new_exp_module_tree, int new_pre_registry); -int scheme_is_module_env(Scheme_Comp_Env *env); - -Scheme_Env *scheme_make_env_like(Scheme_Env *base); - -Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it); -Scheme_Env *scheme_module_access(Scheme_Object *modname, Scheme_Env *env, intptr_t rev_mod_phase); - -int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname); - -Scheme_Module_Exports *scheme_make_module_exports(); - -Scheme_Object *scheme_check_accessible_in_module_instance(Scheme_Env *env, - Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - int position, int want_pos, - int *_protected, int *_unexported, - Scheme_Env *from_env, int *_would_complain, - Scheme_Object **_is_constant); -Scheme_Object *scheme_check_accessible_in_module_name(Scheme_Object *modidx, intptr_t mod_phase, Scheme_Env *env, - Scheme_Object *symbol, int position, - Scheme_Object *current_insp, Scheme_Object *binding_insp, - Scheme_Object **_is_constant); -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name, int mod_phase); - -Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, - Scheme_Object *shift_from_modidx, - Scheme_Object *shift_to_modidx); - -Scheme_Object *scheme_modidx_submodule(Scheme_Object *modidx); -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache); - -#define SCHEME_RMPP(o) (SAME_TYPE(SCHEME_TYPE((o)), scheme_resolved_module_path_type)) -#define SCHEME_MODNAMEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)) - -Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o); -Scheme_Object *scheme_resolved_module_path_value(Scheme_Object *rmp); -int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object *o); - -Scheme_Object *scheme_resolved_module_path_to_modidx(Scheme_Object *rmp); - -Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, - Scheme_Object *stxsym, Scheme_Object *insp, - int pos, intptr_t mod_phase, int is_constant, - Scheme_Object *shape); - - -Scheme_Env *scheme_get_kernel_env(); -int scheme_is_kernel_env(); -Scheme_Env *scheme_get_unsafe_env(); -Scheme_Env *scheme_get_flfxnum_env(); -Scheme_Env *scheme_get_extfl_env(); -Scheme_Env *scheme_get_futures_env(); -Scheme_Env *scheme_get_foreign_env(); - -void scheme_install_initial_module_set(Scheme_Env *env); Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home); -Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Object *modchain, int clone); - -Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o); - -int scheme_is_kernel_modname(Scheme_Object *modname); -int scheme_is_unsafe_modname(Scheme_Object *modname); -int scheme_is_flfxnum_modname(Scheme_Object *modname); -int scheme_is_extfl_modname(Scheme_Object *modname); -int scheme_is_futures_modname(Scheme_Object *modname); -int scheme_is_foreign_modname(Scheme_Object *modname); - -void scheme_clear_modidx_cache(void); -void scheme_clear_shift_cache(void); -void scheme_clear_prompt_cache(void); - -Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath, - Scheme_Object *mode); -Scheme_Object *scheme_module_exported_list(Scheme_Object *modpath, Scheme_Env *genv); - -void scheme_prepare_compile_env(Scheme_Env *env); - -Scheme_Object *scheme_module_to_namespace(Scheme_Object *name, Scheme_Env *env); -void scheme_prep_namespace_rename(Scheme_Env *menv); - -Scheme_Object *scheme_string_to_submodule_path(char *_s, intptr_t len); -char *scheme_submodule_path_to_string(Scheme_Object *p, intptr_t *_len); - -Scheme_Object *scheme_annotate_existing_submodules(Scheme_Object *orig_fm, int incl_star); - -Scheme_Object *scheme_get_modsrc(Scheme_Module *m); - -Scheme_Object *scheme_prune_bindings_table(Scheme_Object *bindings, Scheme_Object *rn_stx, Scheme_Object *phase); +Scheme_Object *scheme_string_to_symbol_path(char *_s, intptr_t len); +char *scheme_symbol_path_to_string(Scheme_Object *p, intptr_t *_len); /*========================================================================*/ /* errors and exceptions */ @@ -4069,39 +3328,19 @@ Scheme_Object *scheme_prune_bindings_table(Scheme_Object *bindings, Scheme_Objec #define NOT_SUPPORTED_STR "unsupported on this platform" +intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...); + int scheme_last_error_is_racket(int errid); -void scheme_read_err(Scheme_Object *port, - Scheme_Object *stxsrc, - intptr_t line, intptr_t column, intptr_t pos, intptr_t span, - int is_eof, Scheme_Object *indentation, - const char *detail, ...); -Scheme_Object *scheme_numr_err(Scheme_Object *complain, - Scheme_Object *stxsrc, - intptr_t line, intptr_t column, intptr_t pos, intptr_t span, - Scheme_Object *indentation, - const char *detail, ...); +void scheme_read_err(Scheme_Object *port, const char *detail, ...); +Scheme_Object *scheme_numr_err(Scheme_Object *complain, const char *detail, ...); + char *scheme_extract_indentation_suggestions(Scheme_Object *indentation); void scheme_wrong_syntax(const char *where, Scheme_Object *local_form, Scheme_Object *form, const char *detail, ...); -void scheme_unbound_syntax(const char *where, - Scheme_Object *local_form, - Scheme_Object *form, - const char *detail, ...); -void scheme_wrong_syntax_with_more_sources(const char *where, - Scheme_Object *detail_form, - Scheme_Object *form, - Scheme_Object *extra_sources, - const char *detail, ...); -extern const char *scheme_compile_stx_string; -extern const char *scheme_expand_stx_string; -extern const char *scheme_application_stx_string; -extern const char *scheme_set_stx_string; -extern const char *scheme_var_ref_string; -extern const char *scheme_begin_stx_string; void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv); @@ -4156,16 +3395,15 @@ typedef struct { MZTAG_IF_REQUIRED Scheme_Object *syms[5]; int count; - intptr_t phase; Scheme_Hash_Table *ht; } DupCheckRecord; -void scheme_begin_dup_symbol_check(DupCheckRecord *r, Scheme_Comp_Env *e); +void scheme_begin_dup_symbol_check(DupCheckRecord *r); void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, Scheme_Object *symbol, char *what, Scheme_Object *form); - -Scheme_Object *scheme_special_comment_value(Scheme_Object *o); +void scheme_check_identifier(const char *formname, Scheme_Object *id, + const char *where, Scheme_Object *form); Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set); @@ -4244,8 +3482,6 @@ void scheme_do_format(const char *procname, Scheme_Object *port, const mzchar *format, int flen, int fpos, int offset, int argc, Scheme_Object **argv); -Scheme_Object *scheme_load_with_clrd(int argc, Scheme_Object *argv[], char *who, int handler_param); - Scheme_Object *scheme_default_load_extension(int argc, Scheme_Object **argv); Scheme_Object *scheme_remove_current_directory_prefix(Scheme_Object *fn); @@ -4446,6 +3682,8 @@ Scheme_Object *scheme_checked_set_mcar (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_set_mcdr (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv); +Scheme_Object *scheme_checked_vector_star_ref(int argc, Scheme_Object **argv); +Scheme_Object *scheme_checked_vector_star_set(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_vector_cas(int argc, Scheme_Object **argv); Scheme_Object *scheme_string_length(Scheme_Object *v); Scheme_Object *scheme_string_eq_2(Scheme_Object *str1, Scheme_Object *str2); @@ -4455,8 +3693,8 @@ Scheme_Object *scheme_byte_string_length(Scheme_Object *v); Scheme_Object *scheme_byte_string_eq_2(Scheme_Object *str1, Scheme_Object *str2); Scheme_Object *scheme_checked_byte_string_ref(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_byte_string_set(int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); Scheme_Object *scheme_vector_length(Scheme_Object *v); +Scheme_Object *scheme_vector_star_length(Scheme_Object *v); Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv); Scheme_Object *scheme_flvector_length(Scheme_Object *v); @@ -4474,9 +3712,14 @@ Scheme_Object *scheme_checked_flreal_part (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_flimag_part (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_make_flrectangular (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_char_to_integer (int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_integer_to_char (int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_checked_make_vector (int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_char_to_integer(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_integer_to_char(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_make_vector(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_checked_hash_count(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_unbox_star(Scheme_Object *b); +void scheme_set_box_star(Scheme_Object *b, Scheme_Object *v); Scheme_Object *scheme_check_not_undefined (int argc, Scheme_Object *argv[]); Scheme_Object *scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]); @@ -4488,6 +3731,8 @@ void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *what, Scheme_Object *vec, intptr_t bottom, intptr_t len); +Scheme_Object *scheme_weak_box_value(Scheme_Object *obj); + Scheme_Bucket_Table *scheme_make_weak_equal_table(void); Scheme_Bucket_Table *scheme_make_weak_eqv_table(void); Scheme_Bucket_Table *scheme_make_nonlock_equal_bucket_table(void); @@ -4515,9 +3760,6 @@ intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *t1); void scheme_set_root_param(int p, Scheme_Object *v); -int scheme_equal_modix_eq(Scheme_Object *obj1, Scheme_Object *obj2); -Scheme_Hash_Table *scheme_make_hash_table_equal_modix_eq(); - Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, uintptr_t len); Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2); Scheme_Object *scheme_copy_list(Scheme_Object *l); @@ -4714,8 +3956,12 @@ Scheme_Object *scheme_place_make_async_channel(); void scheme_place_async_channel_send(Scheme_Object *ch, Scheme_Object *uo); Scheme_Object *scheme_place_async_channel_receive(Scheme_Object *ch); #endif - +int scheme_is_predefined_module_path(Scheme_Object *v); + void scheme_process_global_lock(void); void scheme_process_global_unlock(void); +Scheme_Object *scheme_expander_syntax_to_datum(Scheme_Object *v); +int scheme_is_syntax(Scheme_Object *v); + #endif /* __mzscheme_private__ */ diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index b39b350cbc..9a9e88ff88 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.12.0.4" +#define MZSCHEME_VERSION "6.90.0.16" #define MZSCHEME_VERSION_X 6 -#define MZSCHEME_VERSION_Y 12 +#define MZSCHEME_VERSION_Y 90 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 16 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/sema.c b/racket/src/racket/src/sema.c index 6dd673f720..f070826352 100644 --- a/racket/src/racket/src/sema.c +++ b/racket/src/racket/src/sema.c @@ -86,7 +86,7 @@ static Scheme_Object *sema_for_repost(Scheme_Object *s, int *repost) return SCHEME_PTR_VAL(s); } -void scheme_init_sema(Scheme_Env *env) +void scheme_init_sema(Scheme_Startup_Env *env) { Scheme_Object *o; @@ -94,112 +94,112 @@ void scheme_init_sema(Scheme_Env *env) register_traversers(); #endif - scheme_add_global_constant("make-semaphore", + scheme_addto_prim_instance("make-semaphore", scheme_make_prim_w_arity(make_sema, "make-semaphore", 0, 1), env); - scheme_add_global_constant("semaphore?", + scheme_addto_prim_instance("semaphore?", scheme_make_folding_prim(semap, "semaphore?", 1, 1, 1), env); - scheme_add_global_constant("semaphore-post", + scheme_addto_prim_instance("semaphore-post", scheme_make_prim_w_arity(hit_sema, "semaphore-post", 1, 1), env); - scheme_add_global_constant("semaphore-try-wait?", + scheme_addto_prim_instance("semaphore-try-wait?", scheme_make_prim_w_arity(block_sema_p, "semaphore-try-wait?", 1, 1), env); - scheme_add_global_constant("semaphore-wait", + scheme_addto_prim_instance("semaphore-wait", scheme_make_prim_w_arity(block_sema, "semaphore-wait", 1, 1), env); - scheme_add_global_constant("semaphore-wait/enable-break", + scheme_addto_prim_instance("semaphore-wait/enable-break", scheme_make_prim_w_arity(block_sema_breakable, "semaphore-wait/enable-break", 1, 1), env); - scheme_add_global_constant("semaphore-peek-evt", + scheme_addto_prim_instance("semaphore-peek-evt", scheme_make_prim_w_arity(make_sema_repost, "semaphore-peek-evt", 1, 1), env); - scheme_add_global_constant("semaphore-peek-evt?", + scheme_addto_prim_instance("semaphore-peek-evt?", scheme_make_folding_prim(is_sema_repost, "semaphore-peek-evt?", 1, 1, 1), env); - scheme_add_global_constant("make-channel", + scheme_addto_prim_instance("make-channel", scheme_make_prim_w_arity(make_channel, "make-channel", 0, 0), env); - scheme_add_global_constant("channel-put-evt", + scheme_addto_prim_instance("channel-put-evt", scheme_make_prim_w_arity(make_channel_put, "channel-put-evt", 2, 2), env); - scheme_add_global_constant("channel?", + scheme_addto_prim_instance("channel?", scheme_make_folding_prim(channel_p, "channel?", 1, 1, 1), env); - scheme_add_global_constant("channel-put-evt?", + scheme_addto_prim_instance("channel-put-evt?", scheme_make_folding_prim(channel_put_p, "channel-put-evt?", 1, 1, 1), env); - scheme_add_global_constant("chaperone-channel", + scheme_addto_prim_instance("chaperone-channel", scheme_make_prim_w_arity(chaperone_channel, "chaperone-channel", 3, -1), env); - scheme_add_global_constant("impersonate-channel", + scheme_addto_prim_instance("impersonate-channel", scheme_make_prim_w_arity(impersonate_channel, "impersonate-channel", 3, -1), env); - scheme_add_global_constant("thread-send", + scheme_addto_prim_instance("thread-send", scheme_make_prim_w_arity(thread_send, "thread-send", 2, 3), env); - scheme_add_global_constant("thread-receive", + scheme_addto_prim_instance("thread-receive", scheme_make_prim_w_arity(thread_receive, "thread-receive", 0, 0), env); - scheme_add_global_constant("thread-try-receive", + scheme_addto_prim_instance("thread-try-receive", scheme_make_prim_w_arity(thread_try_receive, "thread-try-receive", 0, 0), env); - scheme_add_global_constant("thread-receive-evt", + scheme_addto_prim_instance("thread-receive-evt", scheme_make_prim_w_arity(thread_receive_evt, "thread-receive-evt", 0, 0), env); - scheme_add_global_constant("thread-rewind-receive", + scheme_addto_prim_instance("thread-rewind-receive", scheme_make_prim_w_arity(thread_rewind_receive, "thread-rewind-receive", 1, 1), env); - scheme_add_global_constant("alarm-evt", + scheme_addto_prim_instance("alarm-evt", scheme_make_prim_w_arity(make_alarm, "alarm-evt", 1, 1), env); - scheme_add_global_constant("system-idle-evt", + scheme_addto_prim_instance("system-idle-evt", scheme_make_prim_w_arity(make_sys_idle, "system-idle-evt", 0, 0), @@ -208,11 +208,11 @@ void scheme_init_sema(Scheme_Env *env) REGISTER_SO(scheme_always_ready_evt); scheme_always_ready_evt = scheme_alloc_small_object(); scheme_always_ready_evt->type = scheme_always_evt_type; - scheme_add_global_constant("always-evt", scheme_always_ready_evt, env); + scheme_addto_prim_instance("always-evt", scheme_always_ready_evt, env); o = scheme_alloc_small_object(); o->type = scheme_never_evt_type; - scheme_add_global_constant("never-evt", o, env); + scheme_addto_prim_instance("never-evt", o, env); REGISTER_SO(thread_recv_evt); o = scheme_alloc_small_object(); diff --git a/racket/src/racket/src/sfs.c b/racket/src/racket/src/sfs.c index d7362c3a3a..f9e719a574 100644 --- a/racket/src/racket/src/sfs.c +++ b/racket/src/racket/src/sfs.c @@ -30,11 +30,10 @@ #include "schpriv.h" #include "schrunst.h" #include "schmach.h" -#include "schexpobs.h" struct SFS_Info { MZTAG_IF_REQUIRED - int for_mod, pass; + int for_linklet, pass; int tail_pos; /* in tail position? */ int depth, stackpos, tlpos; /* stack shape */ int selfpos, selfstart, selflen; /* tracks self calls */ @@ -49,6 +48,18 @@ struct SFS_Info { Scheme_Object *saved; }; +static void linklet_sfs(Scheme_Linklet *linklet, SFS_Info *info); +static Scheme_Object *sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos); +static SFS_Info *new_sfs_info(int depth); + +static void sfs_used(SFS_Info *info, int pos); +static void sfs_push(SFS_Info *info, int count, int track); +static void sfs_start_sequence(SFS_Info *si, int cnt, int last_is_tail); +static Scheme_Object *sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre); + +static Scheme_Object *sfs_passes(Scheme_Object *e, SFS_Info *info); +static void linklet_sfs(Scheme_Linklet *linklet, SFS_Info *info); + #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif @@ -67,16 +78,19 @@ void scheme_init_sfs() #define SFS_LOG(x) /* nothing */ -Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth) +Scheme_Linklet *scheme_sfs_linklet(Scheme_Linklet *linklet) +{ + SFS_Info *info; + + info = new_sfs_info(linklet->max_let_depth); + + return (Scheme_Linklet *)sfs_passes((Scheme_Object *)linklet, info); +} + +static Scheme_Object *sfs_passes(Scheme_Object *o, SFS_Info *info) { int init, i; - SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o))); - - if (!info) { - info = scheme_new_sfs_info(max_let_depth); - } - info->pass = 0; info->ip = 1; info->abs_ip = 1; @@ -85,7 +99,11 @@ Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth) info->max_touch = -1; info->tail_pos = 1; init = info->stackpos; - o = scheme_sfs_expr(o, info, -1); + + if (SAME_TYPE(SCHEME_TYPE(o), scheme_linklet_type)) + linklet_sfs((Scheme_Linklet *)o, info); + else + o = sfs_expr(o, info, -1); if (info->seqn) scheme_signal_error("ended in the middle of an expression?"); @@ -111,12 +129,29 @@ Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth) info->abs_ip = 1; info->tail_pos = 1; info->stackpos = init; - o = scheme_sfs_expr(o, info, -1); + if (SAME_TYPE(SCHEME_TYPE(o), scheme_linklet_type)) + linklet_sfs((Scheme_Linklet *)o, info); + else + o = sfs_expr(o, info, -1); return o; } -SFS_Info *scheme_new_sfs_info(int depth) +static void linklet_sfs(Scheme_Linklet *linklet, SFS_Info *info) +{ + Scheme_Object *e; + int i, cnt; + + cnt = SCHEME_VEC_SIZE(linklet->bodies); + sfs_start_sequence(info, cnt, 0); + + for (i = 0; i < cnt; i++) { + e = sfs_expr(SCHEME_VEC_ELS(linklet->bodies)[i], info, -1); + SCHEME_VEC_ELS(linklet->bodies)[i] = e; + } +} + +static SFS_Info *new_sfs_info(int depth) { SFS_Info *info; int *max_used, *max_calls; @@ -162,12 +197,12 @@ static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info) return v; } -void scheme_sfs_start_sequence(SFS_Info *info, int cnt, int last_is_tail) +static void sfs_start_sequence(SFS_Info *info, int cnt, int last_is_tail) { info->seqn += (cnt - (last_is_tail ? 1 : 0)); } -void scheme_sfs_push(SFS_Info *info, int cnt, int track) +static void sfs_push(SFS_Info *info, int cnt, int track) { info->stackpos -= cnt; @@ -178,12 +213,12 @@ void scheme_sfs_push(SFS_Info *info, int cnt, int track) if (track) { while (cnt--) { - scheme_sfs_used(info, cnt); + sfs_used(info, cnt); } } } -void scheme_sfs_used(SFS_Info *info, int pos) +static void sfs_used(SFS_Info *info, int pos) { if (info->pass) return; @@ -212,7 +247,7 @@ void scheme_sfs_used(SFS_Info *info, int pos) info->max_used[pos] = info->ip; } -Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre) +static Scheme_Object *sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre) { int len, i; Scheme_Object *loc; @@ -268,7 +303,7 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator, int flags) int i; for (i = info->selflen; i--; ) { if ((info->selfstart + i) != info->tlpos) - scheme_sfs_used(info, (info->selfstart - info->stackpos) + i); + sfs_used(info, (info->selfstart - info->stackpos) + i); } tail_ok = 1; } @@ -290,12 +325,12 @@ static Scheme_Object *sfs_application(Scheme_Object *o, SFS_Info *info) app = (Scheme_App_Rec *)o; n = app->num_args + 1; - scheme_sfs_start_sequence(info, n, 0); - scheme_sfs_push(info, n-1, 0); + sfs_start_sequence(info, n, 0); + sfs_push(info, n-1, 0); for (i = 0; i < n; i++) { orig = app->args[i]; - naya = scheme_sfs_expr(orig, info, -1); + naya = sfs_expr(orig, info, -1); app->args[i] = naya; } @@ -313,11 +348,11 @@ static Scheme_Object *sfs_application2(Scheme_Object *o, SFS_Info *info) app = (Scheme_App2_Rec *)o; - scheme_sfs_start_sequence(info, 2, 0); - scheme_sfs_push(info, 1, 0); + sfs_start_sequence(info, 2, 0); + sfs_push(info, 1, 0); - nrator = scheme_sfs_expr(app->rator, info, -1); - nrand = scheme_sfs_expr(app->rand, info, -1); + nrator = sfs_expr(app->rator, info, -1); + nrand = sfs_expr(app->rand, info, -1); app->rator = nrator; app->rand = nrand; @@ -335,12 +370,12 @@ static Scheme_Object *sfs_application3(Scheme_Object *o, SFS_Info *info) app = (Scheme_App3_Rec *)o; - scheme_sfs_start_sequence(info, 3, 0); - scheme_sfs_push(info, 2, 0); + sfs_start_sequence(info, 3, 0); + sfs_push(info, 2, 0); - nrator = scheme_sfs_expr(app->rator, info, -1); - nrand1 = scheme_sfs_expr(app->rand1, info, -1); - nrand2 = scheme_sfs_expr(app->rand2, info, -1); + nrator = sfs_expr(app->rator, info, -1); + nrand1 = sfs_expr(app->rand1, info, -1); + nrand2 = sfs_expr(app->rand2, info, -1); app->rator = nrator; app->rand1 = nrand1; @@ -400,11 +435,11 @@ static Scheme_Object *sfs_sequence(Scheme_Object *o, SFS_Info *info, int can_fla seq = (Scheme_Sequence *)o; n = seq->count; - scheme_sfs_start_sequence(info, n, 1); + sfs_start_sequence(info, n, 1); for (i = 0; i < n; i++) { orig = seq->array[i]; - naya = scheme_sfs_expr(orig, info, -2); + naya = sfs_expr(orig, info, -2); seq->array[i] = naya; } @@ -467,7 +502,8 @@ static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, else_end_abs = SCHEME_INT_VAL(o); SFS_LOG(printf(" %d %d %d %d %d\n", nt, ip, b_end, else_end_abs, info->abs_max_nontail)); if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */ - || (else_end_abs < info->abs_max_nontail)) { /* => non-tail call after branches */ + || (!info->tail_pos + && (else_end_abs < info->abs_max_nontail))) { /* => non-tail call after branches */ SFS_LOG(printf(" other\n")); o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W]; t_min_t = SCHEME_INT_VAL(o); @@ -505,7 +541,7 @@ static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, stackpos = info->stackpos; - tbranch = scheme_sfs_expr(tbranch, info, -1); + tbranch = sfs_expr(tbranch, info, -1); if (info->pass) info->max_nontail = save_nt; @@ -516,7 +552,7 @@ static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, } # endif - tbranch = scheme_sfs_add_clears(tbranch, clears, 1); + tbranch = sfs_add_clears(tbranch, clears, 1); if (!info->pass) { t_min_t = info->min_touch; @@ -587,9 +623,9 @@ static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info) b = (Scheme_Branch_Rec *)o; - scheme_sfs_start_sequence(info, 1, 0); + sfs_start_sequence(info, 1, 0); - t = scheme_sfs_expr(b->test, info, -1); + t = sfs_expr(b->test, info, -1); ip = info->ip; info->ip++; @@ -658,16 +694,16 @@ static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info) Scheme_Object *body, *rhs, *clears = scheme_null; int i, pos; - scheme_sfs_start_sequence(info, 2, 1); + sfs_start_sequence(info, 2, 1); - rhs = scheme_sfs_expr(lv->value, info, -1); + rhs = sfs_expr(lv->value, info, -1); if (!info->pass || (info->ip < info->max_nontail)) { for (i = 0; i < lv->count; i++) { pos = lv->position + i; if (!info->pass) - scheme_sfs_used(info, pos); + sfs_used(info, pos); else { int spos; spos = pos + info->stackpos; @@ -683,9 +719,9 @@ static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info) } } - body = scheme_sfs_expr(lv->body, info, -1); + body = sfs_expr(lv->body, info, -1); - body = scheme_sfs_add_clears(body, clears, 1); + body = sfs_add_clears(body, clears, 1); lv->value = rhs; lv->body = body; @@ -700,9 +736,9 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) int pos, save_mnt, ip, et; int unused = 0; - scheme_sfs_start_sequence(info, 2, 1); + sfs_start_sequence(info, 2, 1); - scheme_sfs_push(info, 1, 1); + sfs_push(info, 1, 1); ip = info->ip; pos = info->stackpos; save_mnt = info->max_nontail; @@ -723,8 +759,8 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]); } - rhs = scheme_sfs_expr(lo->value, info, -1); - body = scheme_sfs_expr(lo->body, info, -1); + rhs = sfs_expr(lo->value, info, -1); + body = sfs_expr(lo->body, info, -1); # if MAX_SFS_CLEARING if (!info->pass) @@ -789,7 +825,7 @@ static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info) int i, pos, save_mnt; Scheme_Object *vec; - scheme_sfs_push(info, lv->count, 1); + sfs_push(info, lv->count, 1); pos = info->stackpos; save_mnt = info->max_nontail; @@ -807,7 +843,7 @@ static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info) info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]); } - body = scheme_sfs_expr(lv->body, info, -1); + body = sfs_expr(lv->body, info, -1); # if MAX_SFS_CLEARING if (!info->pass) @@ -838,12 +874,12 @@ static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info) count = lr->count; - scheme_sfs_start_sequence(info, count + 1, 1); + sfs_start_sequence(info, count + 1, 1); procs = lr->procs; for (i = 0; i < count; i++) { - v = scheme_sfs_expr(procs[i], info, i); + v = sfs_expr(procs[i], info, i); if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. @@ -860,9 +896,9 @@ static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info) procs[i] = v; } - v = scheme_sfs_expr(lr->body, info, -1); + v = sfs_expr(lr->body, info, -1); - v = scheme_sfs_add_clears(v, clears, 1); + v = sfs_add_clears(v, clears, 1); lr->body = v; @@ -874,11 +910,11 @@ static Scheme_Object *sfs_wcm(Scheme_Object *o, SFS_Info *info) Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; Scheme_Object *k, *v, *b; - scheme_sfs_start_sequence(info, 3, 1); + sfs_start_sequence(info, 3, 1); - k = scheme_sfs_expr(wcm->key, info, -1); - v = scheme_sfs_expr(wcm->val, info, -1); - b = scheme_sfs_expr(wcm->body, info, -1); + k = sfs_expr(wcm->key, info, -1); + v = sfs_expr(wcm->val, info, -1); + b = sfs_expr(wcm->body, info, -1); wcm->key = k; wcm->val = v; @@ -895,9 +931,9 @@ static Scheme_Object * define_values_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *e; - scheme_sfs_start_sequence(info, 1, 0); - e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); - SCHEME_VEC_ELS(data)[0] = e; + sfs_start_sequence(info, 1, 0); + e = sfs_expr(SCHEME_DEFN_RHS(data), info, -1); + SCHEME_DEFN_RHS(data) = e; return data; } @@ -905,8 +941,8 @@ static Scheme_Object * inline_variant_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *e; - scheme_sfs_start_sequence(info, 1, 0); - e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); + sfs_start_sequence(info, 1, 0); + e = sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); SCHEME_VEC_ELS(data)[0] = e; /* we don't bother with inlinable variant, since it isn't called directly */ return data; @@ -921,10 +957,10 @@ set_sfs(Scheme_Object *data, SFS_Info *info) var = sb->var; val = sb->val; - scheme_sfs_start_sequence(info, 2, 0); + sfs_start_sequence(info, 2, 0); - val = scheme_sfs_expr(val, info, -1); - var = scheme_sfs_expr(var, info, -1); + val = sfs_expr(val, info, -1); + var = sfs_expr(var, info, -1); sb->var = var; sb->val = val; @@ -938,9 +974,9 @@ ref_sfs(Scheme_Object *data, SFS_Info *info) Scheme_Object *a_naya; Scheme_Object *b_naya; - scheme_sfs_start_sequence(info, 1, 0); - a_naya = scheme_sfs_expr(SCHEME_PTR1_VAL(data), info, -1); - b_naya = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); + sfs_start_sequence(info, 1, 0); + a_naya = sfs_expr(SCHEME_PTR1_VAL(data), info, -1); + b_naya = sfs_expr(SCHEME_PTR2_VAL(data), info, -1); SCHEME_PTR1_VAL(data) = a_naya; SCHEME_PTR2_VAL(data) = b_naya; @@ -955,10 +991,10 @@ apply_values_sfs(Scheme_Object *data, SFS_Info *info) f = SCHEME_PTR1_VAL(data); e = SCHEME_PTR2_VAL(data); - scheme_sfs_start_sequence(info, 2, 0); + sfs_start_sequence(info, 2, 0); - f = scheme_sfs_expr(f, info, -1); - e = scheme_sfs_expr(e, info, -1); + f = sfs_expr(f, info, -1); + e = sfs_expr(e, info, -1); SCHEME_PTR1_VAL(data) = f; SCHEME_PTR2_VAL(data) = e; @@ -972,12 +1008,12 @@ static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info) Scheme_Object *k, *v, *b, *vec; int pos, save_mnt; - scheme_sfs_start_sequence(info, 3, 1); + sfs_start_sequence(info, 3, 1); - k = scheme_sfs_expr(wcm->key, info, -1); - v = scheme_sfs_expr(wcm->val, info, -1); + k = sfs_expr(wcm->key, info, -1); + v = sfs_expr(wcm->val, info, -1); - scheme_sfs_push(info, 1, 1); + sfs_push(info, 1, 1); pos = info->stackpos; save_mnt = info->max_nontail; @@ -994,7 +1030,7 @@ static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info) info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]); } - b = scheme_sfs_expr(wcm->body, info, -1); + b = sfs_expr(wcm->body, info, -1); wcm->key = k; wcm->val = v; @@ -1027,11 +1063,11 @@ case_lambda_sfs(Scheme_Object *expr, SFS_Info *info) Scheme_Object *le, *clears = scheme_null; int i; - scheme_sfs_start_sequence(info, seq->count, 0); + sfs_start_sequence(info, seq->count, 0); for (i = 0; i < seq->count; i++) { le = seq->array[i]; - le = scheme_sfs_expr(le, info, -1); + le = sfs_expr(le, info, -1); if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. Lift them out. */ @@ -1055,7 +1091,7 @@ case_lambda_sfs(Scheme_Object *expr, SFS_Info *info) } if (!SCHEME_NULLP(clears)) { - return scheme_sfs_add_clears(expr, clears, 0); + return sfs_add_clears(expr, clears, 0); } else return expr; } @@ -1074,7 +1110,7 @@ static Scheme_Object *bangboxenv_sfs(Scheme_Object *data, SFS_Info *info) else drop = 0; - e = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); + e = sfs_expr(SCHEME_PTR2_VAL(data), info, -1); if (drop) return e; @@ -1129,11 +1165,11 @@ begin0_sfs(Scheme_Object *obj, SFS_Info *info) cnt = ((Scheme_Sequence *)obj)->count; - scheme_sfs_start_sequence(info, cnt, 0); + sfs_start_sequence(info, cnt, 0); for (i = 0; i < cnt; i++) { Scheme_Object *le; - le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1); + le = sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1); ((Scheme_Sequence *)obj)->array[i] = le; } @@ -1143,45 +1179,6 @@ begin0_sfs(Scheme_Object *obj, SFS_Info *info) return obj; } -static Scheme_Object *do_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *e; - - if (!info->pass) { - int depth; - depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); - info = scheme_new_sfs_info(depth); - e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth); - SCHEME_VEC_ELS(data)[0] = e; - } - - return data; -} - -static Scheme_Object *define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) -{ - return do_define_syntaxes_sfs(data, info); -} - -static Scheme_Object *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *l, *a; - - if (!info->pass) { - int depth; - depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); - - for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - info = scheme_new_sfs_info(depth); - a = scheme_sfs(a, info, depth); - SCHEME_CAR(l) = a; - } - } - - return data; -} - /*========================================================================*/ /* closures */ /*========================================================================*/ @@ -1202,7 +1199,7 @@ static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_p if (!info->pass) { for (i = size; i--; ) { - scheme_sfs_used(info, data->closure_map[i]); + sfs_used(info, data->closure_map[i]); } } else { /* Check whether we need to zero out any stack positions @@ -1225,13 +1222,13 @@ static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_p } } - return scheme_sfs_add_clears(expr, clears, 0); + return sfs_add_clears(expr, clears, 0); } if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_SFS)) { SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_SFS; - info = scheme_new_sfs_info(data->max_let_depth); - scheme_sfs_push(info, data->closure_size + data->num_params, 1); + info = new_sfs_info(data->max_let_depth); + sfs_push(info, data->closure_size + data->num_params, 1); if (has_tl) info->tlpos = info->stackpos + data->closure_size - 1; @@ -1266,7 +1263,7 @@ static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_p } } - code = scheme_sfs(data->body, info, data->max_let_depth); + code = sfs_passes(data->body, info); /* If any arguments go unused, and if there's a non-tail, non-immediate call in the body, then we flush the @@ -1288,7 +1285,7 @@ static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_p } if (SCHEME_PAIRP(clears)) - code = scheme_sfs_add_clears(code, clears, 1); + code = sfs_add_clears(code, clears, 1); if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_NEED_REST_CLEAR; @@ -1300,63 +1297,6 @@ static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_p return expr; } -/*========================================================================*/ -/* module */ -/*========================================================================*/ - -static Scheme_Object * -module_sfs(Scheme_Object *data, SFS_Info *old_info) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *e, *ex; - SFS_Info *info; - int i, j, cnt, let_depth; - - if (!old_info->for_mod) { - if (old_info->pass) - return data; - - info = scheme_new_sfs_info(m->max_let_depth); - info->for_mod = 1; - scheme_sfs(data, info, m->max_let_depth); - return data; - } - - info = old_info; - - cnt = SCHEME_VEC_SIZE(m->bodies[0]); - scheme_sfs_start_sequence(info, cnt, 0); - - for (i = 0; i < cnt; i++) { - e = scheme_sfs_expr(SCHEME_VEC_ELS(m->bodies[0])[i], info, -1); - SCHEME_VEC_ELS(m->bodies[0])[i] = e; - } - - if (!info->pass) { - for (j = m->num_phases; j-- > 1; ) { - cnt = SCHEME_VEC_SIZE(m->bodies[j]); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->bodies[j])[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - ex = SCHEME_VEC_ELS(e)[1]; - - info = scheme_new_sfs_info(let_depth); - ex = scheme_sfs(ex, info, let_depth); - SCHEME_VEC_ELS(e)[1] = ex; - } - } - } - - return data; -} - -static Scheme_Object * -top_level_require_sfs(Scheme_Object *data, SFS_Info *rslv) -{ - return data; -} - /*========================================================================*/ /* expressions */ /*========================================================================*/ @@ -1370,10 +1310,10 @@ static Scheme_Object *sfs_expr_k(void) p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return scheme_sfs_expr(e, info, p->ku.k.i1); + return sfs_expr(e, info, p->ku.k.i1); } -Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos) +static Scheme_Object *sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos) /* closure_self_pos == -2 => immediately in sequence */ { Scheme_Type type = SCHEME_TYPE(expr); @@ -1409,7 +1349,7 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ case scheme_local_type: case scheme_local_unbox_type: if (!info->pass) - scheme_sfs_used(info, SCHEME_LOCAL_POS(expr)); + sfs_used(info, SCHEME_LOCAL_POS(expr)); else if (!SCHEME_GET_LOCAL_TYPE(expr)) { int pos, at_ip; pos = SCHEME_LOCAL_POS(expr); @@ -1441,9 +1381,6 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ case scheme_sequence_type: expr = sfs_sequence(expr, info, closure_self_pos != -2); break; - case scheme_splice_sequence_type: - expr = sfs_sequence(expr, info, 0); - break; case scheme_branch_type: expr = sfs_branch(expr, info); break; @@ -1497,12 +1434,6 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ case scheme_define_values_type: expr = define_values_sfs(expr, info); break; - case scheme_define_syntaxes_type: - expr = define_syntaxes_sfs(expr, info); - break; - case scheme_begin_for_syntax_type: - expr = begin_for_syntax_sfs(expr, info); - break; case scheme_set_bang_type: expr = set_sfs(expr, info); break; @@ -1512,9 +1443,6 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ case scheme_begin0_sequence_type: expr = begin0_sfs(expr, info); break; - case scheme_require_form_type: - expr = top_level_require_sfs(expr, info); - break; case scheme_varref_form_type: expr = ref_sfs(expr, info); break; @@ -1527,9 +1455,6 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ case scheme_case_lambda_sequence_type: expr = case_lambda_sfs(expr, info); break; - case scheme_module_type: - expr = module_sfs(expr, info); - break; case scheme_inline_variant_type: expr = inline_variant_sfs(expr, info); break; diff --git a/racket/src/racket/src/sort.c b/racket/src/racket/src/sort.c new file mode 100644 index 0000000000..29dcb17d04 --- /dev/null +++ b/racket/src/racket/src/sort.c @@ -0,0 +1,170 @@ +/* + Racket + Copyright (c) 2004-2016 PLT Design Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library 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 distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" + +#ifdef MZ_XFORM +START_XFORM_SKIP; +#endif +#include "../gc2/my_qsort.c" +#ifdef MZ_XFORM +END_XFORM_SKIP; +#endif + +static int compare_syms(const void *_a, const void *_b) +{ + Scheme_Object *a = *(Scheme_Object **)_a; + Scheme_Object *b = *(Scheme_Object **)_b; + intptr_t l = SCHEME_SYM_LEN(a), i; + + MZ_ASSERT(SCHEME_SYMBOLP(a)); + MZ_ASSERT(SCHEME_SYMBOLP(b)); + + if (SCHEME_SYM_LEN(b) < l) + l = SCHEME_SYM_LEN(b); + + for (i = 0; i < l; i++) { + if (SCHEME_SYM_VAL(a)[i] != SCHEME_SYM_VAL(b)[i]) + return (SCHEME_SYM_VAL(a)[i] - SCHEME_SYM_VAL(b)[i]); + } + + return SCHEME_SYM_LEN(a) - SCHEME_SYM_LEN(b); +} + +static void sort_symbol_array(Scheme_Object **a, intptr_t count) +{ + my_qsort(a, count, sizeof(Scheme_Object *), compare_syms); +} + +static int compare_nums(const void *_a, const void *_b) +/* also allow #fs */ +{ + Scheme_Object *a = *(Scheme_Object **)_a; + Scheme_Object *b = *(Scheme_Object **)_b; + + if (SCHEME_FALSEP(a)) + return -1; + else if (SCHEME_FALSEP(b)) + return 1; + + MZ_ASSERT(SCHEME_REALP(a)); + MZ_ASSERT(SCHEME_REALP(b)); + + if (scheme_bin_lt(a, b)) + return -1; + else if (scheme_bin_lt(b, a)) + return 1; + else + return 0; +} + +static void sort_number_array(Scheme_Object **a, intptr_t count) +{ + my_qsort(a, count, sizeof(Scheme_Object *), compare_nums); +} + +static int compare_vars_at_resolve(const void *_a, const void *_b) +{ + Scheme_IR_Local *a = *(Scheme_IR_Local **)_a; + Scheme_IR_Local *b = *(Scheme_IR_Local **)_b; + return a->resolve.lex_depth - b->resolve.lex_depth; +} + +void scheme_sort_resolve_ir_local_array(Scheme_IR_Local **a, intptr_t count) +{ + my_qsort(a, count, sizeof(Scheme_IR_Local *), compare_vars_at_resolve); +} + +/**************************************************************/ + +static int all_symbols(Scheme_Object **a, int c) +{ + while (c--) { + if (!SCHEME_SYMBOLP(a[c])) + return 0; + } + return 1; +} + +static int all_reals(Scheme_Object **a, int c) +{ + while (c--) { + if (!SCHEME_REALP(a[c])) + return 0; + } + return 1; +} + +Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *tree) +{ + intptr_t j, i, count; + Scheme_Object **a, *key; + + if (SCHEME_HASHTRP(tree)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)tree; + + count = ht->count; + if (!count) + return NULL; + + a = MALLOC_N(Scheme_Object *, count); + + j = -1; + i = 0; + while ((j = scheme_hash_tree_next(ht, j)) != -1) { + scheme_hash_tree_index(ht, j, &key, NULL); + a[i++] = key; + } + + MZ_ASSERT(i == count); + } else { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)tree; + + count = t->count; + + if (!count) + return NULL; + + a = MALLOC_N(Scheme_Object *, count); + j = 0; + + for (i = t->size; i--; ) { + if (t->vals[i]) { + a[j++] = t->keys[i]; + } + } + + MZ_ASSERT(j == count); + } + + if (SCHEME_SYMBOLP(a[0]) && all_symbols(a, count)) + sort_symbol_array(a, count); + else if (all_reals(a, count)) + sort_number_array(a, count); + else + return NULL; + + return a; +} diff --git a/racket/src/racket/src/sstoinc.rkt b/racket/src/racket/src/sstoinc.rkt deleted file mode 100644 index 8fd2bbef77..0000000000 --- a/racket/src/racket/src/sstoinc.rkt +++ /dev/null @@ -1,33 +0,0 @@ - -#lang racket/base - -(define to-zo? (member "--zo" (vector->list (current-command-line-arguments)))) - -(define DIGS-PER-LINE 20) - -(namespace-require ''#%kernel) - -(call-with-output-file (vector-ref (current-command-line-arguments) 0) #:exists 'replace - (lambda (outfile) - -(let loop () - (let ([expr (read)]) - (unless (eof-object? expr) - (let ([c (compile expr)] - [p (open-output-bytes)]) - (write c p) - (let ([s (get-output-bytes p)]) - (fprintf outfile " {\n SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {") - (let loop ([chars (bytes->list s)][pos 0]) - (unless (null? chars) - (let ([char (car chars)]) - (fprintf outfile "~a," char)) - (loop (cdr chars) - (if (= pos DIGS-PER-LINE) - (begin - (newline outfile) - 0) - (add1 pos))))) - (fprintf outfile "0};\n EVAL_ONE_SIZED_STR((char *)expr, ~a);\n" (bytes-length s)) - (fprintf outfile " }\n"))) - (loop)))))) diff --git a/racket/src/racket/src/sstoinct.rkt b/racket/src/racket/src/sstoinct.rkt deleted file mode 100644 index 251b1f6375..0000000000 --- a/racket/src/racket/src/sstoinct.rkt +++ /dev/null @@ -1,65 +0,0 @@ -#lang racket/base - -(define (brackets->parens l) - (regexp-replace* #rx"\\[" - (regexp-replace* #rx"\\]" l ")") - "(")) - -(let loop ([ready? #f] [parens 0]) - (let ([l (read-line)]) - (cond - [(eof-object? l) - (when ready? - (printf ");\n"))] - [(regexp-match? #px"^\\s*$" l) - ;; just spaces; do nothing - (loop ready? parens)] - [(regexp-match #px"^\\s*;" l) - ;; comment; do nothing - (loop ready? parens)] - [else - (unless ready? - (printf " EVAL_ONE_STR(\n")) - (let* ([l (if (regexp-match? #rx"\"[^\"]*\\[[^\"]*\"" l) - l - (brackets->parens l))] - [l (regexp-replace* #rx"\\\\" l "\\\\\\\\")] - [l (regexp-replace* #rx"\"" l "\\\\\"")] - [l (regexp-replace* #rx"\t" l " ")] - [l (regexp-replace* #rx" +" l " ")] - [l (if (regexp-match? #rx"\"" l) - ;; Has a string - can't safely delete more spaces - l - (regexp-replace* #rx" \\(" l "("))] - [l - ;; Check for comments: - (if (regexp-match? #rx"[\"\\]" l) - ;; If there's a comment char, add a newline, - ;; just in case: - (if (regexp-match? #rx";" l) - (string-append l "\\n") - l) - (regexp-replace #rx";.*$" l ""))]) - (printf "\"~a\"\n" l) - (let* ([l - ;; Remove strings before counting parens: - (regexp-replace* - #rx"\"[^\"]*\"" - (regexp-replace* - #rx"\\\"" l "") - "")] - [l - ;; Convert sq brackets to parens and remove escaped - (regexp-replace* #rx"\\[()]" - (brackets->parens l) - "")]) - (let ([parens (for/fold ([parens parens]) ([c (in-string l)]) - (case c - [(#\() (+ parens 1)] - [(#\)) (- parens 1)] - [else parens]))]) - (if (zero? parens) - (begin - (printf ");\n") - (loop #f 0)) - (loop #t parens)))))]))) diff --git a/racket/src/racket/src/startup-glue.inc b/racket/src/racket/src/startup-glue.inc new file mode 100644 index 0000000000..a4f5bafd81 --- /dev/null +++ b/racket/src/racket/src/startup-glue.inc @@ -0,0 +1,789 @@ +/* This file is #included by expander.inc when it is built via cify */ +#include "schmach.h" + +#ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +#endif + +/* Disable the use of source or bytecode: */ +#define SCHEME_STARTUP_DEFINED + +#ifdef c_VALIDATE_DEBUG +static Scheme_Object *c_validate(Scheme_Object *s); +#endif + +THREAD_LOCAL_DECL(static struct startup_instance_top_t *c_startup_instance_top); + +typedef struct c_saved_mark_stack_t { + MZ_MARK_POS_TYPE pos; + MZ_MARK_STACK_TYPE stack; +} c_saved_mark_stack_t; + +/* Pulling the address of the thread-local table into a local variable + can have a big effect on compile time (not so much on run time) if + the the thread-local implementation is opqaue to the compiler. */ +#ifdef PREFER_TO_CACHE_THREAD_LOCAL +# define c_LINK_THREAD_LOCAL Thread_Local_Variables *c_racket_tls = scheme_get_thread_local_variables(); +# define c_current_runstack (c_racket_tls)->scheme_current_runstack_ +# define c_current_runstack_start (c_racket_tls)->scheme_current_runstack_start_ +# define c_current_thread (c_racket_tls)->scheme_current_thread_ +# define c__startup_instance_top (c_racket_tls)->c_startup_instance_top_ +# define c_scheme_fuel_counter (c_racket_tls)->scheme_fuel_counter_ +static c_saved_mark_stack_t c__push_mark_stack(Thread_Local_Variables *c_racket_tls) +{ + c_saved_mark_stack_t s; + s.pos = c_racket_tls->scheme_current_cont_mark_pos_; + s.stack = c_racket_tls->scheme_current_cont_mark_stack_; + c_racket_tls->scheme_current_cont_mark_pos_ = s.pos + 2; + return s; +} +# define c_push_mark_stack() c__push_mark_stack(c_racket_tls) +static void c__pop_mark_stack(Thread_Local_Variables *c_racket_tls, c_saved_mark_stack_t s) +{ + c_racket_tls->scheme_current_cont_mark_pos_ = s.pos; + c_racket_tls->scheme_current_cont_mark_stack_ = s.stack; +} +# define c_pop_mark_stack(s) c__pop_mark_stack(c_racket_tls, s) +#else +# define c_LINK_THREAD_LOCAL /* empty */ +# define c_current_runstack MZ_RUNSTACK +# define c_current_runstack_start MZ_RUNSTACK_START +# define c_current_thread scheme_current_thread +# define c__startup_instance_top c_startup_instance_top +# define c_scheme_fuel_counter scheme_fuel_counter +static c_saved_mark_stack_t c_push_mark_stack() +{ + c_saved_mark_stack_t s; + s.pos = MZ_CONT_MARK_POS; + s.stack = MZ_CONT_MARK_STACK; + MZ_CONT_MARK_POS = s.pos + 2; + return s; +} +static void c_pop_mark_stack(c_saved_mark_stack_t s) +{ + MZ_CONT_MARK_POS = s.pos; + MZ_CONT_MARK_STACK = s.stack; +} +#endif + +#define c_use_fuel() if (DECREMENT_FUEL(c_scheme_fuel_counter, 1) <= 0) scheme_out_of_fuel(); + + +#define c_RUNSTACK_INIT_VAL NULL + +static void scheme_instance_add(Scheme_Instance *inst, const char *name, Scheme_Object *val) +{ + Scheme_Bucket *b; + b = scheme_instance_variable_bucket(scheme_intern_symbol(name), inst); + b->val = val; + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_CONST | GLOB_IS_CONSISTENT; +} + +#define c_check_runstack_space(max_depth, runstack, runstack_start) \ + ((runstack - runstack_start) < (max_depth + SCHEME_TAIL_COPY_THRESHOLD)) + +static int c_check_overflow_or_runstack_space(int max_depth, Scheme_Object **runstack, Scheme_Object **runstack_start) +{ +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + return 1; + } + } +#endif + return c_check_runstack_space(max_depth, runstack, runstack_start); +} + +static void c_check_top_runstack_depth(int max_depth) +{ + if (c_check_runstack_space(max_depth, MZ_RUNSTACK, MZ_RUNSTACK_START)) { + scheme_log_abort("initial runstack is too small to start up"); + abort(); + } +} + + +static Scheme_Object *do_apply_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + + if (c_check_runstack_space(p->ku.k.i2, MZ_RUNSTACK, MZ_RUNSTACK_START)) { + return (Scheme_Object *)scheme_enlarge_runstack(p->ku.k.i2, (void *(*)())do_apply_k); + } else { + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2; + +#ifdef c_VALIDATE_DEBUG + { + int i; + c_validate(o); + for (i = 0; i < p->ku.k.i1; i++) + c_validate(argv[i]); + } +#endif + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + return _scheme_apply_multi(o, p->ku.k.i1, argv); + } +} + +static Scheme_Object *c_handle_overflow_or_space(Scheme_Object *proc, int argc, Scheme_Object **argv, int runstack_space) +{ + Scheme_Thread *p; + Scheme_Object **argv2; + + /* stash before allocation: */ + p = scheme_current_thread; + p->ku.k.p1 = (void *)proc; + p->ku.k.i1 = argc; + p->ku.k.i2 = runstack_space; + p->ku.k.p2 = (void *)argv; + + argv2 = MALLOC_N(Scheme_Object*, argc); + + p = scheme_current_thread; + argv = (Scheme_Object **)p->ku.k.p2; + + memcpy(argv2, argv, sizeof(Scheme_Object *) * argc); + if (argv == MZ_RUNSTACK) + memset(argv, 0, sizeof(Scheme_Object *) * argc); /* space safety */ + + p->ku.k.p2 = (void *)argv2; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + return scheme_handle_stack_overflow(do_apply_k); + } +#endif + + return (Scheme_Object *)scheme_enlarge_runstack(runstack_space, (void *(*)())do_apply_k); +} + +static Scheme_Object *c_ensure_args_in_place_rest(int argc, Scheme_Object **argv, Scheme_Object **runbase, + int direct_args, int rest_args, int rest_arg_used, + Scheme_Object *self) +{ + Scheme_Object **runstack = runbase - direct_args - rest_args; + int i; + + if (argc == direct_args) { + /* Copy into runbase. If there's a rest arg not supplied, then the + copy may be shifting down, and we need to add a `null` value + for the rest arg. */ + for (i = 0; i < direct_args; i++) + runstack[i] = argv[i]; + if (rest_args) + runstack[direct_args] = scheme_null; + } else { + /* Need to build a list and then copy or shift up */ + Scheme_Object *l = scheme_null; + if (rest_arg_used) { + MZ_GC_DECL_REG(2); + + MZ_GC_VAR_IN_REG(0, argv); + MZ_GC_VAR_IN_REG(1, self); + MZ_GC_REG(); + for (i = argc; i-- > direct_args; ) + l = scheme_make_pair(argv[i], l); + MZ_GC_UNREG(); + } + + runstack[direct_args] = l; + for (i = direct_args; i--; ) + runstack[i] = argv[i]; + } + + return self; +} + +#define c_ensure_args_in_place(argc, argv, runbase) \ + if (argv != (runbase - argc)) (void)c_ensure_args_in_place_rest(argc, argv, runbase, argc, 0, 0, NULL) +#define c_rest_arg_used 1 +#define c_rest_arg_unused 0 + + +static Scheme_Object *c_wrong_arity(const char *name, int argc, Scheme_Object **argv) +{ + scheme_wrong_count(name, -2, 0, argc, argv); + return NULL; +} + +static mzshort *convert_arities(int mina, const char *a) +{ + /* FIXME: On a big-endian machine, we need to reverse the byte order in arities */ + return (mzshort *)a; +} + +static Scheme_Object *scheme_make_prim_w_case_arity(Scheme_Prim *prim, const char *name, mzshort mina, const char *arities) +{ + Scheme_Object *p; + mzshort *a; + p = scheme_make_prim_w_arity(prim, name, 0, 0); + ((Scheme_Primitive_Proc *)p)->mina = mina; + a = convert_arities(mina, arities); + ((Scheme_Primitive_Proc *)p)->mu.cases = a; + return p; +} + +static Scheme_Object *scheme_make_prim_closure_w_case_arity(Scheme_Primitive_Closure_Proc *prim, + int size, Scheme_Object **vals, + const char *name, + mzshort mina, const char *arities) +{ + Scheme_Object *p; + mzshort *a; + p = scheme_make_prim_closure_w_arity(prim, size, vals, name, 0, 0); + ((Scheme_Primitive_Proc *)p)->mina = mina; + a = convert_arities(mina, arities); + ((Scheme_Primitive_Proc *)p)->mu.cases = a; + return p; +} + +#define c_extract_prim(o) ((Scheme_Prim *)((Scheme_Primitive_Proc *)o)->prim_val) + +static MZ_INLINE int c_same_obj(Scheme_Object *a, Scheme_Object *b) +{ + return SAME_OBJ(a, b); +} + +static MZ_INLINE Scheme_Object *c_malloc_struct(int c) +{ + return scheme_malloc_tagged(sizeof(Scheme_Structure) + (((c) - mzFLEX_DELTA) * sizeof(Scheme_Object *))); +} + +static MZ_INLINE void c_struct_set_type(Scheme_Object *s, Scheme_Object *_st) +{ + Scheme_Struct_Type *stype = (Scheme_Struct_Type *)_st; + s->type = (stype->proc_attr ? scheme_proc_struct_type : scheme_structure_type); + ((Scheme_Structure *)s)->stype = stype; +} + +#define c_STRUCT_ELS(o) (((Scheme_Structure *)(o))->slots) + +static MZ_INLINE int c_is_struct_instance(Scheme_Object *v, Scheme_Object *_st) +{ + Scheme_Struct_Type *st = (Scheme_Struct_Type *)_st; + if (SCHEME_CHAPERONEP(v)) + v = SCHEME_CHAPERONE_VAL(v); + return (SCHEME_STRUCTP(v) + && (((Scheme_Structure *)v)->stype->parent_types[st->name_pos] == st)); +} + +static MZ_INLINE int c_is_authentic_struct_instance(Scheme_Object *v, Scheme_Object *_st) +{ + Scheme_Struct_Type *st = (Scheme_Struct_Type *)_st; + return (SCHEME_STRUCTP(v) + && (((Scheme_Structure *)v)->stype->parent_types[st->name_pos] == st)); +} + +static MZ_INLINE Scheme_Object *c_struct_ref(Scheme_Object *v, int pos) +{ + if (SCHEME_CHAPERONEP(v)) + return scheme_struct_ref(v, pos); + else + return ((Scheme_Structure *)v)->slots[pos]; +} + +static MZ_INLINE Scheme_Object *c_authentic_struct_ref(Scheme_Object *v, int pos) +{ + return ((Scheme_Structure *)v)->slots[pos]; +} + +static MZ_INLINE Scheme_Object *c_struct_set(Scheme_Object *v, Scheme_Object *a, int pos) +{ + if (SCHEME_CHAPERONEP(v)) + scheme_struct_set(v, pos, a); + else + ((Scheme_Structure *)v)->slots[pos] = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_authentic_struct_set(Scheme_Object *v, Scheme_Object *a, int pos) +{ + ((Scheme_Structure *)v)->slots[pos] = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_struct_property_ref(Scheme_Object *v, Scheme_Object *prop) +{ + return scheme_chaperone_struct_type_property_ref(prop, v); +} + +static MZ_INLINE int c_int_lt(Scheme_Object *a, Scheme_Object *b) +{ + return SCHEME_INT_VAL(a) < SCHEME_INT_VAL(b); +} + +static MZ_INLINE int c_int_gt(Scheme_Object *a, Scheme_Object *b) +{ + return SCHEME_INT_VAL(a) > SCHEME_INT_VAL(b); +} + +static MZ_INLINE Scheme_Object *c_int_add(Scheme_Object *a, Scheme_Object *b) +{ + return scheme_make_integer(SCHEME_INT_VAL(a) + SCHEME_INT_VAL(b)); +} + +/* Can GC if not in fixnum range */ +static Scheme_Object *c_number_add1(Scheme_Object *a) +{ + if (SCHEME_INTP(a)) { + intptr_t v; + v = SCHEME_INT_VAL(a); + if (v < 0x3FFFFFFF) + return scheme_make_integer(v + 1); + } + + return scheme_bin_plus(a, scheme_make_integer(1)); +} + +/* Can GC if not in fixnum range */ +static Scheme_Object *c_number_sub1(Scheme_Object *a) +{ + if (SCHEME_INTP(a)) { + intptr_t v; + v = SCHEME_INT_VAL(a); + if (v > -0x3FFFFFFF) + return scheme_make_integer(v - 1); + } + + return scheme_bin_minus(a, scheme_make_integer(1)); +} + +#define c_SCHEME_BIN_NUMBER_COMP(id, op, scheme_id) \ + static MZ_INLINE int id(Scheme_Object *a, Scheme_Object *b) { \ + if (SCHEME_INTP(a) && SCHEME_INTP(b)) \ + return (SCHEME_INT_VAL(a) op SCHEME_INT_VAL(b)); \ + return scheme_id(a, b); \ + } +c_SCHEME_BIN_NUMBER_COMP(c_number_eq, ==, scheme_bin_eq) +c_SCHEME_BIN_NUMBER_COMP(c_number_gt, >, scheme_bin_gt) +c_SCHEME_BIN_NUMBER_COMP(c_number_lt, <, scheme_bin_lt) +c_SCHEME_BIN_NUMBER_COMP(c_number_gt_eq, >=, scheme_bin_gt_eq) +c_SCHEME_BIN_NUMBER_COMP(c_number_lt_eq, <=, scheme_bin_lt_eq) + +static int c_number_zerop(Scheme_Object *a) +{ + if (SCHEME_INTP(a)) + return SCHEME_INT_VAL(a) == 0; + else + return scheme_is_zero(a); +} + +#define c_SCHEME_PREDFUNC(id, ID) static MZ_INLINE int id(Scheme_Object *v) { return ID(v); } + +c_SCHEME_PREDFUNC(c_scheme_truep, SCHEME_TRUEP) +c_SCHEME_PREDFUNC(c_scheme_falsep, SCHEME_FALSEP) +c_SCHEME_PREDFUNC(c_scheme_nullp, SCHEME_NULLP) +c_SCHEME_PREDFUNC(c_scheme_eof_objectp, SCHEME_EOFP) +c_SCHEME_PREDFUNC(c_scheme_voidp, SCHEME_VOIDP) +c_SCHEME_PREDFUNC(c_scheme_boolp, SCHEME_BOOLP) +c_SCHEME_PREDFUNC(c_scheme_pairp, SCHEME_PAIRP) +c_SCHEME_PREDFUNC(c_scheme_numberp, SCHEME_NUMBERP) +c_SCHEME_PREDFUNC(c_scheme_charp, SCHEME_CHARP) +c_SCHEME_PREDFUNC(c_scheme_chaperone_vectorp, SCHEME_CHAPERONE_VECTORP) +c_SCHEME_PREDFUNC(c_scheme_chaperone_boxp, SCHEME_CHAPERONE_BOXP) +c_SCHEME_PREDFUNC(c_scheme_symbolp, SCHEME_SYMBOLP) +c_SCHEME_PREDFUNC(c_scheme_keywordp, SCHEME_KEYWORDP) +c_SCHEME_PREDFUNC(c_scheme_char_stringp, SCHEME_CHAR_STRINGP) +c_SCHEME_PREDFUNC(c_scheme_byte_stringp, SCHEME_BYTE_STRINGP) +c_SCHEME_PREDFUNC(c_scheme_pathp, SCHEME_PATHP) + +static MZ_INLINE int c_scheme_hashp(Scheme_Object *v) +{ + if (SCHEME_NP_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return SCHEME_HASHTRP(v) || SCHEME_HASHTP(v) || SCHEME_BUCKTP(v); +} + +/* GC *not* possible during scheme_is_list */ +static MZ_INLINE int c_scheme_listp(Scheme_Object *v) +{ + return scheme_is_list(v); +} + +static MZ_INLINE int c_scheme_char_eq(Scheme_Object *a, Scheme_Object *b) +{ + return SCHEME_CHAR_VAL(a) == SCHEME_CHAR_VAL(b); +} + +static MZ_INLINE int c_scheme_char_whitespacep(Scheme_Object *c) +{ + return scheme_isspace(SCHEME_CHAR_VAL(c)); +} + +static MZ_INLINE Scheme_Object *c_authentic_vector_ref(Scheme_Object *v, Scheme_Object *i) +{ + return SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)]; +} + +static MZ_INLINE Scheme_Object *c_vector_ref(Scheme_Object *v, Scheme_Object *i) +{ + if (SCHEME_NP_CHAPERONEP(v)) + return scheme_chaperone_vector_ref(v, SCHEME_INT_VAL(i)); + else + return SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)]; +} + +static MZ_INLINE Scheme_Object *c_vector_set(Scheme_Object *v, Scheme_Object *i, Scheme_Object *a) +{ + if (SCHEME_NP_CHAPERONEP(v)) + scheme_chaperone_vector_set(v, SCHEME_INT_VAL(i), a); + SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_vector_length(Scheme_Object *v) +{ + if (SCHEME_NP_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + return scheme_make_integer(SCHEME_VEC_SIZE(v)); +} + +static MZ_INLINE Scheme_Object *c_string_ref(Scheme_Object *v, Scheme_Object *i) +{ + mzchar c = SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)]; + return scheme_make_character(c); +} + +static MZ_INLINE Scheme_Object *c_bytes_ref(Scheme_Object *v, Scheme_Object *i) +{ + int c = SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)]; + return scheme_make_integer(c); +} + +static MZ_INLINE Scheme_Object *c_box_ref(Scheme_Object *b) +{ + if (SCHEME_NP_CHAPERONEP(b)) + return scheme_unbox(b); + else + return SCHEME_BOX_VAL(b); +} + +static MZ_INLINE Scheme_Object *c_box_set(Scheme_Object *b, Scheme_Object *a) +{ + if (SCHEME_NP_CHAPERONEP(b)) + scheme_set_box(b, a); + else + SCHEME_BOX_VAL(b) = a; + return scheme_void; +} + +static MZ_INLINE Scheme_Object *c_weak_box_value(Scheme_Object *o) +{ + o = SCHEME_BOX_VAL(o); + if (!o) + return scheme_false; + return o; +} + +#if 0 +static MZ_INLINE Scheme_Object *c_weak_box_value2(Scheme_Object *o, Scheme_Object *defval) +{ + o = SCHEME_BOX_VAL(o); + if (!o) + return defval; + return o; +} +#endif + +static Scheme_Object *c_make_list1(Scheme_Object *v) +{ + return scheme_make_pair(v, scheme_null); +} + +static Scheme_Object *c_make_list2(Scheme_Object *v1, Scheme_Object *v2) +{ + /* A trick to avoid GC registration: put v1 in the wrong place, then move it */ + Scheme_Object *p = scheme_make_pair(v2, v1); + p = scheme_make_pair(scheme_null, p); + SCHEME_CAR(p) = SCHEME_CDR(SCHEME_CDR(p)); + SCHEME_CDR(SCHEME_CDR(p)) = scheme_null; + return p; +} + +static MZ_INLINE Scheme_Object *c_pair_car(Scheme_Object *p) +{ + return SCHEME_CAR(p); +} + +static MZ_INLINE Scheme_Object *c_pair_cdr(Scheme_Object *p) +{ + return SCHEME_CDR(p); +} + +static MZ_INLINE Scheme_Object *c_pair_caar(Scheme_Object *p) +{ + return SCHEME_CAR(SCHEME_CAR(p)); +} + +static MZ_INLINE Scheme_Object *c_pair_cdar(Scheme_Object *p) +{ + return SCHEME_CDR(SCHEME_CAR(p)); +} + +static MZ_INLINE Scheme_Object *c_pair_cadr(Scheme_Object *p) +{ + return SCHEME_CAR(SCHEME_CDR(p)); +} + +static MZ_INLINE Scheme_Object *c_pair_cddr(Scheme_Object *p) +{ + return SCHEME_CDR(SCHEME_CDR(p)); +} + +/* Only when `default` is definitely not a procedure */ +/* Can GC */ +static Scheme_Object *c_hash_ref(Scheme_Object *ht, Scheme_Object *key, Scheme_Object *defval) +{ + Scheme_Object *v; + + /* The fast path doesn't trigger any GCs: */ + if (SCHEME_HASHTP(ht)) { + if (!((Scheme_Hash_Table *)ht)->make_hash_indices) { + v = scheme_eq_hash_get((Scheme_Hash_Table *)ht, key); + if (v) + return v; + else + return defval; + } + } else if (SCHEME_HASHTRP(ht)) { + if (SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(ht))) { + v = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)ht, key); + if (v) + return v; + else + return defval; + } + } + + { + Scheme_Object *argv[3]; + MZ_GC_DECL_REG(3); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_VAR_IN_REG(1, argv[1]); + MZ_GC_VAR_IN_REG(2, argv[2]); + MZ_GC_REG(); + + argv[0] = ht; + argv[1] = key; + argv[2] = defval; + + v = scheme_checked_hash_ref(3, argv); + + MZ_GC_UNREG(); + + return v; + } +} + +/* Can GC */ +static Scheme_Object *c_hash_ref2(Scheme_Object *ht, Scheme_Object *key) +{ + Scheme_Object *argv[2], *v; + MZ_GC_DECL_REG(2); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_VAR_IN_REG(1, argv[1]); + MZ_GC_REG(); + + argv[0] = ht; + argv[1] = key; + + v = scheme_checked_hash_ref(2, argv); + + MZ_GC_UNREG(); + + return v; +} + +/* Can GC */ +static Scheme_Object *c_hash_set(Scheme_Object *ht, Scheme_Object *key, Scheme_Object *val) +{ + Scheme_Object *argv[3], *v; + MZ_GC_DECL_REG(3); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_VAR_IN_REG(1, argv[1]); + MZ_GC_VAR_IN_REG(2, argv[2]); + MZ_GC_REG(); + + argv[0] = ht; + argv[1] = key; + argv[2] = val; + + v = scheme_hash_table_put(3, argv); + + MZ_GC_UNREG(); + + return v; +} + +/* Can GC in the general case */ +static Scheme_Object *c_hash_count(Scheme_Object *ht) +{ + if (SCHEME_CHAPERONEP(ht)) + ht = SCHEME_CHAPERONE_VAL(ht); + + if (SCHEME_HASHTP(ht)) { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)ht; + return scheme_make_integer(t->count); + } else if (SCHEME_HASHTRP(ht)) { + Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)ht; + return scheme_make_integer(t->count); + } else { + Scheme_Object *argv[1], *v; + MZ_GC_DECL_REG(1); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_REG(); + + argv[0] = ht; + + v = scheme_checked_hash_count(1, argv); + + MZ_GC_UNREG(); + + return v; + } +} + +/* Can GC */ +static Scheme_Object *c_hash_iterate_first(Scheme_Object *ht) +{ + Scheme_Object *argv[1], *v; + MZ_GC_DECL_REG(1); + + MZ_GC_VAR_IN_REG(0, argv[0]); + MZ_GC_REG(); + + argv[0] = ht; + + v = scheme_hash_table_iterate_start(1, argv); + + MZ_GC_UNREG(); + + return v; +} + +/* Can GC */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_first(Scheme_Object *ht) +{ + if (SCHEME_NP_CHAPERONEP(ht)) ht = SCHEME_CHAPERONE_VAL(ht); + return scheme_unsafe_hash_tree_start((Scheme_Hash_Tree *)ht); +} + +/* Can GC */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_next(Scheme_Object *ht, Scheme_Object *i) +{ + if (SCHEME_NP_CHAPERONEP(ht)) ht = SCHEME_CHAPERONE_VAL(ht); + return scheme_unsafe_hash_tree_next((Scheme_Hash_Tree *)ht, i); +} + +/* Can GC in case of chaperone */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_key(Scheme_Object *ht, Scheme_Object *idx) +{ + Scheme_Object *key; + Scheme_Hash_Tree *subtree; + int i; + + scheme_unsafe_hash_tree_subtree(ht, idx, &subtree, &i); + key = subtree->els[i]; + + if (SCHEME_NP_CHAPERONEP(ht)) + return scheme_chaperone_hash_key("unsafe-immutable-hash-iterate-key", ht, idx); + else + return key; +} + +/* Can GC */ +static Scheme_Object *c_unsafe_immutable_hash_iterate_key_value(Scheme_Object *ht, Scheme_Object *idx) +{ + Scheme_Object *key, *res[2], *v; + Scheme_Hash_Tree *subtree; + int i; + MZ_GC_DECL_REG(2); + + MZ_GC_VAR_IN_REG(0, res[0]); + MZ_GC_VAR_IN_REG(1, res[1]); + MZ_GC_REG(); + + scheme_unsafe_hash_tree_subtree(ht, idx, &subtree, &i); + key = subtree->els[i]; + + if (SCHEME_NP_CHAPERONEP(ht)) { + scheme_chaperone_hash_key_value("unsafe-immutable-hash-iterate-key+value", + ht, subtree->els[i], &res[0], &res[1], 0); + } else { + res[0] = key; + res[1] = scheme_unsafe_hash_tree_access(subtree, i); + } + + v = scheme_values(2, res); + + MZ_GC_UNREG(); + + return v; +} + +static MZ_INLINE Scheme_Object *c_prefab_struct_key(Scheme_Object *v) +{ + return scheme_prefab_struct_key(v); +} + +static Scheme_Object *c_zero_values() +{ + Scheme_Thread *p = scheme_current_thread; + p->ku.multiple.count = 0; + p->ku.multiple.array = NULL; + return SCHEME_MULTIPLE_VALUES; +} + +static MZ_INLINE Scheme_Object *c_last_use(Scheme_Object **r, int i) +{ + Scheme_Object *v = r[i]; + r[i] = NULL; + return v; +} + +/* static MZ_INLINE void c_no_use(Scheme_Object **r, int i) { r[i] = NULL; } */ +#define c_no_use(r, i) r[i] = NULL + +#ifndef c_VALIDATE_DEBUG + +# define SCHEME_UNBOX_VARIABLE(var) (*(Scheme_Object **)(var)) +# define SCHEME_UNBOX_VARIABLE_LHS(var) SCHEME_UNBOX_VARIABLE(var) + +static Scheme_Object *scheme_box_variable(Scheme_Object *v) +{ + Scheme_Object **b; + b = MALLOC_ONE(Scheme_Object *); + b[0] = v; + return (Scheme_Object *)b; +} + +#else + +# define SCHEME_UNBOX_VARIABLE(var) SCHEME_BOX_VAL(var) +# define SCHEME_UNBOX_VARIABLE_LHS(var) SCHEME_BOX_VAL(var) + +static Scheme_Object *scheme_box_variable(Scheme_Object *v) +{ + return scheme_box(v); +} + +static Scheme_Object *c_validate(Scheme_Object *s) +{ + if ((SCHEME_TYPE(s) < 0) || (SCHEME_TYPE(s) > _scheme_last_type_)) + abort(); + return s; +} + +#endif + +#ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +#endif diff --git a/racket/src/racket/src/startup-select.rkt b/racket/src/racket/src/startup-select.rkt new file mode 100644 index 0000000000..32a8053035 --- /dev/null +++ b/racket/src/racket/src/startup-select.rkt @@ -0,0 +1,6 @@ +(module startup-select '#%kernel + (if (eval-jit-enabled) + (display "cstartup_bytecode") + (display "cstartup_c")) + (newline)) + diff --git a/racket/src/racket/src/startup.c b/racket/src/racket/src/startup.c new file mode 100644 index 0000000000..7a74cabf57 --- /dev/null +++ b/racket/src/racket/src/startup.c @@ -0,0 +1,74 @@ +/* + Racket + Copyright (c) 2004-2018 PLT Design Inc. + Copyright (c) 2000-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library 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 distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" +#include "schvers.h" +#include "schminc.h" + +/* Generated by the build process in the build area; might simply + redirect to "startup.inc": */ +#include "cstartup.inc" + +#ifndef SCHEME_STARTUP_DEFINED + +static Scheme_Linklet *eval_linklet_string(const char *str, intptr_t len, int extract) +{ + Scheme_Object *port, *expr; + + if (len < 0) + len = strlen(str); + port = scheme_make_sized_byte_string_input_port(str, -len); /* negative means it's constant */ + + expr = scheme_internal_read(port, 1, 1, -1, scheme_init_load_on_demand ? scheme_true : scheme_false); + + if (extract) { + /* expr is a linklet bundle; 'startup is mapped to the linklet */ + return (Scheme_Linklet *)scheme_hash_tree_get((Scheme_Hash_Tree *)SCHEME_PTR_VAL(expr), + scheme_intern_symbol("startup")); + } else { + return scheme_compile_and_optimize_linklet(scheme_datum_to_syntax(expr, scheme_false, 0), + scheme_intern_symbol("startup")); + } +} + +static Scheme_Linklet *startup_linklet() +{ +#define EVAL_ONE_STR(str) return eval_linklet_string(str, -1, 0) +#define EVAL_ONE_SIZED_STR(str, len) return eval_linklet_string(str, len, 1) + EVAL_STARTUP; +} + +void scheme_init_startup(void) +{ + /* called once (not per-place) */ +} + +void scheme_init_startup_instance(Scheme_Instance *inst) +{ + /* called per-places */ + scheme_instantiate_linklet_multi(startup_linklet(), inst, 0, NULL, 0); +} + +#endif diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 99dc89d09d..5c65425e2b 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -1,1491 +1,75714 @@ - EVAL_ONE_STR( -"(module #%min-stx '#%kernel" -"(#%require '#%paramz" -"(for-syntax '#%kernel))" -"(#%provide unless when" -" and or" -" cond" -" let let* letrec" -" let*-values" -" parameterize" -" define)" -"(begin-for-syntax " -"(define-values(here-stx)(quote-syntax here)))" -"(define-syntaxes(unless)" -"(lambda(stx)" -"(let-values(((s)(syntax->list stx)))" -"(datum->syntax here-stx" -"(list 'if(cadr s)" +#define EVAL_STARTUP EVAL_ONE_STR(startup_source) +static const char *startup_source = +"(linklet" +"()" +"((boot boot)" +"(1/bound-identifier=? bound-identifier=?)" +"(1/compile compile)" +"(compile-to-linklets compile-to-linklets)" +"(1/current-compile current-compile)" +"(1/current-compiled-file-roots current-compiled-file-roots)" +"(1/current-eval current-eval)" +"(1/current-library-collection-links current-library-collection-links)" +"(1/current-library-collection-paths current-library-collection-paths)" +"(1/current-load current-load)" +"(1/current-load/use-compiled current-load/use-compiled)" +"(1/current-namespace current-namespace)" +"(datum->kernel-syntax datum->kernel-syntax)" +"(1/datum->syntax datum->syntax)" +"(declare-primitive-module! declare-primitive-module!)" +"(1/dynamic-require dynamic-require)" +"(embedded-load embedded-load)" +"(1/eval eval)" +"(expand$1 expand)" +"(1/find-library-collection-links find-library-collection-links)" +"(1/find-library-collection-paths find-library-collection-paths)" +"(find-main-config find-main-config)" +"(1/identifier-binding identifier-binding)" +"(identifier? identifier?)" +"(1/load load)" +"(1/load-extension load-extension)" +"(1/load/use-compiled load/use-compiled)" +"(make-namespace make-namespace)" +"(maybe-raise-missing-module maybe-raise-missing-module)" +"(maybe-syntax->datum maybe-syntax->datum)" +"(1/module->language-info module->language-info)" +"(1/module-compiled-exports module-compiled-exports)" +"(1/module-compiled-indirect-exports module-compiled-indirect-exports)" +"(1/module-declared? module-declared?)" +"(1/module-path-index-join module-path-index-join)" +"(1/module-path-index? module-path-index?)" +"(1/module-path? module-path?)" +"(1/module-predefined? module-predefined?)" +"(namespace->instance namespace->instance)" +"(1/namespace-attach-module namespace-attach-module)" +"(1/namespace-attach-module-declaration namespace-attach-module-declaration)" +"(1/namespace-mapped-symbols namespace-mapped-symbols)" +"(1/namespace-module-identifier namespace-module-identifier)" +"(1/namespace-require namespace-require)" +"(1/namespace-syntax-introduce namespace-syntax-introduce)" +"(1/read read)" +"(1/read-accept-compiled read-accept-compiled)" +"(1/read-syntax read-syntax)" +"(1/resolved-module-path? resolved-module-path?)" +"(seal seal)" +"(1/syntax->datum syntax->datum)" +"(1/syntax-debug-info syntax-debug-info)" +"(1/syntax-e syntax-e)" +"(syntax-property$1 syntax-property)" +"(1/syntax-shift-phase-level syntax-shift-phase-level)" +"(syntax?$1 syntax?)" +"(1/use-collection-link-paths use-collection-link-paths)" +"(1/use-compiled-file-check use-compiled-file-check)" +"(1/use-compiled-file-paths use-compiled-file-paths)" +"(1/use-user-specific-search-paths use-user-specific-search-paths))" +"(define-values" +"(qq-append)" +" (lambda (a_0 b_0) (begin (if (list? a_0) (append a_0 b_0) (raise-argument-error 'unquote-splicing \"list?\" a_0)))))" +"(define-values(call/ec) call-with-escape-continuation)" +"(define-values" +"(bad-list$1)" +" (lambda (who_0 orig-l_0) (begin 'bad-list (raise-mismatch-error who_0 \"not a proper list: \" orig-l_0))))" +"(define-values" +"(memq memv member)" +"(let-values()" +"(let-values()" +"(values" +"(let-values(((memq_0)" +"(lambda(v_0 orig-l_1)" +"(begin" +" 'memq" +"((letrec-values(((loop_0)" +"(lambda(ls_0)" +"(begin" +" 'loop" +"(if(null? ls_0)" +"(let-values() #f)" +"(if(not(pair? ls_0))" +"(let-values()(bad-list$1 'memq orig-l_1))" +"(if(eq? v_0(car ls_0))" +"(let-values() ls_0)" +"(let-values()(loop_0(cdr ls_0))))))))))" +" loop_0)" +" orig-l_1)))))" +" memq_0)" +"(let-values(((memv_0)" +"(lambda(v_1 orig-l_2)" +"(begin" +" 'memv" +"((letrec-values(((loop_1)" +"(lambda(ls_1)" +"(begin" +" 'loop" +"(if(null? ls_1)" +"(let-values() #f)" +"(if(not(pair? ls_1))" +"(let-values()(bad-list$1 'memv orig-l_2))" +"(if(eqv? v_1(car ls_1))" +"(let-values() ls_1)" +"(let-values()(loop_1(cdr ls_1))))))))))" +" loop_1)" +" orig-l_2)))))" +" memv_0)" +"(let-values(((default_0)" +"(let-values(((member_0)" +"(lambda(v_2 orig-l_3)" +"(begin" +" 'member" +"((letrec-values(((loop_2)" +"(lambda(ls_2)" +"(begin" +" 'loop" +"(if(null? ls_2)" +"(let-values() #f)" +"(if(not(pair? ls_2))" +"(let-values()(bad-list$1 'member orig-l_3))" +"(if(equal? v_2(car ls_2))" +"(let-values() ls_2)" +"(let-values()(loop_2(cdr ls_2))))))))))" +" loop_2)" +" orig-l_3)))))" +" member_0)))" +"(let-values(((member_1)" +"(case-lambda" +"((v_3 orig-l_4)(begin 'member(default_0 v_3 orig-l_4)))" +"((v_4 orig-l_5 eq?_0)" +"(begin" +"(if(if(procedure? eq?_0)(procedure-arity-includes? eq?_0 2) #f)" "(void)" -"(cons 'begin(cddr s)))))))" -"(define-syntaxes(when)" -"(lambda(stx)" -"(let-values(((s)(syntax->list stx)))" -"(datum->syntax here-stx" -"(list 'if(cadr s)" -"(cons 'begin(cddr s))" -"(void))))))" -"(define-syntaxes(and)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(if(null? s)" -"(quote-syntax #t)" -"(if(null?(cdr s))" -"(car s)" -"(datum->syntax here-stx" -"(list 'if(car s)(cons 'and(cdr s)) #f)))))))" -"(define-syntaxes(or)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(if(null? s)" -"(quote-syntax #f)" -"(if(null?(cdr s))" -"(car s)" -"(datum->syntax here-stx" -"(list 'let-values(list(list(list 'x)" -"(car s)))" -"(list 'if 'x 'x(cons 'or(cdr s))))))))))" -"(define-syntaxes(let)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(datum->syntax " -" here-stx" -"(if(symbol?(syntax-e(car s)))" -"(let-values(((clauses)" -"(map(lambda(c)" -"(syntax->list c))" -"(syntax->list(cadr s)))))" -"(list 'letrec-values(list(list(list(car s))" -"(list* 'lambda" -"(map car clauses)" -"(cddr s))))" -"(cons(car s)(map cadr clauses))))" -"(list* 'let-values(map(lambda(c)" -"(let-values(((c)(syntax->list c)))" -"(cons(list(car c))" -"(cdr c))))" -"(syntax->list(car s)))" -"(cdr s)))))))" -"(define-syntaxes(letrec)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(datum->syntax " -" here-stx" -"(list* 'letrec-values(map(lambda(c)" -"(let-values(((c)(syntax->list c)))" -"(cons(list(car c))" -"(cdr c))))" -"(syntax->list(car s)))" -"(cdr s))))))" -"(define-syntaxes(let*)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(let-values(((fst)(syntax->list(car s))))" -"(datum->syntax " -" here-stx" -"(if(null? fst)" -"(list* 'let-values()(cdr s))" -"(list 'let(list(car fst))" -"(list* 'let*(cdr fst)(cdr s)))))))))" -"(define-syntaxes(let*-values)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(let-values(((fst)(syntax->list(car s))))" -"(datum->syntax " -" here-stx" -"(if(null? fst)" -"(list* 'let-values()(cdr s))" -"(list 'let-values(list(car fst))" -"(list* 'let*-values(cdr fst)(cdr s)))))))))" -"(define-syntaxes(parameterize)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(let-values(((bindings)(apply append" -"(map syntax->list(syntax->list(car s))))))" -"(syntax-arm" -"(datum->syntax " -" here-stx" -"(list 'with-continuation-mark" -" 'parameterization-key" -"(list* 'extend-parameterization" -" '(continuation-mark-set-first #f parameterization-key)" -" bindings)" -"(list* 'let-values()" -"(cdr s)))))))))" -"(define-syntaxes(cond)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(if(null? s)" -"(quote-syntax(void))" -"(datum->syntax " -" here-stx" -"(let-values(((a)(syntax->list(car s))))" -"(if(eq? '=>(syntax-e(cadr a)))" -"(list 'let-values(list(list '(v)(car a)))" -"(list* 'cond" -"(list 'v(list(caddr a) 'v))" -"(cdr s)))" -"(list 'if(if(eq?(syntax-e(car a)) 'else)" -" #t" -"(car a))" -"(list* 'let-values '()(cdr a))" -"(cons 'cond(cdr s))))))))))" -"(define-syntaxes(define)" -"(lambda(stx)" -"(let-values(((s)(cdr(syntax->list stx))))" -"(datum->syntax " -" here-stx" -"(if(symbol?(syntax-e(car s)))" -"(list 'define-values(list(car s))(cadr s))" -"(let-values(((a)(syntax-e(car s))))" -"(list 'define-values(list(car a))" -"(list* 'lambda(cdr a)" -"(cdr s))))))))))" -); - EVAL_ONE_STR( -"(module #%utils '#%kernel" -"(#%require '#%min-stx '#%paramz)" -"(#%provide path-string?" -" normal-case-path" -" path-replace-extension" -" path-add-extension" -" reroot-path" -" find-col-file" -" collection-path" -" collection-file-path" -" find-library-collection-paths" -" find-library-collection-links" -" path-list-string->path-list" -" find-executable-path" -" load/use-compiled" -" embedded-load" -" call-with-default-reading-parameterization" -" find-main-collects" -" find-main-config)" -"(define-values(path-string?)" -"(lambda(s)" -"(or(path? s) " -"(and(string? s)" -"(or(relative-path? s)" -"(absolute-path? s))))))" -"(define-values(bsbs)(string #\\u5C #\\u5C))" -"(define-values(normal-case-path)" -"(lambda(s)" -"(unless(or(path-for-some-system? s)" -"(path-string? s))" -" (raise-argument-error 'normal-path-case \"(or/c path-for-some-system? path-string?)\" s))" -"(cond" -"((if(path-for-some-system? s)" -"(eq?(path-convention-type s) 'windows)" -"(eq?(system-type) 'windows))" -"(let((str(if(string? s) s(bytes->string/locale(path->bytes s)))))" -" (if (regexp-match? #rx\"^[\\u5C][\\u5C][?][\\u5C]\" str)" -"(if(string? s)" -"(string->path s)" -" s)" -"(let((s(string-locale-downcase str)))" -"(bytes->path " -"(string->bytes/locale" -" (regexp-replace* #rx\"/\" " -" (if (regexp-match? #rx\"[/\\u5C][. ]+[/\\u5C]*$\" s)" -" s" -" (regexp-replace* #rx\"\\u5B .\\u5D+([/\\u5C]*)$\" s \"\\u005C1\"))" -" bsbs))" -" 'windows)))))" -"((string? s)(string->path s))" -"(else s))))" -"(define-values(reroot-path)" -"(lambda(p root)" -"(unless(or(path-string? p)(path-for-some-system? p))" -" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 0 p root))" -"(unless(or(path-string? root)(path-for-some-system? root))" -" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 1 p root))" -"(define conv(if(path-for-some-system? p)" -"(path-convention-type p)" -"(system-path-convention-type)))" -"(unless(or(complete-path? p)" -"(eq?(system-path-convention-type) conv))" -"(raise-arguments-error 'reroot-path" -" \"path is not complete and not the platform's convention\"" -" \"path\" p" -" \"platform convention type\" (system-path-convention-type)))" -"(unless(eq?(if(path-for-some-system? root)" -"(path-convention-type root)" -"(system-path-convention-type))" -" conv)" -"(raise-arguments-error 'reroot-path" -" \"given paths use different conventions\"" -" \"path\" p" -" \"root path\" root))" -"(define c-p(normal-case-path(cleanse-path(if(complete-path? p)" -" p" -"(path->complete-path p)))))" -"(define bstr(path->bytes c-p))" -"(cond " -"((eq? conv 'unix) " -" (if (bytes=? bstr #\"/\")" -"(if(path-for-some-system? root)" -" root" -"(string->path root))" -"(build-path root(bytes->path(subbytes(path->bytes c-p) 1) conv))))" -"((eq? conv 'windows)" -"(build-path" -" root" -"(bytes->path" -"(cond" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\[a-z]:\" bstr)" -" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4 5) #\"\\\\\" (subbytes bstr 6)))" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr)" -" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4)))" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr)" -" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4)))" -" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\\" bstr)" -" (bytes-append #\"UNC\\\\\" (subbytes bstr 2)))" -" ((regexp-match? #rx\"^[a-z]:\" bstr)" -"(bytes-append(subbytes bstr 0 1)(subbytes bstr 2))))" -" conv))))))" -"(define-values(find-executable-path)" -"(case-lambda " -"((program libpath reverse?)" -"(unless(path-string? program) " -" (raise-argument-error 'find-executable-path \"path-string?\" program))" -"(unless(or(not libpath)(and(path-string? libpath) " -"(relative-path? libpath)))" -" (raise-argument-error 'find-executable-path \"(or/c #f (and/c path-string? relative-path?))\" libpath))" -"(letrec((found-exec" -"(lambda(exec-name)" -"(if libpath" -"(let-values(((base name isdir?)(split-path exec-name)))" -"(let((next" -"(lambda()" -"(let((resolved(resolve-path exec-name)))" -"(cond" -"((equal? resolved exec-name) #f)" -"((relative-path? resolved)" -"(found-exec(build-path base resolved)))" -"(else(found-exec resolved)))))))" -"(or(and reverse?(next))" -"(if(path? base)" -"(let((lib(build-path base libpath)))" -"(and(or(directory-exists? lib) " -"(file-exists? lib))" -" lib))" -" #f)" -"(and(not reverse?)(next)))))" -" exec-name))))" -"(if(and(relative-path? program)" -"(let-values(((base name dir?)(split-path program)))" -"(eq? base 'relative)))" -"(let((paths-str(environment-variables-ref(current-environment-variables)" -" #\"PATH\"))" -"(win-add(lambda(s)(if(eq?(system-type) 'windows) " -" (cons (bytes->path #\".\") s) " -" s))))" -"(let loop((paths(win-add " -"(if paths-str" -"(path-list-string->path-list(bytes->string/locale paths-str #\\?)" -" null)" -" null))))" -"(if(null? paths)" -" #f" -"(let*((base(path->complete-path(car paths)))" -"(name(build-path base program)))" -"(if(file-exists? name)" -"(found-exec name)" -"(loop(cdr paths)))))))" -"(let((p(path->complete-path program)))" -"(and(file-exists? p)(found-exec p))))))" -"((program libpath)(find-executable-path program libpath #f))" -"((program)(find-executable-path program #f #f))))" -"(define-values(path-list-string->path-list)" -"(let((r(byte-regexp(string->bytes/utf-8" -"(let((sep(if(eq?(system-type) 'windows)" -" \";\"\n" -" \":\")))" -" (format \"([^~a]*)~a(.*)\" sep sep)))))" -"(cons-path(lambda(default s l) " -"(let((s(if(eq?(system-type) 'windows)" -" (regexp-replace* #rx#\"\\\"\" s #\"\")" -" s)))" -" (if (bytes=? s #\"\")" -"(append default l)" -"(cons(bytes->path s)" -" l))))))" -"(lambda(s default)" -"(unless(or(bytes? s)" -"(string? s))" -" (raise-argument-error 'path-list-string->path-list \"(or/c bytes? string?)\" s))" -"(unless(and(list? default)" -"(andmap path? default))" -" (raise-argument-error 'path-list-string->path-list \"(listof path?)\" default))" -"(let loop((s(if(string? s)" -"(string->bytes/utf-8 s)" -" s)))" -"(let((m(regexp-match r s)))" -"(if m" -"(cons-path default(cadr m)(loop(caddr m)))" -"(cons-path default s null)))))))" -"(define(call-with-default-reading-parameterization thunk)" -"(if(and(procedure? thunk)" -"(procedure-arity-includes? thunk 0))" -"(parameterize((read-case-sensitive #t)" -"(read-square-bracket-as-paren #t)" -"(read-curly-brace-as-paren #t)" -"(read-square-bracket-with-tag #f)" -"(read-curly-brace-with-tag #f)" -"(read-accept-box #t)" -"(read-accept-compiled #f)" -"(read-accept-bar-quote #t)" -"(read-accept-graph #t)" -"(read-decimal-as-inexact #t)" -"(read-cdot #f)" -"(read-accept-dot #t)" -"(read-accept-infix-dot #t)" -"(read-accept-quasiquote #t)" -"(read-accept-reader #f)" -"(read-accept-lang #t)" -"(current-readtable #f))" -"(thunk))" -"(raise-argument-error 'call-with-default-reading-parameterization" -" \"(procedure-arity-includes/c 0)\"" -" thunk)))" -"(define-values(-check-relpath)" -"(lambda(who s)" -"(unless(path-string? s)" -" (raise-argument-error who \"path-string?\" s))" -"(unless(relative-path? s)" -"(raise-arguments-error who" -" \"invalid relative path\"" -" \"path\" s))))" -"(define-values(-check-collection)" -"(lambda(who collection collection-path)" -"(-check-relpath who collection) " -"(for-each(lambda(p)(-check-relpath who p)) collection-path)))" -"(define-values(-check-fail)" -"(lambda(who fail)" -"(unless(and(procedure? fail)" -"(procedure-arity-includes? fail 1))" -" (raise-argument-error who \"(any/c . -> . any)\" fail))))" -"(define-values(collection-path)" -"(lambda(fail collection collection-path) " -"(-check-collection 'collection-path collection collection-path)" -"(-check-fail 'collection-path fail)" -"(find-col-file fail" -" collection collection-path" -" #f" -" #f)))" -"(define-values(collection-file-path)" -"(lambda(fail check-compiled? file-name collection collection-path) " -"(-check-relpath 'collection-file-path file-name)" -"(-check-collection 'collection-file-path collection collection-path)" -"(-check-fail 'collection-file-path fail)" -"(find-col-file fail" -" collection collection-path" -" file-name" -" check-compiled?)))" -"(define-values(find-main-collects)" -"(lambda()" -"(cache-configuration" -" 0" -"(lambda()" -"(exe-relative-path->complete-path(find-system-path 'collects-dir))))))" -"(define-values(find-main-config)" -"(lambda()" -"(cache-configuration" -" 1" -"(lambda()" -"(exe-relative-path->complete-path(find-system-path 'config-dir))))))" -"(define-values(get-config-table)" -"(lambda(d)" -" (let ((p (and d (build-path d \"config.rktd\"))))" -"(or(and p" -"(file-exists? p)" -"(with-input-from-file p" -"(lambda()" -"(let((v(call-with-default-reading-parameterization read)))" -"(and(hash? v)" -" v)))))" -" #hash()))))" -"(define-values(get-installation-name)" -"(lambda(config-table)" -"(hash-ref config-table" -" 'installation-name " -"(version))))" -"(define-values(coerce-to-path)" -"(lambda(p)" -"(cond" -"((string? p)(collects-relative-path->complete-path(string->path p)))" -"((bytes? p)(collects-relative-path->complete-path(bytes->path p)))" -"((path? p)(collects-relative-path->complete-path p))" -"(else p))))" -"(define-values(collects-relative-path->complete-path)" -"(lambda(p)" -"(cond" -"((complete-path? p) p)" -"(else" -"(path->complete-path p(or(find-main-collects)" -"(current-directory)))))))" -"(define-values(exe-relative-path->complete-path)" -"(lambda(collects-path)" -"(cond" -"((complete-path? collects-path)(simplify-path collects-path))" -"((absolute-path? collects-path)" -"(let((exec(path->complete-path" -"(find-executable-path(find-system-path 'exec-file))" -"(find-system-path 'orig-dir))))" -"(let-values(((base name dir?)(split-path exec)))" -"(simplify-path(path->complete-path collects-path base)))))" -"(else" -"(let((p(find-executable-path(find-system-path 'exec-file) collects-path #t)))" -"(and p(simplify-path p)))))))" -"(define-values(add-config-search)" -"(lambda(ht key orig-l)" -"(let((l(hash-ref ht key #f)))" -"(if l" -"(let loop((l l))" -"(cond" -"((null? l) null)" -"((not(car l))(append orig-l(loop(cdr l))))" -"(else(cons(coerce-to-path(car l))(loop(cdr l))))))" -" orig-l))))" -"(define-values(find-library-collection-links)" -"(lambda()" -"(let*((ht(get-config-table(find-main-config)))" -"(lf(coerce-to-path" -"(or(hash-ref ht 'links-file #f)" -"(build-path(or(hash-ref ht 'share-dir #f)" -" (build-path 'up \"share\"))" -" \"links.rktd\")))))" -"(append" -"(list #f)" -"(if(and(use-user-specific-search-paths)" -"(use-collection-link-paths))" -"(list(build-path(find-system-path 'addon-dir)" -"(get-installation-name ht)" -" \"links.rktd\"))" -" null)" -"(if(use-collection-link-paths)" -"(add-config-search" -" ht" -" 'links-search-files" -"(list lf))" -" null)))))" -"(define-values(links-cache)(make-weak-hash))" -"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))" -"(define-values(file->stamp)" -"(lambda(path old-stamp)" -"(cond" -"((and old-stamp" -"(cdr old-stamp)" -"(not(sync/timeout 0(cdr old-stamp))))" -" old-stamp)" -"(else" +" (raise-argument-error 'member \"(procedure-arity-includes/c 2)\" eq?_0))" +"((let-values(((member_2)" +"(lambda(v_5 orig-l_6)" +"(begin" +" 'member" +"((letrec-values(((loop_3)" +"(lambda(ls_3)" +"(begin" +" 'loop" +"(if(null? ls_3)" +"(let-values() #f)" +"(if(not(pair? ls_3))" +"(let-values()(bad-list$1 'member orig-l_6))" +"(if(eq?_0 v_5(car ls_3))" +"(let-values() ls_3)" +"(let-values()(loop_3(cdr ls_3))))))))))" +" loop_3)" +" orig-l_6)))))" +" member_2)" +" v_4" +" orig-l_5))))))" +" member_1))))))" +"(define-values" +"(select-handler/no-breaks)" +"(lambda(e_0 bpz_0 l_0)" +"(begin" +"(with-continuation-mark" +" break-enabled-key" +"(make-thread-cell #f)" +"((letrec-values(((loop_4)" +"(lambda(l_1)" +"(begin" +" 'loop" +"(if(null? l_1)" +"(let-values()(raise e_0))" +"(if((caar l_1) e_0)" +"(let-values()" +"(begin0" +"((cdar l_1) e_0)" +"(with-continuation-mark break-enabled-key bpz_0(check-for-break))))" +"(let-values()(loop_4(cdr l_1)))))))))" +" loop_4)" +" l_0)))))" +"(define-values(false-thread-cell)(make-thread-cell #f))" +"(define-values(handler-prompt-key)(make-continuation-prompt-tag 'handler-prompt-tag))" +"(define-values" +"(call-handled-body)" +"(lambda(bpz_1 handle-proc_0 body-thunk_0)" +"(begin" +"(with-continuation-mark" +" break-enabled-key" +" false-thread-cell" "(call-with-continuation-prompt" -"(lambda()" +"(lambda(bpz_2 body-thunk_1)" +"(with-continuation-mark" +" break-enabled-key" +" bpz_2" "(with-continuation-mark" " exception-handler-key" -"(lambda(exn)" -"(abort-current-continuation " -" stamp-prompt-tag" -"(if(exn:fail:filesystem? exn)" -"(lambda() #f)" -"(lambda()(raise exn)))))" -"(let((dir-evt" -"(and(vector-ref(system-type 'fs-change) 2) " -"(let loop((path path))" -"(let-values(((base name dir?)(split-path path)))" -"(and(path? base)" -"(if(directory-exists? base)" -"(filesystem-change-evt base(lambda() #f))" -"(loop base))))))))" -"(if(not(file-exists? path))" -"(cons #f dir-evt)" -"(let((evt(and(vector-ref(system-type 'fs-change) 2) " -"(filesystem-change-evt path(lambda() #f)))))" -"(when dir-evt(filesystem-change-evt-cancel dir-evt))" +"(lambda(e_1)(abort-current-continuation handler-prompt-key e_1))" +"(body-thunk_1))))" +" handler-prompt-key" +" handle-proc_0" +" bpz_1" +" body-thunk_0)))))" +"(define-values" +"(call-with-exception-handler)" +"(lambda(exnh_0 thunk_0)(begin(begin0(with-continuation-mark exception-handler-key exnh_0(thunk_0))(void)))))" +"(define-values" +"(hash-update hash-update! hash-has-key? hash-ref!)" +"(let-values(((not-there_0)(gensym)))" +"(let-values(((up_0)" +"(lambda(who_1 mut?_0 set_0 ht_0 key_0 xform_0 default_1)" +"(begin" +" 'up" +"(begin" +"(if(if(hash? ht_0)(if mut?_0(not(immutable? ht_0))(immutable? ht_0)) #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_1" +" (if mut?_0 \"(and/c hash? (not/c immutable?))\" \"(and/c hash? immutable?)\")" +" ht_0)))" +"(if(if(procedure? xform_0)(procedure-arity-includes? xform_0 1) #f)" +"(void)" +" (let-values () (raise-argument-error who_1 \"(any/c . -> . any/c)\" xform_0)))" +"(let-values(((v_6)(hash-ref ht_0 key_0 default_1)))" +"(if(eq? v_6 not-there_0)" +" (raise-mismatch-error who_1 \"no value found for key: \" key_0)" +"(set_0 ht_0 key_0(xform_0 v_6)))))))))" +"(let-values(((hash-update_0)" +"(case-lambda" +"((ht_1 key_1 xform_1 default_2)" +"(begin 'hash-update(up_0 'hash-update #f hash-set ht_1 key_1 xform_1 default_2)))" +"((ht_2 key_2 xform_2)(hash-update ht_2 key_2 xform_2 not-there_0))))" +"((hash-update!_0)" +"(case-lambda" +"((ht_3 key_3 xform_3 default_3)" +"(begin 'hash-update!(up_0 'hash-update! #t hash-set! ht_3 key_3 xform_3 default_3)))" +"((ht_4 key_4 xform_4)(hash-update! ht_4 key_4 xform_4 not-there_0))))" +"((hash-has-key?_0)" +"(lambda(ht_5 key_5)" +"(begin" +" 'hash-has-key?" +"(begin" +"(if(hash? ht_5)" +"(void)" +" (let-values () (raise-argument-error 'hash-has-key? \"hash?\" 0 ht_5 key_5)))" +"(not(eq? not-there_0(hash-ref ht_5 key_5 not-there_0)))))))" +"((hash-ref!_0)" +"(lambda(ht_6 key_6 new_0)" +"(begin" +" 'hash-ref!" +"(begin" +"(if(if(hash? ht_6)(not(immutable? ht_6)) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'hash-ref! \"(and/c hash? (not/c immutable?))\" 0 ht_6 key_6 new_0)))" +"(let-values(((v_7)(hash-ref ht_6 key_6 not-there_0)))" +"(if(eq? not-there_0 v_7)" +"(let-values(((n_0)(if(procedure? new_0)(new_0) new_0)))" +"(begin(hash-set! ht_6 key_6 n_0) n_0))" +" v_7)))))))" +"(values hash-update_0 hash-update!_0 hash-has-key?_0 hash-ref!_0)))))" +"(define-values" +"(path-string?)" +"(lambda(s_0)" +"(begin" +"(let-values(((or-part_0)(path? s_0)))" +"(if or-part_0" +" or-part_0" +"(if(string? s_0)" +"(let-values(((or-part_1)(relative-path? s_0)))(if or-part_1 or-part_1(absolute-path? s_0)))" +" #f))))))" +"(define-values(bsbs)(string '#\\\\ '#\\\\))" +"(define-values" +"(normal-case-path)" +"(lambda(s_1)" +"(begin" +"(begin" +"(if(let-values(((or-part_2)(path-for-some-system? s_1)))(if or-part_2 or-part_2(path-string? s_1)))" +"(void)" +" (let-values () (raise-argument-error 'normal-path-case \"(or/c path-for-some-system? path-string?)\" s_1)))" +"(if(if(path-for-some-system? s_1)(eq?(path-convention-type s_1) 'windows)(eq?(system-type) 'windows))" +"(let-values()" +"(let-values(((str_0)(if(string? s_1) s_1(bytes->string/locale(path->bytes s_1)))))" +" (if (regexp-match? '#rx\"^[\\\\][\\\\][?][\\\\]\" str_0)" +"(if(string? s_1)(string->path s_1) s_1)" +"(let-values(((s_2)(string-locale-downcase str_0)))" +"(bytes->path" +"(string->bytes/locale" +"(regexp-replace*" +" '#rx\"/\"" +" (if (regexp-match? '#rx\"[/\\\\][. ]+[/\\\\]*$\" s_2)" +" s_2" +" (regexp-replace* '#rx\"[ .]+([/\\\\]*)$\" s_2 \"\\\\1\"))" +" bsbs))" +" 'windows)))))" +"(if(string? s_1)(let-values()(string->path s_1))(let-values() s_1)))))))" +"(define-values" +"(check-extension-call)" +"(lambda(s_3 sfx_0 who_2 sep_0 trust-sep?_0)" +"(begin" +"(begin" +"(let-values(((err-msg_0 err-index_0)" +"(if(not" +"(let-values(((or-part_3)(path-for-some-system? s_3)))" +"(if or-part_3 or-part_3(path-string? s_3))))" +" (let-values () (values \"(or/c path-for-some-system? path-string?)\" 0))" +"(if(not(let-values(((or-part_4)(string? sfx_0)))(if or-part_4 or-part_4(bytes? sfx_0))))" +" (let-values () (values \"(or/c string? bytes?)\" 1))" +"(if(not" +"(let-values(((or-part_5) trust-sep?_0))" +"(if or-part_5" +" or-part_5" +"(let-values(((or-part_6)(string? sep_0)))" +"(if or-part_6 or-part_6(bytes? sep_0))))))" +" (let-values () (values \"(or/c string? bytes?)\" 2))" +"(let-values()(values #f #f)))))))" +"(if err-msg_0" +"(let-values()" +"(if trust-sep?_0" +"(raise-argument-error who_2 err-msg_0 err-index_0 s_3 sfx_0)" +"(raise-argument-error who_2 err-msg_0 err-index_0 s_3 sfx_0 sep_0)))" +"(void)))" +"(let-values(((base_0 name_0 dir?_0)(split-path s_3)))" +"(begin" +"(if(not base_0)" +" (let-values () (raise-mismatch-error who_2 \"cannot add an extension to a root path: \" s_3))" +"(void))" +"(values base_0 name_0)))))))" +"(define-values" +"(path-adjust-extension)" +"(lambda(name_1 sep_1 rest-bytes_0 s_4 sfx_1 trust-sep?_1)" +"(begin" +"(let-values(((base_1 name_2)(check-extension-call s_4 sfx_1 name_1 sep_1 trust-sep?_1)))" +"(let-values(((bs_0)(path-element->bytes name_2)))" +"(let-values(((finish_0)" +"(lambda(i_0 sep_2 i2_0)" +"(begin" +" 'finish" +"(bytes->path-element" +"(bytes-append" +"(subbytes bs_0 0 i_0)" +"(if(string? sep_2)(string->bytes/locale sep_2(char->integer '#\\?)) sep_2)" +"(rest-bytes_0 bs_0 i2_0)" +"(if(string? sfx_1)(string->bytes/locale sfx_1(char->integer '#\\?)) sfx_1))" +"(if(path-for-some-system? s_4)" +"(path-convention-type s_4)" +"(system-path-convention-type)))))))" +"(let-values(((new-name_0)" +"(letrec-values(((loop_5)" +"(lambda(i_1)" +"(begin" +" 'loop" +"(if(zero? i_1)" +" (finish_0 (bytes-length bs_0) #\"\" (bytes-length bs_0))" +"(let-values(((i_2)(sub1 i_1)))" +"(if(if(not(zero? i_2))" +"(eq?(char->integer '#\\.)(bytes-ref bs_0 i_2))" +" #f)" +"(finish_0 i_2 sep_1(add1 i_2))" +"(loop_5 i_2))))))))" +"(loop_5(bytes-length bs_0)))))" +"(if(path-for-some-system? base_1)(build-path base_1 new-name_0) new-name_0))))))))" +"(define-values" +"(path-replace-extension)" +" (lambda (s_5 sfx_2) (begin (path-adjust-extension 'path-replace-extension #\"\" (lambda (bs_1 i_3) #\"\") s_5 sfx_2 #t))))" +"(define-values" +"(path-add-extension)" +"(case-lambda" +" ((s_6 sfx_3) (begin (path-adjust-extension 'path-add-extension #\"_\" subbytes s_6 sfx_3 #t)))" +"((s_7 sfx_4 sep_3)(path-adjust-extension 'path-add-extension sep_3 subbytes s_7 sfx_4 #f))))" +"(define-values" +"(reroot-path)" +"(lambda(p_0 root_0)" +"(begin" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_7)(path-string? p_0)))" +"(if or-part_7 or-part_7(path-for-some-system? p_0)))" +"(void)" +"(let-values()" +" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 0 p_0 root_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_8)(path-string? root_0)))" +"(if or-part_8 or-part_8(path-for-some-system? root_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'reroot-path" +" \"(or/c path-string? path-for-some-system?)\"" +" 1" +" p_0" +" root_0)))" +"(values))))" +"(let-values(((conv_0)" +"(if(path-for-some-system? p_0)(path-convention-type p_0)(system-path-convention-type))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_9)(complete-path? p_0)))" +"(if or-part_9 or-part_9(eq?(system-path-convention-type) conv_0)))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'reroot-path" +" \"path is not complete and not the platform's convention\"" +" \"path\"" +" p_0" +" \"platform convention type\"" +"(system-path-convention-type))))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?" +"(if(path-for-some-system? root_0)" +"(path-convention-type root_0)" +"(system-path-convention-type))" +" conv_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'reroot-path" +" \"given paths use different conventions\"" +" \"path\"" +" p_0" +" \"root path\"" +" root_0)))" +"(values))))" +"(let-values(((c-p_0)" +"(normal-case-path" +"(cleanse-path(if(complete-path? p_0) p_0(path->complete-path p_0))))))" +"(let-values(((bstr_0)(path->bytes c-p_0)))" +"(if(eq? conv_0 'unix)" +"(let-values()" +" (if (bytes=? bstr_0 #\"/\")" +"(if(path-for-some-system? root_0) root_0(string->path root_0))" +"(build-path root_0(bytes->path(subbytes(path->bytes c-p_0) 1) conv_0))))" +"(if(eq? conv_0 'windows)" +"(let-values()" +"(build-path" +" root_0" +"(bytes->path" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\[a-z]:\" bstr_0)" +"(let-values()" +" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr_0 4 5) #\"\\\\\" (subbytes bstr_0 6)))" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr_0)" +" (let-values () (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr_0 4)))" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr_0)" +" (let-values () (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr_0 4)))" +" (if (regexp-match? '#rx\"^\\\\\\\\\\\\\\\\\" bstr_0)" +" (let-values () (bytes-append #\"UNC\\\\\" (subbytes bstr_0 2)))" +" (if (regexp-match? '#rx\"^[a-z]:\" bstr_0)" +"(let-values()(bytes-append(subbytes bstr_0 0 1)(subbytes bstr_0 2)))" +"(void))))))" +" conv_0)))" +"(void)))))))))))))" +"(define-values" +"(path-list-string->path-list)" +"(let-values(((r_0) #f)" +"((cons-path_0)" +"(lambda(default_4 s_1 l_2)" +"(begin" +" 'cons-path" +" (let-values (((s_8) (if (eq? (system-type) 'windows) (regexp-replace* '#rx#\"\\\"\" s_1 #\"\") s_1)))" +" (if (bytes=? s_8 #\"\") (append default_4 l_2) (cons (bytes->path s_8) l_2)))))))" +"(lambda(s_2 default_5)" +"(begin" +"(begin" +"(if r_0" +"(void)" +"(let-values()" +"(set! r_0" +"(byte-regexp" +"(string->bytes/utf-8" +" (let-values (((sep_4) (if (eq? (system-type) 'windows) \";\" \":\")))" +" (format \"([^~a]*)~a(.*)\" sep_4 sep_4)))))))" +"(if(let-values(((or-part_10)(bytes? s_2)))(if or-part_10 or-part_10(string? s_2)))" +"(void)" +" (let-values () (raise-argument-error 'path-list-string->path-list \"(or/c bytes? string?)\" s_2)))" +"(if(if(list? default_5)(andmap path? default_5) #f)" +"(void)" +" (let-values () (raise-argument-error 'path-list-string->path-list \"(listof path?)\" default_5)))" +"((letrec-values(((loop_6)" +"(lambda(s_9)" +"(begin" +" 'loop" +"(let-values(((m_0)(regexp-match r_0 s_9)))" +"(if m_0" +"(cons-path_0 default_5(cadr m_0)(loop_6(caddr m_0)))" +"(cons-path_0 default_5 s_9 null)))))))" +" loop_6)" +"(if(string? s_2)(string->bytes/utf-8 s_2) s_2)))))))" +"(define-values" +"(find-executable-path)" +"(case-lambda" +"((program_0 libpath_0 reverse?_0)" +"(begin" +"(begin" +"(if(path-string? program_0)" +"(void)" +" (let-values () (raise-argument-error 'find-executable-path \"path-string?\" program_0)))" +"(if(let-values(((or-part_11)(not libpath_0)))" +"(if or-part_11 or-part_11(if(path-string? libpath_0)(relative-path? libpath_0) #f)))" +"(void)" +"(let-values()" +" (raise-argument-error 'find-executable-path \"(or/c #f (and/c path-string? relative-path?))\" libpath_0)))" +"(letrec-values(((found-exec_0)" +"(lambda(exec-name_0)" +"(begin" +" 'found-exec" +"(if libpath_0" +"(let-values(((base_2 name_3 isdir?_0)(split-path exec-name_0)))" +"(let-values(((next_0)" +"(lambda()" +"(begin" +" 'next" +"(let-values(((resolved_0)(resolve-path exec-name_0)))" +"(if(equal? resolved_0 exec-name_0)" +"(let-values() #f)" +"(if(relative-path? resolved_0)" +"(let-values()(found-exec_0(build-path base_2 resolved_0)))" +"(let-values()(found-exec_0 resolved_0)))))))))" +"(let-values(((or-part_12)(if reverse?_0(next_0) #f)))" +"(if or-part_12" +" or-part_12" +"(let-values(((or-part_13)" +"(if(path? base_2)" +"(let-values(((lib_0)(build-path base_2 libpath_0)))" +"(if(let-values(((or-part_3)(directory-exists? lib_0)))" +"(if or-part_3 or-part_3(file-exists? lib_0)))" +" lib_0" +" #f))" +" #f)))" +"(if or-part_13 or-part_13(if(not reverse?_0)(next_0) #f)))))))" +" exec-name_0)))))" +"(if(if(relative-path? program_0)" +"(let-values(((base_3 name_4 dir?_1)(split-path program_0)))(eq? base_3 'relative))" +" #f)" +" (let-values (((paths-str_0) (environment-variables-ref (current-environment-variables) #\"PATH\"))" +"((win-add_0)" +"(lambda(s_10)" +" (begin 'win-add (if (eq? (system-type) 'windows) (cons (bytes->path #\".\") s_10) s_10)))))" +"((letrec-values(((loop_7)" +"(lambda(paths_0)" +"(begin" +" 'loop" +"(if(null? paths_0)" +" #f" +"(let-values(((base_4)(path->complete-path(car paths_0))))" +"(let-values(((name_5)(build-path base_4 program_0)))" +"(if(file-exists? name_5)(found-exec_0 name_5)(loop_7(cdr paths_0))))))))))" +" loop_7)" +"(win-add_0" +"(if paths-str_0(path-list-string->path-list(bytes->string/locale paths-str_0 '#\\?) null) null))))" +"(let-values(((p_1)(path->complete-path program_0)))(if(file-exists? p_1)(found-exec_0 p_1) #f)))))))" +"((program_1 libpath_1)(find-executable-path program_1 libpath_1 #f))" +"((program_2)(find-executable-path program_2 #f #f))))" +"(define-values" +"(call-with-default-reading-parameterization)" +"(lambda(thunk_1)" +"(begin" +"(if(if(procedure? thunk_1)(procedure-arity-includes? thunk_1 0) #f)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" read-case-sensitive" +" #t" +" 1/read-square-bracket-as-paren" +" #t" +" 1/read-curly-brace-as-paren" +" #t" +" 1/read-square-bracket-with-tag" +" #f" +" 1/read-curly-brace-with-tag" +" #f" +" 1/read-accept-box" +" #t" +" 1/read-accept-compiled" +" #f" +" read-accept-bar-quote" +" #t" +" 1/read-accept-graph" +" #t" +" 1/read-decimal-as-inexact" +" #t" +" 1/read-cdot" +" #f" +" 1/read-accept-dot" +" #t" +" 1/read-accept-infix-dot" +" #t" +" 1/read-accept-quasiquote" +" #t" +" 1/read-accept-reader" +" #f" +" 1/read-accept-lang" +" #t" +" 1/current-readtable" +" #f)" +"(let-values()(thunk_1)))" +" (raise-argument-error 'call-with-default-reading-parameterization \"(procedure-arity-includes/c 0)\" thunk_1)))))" +"(define-values" +"(prop:procedure-accessor procedure-accessor? procedure-accessor-ref)" +"(make-struct-type-property" +" 'procedure" +"(lambda(v_8 info-l_0)(if(exact-integer? v_8)(make-struct-field-accessor(list-ref info-l_0 3) v_8) #f))))" +"(define-values" +"(new-prop:procedure new-procedure? new-procedure-ref)" +"(make-struct-type-property" +" 'procedure" +" #f" +"(list(cons prop:procedure values)(cons prop:procedure-accessor values))" +" #t))" +"(define-values" +"(reverse$1)" +"(lambda(l_3)" +"(begin" +" 'reverse" +"(begin" +" (if (list? l_3) (void) (raise-argument-error 'reverse \"list?\" l_3))" +"(letrec-values(((loop_8)" +"(lambda(a_1 l_4)(begin 'loop(if(null? l_4) a_1(loop_8(cons(car l_4) a_1)(cdr l_4)))))))" +"(loop_8 null l_3))))))" +"(define-values" +"(sort vector-sort vector-sort!)" +"(let-values()" +"(let-values(((generic-sort_0)" +"(lambda(A_0 less-than?_0 n_1)" +"(begin" +" 'generic-sort" +"(let-values()" +"(let-values()" +"(let-values(((n/2-_0)(unsafe-fxrshift n_1 1)))" +"(let-values(((n/2+_0)(unsafe-fx- n_1 n/2-_0)))" +"(letrec-values(((copying-mergesort_0)" +"(lambda(Alo_0 Blo_0 n_2)" +"(begin" +" 'copying-mergesort" +"(if(unsafe-fx= n_2 1)" +"(let-values()" +"(unsafe-vector-set! A_0 Blo_0(unsafe-vector-ref A_0 Alo_0)))" +"(if(unsafe-fx= n_2 2)" +"(let-values()" +"(let-values(((x_0)(unsafe-vector-ref A_0 Alo_0))" +"((y_0)" +"(unsafe-vector-ref A_0(unsafe-fx+ Alo_0 1))))" +"(if(less-than?_0 y_0 x_0)" +"(begin" +"(unsafe-vector-set! A_0 Blo_0 y_0)" +"(unsafe-vector-set! A_0(unsafe-fx+ Blo_0 1) x_0))" +"(begin" +"(unsafe-vector-set! A_0 Blo_0 x_0)" +"(unsafe-vector-set! A_0(unsafe-fx+ Blo_0 1) y_0)))))" +"(if(unsafe-fx< n_2 16)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_0" +" Blo_0" +"(unsafe-vector-ref A_0 Alo_0))" +"((letrec-values(((iloop_0)" +"(lambda(i_4)" +"(begin" +" 'iloop" +"(if(unsafe-fx< i_4 n_2)" +"(let-values()" +"(let-values(((ref-i_0)" +"(unsafe-vector-ref" +" A_0" +"(unsafe-fx+" +" Alo_0" +" i_4))))" +"((letrec-values(((jloop_0)" +"(lambda(j_0)" +"(begin" +" 'jloop" +"(let-values(((ref-j-1_0)" +"(unsafe-vector-ref" +" A_0" +"(unsafe-fx-" +" j_0" +" 1))))" +"(if(if(unsafe-fx<" +" Blo_0" +" j_0)" +"(less-than?_0" +" ref-i_0" +" ref-j-1_0)" +" #f)" +"(begin" +"(unsafe-vector-set!" +" A_0" +" j_0" +" ref-j-1_0)" +"(jloop_0" +"(unsafe-fx-" +" j_0" +" 1)))" +"(begin" +"(unsafe-vector-set!" +" A_0" +" j_0" +" ref-i_0)" +"(iloop_0" +"(unsafe-fx+" +" i_4" +" 1)))))))))" +" jloop_0)" +"(unsafe-fx+ Blo_0 i_4))))" +"(void))))))" +" iloop_0)" +" 1)))" +"(let-values()" +"(let-values(((n/2-_1)(unsafe-fxrshift n_2 1)))" +"(let-values(((n/2+_1)(unsafe-fx- n_2 n/2-_1)))" +"(let-values(((Amid1_0)(unsafe-fx+ Alo_0 n/2-_1))" +"((Amid2_0)(unsafe-fx+ Alo_0 n/2+_1))" +"((Bmid1_0)(unsafe-fx+ Blo_0 n/2-_1)))" +"(begin" +"(copying-mergesort_0 Amid1_0 Bmid1_0 n/2+_1)" +"(copying-mergesort_0 Alo_0 Amid2_0 n/2-_1)" +"(let-values(((b2_0)(unsafe-fx+ Blo_0 n_2)))" +"((letrec-values(((loop_9)" +"(lambda(a1_0 b1_0 c1_0)" +"(begin" +" 'loop" +"(let-values(((x_1)" +"(unsafe-vector-ref" +" A_0" +" a1_0))" +"((y_1)" +"(unsafe-vector-ref" +" A_0" +" b1_0)))" +"(if(not" +"(less-than?_0" +" y_1" +" x_1))" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_0" +" x_1)" +"(let-values(((a1_1)" +"(unsafe-fx+" +" a1_0" +" 1))" +"((c1_1)" +"(unsafe-fx+" +" c1_0" +" 1)))" +"(if(unsafe-fx<" +" c1_1" +" b1_0)" +"(let-values()" +"(loop_9" +" a1_1" +" b1_0" +" c1_1))" +"(void))))" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_0" +" y_1)" +"(let-values(((b1_1)" +"(unsafe-fx+" +" b1_0" +" 1))" +"((c1_2)" +"(unsafe-fx+" +" c1_0" +" 1)))" +"(if(unsafe-fx<=" +" b2_0" +" b1_1)" +"((letrec-values(((loop_10)" +"(lambda(a1_2" +" c1_3)" +"(begin" +" 'loop" +"(if(unsafe-fx<" +" c1_3" +" b1_1)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_3" +"(unsafe-vector-ref" +" A_0" +" a1_2))" +"(loop_10" +"(unsafe-fx+" +" a1_2" +" 1)" +"(unsafe-fx+" +" c1_3" +" 1))))" +"(void))))))" +" loop_10)" +" a1_0" +" c1_2)" +"(loop_9" +" a1_0" +" b1_1" +" c1_2))))))))))" +" loop_9)" +" Amid2_0" +" Bmid1_0" +" Blo_0))))))))))))))" +"(let-values(((Alo_1) 0)" +"((Amid1_1) n/2-_0)" +"((Amid2_1) n/2+_0)" +"((Ahi_0) n_1)" +"((B1lo_0) n_1))" +"(begin" +"(copying-mergesort_0 Amid1_1 B1lo_0 n/2+_0)" +"(if(zero? n/2-_0)" +"(void)" +"(let-values()(copying-mergesort_0 Alo_1 Amid2_1 n/2-_0)))" +"(let-values(((b2_1) Ahi_0))" +"((letrec-values(((loop_11)" +"(lambda(a1_3 b1_2 c1_4)" +"(begin" +" 'loop" +"(let-values(((x_2)(unsafe-vector-ref A_0 a1_3))" +"((y_2)(unsafe-vector-ref A_0 b1_2)))" +"(if(less-than?_0 x_2 y_2)" +"(begin" +"(unsafe-vector-set! A_0 c1_4 x_2)" +"(let-values(((a1_4)(unsafe-fx+ a1_3 1))" +"((c1_5)(unsafe-fx+ c1_4 1)))" +"(if(unsafe-fx< c1_5 b1_2)" +"(let-values()(loop_11 a1_4 b1_2 c1_5))" +"(void))))" +"(begin" +"(unsafe-vector-set! A_0 c1_4 y_2)" +"(let-values(((b1_3)(unsafe-fx+ b1_2 1))" +"((c1_6)(unsafe-fx+ c1_4 1)))" +"(if(unsafe-fx<= b2_1 b1_3)" +"((letrec-values(((loop_12)" +"(lambda(a1_5 c1_7)" +"(begin" +" 'loop" +"(if(unsafe-fx< c1_7 b1_3)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_0" +" c1_7" +"(unsafe-vector-ref" +" A_0" +" a1_5))" +"(loop_12" +"(unsafe-fx+ a1_5 1)" +"(unsafe-fx+" +" c1_7" +" 1))))" +"(void))))))" +" loop_12)" +" a1_3" +" c1_6)" +"(loop_11 a1_3 b1_3 c1_6))))))))))" +" loop_11)" +" B1lo_0" +" Amid2_1" +" Alo_1)))))))))))))" +"(let-values(((generic-sort/key_0)" +"(lambda(A_1 less-than?_1 n_3 key_7)" +"(begin" +" 'generic-sort/key" +"(let-values()" +"(let-values()" +"(let-values(((n/2-_2)(unsafe-fxrshift n_3 1)))" +"(let-values(((n/2+_2)(unsafe-fx- n_3 n/2-_2)))" +"(letrec-values(((copying-mergesort_1)" +"(lambda(Alo_2 Blo_1 n_4)" +"(begin" +" 'copying-mergesort" +"(if(unsafe-fx= n_4 1)" +"(let-values()" +"(unsafe-vector-set! A_1 Blo_1(unsafe-vector-ref A_1 Alo_2)))" +"(if(unsafe-fx= n_4 2)" +"(let-values()" +"(let-values(((x_3)(unsafe-vector-ref A_1 Alo_2))" +"((y_3)" +"(unsafe-vector-ref A_1(unsafe-fx+ Alo_2 1))))" +"(if(if key_7" +"(less-than?_1(key_7 y_3)(key_7 x_3))" +"(less-than?_1 y_3 x_3))" +"(begin" +"(unsafe-vector-set! A_1 Blo_1 y_3)" +"(unsafe-vector-set! A_1(unsafe-fx+ Blo_1 1) x_3))" +"(begin" +"(unsafe-vector-set! A_1 Blo_1 x_3)" +"(unsafe-vector-set! A_1(unsafe-fx+ Blo_1 1) y_3)))))" +"(if(unsafe-fx< n_4 16)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_1" +" Blo_1" +"(unsafe-vector-ref A_1 Alo_2))" +"((letrec-values(((iloop_1)" +"(lambda(i_5)" +"(begin" +" 'iloop" +"(if(unsafe-fx< i_5 n_4)" +"(let-values()" +"(let-values(((ref-i_1)" +"(unsafe-vector-ref" +" A_1" +"(unsafe-fx+" +" Alo_2" +" i_5))))" +"((letrec-values(((jloop_1)" +"(lambda(j_1)" +"(begin" +" 'jloop" +"(let-values(((ref-j-1_1)" +"(unsafe-vector-ref" +" A_1" +"(unsafe-fx-" +" j_1" +" 1))))" +"(if(if(unsafe-fx<" +" Blo_1" +" j_1)" +"(if key_7" +"(less-than?_1" +"(key_7" +" ref-i_1)" +"(key_7" +" ref-j-1_1))" +"(less-than?_1" +" ref-i_1" +" ref-j-1_1))" +" #f)" +"(begin" +"(unsafe-vector-set!" +" A_1" +" j_1" +" ref-j-1_1)" +"(jloop_1" +"(unsafe-fx-" +" j_1" +" 1)))" +"(begin" +"(unsafe-vector-set!" +" A_1" +" j_1" +" ref-i_1)" +"(iloop_1" +"(unsafe-fx+" +" i_5" +" 1)))))))))" +" jloop_1)" +"(unsafe-fx+ Blo_1 i_5))))" +"(void))))))" +" iloop_1)" +" 1)))" +"(let-values()" +"(let-values(((n/2-_3)(unsafe-fxrshift n_4 1)))" +"(let-values(((n/2+_3)(unsafe-fx- n_4 n/2-_3)))" +"(let-values(((Amid1_2)(unsafe-fx+ Alo_2 n/2-_3))" +"((Amid2_2)(unsafe-fx+ Alo_2 n/2+_3))" +"((Bmid1_1)(unsafe-fx+ Blo_1 n/2-_3)))" +"(begin" +"(copying-mergesort_1 Amid1_2 Bmid1_1 n/2+_3)" +"(copying-mergesort_1 Alo_2 Amid2_2 n/2-_3)" +"(let-values(((b2_2)(unsafe-fx+ Blo_1 n_4)))" +"((letrec-values(((loop_13)" +"(lambda(a1_6 b1_4 c1_8)" +"(begin" +" 'loop" +"(let-values(((x_4)" +"(unsafe-vector-ref" +" A_1" +" a1_6))" +"((y_4)" +"(unsafe-vector-ref" +" A_1" +" b1_4)))" +"(if(not" +"(if key_7" +"(less-than?_1" +"(key_7 y_4)" +"(key_7 x_4))" +"(less-than?_1" +" y_4" +" x_4)))" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_8" +" x_4)" +"(let-values(((a1_7)" +"(unsafe-fx+" +" a1_6" +" 1))" +"((c1_9)" +"(unsafe-fx+" +" c1_8" +" 1)))" +"(if(unsafe-fx<" +" c1_9" +" b1_4)" +"(let-values()" +"(loop_13" +" a1_7" +" b1_4" +" c1_9))" +"(void))))" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_8" +" y_4)" +"(let-values(((b1_5)" +"(unsafe-fx+" +" b1_4" +" 1))" +"((c1_10)" +"(unsafe-fx+" +" c1_8" +" 1)))" +"(if(unsafe-fx<=" +" b2_2" +" b1_5)" +"((letrec-values(((loop_14)" +"(lambda(a1_8" +" c1_11)" +"(begin" +" 'loop" +"(if(unsafe-fx<" +" c1_11" +" b1_5)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_11" +"(unsafe-vector-ref" +" A_1" +" a1_8))" +"(loop_14" +"(unsafe-fx+" +" a1_8" +" 1)" +"(unsafe-fx+" +" c1_11" +" 1))))" +"(void))))))" +" loop_14)" +" a1_6" +" c1_10)" +"(loop_13" +" a1_6" +" b1_5" +" c1_10))))))))))" +" loop_13)" +" Amid2_2" +" Bmid1_1" +" Blo_1))))))))))))))" +"(let-values(((Alo_3) 0)" +"((Amid1_3) n/2-_2)" +"((Amid2_3) n/2+_2)" +"((Ahi_1) n_3)" +"((B1lo_1) n_3))" +"(begin" +"(copying-mergesort_1 Amid1_3 B1lo_1 n/2+_2)" +"(if(zero? n/2-_2)" +"(void)" +"(let-values()(copying-mergesort_1 Alo_3 Amid2_3 n/2-_2)))" +"(let-values(((b2_3) Ahi_1))" +"((letrec-values(((loop_15)" +"(lambda(a1_9 b1_6 c1_12)" +"(begin" +" 'loop" +"(let-values(((x_5)(unsafe-vector-ref A_1 a1_9))" +"((y_5)(unsafe-vector-ref A_1 b1_6)))" +"(if(if key_7" +"(less-than?_1(key_7 x_5)(key_7 y_5))" +"(less-than?_1 x_5 y_5))" +"(begin" +"(unsafe-vector-set! A_1 c1_12 x_5)" +"(let-values(((a1_10)(unsafe-fx+ a1_9 1))" +"((c1_13)(unsafe-fx+ c1_12 1)))" +"(if(unsafe-fx< c1_13 b1_6)" +"(let-values()(loop_15 a1_10 b1_6 c1_13))" +"(void))))" +"(begin" +"(unsafe-vector-set! A_1 c1_12 y_5)" +"(let-values(((b1_7)(unsafe-fx+ b1_6 1))" +"((c1_14)(unsafe-fx+ c1_12 1)))" +"(if(unsafe-fx<= b2_3 b1_7)" +"((letrec-values(((loop_16)" +"(lambda(a1_11 c1_15)" +"(begin" +" 'loop" +"(if(unsafe-fx<" +" c1_15" +" b1_7)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" A_1" +" c1_15" +"(unsafe-vector-ref" +" A_1" +" a1_11))" +"(loop_16" +"(unsafe-fx+" +" a1_11" +" 1)" +"(unsafe-fx+" +" c1_15" +" 1))))" +"(void))))))" +" loop_16)" +" a1_9" +" c1_14)" +"(loop_15 a1_9 b1_7 c1_14))))))))))" +" loop_15)" +" B1lo_1" +" Amid2_3" +" Alo_3)))))))))))))" +"(values" +"(case-lambda" +"((lst_0 less-than?_2)" +"(let-values(((n_5)(length lst_0)))" +"(let-values()" +"(if(unsafe-fx= n_5 0)" +"(let-values() lst_0)" +"(if((letrec-values(((loop_17)" +"(lambda(last_0 next_1)" +"(begin" +" 'loop" +"(let-values(((or-part_14)(null? next_1)))" +"(if or-part_14" +" or-part_14" +"(if(not(less-than?_2(unsafe-car next_1) last_0))" +"(loop_17(unsafe-car next_1)(unsafe-cdr next_1))" +" #f)))))))" +" loop_17)" +"(car lst_0)" +"(cdr lst_0))" +"(let-values() lst_0)" +"(if(unsafe-fx<= n_5 3)" +"(let-values()" +"(if(unsafe-fx= n_5 1)" +"(let-values() lst_0)" +"(if(unsafe-fx= n_5 2)" +"(let-values()(list(cadr lst_0)(car lst_0)))" +"(let-values()" +"(let-values(((a_2)(car lst_0))((b_1)(cadr lst_0))((c_0)(caddr lst_0)))" +"(if(less-than?_2 b_1 a_2)" +"(if(less-than?_2 c_0 b_1)" +"(list c_0 b_1 a_2)" +"(if(less-than?_2 c_0 a_2)(list b_1 c_0 a_2)(list b_1 a_2 c_0)))" +"(if(less-than?_2 c_0 a_2)(list c_0 a_2 b_1)(list a_2 c_0 b_1))))))))" +"(let-values()" +"(let-values(((vec_0)(make-vector(+ n_5(ceiling(/ n_5 2))))))" +"(begin" +"((letrec-values(((loop_18)" +"(lambda(i_6 lst_1)" +"(begin" +" 'loop" +"(if(pair? lst_1)" +"(let-values()" +"(begin" +"(vector-set! vec_0 i_6(car lst_1))" +"(loop_18(add1 i_6)(cdr lst_1))))" +"(void))))))" +" loop_18)" +" 0" +" lst_0)" +"(generic-sort_0 vec_0 less-than?_2 n_5)" +"((letrec-values(((loop_19)" +"(lambda(i_7 r_1)" +"(begin" +" 'loop" +"(let-values(((i_8)(sub1 i_7)))" +"(if(< i_8 0)" +" r_1" +"(loop_19 i_8(cons(vector-ref vec_0 i_8) r_1))))))))" +" loop_19)" +" n_5" +" '()))))))))))" +"((lst_2 less-than?_3 getkey_0)" +"(if(if getkey_0(not(eq? values getkey_0)) #f)" +"(sort lst_2 less-than?_3 getkey_0 #f)" +"(sort lst_2 less-than?_3)))" +"((lst_3 less-than?_4 getkey_1 cache-keys?_0)" +"(if(if getkey_1(not(eq? values getkey_1)) #f)" +"(let-values(((n_6)(length lst_3)))" +"(let-values()" +"(if(unsafe-fx= n_6 0)" +"(let-values() lst_3)" +"(if cache-keys?_0" +"(let-values()" +"(let-values(((vec_1)(make-vector(+ n_6(ceiling(/ n_6 2))))))" +"(begin" +"((letrec-values(((loop_20)" +"(lambda(i_9 lst_4)" +"(begin" +" 'loop" +"(if(pair? lst_4)" +"(let-values()" +"(let-values(((x_6)(car lst_4)))" +"(begin" +"(unsafe-vector-set! vec_1 i_9(cons(getkey_1 x_6) x_6))" +"(loop_20(unsafe-fx+ i_9 1)(cdr lst_4)))))" +"(void))))))" +" loop_20)" +" 0" +" lst_3)" +"(generic-sort/key_0 vec_1 less-than?_4 n_6 unsafe-car)" +"((letrec-values(((loop_21)" +"(lambda(i_10 r_2)" +"(begin" +" 'loop" +"(let-values(((i_11)(unsafe-fx- i_10 1)))" +"(if(unsafe-fx< i_11 0)" +" r_2" +"(loop_21" +" i_11" +"(cons(unsafe-cdr(unsafe-vector-ref vec_1 i_11)) r_2))))))))" +" loop_21)" +" n_6" +" '()))))" +"(if((letrec-values(((loop_22)" +"(lambda(last_1 next_2)" +"(begin" +" 'loop" +"(let-values(((or-part_15)(null? next_2)))" +"(if or-part_15" +" or-part_15" +"(if(not" +"(if getkey_1" +"(less-than?_4" +"(getkey_1(unsafe-car next_2))" +"(getkey_1 last_1))" +"(less-than?_4(unsafe-car next_2) last_1)))" +"(loop_22(unsafe-car next_2)(unsafe-cdr next_2))" +" #f)))))))" +" loop_22)" +"(car lst_3)" +"(cdr lst_3))" +"(let-values() lst_3)" +"(if(unsafe-fx<= n_6 3)" +"(let-values()" +"(if(unsafe-fx= n_6 1)" +"(let-values() lst_3)" +"(if(unsafe-fx= n_6 2)" +"(let-values()(list(cadr lst_3)(car lst_3)))" +"(let-values()" +"(let-values(((a_3)(car lst_3))((b_2)(cadr lst_3))((c_1)(caddr lst_3)))" +"(if(if getkey_1(less-than?_4(getkey_1 b_2)(getkey_1 a_3))(less-than?_4 b_2 a_3))" +"(if(if getkey_1" +"(less-than?_4(getkey_1 c_1)(getkey_1 b_2))" +"(less-than?_4 c_1 b_2))" +"(list c_1 b_2 a_3)" +"(if(if getkey_1" +"(less-than?_4(getkey_1 c_1)(getkey_1 a_3))" +"(less-than?_4 c_1 a_3))" +"(list b_2 c_1 a_3)" +"(list b_2 a_3 c_1)))" +"(if(if getkey_1" +"(less-than?_4(getkey_1 c_1)(getkey_1 a_3))" +"(less-than?_4 c_1 a_3))" +"(list c_1 a_3 b_2)" +"(list a_3 c_1 b_2))))))))" +"(let-values()" +"(let-values(((vec_2)(make-vector(+ n_6(ceiling(/ n_6 2))))))" +"(begin" +"((letrec-values(((loop_23)" +"(lambda(i_12 lst_5)" +"(begin" +" 'loop" +"(if(pair? lst_5)" +"(let-values()" +"(begin" +"(vector-set! vec_2 i_12(car lst_5))" +"(loop_23(add1 i_12)(cdr lst_5))))" +"(void))))))" +" loop_23)" +" 0" +" lst_3)" +"(generic-sort/key_0 vec_2 less-than?_4 n_6 getkey_1)" +"((letrec-values(((loop_24)" +"(lambda(i_13 r_3)" +"(begin" +" 'loop" +"(let-values(((i_14)(sub1 i_13)))" +"(if(< i_14 0)" +" r_3" +"(loop_24 i_14(cons(vector-ref vec_2 i_14) r_3))))))))" +" loop_24)" +" n_6" +" '()))))))))))" +"(sort lst_3 less-than?_4))))" +"(case-lambda" +"((vec_3 less-than?_5 start_0 end_0)" +"(let-values(((n_7)(- end_0 start_0)))" +"(let-values(((dst-vec_0)(make-vector n_7)))" +"(let-values(((dst-start_0) 0))" +"(begin" +"(if(unsafe-fx= n_7 0)" +"(let-values()(void))" +"(if((letrec-values(((loop_25)" +"(lambda(prev-val_0 next-index_0)" +"(begin" +" 'loop" +"(let-values(((or-part_16)(unsafe-fx= next-index_0 end_0)))" +"(if or-part_16" +" or-part_16" +"(let-values(((next-val_0)(unsafe-vector-ref vec_3 next-index_0)))" +"(if(not(less-than?_5 next-val_0 prev-val_0))" +"(loop_25 next-val_0(unsafe-fx+ next-index_0 1))" +" #f))))))))" +" loop_25)" +"(unsafe-vector-ref vec_3 start_0)" +"(unsafe-fx+ start_0 1))" +"(let-values()(let-values()(vector-copy! dst-vec_0 dst-start_0 vec_3 start_0 end_0)))" +"(if(unsafe-fx<= n_7 3)" +"(let-values()" +"(begin" +"(let-values()(vector-copy! dst-vec_0 dst-start_0 vec_3 start_0 end_0))" +"(if(unsafe-fx= n_7 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_7 2)" +"(let-values()" +"(let-values(((tmp_0)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_0" +"(unsafe-fx+ dst-start_0 0)" +"(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 1)))" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) tmp_0))))" +"(let-values()" +"(let-values(((a_4)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 0)))" +"((b_3)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 1)))" +"((c_2)(unsafe-vector-ref dst-vec_0(unsafe-fx+ dst-start_0 2))))" +"(if(less-than?_5 b_3 a_4)" +"(let-values()" +"(if(less-than?_5 c_2 b_3)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) a_4)))" +"(if(less-than?_5 c_2 a_4)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) b_3)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) a_4)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) b_3)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) a_4))))))" +"(if(less-than?_5 c_2 a_4)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 0) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) a_4)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) b_3)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 1) c_2)" +"(unsafe-vector-set! dst-vec_0(unsafe-fx+ dst-start_0 2) b_3)))))))))))" +"(let-values()" +"(let-values(((work-vec_0)(make-vector(+ n_7(ceiling(/ n_7 2))) #f)))" +"(begin" +"(vector-copy! work-vec_0 0 vec_3 start_0 end_0)" +"(generic-sort_0 work-vec_0 less-than?_5 n_7)" +"(vector-copy! dst-vec_0 dst-start_0 work-vec_0 0 n_7)))))))" +" dst-vec_0)))))" +"((vec_4 less-than?_6 start_1 end_1 getkey_2 cache-keys?_1)" +"(if(if getkey_2(not(eq? values getkey_2)) #f)" +"(let-values(((n_8)(- end_1 start_1)))" +"(let-values(((dst-vec_1)(make-vector n_8)))" +"(let-values(((dst-start_1) 0))" +"(begin" +"(if(unsafe-fx= n_8 0)" +"(let-values()(void))" +"(if cache-keys?_1" +"(let-values()" +"(let-values(((work-vec_1)(make-vector(+ n_8(ceiling(/ n_8 2))) #t)))" +"(begin" +"((letrec-values(((loop_26)" +"(lambda(i_15)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_15 n_8)" +"(let-values()" +"(begin" +"(let-values(((x_7)" +"(unsafe-vector-ref" +" vec_4" +"(unsafe-fx+ i_15 start_1))))" +"(unsafe-vector-set!" +" work-vec_1" +" i_15" +"(cons(getkey_2 x_7) x_7)))" +"(loop_26(unsafe-fx+ i_15 1))))" +"(void))))))" +" loop_26)" +" 0)" +"(generic-sort/key_0 work-vec_1 less-than?_6 n_8 unsafe-car)" +"((letrec-values(((loop_27)" +"(lambda(i_16)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_16 n_8)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" dst-vec_1" +"(unsafe-fx+ i_16 dst-start_1)" +"(unsafe-cdr(unsafe-vector-ref work-vec_1 i_16)))" +"(loop_27(unsafe-fx+ i_16 1))))" +"(void))))))" +" loop_27)" +" 0))))" +"(if((letrec-values(((loop_28)" +"(lambda(prev-val_1 next-index_1)" +"(begin" +" 'loop" +"(let-values(((or-part_17)(unsafe-fx= next-index_1 end_1)))" +"(if or-part_17" +" or-part_17" +"(let-values(((next-val_1)" +"(unsafe-vector-ref vec_4 next-index_1)))" +"(if(not" +"(if getkey_2" +"(less-than?_6" +"(getkey_2 next-val_1)" +"(getkey_2 prev-val_1))" +"(less-than?_6 next-val_1 prev-val_1)))" +"(loop_28 next-val_1(unsafe-fx+ next-index_1 1))" +" #f))))))))" +" loop_28)" +"(unsafe-vector-ref vec_4 start_1)" +"(unsafe-fx+ start_1 1))" +"(let-values()(let-values()(vector-copy! dst-vec_1 dst-start_1 vec_4 start_1 end_1)))" +"(if(unsafe-fx<= n_8 3)" +"(let-values()" +"(begin" +"(let-values()(vector-copy! dst-vec_1 dst-start_1 vec_4 start_1 end_1))" +"(if(unsafe-fx= n_8 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_8 2)" +"(let-values()" +"(let-values(((tmp_1)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_1" +"(unsafe-fx+ dst-start_1 0)" +"(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 1)))" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) tmp_1))))" +"(let-values()" +"(let-values(((a_5)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 0)))" +"((b_4)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 1)))" +"((c_3)(unsafe-vector-ref dst-vec_1(unsafe-fx+ dst-start_1 2))))" +"(if(if getkey_2" +"(less-than?_6(getkey_2 b_4)(getkey_2 a_5))" +"(less-than?_6 b_4 a_5))" +"(let-values()" +"(if(if getkey_2" +"(less-than?_6(getkey_2 c_3)(getkey_2 b_4))" +"(less-than?_6 c_3 b_4))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) a_5)))" +"(if(if getkey_2" +"(less-than?_6(getkey_2 c_3)(getkey_2 a_5))" +"(less-than?_6 c_3 a_5))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) b_4)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) a_5)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) b_4)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) a_5))))))" +"(if(if getkey_2" +"(less-than?_6(getkey_2 c_3)(getkey_2 a_5))" +"(less-than?_6 c_3 a_5))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 0) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) a_5)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) b_4)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 1) c_3)" +"(unsafe-vector-set! dst-vec_1(unsafe-fx+ dst-start_1 2) b_4)))))))))))" +"(let-values()" +"(let-values(((work-vec_2)(make-vector(+ n_8(ceiling(/ n_8 2))) #f)))" +"(begin" +"(vector-copy! work-vec_2 0 vec_4 start_1 end_1)" +"(generic-sort/key_0 work-vec_2 less-than?_6 n_8 getkey_2)" +"(vector-copy! dst-vec_1 dst-start_1 work-vec_2 0 n_8))))))))" +" dst-vec_1))))" +"(vector-sort vec_4 less-than?_6 start_1 end_1))))" +"(case-lambda" +"((vec_5 less-than?_7 start_2 end_2)" +"(let-values(((n_9)(- end_2 start_2)))" +"(let-values(((dst-vec_2) vec_5))" +"(let-values(((dst-start_2) start_2))" +"(begin" +"(if(unsafe-fx= n_9 0)" +"(let-values()(void))" +"(if((letrec-values(((loop_29)" +"(lambda(prev-val_2 next-index_2)" +"(begin" +" 'loop" +"(let-values(((or-part_18)(unsafe-fx= next-index_2 end_2)))" +"(if or-part_18" +" or-part_18" +"(let-values(((next-val_2)(unsafe-vector-ref vec_5 next-index_2)))" +"(if(not(less-than?_7 next-val_2 prev-val_2))" +"(loop_29 next-val_2(unsafe-fx+ next-index_2 1))" +" #f))))))))" +" loop_29)" +"(unsafe-vector-ref vec_5 start_2)" +"(unsafe-fx+ start_2 1))" +"(let-values()(void))" +"(if(unsafe-fx<= n_9 3)" +"(let-values()" +"(begin" +"(void)" +"(if(unsafe-fx= n_9 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_9 2)" +"(let-values()" +"(let-values(((tmp_2)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_2" +"(unsafe-fx+ dst-start_2 0)" +"(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 1)))" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) tmp_2))))" +"(let-values()" +"(let-values(((a_6)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 0)))" +"((b_5)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 1)))" +"((c_4)(unsafe-vector-ref dst-vec_2(unsafe-fx+ dst-start_2 2))))" +"(if(less-than?_7 b_5 a_6)" +"(let-values()" +"(if(less-than?_7 c_4 b_5)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) a_6)))" +"(if(less-than?_7 c_4 a_6)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) b_5)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) a_6)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) b_5)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) a_6))))))" +"(if(less-than?_7 c_4 a_6)" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 0) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) a_6)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) b_5)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 1) c_4)" +"(unsafe-vector-set! dst-vec_2(unsafe-fx+ dst-start_2 2) b_5)))))))))))" +"(let-values()" +"(let-values(((work-vec_3)(make-vector(+ n_9(ceiling(/ n_9 2))) #f)))" +"(begin" +"(vector-copy! work-vec_3 0 vec_5 start_2 end_2)" +"(generic-sort_0 work-vec_3 less-than?_7 n_9)" +"(vector-copy! dst-vec_2 dst-start_2 work-vec_3 0 n_9)))))))" +"(void))))))" +"((vec_6 less-than?_8 start_3 end_3 getkey_3 cache-keys?_2)" +"(if(if getkey_3(not(eq? values getkey_3)) #f)" +"(let-values(((n_10)(- end_3 start_3)))" +"(let-values(((dst-vec_3) vec_6))" +"(let-values(((dst-start_3) start_3))" +"(begin" +"(if(unsafe-fx= n_10 0)" +"(let-values()(void))" +"(if cache-keys?_2" +"(let-values()" +"(let-values(((work-vec_4)(make-vector(+ n_10(ceiling(/ n_10 2))) #t)))" +"(begin" +"((letrec-values(((loop_30)" +"(lambda(i_17)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_17 n_10)" +"(let-values()" +"(begin" +"(let-values(((x_8)" +"(unsafe-vector-ref" +" vec_6" +"(unsafe-fx+ i_17 start_3))))" +"(unsafe-vector-set!" +" work-vec_4" +" i_17" +"(cons(getkey_3 x_8) x_8)))" +"(loop_30(unsafe-fx+ i_17 1))))" +"(void))))))" +" loop_30)" +" 0)" +"(generic-sort/key_0 work-vec_4 less-than?_8 n_10 unsafe-car)" +"((letrec-values(((loop_31)" +"(lambda(i_18)" +"(begin" +" 'loop" +"(if(unsafe-fx< i_18 n_10)" +"(let-values()" +"(begin" +"(unsafe-vector-set!" +" dst-vec_3" +"(unsafe-fx+ i_18 dst-start_3)" +"(unsafe-cdr(unsafe-vector-ref work-vec_4 i_18)))" +"(loop_31(unsafe-fx+ i_18 1))))" +"(void))))))" +" loop_31)" +" 0))))" +"(if((letrec-values(((loop_32)" +"(lambda(prev-val_3 next-index_3)" +"(begin" +" 'loop" +"(let-values(((or-part_19)(unsafe-fx= next-index_3 end_3)))" +"(if or-part_19" +" or-part_19" +"(let-values(((next-val_3)" +"(unsafe-vector-ref vec_6 next-index_3)))" +"(if(not" +"(if getkey_3" +"(less-than?_8" +"(getkey_3 next-val_3)" +"(getkey_3 prev-val_3))" +"(less-than?_8 next-val_3 prev-val_3)))" +"(loop_32 next-val_3(unsafe-fx+ next-index_3 1))" +" #f))))))))" +" loop_32)" +"(unsafe-vector-ref vec_6 start_3)" +"(unsafe-fx+ start_3 1))" +"(let-values()(void))" +"(if(unsafe-fx<= n_10 3)" +"(let-values()" +"(begin" +"(void)" +"(if(unsafe-fx= n_10 1)" +"(let-values()(void))" +"(if(unsafe-fx= n_10 2)" +"(let-values()" +"(let-values(((tmp_3)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 0))))" +"(begin" +"(unsafe-vector-set!" +" dst-vec_3" +"(unsafe-fx+ dst-start_3 0)" +"(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 1)))" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) tmp_3))))" +"(let-values()" +"(let-values(((a_7)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 0)))" +"((b_6)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 1)))" +"((c_5)(unsafe-vector-ref dst-vec_3(unsafe-fx+ dst-start_3 2))))" +"(if(if getkey_3" +"(less-than?_8(getkey_3 b_6)(getkey_3 a_7))" +"(less-than?_8 b_6 a_7))" +"(let-values()" +"(if(if getkey_3" +"(less-than?_8(getkey_3 c_5)(getkey_3 b_6))" +"(less-than?_8 c_5 b_6))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) a_7)))" +"(if(if getkey_3" +"(less-than?_8(getkey_3 c_5)(getkey_3 a_7))" +"(less-than?_8 c_5 a_7))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) b_6)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) a_7)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) b_6)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) a_7))))))" +"(if(if getkey_3" +"(less-than?_8(getkey_3 c_5)(getkey_3 a_7))" +"(less-than?_8 c_5 a_7))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 0) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) a_7)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) b_6)))" +"(let-values()" +"(begin" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 1) c_5)" +"(unsafe-vector-set! dst-vec_3(unsafe-fx+ dst-start_3 2) b_6)))))))))))" +"(let-values()" +"(let-values(((work-vec_5)(make-vector(+ n_10(ceiling(/ n_10 2))) #f)))" +"(begin" +"(vector-copy! work-vec_5 0 vec_6 start_3 end_3)" +"(generic-sort/key_0 work-vec_5 less-than?_8 n_10 getkey_3)" +"(vector-copy! dst-vec_3 dst-start_3 work-vec_5 0 n_10))))))))" +"(void)))))" +"(vector-sort! vec_6 less-than?_8 start_3 end_3)))))))))" +"(define-values" +"(prop:stream stream-via-prop? stream-ref)" +"(make-struct-type-property" +" 'stream" +"(lambda(v_9 si_0)" +"(begin" +"(if(if(vector? v_9)" +"(if(= 3(vector-length v_9))" +"(if(procedure?(vector-ref v_9 0))" +"(if(procedure-arity-includes?(vector-ref v_9 0) 1)" +"(if(procedure?(vector-ref v_9 1))" +"(if(procedure-arity-includes?(vector-ref v_9 1) 1)" +"(if(procedure?(vector-ref v_9 2))(procedure-arity-includes?(vector-ref v_9 2) 1) #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:stream" +"(string-append" +" \"(vector/c (procedure-arity-includes/c 1)\\n\"" +" \" (procedure-arity-includes/c 1)\\n\"" +" \" (procedure-arity-includes/c 1))\")" +" v_9)))" +"(vector->immutable-vector v_9)))))" +"(define-values" +"(prop:gen-sequence sequence-via-prop? sequence-ref)" +"(make-struct-type-property" +" 'sequence" +"(lambda(v_10 si_1)" +"(begin" +"(if(if(procedure? v_10)(procedure-arity-includes? v_10 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'guard-for-prop:sequence \"(procedure-arity-includes/c 1)\" v_10)))" +" v_10))))" +"(define-values" +"(struct:range make-range range? range-ref range-set!)" +"(make-struct-type" +" 'stream" +" #f" +" 3" +" 0" +" #f" +"(list" "(cons" -"(let((p(open-input-file path)))" -"(dynamic-wind" +" prop:stream" +"(vector" +"(lambda(v_11)(let-values(((cont?_0)(range-ref v_11 2)))(if cont?_0(not(cont?_0(range-ref v_11 0))) #f)))" +"(lambda(v_12)(range-ref v_12 0))" +"(lambda(v_13)(make-range((range-ref v_13 1)(range-ref v_13 0))(range-ref v_13 1)(range-ref v_13 2)))))" +"(cons" +" prop:gen-sequence" +"(lambda(v_14)(values values #f(range-ref v_14 1)(range-ref v_14 0)(range-ref v_14 2) #f #f))))))" +"(define-values" +"(check-range)" +"(lambda(a_8 b_7 step_0)" +"(begin" +"(begin" +" (if (real? a_8) (void) (let-values () (raise-argument-error 'in-range \"real?\" a_8)))" +" (if (real? b_7) (void) (let-values () (raise-argument-error 'in-range \"real?\" b_7)))" +" (if (real? step_0) (void) (let-values () (raise-argument-error 'in-range \"real?\" step_0)))))))" +"(define-values" +"(check-naturals)" +"(lambda(n_11)" +"(begin" +"(if(if(integer? n_11)(if(exact? n_11)(>= n_11 0) #f) #f)" +"(void)" +" (let-values () (raise-argument-error 'in-naturals \"exact-nonnegative-integer?\" n_11))))))" +"(define-values" +"(struct:list-stream make-list-stream list-stream? list-stream-ref list-stream-set!)" +"(make-struct-type" +" 'stream" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:stream" +"(vector" +"(lambda(v_15)(not(pair?(list-stream-ref v_15 0))))" +"(lambda(v_16)(car(list-stream-ref v_16 0)))" +"(lambda(v_17)(make-list-stream(cdr(list-stream-ref v_17 0))))))" +"(cons prop:gen-sequence(lambda(v_18)(values car cdr values(list-stream-ref v_18 0) pair? #f #f))))))" +"(define-values" +"(check-list)" +" (lambda (l_5) (begin (if (list? l_5) (void) (let-values () (raise-argument-error 'in-list \"list?\" l_5))))))" +"(define-values" +"(check-in-hash)" +"(lambda(ht_7)" +"(begin" +" (if ((lambda (ht_8) (hash? ht_8)) ht_7) (void) (let-values () (raise-argument-error 'in-hash \"hash?\" ht_7))))))" +"(define-values" +"(check-in-immutable-hash)" +"(lambda(ht_9)" +"(begin" +"(if((lambda(ht_10)(if(hash? ht_10)(immutable? ht_10) #f)) ht_9)" +"(void)" +" (let-values () (raise-argument-error 'in-immutable-hash \"(and/c hash? immutable?)\" ht_9))))))" +"(define-values" +"(check-in-hash-keys)" +"(lambda(ht_11)" +"(begin" +"(if((lambda(ht_12)(hash? ht_12)) ht_11)" +"(void)" +" (let-values () (raise-argument-error 'in-hash-keys \"hash?\" ht_11))))))" +"(define-values" +"(check-in-immutable-hash-keys)" +"(lambda(ht_13)" +"(begin" +"(if((lambda(ht_14)(if(hash? ht_14)(immutable? ht_14) #f)) ht_13)" +"(void)" +" (let-values () (raise-argument-error 'in-immutable-hash-keys \"(and/c hash? immutable?)\" ht_13))))))" +"(define-values" +"(check-in-hash-values)" +"(lambda(ht_15)" +"(begin" +"(if((lambda(ht_16)(hash? ht_16)) ht_15)" +"(void)" +" (let-values () (raise-argument-error 'in-hash-values \"hash?\" ht_15))))))" +"(define-values" +"(check-ranges)" +"(lambda(who_3 vec_7 start_4 stop_0 step_1 len_0)" +"(begin" +"(begin" +"(if(if(exact-nonnegative-integer? start_4)" +"(let-values(((or-part_20)(< start_4 len_0)))(if or-part_20 or-part_20(= len_0 start_4 stop_0)))" +" #f)" +"(void)" +" (let-values () (raise-range-error who_3 \"vector\" \"starting \" start_4 vec_7 0 (sub1 len_0))))" +"(if(if(exact-integer? stop_0)(if(<= -1 stop_0)(<= stop_0 len_0) #f) #f)" +"(void)" +" (let-values () (raise-range-error who_3 \"vector\" \"stopping \" stop_0 vec_7 -1 len_0)))" +"(if(if(exact-integer? step_1)(not(zero? step_1)) #f)" +"(void)" +" (let-values () (raise-argument-error who_3 \"(and/c exact-integer? (not/c zero?))\" step_1)))" +"(if(if(< start_4 stop_0)(< step_1 0) #f)" +"(let-values()" +"(raise-arguments-error" +" who_3" +" \"starting index less than stopping index, but given a negative step\"" +" \"starting index\"" +" start_4" +" \"stopping index\"" +" stop_0" +" \"step\"" +" step_1))" +"(void))" +"(if(if(< stop_0 start_4)(> step_1 0) #f)" +"(let-values()" +"(raise-arguments-error" +" who_3" +" \"starting index more than stopping index, but given a positive step\"" +" \"starting index\"" +" start_4" +" \"stopping index\"" +" stop_0" +" \"step\"" +" step_1))" +"(void))))))" +"(define-values" +"(normalise-inputs)" +"(lambda(who_4 type-name_0 vector?_0 unsafe-vector-length_0 vec_8 start_5 stop_1 step_2)" +"(begin" +"(begin" +"(if(vector?_0 vec_8)(void)(let-values()(raise-argument-error who_4 type-name_0 vec_8)))" +"(let-values(((len_1)(unsafe-vector-length_0 vec_8)))" +"(let-values(((stop*_0)(if stop_1 stop_1 len_1)))" +"(begin(check-ranges who_4 vec_8 start_5 stop*_0 step_2 len_1)(values vec_8 start_5 stop*_0 step_2))))))))" +"(define-values" +"(check-vector)" +" (lambda (v_19) (begin (if (vector? v_19) (void) (let-values () (raise-argument-error 'in-vector \"vector\" v_19))))))" +"(define-values" +"(check-string)" +" (lambda (v_20) (begin (if (string? v_20) (void) (let-values () (raise-argument-error 'in-string \"string\" v_20))))))" +"(define-values" +"(check-bytes)" +" (lambda (v_21) (begin (if (bytes? v_21) (void) (let-values () (raise-argument-error 'in-bytes \"bytes\" v_21))))))" +"(define-values" +"(struct:do-stream make-do-stream do-stream? do-stream-ref do-stream-set!)" +"(make-struct-type" +" 'stream" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons" +" prop:stream" +"(vector" +"(lambda(v_22)((do-stream-ref v_22 0)))" +"(lambda(v_23)((do-stream-ref v_23 1)))" +"(lambda(v_24)((do-stream-ref v_24 2))))))))" +"(define-values(empty-stream)(make-do-stream(lambda() #t) void void))" +"(define-values" +"(grow-vector)" +"(lambda(vec_9)" +"(begin" +"(let-values(((n_12)(vector-length vec_9)))" +"(let-values(((new-vec_0)(make-vector(* 2 n_12))))" +"(begin(vector-copy! new-vec_0 0 vec_9 0 n_12) new-vec_0))))))" +"(define-values" +"(shrink-vector)" +"(lambda(vec_10 i_19)" +"(begin(let-values(((new-vec_1)(make-vector i_19)))(begin(vector-copy! new-vec_1 0 vec_10 0 i_19) new-vec_1)))))" +"(define-values" +"(map2)" +"(let-values(((map_0)" +"(case-lambda" +"((f_0 l_6)" +"(begin" +" 'map" +"(if(if(procedure? f_0)(if(procedure-arity-includes? f_0 1)(list? l_6) #f) #f)" +"((letrec-values(((loop_33)" +"(lambda(l_2)" +"(begin" +" 'loop" +"(if(null? l_2)" +"(let-values() null)" +"(let-values()" +"(let-values(((r_4)(cdr l_2)))" +"(cons(f_0(car l_2))(loop_33 r_4)))))))))" +" loop_33)" +" l_6)" +"(gen-map f_0(list l_6)))))" +"((f_1 l1_0 l2_0)" +"(if(if(procedure? f_1)" +"(if(procedure-arity-includes? f_1 2)" +"(if(list? l1_0)(if(list? l2_0)(=(length l1_0)(length l2_0)) #f) #f)" +" #f)" +" #f)" +"((letrec-values(((loop_34)" +"(lambda(l1_1 l2_1)" +"(begin" +" 'loop" +"(if(null? l1_1)" +"(let-values() null)" +"(let-values()" +"(let-values(((r1_0)(cdr l1_1))((r2_0)(cdr l2_1)))" +"(cons(f_1(car l1_1)(car l2_1))(loop_34 r1_0 r2_0)))))))))" +" loop_34)" +" l1_0" +" l2_0)" +"(gen-map f_1(list l1_0 l2_0))))" +"((f_2 l_7 . args_0)(gen-map f_2(cons l_7 args_0))))))" +" map_0))" +"(define-values" +"(for-each2)" +"(let-values(((for-each_0)" +"(case-lambda" +"((f_3 l_8)" +"(begin" +" 'for-each" +"(if(if(procedure? f_3)(if(procedure-arity-includes? f_3 1)(list? l_8) #f) #f)" +"((letrec-values(((loop_35)" +"(lambda(l_9)" +"(begin" +" 'loop" +"(if(null? l_9)" +"(let-values()(void))" +"(let-values()" +"(let-values(((r_5)(cdr l_9)))" +"(begin(f_3(car l_9))(loop_35 r_5)))))))))" +" loop_35)" +" l_8)" +"(gen-for-each f_3(list l_8)))))" +"((f_4 l1_2 l2_2)" +"(if(if(procedure? f_4)" +"(if(procedure-arity-includes? f_4 2)" +"(if(list? l1_2)(if(list? l2_2)(=(length l1_2)(length l2_2)) #f) #f)" +" #f)" +" #f)" +"((letrec-values(((loop_36)" +"(lambda(l1_3 l2_3)" +"(begin" +" 'loop" +"(if(null? l1_3)" +"(let-values()(void))" +"(let-values()" +"(let-values(((r1_1)(cdr l1_3))((r2_1)(cdr l2_3)))" +"(begin(f_4(car l1_3)(car l2_3))(loop_36 r1_1 r2_1)))))))))" +" loop_36)" +" l1_2" +" l2_2)" +"(gen-for-each f_4(list l1_2 l2_2))))" +"((f_5 l_10 . args_1)(gen-for-each f_5(cons l_10 args_1))))))" +" for-each_0))" +"(define-values" +"(andmap2)" +"(let-values(((andmap_0)" +"(case-lambda" +"((f_6 l_11)" +"(begin" +" 'andmap" +"(if(if(procedure? f_6)(if(procedure-arity-includes? f_6 1)(list? l_11) #f) #f)" +"(if(null? l_11)" +" #t" +"((letrec-values(((loop_37)" +"(lambda(l_12)" +"(begin" +" 'loop" +"(if(null?(cdr l_12))" +"(let-values()(f_6(car l_12)))" +"(let-values()" +"(let-values(((r_6)(cdr l_12)))" +"(if(f_6(car l_12))(loop_37 r_6) #f))))))))" +" loop_37)" +" l_11))" +"(gen-andmap f_6(list l_11)))))" +"((f_7 l1_4 l2_4)" +"(if(if(procedure? f_7)" +"(if(procedure-arity-includes? f_7 2)" +"(if(list? l1_4)(if(list? l2_4)(=(length l1_4)(length l2_4)) #f) #f)" +" #f)" +" #f)" +"(if(null? l1_4)" +" #t" +"((letrec-values(((loop_38)" +"(lambda(l1_5 l2_5)" +"(begin" +" 'loop" +"(if(null?(cdr l1_5))" +"(let-values()(f_7(car l1_5)(car l2_5)))" +"(let-values()" +"(let-values(((r1_2)(cdr l1_5))((r2_2)(cdr l2_5)))" +"(if(f_7(car l1_5)(car l2_5))(loop_38 r1_2 r2_2) #f))))))))" +" loop_38)" +" l1_4" +" l2_4))" +"(gen-andmap f_7(list l1_4 l2_4))))" +"((f_8 l_13 . args_2)(gen-andmap f_8(cons l_13 args_2))))))" +" andmap_0))" +"(define-values" +"(ormap2)" +"(let-values(((ormap_0)" +"(case-lambda" +"((f_9 l_14)" +"(begin" +" 'ormap" +"(if(if(procedure? f_9)(if(procedure-arity-includes? f_9 1)(list? l_14) #f) #f)" +"(if(null? l_14)" +" #f" +"((letrec-values(((loop_39)" +"(lambda(l_15)" +"(begin" +" 'loop" +"(if(null?(cdr l_15))" +"(let-values()(f_9(car l_15)))" +"(let-values()" +"(let-values(((r_7)(cdr l_15)))" +"(let-values(((or-part_21)(f_9(car l_15))))" +"(if or-part_21 or-part_21(loop_39 r_7))))))))))" +" loop_39)" +" l_14))" +"(gen-ormap f_9(list l_14)))))" +"((f_10 l1_6 l2_6)" +"(if(if(procedure? f_10)" +"(if(procedure-arity-includes? f_10 2)" +"(if(list? l1_6)(if(list? l2_6)(=(length l1_6)(length l2_6)) #f) #f)" +" #f)" +" #f)" +"(if(null? l1_6)" +" #f" +"((letrec-values(((loop_40)" +"(lambda(l1_7 l2_7)" +"(begin" +" 'loop" +"(if(null?(cdr l1_7))" +"(let-values()(f_10(car l1_7)(car l2_7)))" +"(let-values()" +"(let-values(((r1_3)(cdr l1_7))((r2_3)(cdr l2_7)))" +"(let-values(((or-part_22)(f_10(car l1_7)(car l2_7))))" +"(if or-part_22 or-part_22(loop_40 r1_3 r2_3))))))))))" +" loop_40)" +" l1_6" +" l2_6))" +"(gen-ormap f_10(list l1_6 l2_6))))" +"((f_11 l_16 . args_3)(gen-ormap f_11(cons l_16 args_3))))))" +" ormap_0))" +"(define-values" +"(check-args)" +"(lambda(who_5 f_12 ls_4)" +"(begin" +"(begin" +" (if (procedure? f_12) (void) (let-values () (raise-argument-error who_5 \"procedure?\" f_12)))" +"((letrec-values(((loop_41)" +"(lambda(prev-len_0 ls_5 i_20)" +"(begin" +" 'loop" +"(if(null? ls_5)" +"(void)" +"(let-values()" +"(let-values(((l_17)(car ls_5)))" +"(begin" +" (if (list? l_17) (void) (let-values () (raise-argument-error who_5 \"list?\" l_17)))" +"(let-values(((len_2)(length l_17)))" +"(begin" +"(if(if prev-len_0(not(= len_2 prev-len_0)) #f)" +"(let-values()" +"(raise-arguments-error" +" who_5" +" \"all lists must have same size\"" +" \"first list length\"" +" prev-len_0" +" \"other list length\"" +" len_2" +" \"procedure\"" +" f_12))" +"(void))" +"(loop_41 len_2(cdr ls_5)(add1 i_20))))))))))))" +" loop_41)" +" #f" +" ls_4" +" 1)" +"(if(procedure-arity-includes? f_12(length ls_4))" +"(void)" +"(let-values()" +"(apply" +" raise-arguments-error" +" who_5" +"(string-append" +" \"argument mismatch;\\n\"" +" \" the given procedure's expected number of arguments does not match\"" +" \" the given number of lists\")" +" \"given procedure\"" +"(unquoted-printing-string" +"(let-values(((or-part_23)" +"(let-values(((n_13)(object-name f_12)))(if(symbol? n_13)(symbol->string n_13) #f))))" +" (if or-part_23 or-part_23 \"#\")))" +"(append" +"(let-values(((a_9)(procedure-arity f_12)))" +"(if(integer? a_9)" +" (let-values () (list \"expected\" a_9))" +"(if(arity-at-least? a_9)" +"(let-values()" +"(list" +" \"expected\"" +"(unquoted-printing-string" +" (string-append \"at least \" (number->string (arity-at-least-value a_9))))))" +"(let-values() null))))" +" (list \"given\" (length ls_4))" +"(let-values(((w_0)(quotient(error-print-width)(length ls_4))))" +"(if(> w_0 10)" +"(list" +" \"argument lists...\"" +"(unquoted-printing-string" +"(apply" +" string-append" +"((letrec-values(((loop_42)" +"(lambda(ls_6)" +"(begin" +" 'loop" +"(if(null? ls_6)" +"(let-values() null)" +"(let-values()" +"(cons" +" (string-append \"\\n \" ((error-value->string-handler) (car ls_6) w_0))" +"(loop_42(cdr ls_6)))))))))" +" loop_42)" +" ls_4))))" +" null))))))))))" +"(define-values" +"(gen-map)" +"(lambda(f_13 ls_7)" +"(begin" +"(begin" +"(check-args 'map f_13 ls_7)" +"((letrec-values(((loop_43)" +"(lambda(ls_8)" +"(begin" +" 'loop" +"(if(null?(car ls_8))" +"(let-values() null)" +"(let-values()" +"(let-values(((next-ls_0)(map2 cdr ls_8)))" +"(cons(apply f_13(map2 car ls_8))(loop_43 next-ls_0)))))))))" +" loop_43)" +" ls_7)))))" +"(define-values" +"(gen-for-each)" +"(lambda(f_14 ls_9)" +"(begin" +"(begin" +"(check-args 'for-each f_14 ls_9)" +"((letrec-values(((loop_44)" +"(lambda(ls_10)" +"(begin" +" 'loop" +"(if(null?(car ls_10))" +"(void)" +"(let-values()" +"(let-values(((next-ls_1)(map2 cdr ls_10)))" +"(begin(apply f_14(map2 car ls_10))(loop_44 next-ls_1)))))))))" +" loop_44)" +" ls_9)))))" +"(define-values" +"(gen-andmap)" +"(lambda(f_15 ls_11)" +"(begin" +"(begin" +"(check-args 'andmap f_15 ls_11)" +"((letrec-values(((loop_45)" +"(lambda(ls_12)" +"(begin" +" 'loop" +"(if(null?(car ls_12))" +"(let-values() #t)" +"(if(null?(cdar ls_12))" +"(let-values()(apply f_15(map2 car ls_12)))" +"(let-values()" +"(let-values(((next-ls_2)(map2 cdr ls_12)))" +"(if(apply f_15(map2 car ls_12))(loop_45 next-ls_2) #f)))))))))" +" loop_45)" +" ls_11)))))" +"(define-values" +"(gen-ormap)" +"(lambda(f_16 ls_13)" +"(begin" +"(begin" +"(check-args 'ormap f_16 ls_13)" +"((letrec-values(((loop_46)" +"(lambda(ls_14)" +"(begin" +" 'loop" +"(if(null?(car ls_14))" +"(let-values() #f)" +"(if(null?(cdar ls_14))" +"(let-values()(apply f_16(map2 car ls_14)))" +"(let-values()" +"(let-values(((next-ls_3)(map2 cdr ls_14)))" +"(let-values(((or-part_24)(apply f_16(map2 car ls_14))))" +"(if or-part_24 or-part_24(loop_46 next-ls_3)))))))))))" +" loop_46)" +" ls_13)))))" +"(define-values" +"(hash-keys)" +"(lambda(h_0)" +"(begin" +"((letrec-values(((loop_8)" +"(lambda(pos_0)" +"(begin" +" 'loop" +"(if pos_0" +"(cons(hash-iterate-key h_0 pos_0)(loop_8(hash-iterate-next h_0 pos_0)))" +" null)))))" +" loop_8)" +"(hash-iterate-first h_0)))))" +"(define-values" +"(sort7.1)" +"(lambda(cache-keys?2_0 cache-keys?4_0 key1_0 key3_0 lst5_0 less?6_0)" +"(begin" +" 'sort7" +"(let-values(((lst_6) lst5_0))" +"(let-values(((less?_0) less?6_0))" +"(let-values(((getkey_4)(if key3_0 key1_0 #f)))" +"(let-values(((cache-keys?_3)(if cache-keys?4_0 cache-keys?2_0 #f)))" +"(let-values()" +"(begin" +" (if (list? lst_6) (void) (let-values () (raise-argument-error 'sort \"list?\" lst_6)))" +"(if(if(procedure? less?_0)(procedure-arity-includes? less?_0 2) #f)" +"(void)" +" (let-values () (raise-argument-error 'sort \"(any/c any/c . -> . any/c)\" less?_0)))" +"(if(if getkey_4(not(if(procedure? getkey_4)(procedure-arity-includes? getkey_4 1) #f)) #f)" +" (let-values () (raise-argument-error 'sort \"(any/c . -> . any/c)\" getkey_4))" +"(void))" +"(if getkey_4(sort lst_6 less?_0 getkey_4 cache-keys?_3)(sort lst_6 less?_0)))))))))))" +"(define-values" +"(bad-list)" +" (lambda (who_6 orig-l_7) (begin (raise-mismatch-error who_6 \"not a proper list: \" orig-l_7))))" +"(define-values" +"(bad-item)" +" (lambda (who_7 a_10 orig-l_8) (begin (raise-mismatch-error who_7 \"non-pair found in list: \" a_10 \" in \" orig-l_8))))" +"(define-values" +"(1/assq 1/assv 1/assoc assf)" +"(let-values()" +"(let-values()" +"(let-values(((assq_0)" +"(lambda(x_9 l_18)" +"(begin" +" 'assq" +"((letrec-values(((loop_46)" +"(lambda(l_19 t_0)" +"(begin" +" 'loop" +"(if(pair? l_19)" +"(let-values()" +"(let-values(((a_0)(unsafe-car l_19)))" +"(if(pair? a_0)" +"(if(eq? x_9(unsafe-car a_0))" +" a_0" +"(let-values(((l_20)(unsafe-cdr l_19)))" +"(if(pair? l_20)" +"(let-values()" +"(let-values(((a_11)(unsafe-car l_20)))" +"(if(pair? a_11)" +"(if(eq? x_9(unsafe-car a_11))" +" a_11" +"(let-values(((t_1)(unsafe-cdr t_0))" +"((l_21)(unsafe-cdr l_20)))" +"(if(eq? l_21 t_1)" +"(bad-list 'assq l_18)" +"(loop_46 l_21 t_1))))" +"(bad-item 'assq a_11 l_18))))" +"(if(null? l_20)" +"(let-values() #f)" +"(let-values()(bad-list 'assq l_18))))))" +"(bad-item 'assq a_0 l_18))))" +"(if(null? l_19)" +"(let-values() #f)" +"(let-values()(bad-list 'assq l_18))))))))" +" loop_46)" +" l_18" +" l_18))))" +"((assv_0)" +"(lambda(x_10 l_22)" +"(begin" +" 'assv" +"((letrec-values(((loop_47)" +"(lambda(l_23 t_2)" +"(begin" +" 'loop" +"(if(pair? l_23)" +"(let-values()" +"(let-values(((a_12)(unsafe-car l_23)))" +"(if(pair? a_12)" +"(if(eqv? x_10(unsafe-car a_12))" +" a_12" +"(let-values(((l_24)(unsafe-cdr l_23)))" +"(if(pair? l_24)" +"(let-values()" +"(let-values(((a_13)(unsafe-car l_24)))" +"(if(pair? a_13)" +"(if(eqv? x_10(unsafe-car a_13))" +" a_13" +"(let-values(((t_3)(unsafe-cdr t_2))" +"((l_25)(unsafe-cdr l_24)))" +"(if(eq? l_25 t_3)" +"(bad-list 'assv l_22)" +"(loop_47 l_25 t_3))))" +"(bad-item 'assv a_13 l_22))))" +"(if(null? l_24)" +"(let-values() #f)" +"(let-values()(bad-list 'assv l_22))))))" +"(bad-item 'assv a_12 l_22))))" +"(if(null? l_23)" +"(let-values() #f)" +"(let-values()(bad-list 'assv l_22))))))))" +" loop_47)" +" l_22" +" l_22))))" +"((assoc_0)" +"(case-lambda" +"((x_11 l_26)" +"(begin" +" 'assoc" +"((letrec-values(((loop_48)" +"(lambda(l_27 t_4)" +"(begin" +" 'loop" +"(if(pair? l_27)" +"(let-values()" +"(let-values(((a_14)(unsafe-car l_27)))" +"(if(pair? a_14)" +"(if(equal? x_11(unsafe-car a_14))" +" a_14" +"(let-values(((l_28)(unsafe-cdr l_27)))" +"(if(pair? l_28)" +"(let-values()" +"(let-values(((a_15)(unsafe-car l_28)))" +"(if(pair? a_15)" +"(if(equal? x_11(unsafe-car a_15))" +" a_15" +"(let-values(((t_5)(unsafe-cdr t_4))" +"((l_29)(unsafe-cdr l_28)))" +"(if(eq? l_29 t_5)" +"(bad-list 'assoc l_26)" +"(loop_48 l_29 t_5))))" +"(bad-item 'assoc a_15 l_26))))" +"(if(null? l_28)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_26))))))" +"(bad-item 'assoc a_14 l_26))))" +"(if(null? l_27)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_26))))))))" +" loop_48)" +" l_26" +" l_26)))" +"((x_12 l_30 is-equal?_0)" +"(begin" +"(if(if(procedure? is-equal?_0)(procedure-arity-includes? is-equal?_0 2) #f)" +"(void)" +" (let-values () (raise-argument-error 'assoc \"(any/c any/c . -> . any/c)\" is-equal?_0)))" +"((letrec-values(((loop_49)" +"(lambda(l_31 t_6)" +"(begin" +" 'loop" +"(if(pair? l_31)" +"(let-values()" +"(let-values(((a_16)(unsafe-car l_31)))" +"(if(pair? a_16)" +"(if(is-equal?_0 x_12(unsafe-car a_16))" +" a_16" +"(let-values(((l_32)(unsafe-cdr l_31)))" +"(if(pair? l_32)" +"(let-values()" +"(let-values(((a_17)(unsafe-car l_32)))" +"(if(pair? a_17)" +"(if(is-equal?_0 x_12(unsafe-car a_17))" +" a_17" +"(let-values(((t_7)(unsafe-cdr t_6))" +"((l_33)(unsafe-cdr l_32)))" +"(if(eq? l_33 t_7)" +"(bad-list 'assoc l_30)" +"(loop_49 l_33 t_7))))" +"(bad-item 'assoc a_17 l_30))))" +"(if(null? l_32)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_30))))))" +"(bad-item 'assoc a_16 l_30))))" +"(if(null? l_31)" +"(let-values() #f)" +"(let-values()(bad-list 'assoc l_30))))))))" +" loop_49)" +" l_30" +" l_30)))))" +"((assf_0)" +"(lambda(f_17 l_34)" +"(begin" +" 'assf" +"(begin" +"(if(if(procedure? f_17)(procedure-arity-includes? f_17 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'assf \"(any/c any/c . -> . any/c)\" f_17)))" +"((letrec-values(((loop_50)" +"(lambda(l_35 t_8)" +"(begin" +" 'loop" +"(if(pair? l_35)" +"(let-values()" +"(let-values(((a_18)(unsafe-car l_35)))" +"(if(pair? a_18)" +"(if((lambda(__0 a_19)(f_17 a_19)) #f(unsafe-car a_18))" +" a_18" +"(let-values(((l_36)(unsafe-cdr l_35)))" +"(if(pair? l_36)" +"(let-values()" +"(let-values(((a_20)(unsafe-car l_36)))" +"(if(pair? a_20)" +"(if((lambda(__1 a_21)(f_17 a_21))" +" #f" +"(unsafe-car a_20))" +" a_20" +"(let-values(((t_9)(unsafe-cdr t_8))" +"((l_37)(unsafe-cdr l_36)))" +"(if(eq? l_37 t_9)" +"(bad-list 'assf l_34)" +"(loop_50 l_37 t_9))))" +"(bad-item 'assf a_20 l_34))))" +"(if(null? l_36)" +"(let-values() #f)" +"(let-values()(bad-list 'assf l_34))))))" +"(bad-item 'assf a_18 l_34))))" +"(if(null? l_35)" +"(let-values() #f)" +"(let-values()(bad-list 'assf l_34))))))))" +" loop_50)" +" l_34" +" l_34))))))" +"(values assq_0 assv_0 assoc_0 assf_0)))))" +"(define-values" +"(filter)" +"(lambda(f_18 list_0)" +"(begin" +"(begin" +"(if(if(procedure? f_18)(procedure-arity-includes? f_18 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'filter \"(any/c . -> . any/c)\" f_18)))" +" (if (list? list_0) (void) (let-values () (raise-argument-error 'filter \"list?\" list_0)))" +"((letrec-values(((loop_51)" +"(lambda(l_38 result_0)" +"(begin" +" 'loop" +"(if(null? l_38)" +"(reverse$1 result_0)" +"(loop_51(cdr l_38)(if(f_18(car l_38))(cons(car l_38) result_0) result_0)))))))" +" loop_51)" +" list_0" +" null)))))" +"(define-values(no-empty-edge-table)(make-hash))" +" (define-values (binary-or-text-desc) \"(or/c 'binary 'text)\")" +"(define-values" +"(open-input-file6.1)" +"(lambda(for-module?2_0 for-module?4_0 mode1_0 mode3_0 path5_0)" +"(begin" +" 'open-input-file6" +"(let-values(((path_0) path5_0))" +"(let-values(((mode_0)(if mode3_0 mode1_0 'binary)))" +"(let-values(((for-module?_0)(if for-module?4_0 for-module?2_0 #f)))" +"(let-values()" +"(begin" +"(if(path-string? path_0)" +"(void)" +" (let-values () (raise-argument-error 'open-input-file \"path-string?\" path_0)))" +"(if(memq mode_0 '(binary text))" +"(void)" +"(let-values()(raise-argument-error 'open-input-file binary-or-text-desc mode_0)))" +"(open-input-file path_0 mode_0(if for-module?_0 'module 'none))))))))))" +"(define-values" +"(with-input-from-file45.1)" +"(lambda(mode41_0 mode42_0 path43_0 proc44_0)" +"(begin" +" 'with-input-from-file45" +"(let-values(((path_1) path43_0))" +"(let-values(((proc_0) proc44_0))" +"(let-values(((mode_1)(if mode42_0 mode41_0 'binary)))" +"(let-values()" +"(begin" +"(if(path-string? path_1)" +"(void)" +" (let-values () (raise-argument-error 'with-input-from-file \"path-string?\" path_1)))" +"(if(if(procedure? proc_0)(procedure-arity-includes? proc_0 0) #f)" +"(void)" +" (let-values () (raise-argument-error 'with-input-from-file \"(-> any)\" proc_0)))" +"(if(memq mode_1 '(binary text))" +"(void)" +"(let-values()(raise-argument-error 'with-input-from-file binary-or-text-desc mode_1)))" +"(with-input-from-file path_1 proc_0 mode_1)))))))))" +"(define-values" +"(call-with-input-file*61.1)" +"(lambda(mode57_0 mode58_0 path59_0 proc60_0)" +"(begin" +" 'call-with-input-file*61" +"(let-values(((path_2) path59_0))" +"(let-values(((proc_1) proc60_0))" +"(let-values(((mode_2)(if mode58_0 mode57_0 'binary)))" +"(let-values()" +"(begin" +"(if(path-string? path_2)" +"(void)" +" (let-values () (raise-argument-error 'call-with-input-file* \"path-string?\" path_2)))" +"(if(if(procedure? proc_1)(procedure-arity-includes? proc_1 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'call-with-input-file* \"(input-port? . -> . any)\" proc_1)))" +"(if(memq mode_2 '(binary text))" +"(void)" +"(let-values()(raise-argument-error 'call-with-input-file* binary-or-text-desc mode_2)))" +"(let-values(((p_2)(open-input-file path_2 mode_2)))" +"(dynamic-wind void(lambda()(proc_1 p_2))(lambda()(close-input-port p_2))))))))))))" +"(define-values(the-empty-hash) '#hash())" +"(define-values(the-empty-hasheq) '#hasheq())" +"(define-values(the-empty-hasheqv) '#hasheqv())" +"(define-values" +"(set)" +"(case-lambda" +"(()(begin the-empty-hash))" +"(l_39" +"(let-values(((lst_7) l_39))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_7)))" +"((letrec-values(((for-loop_0)" +"(lambda(s_11 lst_8)" +"(begin" +" 'for-loop" +"(if(pair? lst_8)" +"(let-values(((e_2)(unsafe-car lst_8))((rest_0)(unsafe-cdr lst_8)))" +"(let-values(((s_12)" +"(let-values(((s_13) s_11))" +"(let-values(((s_14)(let-values()(hash-set s_13 e_2 #t))))" +"(values s_14)))))" +"(if(not #f)(for-loop_0 s_12 rest_0) s_12)))" +" s_11)))))" +" for-loop_0)" +" the-empty-hash" +" lst_7))))))" +"(define-values" +"(seteq)" +"(case-lambda" +"(()(begin the-empty-hasheq))" +"(l_40" +"(let-values(((lst_9) l_40))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_9)))" +"((letrec-values(((for-loop_1)" +"(lambda(s_15 lst_10)" +"(begin" +" 'for-loop" +"(if(pair? lst_10)" +"(let-values(((e_3)(unsafe-car lst_10))((rest_1)(unsafe-cdr lst_10)))" +"(let-values(((s_16)" +"(let-values(((s_17) s_15))" +"(let-values(((s_18)(let-values()(hash-set s_17 e_3 #t))))" +"(values s_18)))))" +"(if(not #f)(for-loop_1 s_16 rest_1) s_16)))" +" s_15)))))" +" for-loop_1)" +" the-empty-hasheq" +" lst_9))))))" +"(define-values(seteqv)(lambda()(begin the-empty-hasheqv)))" +"(define-values(set?)(lambda(s_19)(begin(hash? s_19))))" +"(define-values(set-empty?)(lambda(s_20)(begin(zero?(hash-count s_20)))))" +"(define-values(set-member?)(lambda(s_21 e_4)(begin(hash-ref s_21 e_4 #f))))" +"(define-values(set-count)(lambda(s_22)(begin(hash-count s_22))))" +"(define-values(set-add)(lambda(s_23 e_5)(begin(hash-set s_23 e_5 #t))))" +"(define-values(set-remove)(lambda(s_24 e_6)(begin(hash-remove s_24 e_6))))" +"(define-values(set-first)(lambda(s_25)(begin(hash-iterate-key s_25(hash-iterate-first s_25)))))" +"(define-values(subset?)(lambda(s1_0 s2_0)(begin(hash-keys-subset? s1_0 s2_0))))" +"(define-values" +"(set=?)" +"(lambda(s1_1 s2_1)" +"(begin" +"(let-values(((or-part_25)(eq? s1_1 s2_1)))" +"(if or-part_25 or-part_25(if(=(hash-count s1_1)(hash-count s2_1))(hash-keys-subset? s1_1 s2_1) #f))))))" +"(define-values" +"(set-subtract)" +"(lambda(s1_2 s2_2)" +"(begin" +"(let-values(((ht_17) s2_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_17)))" +"((letrec-values(((for-loop_2)" +"(lambda(s1_3 i_21)" +"(begin" +" 'for-loop" +"(if i_21" +"(let-values(((k_0)(unsafe-immutable-hash-iterate-key ht_17 i_21)))" +"(let-values(((s1_4)" +"(let-values(((s1_5) s1_3))" +"(let-values(((s1_6)(let-values()(hash-remove s1_5 k_0))))" +"(values s1_6)))))" +"(if(not #f)" +"(for-loop_2 s1_4(unsafe-immutable-hash-iterate-next ht_17 i_21))" +" s1_4)))" +" s1_3)))))" +" for-loop_2)" +" s1_2" +"(unsafe-immutable-hash-iterate-first ht_17)))))))" +"(define-values" +"(set-union)" +"(lambda(s1_7 s2_3)" +"(begin" +"(if(<(set-count s1_7)(set-count s2_3))" +"(set-union s2_3 s1_7)" +"(let-values(((ht_18) s2_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_18)))" +"((letrec-values(((for-loop_3)" +"(lambda(s1_8 i_22)" +"(begin" +" 'for-loop" +"(if i_22" +"(let-values(((k_1)(unsafe-immutable-hash-iterate-key ht_18 i_22)))" +"(let-values(((s1_9)" +"(let-values(((s1_10) s1_8))" +"(let-values(((s1_11)(let-values()(hash-set s1_10 k_1 #t))))" +"(values s1_11)))))" +"(if(not #f)" +"(for-loop_3 s1_9(unsafe-immutable-hash-iterate-next ht_18 i_22))" +" s1_9)))" +" s1_8)))))" +" for-loop_3)" +" s1_7" +"(unsafe-immutable-hash-iterate-first ht_18))))))))" +"(define-values" +"(set-intersect)" +"(lambda(s1_12 s2_4)" +"(begin" +"(if(<(set-count s1_12)(set-count s2_4))" +"(set-intersect s2_4 s1_12)" +"(let-values(((ht_19) s2_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_19)))" +"((letrec-values(((for-loop_4)" +"(lambda(s_26 i_23)" +"(begin" +" 'for-loop" +"(if i_23" +"(let-values(((k_2)(unsafe-immutable-hash-iterate-key ht_19 i_23)))" +"(let-values(((s_27)" +"(let-values(((s_28) s_26))" +"(let-values(((s_29)" +"(let-values()" +"(if(hash-ref s1_12 k_2 #f)" +" s_28" +"(hash-remove s_28 k_2)))))" +"(values s_29)))))" +"(if(not #f)" +"(for-loop_4 s_27(unsafe-immutable-hash-iterate-next ht_19 i_23))" +" s_27)))" +" s_26)))))" +" for-loop_4)" +" s2_4" +"(unsafe-immutable-hash-iterate-first ht_19))))))))" +"(define-values" +"(set-partition)" +"(lambda(s_30 pred_0 empty-y-set_0 empty-n-set_0)" +"(begin" +"(let-values(((ht_20) s_30))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_20)))" +"((letrec-values(((for-loop_5)" +"(lambda(y_6 n_14 i_24)" +"(begin" +" 'for-loop" +"(if i_24" +"(let-values(((v_25)(unsafe-immutable-hash-iterate-key ht_20 i_24)))" +"(let-values(((y_7 n_15)" +"(let-values(((y_8) y_6)((n_16) n_14))" +"(let-values(((y_9 n_17)" +"(let-values()" +"(if(pred_0 v_25)" +"(values(set-add y_8 v_25) n_16)" +"(values y_8(set-add n_16 v_25))))))" +"(values y_9 n_17)))))" +"(if(not #f)" +"(for-loop_5 y_7 n_15(unsafe-immutable-hash-iterate-next ht_20 i_24))" +"(values y_7 n_15))))" +"(values y_6 n_14))))))" +" for-loop_5)" +" empty-y-set_0" +" empty-n-set_0" +"(unsafe-immutable-hash-iterate-first ht_20)))))))" +"(define-values" +"(set->list)" +"(lambda(s_31)" +"(begin" +"(reverse$1" +"(let-values(((ht_21) s_31))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_21)))" +"((letrec-values(((for-loop_6)" +"(lambda(fold-var_0 i_25)" +"(begin" +" 'for-loop" +"(if i_25" +"(let-values(((k_3)(unsafe-immutable-hash-iterate-key ht_21 i_25)))" +"(let-values(((fold-var_1)" +"(let-values(((fold-var_2) fold-var_0))" +"(let-values(((fold-var_3)" +"(let-values()" +"(cons(let-values() k_3) fold-var_2))))" +"(values fold-var_3)))))" +"(if(not #f)" +"(for-loop_6 fold-var_1(unsafe-immutable-hash-iterate-next ht_21 i_25))" +" fold-var_1)))" +" fold-var_0)))))" +" for-loop_6)" +" null" +"(unsafe-immutable-hash-iterate-first ht_21))))))))" +"(define-values" +"(list->set)" +"(lambda(l_41)" +"(begin" +"(let-values(((lst_11) l_41))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_11)))" +"((letrec-values(((for-loop_7)" +"(lambda(table_0 lst_12)" +"(begin" +" 'for-loop" +"(if(pair? lst_12)" +"(let-values(((k_4)(unsafe-car lst_12))((rest_2)(unsafe-cdr lst_12)))" +"(let-values(((table_1)" +"(let-values(((table_2) table_0))" +"(let-values(((table_3)" +"(let-values()" +"(let-values(((key_8 val_0)" +"(let-values()" +"(values(let-values() k_4) #t))))" +"(hash-set table_2 key_8 val_0)))))" +"(values table_3)))))" +"(if(not #f)(for-loop_7 table_1 rest_2) table_1)))" +" table_0)))))" +" for-loop_7)" +" '#hash()" +" lst_11))))))" +"(define-values" +"(list->seteq)" +"(lambda(l_42)" +"(begin" +"(let-values(((lst_13) l_42))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_13)))" +"((letrec-values(((for-loop_8)" +"(lambda(table_4 lst_14)" +"(begin" +" 'for-loop" +"(if(pair? lst_14)" +"(let-values(((k_5)(unsafe-car lst_14))((rest_3)(unsafe-cdr lst_14)))" +"(let-values(((table_5)" +"(let-values(((table_6) table_4))" +"(let-values(((table_7)" +"(let-values()" +"(let-values(((key_9 val_1)" +"(let-values()" +"(values(let-values() k_5) #t))))" +"(hash-set table_6 key_9 val_1)))))" +"(values table_7)))))" +"(if(not #f)(for-loop_8 table_5 rest_3) table_5)))" +" table_4)))))" +" for-loop_8)" +" '#hasheq()" +" lst_13))))))" +"(define-values(prop:serialize serialize? serialize-ref)(make-struct-type-property 'serialize))" +"(define-values" +"(prop:serialize-fill! serialize-fill!? serialize-fill!-ref)" +"(make-struct-type-property 'serialize-fill!))" +"(define-values(prop:reach-scopes reach-scopes? reach-scopes-ref)(make-struct-type-property 'reach-scopes))" +"(define-values" +"(prop:scope-with-bindings scope-with-bindings? scope-with-bindings-ref)" +"(make-struct-type-property 'scope-with-bindings))" +"(define-values" +"(prop:binding-reach-scopes binding-reach-scopes? binding-reach-scopes-ref)" +"(make-struct-type-property 'binding-reach-scopes))" +"(define-values" +"(1/module-path?)" +"(lambda(v_26)" +"(begin" +" 'module-path?" +"(let-values(((or-part_0)(if(pair? v_26)(if(eq?(car v_26) 'submod)(submodule-module-path? v_26) #f) #f)))" +"(if or-part_0 or-part_0(root-module-path? v_26))))))" +"(define-values" +"(root-module-path?)" +"(lambda(v_27)" +"(begin" +"(let-values(((or-part_11)(path? v_27)))" +"(if or-part_11" +" or-part_11" +"(let-values(((or-part_2)(if(string? v_27)(string-module-path? v_27) #f)))" +"(if or-part_2" +" or-part_2" +"(let-values(((or-part_26)(if(symbol? v_27)(symbol-module-path? v_27) #f)))" +"(if or-part_26" +" or-part_26" +"(if(pair? v_27)" +"(let-values(((tmp_4)(car v_27)))" +"(if(equal? tmp_4 'quote)" +"(let-values()(if(pair?(cdr v_27))(if(symbol?(cadr v_27))(null?(cddr v_27)) #f) #f))" +"(if(equal? tmp_4 'lib)" +"(let-values()(lib-module-path? v_27))" +"(if(equal? tmp_4 'file)" +"(let-values()" +"(if(pair?(cdr v_27))" +"(if(string?(cadr v_27))(if(path-string?(cadr v_27))(null?(cddr v_27)) #f) #f)" +" #f))" +"(if(equal? tmp_4 'planet)" +"(let-values()(planet-module-path? v_27))" +"(let-values() #f))))))" +" #f))))))))))" +"(define-values" +"(submodule-module-path?)" +"(lambda(v_28)" +"(begin" +"(if(pair?(cdr v_28))" +"(if(list? v_28)" +" (if (let-values (((or-part_27) (equal? (cadr v_28) \"..\")))" +"(if or-part_27" +" or-part_27" +" (let-values (((or-part_10) (equal? (cadr v_28) \".\")))" +"(if or-part_10 or-part_10(root-module-path?(cadr v_28))))))" +"(let-values(((lst_15)(cddr v_28)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_15)))" +"((letrec-values(((for-loop_9)" +"(lambda(result_1 lst_16)" +"(begin" +" 'for-loop" +"(if(pair? lst_16)" +"(let-values(((e_7)(unsafe-car lst_16))((rest_4)(unsafe-cdr lst_16)))" +"(let-values(((result_2)" +"(let-values()" +"(let-values(((result_3)" +"(let-values()" +"(let-values()" +"(let-values(((or-part_28)" +" (equal? e_7 \"..\")))" +"(if or-part_28" +" or-part_28" +"(symbol? e_7)))))))" +"(values result_3)))))" +"(if(if(not((lambda x_13(not result_2)) e_7))(not #f) #f)" +"(for-loop_9 result_2 rest_4)" +" result_2)))" +" result_1)))))" +" for-loop_9)" +" #t" +" lst_15)))" +" #f)" +" #f)" +" #f))))" +"(define-values" +"(string-module-path?)" +"(lambda(v_29)" +"(begin" +"(let-values(((temp14_0) #t)((temp15_0) #t)((temp16_0) #t))" +"(module-path-string?10.1 temp14_0 #t temp16_0 #t #f #f temp15_0 #t v_29)))))" +"(define-values" +"(symbol-module-path?)" +"(lambda(v_30)" +"(begin" +"(let-values(((temp17_0)(symbol->string v_30)))(module-path-string?10.1 #f #f #f #f #f #f #f #f temp17_0)))))" +"(define-values" +"(lib-module-path?)" +"(lambda(v_31)" +"(begin" +"(if(list? v_31)" +"(if(pair?(cdr v_31))" +"((letrec-values(((loop_52)" +"(lambda(v_32 first?_0)" +"(begin" +" 'loop" +"(let-values(((or-part_29)(null? v_32)))" +"(if or-part_29" +" or-part_29" +"(if(string?(car v_32))" +"(if(let-values(((temp18_0)(car v_32))" +"((first?19_0) first?_0)" +"((first?20_0) first?_0))" +"(module-path-string?10.1 #f #f first?20_0 #t #f #f first?19_0 #t temp18_0))" +"(loop_52(cdr v_32) #f)" +" #f)" +" #f)))))))" +" loop_52)" +"(cdr v_31)" +" #t)" +" #f)" +" #f))))" +"(define-values" +"(planet-module-path?)" +"(lambda(v_33)" +"(begin" +"(if(list? v_33)" +"(let-values(((tmp_5)(length v_33)))" +"(if(equal? tmp_5 1)" +"(let-values() #f)" +"(if(equal? tmp_5 2)" +"(let-values()" +"(let-values(((e_8)(cadr v_33)))" +"(if(string? e_8)" +"(let-values()" +"(let-values(((temp22_0) #t)((temp23_0) #t))" +"(module-path-string?10.1 #f #f temp23_0 #t temp22_0 #t #f #f e_8)))" +"(if(symbol? e_8)" +"(let-values()" +"(let-values(((temp24_0)(symbol->string e_8))((temp25_0) #t))" +"(module-path-string?10.1 #f #f #f #f temp25_0 #t #f #f temp24_0)))" +"(let-values() #f)))))" +"(let-values()" +"(let-values(((file_0)(cadr v_33)))" +"(let-values(((pkg_0)(caddr v_33)))" +"(let-values(((subs_0)(cdddr v_33)))" +"(if file_0" +"(if(let-values(((temp27_0) #t)((temp28_0) #t))" +"(module-path-string?10.1 #f #f temp28_0 #t #f #f temp27_0 #t file_0))" +"(if(if(list? pkg_0)" +"(if(<= 2(length pkg_0) 4)" +"(if(planet-user/pkg-string?(car pkg_0))" +"(if(planet-user/pkg-string?(cadr pkg_0))" +"(let-values(((or-part_30)(null?(cddr pkg_0))))" +"(if or-part_30" +" or-part_30" +"(let-values(((or-part_31)(planet-version-number?(caddr pkg_0))))" +"(if or-part_31" +" or-part_31" +"(let-values(((or-part_32)(null?(cddr pkg_0))))" +"(if or-part_32" +" or-part_32" +"(planet-version-minor-spec?(cadddr pkg_0))))))))" +" #f)" +" #f)" +" #f)" +" #f)" +"(let-values(((lst_17) subs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_17)))" +"((letrec-values(((for-loop_10)" +"(lambda(result_4 lst_18)" +"(begin" +" 'for-loop" +"(if(pair? lst_18)" +"(let-values(((sub_0)(unsafe-car lst_18))" +"((rest_5)(unsafe-cdr lst_18)))" +"(let-values(((result_5)" +"(let-values()" +"(let-values(((result_6)" +"(let-values()" +"(let-values()" +"(let-values(((sub29_0)" +" sub_0))" +"(module-path-string?10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" sub29_0))))))" +"(values result_6)))))" +"(if(if(not((lambda x_14(not result_5)) sub_0))" +"(not #f)" +" #f)" +"(for-loop_10 result_5 rest_5)" +" result_5)))" +" result_4)))))" +" for-loop_10)" +" #t" +" lst_17)))" +" #f)" +" #f)" +" #f))))))))" +" #f))))" +"(define-values(planet-version-number?)(lambda(v_34)(begin(exact-nonnegative-integer? v_34))))" +"(define-values" +"(planet-version-minor-spec?)" +"(lambda(v_35)" +"(begin" +"(let-values(((or-part_33)(planet-version-number? v_35)))" +"(if or-part_33" +" or-part_33" +"(if(pair? v_35)" +"(if(list? v_35)" +"(if(= 2(length v_35))" +"(let-values(((tmp_6)(car v_35)))" +"(if(if(equal? tmp_6 '=) #t(if(equal? tmp_6 '+) #t(equal? tmp_6 '-)))" +"(let-values()(planet-version-number?(cadr v_35)))" +"(let-values()(if(planet-version-number?(car v_35))(planet-version-number?(cadr v_35)) #f))))" +" #f)" +" #f)" +" #f))))))" +"(define-values" +"(module-path-string?10.1)" +"(lambda(dots-dir-ok?2_0" +" dots-dir-ok?6_0" +" file-end-ok?4_0" +" file-end-ok?8_0" +" for-planet?1_0" +" for-planet?5_0" +" just-file-ok?3_0" +" just-file-ok?7_0" +" v9_0)" +"(begin" +" 'module-path-string?10" +"(let-values(((v_36) v9_0))" +"(let-values(((for-planet?_0)(if for-planet?5_0 for-planet?1_0 #f)))" +"(let-values(((dots-dir-ok?_0)(if dots-dir-ok?6_0 dots-dir-ok?2_0 #f)))" +"(let-values(((just-file-ok?_0)(if just-file-ok?7_0 just-file-ok?3_0 #f)))" +"(let-values(((file-end-ok?_0)(if file-end-ok?8_0 file-end-ok?4_0 #f)))" +"(let-values()" +"(let-values(((len_3)(string-length v_36)))" +"(if(positive? len_3)" +"(if(not(char=? '#\\/(string-ref v_36 0)))" +"(if(not(char=? '#\\/(string-ref v_36(sub1 len_3))))" +"(let-values(((start-package-version-pos_0 end-package-version-pos_0)" +"(if for-planet?_0(check-planet-part v_36 len_3)(values 0 0))))" +"(if start-package-version-pos_0" +"((letrec-values(((loop_53)" +"(lambda(i_26 prev-was-slash?_0 saw-slash?_0 saw-dot?_0)" +"(begin" +" 'loop" +"(if(not(zero? i_26))" +"(let-values()" +"(let-values(((c_6)(string-ref v_36 i_26)))" +"(if(char=? c_6 '#\\/)" +"(let-values()" +"(if(not prev-was-slash?_0)" +"(loop_53(sub1 i_26) #t #t saw-dot?_0)" +" #f))" +"(if(char=? c_6 '#\\.)" +"(let-values()" +"(if(if(<(add1 i_26) len_3)" +"(if(not" +"(char=?(string-ref v_36(add1 i_26)) '#\\/))" +"(not" +"(char=?(string-ref v_36(add1 i_26)) '#\\.))" +" #f)" +" #f)" +"(if(not saw-slash?_0)" +"(loop_53(sub1 i_26) #f saw-slash?_0 #t)" +" #f)" +"(loop_53(sub1 i_26) #f saw-slash?_0 saw-dot?_0)))" +"(if(let-values(((or-part_34)(plain-char? c_6)))" +"(if or-part_34" +" or-part_34" +"(if(char=? c_6 '#\\%)" +"(if(<(+ i_26 2) len_3)" +"(hex-sequence? v_36(add1 i_26))" +" #f)" +" #f)))" +"(let-values()" +"(loop_53(sub1 i_26) #f saw-slash?_0 saw-dot?_0))" +"(if(if(>= i_26 start-package-version-pos_0)" +"(< i_26 end-package-version-pos_0)" +" #f)" +"(let-values()" +"(loop_53(sub1 i_26) #f saw-slash?_0 saw-dot?_0))" +"(let-values() #f)))))))" +"(let-values()" +"(if(not" +"(if(not just-file-ok?_0)" +"(if saw-dot?_0(not saw-slash?_0) #f)" +" #f))" +"(let-values(((or-part_35) dots-dir-ok?_0))" +"(if or-part_35" +" or-part_35" +"((letrec-values(((loop_54)" +"(lambda(i_27)" +"(begin" +" 'loop" +"(if(= i_27 len_3)" +"(let-values() #t)" +"(if(char=?" +"(string-ref v_36 i_27)" +" '#\\.)" +"(let-values()" +"(if(not" +"(let-values(((or-part_36)" +"(=" +" len_3" +"(add1" +" i_27))))" +"(if or-part_36" +" or-part_36" +"(char=?" +"(string-ref" +" v_36" +"(add1 i_27))" +" '#\\/))))" +"(if(not" +"(if(char=?" +"(string-ref" +" v_36" +"(add1 i_27))" +" '#\\.)" +"(let-values(((or-part_37)" +"(=" +" len_3" +"(+" +" i_27" +" 2))))" +"(if or-part_37" +" or-part_37" +"(char=?" +"(string-ref" +" v_36" +"(+ i_27 2))" +" '#\\/)))" +" #f))" +"(loop_54" +"((letrec-values(((loop_55)" +"(lambda(i_28)" +"(begin" +" 'loop" +"(if(char=?" +" '#\\." +"(string-ref" +" v_36" +" i_28))" +"(loop_55" +"(add1" +" i_28))" +" i_28)))))" +" loop_55)" +" i_27))" +" #f)" +" #f))" +"(let-values()" +"(loop_54(add1 i_27)))))))))" +" loop_54)" +" 0)))" +" #f)))))))" +" loop_53)" +"(sub1 len_3)" +" #f" +"(not file-end-ok?_0)" +" #f)" +" #f))" +" #f)" +" #f)" +" #f)))))))))))" +"(define-values" +"(planet-user/pkg-string?)" +"(lambda(v_37)" +"(begin" +"(if(string? v_37)" +"(let-values(((len_4)(string-length v_37)))" +"(if(positive? len_4)" +"(let-values(((vec_11 len_5)" +"(let-values(((vec_12) v_37))" +"(begin(check-string vec_12)(values vec_12(unsafe-string-length vec_12)))))" +"((start_6) 0))" +"(begin" +" #f" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_6)))" +"((letrec-values(((for-loop_11)" +"(lambda(result_7 pos_1 pos_2)" +"(begin" +" 'for-loop" +"(if(if(unsafe-fx< pos_1 len_5) #t #f)" +"(let-values(((c_7)(string-ref vec_11 pos_1))((i_29) pos_2))" +"(let-values(((result_8)" +"(let-values()" +"(let-values(((result_9)" +"(let-values()" +"(let-values()" +"(let-values(((or-part_38)" +"(plain-char? c_7)))" +"(if or-part_38" +" or-part_38" +"(let-values(((or-part_39)" +"(char=? '#\\. c_7)))" +"(if or-part_39" +" or-part_39" +"(if(char=? '#\\% c_7)" +"(if(< i_29(- len_4 2))" +"(hex-sequence? v_37(add1 i_29))" +" #f)" +" #f)))))))))" +"(values result_9)))))" +"(if(if(not((lambda x_15(not result_8)) c_7))" +"(if(not((lambda x_16(not result_8)) i_29))(not #f) #f)" +" #f)" +"(for-loop_11 result_8(unsafe-fx+ 1 pos_1)(+ pos_2 1))" +" result_8)))" +" result_7)))))" +" for-loop_11)" +" #t" +" 0" +" start_6)))" +" #f))" +" #f))))" +"(define-values" +"(plain-char?)" +"(lambda(c_8)" +"(begin" +"(let-values(((or-part_40)(char<=? '#\\a c_8 '#\\z)))" +"(if or-part_40" +" or-part_40" +"(let-values(((or-part_41)(char<=? '#\\A c_8 '#\\Z)))" +"(if or-part_41" +" or-part_41" +"(let-values(((or-part_42)(char<=? '#\\0 c_8 '#\\9)))" +"(if or-part_42" +" or-part_42" +"(let-values(((or-part_43)(char=? '#\\- c_8)))" +"(if or-part_43" +" or-part_43" +"(let-values(((or-part_44)(char=? '#\\_ c_8)))" +"(if or-part_44 or-part_44(char=? '#\\+ c_8))))))))))))))" +"(define-values" +"(hex-sequence?)" +"(lambda(s_32 i_30)" +"(begin" +"(let-values(((c1_16)(string-ref s_32 i_30)))" +"(let-values(((c2_0)(string-ref s_32(add1 i_30))))" +"(if(hex-char? c1_16)" +"(if(hex-char? c2_0)" +"(let-values(((c_9)(integer->char(+(*(hex-char->integer c1_16) 16)(hex-char->integer c2_0)))))" +"(not(plain-char? c_9)))" +" #f)" +" #f))))))" +"(define-values" +"(hex-char?)" +"(lambda(c_10)" +"(begin(let-values(((or-part_45)(char<=? '#\\a c_10 '#\\f)))(if or-part_45 or-part_45(char<=? '#\\0 c_10 '#\\9))))))" +"(define-values" +"(hex-char->integer)" +"(lambda(c_11)" +"(begin" +"(if(char<=? '#\\a c_11 '#\\f)" +"(let-values()(-(char->integer c_11)(+ 10(char->integer '#\\a))))" +"(if(char<=? '#\\A c_11 '#\\F)" +"(let-values()(-(char->integer c_11)(+ 10(char->integer '#\\A))))" +"(let-values()(-(char->integer c_11)(char->integer '#\\0))))))))" +"(define-values" +"(check-planet-part)" +"(lambda(v_38 len_6)" +"(begin" +"(let-values(((start-package-version-pos_1 end-package-version-pos_1 colon1-pos_0 colon2-pos_0)" +"((letrec-values(((loop_56)" +"(lambda(j_2" +" start-package-version-pos_2" +" end-package-version-pos_2" +" colon1-pos_1" +" colon2-pos_1)" +"(begin" +" 'loop" +"(if(= j_2 len_6)" +"(let-values()" +"(values" +" start-package-version-pos_2" +"(let-values(((or-part_46) end-package-version-pos_2))" +"(if or-part_46 or-part_46 j_2))" +" colon1-pos_1" +" colon2-pos_1))" +"(let-values()" +"(let-values(((tmp_7)(string-ref v_38 j_2)))" +"(if(equal? tmp_7 '#\\/)" +"(let-values()" +"(loop_56" +"(add1 j_2)" +"(let-values(((or-part_47) start-package-version-pos_2))" +"(if or-part_47 or-part_47(add1 j_2)))" +"(if start-package-version-pos_2" +"(let-values(((or-part_48) end-package-version-pos_2))" +"(if or-part_48 or-part_48 j_2))" +" #f)" +" colon1-pos_1" +" colon2-pos_1))" +"(if(equal? tmp_7 '#\\:)" +"(let-values()" +"(if colon2-pos_1" +"(let-values()(values #f #f #f #f))" +"(if colon1-pos_1" +"(let-values()" +"(loop_56" +"(add1 j_2)" +" start-package-version-pos_2" +" end-package-version-pos_2" +" colon1-pos_1" +" j_2))" +"(let-values()" +"(loop_56" +"(add1 j_2)" +" start-package-version-pos_2" +" end-package-version-pos_2" +" j_2" +" #f)))))" +"(let-values()" +"(loop_56" +"(add1 j_2)" +" start-package-version-pos_2" +" end-package-version-pos_2" +" colon1-pos_1" +" colon2-pos_1)))))))))))" +" loop_56)" +" 0" +" #f" +" #f" +" #f" +" #f)))" +"(if(if start-package-version-pos_1" +"(if(> end-package-version-pos_1 start-package-version-pos_1)" +"(let-values(((or-part_49)(not colon2-pos_0)))" +"(if or-part_49 or-part_49(<(add1 colon2-pos_0) end-package-version-pos_1)))" +" #f)" +" #f)" +"(let-values()" +"(if colon1-pos_0" +"(let-values()" +"(let-values(((colon1-end_0)" +"(let-values(((or-part_50) colon2-pos_0))" +"(if or-part_50 or-part_50 end-package-version-pos_1))))" +"(if(if(integer-sequence? v_38(add1 colon1-pos_0) colon1-end_0)" +"(let-values(((or-part_51)(not colon2-pos_0)))" +"(if or-part_51" +" or-part_51" +"(let-values(((tmp_8)(string-ref v_38(add1 colon2-pos_0))))" +"(if(equal? tmp_8 '#\\=)" +"(let-values()(integer-sequence? v_38(+ 2 colon2-pos_0) end-package-version-pos_1))" +"(if(if(equal? tmp_8 '#\\>) #t(equal? tmp_8 '#\\<))" +"(let-values()" +"(if(if(<(+ 2 colon2-pos_0) end-package-version-pos_1)" +"(char=? '#\\=(string-ref v_38(+ colon2-pos_0 2)))" +" #f)" +"(let-values()" +"(integer-sequence? v_38(+ 3 colon2-pos_0) end-package-version-pos_1))" +"(let-values()" +"(integer-sequence? v_38(+ 2 colon2-pos_0) end-package-version-pos_1))))" +"(let-values()" +"(integer-range-sequence? v_38(add1 colon2-pos_0) end-package-version-pos_1)))))))" +" #f)" +"(let-values()(values colon1-pos_0 end-package-version-pos_1))" +"(let-values()(values #f #f)))))" +"(let-values()(values 0 0))))" +"(let-values()(values #f #f)))))))" +"(define-values" +"(integer-sequence?)" +"(lambda(s_33 start_7 end_4)" +"(begin" +"(if(< start_7 end_4)" +"(let-values(((start_8) start_7)((end_5) end_4)((inc_0) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_8 end_5 inc_0)))" +"((letrec-values(((for-loop_12)" +"(lambda(result_10 pos_3)" +"(begin" +" 'for-loop" +"(if(< pos_3 end_5)" +"(let-values(((i_31) pos_3))" +"(let-values(((result_11)" +"(let-values()" +"(let-values(((result_12)" +"(let-values()" +"(let-values()" +"(char<=? '#\\0(string-ref s_33 i_31) '#\\9)))))" +"(values result_12)))))" +"(if(if(not((lambda x_17(not result_11)) i_31))(not #f) #f)" +"(for-loop_12 result_11(+ pos_3 inc_0))" +" result_11)))" +" result_10)))))" +" for-loop_12)" +" #t" +" start_8)))" +" #f))))" +"(define-values" +"(integer-range-sequence?)" +"(lambda(s_34 start_9 end_6)" +"(begin" +"(if(< start_9 end_6)" +"(if(let-values(((start_10) start_9)((end_7) end_6)((inc_1) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_10 end_7 inc_1)))" +"((letrec-values(((for-loop_13)" +"(lambda(result_13 pos_4)" +"(begin" +" 'for-loop" +"(if(< pos_4 end_7)" +"(let-values(((i_32) pos_4))" +"(let-values(((result_14)" +"(let-values()" +"(let-values(((result_15)" +"(let-values()" +"(let-values()" +"(let-values(((c_12)" +"(string-ref s_34 i_32)))" +"(let-values(((or-part_52)" +"(char=? c_12 '#\\-)))" +"(if or-part_52" +" or-part_52" +"(char<=? '#\\0 c_12 '#\\9))))))))" +"(values result_15)))))" +"(if(if(not((lambda x_18(not result_14)) i_32))(not #f) #f)" +"(for-loop_13 result_14(+ pos_4 inc_1))" +" result_14)))" +" result_13)))))" +" for-loop_13)" +" #t" +" start_10)))" +"(>=" +" 1" +"(let-values(((start_11) start_9)((end_8) end_6)((inc_2) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_11 end_8 inc_2)))" +"((letrec-values(((for-loop_14)" +"(lambda(result_16 pos_5)" +"(begin" +" 'for-loop" +"(if(< pos_5 end_8)" +"(let-values(((i_33) pos_5))" +"(let-values(((result_17)" +"(let-values(((result_18) result_16))" +"(let-values(((result_19)" +"(let-values()" +"(+" +" result_18" +"(let-values()" +"(if(char=?(string-ref s_34 i_33) '#\\-)" +" 1" +" 0))))))" +"(values result_19)))))" +"(if(not #f)(for-loop_14 result_17(+ pos_5 inc_2)) result_17)))" +" result_16)))))" +" for-loop_14)" +" 0" +" start_11))))" +" #f)" +" #f))))" +"(define-values" +"(struct:weak-intern-table weak-intern-table1.1 weak-intern-table? weak-intern-table-box)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'weak-intern-table" +" #f" +" 1" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'weak-intern-table)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'box))))" +"(define-values" +"(struct:table table2.1 table? table-ht table-count table-prune-at)" +"(let-values(((struct:_1 make-_1 ?_1 -ref_1 -set!_1)" +"(let-values()" +"(let-values()(make-struct-type 'table #f 3 0 #f null(current-inspector) #f '(0 1 2) #f 'table)))))" +"(values" +" struct:_1" +" make-_1" +" ?_1" +"(make-struct-field-accessor -ref_1 0 'ht)" +"(make-struct-field-accessor -ref_1 1 'count)" +"(make-struct-field-accessor -ref_1 2 'prune-at))))" +"(define-values(make-weak-intern-table)(lambda()(begin(weak-intern-table1.1(box(table2.1(hasheqv) 0 128))))))" +"(define-values" +"(weak-intern!)" +"(lambda(tt_0 v_39)" +"(begin" +"(let-values(((b_8)(weak-intern-table-box tt_0)))" +"(let-values(((t_10)(unbox b_8)))" +"(let-values(((code_0)(equal-hash-code v_39)))" +"(let-values(((vals_0)(hash-ref(table-ht t_10) code_0 null)))" +"(let-values(((or-part_53)" +"(let-values(((lst_19) vals_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_19)))" +"((letrec-values(((for-loop_15)" +"(lambda(result_20 lst_20)" +"(begin" +" 'for-loop" +"(if(pair? lst_20)" +"(let-values(((b_9)(unsafe-car lst_20))" +"((rest_6)(unsafe-cdr lst_20)))" +"(let-values(((result_21)" +"(let-values()" +"(let-values(((result_22)" +"(let-values()" +"(let-values()" +"(let-values(((bv_0)" +"(weak-box-value" +" b_9)))" +"(if(equal? bv_0 v_39)" +" bv_0" +" #f))))))" +"(values result_22)))))" +"(if(if(not((lambda x_19 result_21) b_9))(not #f) #f)" +"(for-loop_15 result_21 rest_6)" +" result_21)))" +" result_20)))))" +" for-loop_15)" +" #f" +" lst_19)))))" +"(if or-part_53" +" or-part_53" +"(let-values(((pruned-t_0)(if(=(table-count t_10)(table-prune-at t_10))(prune-table t_10) t_10)))" +"(let-values(((ht_22)(table-ht pruned-t_0)))" +"(let-values(((new-t_0)" +"(table2.1" +"(hash-set ht_22 code_0(cons(make-weak-box v_39)(hash-ref ht_22 code_0 null)))" +"(add1(table-count pruned-t_0))" +"(table-prune-at pruned-t_0))))" +"(let-values(((or-part_54)(if(box-cas! b_8 t_10 new-t_0) v_39 #f)))" +"(if or-part_54 or-part_54(weak-intern! tt_0 v_39)))))))))))))))" +"(define-values" +"(prune-table)" +"(lambda(t_11)" +"(begin" +"(let-values(((new-ht_0)" +"(let-values(((ht_23)(table-ht t_11)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_23)))" +"((letrec-values(((for-loop_16)" +"(lambda(table_8 i_34)" +"(begin" +" 'for-loop" +"(if i_34" +"(let-values(((k_6 vals_1)(hash-iterate-key+value ht_23 i_34)))" +"(let-values(((table_9)" +"(let-values(((new-vals_0)" +"(reverse$1" +"(let-values(((lst_21) vals_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_21)))" +"((letrec-values(((for-loop_17)" +"(lambda(fold-var_4" +" lst_22)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_22)" +"(let-values(((b_10)" +"(unsafe-car" +" lst_22))" +"((rest_7)" +"(unsafe-cdr" +" lst_22)))" +"(let-values(((fold-var_5)" +"(let-values(((fold-var_6)" +" fold-var_4))" +"(if(weak-box-value" +" b_10)" +"(let-values(((fold-var_7)" +" fold-var_6))" +"(let-values(((fold-var_8)" +"(let-values()" +"(cons" +"(let-values()" +" b_10)" +" fold-var_7))))" +"(values" +" fold-var_8)))" +" fold-var_6))))" +"(if(not" +" #f)" +"(for-loop_17" +" fold-var_5" +" rest_7)" +" fold-var_5)))" +" fold-var_4)))))" +" for-loop_17)" +" null" +" lst_21))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_18)" +"(lambda(table_10)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_11)" +"(let-values(((table_12)" +" table_10))" +"(if(pair?" +" new-vals_0)" +"(let-values(((table_13)" +" table_12))" +"(let-values(((table_14)" +"(let-values()" +"(let-values(((key_10" +" val_2)" +"(let-values()" +"(values" +" k_6" +" new-vals_0))))" +"(hash-set" +" table_13" +" key_10" +" val_2)))))" +"(values" +" table_14)))" +" table_12))))" +" table_11))))))" +" for-loop_18)" +" table_8)))))" +"(if(not #f)" +"(for-loop_16 table_9(hash-iterate-next ht_23 i_34))" +" table_9)))" +" table_8)))))" +" for-loop_16)" +" '#hash()" +"(hash-iterate-first ht_23))))))" +"(let-values(((count_0)" +"(let-values(((ht_24) new-ht_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_24)))" +"((letrec-values(((for-loop_19)" +"(lambda(result_23 i_35)" +"(begin" +" 'for-loop" +"(if i_35" +"(let-values(((k_7 vals_2)(hash-iterate-key+value ht_24 i_35)))" +"(let-values(((result_24)" +"(let-values(((result_25) result_23))" +"(let-values(((result_26)" +"(let-values()" +"(+" +" result_25" +"(let-values()(length vals_2))))))" +"(values result_26)))))" +"(if(not #f)" +"(for-loop_19 result_24(hash-iterate-next ht_24 i_35))" +" result_24)))" +" result_23)))))" +" for-loop_19)" +" 0" +"(hash-iterate-first ht_24))))))" +"(table2.1 new-ht_0 count_0(max 128(* 2 count_0))))))))" +"(define-values" +"(struct:resolved-module-path resolved-module-path1.1 1/resolved-module-path? 1/resolved-module-path-name)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'resolved-module-path" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(r_8 ser-push!_0 state_0)" +"(begin" +"(ser-push!_0 'tag '#:resolved-module-path)" +"(ser-push!_0(1/resolved-module-path-name r_8)))))" +"(cons" +" prop:custom-write" +"(lambda(r_9 port_0 mode_3)" +"(begin" +" (if mode_3 (let-values () (write-string \"#\" port_0)) (void)))))" +"(cons" +" prop:equal+hash" +"(list" +"(lambda(a_22 b_11 eql?_0)" +"(eql?_0(1/resolved-module-path-name a_22)(1/resolved-module-path-name b_11)))" +"(lambda(a_23 hash-code_0)(hash-code_0(1/resolved-module-path-name a_23)))" +"(lambda(a_24 hash-code_1)(hash-code_1(1/resolved-module-path-name a_24))))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'resolved-module-path)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'name))))" +"(define-values" +"(format-resolved-module-path-name)" +"(lambda(p_3)" +"(begin" +"(if(path? p_3)" +" (let-values () (string-append \"\\\"\" (path->string p_3) \"\\\"\"))" +"(if(symbol? p_3)" +"(let-values()(format-symbol p_3))" +"(let-values()(format-submod(format-resolved-module-path-name(car p_3))(cdr p_3))))))))" +"(define-values" +"(format-symbol)" +" (lambda (p_4) (begin (format \"'~s~a\" p_4 (if (symbol-interned? p_4) \"\" (format \"[~a]\" (eq-hash-code p_4)))))))" +"(define-values" +"(format-submod)" +"(lambda(base_5 syms_0)" +"(begin" +"(format" +" \"(submod ~a~a)\"" +" base_5" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_23) syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_23)))" +"((letrec-values(((for-loop_20)" +"(lambda(fold-var_9 lst_24)" +"(begin" +" 'for-loop" +"(if(pair? lst_24)" +"(let-values(((i_36)(unsafe-car lst_24))((rest_8)(unsafe-cdr lst_24)))" +"(let-values(((fold-var_10)" +"(let-values(((fold-var_11) fold-var_9))" +"(let-values(((fold-var_12)" +"(let-values()" +"(cons" +" (let-values () (format \" ~s\" i_36))" +" fold-var_11))))" +"(values fold-var_12)))))" +"(if(not #f)(for-loop_20 fold-var_10 rest_8) fold-var_10)))" +" fold-var_9)))))" +" for-loop_20)" +" null" +" lst_23)))))))))" +"(define-values" +"(resolved-module-path-root-name)" +"(lambda(r_10)" +"(begin(let-values(((name_6)(1/resolved-module-path-name r_10)))(if(pair? name_6)(car name_6) name_6)))))" +"(define-values(resolved-module-paths)(make-weak-intern-table))" +"(define-values" +"(1/make-resolved-module-path)" +"(lambda(p_5)" +"(begin" +" 'make-resolved-module-path" +"(begin" +"(if(let-values(((or-part_55)(symbol? p_5)))" +"(if or-part_55" +" or-part_55" +"(let-values(((or-part_56)(if(path? p_5)(complete-path? p_5) #f)))" +"(if or-part_56" +" or-part_56" +"(if(pair? p_5)" +"(if(pair?(cdr p_5))" +"(if(list? p_5)" +"(if(let-values(((or-part_7)(symbol?(car p_5))))" +"(if or-part_7 or-part_7(if(path?(car p_5))(complete-path?(car p_5)) #f)))" +"(let-values(((lst_18)(cdr p_5)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_18)))" +"((letrec-values(((for-loop_21)" +"(lambda(result_27 lst_25)" +"(begin" +" 'for-loop" +"(if(pair? lst_25)" +"(let-values(((s_35)(unsafe-car lst_25))" +"((rest_9)(unsafe-cdr lst_25)))" +"(let-values(((result_20)" +"(let-values()" +"(let-values(((result_28)" +"(let-values()" +"(let-values()" +"(symbol? s_35)))))" +"(values result_28)))))" +"(if(if(not((lambda x_20(not result_20)) s_35))" +"(not #f)" +" #f)" +"(for-loop_21 result_20 rest_9)" +" result_20)))" +" result_27)))))" +" for-loop_21)" +" #t" +" lst_18)))" +" #f)" +" #f)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-resolved-module-path" +"(string-append" +" \"(or/c symbol?\\n\"" +" \" (and/c path? complete-path?)\\n\"" +" \" (cons/c (or/c symbol?\\n\"" +" \" (and/c path? complete-path?))\\n\"" +" \" (non-empty-listof symbol?)))\")" +" p_5)))" +"(weak-intern! resolved-module-paths(resolved-module-path1.1 p_5))))))" +"(define-values" +"(resolved-module-path->module-path)" +"(lambda(r_11)" +"(begin" +"(let-values(((name_7)(1/resolved-module-path-name r_11)))" +"(let-values(((root-name_0)(if(pair? name_7)(car name_7) name_7)))" +"(let-values(((root-mod-path_0)(if(path? root-name_0) root-name_0(list 'quote root-name_0))))" +"(if(pair? name_7)(list* 'submod root-mod-path_0(cdr name_7)) root-mod-path_0)))))))" +"(define-values" +"(struct:module-path-index" +" module-path-index2.1" +" 1/module-path-index?" +" module-path-index-path" +" module-path-index-base" +" module-path-index-resolved" +" module-path-index-shift-cache" +" set-module-path-index-resolved!" +" set-module-path-index-shift-cache!)" +"(let-values(((struct:_2 make-_2 ?_2 -ref_2 -set!_2)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-path-index" +" #f" +" 4" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:custom-write" +"(lambda(r_12 port_1 mode_4)" +"(begin" +" (write-string \"#\" port_1))))" +"(cons" +" prop:equal+hash" +"(list" +"(lambda(a_25 b_12 eql?_1)" +"(if(eql?_1(module-path-index-path a_25)(module-path-index-path b_12))" +"(eql?_1(module-path-index-base a_25)(module-path-index-base b_12))" +" #f))" +"(lambda(a_26 hash-code_2)" +"(+(hash-code_2(module-path-index-path a_26))(hash-code_2(module-path-index-base a_26))))" +"(lambda(a_27 hash-code_3)" +"(+" +"(hash-code_3(module-path-index-path a_27))" +"(hash-code_3(module-path-index-base a_27)))))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'module-path-index)))))" +"(values" +" struct:_2" +" make-_2" +" ?_2" +"(make-struct-field-accessor -ref_2 0 'path)" +"(make-struct-field-accessor -ref_2 1 'base)" +"(make-struct-field-accessor -ref_2 2 'resolved)" +"(make-struct-field-accessor -ref_2 3 'shift-cache)" +"(make-struct-field-mutator -set!_2 2 'resolved)" +"(make-struct-field-mutator -set!_2 3 'shift-cache))))" +"(define-values" +"(deserialize-module-path-index)" +"(case-lambda" +"((path_3 base_6)(begin(1/module-path-index-join path_3 base_6)))" +"((name_8)(make-self-module-path-index(1/make-resolved-module-path name_8)))" +"(() top-level-module-path-index)))" +"(define-values" +"(1/module-path-index-resolve)" +"(let-values(((module-path-index-resolve6_0)" +"(lambda(mpi5_0 load?3_0 load?4_0)" +"(begin" +" 'module-path-index-resolve6" +"(let-values(((mpi_0) mpi5_0))" +"(let-values(((load?_0)(if load?4_0 load?3_0 #f)))" +"(let-values()" +"(begin" +"(if(1/module-path-index? mpi_0)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-path-index-resolve \"module-path-index?\" mpi_0)))" +"(let-values(((or-part_57)(module-path-index-resolved mpi_0)))" +"(if or-part_57" +" or-part_57" +"(let-values(((mod-name_0)" +"((1/current-module-name-resolver)" +"(module-path-index-path mpi_0)" +"(module-path-index-resolve/maybe(module-path-index-base mpi_0) load?_0)" +" #f" +" load?_0)))" +"(begin" +"(if(1/resolved-module-path? mod-name_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'module-path-index-resolve" +" \"current module name resolver's result is not a resolved module path\"" +" \"result\"" +" mod-name_0)))" +"(set-module-path-index-resolved! mpi_0 mod-name_0)" +" mod-name_0))))))))))))" +"(case-lambda" +"((mpi_1)(begin 'module-path-index-resolve(module-path-index-resolve6_0 mpi_1 #f #f)))" +"((mpi_2 load?3_1)(module-path-index-resolve6_0 mpi_2 load?3_1 #t)))))" +"(define-values" +"(module-path-index-unresolve)" +"(lambda(mpi_3)" +"(begin" +"(if(module-path-index-resolved mpi_3)" +"(let-values()" +"(let-values(((path_4 base_7)(1/module-path-index-split mpi_3)))(1/module-path-index-join path_4 base_7)))" +"(let-values() mpi_3)))))" +"(define-values" +"(1/module-path-index-join)" +"(let-values(((module-path-index-join12_0)" +"(lambda(mod-path10_0 base11_0 submod8_0 submod9_0)" +"(begin" +" 'module-path-index-join12" +"(let-values(((mod-path_0) mod-path10_0))" +"(let-values(((base_8) base11_0))" +"(let-values(((submod_0)(if submod9_0 submod8_0 #f)))" +"(let-values()" +"(begin" +"(if(let-values(((or-part_43)(not mod-path_0)))" +"(if or-part_43 or-part_43(1/module-path? mod-path_0)))" +"(void)" +"(let-values()" +" (raise-argument-error 'module-path-index-join \"(or/c #f module-path?)\" mod-path_0)))" +"(if(let-values(((or-part_44)(not base_8)))" +"(if or-part_44" +" or-part_44" +"(let-values(((or-part_58)(1/resolved-module-path? base_8)))" +"(if or-part_58 or-part_58(1/module-path-index? base_8)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-path-index-join" +" \"(or/c #f resolved-module-path? module-path-index?)\"" +" base_8)))" +"(if(let-values(((or-part_59)(not submod_0)))" +"(if or-part_59" +" or-part_59" +"(if(pair? submod_0)(if(list? submod_0)(andmap2 symbol? submod_0) #f) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-path-index-join" +" \"(or/c #f (non-empty-listof symbol?))\"" +" submod_0)))" +"(if(if(not mod-path_0) base_8 #f)" +"(let-values()" +"(raise-arguments-error" +" 'module-path-index-join" +" \"cannot combine #f path with non-#f base\"" +" \"given base\"" +" base_8))" +"(void))" +"(if(if submod_0 mod-path_0 #f)" +"(let-values()" +"(raise-arguments-error" +" 'module-path-index-join" +" \"cannot combine #f submodule list with non-#f module path\"" +" \"given module path\"" +" mod-path_0" +" \"given submodule list\"" +" submod_0))" +"(void))" +"(if submod_0" +"(let-values()" +"(make-self-module-path-index" +"(1/make-resolved-module-path(cons generic-module-name submod_0))))" +"(let-values()" +"(let-values(((keep-base_0)" +"((letrec-values(((loop_59)" +"(lambda(mod-path_1)" +"(begin" +" 'loop" +"(if(path? mod-path_1)" +"(let-values() #f)" +"(if(if(pair? mod-path_1)" +"(eq? 'quote(car mod-path_1))" +" #f)" +"(let-values() #f)" +"(if(symbol? mod-path_1)" +"(let-values() #f)" +"(if(if(pair? mod-path_1)" +"(eq? 'submod(car mod-path_1))" +" #f)" +"(let-values()" +"(loop_59(cadr mod-path_1)))" +"(let-values() base_8)))))))))" +" loop_59)" +" mod-path_0)))" +"(module-path-index2.1 mod-path_0 keep-base_0 #f #f)))))))))))))" +"(case-lambda" +"((mod-path_2 base_9)(begin 'module-path-index-join(module-path-index-join12_0 mod-path_2 base_9 #f #f)))" +"((mod-path_3 base_10 submod8_1)(module-path-index-join12_0 mod-path_3 base_10 submod8_1 #t)))))" +"(define-values" +"(module-path-index-resolve/maybe)" +"(lambda(base_11 load?_1)" +"(begin(if(1/module-path-index? base_11)(1/module-path-index-resolve base_11 load?_1) base_11))))" +"(define-values" +"(1/module-path-index-split)" +"(lambda(mpi_4)" +"(begin" +" 'module-path-index-split" +"(begin" +"(if(1/module-path-index? mpi_4)" +"(void)" +" (let-values () (raise-argument-error 'module-path-index-split \"module-path-index?\" mpi_4)))" +"(values(module-path-index-path mpi_4)(module-path-index-base mpi_4))))))" +"(define-values" +"(1/module-path-index-submodule)" +"(lambda(mpi_5)" +"(begin" +" 'module-path-index-submodule" +"(begin" +"(if(1/module-path-index? mpi_5)" +"(void)" +" (let-values () (raise-argument-error 'module-path-index-submodule \"module-path-index?\" mpi_5)))" +"(if(not(module-path-index-path mpi_5))" +"(let-values(((r_14)(module-path-index-resolved mpi_5)))" +"(if r_14(let-values(((p_6)(1/resolved-module-path-name r_14)))(if(pair? p_6)(cdr p_6) #f)) #f))" +" #f)))))" +"(define-values" +"(make-self-module-path-index)" +"(case-lambda" +"((name_9)(begin(module-path-index2.1 #f #f name_9 #f)))" +"((name_10 enclosing_0)" +"(make-self-module-path-index" +"(let-values(((name23_0) name_10)((temp24_1)(if enclosing_0(1/module-path-index-resolve enclosing_0) #f)))" +"(build-module-name18.1 #f #f name23_0 temp24_1))))))" +"(define-values(generic-self-mpis)(make-weak-hash))" +"(define-values(generic-module-name) '|expanded module|)" +"(define-values" +"(make-generic-self-module-path-index)" +"(lambda(self_0)" +"(begin" +"(let-values(((r_15)(resolved-module-path-to-generic-resolved-module-path(module-path-index-resolved self_0))))" +"(let-values(((or-part_48)" +"(let-values(((e_9)(hash-ref generic-self-mpis r_15 #f)))(if e_9(ephemeron-value e_9) #f))))" +"(if or-part_48" +" or-part_48" +"(let-values(((mpi_6)(module-path-index2.1 #f #f r_15 #f)))" +"(begin(hash-set! generic-self-mpis r_15(make-ephemeron r_15 mpi_6)) mpi_6))))))))" +"(define-values" +"(resolved-module-path-to-generic-resolved-module-path)" +"(lambda(r_16)" +"(begin" +"(let-values(((name_11)(1/resolved-module-path-name r_16)))" +"(1/make-resolved-module-path" +"(if(symbol? name_11) generic-module-name(cons generic-module-name(cdr name_11))))))))" +"(define-values" +"(imitate-generic-module-path-index!)" +"(lambda(mpi_7)" +"(begin" +"(let-values(((r_17)(module-path-index-resolved mpi_7)))" +"(if r_17" +"(let-values()" +"(set-module-path-index-resolved! mpi_7(resolved-module-path-to-generic-resolved-module-path r_17)))" +"(void))))))" +"(define-values" +"(module-path-index-shift)" +"(lambda(mpi_8 from-mpi_0 to-mpi_0)" +"(begin" +"(if(eq? mpi_8 from-mpi_0)" +"(let-values() to-mpi_0)" +"(let-values()" +"(let-values(((base_12)(module-path-index-base mpi_8)))" +"(if(not base_12)" +"(let-values() mpi_8)" +"(let-values()" +"(let-values(((shifted-base_0)(module-path-index-shift base_12 from-mpi_0 to-mpi_0)))" +"(if(eq? shifted-base_0 base_12)" +"(let-values() mpi_8)" +"(let-values(((c1_17)(shift-cache-ref(module-path-index-shift-cache shifted-base_0) mpi_8)))" +"(if c1_17" +" c1_17" +"(let-values()" +"(let-values(((shifted-mpi_0)" +"(module-path-index2.1(module-path-index-path mpi_8) shifted-base_0 #f #f)))" +"(begin" +"(shift-cache-set!(module-path-index-shift-cache! shifted-base_0) mpi_8 shifted-mpi_0)" +" shifted-mpi_0)))))))))))))))" +"(define-values" +"(module-path-index-shift-cache!)" +"(lambda(mpi_9)" +"(begin" +"(let-values(((or-part_60)" +"(let-values(((cache_0)(module-path-index-shift-cache mpi_9)))" +"(if cache_0(if(weak-box-value cache_0) cache_0 #f) #f))))" +"(if or-part_60" +" or-part_60" +"(let-values(((cache_1)(make-weak-box(box '#hasheq()))))" +"(begin(set-module-path-index-shift-cache! mpi_9 cache_1) cache_1)))))))" +"(define-values" +"(shift-cache-ref)" +"(lambda(cache_2 v_41)" +"(begin" +"(if cache_2(let-values(((b_13)(weak-box-value cache_2)))(if b_13(hash-ref(unbox b_13) v_41 #f) #f)) #f))))" +"(define-values" +"(shift-cache-set!)" +"(lambda(cache_3 v_42 r_18)" +"(begin" +"(let-values(((b_14)(weak-box-value cache_3)))" +"(if b_14(let-values()(set-box! b_14(hash-set(unbox b_14) v_42 r_18)))(void))))))" +"(define-values(top-level-module-path-index)(make-self-module-path-index(1/make-resolved-module-path 'top-level)))" +"(define-values(top-level-module-path-index?)(lambda(mpi_10)(begin(eq? top-level-module-path-index mpi_10))))" +"(define-values" +"(core-module-name-resolver)" +"(case-lambda" +"((name_12 from-namespace_0)(begin(void)))" +"((p_7 enclosing_1 source-stx-stx_0 load?_2)" +"(begin" +"(if(1/module-path? p_7)" +"(void)" +" (let-values () (raise-argument-error 'core-module-name-resolver \"module-path?\" p_7)))" +"(if(let-values(((or-part_52)(not enclosing_1)))" +"(if or-part_52 or-part_52(1/resolved-module-path? enclosing_1)))" +"(void)" +" (let-values () (raise-argument-error 'core-module-name-resolver \"resolved-module-path?\" enclosing_1)))" +"(if(if(list? p_7)(if(=(length p_7) 2)(if(eq? 'quote(car p_7))(symbol?(cadr p_7)) #f) #f) #f)" +"(let-values()(1/make-resolved-module-path(cadr p_7)))" +" (if (if (list? p_7) (if (eq? 'submod (car p_7)) (equal? \"..\" (cadr p_7)) #f) #f)" +"(let-values()" +"(let-values(((lst_28)(cdr p_7)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_28)))" +"((letrec-values(((for-loop_23)" +"(lambda(enclosing_2 lst_29)" +"(begin" +" 'for-loop" +"(if(pair? lst_29)" +"(let-values(((s_36)(unsafe-car lst_29))((rest_11)(unsafe-cdr lst_29)))" +"(let-values(((enclosing_3)" +"(let-values(((enclosing_4) enclosing_2))" +"(let-values(((enclosing_5)" +"(let-values()" +"(let-values(((p27_0) p_7))" +"(build-module-name18.1" +" p27_0" +" #t" +" s_36" +" enclosing_4)))))" +"(values enclosing_5)))))" +"(if(not #f)(for-loop_23 enclosing_3 rest_11) enclosing_3)))" +" enclosing_2)))))" +" for-loop_23)" +" enclosing_1" +" lst_28))))" +" (if (if (list? p_7) (if (eq? 'submod (car p_7)) (equal? \".\" (cadr p_7)) #f) #f)" +"(let-values()" +"(let-values(((lst_30)(cddr p_7)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_30)))" +"((letrec-values(((for-loop_24)" +"(lambda(enclosing_6 lst_31)" +"(begin" +" 'for-loop" +"(if(pair? lst_31)" +"(let-values(((s_37)(unsafe-car lst_31))((rest_12)(unsafe-cdr lst_31)))" +"(let-values(((enclosing_7)" +"(let-values(((enclosing_8) enclosing_6))" +"(let-values(((enclosing_9)" +"(let-values()" +"(let-values(((p30_0) p_7))" +"(build-module-name18.1" +" p30_0" +" #t" +" s_37" +" enclosing_8)))))" +"(values enclosing_9)))))" +"(if(not #f)(for-loop_24 enclosing_7 rest_12) enclosing_7)))" +" enclosing_6)))))" +" for-loop_24)" +" enclosing_1" +" lst_30))))" +"(if(if(list? p_7)(eq? 'submod(car p_7)) #f)" +"(let-values()" +"(let-values(((base_13)((1/current-module-name-resolver)(cadr p_7) enclosing_1 #f #f)))" +"(let-values(((lst_32)(cddr p_7)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_32)))" +"((letrec-values(((for-loop_25)" +"(lambda(enclosing_10 lst_33)" +"(begin" +" 'for-loop" +"(if(pair? lst_33)" +"(let-values(((s_38)(unsafe-car lst_33))((rest_13)(unsafe-cdr lst_33)))" +"(let-values(((enclosing_11)" +"(let-values(((enclosing_12) enclosing_10))" +"(let-values(((enclosing_13)" +"(let-values()" +"(let-values(((p33_0) p_7))" +"(build-module-name18.1" +" p33_0" +" #t" +" s_38" +" enclosing_12)))))" +"(values enclosing_13)))))" +"(if(not #f)(for-loop_25 enclosing_11 rest_13) enclosing_11)))" +" enclosing_10)))))" +" for-loop_25)" +" base_13" +" lst_32)))))" +" (let-values () (error 'core-module-name-resolver \"not a supported module path: ~v\" p_7))))))))))" +"(define-values" +"(build-module-name18.1)" +"(lambda(original14_0 original15_0 name16_0 enclosing17_0)" +"(begin" +" 'build-module-name18" +"(let-values(((name_13) name16_0))" +"(let-values(((enclosing_14) enclosing17_0))" +"(let-values(((orig-name_0)(if original15_0 original14_0 name_13)))" +"(let-values()" +"(let-values(((enclosing-module-name_0)(if enclosing_14(1/resolved-module-path-name enclosing_14) #f)))" +"(1/make-resolved-module-path" +"(if(not enclosing-module-name_0)" +"(let-values() name_13)" +"(if(symbol? enclosing-module-name_0)" +"(let-values()(list enclosing-module-name_0 name_13))" +" (if (equal? name_13 \"..\")" +"(let-values()" +"(if(symbol? enclosing-module-name_0)" +" (let-values () (error \"too many \\\"..\\\"s:\" orig-name_0))" +"(if(= 2(length enclosing-module-name_0))" +"(let-values()(car enclosing-module-name_0))" +"(let-values()(reverse$1(cdr(reverse$1 enclosing-module-name_0)))))))" +"(let-values()(append enclosing-module-name_0(list name_13)))))))))))))))" +"(define-values" +"(1/current-module-name-resolver)" +"(make-parameter" +" core-module-name-resolver" +"(lambda(v_43)" +"(begin" +"(if(if(procedure? v_43)(if(procedure-arity-includes? v_43 2)(procedure-arity-includes? v_43 4) #f) #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-module-name-resolver" +" \"(and/c (procedure-arity-includes/c 2) (procedure-arity-includes/c 4))\"" +" v_43)))" +" v_43))))" +"(define-values" +"(1/current-module-declare-name)" +"(make-parameter" +" #f" +"(lambda(r_19)" +"(begin" +"(if(let-values(((or-part_61)(not r_19)))(if or-part_61 or-part_61(1/resolved-module-path? r_19)))" +"(void)" +" (let-values () (raise-argument-error 'current-module-declare-name \"(or/c #f resolved-module-path?)\" r_19)))" +" r_19))))" +"(define-values" +"(1/current-module-declare-source)" +"(make-parameter" +" #f" +"(lambda(s_39)" +"(begin" +"(if(let-values(((or-part_62)(not s_39)))" +"(if or-part_62" +" or-part_62" +"(let-values(((or-part_63)(symbol? s_39)))" +"(if or-part_63 or-part_63(if(path? s_39)(complete-path? s_39) #f)))))" +"(void)" +"(let-values()" +" (raise-argument-error 'current-module-declare-source \"(or/c #f symbol? (and/c path? complete-path?))\" s_39)))" +" s_39))))" +"(define-values" +"(substitute-module-declare-name)" +"(lambda(default-name_0)" +"(begin" +"(let-values(((current-name_0)(1/current-module-declare-name)))" +"(let-values(((root-name_1)" +"(if current-name_0" +"(resolved-module-path-root-name current-name_0)" +"(if(pair? default-name_0)(car default-name_0) default-name_0))))" +"(1/make-resolved-module-path" +"(if(pair? default-name_0)(cons root-name_1(cdr default-name_0)) root-name_1)))))))" +"(define-values" +"(force/composable)" +"(lambda(root_1)" +"(begin" +"(let-values(((v_44)(unsafe-struct-ref root_1 0)))" +"(if(procedure? v_44)" +"(let-values()" +"(begin" +"(unsafe-struct-set! root_1 0(make-running(object-name v_44)))" +"(call-with-exception-handler" +"(lambda(e_10)(begin(unsafe-struct-set! root_1 0(make-reraise e_10)) e_10))" +"(lambda()" +"((letrec-values(((loop_60)" +"(lambda(v_45)" +"(begin" +" 'loop" +"(if(composable-promise? v_45)" +"(let-values()" +"(let-values(((v*_0)(unsafe-struct-ref v_45 0)))" +"(begin" +"(unsafe-struct-set! v_45 0 root_1)" +"(if(procedure? v*_0)" +"(let-values()(loop_60(v*_0)))" +"(if(pair? v*_0)" +"(let-values()" +"(begin(unsafe-struct-set! root_1 0 v*_0)(unsafe-car v*_0)))" +"(let-values()(loop_60 v*_0)))))))" +"(if(promise? v_45)" +"(let-values()(begin(unsafe-struct-set! root_1 0 v_45)(force v_45)))" +"(let-values()(begin(unsafe-struct-set! root_1 0(list v_45)) v_45))))))))" +" loop_60)" +"(v_44))))))" +"(if(pair? v_44)" +"(let-values()(if(null?(unsafe-cdr v_44))(unsafe-car v_44)(apply values v_44)))" +"(if(composable-promise? v_44)" +"(let-values()(force/composable v_44))" +"(if(null? v_44)" +"(let-values()(values))" +"(if(promise? v_44)" +"(let-values()(force v_44))" +" (let-values () (error 'force \"composable promise with invalid contents: ~e\" v_44)))))))))))" +"(define-values" +"(reify-result)" +"(lambda(v_46)" +"(begin" +"(if(pair? v_46)" +"(let-values()(if(null?(unsafe-cdr v_46))(unsafe-car v_46)(apply values v_46)))" +"(if(null? v_46)" +"(let-values()(values))" +"(if(reraise? v_46)" +"(let-values()(v_46))" +" (let-values () (error 'force \"promise with invalid contents: ~e\" v_46))))))))" +"(define-values" +"(force/generic)" +"(lambda(promise_0)" +"(begin" +"(reify-result" +"(let-values(((v_47)(unsafe-struct-ref promise_0 0)))" +"(if(procedure? v_47)" +"(begin" +"(unsafe-struct-set! promise_0 0(make-running(object-name v_47)))" +"(call-with-exception-handler" +"(lambda(e_11)(begin(unsafe-struct-set! promise_0 0(make-reraise e_11)) e_11))" +"(lambda()" +"(let-values(((vs_0)(call-with-values v_47 list)))" +"(begin(unsafe-struct-set! promise_0 0 vs_0) vs_0)))))" +" v_47))))))" +"(define-values" +"(force)" +"(lambda(promise_1)(begin(if(promise? promise_1)((promise-forcer promise_1) promise_1) promise_1))))" +"(define-values" +"(promise-printer)" +"(lambda(promise_2 port_2 write?_0)" +"(begin" +"((letrec-values(((loop_47)" +"(lambda(v_48)" +"(begin" +" 'loop" +"(if(reraise? v_48)" +"(let-values()" +"(let-values(((r_20)(reraise-val v_48)))" +"(if(exn? r_20)" +"(fprintf" +" port_2" +" (if write?_0 \"#\" \"#\")" +"(exn-message r_20))" +" (fprintf port_2 (if write?_0 \"#\" \"#\") r_20))))" +"(if(running? v_48)" +"(let-values()" +"(let-values(((r_21)(running-name v_48)))" +"(if r_21" +" (fprintf port_2 \"#\" r_21)" +" (fprintf port_2 \"#\"))))" +"(if(procedure? v_48)" +"(let-values()" +"(let-values(((c1_18)(object-name v_48)))" +"(if c1_18" +" ((lambda (n_18) (fprintf port_2 \"#\" n_18)) c1_18)" +" (let-values () (display \"#\" port_2)))))" +"(if(promise? v_48)" +"(let-values()(loop_47(unsafe-struct-ref v_48 0)))" +"(if(null? v_48)" +" (let-values () (fprintf port_2 \"#\"))" +"(if(null?(cdr v_48))" +"(let-values()" +" (fprintf port_2 (if write?_0 \"#\" \"#\") (car v_48)))" +"(let-values()" +"(begin" +" (display \"#\" port_2)))))))))))))" +" loop_47)" +"(unsafe-struct-ref promise_2 0)))))" +"(define-values" +"(prop:force promise-forcer)" +"(let-values(((prop_0 pred?_0 get_0)" +"(make-struct-type-property" +" 'forcer" +"(lambda(v_49 info_0)" +"(begin" +"(if(if(procedure? v_49)(procedure-arity-includes? v_49 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'prop:force \"(any/c . -> . any)\" v_49)))" +" v_49))" +" null" +" #t)))" +"(values prop_0 get_0)))" +"(define-values" +"(struct:promise make-promise promise? promise-val set-promise-val!)" +"(let-values(((struct:_3 make-_3 ?_3 -ref_3 -set!_3)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:force force/generic)(cons prop:custom-write promise-printer))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise)))))" +"(values" +" struct:_3" +" make-_3" +" ?_3" +"(make-struct-field-accessor -ref_3 0 'val)" +"(make-struct-field-mutator -set!_3 0 'val))))" +"(define-values" +"(struct:composable-promise make-composable-promise composable-promise?)" +"(let-values(((struct:_4 make-_4 ?_4 -ref_4 -set!_4)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'composable-promise" +" struct:promise" +" 0" +" 0" +" #f" +"(list(cons prop:force force/composable))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'composable-promise)))))" +"(values struct:_4 make-_4 ?_4)))" +"(define-values(delay) make-promise)" +"(define-values" +"(struct:reraise make-reraise reraise? reraise-val)" +"(let-values(((struct:_5 make-_5 ?_5 -ref_5 -set!_5)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'reraise" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:procedure(lambda(this_0)(raise(reraise-val this_0)))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'reraise)))))" +"(values struct:_5 make-_5 ?_5(make-struct-field-accessor -ref_5 0 'val))))" +"(define-values" +"(struct:running make-running running? running-name)" +"(let-values(((struct:_6 make-_6 ?_6 -ref_6 -set!_6)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'running" +" #f" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:custom-write" +"(lambda(this_1 port_3 write?_1)" +" (fprintf port_3 (if write?_1 \"#\" \"#\") (running-name this_1))))" +"(cons" +" prop:procedure" +"(lambda(this_2)" +"(let-values(((name_14)(running-name this_2)))" +"(if name_14" +" (error 'force \"reentrant promise `~.s'\" name_14)" +" (error 'force \"reentrant promise\"))))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'running)))))" +"(values struct:_6 make-_6 ?_6(make-struct-field-accessor -ref_6 0 'name))))" +"(define-values" +"(struct:promise/name make-promise/name promise/name?)" +"(let-values(((struct:_7 make-_7 ?_7 -ref_7 -set!_7)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/name" +" struct:promise" +" 0" +" 0" +" #f" +"(list(cons prop:force(lambda(p_8)((unsafe-struct-ref p_8 0)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/name)))))" +"(values struct:_7 make-_7 ?_7)))" +"(define-values" +"(struct:promise/strict make-promise/strict promise/strict?)" +"(let-values(((struct:_8 make-_8 ?_8 -ref_8 -set!_8)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/strict" +" struct:promise" +" 0" +" 0" +" #f" +"(list(cons prop:force(lambda(p_9)(reify-result(unsafe-struct-ref p_9 0)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/strict)))))" +"(values struct:_8 make-_8 ?_8)))" +"(define-values" +"(struct:running-thread make-running-thread running-thread? running-thread-thread)" +"(let-values(((struct:_9 make-_9 ?_9 -ref_9 -set!_9)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'running-thread" +" struct:running" +" 1" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'running-thread)))))" +"(values struct:_9 make-_9 ?_9(make-struct-field-accessor -ref_9 0 'thread))))" +"(define-values" +"(struct:syncinfo" +" make-syncinfo" +" syncinfo?" +" syncinfo-thunk" +" syncinfo-done-evt" +" syncinfo-done-sema" +" syncinfo-access-sema" +" set-syncinfo-thunk!)" +"(let-values(((struct:_10 make-_10 ?_10 -ref_10 -set!_10)" +"(let-values()" +"(let-values()" +"(make-struct-type 'syncinfo #f 4 0 #f null(current-inspector) #f '(1 2 3) #f 'syncinfo)))))" +"(values" +" struct:_10" +" make-_10" +" ?_10" +"(make-struct-field-accessor -ref_10 0 'thunk)" +"(make-struct-field-accessor -ref_10 1 'done-evt)" +"(make-struct-field-accessor -ref_10 2 'done-sema)" +"(make-struct-field-accessor -ref_10 3 'access-sema)" +"(make-struct-field-mutator -set!_10 0 'thunk))))" +"(define-values" +"(struct:promise/sync make-promise/sync promise/sync?)" +"(let-values(((struct:_11 make-_11 ?_11 -ref_11 -set!_11)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/sync" +" struct:promise" +" 0" +" 0" +" #f" +"(list" +"(cons" +" prop:evt" +"(lambda(p_10)" +"(let-values(((v_50)(unsafe-struct-ref p_10 0)))" +"(wrap-evt(if(syncinfo? v_50)(syncinfo-done-evt v_50) always-evt) void))))" +"(cons" +" prop:force" +"(lambda(p_11)" +"(let-values(((v_48)(unsafe-struct-ref p_11 0)))" +"(reify-result" +"(if(not(syncinfo? v_48))" +"(let-values() v_48)" +"(if(running-thread?(syncinfo-thunk v_48))" +"(let-values()" +"(let-values(((r_20)(syncinfo-thunk v_48)))" +"(if(eq?(running-thread-thread r_20)(current-thread))" +"(r_20)" +"(begin(sync(syncinfo-done-evt v_48))(unsafe-struct-ref p_11 0)))))" +"(let-values()" +"(begin" +"(call-with-semaphore" +"(syncinfo-access-sema v_48)" +"(lambda(p_12 v_51)" +"(let-values(((thunk_2)(syncinfo-thunk v_51)))" +"(let-values(((done_0)(syncinfo-done-sema v_51)))" +"(if(running-thread? thunk_2)" +"(void)" +"(let-values()" +"(begin" +"(set-syncinfo-thunk!" +" v_51" +"(make-running-thread(object-name thunk_2)(current-thread)))" +"(call-with-exception-handler" +"(lambda(e_12)" +"(begin" +"(unsafe-struct-set! p_12 0(make-reraise e_12))" +"(semaphore-post done_0)" +" e_12))" +"(lambda()" +"(begin" +"(unsafe-struct-set! p_12 0(call-with-values thunk_2 list))" +"(semaphore-post done_0))))))))))" +" #f" +" p_11" +" v_48)" +"(unsafe-struct-ref p_11 0)))))))))" +"(cons" +" prop:custom-write" +"(lambda(p_13 port_4 write?_2)" +"(let-values(((v_49)(unsafe-struct-ref p_13 0)))" +"(promise-printer" +"(if(syncinfo? v_49)(make-promise(syncinfo-thunk v_49)) p_13)" +" port_4" +" write?_2)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/sync)))))" +"(values struct:_11 make-_11 ?_11)))" +"(define-values" +"(struct:promise/thread make-promise/thread promise/thread?)" +"(let-values(((struct:_12 make-_12 ?_12 -ref_12 -set!_12)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/thread" +" struct:promise" +" 0" +" 0" +" #f" +"(list" +"(cons" +" prop:evt" +"(lambda(p_14)" +"(let-values(((v_52)(unsafe-struct-ref p_14 0)))" +"(wrap-evt(if(running? v_52)(running-thread-thread v_52) always-evt) void))))" +"(cons" +" prop:force" +"(lambda(p_15)" +"(let-values(((v_25)(unsafe-struct-ref p_15 0)))" +"(reify-result" +"(if(running-thread? v_25)" +"(let-values(((t_8)(running-thread-thread v_25)))" +"(let-values((()(begin(thread-wait t_8)(values))))" +"(let-values(((v_53)(unsafe-struct-ref p_15 0)))" +"(if(running-thread? v_53)" +"(error" +" 'force" +" \"promise's thread terminated ~a\\n promise: ~e\"" +" \"without result or exception\"" +" p_15)" +" v_53))))" +" v_25))))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/thread)))))" +"(values struct:_12 make-_12 ?_12)))" +"(define-values" +"(struct:promise/idle make-promise/idle promise/idle?)" +"(let-values(((struct:_13 make-_13 ?_13 -ref_13 -set!_13)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'promise/idle" +" struct:promise/thread" +" 0" +" 0" +" #f" +"(list" +"(cons" +" prop:force" +"(lambda(p_16)" +"(let-values(((v_54)(unsafe-struct-ref p_16 0)))" +"(reify-result" +"(if(procedure? v_54)" +"(let-values(((controller_0)" +"(if(running-thread? v_54)(running-thread-thread v_54)(v_54))))" +"(begin" +"(thread-send controller_0 'force!)" +"(thread-wait controller_0)" +"(unsafe-struct-ref p_16 0)))" +" v_54))))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'promise/idle)))))" +"(values struct:_13 make-_13 ?_13)))" +"(define-values" +"(phase?)" +"(lambda(v_26)(begin(let-values(((or-part_0)(not v_26)))(if or-part_0 or-part_0(exact-integer? v_26))))))" +"(define-values(phase+)(lambda(a_1 b_15)(begin(if a_1(if b_15(+ a_1 b_15) #f) #f))))" +"(define-values(phase-)(lambda(a_28 b_16)(begin(if a_28(if b_16(- a_28 b_16) #f) #f))))" +"(define-values" +"(phaseimmutable-vector" +"(let-values(((len_7)(vector-length s_41)))" +"(begin" +"(if(exact-nonnegative-integer? len_7)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/vector" +" \"exact-nonnegative-integer?\"" +" len_7)))" +"(let-values(((v_58)(make-vector len_7 0)))" +"(begin" +"(if(zero? len_7)" +"(void)" +"(let-values()" +"(let-values(((vec_14 len_8)" +"(let-values(((vec_15) s_41))" +"(begin" +"(check-vector vec_15)" +"(values" +" vec_15" +"(unsafe-vector-length vec_15))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_26)" +"(lambda(i_38 pos_6)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_6 len_8)" +"(let-values(((e_13)" +"(unsafe-vector-ref" +" vec_14" +" pos_6)))" +"(let-values(((i_39)" +"(let-values(((i_40)" +" i_38))" +"(let-values(((i_41)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_58" +" i_40" +"(let-values()" +"(loop_61" +" #f" +" e_13" +" seen_1)))" +"(unsafe-fx+" +" 1" +" i_40)))))" +"(values i_41)))))" +"(if(if(not" +"((lambda x_22" +"(unsafe-fx=" +" i_39" +" len_7))" +" e_13))" +"(not #f)" +" #f)" +"(for-loop_26" +" i_39" +"(unsafe-fx+ 1 pos_6))" +" i_39)))" +" i_38)))))" +" for-loop_26)" +" 0" +" 0)))))" +" v_58)))))))" +"(if(box? s_41)" +"(let-values()(f_19 #f(box-immutable(loop_61 #f(unbox s_41) seen_1))))" +"(let-values(((c1_20)(immutable-prefab-struct-key s_41)))" +"(if c1_20" +"((lambda(key_13)" +"(f_19" +" #f" +"(apply" +" make-prefab-struct" +" key_13" +"(reverse$1" +"(let-values(((v*_1 start*_0 stop*_1 step*_0)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_23)(vector? x_23))" +"(lambda(x_24)(unsafe-vector-length x_24))" +"(struct->vector s_41)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_27)" +"(lambda(fold-var_17 idx_0)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< idx_0 stop*_1)" +"(let-values(((e_14)" +"(unsafe-vector-ref" +" v*_1" +" idx_0)))" +"(let-values(((fold-var_18)" +"(let-values(((fold-var_19)" +" fold-var_17))" +"(let-values(((fold-var_20)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_61" +" #f" +" e_14" +" seen_1))" +" fold-var_19))))" +"(values" +" fold-var_20)))))" +"(if(not #f)" +"(for-loop_27" +" fold-var_18" +"(unsafe-fx+ idx_0 1))" +" fold-var_18)))" +" fold-var_17)))))" +" for-loop_27)" +" null" +" start*_0)))))))" +" c1_20)" +"(if(if(hash? s_41)(immutable? s_41) #f)" +"(let-values()" +"(if(hash-eq? s_41)" +"(let-values()" +"(f_19" +" #f" +"(let-values(((ht_28) s_41))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_28)))" +"((letrec-values(((for-loop_28)" +"(lambda(table_15 i_42)" +"(begin" +" 'for-loop" +"(if i_42" +"(let-values(((k_10 v_59)" +"(hash-iterate-key+value" +" ht_28" +" i_42)))" +"(let-values(((table_16)" +"(let-values(((table_17)" +" table_15))" +"(let-values(((table_18)" +"(let-values()" +"(let-values(((key_14" +" val_4)" +"(let-values()" +"(values" +" k_10" +"(loop_61" +" #f" +" v_59" +" seen_1)))))" +"(hash-set" +" table_17" +" key_14" +" val_4)))))" +"(values" +" table_18)))))" +"(if(not #f)" +"(for-loop_28" +" table_16" +"(hash-iterate-next ht_28 i_42))" +" table_16)))" +" table_15)))))" +" for-loop_28)" +" '#hasheq()" +"(hash-iterate-first ht_28))))))" +"(if(hash-eqv? s_41)" +"(let-values()" +"(f_19" +" #f" +"(let-values(((ht_29) s_41))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_29)))" +"((letrec-values(((for-loop_29)" +"(lambda(table_19 i_43)" +"(begin" +" 'for-loop" +"(if i_43" +"(let-values(((k_11 v_60)" +"(hash-iterate-key+value" +" ht_29" +" i_43)))" +"(let-values(((table_20)" +"(let-values(((table_21)" +" table_19))" +"(let-values(((table_22)" +"(let-values()" +"(let-values(((key_15" +" val_5)" +"(let-values()" +"(values" +" k_11" +"(loop_61" +" #f" +" v_60" +" seen_1)))))" +"(hash-set" +" table_21" +" key_15" +" val_5)))))" +"(values" +" table_22)))))" +"(if(not #f)" +"(for-loop_29" +" table_20" +"(hash-iterate-next" +" ht_29" +" i_43))" +" table_20)))" +" table_19)))))" +" for-loop_29)" +" '#hasheqv()" +"(hash-iterate-first ht_29))))))" +"(let-values()" +"(f_19" +" #f" +"(let-values(((ht_30) s_41))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_30)))" +"((letrec-values(((for-loop_30)" +"(lambda(table_23 i_27)" +"(begin" +" 'for-loop" +"(if i_27" +"(let-values(((k_12 v_61)" +"(hash-iterate-key+value" +" ht_30" +" i_27)))" +"(let-values(((table_10)" +"(let-values(((table_11)" +" table_23))" +"(let-values(((table_12)" +"(let-values()" +"(let-values(((key_16" +" val_6)" +"(let-values()" +"(values" +" k_12" +"(loop_61" +" #f" +" v_61" +" seen_1)))))" +"(hash-set" +" table_11" +" key_16" +" val_6)))))" +"(values" +" table_12)))))" +"(if(not #f)" +"(for-loop_30" +" table_10" +"(hash-iterate-next" +" ht_30" +" i_27))" +" table_10)))" +" table_23)))))" +" for-loop_30)" +" '#hash()" +"(hash-iterate-first ht_30)))))))))" +"(let-values()(f_19 #f s_41)))))))))))))))" +" loop_61)" +" tail?_0" +" s_40" +" seen_0))))" +"(define-values" +"(datum-has-elements?)" +"(lambda(d_0)" +"(begin" +"(let-values(((or-part_72)(pair? d_0)))" +"(if or-part_72" +" or-part_72" +"(let-values(((or-part_73)(vector? d_0)))" +"(if or-part_73" +" or-part_73" +"(let-values(((or-part_74)(box? d_0)))" +"(if or-part_74" +" or-part_74" +"(let-values(((or-part_75)(immutable-prefab-struct-key d_0)))" +"(if or-part_75" +" or-part_75" +"(if(hash? d_0)(if(immutable? d_0)(positive?(hash-count d_0)) #f) #f))))))))))))" +"(define-values" +"(struct:preserved-property-value" +" preserved-property-value1.1" +" preserved-property-value?" +" preserved-property-value-content)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'preserved-property-value" +" #f" +" 1" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'preserved-property-value)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'content))))" +"(define-values" +"(plain-property-value)" +"(lambda(v_62)(begin(if(preserved-property-value? v_62)(preserved-property-value-content v_62) v_62))))" +"(define-values" +"(check-value-to-preserve)" +"(lambda(v_63 syntax?_0)" +"(begin" +"(let-values(((s_4) v_63)" +"((f_20)" +"(lambda(tail?_0 v_3)" +"(begin" +" 'f" +"(begin" +"(if(let-values(((or-part_76)(null? v_3)))" +"(if or-part_76" +" or-part_76" +"(let-values(((or-part_77)(boolean? v_3)))" +"(if or-part_77" +" or-part_77" +"(let-values(((or-part_29)(symbol? v_3)))" +"(if or-part_29" +" or-part_29" +"(let-values(((or-part_78)(number? v_3)))" +"(if or-part_78" +" or-part_78" +"(let-values(((or-part_79)(char? v_3)))" +"(if or-part_79" +" or-part_79" +"(let-values(((or-part_80)(string? v_3)))" +"(if or-part_80" +" or-part_80" +"(let-values(((or-part_81)(bytes? v_3)))" +"(if or-part_81" +" or-part_81" +"(let-values(((or-part_70)(regexp? v_3)))" +"(if or-part_70" +" or-part_70" +"(let-values(((or-part_71)(syntax?_0 v_3)))" +"(if or-part_71" +" or-part_71" +"(let-values(((or-part_82)(pair? v_3)))" +"(if or-part_82" +" or-part_82" +"(let-values(((or-part_83)(vector? v_3)))" +"(if or-part_83" +" or-part_83" +"(let-values(((or-part_84)(box? v_3)))" +"(if or-part_84" +" or-part_84" +"(let-values(((or-part_85)(hash? v_3)))" +"(if or-part_85" +" or-part_85" +"(immutable-prefab-struct-key" +" v_3)))))))))))))))))))))))))))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'write" +" \"disallowed value in preserved syntax property\"" +" \"value\"" +" v_3)))" +" v_3))))" +"((seen_2) disallow-cycles$1))" +"((letrec-values(((loop_62)" +"(lambda(tail?_2 s_7 prev-depth_0)" +"(begin" +" 'loop" +"(let-values(((depth_0)(add1 prev-depth_0)))" +"(if(if seen_2(> depth_0 32) #f)" +"(let-values()" +"(datum-map-slow tail?_2 s_7(lambda(tail?_3 s_42)(f_20 tail?_3 s_42)) seen_2))" +"(if(null? s_7)" +"(let-values()(f_20 tail?_2 s_7))" +"(if(pair? s_7)" +"(let-values()" +"(f_20" +" tail?_2" +"(cons(loop_62 #f(car s_7) depth_0)(loop_62 #t(cdr s_7) depth_0))))" +"(if(let-values(((or-part_32)(symbol? s_7)))" +"(if or-part_32" +" or-part_32" +"(let-values(((or-part_55)(boolean? s_7)))" +"(if or-part_55 or-part_55(number? s_7)))))" +"(let-values()(f_20 #f s_7))" +"(if(let-values(((or-part_56)(vector? s_7)))" +"(if or-part_56" +" or-part_56" +"(let-values(((or-part_7)(box? s_7)))" +"(if or-part_7" +" or-part_7" +"(let-values(((or-part_8)(prefab-struct-key s_7)))" +"(if or-part_8 or-part_8(hash? s_7)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_2" +" s_7" +"(lambda(tail?_4 s_43)(f_20 tail?_4 s_43))" +" seen_2))" +"(let-values()(f_20 #f s_7))))))))))))" +" loop_62)" +" #f" +" s_4" +" 0)))))" +"(define-values" +"(disallow-cycles$1)" +"(hash" +" 'cycle-fail" +" (lambda (v_64) (raise-arguments-error 'write \"disallowed cycle in preserved syntax property\" \"at\" v_64))))" +"(define-values" +"(tamper?)" +"(lambda(v_26)" +"(begin" +"(let-values(((or-part_0)(not v_26)))" +"(if or-part_0 or-part_0(let-values(((or-part_1)(symbol? v_26)))(if or-part_1 or-part_1(set? v_26))))))))" +"(define-values(tamper-tainted?)(lambda(v_65)(begin(symbol? v_65))))" +"(define-values(tamper-armed?)(lambda(v_66)(begin(set? v_66))))" +"(define-values(tamper-clean?)(lambda(v_67)(begin(not v_67))))" +"(define-values" +"(tamper-tainted-for-content)" +"(lambda(v_68)(begin(if(datum-has-elements? v_68) 'tainted/need-propagate 'tainted))))" +"(define-values(tamper-needs-propagate?)(lambda(t_12)(begin(eq? t_12 'tainted/need-propagate))))" +"(define-values(tamper-propagated)(lambda(t_13)(begin(if(eq? t_13 'tainted/need-propagate) 'tainted t_13))))" +"(define-values(serialize-tamper)(lambda(t_14)(begin(if(tamper-armed? t_14) 'armed t_14))))" +"(define-values(current-arm-inspectors)(make-parameter(seteq)))" +"(define-values(deserialize-tamper)(lambda(t_15)(begin(if(eq? t_15 'armed)(current-arm-inspectors) t_15))))" +"(define-values" +"(struct:syntax" +" syntax1.1" +" syntax?$1" +" syntax-content" +" syntax-scopes" +" syntax-shifted-multi-scopes" +" syntax-scope-propagations+tamper" +" syntax-mpi-shifts" +" syntax-srcloc" +" syntax-props" +" syntax-inspector" +" set-syntax-content!" +" set-syntax-scope-propagations+tamper!)" +"(let-values(((struct:_14 make-_14 ?_14 -ref_14 -set!_14)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'syntax" +" #f" +" 8" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:reach-scopes" +"(lambda(s_44 reach_0)" +"(let-values(((prop_1)(syntax-scope-propagations+tamper s_44)))" +"(begin" +"(reach_0" +"(if(propagation?$1 prop_1)((propagation-ref prop_1) s_44)(syntax-content s_44)))" +"(reach_0(syntax-scopes s_44))" +"(reach_0(syntax-shifted-multi-scopes s_44))" +"(let-values(((ht_31)(syntax-props s_44)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_31)))" +"((letrec-values(((for-loop_31)" +"(lambda(i_44)" +"(begin" +" 'for-loop" +"(if i_44" +"(let-values(((k_13 v_69)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_31" +" i_44)))" +"(let-values((()" +"(let-values()" +"(if(preserved-property-value? v_69)" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(reach_0" +"(plain-property-value" +" v_69)))" +"(values)))))" +"(values)))" +"(values)))))" +"(if(not #f)" +"(for-loop_31" +"(unsafe-immutable-hash-iterate-next ht_31 i_44))" +"(values))))" +"(values))))))" +" for-loop_31)" +"(unsafe-immutable-hash-iterate-first ht_31))))" +"(void)" +"(reach_0(syntax-srcloc s_44))))))" +"(cons" +" prop:serialize" +"(lambda(s_45 ser-push!_1 state_9)" +"(let-values(((prop_2)(syntax-scope-propagations+tamper s_45)))" +"(let-values(((content_0)" +"(if(propagation?$1 prop_2)" +"((propagation-ref prop_2) s_45)" +"(syntax-content s_45))))" +"(let-values(((properties_0)" +"(intern-properties" +"(syntax-props s_45)" +"(lambda()" +"(let-values(((ht_32)(syntax-props s_45)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_32)))" +"((letrec-values(((for-loop_32)" +"(lambda(table_24 i_29)" +"(begin" +" 'for-loop" +"(if i_29" +"(let-values(((k_14 v_70)" +"(hash-iterate-key+value" +" ht_32" +" i_29)))" +"(let-values(((table_25)" +"(let-values(((table_26)" +" table_24))" +"(if(preserved-property-value?" +" v_70)" +"(let-values(((table_27)" +" table_26))" +"(let-values(((table_28)" +"(let-values()" +"(let-values(((key_17" +" val_7)" +"(let-values()" +"(values" +" k_14" +"(check-value-to-preserve" +"(plain-property-value" +" v_70)" +" syntax?$1)))))" +"(hash-set" +" table_27" +" key_17" +" val_7)))))" +"(values table_28)))" +" table_26))))" +"(if(not #f)" +"(for-loop_32" +" table_25" +"(hash-iterate-next ht_32 i_29))" +" table_25)))" +" table_24)))))" +" for-loop_32)" +" '#hasheq()" +"(hash-iterate-first ht_32)))))" +" state_9)))" +"(let-values(((tamper_0)(serialize-tamper(syntax-tamper s_45))))" +"(let-values(((context-triple_0)" +"(intern-context-triple" +"(intern-scopes(syntax-scopes s_45) state_9)" +"(intern-shifted-multi-scopes(syntax-shifted-multi-scopes s_45) state_9)" +"(intern-mpi-shifts(syntax-mpi-shifts s_45) state_9)" +" state_9)))" +"(let-values(((stx-state_0)(get-syntax-context state_9)))" +"(if(let-values(((or-part_40) properties_0))(if or-part_40 or-part_40 tamper_0))" +"(let-values()" +"(begin" +"(ser-push!_1 'tag '#:syntax+props)" +"(push-syntax-context! state_9 #f)" +"(ser-push!_1 content_0)" +"(pop-syntax-context! state_9)" +"(ser-push!_1 'reference context-triple_0)" +"(ser-push!_1 'reference(syntax-srcloc s_45))" +"(ser-push!_1 properties_0)" +"(ser-push!_1 tamper_0)" +"(if stx-state_0" +"(let-values()(set-syntax-state-all-sharing?! stx-state_0 #f))" +"(void))))" +"(let-values()" +"(let-values(((sharing-mode_0)" +"(hash-ref" +"(serialize-state-sharing-syntaxes state_9)" +" s_45" +" 'unknown)))" +"(begin" +"(if(eq? sharing-mode_0 'share)" +"(let-values()" +"(begin" +"(ser-push!_1 'tag '#:datum->syntax)" +"(ser-push!_1(syntax->datum$1 s_45))))" +"(if(eq? sharing-mode_0 'unknown)" +"(let-values()" +"(let-values((()(begin(ser-push!_1 'tag '#:syntax)(values))))" +"(let-values(((this-state_0)" +"(if(no-pair-syntax-in-cdr? content_0)" +"(syntax-state19.1" +" #t" +" context-triple_0" +"(syntax-srcloc s_45))" +" #f)))" +"(let-values((()" +"(begin" +"(push-syntax-context! state_9 this-state_0)" +"(values))))" +"(let-values((()(begin(ser-push!_1 content_0)(values))))" +"(let-values((()" +"(begin" +"(pop-syntax-context! state_9)" +"(values))))" +"(let-values(((new-sharing-mode_0)" +"(if(if this-state_0" +"(syntax-state-all-sharing?" +" this-state_0)" +" #f)" +" 'share" +" 'none)))" +"(begin" +"(hash-set!" +"(serialize-state-sharing-syntaxes state_9)" +" s_45" +"(if(datum-has-elements? content_0)" +" new-sharing-mode_0" +" 'none))" +"(if(if stx-state_0(eq? new-sharing-mode_0 'none) #f)" +"(let-values()" +"(set-syntax-state-all-sharing?! stx-state_0 #f))" +"(void))))))))))" +"(let-values()" +"(begin" +"(ser-push!_1 'tag '#:syntax)" +"(push-syntax-context! state_9 #f)" +"(ser-push!_1 content_0)" +"(pop-syntax-context! state_9)))))" +"(ser-push!_1 'reference context-triple_0)" +"(ser-push!_1 'reference(syntax-srcloc s_45))" +"(if stx-state_0" +"(let-values()" +"(if(if(eq?" +" context-triple_0" +"(syntax-state-context-triple stx-state_0))" +"(equal?(syntax-srcloc s_45)(syntax-state-srcloc stx-state_0))" +" #f)" +"(void)" +"(let-values()(set-syntax-state-all-sharing?! stx-state_0 #f))))" +"(void))))))))))))))" +"(cons" +" prop:custom-write" +"(lambda(s_46 port_5 mode_5)" +" (let-values ((() (begin (write-string \"#string srcloc_0)))" +" (if srcloc-str_0 (let-values () (fprintf port_5 \":~a\" srcloc-str_0)) (void))))" +"(void))" +" (fprintf port_5 \" ~.s\" (syntax->datum$1 s_46))" +" (write-string \">\" port_5)))))))" +"(current-inspector)" +" #f" +" '(1 2 4 5 6 7)" +" #f" +" 'syntax)))))" +"(values" +" struct:_14" +" make-_14" +" ?_14" +"(make-struct-field-accessor -ref_14 0 'content)" +"(make-struct-field-accessor -ref_14 1 'scopes)" +"(make-struct-field-accessor -ref_14 2 'shifted-multi-scopes)" +"(make-struct-field-accessor -ref_14 3 'scope-propagations+tamper)" +"(make-struct-field-accessor -ref_14 4 'mpi-shifts)" +"(make-struct-field-accessor -ref_14 5 'srcloc)" +"(make-struct-field-accessor -ref_14 6 'props)" +"(make-struct-field-accessor -ref_14 7 'inspector)" +"(make-struct-field-mutator -set!_14 0 'content)" +"(make-struct-field-mutator -set!_14 3 'scope-propagations+tamper))))" +"(define-values(prop:propagation propagation?$1 propagation-ref)(make-struct-type-property 'propagation))" +"(define-values" +"(prop:propagation-tamper propagation-tamper? propagation-tamper-ref)" +"(make-struct-type-property 'propagation-tamper))" +"(define-values" +"(prop:propagation-set-tamper propagation-set-tamper? propagation-set-tamper-ref)" +"(make-struct-type-property 'propagation-set-tamper))" +"(define-values" +"(syntax-tamper)" +"(lambda(s_47)" +"(begin" +"(let-values(((v_71)(syntax-scope-propagations+tamper s_47)))" +"(if(tamper? v_71) v_71((propagation-tamper-ref v_71) v_71))))))" +"(define-values(empty-scopes)(seteq))" +"(define-values(empty-shifted-multi-scopes)(seteq))" +"(define-values(empty-mpi-shifts) null)" +"(define-values(empty-props) '#hasheq())" +"(define-values" +"(empty-syntax)" +"(syntax1.1 #f empty-scopes empty-shifted-multi-scopes #f empty-mpi-shifts #f empty-props #f))" +"(define-values(identifier?)(lambda(s_48)(begin(if(syntax?$1 s_48)(symbol?(syntax-content s_48)) #f))))" +"(define-values" +"(syntax->datum$1)" +"(lambda(s_49)" +"(begin" +" 'syntax->datum" +"(let-values(((s_50) s_49)" +"((f_21)(lambda(tail?_5 x_25)(begin 'f x_25)))" +"((d->s_0)(lambda(s_51 d_1)(begin 'd->s d_1)))" +"((s-e_0) syntax-content)" +"((seen_3) #f))" +"((letrec-values(((loop_63)" +"(lambda(s_52)" +"(begin" +" 'loop" +"(let-values(((s_53) s_52)" +"((f_22)" +"(lambda(tail?_6 v_72)" +"(begin" +" 'f" +"(if(syntax?$1 v_72)" +"(let-values()(d->s_0 v_72(loop_63(s-e_0 v_72))))" +"(let-values()(f_21 tail?_6 v_72))))))" +"((seen_4) seen_3))" +"((letrec-values(((loop_64)" +"(lambda(tail?_7 s_54 prev-depth_1)" +"(begin" +" 'loop" +"(let-values(((depth_1)(add1 prev-depth_1)))" +"(if(if seen_4(> depth_1 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_7" +" s_54" +"(lambda(tail?_8 s_55)(f_22 tail?_8 s_55))" +" seen_4))" +"(if(null? s_54)" +"(let-values()(f_22 tail?_7 s_54))" +"(if(pair? s_54)" +"(let-values()" +"(f_22" +" tail?_7" +"(cons" +"(loop_64 #f(car s_54) depth_1)" +"(loop_64 #t(cdr s_54) depth_1))))" +"(if(let-values(((or-part_86)(symbol? s_54)))" +"(if or-part_86" +" or-part_86" +"(let-values(((or-part_87)(boolean? s_54)))" +"(if or-part_87 or-part_87(number? s_54)))))" +"(let-values()(f_22 #f s_54))" +"(if(let-values(((or-part_88)(vector? s_54)))" +"(if or-part_88" +" or-part_88" +"(let-values(((or-part_89)(box? s_54)))" +"(if or-part_89" +" or-part_89" +"(let-values(((or-part_90)" +"(prefab-struct-key s_54)))" +"(if or-part_90" +" or-part_90" +"(hash? s_54)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_7" +" s_54" +"(lambda(tail?_9 s_56)(f_22 tail?_9 s_56))" +" seen_4))" +"(let-values()(f_22 #f s_54))))))))))))" +" loop_64)" +" #f" +" s_53" +" 0))))))" +" loop_63)" +" s_50)))))" +"(define-values" +"(datum->syntax$1)" +"(let-values(((datum->syntax8_0)" +"(lambda(stx-c6_0 s7_0 stx-l2_0 stx-p3_0 stx-l4_0 stx-p5_0)" +"(begin" +" 'datum->syntax8" +"(let-values(((stx-c_0) stx-c6_0))" +"(let-values(((s_57) s7_0))" +"(let-values(((stx-l_0)(if stx-l4_0 stx-l2_0 #f)))" +"(let-values(((stx-p_0)(if stx-p5_0 stx-p3_0 #f)))" +"(let-values()" +"(if(syntax?$1 s_57)" +"(let-values() s_57)" +"(let-values()" +"(let-values(((wrap_0)" +"(lambda(content_1)" +"(begin" +" 'wrap" +"(syntax1.1" +" content_1" +"(if stx-c_0(syntax-scopes stx-c_0) empty-scopes)" +"(if stx-c_0" +"(syntax-shifted-multi-scopes stx-c_0)" +" empty-shifted-multi-scopes)" +"(if stx-c_0" +"(if(syntax-tamper stx-c_0)" +"(tamper-tainted-for-content content_1)" +" #f)" +" #f)" +"(if stx-c_0(syntax-mpi-shifts stx-c_0) empty-mpi-shifts)" +"(if stx-l_0(syntax-srcloc stx-l_0) #f)" +" empty-props" +"(if stx-c_0(syntax-inspector stx-c_0) #f))))))" +"(let-values(((result-s_0)" +"(let-values(((s_58) s_57)" +"((f_23)" +"(lambda(tail?_10 x_26)" +"(begin 'f(if tail?_10 x_26(wrap_0 x_26)))))" +"((s->_0)(lambda(s_59)(begin 's-> s_59)))" +"((seen_5) disallow-cycles))" +"(let-values(((s_60) s_58)" +"((f_24)" +"(lambda(tail?_11 v_73)" +"(begin" +" 'f" +"(if(syntax?$1 v_73)" +"(let-values()(s->_0 v_73))" +"(let-values()(f_23 tail?_11 v_73))))))" +"((seen_6) seen_5))" +"((letrec-values(((loop_65)" +"(lambda(tail?_12 s_61 prev-depth_2)" +"(begin" +" 'loop" +"(let-values(((depth_2)" +"(add1 prev-depth_2)))" +"(if(if seen_6(> depth_2 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_12" +" s_61" +"(lambda(tail?_13 s_62)" +"(f_24 tail?_13 s_62))" +" seen_6))" +"(if(null? s_61)" +"(let-values()(f_24 tail?_12 s_61))" +"(if(pair? s_61)" +"(let-values()" +"(f_24" +" tail?_12" +"(cons" +"(loop_65 #f(car s_61) depth_2)" +"(loop_65" +" #t" +"(cdr s_61)" +" depth_2))))" +"(if(let-values(((or-part_91)" +"(symbol? s_61)))" +"(if or-part_91" +" or-part_91" +"(let-values(((or-part_92)" +"(boolean?" +" s_61)))" +"(if or-part_92" +" or-part_92" +"(number? s_61)))))" +"(let-values()(f_24 #f s_61))" +"(if(let-values(((or-part_93)" +"(vector? s_61)))" +"(if or-part_93" +" or-part_93" +"(let-values(((or-part_94)" +"(box?" +" s_61)))" +"(if or-part_94" +" or-part_94" +"(let-values(((or-part_95)" +"(prefab-struct-key" +" s_61)))" +"(if or-part_95" +" or-part_95" +"(hash? s_61)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_12" +" s_61" +"(lambda(tail?_14 s_63)" +"(f_24 tail?_14 s_63))" +" seen_6))" +"(let-values()" +"(f_24 #f s_61))))))))))))" +" loop_65)" +" #f" +" s_60" +" 0)))))" +"(if(if stx-p_0(not(eq?(syntax-props stx-p_0) empty-props)) #f)" +"(let-values(((the-struct_0) result-s_0))" +"(if(syntax?$1 the-struct_0)" +"(let-values(((props21_0)(syntax-props stx-p_0)))" +"(syntax1.1" +"(syntax-content the-struct_0)" +"(syntax-scopes the-struct_0)" +"(syntax-shifted-multi-scopes the-struct_0)" +"(syntax-scope-propagations+tamper the-struct_0)" +"(syntax-mpi-shifts the-struct_0)" +"(syntax-srcloc the-struct_0)" +" props21_0" +"(syntax-inspector the-struct_0)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_0)))" +" result-s_0))))))))))))))" +"(case-lambda" +"((stx-c_1 s_64)(begin 'datum->syntax(datum->syntax8_0 stx-c_1 s_64 #f #f #f #f)))" +"((stx-c_2 s_38 stx-l_1 stx-p3_1)(datum->syntax8_0 stx-c_2 s_38 stx-l_1 stx-p3_1 #t #t))" +"((stx-c_3 s_65 stx-l2_1)(datum->syntax8_0 stx-c_3 s_65 stx-l2_1 #f #t #f)))))" +"(define-values" +"(disallow-cycles)" +"(hasheq" +" 'cycle-fail" +" (lambda (s_66) (raise-arguments-error 'datum->syntax \"cannot create syntax from cyclic datum\" s_66))))" +"(define-values" +"(struct:syntax-state" +" syntax-state19.1" +" syntax-state?" +" syntax-state-all-sharing?" +" syntax-state-context-triple" +" syntax-state-srcloc" +" set-syntax-state-all-sharing?!)" +"(let-values(((struct:_15 make-_15 ?_15 -ref_15 -set!_15)" +"(let-values()" +"(let-values()" +"(make-struct-type 'syntax-state #f 3 0 #f null(current-inspector) #f '(1 2) #f 'syntax-state)))))" +"(values" +" struct:_15" +" make-_15" +" ?_15" +"(make-struct-field-accessor -ref_15 0 'all-sharing?)" +"(make-struct-field-accessor -ref_15 1 'context-triple)" +"(make-struct-field-accessor -ref_15 2 'srcloc)" +"(make-struct-field-mutator -set!_15 0 'all-sharing?))))" +"(define-values" +"(no-pair-syntax-in-cdr?)" +"(lambda(content_2)" +"(begin" +"(if(pair? content_2)" +"(let-values()" +"((letrec-values(((loop_66)" +"(lambda(content_3)" +"(begin" +" 'loop" +"(if(if(syntax?$1 content_3)(pair?(syntax-content content_3)) #f)" +"(let-values() #f)" +"(if(pair? content_3)" +"(let-values()(loop_66(cdr content_3)))" +"(let-values() #t)))))))" +" loop_66)" +"(cdr content_2)))" +"(let-values() #t)))))" +"(define-values" +"(deserialize-syntax)" +"(lambda(content_4 context-triple_1 srcloc_1 props_0 tamper_1 inspector_0)" +"(begin" +"(syntax1.1" +" content_4" +"(vector*-ref context-triple_1 0)" +"(vector*-ref context-triple_1 1)" +"(deserialize-tamper tamper_1)" +"(vector*-ref context-triple_1 2)" +" srcloc_1" +"(if props_0" +"(let-values(((ht_33) props_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_33)))" +"((letrec-values(((for-loop_33)" +"(lambda(table_29 i_45)" +"(begin" +" 'for-loop" +"(if i_45" +"(let-values(((k_15 v_74)(unsafe-immutable-hash-iterate-key+value ht_33 i_45)))" +"(let-values(((table_30)" +"(let-values(((table_31) table_29))" +"(let-values(((table_32)" +"(let-values()" +"(let-values(((key_18 val_8)" +"(let-values()" +"(values" +" k_15" +"(preserved-property-value1.1" +" v_74)))))" +"(hash-set table_31 key_18 val_8)))))" +"(values table_32)))))" +"(if(not #f)" +"(for-loop_33 table_30(unsafe-immutable-hash-iterate-next ht_33 i_45))" +" table_30)))" +" table_29)))))" +" for-loop_33)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_33))))" +" empty-props)" +" inspector_0))))" +"(define-values" +"(deserialize-datum->syntax)" +"(lambda(content_5 context-triple_2 srcloc_2 inspector_1)" +"(begin" +"(let-values(((s_67)(deserialize-syntax #f context-triple_2 srcloc_2 #f #f inspector_1)))" +"(datum->syntax$1 s_67 content_5 s_67 s_67)))))" +"(define-values(empty-binding-table) '#hasheq())" +"(define-values" +"(struct:table-with-bulk-bindings" +" table-with-bulk-bindings1.1" +" table-with-bulk-bindings?" +" table-with-bulk-bindings-syms" +" table-with-bulk-bindings-syms/serialize" +" table-with-bulk-bindings-bulk-bindings)" +"(let-values(((struct:_16 make-_16 ?_16 -ref_16 -set!_16)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'table-with-bulk-bindings" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons" +" prop:serialize" +"(lambda(twbb_0 ser-push!_2 state_10)" +"(begin" +"(ser-push!_2 'tag '#:table-with-bulk-bindings)" +"(ser-push!_2(table-with-bulk-bindings-syms/serialize twbb_0))" +"(ser-push!_2(table-with-bulk-bindings-bulk-bindings twbb_0))))))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'table-with-bulk-bindings)))))" +"(values" +" struct:_16" +" make-_16" +" ?_16" +"(make-struct-field-accessor -ref_16 0 'syms)" +"(make-struct-field-accessor -ref_16 1 'syms/serialize)" +"(make-struct-field-accessor -ref_16 2 'bulk-bindings))))" +"(define-values" +"(deserialize-table-with-bulk-bindings)" +"(lambda(syms_1 bulk-bindings_0)(begin(table-with-bulk-bindings1.1 syms_1 syms_1 bulk-bindings_0))))" +"(define-values" +"(struct:bulk-binding-at bulk-binding-at2.1 bulk-binding-at? bulk-binding-at-scopes bulk-binding-at-bulk)" +"(let-values(((struct:_17 make-_17 ?_17 -ref_17 -set!_17)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding-at" +" #f" +" 2" +" 0" +" #f" +"(list" +" (cons prop:reach-scopes (lambda (sms_2 reach_1) (error \"shouldn't get here\")))" +"(cons" +" prop:serialize" +"(lambda(bba_0 ser-push!_3 state_11)" +"(begin" +"(ser-push!_3 'tag '#:bulk-binding-at)" +"(ser-push!_3(bulk-binding-at-scopes bba_0))" +"(ser-push!_3(bulk-binding-at-bulk bba_0))))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'bulk-binding-at)))))" +"(values" +" struct:_17" +" make-_17" +" ?_17" +"(make-struct-field-accessor -ref_17 0 'scopes)" +"(make-struct-field-accessor -ref_17 1 'bulk))))" +"(define-values(deserialize-bulk-binding-at)(lambda(scopes_0 bulk_0)(begin(bulk-binding-at2.1 scopes_0 bulk_0))))" +"(define-values(prop:bulk-binding bulk-binding?$1 bulk-binding-ref)(make-struct-type-property 'bulk-binding))" +"(define-values" +"(struct:bulk-binding-class" +" bulk-binding-class3.1" +" bulk-binding-class?" +" bulk-binding-class-get-symbols" +" bulk-binding-class-create)" +"(let-values(((struct:_18 make-_18 ?_18 -ref_18 -set!_18)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding-class" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'bulk-binding-class)))))" +"(values" +" struct:_18" +" make-_18" +" ?_18" +"(make-struct-field-accessor -ref_18 0 'get-symbols)" +"(make-struct-field-accessor -ref_18 1 'create))))" +"(define-values" +"(bulk-binding-symbols)" +"(lambda(b_21 s_68 extra-shifts_0)" +"(begin" +"((bulk-binding-class-get-symbols(bulk-binding-ref b_21))" +" b_21" +"(append extra-shifts_0(if s_68(syntax-mpi-shifts s_68) null))))))" +"(define-values(bulk-binding-create)(lambda(b_22)(begin(bulk-binding-class-create(bulk-binding-ref b_22)))))" +"(define-values(binding-table-empty?)(lambda(bt_0)(begin(if(hash? bt_0)(zero?(hash-count bt_0)) #f))))" +"(define-values" +"(binding-table-add)" +"(lambda(bt_1 scopes_1 sym_0 binding_0 just-for-nominal?_0)" +"(begin" +"(if(hash? bt_1)" +"(let-values()(hash-set bt_1 sym_0(hash-set(hash-ref bt_1 sym_0 '#hash()) scopes_1 binding_0)))" +"(let-values()" +"(let-values(((new-syms_0)" +"(binding-table-add" +"(table-with-bulk-bindings-syms bt_1)" +" scopes_1" +" sym_0" +" binding_0" +" just-for-nominal?_0)))" +"(let-values(((new-syms/serialize_0)" +"(if just-for-nominal?_0" +"(let-values()(table-with-bulk-bindings-syms/serialize bt_1))" +"(if(eq?" +"(table-with-bulk-bindings-syms bt_1)" +"(table-with-bulk-bindings-syms/serialize bt_1))" +"(let-values() new-syms_0)" +"(let-values()" +"(binding-table-add" +"(table-with-bulk-bindings-syms/serialize bt_1)" +" scopes_1" +" sym_0" +" binding_0" +" #f))))))" +"(let-values(((the-struct_1) bt_1))" +"(if(table-with-bulk-bindings? the-struct_1)" +"(let-values(((syms7_0) new-syms_0)((syms/serialize8_0) new-syms/serialize_0))" +"(table-with-bulk-bindings1.1" +" syms7_0" +" syms/serialize8_0" +"(table-with-bulk-bindings-bulk-bindings the-struct_1)))" +" (raise-argument-error 'struct-copy \"table-with-bulk-bindings?\" the-struct_1))))))))))" +"(define-values" +"(binding-table-add-bulk)" +"(lambda(bt_2 scopes_2 bulk_1)" +"(begin" +"(if(table-with-bulk-bindings? bt_2)" +"(let-values()" +"(let-values(((new-syms_1)(remove-matching-bindings(table-with-bulk-bindings-syms bt_2) scopes_2 bulk_1)))" +"(let-values(((new-syms/serialize_1)" +"(if(eq?(table-with-bulk-bindings-syms bt_2)(table-with-bulk-bindings-syms/serialize bt_2))" +" new-syms_1" +"(remove-matching-bindings(table-with-bulk-bindings-syms/serialize bt_2) scopes_2 bulk_1))))" +"(table-with-bulk-bindings1.1" +" new-syms_1" +" new-syms/serialize_1" +"(cons(bulk-binding-at2.1 scopes_2 bulk_1)(table-with-bulk-bindings-bulk-bindings bt_2))))))" +"(let-values()(binding-table-add-bulk(table-with-bulk-bindings1.1 bt_2 bt_2 null) scopes_2 bulk_1))))))" +"(define-values" +"(remove-matching-bindings)" +"(lambda(syms_2 scopes_3 bulk_2)" +"(begin" +"(let-values(((bulk-symbols_0)(bulk-binding-symbols bulk_2 #f null)))" +"(if(<(hash-count syms_2)(hash-count bulk-symbols_0))" +"(let-values()" +"(let-values(((ht_34) syms_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_34)))" +"((letrec-values(((for-loop_34)" +"(lambda(syms_3 i_46)" +"(begin" +" 'for-loop" +"(if i_46" +"(let-values(((sym_1 sym-bindings_0)" +"(unsafe-immutable-hash-iterate-key+value ht_34 i_46)))" +"(let-values(((syms_4)" +"(let-values(((syms_5) syms_3))" +"(let-values(((syms_6)" +"(let-values()" +"(if(hash-ref bulk-symbols_0 sym_1 #f)" +"(remove-matching-binding" +" syms_5" +" sym_1" +" sym-bindings_0" +" scopes_3)" +" syms_5))))" +"(values syms_6)))))" +"(if(not #f)" +"(for-loop_34 syms_4(unsafe-immutable-hash-iterate-next ht_34 i_46))" +" syms_4)))" +" syms_3)))))" +" for-loop_34)" +" syms_2" +"(unsafe-immutable-hash-iterate-first ht_34)))))" +"(let-values()" +"(let-values(((ht_35) bulk-symbols_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_35)))" +"((letrec-values(((for-loop_35)" +"(lambda(syms_7 i_47)" +"(begin" +" 'for-loop" +"(if i_47" +"(let-values(((sym_2)(unsafe-immutable-hash-iterate-key ht_35 i_47)))" +"(let-values(((syms_8)" +"(let-values(((syms_9) syms_7))" +"(let-values(((syms_10)" +"(let-values()" +"(let-values(((sym-bindings_1)" +"(hash-ref syms_9 sym_2 #f)))" +"(if sym-bindings_1" +"(remove-matching-binding" +" syms_9" +" sym_2" +" sym-bindings_1" +" scopes_3)" +" syms_9)))))" +"(values syms_10)))))" +"(if(not #f)" +"(for-loop_35 syms_8(unsafe-immutable-hash-iterate-next ht_35 i_47))" +" syms_8)))" +" syms_7)))))" +" for-loop_35)" +" syms_2" +"(unsafe-immutable-hash-iterate-first ht_35))))))))))" +"(define-values" +"(remove-matching-binding)" +"(lambda(syms_11 sym_3 sym-bindings_2 scopes_4)" +"(begin(hash-set syms_11 sym_3(hash-remove sym-bindings_2 scopes_4)))))" +"(define-values" +"(binding-table-symbols)" +"(lambda(table_33 scs_2 s_69 extra-shifts_1)" +"(begin" +"(let-values(((ht_36 bulk-bindings_1)" +"(if(hash? table_33)" +"(values table_33 null)" +"(values" +"(table-with-bulk-bindings-syms table_33)" +"(table-with-bulk-bindings-bulk-bindings table_33)))))" +"(set-union" +"(let-values(((ht_37) ht_36))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_37)))" +"((letrec-values(((for-loop_36)" +"(lambda(table_34 i_48)" +"(begin" +" 'for-loop" +"(if i_48" +"(let-values(((sym_4 at-sym_0)(hash-iterate-key+value ht_37 i_48)))" +"(let-values(((table_2)" +"(let-values(((table_3) table_34))" +"(if(let-values(((ht_38) at-sym_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_38)))" +"((letrec-values(((for-loop_37)" +"(lambda(result_29 i_49)" +"(begin" +" 'for-loop" +"(if i_49" +"(let-values(((an-scs_0)" +"(hash-iterate-key" +" ht_38" +" i_49)))" +"(let-values(((result_30)" +"(let-values()" +"(let-values(((result_31)" +"(let-values()" +"(let-values()" +"(subset?" +" an-scs_0" +" scs_2)))))" +"(values" +" result_31)))))" +"(if(if(not" +"((lambda x_27" +" result_30)" +" an-scs_0))" +"(not #f)" +" #f)" +"(for-loop_37" +" result_30" +"(hash-iterate-next" +" ht_38" +" i_49))" +" result_30)))" +" result_29)))))" +" for-loop_37)" +" #f" +"(hash-iterate-first ht_38))))" +"(let-values(((table_5) table_3))" +"(let-values(((table_6)" +"(let-values()" +"(let-values(((key_19 val_9)" +"(let-values()" +"(values" +"(let-values() sym_4)" +" #t))))" +"(hash-set table_5 key_19 val_9)))))" +"(values table_6)))" +" table_3))))" +"(if(not #f)(for-loop_36 table_2(hash-iterate-next ht_37 i_48)) table_2)))" +" table_34)))))" +" for-loop_36)" +" '#hasheq()" +"(hash-iterate-first ht_37))))" +"(let-values(((lst_34) bulk-bindings_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_34)))" +"((letrec-values(((for-loop_38)" +"(lambda(table_35 lst_35)" +"(begin" +" 'for-loop" +"(if(pair? lst_35)" +"(let-values(((bba_1)(unsafe-car lst_35))((rest_14)(unsafe-cdr lst_35)))" +"(let-values(((table_36)" +"(let-values(((table_37) table_35))" +"(if(subset?(bulk-binding-at-scopes bba_1) scs_2)" +"(let-values(((ht_39)" +"(bulk-binding-symbols" +"(bulk-binding-at-bulk bba_1)" +" s_69" +" extra-shifts_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_39)))" +"((letrec-values(((for-loop_39)" +"(lambda(table_38 i_50)" +"(begin" +" 'for-loop" +"(if i_50" +"(let-values(((sym_5)" +"(hash-iterate-key" +" ht_39" +" i_50)))" +"(let-values(((table_39)" +"(let-values(((table_40)" +" table_38))" +"(let-values(((table_41)" +"(let-values()" +"(let-values(((key_20" +" val_10)" +"(let-values()" +"(values" +"(let-values()" +" sym_5)" +" #t))))" +"(hash-set" +" table_40" +" key_20" +" val_10)))))" +"(values" +" table_41)))))" +"(if(not #f)" +"(for-loop_39" +" table_39" +"(hash-iterate-next" +" ht_39" +" i_50))" +" table_39)))" +" table_38)))))" +" for-loop_39)" +" table_37" +"(hash-iterate-first ht_39))))" +" table_37))))" +"(if(not #f)(for-loop_38 table_36 rest_14) table_36)))" +" table_35)))))" +" for-loop_38)" +" '#hasheq()" +" lst_34))))))))" +"(define-values" +"(binding-table-prune-to-reachable)" +"(lambda(bt_3 state_12)" +"(begin" +"(let-values(((or-part_96)(hash-ref(serialize-state-bindings-intern state_12) bt_3 #f)))" +"(if or-part_96" +" or-part_96" +"(let-values(((reachable-scopes_1)(serialize-state-reachable-scopes state_12)))" +"(let-values(((new-syms_2)" +"(let-values(((ht_40)(if(hash? bt_3) bt_3(table-with-bulk-bindings-syms/serialize bt_3))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_40)))" +"((letrec-values(((for-loop_40)" +"(lambda(table_42 i_51)" +"(begin" +" 'for-loop" +"(if i_51" +"(let-values(((sym_6 bindings-for-sym_0)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_40" +" i_51)))" +"(let-values(((table_43)" +"(let-values(((new-bindings-for-sym_0)" +"(let-values(((ht_41)" +" bindings-for-sym_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash" +" ht_41)))" +"((letrec-values(((for-loop_41)" +"(lambda(table_44" +" i_52)" +"(begin" +" 'for-loop" +"(if i_52" +"(let-values(((scopes_5" +" binding_1)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_41" +" i_52)))" +"(let-values(((table_45)" +"(let-values(((table_46)" +" table_44))" +"(if(subset?" +" scopes_5" +" reachable-scopes_1)" +"(let-values(((table_47)" +" table_46))" +"(let-values(((table_48)" +"(let-values()" +"(let-values(((key_21" +" val_11)" +"(let-values()" +"(values" +"(intern-scopes" +" scopes_5" +" state_12)" +" binding_1))))" +"(hash-set" +" table_47" +" key_21" +" val_11)))))" +"(values" +" table_48)))" +" table_46))))" +"(if(not" +" #f)" +"(for-loop_41" +" table_45" +"(unsafe-immutable-hash-iterate-next" +" ht_41" +" i_52))" +" table_45)))" +" table_44)))))" +" for-loop_41)" +" '#hash()" +"(unsafe-immutable-hash-iterate-first" +" ht_41))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_42)" +"(lambda(table_49)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_50)" +"(let-values(((table_51)" +" table_49))" +"(if(positive?" +"(hash-count" +" new-bindings-for-sym_0))" +"(let-values(((table_52)" +" table_51))" +"(let-values(((table_53)" +"(let-values()" +"(let-values(((key_22" +" val_12)" +"(let-values()" +"(values" +" sym_6" +" new-bindings-for-sym_0))))" +"(hash-set" +" table_52" +" key_22" +" val_12)))))" +"(values" +" table_53)))" +" table_51))))" +" table_50))))))" +" for-loop_42)" +" table_42)))))" +"(if(not #f)" +"(for-loop_40" +" table_43" +"(unsafe-immutable-hash-iterate-next ht_40 i_51))" +" table_43)))" +" table_42)))))" +" for-loop_40)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_40))))))" +"(let-values(((new-bulk-bindings_0)" +"(if(hash? bt_3)" +" null" +"(reverse$1" +"(let-values(((lst_36)(table-with-bulk-bindings-bulk-bindings bt_3)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_36)))" +"((letrec-values(((for-loop_43)" +"(lambda(fold-var_21 lst_37)" +"(begin" +" 'for-loop" +"(if(pair? lst_37)" +"(let-values(((bba_2)(unsafe-car lst_37))" +"((rest_15)(unsafe-cdr lst_37)))" +"(let-values(((fold-var_22)" +"(let-values(((fold-var_23) fold-var_21))" +"(if(subset?" +"(bulk-binding-at-scopes bba_2)" +" reachable-scopes_1)" +"(let-values(((fold-var_24) fold-var_23))" +"(let-values(((fold-var_25)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((the-struct_2)" +" bba_2))" +"(if(bulk-binding-at?" +" the-struct_2)" +"(let-values(((scopes9_0)" +"(intern-scopes" +"(bulk-binding-at-scopes" +" bba_2)" +" state_12)))" +"(bulk-binding-at2.1" +" scopes9_0" +"(bulk-binding-at-bulk" +" the-struct_2)))" +"(raise-argument-error" +" 'struct-copy" +" \"bulk-binding-at?\"" +" the-struct_2))))" +" fold-var_24))))" +"(values fold-var_25)))" +" fold-var_23))))" +"(if(not #f)" +"(for-loop_43 fold-var_22 rest_15)" +" fold-var_22)))" +" fold-var_21)))))" +" for-loop_43)" +" null" +" lst_36)))))))" +"(let-values(((new-bt_0)" +"(if(pair? new-bulk-bindings_0)" +"(table-with-bulk-bindings1.1 new-syms_2 new-syms_2 new-bulk-bindings_0)" +" new-syms_2)))" +"(begin(hash-set!(serialize-state-bulk-bindings-intern state_12) bt_3 new-bt_0) new-bt_0))))))))))" +"(define-values" +"(binding-table-register-reachable)" +"(lambda(bt_4 reachable-scopes_2 reach_2 register-trigger_0)" +"(begin" +"(begin" +"(let-values(((ht_42)(if(hash? bt_4) bt_4(table-with-bulk-bindings-syms/serialize bt_4))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_42)))" +"((letrec-values(((for-loop_44)" +"(lambda(i_53)" +"(begin" +" 'for-loop" +"(if i_53" +"(let-values(((sym_7 bindings-for-sym_1)" +"(unsafe-immutable-hash-iterate-key+value ht_42 i_53)))" +"(let-values((()" +"(let-values(((ht_43) bindings-for-sym_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_43)))" +"((letrec-values(((for-loop_45)" +"(lambda(i_54)" +"(begin" +" 'for-loop" +"(if i_54" +"(let-values(((scopes_6 binding_2)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_43" +" i_54)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(scopes-register-reachable" +" scopes_6" +" binding_2" +" reachable-scopes_2" +" reach_2" +" register-trigger_0))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_45" +"(unsafe-immutable-hash-iterate-next" +" ht_43" +" i_54))" +"(values))))" +"(values))))))" +" for-loop_45)" +"(unsafe-immutable-hash-iterate-first ht_43))))))" +"(if(not #f)" +"(for-loop_44(unsafe-immutable-hash-iterate-next ht_42 i_53))" +"(values))))" +"(values))))))" +" for-loop_44)" +"(unsafe-immutable-hash-iterate-first ht_42))))" +"(void)))))" +"(define-values" +"(scopes-register-reachable)" +"(lambda(scopes_7 binding_3 reachable-scopes_3 reach_3 register-trigger_1)" +"(begin" +"(let-values(((v_43)(if(binding-reach-scopes? binding_3)((binding-reach-scopes-ref binding_3) binding_3) #f)))" +"(if v_43" +"(let-values()" +"(if(subset? scopes_7 reachable-scopes_3)" +"(let-values()(reach_3 v_43))" +"(let-values()" +"(begin" +"(let-values(((ht_44) scopes_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_44)))" +"((letrec-values(((for-loop_46)" +"(lambda(i_55)" +"(begin" +" 'for-loop" +"(if i_55" +"(let-values(((sc_0)(unsafe-immutable-hash-iterate-key ht_44 i_55)))" +"(let-values((()" +"(let-values()" +"(if(set-member? reachable-scopes_3 sc_0)" +"(values)" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(register-trigger_1 sc_0 v_43))" +"(values)))))" +"(values)))))))" +"(if(not #f)" +"(for-loop_46(unsafe-immutable-hash-iterate-next ht_44 i_55))" +"(values))))" +"(values))))))" +" for-loop_46)" +"(unsafe-immutable-hash-iterate-first ht_44))))" +"(void)))))" +"(void))))))" +"(define-values" +"(taint-content)" +"(lambda(d_2)" +"(begin" +"(let-values(((s_70) d_2)" +"((f_25)(lambda(tail?_15 x_28)(begin 'f x_28)))" +"((s->_1)" +"(lambda(sub-s_0)" +"(begin" +" 's->" +"(if(tamper-tainted?(syntax-tamper sub-s_0))" +"(let-values() sub-s_0)" +"(let-values()" +"(let-values(((stx_0) sub-s_0))" +"(let-values(((the-struct_3) stx_0))" +"(if(syntax?$1 the-struct_3)" +"(let-values(((scope-propagations+tamper6_0)" +"(let-values(((t_16)" +"(tamper-tainted-for-content(syntax-content sub-s_0)))" +"((p_19)(syntax-scope-propagations+tamper stx_0)))" +"(if(tamper? p_19)" +" t_16" +"((propagation-set-tamper-ref p_19) p_19 t_16)))))" +"(syntax1.1" +"(syntax-content the-struct_3)" +"(syntax-scopes the-struct_3)" +"(syntax-shifted-multi-scopes the-struct_3)" +" scope-propagations+tamper6_0" +"(syntax-mpi-shifts the-struct_3)" +"(syntax-srcloc the-struct_3)" +"(syntax-props the-struct_3)" +"(syntax-inspector the-struct_3)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_3)))))))))" +"((seen_7) #f))" +"(let-values(((s_71) s_70)" +"((f_4)" +"(lambda(tail?_16 v_75)" +"(begin" +" 'f" +"(if(syntax?$1 v_75)(let-values()(s->_1 v_75))(let-values()(f_25 tail?_16 v_75))))))" +"((seen_8) seen_7))" +"((letrec-values(((loop_67)" +"(lambda(tail?_17 s_72 prev-depth_3)" +"(begin" +" 'loop" +"(let-values(((depth_3)(add1 prev-depth_3)))" +"(if(if seen_8(> depth_3 32) #f)" +"(let-values()" +"(datum-map-slow tail?_17 s_72(lambda(tail?_1 s_41)(f_4 tail?_1 s_41)) seen_8))" +"(if(null? s_72)" +"(let-values()(f_4 tail?_17 s_72))" +"(if(pair? s_72)" +"(let-values()" +"(f_4" +" tail?_17" +"(cons(loop_67 #f(car s_72) depth_3)(loop_67 #t(cdr s_72) depth_3))))" +"(if(let-values(((or-part_80)(symbol? s_72)))" +"(if or-part_80" +" or-part_80" +"(let-values(((or-part_81)(boolean? s_72)))" +"(if or-part_81 or-part_81(number? s_72)))))" +"(let-values()(f_4 #f s_72))" +"(if(let-values(((or-part_70)(vector? s_72)))" +"(if or-part_70" +" or-part_70" +"(let-values(((or-part_71)(box? s_72)))" +"(if or-part_71" +" or-part_71" +"(let-values(((or-part_82)(prefab-struct-key s_72)))" +"(if or-part_82 or-part_82(hash? s_72)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_17" +" s_72" +"(lambda(tail?_18 s_73)(f_4 tail?_18 s_73))" +" seen_8))" +"(let-values()(f_4 #f s_72))))))))))))" +" loop_67)" +" #f" +" s_71" +" 0))))))" +"(define-values(syntax-tainted?$1)(lambda(s_74)(begin 'syntax-tainted?(tamper-tainted?(syntax-tamper s_74)))))" +"(define-values(syntax-clean?)(lambda(s_6)(begin(tamper-clean?(syntax-tamper s_6)))))" +"(define-values" +"(syntax-arm$1)" +"(lambda(s_75 insp_0)" +"(begin" +" 'syntax-arm" +"(let-values(((t_17)(syntax-tamper s_75)))" +"(if(tamper-tainted? t_17)" +"(let-values() s_75)" +"(if(if t_17" +"(let-values(((or-part_97)(set-member? t_17 insp_0)))" +"(if or-part_97" +" or-part_97" +"(let-values(((ht_45) t_17))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_45)))" +"((letrec-values(((for-loop_47)" +"(lambda(result_32 i_56)" +"(begin" +" 'for-loop" +"(if i_56" +"(let-values(((already-insp_0)" +"(unsafe-immutable-hash-iterate-key ht_45 i_56)))" +"(let-values(((result_4)" +"(let-values()" +"(let-values(((result_33)" +"(let-values()" +"(let-values()" +"(inspector-superior-or-same?" +" already-insp_0" +" insp_0)))))" +"(values result_33)))))" +"(if(if(not((lambda x_29 result_4) already-insp_0))(not #f) #f)" +"(for-loop_47" +" result_4" +"(unsafe-immutable-hash-iterate-next ht_45 i_56))" +" result_4)))" +" result_32)))))" +" for-loop_47)" +" #f" +"(unsafe-immutable-hash-iterate-first ht_45))))))" +" #f)" +"(let-values() s_75)" +"(let-values()" +"(let-values(((stx_1) s_75))" +"(let-values(((the-struct_4) stx_1))" +"(if(syntax?$1 the-struct_4)" +"(let-values(((scope-propagations+tamper7_0)" +"(let-values(((t_18)(set-add(if t_17(remove-inferior t_17 insp_0)(seteq)) insp_0))" +"((p_20)(syntax-scope-propagations+tamper stx_1)))" +"(if(tamper? p_20) t_18((propagation-set-tamper-ref p_20) p_20 t_18)))))" +"(syntax1.1" +"(syntax-content the-struct_4)" +"(syntax-scopes the-struct_4)" +"(syntax-shifted-multi-scopes the-struct_4)" +" scope-propagations+tamper7_0" +"(syntax-mpi-shifts the-struct_4)" +"(syntax-srcloc the-struct_4)" +"(syntax-props the-struct_4)" +"(syntax-inspector the-struct_4)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_4)))))))))))" +"(define-values" +"(remove-inferior)" +"(lambda(t_19 insp_1)" +"(begin" +"(let-values(((ht_46) t_19))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_46)))" +"((letrec-values(((for-loop_48)" +"(lambda(table_54 i_57)" +"(begin" +" 'for-loop" +"(if i_57" +"(let-values(((already-insp_1)(unsafe-immutable-hash-iterate-key ht_46 i_57)))" +"(let-values(((table_15)" +"(let-values(((table_55) table_54))" +"(if(inspector-superior-or-same? insp_1 already-insp_1)" +" table_55" +"(let-values(((table_56) table_55))" +"(let-values(((table_57)" +"(let-values()" +"(let-values(((key_23 val_13)" +"(let-values()" +"(values" +"(let-values() already-insp_1)" +" #t))))" +"(hash-set table_56 key_23 val_13)))))" +"(values table_57)))))))" +"(if(not #f)" +"(for-loop_48 table_15(unsafe-immutable-hash-iterate-next ht_46 i_57))" +" table_15)))" +" table_54)))))" +" for-loop_48)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_46)))))))" +"(define-values" +"(syntax-disarm$1)" +"(let-values(((syntax-disarm4_0)" +"(lambda(s3_0 insp1_0 insp2_0)" +"(begin" +" 'syntax-disarm4" +"(let-values(((s_13) s3_0))" +"(let-values(((insp_2)(if insp2_0 insp1_0 #f)))" +"(let-values()" +"(let-values(((t_20)(syntax-tamper s_13)))" +"(if(not(tamper-armed? t_20))" +"(let-values() s_13)" +"(if(not insp_2)" +"(let-values()" +"(let-values(((stx_2) s_13))" +"(let-values(((the-struct_5) stx_2))" +"(if(syntax?$1 the-struct_5)" +"(let-values(((scope-propagations+tamper8_0)" +"(let-values(((t_21) #f)" +"((p_21)(syntax-scope-propagations+tamper stx_2)))" +"(if(tamper? p_21)" +" t_21" +"((propagation-set-tamper-ref p_21) p_21 t_21)))))" +"(syntax1.1" +"(syntax-content the-struct_5)" +"(syntax-scopes the-struct_5)" +"(syntax-shifted-multi-scopes the-struct_5)" +" scope-propagations+tamper8_0" +"(syntax-mpi-shifts the-struct_5)" +"(syntax-srcloc the-struct_5)" +"(syntax-props the-struct_5)" +"(syntax-inspector the-struct_5)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_5)))))" +"(let-values()" +"(let-values(((new-t_1)(remove-inferior t_20 insp_2)))" +"(let-values(((stx_3) s_13))" +"(let-values(((the-struct_6) stx_3))" +"(if(syntax?$1 the-struct_6)" +"(let-values(((scope-propagations+tamper9_0)" +"(let-values(((t_22)(if(not(set-empty? new-t_1)) new-t_1 #f))" +"((p_22)(syntax-scope-propagations+tamper stx_3)))" +"(if(tamper? p_22)" +" t_22" +"((propagation-set-tamper-ref p_22) p_22 t_22)))))" +"(syntax1.1" +"(syntax-content the-struct_6)" +"(syntax-scopes the-struct_6)" +"(syntax-shifted-multi-scopes the-struct_6)" +" scope-propagations+tamper9_0" +"(syntax-mpi-shifts the-struct_6)" +"(syntax-srcloc the-struct_6)" +"(syntax-props the-struct_6)" +"(syntax-inspector the-struct_6)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_6))))))))))))))))" +"(case-lambda" +"((s_21)(begin 'syntax-disarm(syntax-disarm4_0 s_21 #f #f)))" +"((s_76 insp1_1)(syntax-disarm4_0 s_76 insp1_1 #t)))))" +"(define-values" +"(syntax-rearm$1)" +"(lambda(s_23 from-s_0)" +"(begin" +" 'syntax-rearm" +"(let-values(((t_23)(syntax-tamper s_23)))" +"(if(tamper-tainted? t_23)" +"(let-values() s_23)" +"(let-values()" +"(let-values(((from-t_0)(syntax-tamper from-s_0)))" +"(if(tamper-clean? from-t_0)" +"(let-values() s_23)" +"(if(tamper-tainted? from-t_0)" +"(let-values()" +"(let-values(((stx_4) s_23))" +"(let-values(((the-struct_7) stx_4))" +"(if(syntax?$1 the-struct_7)" +"(let-values(((scope-propagations+tamper10_0)" +"(let-values(((t_24)(tamper-tainted-for-content(syntax-content s_23)))" +"((p_23)(syntax-scope-propagations+tamper stx_4)))" +"(if(tamper? p_23) t_24((propagation-set-tamper-ref p_23) p_23 t_24)))))" +"(syntax1.1" +"(syntax-content the-struct_7)" +"(syntax-scopes the-struct_7)" +"(syntax-shifted-multi-scopes the-struct_7)" +" scope-propagations+tamper10_0" +"(syntax-mpi-shifts the-struct_7)" +"(syntax-srcloc the-struct_7)" +"(syntax-props the-struct_7)" +"(syntax-inspector the-struct_7)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_7)))))" +"(if(tamper-clean? t_23)" +"(let-values()" +"(let-values(((stx_5) s_23))" +"(let-values(((the-struct_8) stx_5))" +"(if(syntax?$1 the-struct_8)" +"(let-values(((scope-propagations+tamper11_0)" +"(let-values(((t_25) from-t_0)" +"((p_24)(syntax-scope-propagations+tamper stx_5)))" +"(if(tamper? p_24) t_25((propagation-set-tamper-ref p_24) p_24 t_25)))))" +"(syntax1.1" +"(syntax-content the-struct_8)" +"(syntax-scopes the-struct_8)" +"(syntax-shifted-multi-scopes the-struct_8)" +" scope-propagations+tamper11_0" +"(syntax-mpi-shifts the-struct_8)" +"(syntax-srcloc the-struct_8)" +"(syntax-props the-struct_8)" +"(syntax-inspector the-struct_8)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_8)))))" +"(let-values()" +"(let-values(((stx_6) s_23))" +"(let-values(((the-struct_9) stx_6))" +"(if(syntax?$1 the-struct_9)" +"(let-values(((scope-propagations+tamper12_0)" +"(let-values(((t_26)" +"(let-values(((ht_47) from-t_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_47)))" +"((letrec-values(((for-loop_49)" +"(lambda(t_27 i_58)" +"(begin" +" 'for-loop" +"(if i_58" +"(let-values(((from-i_0)" +"(unsafe-immutable-hash-iterate-key" +" ht_47" +" i_58)))" +"(let-values(((t_28)" +"(let-values(((t_29)" +" t_27))" +"(let-values(((t_30)" +"(let-values()" +"(if(set-member?" +" t_29" +" from-i_0)" +"(let-values()" +" t_29)" +"(if(any-superior?" +" t_29" +" from-i_0)" +"(let-values()" +" t_29)" +"(let-values()" +"(set-add" +"(remove-inferior" +" t_29" +" from-i_0)" +" from-i_0)))))))" +"(values" +" t_30)))))" +"(if(not #f)" +"(for-loop_49" +" t_28" +"(unsafe-immutable-hash-iterate-next" +" ht_47" +" i_58))" +" t_28)))" +" t_27)))))" +" for-loop_49)" +" t_23" +"(unsafe-immutable-hash-iterate-first ht_47)))))" +"((p_25)(syntax-scope-propagations+tamper stx_6)))" +"(if(tamper? p_25) t_26((propagation-set-tamper-ref p_25) p_25 t_26)))))" +"(syntax1.1" +"(syntax-content the-struct_9)" +"(syntax-scopes the-struct_9)" +"(syntax-shifted-multi-scopes the-struct_9)" +" scope-propagations+tamper12_0" +"(syntax-mpi-shifts the-struct_9)" +"(syntax-srcloc the-struct_9)" +"(syntax-props the-struct_9)" +"(syntax-inspector the-struct_9)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_9)))))))))))))))" +"(define-values" +"(syntax-taint$1)" +"(lambda(s_77)" +"(begin" +" 'syntax-taint" +"(if(tamper-tainted?(syntax-tamper s_77))" +" s_77" +"(let-values(((stx_7) s_77))" +"(let-values(((the-struct_10) stx_7))" +"(if(syntax?$1 the-struct_10)" +"(let-values(((scope-propagations+tamper13_0)" +"(let-values(((t_31)(tamper-tainted-for-content(syntax-content s_77)))" +"((p_26)(syntax-scope-propagations+tamper stx_7)))" +"(if(tamper? p_26) t_31((propagation-set-tamper-ref p_26) p_26 t_31)))))" +"(syntax1.1" +"(syntax-content the-struct_10)" +"(syntax-scopes the-struct_10)" +"(syntax-shifted-multi-scopes the-struct_10)" +" scope-propagations+tamper13_0" +"(syntax-mpi-shifts the-struct_10)" +"(syntax-srcloc the-struct_10)" +"(syntax-props the-struct_10)" +"(syntax-inspector the-struct_10)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_10))))))))" +"(define-values" +"(any-superior?)" +"(lambda(t_5 from-i_1)" +"(begin" +"(let-values(((ht_48) t_5))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_48)))" +"((letrec-values(((for-loop_50)" +"(lambda(result_34 i_59)" +"(begin" +" 'for-loop" +"(if i_59" +"(let-values(((i_60)(unsafe-immutable-hash-iterate-key ht_48 i_59)))" +"(let-values(((result_7)" +"(let-values()" +"(let-values(((result_35)" +"(let-values()" +"(let-values()" +"(inspector-superior-or-same? i_60 from-i_1)))))" +"(values result_35)))))" +"(if(if(not((lambda x_30 result_7) i_60))(not #f) #f)" +"(for-loop_50 result_7(unsafe-immutable-hash-iterate-next ht_48 i_59))" +" result_7)))" +" result_34)))))" +" for-loop_50)" +" #f" +"(unsafe-immutable-hash-iterate-first ht_48)))))))" +"(define-values" +"(inspector-superior-or-same?)" +"(lambda(sup-i_0 i_61)" +"(begin" +"(let-values(((or-part_98)(eq? sup-i_0 i_61)))(if or-part_98 or-part_98(inspector-superior? sup-i_0 i_61))))))" +"(define-values" +"(struct:fallback fallback1.1 fallback? fallback-search-list)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()(make-struct-type 'fallback #f 1 0 #f null 'prefab #f '(0) #f 'fallback)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'search-list))))" +"(define-values" +"(fallback-first)" +"(lambda(smss_0)(begin(if(fallback? smss_0)(car(fallback-search-list smss_0)) smss_0))))" +"(define-values" +"(fallback-rest)" +"(lambda(smss_1)" +"(begin" +"(let-values(((l_44)(cdr(fallback-search-list smss_1))))" +"(if(null?(cdr l_44))(car l_44)(fallback1.1 l_44))))))" +"(define-values" +"(fallback-push)" +"(lambda(smss_2 smss/maybe-fallback_0)" +"(begin" +"(fallback1.1" +"(cons" +" smss_2" +"(if(fallback? smss/maybe-fallback_0)" +"(fallback-search-list smss/maybe-fallback_0)" +"(list smss/maybe-fallback_0)))))))" +"(define-values" +"(fallback-update-first)" +"(lambda(smss_3 f_26)" +"(begin" +"(if(fallback? smss_3)" +"(let-values(((l_45)(fallback-search-list smss_3)))(fallback1.1(cons(f_26(car l_45))(cdr l_45))))" +"(f_26 smss_3)))))" +"(define-values" +"(fallback-map)" +"(lambda(smss_4 f_19)" +"(begin" +"(if(fallback? smss_4)" +"(fallback1.1" +"(reverse$1" +"(let-values(((lst_38)(fallback-search-list smss_4)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_38)))" +"((letrec-values(((for-loop_51)" +"(lambda(fold-var_26 lst_39)" +"(begin" +" 'for-loop" +"(if(pair? lst_39)" +"(let-values(((smss_5)(unsafe-car lst_39))((rest_16)(unsafe-cdr lst_39)))" +"(let-values(((fold-var_27)" +"(let-values(((fold-var_28) fold-var_26))" +"(let-values(((fold-var_29)" +"(let-values()" +"(cons" +"(let-values()(f_19 smss_5))" +" fold-var_28))))" +"(values fold-var_29)))))" +"(if(not #f)(for-loop_51 fold-var_27 rest_16) fold-var_27)))" +" fold-var_26)))))" +" for-loop_51)" +" null" +" lst_38)))))" +"(f_19 smss_4)))))" +"(define-values" +"(fallback->list)" +"(lambda(smss_6)(begin(if(fallback? smss_6)(fallback-search-list smss_6)(list smss_6)))))" +"(define-values(cache)(box(make-weak-box #f)))" +"(define-values" +"(clear-resolve-cache!)" +"(case-lambda" +"((sym_8)" +"(begin" +"(let-values(((c_13)(weak-box-value(unbox* cache))))" +"(if c_13(let-values()(hash-remove! c_13 sym_8))(void)))))" +"(()(let-values(((c_14)(weak-box-value(unbox* cache))))(if c_14(let-values()(hash-clear! c_14))(void))))))" +"(define-values" +"(struct:entry entry1.1 entry? entry-scs entry-smss entry-phase entry-binding)" +"(let-values(((struct:_16 make-_16 ?_16 -ref_16 -set!_16)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'entry" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'entry)))))" +"(values" +" struct:_16" +" make-_16" +" ?_16" +"(make-struct-field-accessor -ref_16 0 'scs)" +"(make-struct-field-accessor -ref_16 1 'smss)" +"(make-struct-field-accessor -ref_16 2 'phase)" +"(make-struct-field-accessor -ref_16 3 'binding))))" +"(define-values" +"(resolve-cache-get)" +"(lambda(sym_9 phase_0 scs_3 smss_7)" +"(begin" +"(let-values(((c_15)(weak-box-value(unbox* cache))))" +"(if c_15" +"(let-values(((v_76)(hash-ref c_15 sym_9 #f)))" +"(if v_76" +"(if(eqv? phase_0(entry-phase v_76))" +"(if(set=? scs_3(entry-scs v_76))(if(set=? smss_7(entry-smss v_76))(entry-binding v_76) #f) #f)" +" #f)" +" #f))" +" #f)))))" +"(define-values" +"(resolve-cache-set!)" +"(lambda(sym_10 phase_1 scs_4 smss_8 b_23)" +"(begin" +"(let-values(((wb_0)(unbox* cache)))" +"(let-values(((c_16)(weak-box-value wb_0)))" +"(if(not c_16)" +"(let-values()" +"(begin" +"(box-cas! cache wb_0(make-weak-box(make-hasheq)))" +"(resolve-cache-set! sym_10 phase_1 scs_4 smss_8 b_23)))" +"(let-values()(hash-set! c_16 sym_10(entry1.1 scs_4 smss_8 phase_1 b_23)))))))))" +"(define-values(NUM-CACHE-SLOTS) 8)" +"(define-values(cached-sets)(make-weak-box(make-vector NUM-CACHE-SLOTS #f)))" +"(define-values(cached-sets-pos) 0)" +"(define-values(cached-hashes)(make-weak-box(make-vector NUM-CACHE-SLOTS #f)))" +"(define-values(cached-hashes-pos) 0)" +"(define-values" +"(cache-or-reuse-set)" +"(lambda(s_78)" +"(begin" +"(let-values(((vec_16)" +"(let-values(((or-part_99)(weak-box-value cached-sets)))" +"(if or-part_99" +" or-part_99" +"(let-values(((vec_17)(make-vector NUM-CACHE-SLOTS #f)))" +"(begin(set! cached-sets(make-weak-box vec_17)) vec_17))))))" +"(let-values(((or-part_100)" +"(let-values(((vec_18 len_9)" +"(let-values(((vec_19) vec_16))" +"(begin(check-vector vec_19)(values vec_19(unsafe-vector-length vec_19))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_52)" +"(lambda(result_36 pos_7)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_7 len_9)" +"(let-values(((s2_5)(unsafe-vector-ref vec_18 pos_7)))" +"(let-values(((result_37)" +"(let-values()" +"(let-values(((result_38)" +"(let-values()" +"(let-values()" +"(if s2_5" +"(if(set=? s_78 s2_5) s2_5 #f)" +" #f)))))" +"(values result_38)))))" +"(if(if(not((lambda x_31 result_37) s2_5))(not #f) #f)" +"(for-loop_52 result_37(unsafe-fx+ 1 pos_7))" +" result_37)))" +" result_36)))))" +" for-loop_52)" +" #f" +" 0)))))" +"(if or-part_100" +" or-part_100" +"(begin" +"(vector-set! vec_16 cached-sets-pos s_78)" +"(set! cached-sets-pos(modulo(add1 cached-sets-pos) NUM-CACHE-SLOTS))" +" s_78)))))))" +"(define-values" +"(cache-or-reuse-hash)" +"(lambda(s_79)" +"(begin" +"(let-values(((vec_20)" +"(let-values(((or-part_101)(weak-box-value cached-hashes)))" +"(if or-part_101" +" or-part_101" +"(let-values(((vec_21)(make-vector NUM-CACHE-SLOTS #f)))" +"(begin(set! cached-hashes(make-weak-box vec_21)) vec_21))))))" +"(let-values(((or-part_102)" +"(let-values(((vec_22 len_10)" +"(let-values(((vec_23) vec_20))" +"(begin(check-vector vec_23)(values vec_23(unsafe-vector-length vec_23))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_53)" +"(lambda(result_39 pos_8)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_8 len_10)" +"(let-values(((s2_6)(unsafe-vector-ref vec_22 pos_8)))" +"(let-values(((result_40)" +"(let-values()" +"(let-values(((result_41)" +"(let-values()" +"(let-values()" +"(if s2_6" +"(if(equal? s_79 s2_6) s2_6 #f)" +" #f)))))" +"(values result_41)))))" +"(if(if(not((lambda x_32 result_40) s2_6))(not #f) #f)" +"(for-loop_53 result_40(unsafe-fx+ 1 pos_8))" +" result_40)))" +" result_39)))))" +" for-loop_53)" +" #f" +" 0)))))" +"(if or-part_102" +" or-part_102" +"(begin" +"(vector-set! vec_20 cached-hashes-pos s_79)" +"(set! cached-hashes-pos(modulo(add1 cached-hashes-pos) NUM-CACHE-SLOTS))" +" s_79)))))))" +"(define-values" +"(struct:scope scope1.1 scope? scope-id scope-kind scope-binding-table set-scope-binding-table!)" +"(let-values(((struct:_19 make-_19 ?_19 -ref_19 -set!_19)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'scope" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:scope-with-bindings" +"(lambda(s_75 reachable-scopes_4 reach_4 register-trigger_2)" +"(binding-table-register-reachable" +"(scope-binding-table s_75)" +" reachable-scopes_4" +" reach_4" +" register-trigger_2)))" +"(cons prop:reach-scopes(lambda(s_80 reach_5)(void)))" +"(cons" +" prop:serialize-fill!" +"(lambda(s_81 ser-push!_4 state_13)" +"(if(binding-table-empty?(scope-binding-table s_81))" +"(let-values()(ser-push!_4 'tag #f))" +"(let-values()" +"(begin" +"(ser-push!_4 'tag '#:scope-fill!)" +"(ser-push!_4(binding-table-prune-to-reachable(scope-binding-table s_81) state_13)))))))" +"(cons" +" prop:serialize" +"(lambda(s_82 ser-push!_5 state_14)" +"(begin" +"(if(set-member?(serialize-state-reachable-scopes state_14) s_82)" +"(void)" +" (let-values () (error \"internal error: found supposedly unreachable scope\")))" +"(if(eq? s_82 top-level-common-scope)" +"(let-values()(ser-push!_5 'tag '#:scope))" +"(let-values()" +"(begin(ser-push!_5 'tag '#:scope+kind)(ser-push!_5(scope-kind s_82))))))))" +"(cons" +" prop:custom-write" +"(lambda(sc_1 port_6 mode_6)" +"(begin" +" (write-string \"#\" port_6)))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'scope)))))" +"(values" +" struct:_19" +" make-_19" +" ?_19" +"(make-struct-field-accessor -ref_19 0 'id)" +"(make-struct-field-accessor -ref_19 1 'kind)" +"(make-struct-field-accessor -ref_19 2 'binding-table)" +"(make-struct-field-mutator -set!_19 2 'binding-table))))" +"(define-values" +"(deserialize-scope)" +"(case-lambda" +"(()(begin top-level-common-scope))" +"((kind_0)(scope1.1(new-deserialize-scope-id!) kind_0 empty-binding-table))))" +"(define-values(deserialize-scope-fill!)(lambda(s_83 bt_5)(begin(set-scope-binding-table! s_83 bt_5))))" +"(define-values" +"(struct:multi-scope" +" multi-scope2.1" +" multi-scope?" +" multi-scope-id" +" multi-scope-name" +" multi-scope-scopes" +" multi-scope-shifted" +" multi-scope-label-shifted)" +"(let-values(((struct:_20 make-_20 ?_20 -ref_20 -set!_20)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'multi-scope" +" #f" +" 5" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons prop:reach-scopes(lambda(ms_0 reach_6)(reach_6(multi-scope-scopes ms_0))))" +"(cons" +" prop:serialize" +"(lambda(ms_1 ser-push!_6 state_6)" +"(begin" +"(ser-push!_6 'tag '#:multi-scope)" +"(ser-push!_6(multi-scope-name ms_1))" +"(ser-push!_6(multi-scope-scopes ms_1))))))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4)" +" #f" +" 'multi-scope)))))" +"(values" +" struct:_20" +" make-_20" +" ?_20" +"(make-struct-field-accessor -ref_20 0 'id)" +"(make-struct-field-accessor -ref_20 1 'name)" +"(make-struct-field-accessor -ref_20 2 'scopes)" +"(make-struct-field-accessor -ref_20 3 'shifted)" +"(make-struct-field-accessor -ref_20 4 'label-shifted))))" +"(define-values" +"(deserialize-multi-scope)" +"(lambda(name_15 scopes_8)" +"(begin(multi-scope2.1(new-deserialize-scope-id!) name_15 scopes_8(box(hasheqv))(box(hash))))))" +"(define-values" +"(struct:representative-scope" +" representative-scope3.1" +" representative-scope?" +" representative-scope-owner" +" representative-scope-phase" +" set-representative-scope-owner!" +" set-representative-scope-phase!)" +"(let-values(((struct:_21 make-_21 ?_21 -ref_21 -set!_21)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'representative-scope" +" struct:scope" +" 2" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons prop:reach-scopes(lambda(s_28 reach_7)(reach_7(representative-scope-owner s_28))))" +"(cons" +" prop:serialize-fill!" +"(lambda(s_30 ser-push!_7 state_15)" +"(begin" +"(ser-push!_7 'tag '#:representative-scope-fill!)" +"(ser-push!_7(binding-table-prune-to-reachable(scope-binding-table s_30) state_15))" +"(ser-push!_7(representative-scope-owner s_30)))))" +"(cons" +" prop:serialize" +"(lambda(s_84 ser-push!_8 state_16)" +"(begin" +"(ser-push!_8 'tag '#:representative-scope)" +"(ser-push!_8(scope-kind s_84))" +"(ser-push!_8(representative-scope-phase s_84)))))" +"(cons" +" prop:custom-write" +"(lambda(sc_2 port_7 mode_7)" +"(begin" +" (write-string \"#\" port_7)))))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'representative-scope)))))" +"(values" +" struct:_21" +" make-_21" +" ?_21" +"(make-struct-field-accessor -ref_21 0 'owner)" +"(make-struct-field-accessor -ref_21 1 'phase)" +"(make-struct-field-mutator -set!_21 0 'owner)" +"(make-struct-field-mutator -set!_21 1 'phase))))" +"(define-values" +"(deserialize-representative-scope)" +"(lambda(kind_1 phase_2)" +"(begin(let-values(((v_53)(representative-scope3.1(new-deserialize-scope-id!) kind_1 #f #f phase_2))) v_53))))" +"(define-values" +"(deserialize-representative-scope-fill!)" +"(lambda(s_85 bt_6 owner_0)" +"(begin(begin(deserialize-scope-fill! s_85 bt_6)(set-representative-scope-owner! s_85 owner_0)))))" +"(define-values" +"(struct:shifted-multi-scope" +" shifted-multi-scope4.1" +" shifted-multi-scope?" +" shifted-multi-scope-phase" +" shifted-multi-scope-multi-scope)" +"(let-values(((struct:_22 make-_22 ?_22 -ref_22 -set!_22)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'shifted-multi-scope" +" #f" +" 2" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:reach-scopes" +"(lambda(sms_3 reach_8)(reach_8(shifted-multi-scope-multi-scope sms_3))))" +"(cons" +" prop:serialize" +"(lambda(sms_4 ser-push!_9 state_17)" +"(begin" +"(ser-push!_9 'tag '#:shifted-multi-scope)" +"(ser-push!_9(shifted-multi-scope-phase sms_4))" +"(ser-push!_9(shifted-multi-scope-multi-scope sms_4)))))" +"(cons" +" prop:custom-write" +"(lambda(sms_5 port_8 mode_8)" +"(begin" +" (write-string \"#\" port_8)))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'shifted-multi-scope)))))" +"(values" +" struct:_22" +" make-_22" +" ?_22" +"(make-struct-field-accessor -ref_22 0 'phase)" +"(make-struct-field-accessor -ref_22 1 'multi-scope))))" +"(define-values" +"(deserialize-shifted-multi-scope)" +"(lambda(phase_3 multi-scope_0)(begin(intern-shifted-multi-scope phase_3 multi-scope_0))))" +"(define-values" +"(intern-shifted-multi-scope)" +"(lambda(phase_4 multi-scope_1)" +"(begin" +"(letrec-values(((transaction-loop_0)" +"(lambda(boxed-table_0 key_24 make_0)" +"(begin" +" 'transaction-loop" +"(let-values(((or-part_60)(hash-ref(unbox boxed-table_0) phase_4 #f)))" +"(if or-part_60" +" or-part_60" +"(let-values(((val_14)(make_0)))" +"(let-values(((current_0)(unbox boxed-table_0)))" +"(let-values(((next_3)(hash-set current_0 key_24 val_14)))" +"(if(box-cas! boxed-table_0 current_0 next_3)" +" val_14" +"(transaction-loop_0 boxed-table_0 key_24 make_0)))))))))))" +"(if(phase? phase_4)" +"(let-values()" +"(let-values(((or-part_103)(hash-ref(unbox(multi-scope-shifted multi-scope_1)) phase_4 #f)))" +"(if or-part_103" +" or-part_103" +"(transaction-loop_0" +"(multi-scope-shifted multi-scope_1)" +" phase_4" +"(lambda()(shifted-multi-scope4.1 phase_4 multi-scope_1))))))" +"(let-values()" +"(let-values(((or-part_104)(hash-ref(unbox(multi-scope-label-shifted multi-scope_1)) phase_4 #f)))" +"(if or-part_104" +" or-part_104" +"(transaction-loop_0" +"(multi-scope-label-shifted multi-scope_1)" +" phase_4" +"(lambda()(shifted-multi-scope4.1 phase_4 multi-scope_1)))))))))))" +"(define-values" +"(struct:shifted-to-label-phase shifted-to-label-phase5.1 shifted-to-label-phase? shifted-to-label-phase-from)" +"(let-values(((struct:_23 make-_23 ?_23 -ref_23 -set!_23)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'shifted-to-label-phase" +" #f" +" 1" +" 0" +" #f" +" null" +" 'prefab" +" #f" +" '(0)" +" #f" +" 'shifted-to-label-phase)))))" +"(values struct:_23 make-_23 ?_23(make-struct-field-accessor -ref_23 0 'from))))" +"(define-values(id-counter) 0)" +"(define-values(new-scope-id!)(lambda()(begin(begin(set! id-counter(add1 id-counter)) id-counter))))" +"(define-values(new-deserialize-scope-id!)(lambda()(begin(-(new-scope-id!)))))" +"(define-values(top-level-common-scope)(scope1.1 0 'module empty-binding-table))" +"(define-values(new-scope)(lambda(kind_2)(begin(scope1.1(new-scope-id!) kind_2 empty-binding-table))))" +"(define-values" +"(new-multi-scope)" +"(let-values(((new-multi-scope8_0)" +"(lambda(name6_0 name7_0)" +"(begin" +" 'new-multi-scope8" +"(let-values(((name_16)(if name7_0 name6_0 #f)))" +"(let-values()" +"(intern-shifted-multi-scope" +" 0" +"(multi-scope2.1(new-scope-id!) name_16(make-hasheqv)(box(hasheqv))(box(hash))))))))))" +"(case-lambda(()(begin(new-multi-scope8_0 #f #f)))((name6_1)(new-multi-scope8_0 name6_1 #t)))))" +"(define-values" +"(multi-scope-to-scope-at-phase)" +"(lambda(ms_2 phase_5)" +"(begin" +"(let-values(((or-part_92)(hash-ref(multi-scope-scopes ms_2) phase_5 #f)))" +"(if or-part_92" +" or-part_92" +"(let-values(((s_86)(representative-scope3.1(new-scope-id!) 'module empty-binding-table ms_2 phase_5)))" +"(begin(hash-set!(multi-scope-scopes ms_2) phase_5 s_86) s_86)))))))" +"(define-values(scope>?)(lambda(sc1_0 sc2_0)(begin(>(scope-id sc1_0)(scope-id sc2_0)))))" +"(define-values(scope_2)" +"(lambda(sub-s_1)" +"(begin" +" 's->" +"(if(propagation? prop_3)" +"(let-values(((the-struct_11) sub-s_1))" +"(if(syntax?$1 the-struct_11)" +"(let-values(((scopes41_0)" +"(propagation-apply prop_3(syntax-scopes sub-s_1) s_87))" +"((shifted-multi-scopes42_0)" +"(propagation-apply-shifted" +" prop_3" +"(syntax-shifted-multi-scopes sub-s_1)" +" s_87))" +"((mpi-shifts43_0)" +"(propagation-apply-mpi-shifts" +" prop_3" +"(syntax-mpi-shifts sub-s_1)" +" s_87))" +"((inspector44_0)" +"(propagation-apply-inspector" +" prop_3" +"(syntax-inspector sub-s_1)))" +"((scope-propagations+tamper45_0)" +"(propagation-merge" +"(syntax-content sub-s_1)" +" prop_3" +"(syntax-scope-propagations+tamper sub-s_1)" +"(syntax-scopes sub-s_1)" +"(syntax-shifted-multi-scopes sub-s_1)" +"(syntax-mpi-shifts sub-s_1))))" +"(syntax1.1" +"(syntax-content the-struct_11)" +" scopes41_0" +" shifted-multi-scopes42_0" +" scope-propagations+tamper45_0" +" mpi-shifts43_0" +"(syntax-srcloc the-struct_11)" +"(syntax-props the-struct_11)" +" inspector44_0))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_11)))" +"(let-values(((the-struct_12) sub-s_1))" +"(if(syntax?$1 the-struct_12)" +"(let-values(((scope-propagations+tamper46_0)" +"(tamper-tainted-for-content(syntax-content sub-s_1))))" +"(syntax1.1" +"(syntax-content the-struct_12)" +"(syntax-scopes the-struct_12)" +"(syntax-shifted-multi-scopes the-struct_12)" +" scope-propagations+tamper46_0" +"(syntax-mpi-shifts the-struct_12)" +"(syntax-srcloc the-struct_12)" +"(syntax-props the-struct_12)" +"(syntax-inspector the-struct_12)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_12)))))))" +"((seen_9) #f))" +"(let-values(((s_89) s_88)" +"((f_28)" +"(lambda(tail?_20 v_77)" +"(begin" +" 'f" +"(if(syntax?$1 v_77)" +"(let-values()(s->_2 v_77))" +"(let-values()(f_27 tail?_20 v_77))))))" +"((seen_10) seen_9))" +"((letrec-values(((loop_68)" +"(lambda(tail?_21 s_90 prev-depth_4)" +"(begin" +" 'loop" +"(let-values(((depth_4)(add1 prev-depth_4)))" +"(if(if seen_10(> depth_4 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_21" +" s_90" +"(lambda(tail?_22 s_91)(f_28 tail?_22 s_91))" +" seen_10))" +"(if(null? s_90)" +"(let-values()(f_28 tail?_21 s_90))" +"(if(pair? s_90)" +"(let-values()" +"(f_28" +" tail?_21" +"(cons" +"(loop_68 #f(car s_90) depth_4)" +"(loop_68 #t(cdr s_90) depth_4))))" +"(if(let-values(((or-part_106)(symbol? s_90)))" +"(if or-part_106" +" or-part_106" +"(let-values(((or-part_61)(boolean? s_90)))" +"(if or-part_61 or-part_61(number? s_90)))))" +"(let-values()(f_28 #f s_90))" +"(if(let-values(((or-part_107)(vector? s_90)))" +"(if or-part_107" +" or-part_107" +"(let-values(((or-part_62)(box? s_90)))" +"(if or-part_62" +" or-part_62" +"(let-values(((or-part_63)" +"(prefab-struct-key s_90)))" +"(if or-part_63 or-part_63(hash? s_90)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_21" +" s_90" +"(lambda(tail?_23 s_92)(f_28 tail?_23 s_92))" +" seen_10))" +"(let-values()(f_28 #f s_90))))))))))))" +" loop_68)" +" #f" +" s_89" +" 0)))))" +"(begin" +"(set-syntax-content! s_87 new-content_0)" +"(set-syntax-scope-propagations+tamper!" +" s_87" +"(tamper-propagated(if(propagation? prop_3)(propagation-tamper prop_3) prop_3)))" +" new-content_0))" +"(syntax-content s_87))))))" +"(define-values" +"(syntax-e$1)" +"(lambda(s_93)" +"(begin" +" 'syntax-e" +"(let-values(((content_4)(syntax-e/no-taint s_93)))" +"(if(not(tamper-armed?(syntax-tamper s_93)))" +"(let-values() content_4)" +"(if(datum-has-elements? content_4)(let-values()(taint-content content_4))(let-values() content_4)))))))" +"(define-values" +"(generalize-scope)" +"(lambda(sc_3)" +"(begin" +"(if(representative-scope? sc_3)" +"(intern-shifted-multi-scope(representative-scope-phase sc_3)(representative-scope-owner sc_3))" +" sc_3))))" +"(define-values" +"(add-scope)" +"(lambda(s_94 sc_4)" +"(begin" +"(let-values(((s_95) s_94)((sc_5)(generalize-scope sc_4))((op_0) set-add)((prop-op_0) propagation-add))" +"(if(shifted-multi-scope? sc_5)" +"(let-values(((the-struct_13) s_95))" +"(if(syntax?$1 the-struct_13)" +"(let-values(((shifted-multi-scopes47_0)" +"(fallback-update-first" +"(syntax-shifted-multi-scopes s_95)" +"(lambda(smss_9)(op_0(fallback-first smss_9) sc_5))))" +"((scope-propagations+tamper48_0)" +"(if(datum-has-elements?(syntax-content s_95))" +"(prop-op_0" +"(syntax-scope-propagations+tamper s_95)" +" sc_5" +"(syntax-scopes s_95)" +"(syntax-shifted-multi-scopes s_95)" +"(syntax-mpi-shifts s_95))" +"(syntax-scope-propagations+tamper s_95))))" +"(syntax1.1" +"(syntax-content the-struct_13)" +"(syntax-scopes the-struct_13)" +" shifted-multi-scopes47_0" +" scope-propagations+tamper48_0" +"(syntax-mpi-shifts the-struct_13)" +"(syntax-srcloc the-struct_13)" +"(syntax-props the-struct_13)" +"(syntax-inspector the-struct_13)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_13)))" +"(let-values(((the-struct_14) s_95))" +"(if(syntax?$1 the-struct_14)" +"(let-values(((scopes49_0)(op_0(syntax-scopes s_95) sc_5))" +"((scope-propagations+tamper50_0)" +"(if(datum-has-elements?(syntax-content s_95))" +"(prop-op_0" +"(syntax-scope-propagations+tamper s_95)" +" sc_5" +"(syntax-scopes s_95)" +"(syntax-shifted-multi-scopes s_95)" +"(syntax-mpi-shifts s_95))" +"(syntax-scope-propagations+tamper s_95))))" +"(syntax1.1" +"(syntax-content the-struct_14)" +" scopes49_0" +"(syntax-shifted-multi-scopes the-struct_14)" +" scope-propagations+tamper50_0" +"(syntax-mpi-shifts the-struct_14)" +"(syntax-srcloc the-struct_14)" +"(syntax-props the-struct_14)" +"(syntax-inspector the-struct_14)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_14))))))))" +"(define-values" +"(add-scopes)" +"(lambda(s_96 scs_5)" +"(begin" +"(let-values(((lst_40) scs_5))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_40)))" +"((letrec-values(((for-loop_54)" +"(lambda(s_97 lst_41)" +"(begin" +" 'for-loop" +"(if(pair? lst_41)" +"(let-values(((sc_6)(unsafe-car lst_41))((rest_17)(unsafe-cdr lst_41)))" +"(let-values(((s_98)" +"(let-values(((s_99) s_97))" +"(let-values(((s_100)(let-values()(add-scope s_99 sc_6))))" +"(values s_100)))))" +"(if(not #f)(for-loop_54 s_98 rest_17) s_98)))" +" s_97)))))" +" for-loop_54)" +" s_96" +" lst_40))))))" +"(define-values" +"(remove-scope)" +"(lambda(s_101 sc_7)" +"(begin" +"(let-values(((s_102) s_101)" +"((sc_8)(generalize-scope sc_7))" +"((op_1) set-remove)" +"((prop-op_1) propagation-remove))" +"(if(shifted-multi-scope? sc_8)" +"(let-values(((the-struct_15) s_102))" +"(if(syntax?$1 the-struct_15)" +"(let-values(((shifted-multi-scopes51_0)" +"(fallback-update-first" +"(syntax-shifted-multi-scopes s_102)" +"(lambda(smss_10)(op_1(fallback-first smss_10) sc_8))))" +"((scope-propagations+tamper52_0)" +"(if(datum-has-elements?(syntax-content s_102))" +"(prop-op_1" +"(syntax-scope-propagations+tamper s_102)" +" sc_8" +"(syntax-scopes s_102)" +"(syntax-shifted-multi-scopes s_102)" +"(syntax-mpi-shifts s_102))" +"(syntax-scope-propagations+tamper s_102))))" +"(syntax1.1" +"(syntax-content the-struct_15)" +"(syntax-scopes the-struct_15)" +" shifted-multi-scopes51_0" +" scope-propagations+tamper52_0" +"(syntax-mpi-shifts the-struct_15)" +"(syntax-srcloc the-struct_15)" +"(syntax-props the-struct_15)" +"(syntax-inspector the-struct_15)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_15)))" +"(let-values(((the-struct_16) s_102))" +"(if(syntax?$1 the-struct_16)" +"(let-values(((scopes53_0)(op_1(syntax-scopes s_102) sc_8))" +"((scope-propagations+tamper54_0)" +"(if(datum-has-elements?(syntax-content s_102))" +"(prop-op_1" +"(syntax-scope-propagations+tamper s_102)" +" sc_8" +"(syntax-scopes s_102)" +"(syntax-shifted-multi-scopes s_102)" +"(syntax-mpi-shifts s_102))" +"(syntax-scope-propagations+tamper s_102))))" +"(syntax1.1" +"(syntax-content the-struct_16)" +" scopes53_0" +"(syntax-shifted-multi-scopes the-struct_16)" +" scope-propagations+tamper54_0" +"(syntax-mpi-shifts the-struct_16)" +"(syntax-srcloc the-struct_16)" +"(syntax-props the-struct_16)" +"(syntax-inspector the-struct_16)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_16))))))))" +"(define-values" +"(remove-scopes)" +"(lambda(s_103 scs_6)" +"(begin" +"(let-values(((lst_42) scs_6))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_42)))" +"((letrec-values(((for-loop_55)" +"(lambda(s_104 lst_43)" +"(begin" +" 'for-loop" +"(if(pair? lst_43)" +"(let-values(((sc_9)(unsafe-car lst_43))((rest_18)(unsafe-cdr lst_43)))" +"(let-values(((s_105)" +"(let-values(((s_106) s_104))" +"(let-values(((s_107)(let-values()(remove-scope s_106 sc_9))))" +"(values s_107)))))" +"(if(not #f)(for-loop_55 s_105 rest_18) s_105)))" +" s_104)))))" +" for-loop_55)" +" s_103" +" lst_42))))))" +"(define-values" +"(set-flip)" +"(lambda(s_108 e_15)(begin(if(set-member? s_108 e_15)(set-remove s_108 e_15)(set-add s_108 e_15)))))" +"(define-values" +"(flip-scope)" +"(lambda(s_109 sc_10)" +"(begin" +"(let-values(((s_110) s_109)((sc_11)(generalize-scope sc_10))((op_2) set-flip)((prop-op_2) propagation-flip))" +"(if(shifted-multi-scope? sc_11)" +"(let-values(((the-struct_17) s_110))" +"(if(syntax?$1 the-struct_17)" +"(let-values(((shifted-multi-scopes55_0)" +"(fallback-update-first" +"(syntax-shifted-multi-scopes s_110)" +"(lambda(smss_11)(op_2(fallback-first smss_11) sc_11))))" +"((scope-propagations+tamper56_0)" +"(if(datum-has-elements?(syntax-content s_110))" +"(prop-op_2" +"(syntax-scope-propagations+tamper s_110)" +" sc_11" +"(syntax-scopes s_110)" +"(syntax-shifted-multi-scopes s_110)" +"(syntax-mpi-shifts s_110))" +"(syntax-scope-propagations+tamper s_110))))" +"(syntax1.1" +"(syntax-content the-struct_17)" +"(syntax-scopes the-struct_17)" +" shifted-multi-scopes55_0" +" scope-propagations+tamper56_0" +"(syntax-mpi-shifts the-struct_17)" +"(syntax-srcloc the-struct_17)" +"(syntax-props the-struct_17)" +"(syntax-inspector the-struct_17)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_17)))" +"(let-values(((the-struct_18) s_110))" +"(if(syntax?$1 the-struct_18)" +"(let-values(((scopes57_0)(op_2(syntax-scopes s_110) sc_11))" +"((scope-propagations+tamper58_0)" +"(if(datum-has-elements?(syntax-content s_110))" +"(prop-op_2" +"(syntax-scope-propagations+tamper s_110)" +" sc_11" +"(syntax-scopes s_110)" +"(syntax-shifted-multi-scopes s_110)" +"(syntax-mpi-shifts s_110))" +"(syntax-scope-propagations+tamper s_110))))" +"(syntax1.1" +"(syntax-content the-struct_18)" +" scopes57_0" +"(syntax-shifted-multi-scopes the-struct_18)" +" scope-propagations+tamper58_0" +"(syntax-mpi-shifts the-struct_18)" +"(syntax-srcloc the-struct_18)" +"(syntax-props the-struct_18)" +"(syntax-inspector the-struct_18)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_18))))))))" +"(define-values" +"(flip-scopes)" +"(lambda(s_111 scs_7)" +"(begin" +"(let-values(((lst_44) scs_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_44)))" +"((letrec-values(((for-loop_56)" +"(lambda(s_112 lst_45)" +"(begin" +" 'for-loop" +"(if(pair? lst_45)" +"(let-values(((sc_12)(unsafe-car lst_45))((rest_19)(unsafe-cdr lst_45)))" +"(let-values(((s_113)" +"(let-values(((s_114) s_112))" +"(let-values(((s_115)(let-values()(flip-scope s_114 sc_12))))" +"(values s_115)))))" +"(if(not #f)(for-loop_56 s_113 rest_19) s_113)))" +" s_112)))))" +" for-loop_56)" +" s_111" +" lst_44))))))" +"(define-values" +"(push-scope)" +"(lambda(s_116 sms_6)" +"(begin" +"(let-values(((smss/maybe-fallbacks59_0) #f))" +"(let-values(((prev-result_0) #f))" +"(let-values(((push_0)" +"(lambda(smss/maybe-fallbacks_0)" +"(begin" +" 'push" +"(if(eq? smss/maybe-fallbacks59_0 smss/maybe-fallbacks_0)" +"(let-values() prev-result_0)" +"(let-values()" +"(let-values(((r_22)" +"(let-values()" +"(let-values(((smss_12)(fallback-first smss/maybe-fallbacks_0)))" +"(if(set-empty? smss_12)" +"(let-values()(set-add smss_12 sms_6))" +"(if(set-member? smss_12 sms_6)" +"(let-values() smss/maybe-fallbacks_0)" +"(let-values()" +"(fallback-push" +"(set-add smss_12 sms_6)" +" smss/maybe-fallbacks_0))))))))" +"(begin" +"(set! smss/maybe-fallbacks59_0 smss/maybe-fallbacks_0)" +"(set! prev-result_0 r_22)" +" r_22))))))))" +"(let-values(((s_117) s_116)" +"((f_29)(lambda(tail?_24 x_34)(begin 'f x_34)))" +"((d->s_1)" +"(lambda(s_118 d_3)" +"(begin" +" 'd->s" +"(let-values(((the-struct_19) s_118))" +"(if(syntax?$1 the-struct_19)" +"(let-values(((content60_0) d_3)" +"((shifted-multi-scopes61_0)" +"(push_0(syntax-shifted-multi-scopes s_118))))" +"(syntax1.1" +" content60_0" +"(syntax-scopes the-struct_19)" +" shifted-multi-scopes61_0" +"(syntax-scope-propagations+tamper the-struct_19)" +"(syntax-mpi-shifts the-struct_19)" +"(syntax-srcloc the-struct_19)" +"(syntax-props the-struct_19)" +"(syntax-inspector the-struct_19)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_19))))))" +"((s-e_1) syntax-e/no-taint)" +"((seen_11) #f))" +"((letrec-values(((loop_69)" +"(lambda(s_119)" +"(begin" +" 'loop" +"(let-values(((s_120) s_119)" +"((f_30)" +"(lambda(tail?_25 v_78)" +"(begin" +" 'f" +"(if(syntax?$1 v_78)" +"(let-values()(d->s_1 v_78(loop_69(s-e_1 v_78))))" +"(let-values()(f_29 tail?_25 v_78))))))" +"((seen_12) seen_11))" +"((letrec-values(((loop_70)" +"(lambda(tail?_26 s_121 prev-depth_5)" +"(begin" +" 'loop" +"(let-values(((depth_5)(add1 prev-depth_5)))" +"(if(if seen_12(> depth_5 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_26" +" s_121" +"(lambda(tail?_27 s_122)(f_30 tail?_27 s_122))" +" seen_12))" +"(if(null? s_121)" +"(let-values()(f_30 tail?_26 s_121))" +"(if(pair? s_121)" +"(let-values()" +"(f_30" +" tail?_26" +"(cons" +"(loop_70 #f(car s_121) depth_5)" +"(loop_70 #t(cdr s_121) depth_5))))" +"(if(let-values(((or-part_108)(symbol? s_121)))" +"(if or-part_108" +" or-part_108" +"(let-values(((or-part_109)" +"(boolean? s_121)))" +"(if or-part_109" +" or-part_109" +"(number? s_121)))))" +"(let-values()(f_30 #f s_121))" +"(if(let-values(((or-part_110)(vector? s_121)))" +"(if or-part_110" +" or-part_110" +"(let-values(((or-part_111)(box? s_121)))" +"(if or-part_111" +" or-part_111" +"(let-values(((or-part_112)" +"(prefab-struct-key" +" s_121)))" +"(if or-part_112" +" or-part_112" +"(hash? s_121)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_26" +" s_121" +"(lambda(tail?_28 s_123)" +"(f_30 tail?_28 s_123))" +" seen_12))" +"(let-values()(f_30 #f s_121))))))))))))" +" loop_70)" +" #f" +" s_120" +" 0))))))" +" loop_69)" +" s_117))))))))" +"(define-values" +"(struct:propagation" +" propagation14.1" +" propagation?" +" propagation-prev-scs" +" propagation-prev-smss" +" propagation-scope-ops" +" propagation-prev-mss" +" propagation-add-mpi-shifts" +" propagation-inspector" +" propagation-tamper)" +"(let-values(((struct:_24 make-_24 ?_24 -ref_24 -set!_24)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'propagation" +" #f" +" 7" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons prop:propagation-set-tamper(lambda(p_27 v_79)(propagation-set-tamper p_27 v_79)))" +"(cons prop:propagation-tamper(lambda(p_28)(propagation-tamper p_28)))" +"(cons prop:propagation syntax-e$1))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'propagation)))))" +"(values" +" struct:_24" +" make-_24" +" ?_24" +"(make-struct-field-accessor -ref_24 0 'prev-scs)" +"(make-struct-field-accessor -ref_24 1 'prev-smss)" +"(make-struct-field-accessor -ref_24 2 'scope-ops)" +"(make-struct-field-accessor -ref_24 3 'prev-mss)" +"(make-struct-field-accessor -ref_24 4 'add-mpi-shifts)" +"(make-struct-field-accessor -ref_24 5 'inspector)" +"(make-struct-field-accessor -ref_24 6 'tamper))))" +"(define-values" +"(propagation-add)" +"(lambda(prop_4 sc_13 prev-scs_0 prev-smss_0 prev-mss_0)" +"(begin" +"(if(propagation? prop_4)" +"(let-values(((the-struct_20) prop_4))" +"(if(propagation? the-struct_20)" +"(let-values(((scope-ops63_0)(hash-set(propagation-scope-ops prop_4) sc_13 'add)))" +"(propagation14.1" +"(propagation-prev-scs the-struct_20)" +"(propagation-prev-smss the-struct_20)" +" scope-ops63_0" +"(propagation-prev-mss the-struct_20)" +"(propagation-add-mpi-shifts the-struct_20)" +"(propagation-inspector the-struct_20)" +"(propagation-tamper the-struct_20)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_20)))" +"(propagation14.1 prev-scs_0 prev-smss_0(hasheq sc_13 'add) prev-mss_0 #f #f prop_4)))))" +"(define-values" +"(propagation-remove)" +"(lambda(prop_5 sc_14 prev-scs_1 prev-smss_1 prev-mss_1)" +"(begin" +"(if(propagation? prop_5)" +"(let-values(((the-struct_21) prop_5))" +"(if(propagation? the-struct_21)" +"(let-values(((scope-ops64_0)(hash-set(propagation-scope-ops prop_5) sc_14 'remove)))" +"(propagation14.1" +"(propagation-prev-scs the-struct_21)" +"(propagation-prev-smss the-struct_21)" +" scope-ops64_0" +"(propagation-prev-mss the-struct_21)" +"(propagation-add-mpi-shifts the-struct_21)" +"(propagation-inspector the-struct_21)" +"(propagation-tamper the-struct_21)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_21)))" +"(propagation14.1 prev-scs_1 prev-smss_1(hasheq sc_14 'remove) prev-mss_1 #f #f prop_5)))))" +"(define-values" +"(propagation-flip)" +"(lambda(prop_6 sc_15 prev-scs_2 prev-smss_2 prev-mss_2)" +"(begin" +"(if(propagation? prop_6)" +"(let-values(((ops_0)(propagation-scope-ops prop_6)))" +"(let-values(((current-op_0)(hash-ref ops_0 sc_15 #f)))" +"(if(if(eq? current-op_0 'flip)" +"(if(= 1(hash-count ops_0))" +"(if(not(propagation-inspector prop_6))(not(propagation-add-mpi-shifts prop_6)) #f)" +" #f)" +" #f)" +"(let-values() #f)" +"(let-values()" +"(let-values(((the-struct_22) prop_6))" +"(if(propagation? the-struct_22)" +"(let-values(((scope-ops65_0)" +"(if(eq? current-op_0 'flip)" +"(hash-remove ops_0 sc_15)" +"(hash-set" +" ops_0" +" sc_15" +"(let-values(((tmp_9) current-op_0))" +"(if(equal? tmp_9 'add)" +"(let-values() 'remove)" +"(if(equal? tmp_9 'remove)(let-values() 'add)(let-values() 'flip))))))))" +"(propagation14.1" +"(propagation-prev-scs the-struct_22)" +"(propagation-prev-smss the-struct_22)" +" scope-ops65_0" +"(propagation-prev-mss the-struct_22)" +"(propagation-add-mpi-shifts the-struct_22)" +"(propagation-inspector the-struct_22)" +"(propagation-tamper the-struct_22)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_22)))))))" +"(propagation14.1 prev-scs_2 prev-smss_2(hasheq sc_15 'flip) prev-mss_2 #f #f prop_6)))))" +"(define-values" +"(propagation-mpi-shift)" +"(lambda(prop_7 add_0 inspector_2 prev-scs_3 prev-smss_3 prev-mss_3)" +"(begin" +"(if(propagation? prop_7)" +"(let-values(((the-struct_23) prop_7))" +"(if(propagation? the-struct_23)" +"(let-values(((add-mpi-shifts66_0)" +"(let-values(((base-add_0)(propagation-add-mpi-shifts prop_7)))" +"(if(if add_0 base-add_0 #f)" +"(lambda(mss_0)(begin 'add-mpi-shifts66(add_0(base-add_0 mss_0))))" +"(let-values(((or-part_113) add_0))(if or-part_113 or-part_113 base-add_0)))))" +"((inspector67_0)" +"(let-values(((or-part_114)(propagation-inspector prop_7)))" +"(if or-part_114 or-part_114 inspector_2))))" +"(propagation14.1" +"(propagation-prev-scs the-struct_23)" +"(propagation-prev-smss the-struct_23)" +"(propagation-scope-ops the-struct_23)" +"(propagation-prev-mss the-struct_23)" +" add-mpi-shifts66_0" +" inspector67_0" +"(propagation-tamper the-struct_23)))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_23)))" +"(propagation14.1 prev-scs_3 prev-smss_3 '#hasheq() prev-mss_3 add_0 inspector_2 prop_7)))))" +"(define-values" +"(propagation-apply)" +"(lambda(prop_8 scs_8 parent-s_0)" +"(begin" +"(if(eq?(propagation-prev-scs prop_8) scs_8)" +"(let-values()(syntax-scopes parent-s_0))" +"(let-values()" +"(let-values(((new-scs_0)" +"(let-values(((ht_49)(propagation-scope-ops prop_8)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_49)))" +"((letrec-values(((for-loop_57)" +"(lambda(scs_9 i_62)" +"(begin" +" 'for-loop" +"(if i_62" +"(let-values(((sc_16 op_3)" +"(unsafe-immutable-hash-iterate-key+value ht_49 i_62)))" +"(let-values(((scs_10)" +"(let-values(((scs_11) scs_9))" +"(if(not(shifted-multi-scope? sc_16))" +"(let-values(((scs_12) scs_11))" +"(let-values(((scs_13)" +"(let-values()" +"(let-values(((tmp_10) op_3))" +"(if(equal? tmp_10 'add)" +"(let-values()" +"(set-add scs_12 sc_16))" +"(if(equal?" +" tmp_10" +" 'remove)" +"(let-values()" +"(set-remove" +" scs_12" +" sc_16))" +"(let-values()" +"(set-flip" +" scs_12" +" sc_16))))))))" +"(values scs_13)))" +" scs_11))))" +"(if(not #f)" +"(for-loop_57" +" scs_10" +"(unsafe-immutable-hash-iterate-next ht_49 i_62))" +" scs_10)))" +" scs_9)))))" +" for-loop_57)" +" scs_8" +"(unsafe-immutable-hash-iterate-first ht_49))))))" +"(if(set=? new-scs_0(syntax-scopes parent-s_0))" +"(syntax-scopes parent-s_0)" +"(cache-or-reuse-set new-scs_0))))))))" +"(define-values" +"(propagation-apply-shifted)" +"(lambda(prop_9 smss_13 parent-s_1)" +"(begin" +"(if(eq?(propagation-prev-smss prop_9) smss_13)" +"(let-values()(syntax-shifted-multi-scopes parent-s_1))" +"(let-values()" +"(let-values(((new-smss_0)" +"(let-values(((ht_50)(propagation-scope-ops prop_9)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_50)))" +"((letrec-values(((for-loop_58)" +"(lambda(smss_14 i_63)" +"(begin" +" 'for-loop" +"(if i_63" +"(let-values(((sms_7 op_4)" +"(unsafe-immutable-hash-iterate-key+value ht_50 i_63)))" +"(let-values(((smss_15)" +"(let-values(((smss_16) smss_14))" +"(if(shifted-multi-scope? sms_7)" +"(let-values(((smss_17) smss_16))" +"(let-values(((smss_18)" +"(let-values()" +"(fallback-update-first" +" smss_17" +"(lambda(smss_19)" +"(let-values(((tmp_11)" +" op_4))" +"(if(equal? tmp_11 'add)" +"(let-values()" +"(set-add" +" smss_19" +" sms_7))" +"(if(equal?" +" tmp_11" +" 'remove)" +"(let-values()" +"(set-remove" +" smss_19" +" sms_7))" +"(let-values()" +"(set-flip" +" smss_19" +" sms_7))))))))))" +"(values smss_18)))" +" smss_16))))" +"(if(not #f)" +"(for-loop_58" +" smss_15" +"(unsafe-immutable-hash-iterate-next ht_50 i_63))" +" smss_15)))" +" smss_14)))))" +" for-loop_58)" +" smss_13" +"(unsafe-immutable-hash-iterate-first ht_50))))))" +"(let-values(((parent-smss_0)(syntax-shifted-multi-scopes parent-s_1)))" +"(if(if(set? new-smss_0)(if(set? parent-smss_0)(set=? new-smss_0 parent-smss_0) #f) #f)" +" parent-smss_0" +"(cache-or-reuse-hash new-smss_0)))))))))" +"(define-values" +"(propagation-apply-mpi-shifts)" +"(lambda(prop_10 mss_1 parent-s_2)" +"(begin" +"(if(eq?(propagation-prev-mss prop_10) mss_1)" +"(let-values()(syntax-mpi-shifts parent-s_2))" +"(let-values()(let-values(((add_1)(propagation-add-mpi-shifts prop_10)))(if add_1(add_1 mss_1) mss_1)))))))" +"(define-values" +"(propagation-apply-inspector)" +"(lambda(prop_11 i_64)" +"(begin(let-values(((or-part_115) i_64))(if or-part_115 or-part_115(propagation-inspector prop_11))))))" +"(define-values" +"(propagation-set-tamper)" +"(lambda(prop_12 t_32)" +"(begin" +"(if(propagation? prop_12)" +"(let-values(((the-struct_24) prop_12))" +"(if(propagation? the-struct_24)" +"(let-values(((tamper68_0) t_32))" +"(propagation14.1" +"(propagation-prev-scs the-struct_24)" +"(propagation-prev-smss the-struct_24)" +"(propagation-scope-ops the-struct_24)" +"(propagation-prev-mss the-struct_24)" +"(propagation-add-mpi-shifts the-struct_24)" +"(propagation-inspector the-struct_24)" +" tamper68_0))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_24)))" +" t_32))))" +"(define-values" +"(propagation-merge)" +"(lambda(content_6 prop_13 base-prop_0 prev-scs_4 prev-smss_4 prev-mss_4)" +"(begin" +"(if(not(datum-has-elements? content_6))" +"(let-values()(if(tamper-tainted?(propagation-tamper prop_13)) 'tainted base-prop_0))" +"(if(not(propagation? base-prop_0))" +"(let-values()" +"(if(if(eq?(propagation-prev-scs prop_13) prev-scs_4)" +"(if(eq?(propagation-prev-smss prop_13) prev-smss_4)" +"(if(eq?(propagation-prev-mss prop_13) prev-mss_4)" +"(eq?(propagation-tamper prop_13) base-prop_0)" +" #f)" +" #f)" +" #f)" +"(let-values() prop_13)" +"(let-values()" +"(propagation14.1" +" prev-scs_4" +" prev-smss_4" +"(propagation-scope-ops prop_13)" +" prev-mss_4" +"(propagation-add-mpi-shifts prop_13)" +"(propagation-inspector prop_13)" +"(if(tamper-tainted?(propagation-tamper prop_13)) 'tainted/need-propagate base-prop_0)))))" +"(let-values()" +"(let-values(((new-ops_0)" +"(let-values(((ht_51)(propagation-scope-ops prop_13)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_51)))" +"((letrec-values(((for-loop_59)" +"(lambda(ops_1 i_65)" +"(begin" +" 'for-loop" +"(if i_65" +"(let-values(((sc_17 op_5)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_51" +" i_65)))" +"(let-values(((ops_2)" +"(let-values(((ops_3) ops_1))" +"(let-values(((ops_4)" +"(let-values()" +"(let-values(((tmp_12) op_5))" +"(if(equal? tmp_12 'add)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_17" +" 'add))" +"(if(equal? tmp_12 'remove)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_17" +" 'remove))" +"(let-values()" +"(let-values(((current-op_1)" +"(hash-ref" +" ops_3" +" sc_17" +" #f)))" +"(let-values(((tmp_13)" +" current-op_1))" +"(if(equal?" +" tmp_13" +" 'add)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_17" +" 'remove))" +"(if(equal?" +" tmp_13" +" 'remove)" +"(let-values()" +"(hash-set" +" ops_3" +" sc_17" +" 'add))" +"(if(equal?" +" tmp_13" +" 'flip)" +"(let-values()" +"(hash-remove" +" ops_3" +" sc_17))" +"(let-values()" +"(hash-set" +" ops_3" +" sc_17" +" 'flip))))))))))))))" +"(values ops_4)))))" +"(if(not #f)" +"(for-loop_59" +" ops_2" +"(unsafe-immutable-hash-iterate-next ht_51 i_65))" +" ops_2)))" +" ops_1)))))" +" for-loop_59)" +"(propagation-scope-ops base-prop_0)" +"(unsafe-immutable-hash-iterate-first ht_51))))))" +"(let-values(((add_2)(propagation-add-mpi-shifts prop_13)))" +"(let-values(((base-add_1)(propagation-add-mpi-shifts base-prop_0)))" +"(let-values(((new-tamper_0)" +"(if(let-values(((or-part_116)(tamper-tainted?(propagation-tamper prop_13))))" +"(if or-part_116 or-part_116(tamper-tainted?(propagation-tamper base-prop_0))))" +" 'tainted/need-propagate" +"(propagation-tamper base-prop_0))))" +"(if(if(zero?(hash-count new-ops_0))" +"(if(not add_2)" +"(if(not base-add_1)" +"(if(not(propagation-inspector prop_13))(not(propagation-inspector base-prop_0)) #f)" +" #f)" +" #f)" +" #f)" +" new-tamper_0" +"(let-values(((the-struct_25) base-prop_0))" +"(if(propagation? the-struct_25)" +"(let-values(((scope-ops69_0) new-ops_0)" +"((add-mpi-shifts70_0)" +"(if(if add_2 base-add_1 #f)" +"(lambda(mss_2)(begin 'add-mpi-shifts70(add_2(base-add_1 mss_2))))" +"(let-values(((or-part_117) add_2))(if or-part_117 or-part_117 base-add_1))))" +"((inspector71_0)" +"(let-values(((or-part_118)(propagation-inspector base-prop_0)))" +"(if or-part_118 or-part_118(propagation-inspector prop_13))))" +"((tamper72_0) new-tamper_0))" +"(propagation14.1" +"(propagation-prev-scs the-struct_25)" +"(propagation-prev-smss the-struct_25)" +" scope-ops69_0" +"(propagation-prev-mss the-struct_25)" +" add-mpi-shifts70_0" +" inspector71_0" +" tamper72_0))" +" (raise-argument-error 'struct-copy \"propagation?\" the-struct_25))))))))))))))" +"(define-values" +"(shift-multi-scope)" +"(lambda(sms_8 delta_0)" +"(begin" +"(if(zero-phase? delta_0)" +"(let-values() sms_8)" +"(if(label-phase? delta_0)" +"(let-values()" +"(if(shifted-to-label-phase?(shifted-multi-scope-phase sms_8))" +"(let-values() #f)" +"(let-values()" +"(intern-shifted-multi-scope" +"(shifted-to-label-phase5.1(phase- 0(shifted-multi-scope-phase sms_8)))" +"(shifted-multi-scope-multi-scope sms_8)))))" +"(if(shifted-to-label-phase?(shifted-multi-scope-phase sms_8))" +"(let-values() sms_8)" +"(let-values()" +"(intern-shifted-multi-scope" +"(phase+ delta_0(shifted-multi-scope-phase sms_8))" +"(shifted-multi-scope-multi-scope sms_8)))))))))" +"(define-values" +"(syntax-shift-phase-level$1)" +"(lambda(s_124 phase_6)" +"(begin" +" 'syntax-shift-phase-level" +"(if(eqv? phase_6 0)" +" s_124" +"(let-values()" +"(let-values(((smss73_0) #f))" +"(let-values(((prev-result_1) #f))" +"(let-values(((shift-all_0)" +"(lambda(smss_20)" +"(begin" +" 'shift-all" +"(if(eq? smss73_0 smss_20)" +"(let-values() prev-result_1)" +"(let-values()" +"(let-values(((r_23)" +"(let-values()" +"(fallback-map" +" smss_20" +"(lambda(smss_21)" +"(let-values(((ht_52) smss_21))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_52)))" +"((letrec-values(((for-loop_60)" +"(lambda(table_58 i_66)" +"(begin" +" 'for-loop" +"(if i_66" +"(let-values(((sms_9)" +"(unsafe-immutable-hash-iterate-key" +" ht_52" +" i_66)))" +"(let-values(((table_59)" +"(let-values(((new-sms_0)" +"(shift-multi-scope" +" sms_9" +" phase_6)))" +"(begin" +" #t" +"((letrec-values(((for-loop_61)" +"(lambda(table_60)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_61)" +"(let-values(((table_62)" +" table_60))" +"(if new-sms_0" +"(let-values(((table_63)" +" table_62))" +"(let-values(((table_64)" +"(let-values()" +"(let-values(((key_25" +" val_15)" +"(let-values()" +"(values" +"(let-values()" +" new-sms_0)" +" #t))))" +"(hash-set" +" table_63" +" key_25" +" val_15)))))" +"(values" +" table_64)))" +" table_62))))" +" table_61))))))" +" for-loop_61)" +" table_58)))))" +"(if(not #f)" +"(for-loop_60" +" table_59" +"(unsafe-immutable-hash-iterate-next" +" ht_52" +" i_66))" +" table_59)))" +" table_58)))))" +" for-loop_60)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_52)))))))))" +"(begin(set! smss73_0 smss_20)(set! prev-result_1 r_23) r_23))))))))" +"(let-values(((s_125) s_124)" +"((f_31)(lambda(tail?_29 d_4)(begin 'f d_4)))" +"((d->s_2)" +"(lambda(s_126 d_5)" +"(begin" +" 'd->s" +"(let-values(((the-struct_26) s_126))" +"(if(syntax?$1 the-struct_26)" +"(let-values(((content74_0) d_5)" +"((shifted-multi-scopes75_0)" +"(shift-all_0(syntax-shifted-multi-scopes s_126))))" +"(syntax1.1" +" content74_0" +"(syntax-scopes the-struct_26)" +" shifted-multi-scopes75_0" +"(syntax-scope-propagations+tamper the-struct_26)" +"(syntax-mpi-shifts the-struct_26)" +"(syntax-srcloc the-struct_26)" +"(syntax-props the-struct_26)" +"(syntax-inspector the-struct_26)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_26))))))" +"((s-e_2) syntax-e/no-taint)" +"((seen_13) #f))" +"((letrec-values(((loop_71)" +"(lambda(s_127)" +"(begin" +" 'loop" +"(let-values(((s_128) s_127)" +"((f_32)" +"(lambda(tail?_30 v_80)" +"(begin" +" 'f" +"(if(syntax?$1 v_80)" +"(let-values()(d->s_2 v_80(loop_71(s-e_2 v_80))))" +"(let-values()(f_31 tail?_30 v_80))))))" +"((seen_14) seen_13))" +"((letrec-values(((loop_72)" +"(lambda(tail?_31 s_129 prev-depth_6)" +"(begin" +" 'loop" +"(let-values(((depth_6)(add1 prev-depth_6)))" +"(if(if seen_14(> depth_6 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_31" +" s_129" +"(lambda(tail?_32 s_130)(f_32 tail?_32 s_130))" +" seen_14))" +"(if(null? s_129)" +"(let-values()(f_32 tail?_31 s_129))" +"(if(pair? s_129)" +"(let-values()" +"(f_32" +" tail?_31" +"(cons" +"(loop_72 #f(car s_129) depth_6)" +"(loop_72 #t(cdr s_129) depth_6))))" +"(if(let-values(((or-part_119)" +"(symbol? s_129)))" +"(if or-part_119" +" or-part_119" +"(let-values(((or-part_120)" +"(boolean? s_129)))" +"(if or-part_120" +" or-part_120" +"(number? s_129)))))" +"(let-values()(f_32 #f s_129))" +"(if(let-values(((or-part_121)" +"(vector? s_129)))" +"(if or-part_121" +" or-part_121" +"(let-values(((or-part_122)" +"(box? s_129)))" +"(if or-part_122" +" or-part_122" +"(let-values(((or-part_123)" +"(prefab-struct-key" +" s_129)))" +"(if or-part_123" +" or-part_123" +"(hash? s_129)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_31" +" s_129" +"(lambda(tail?_33 s_131)" +"(f_32 tail?_33 s_131))" +" seen_14))" +"(let-values()(f_32 #f s_129))))))))))))" +" loop_72)" +" #f" +" s_128" +" 0))))))" +" loop_71)" +" s_125))))))))))" +"(define-values" +"(syntax-swap-scopes)" +"(lambda(s_132 src-scopes_0 dest-scopes_0)" +"(begin" +"(if(equal? src-scopes_0 dest-scopes_0)" +" s_132" +"(let-values(((src-smss_0 src-scs_0)" +"(set-partition" +"(let-values(((ht_53) src-scopes_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_53)))" +"((letrec-values(((for-loop_62)" +"(lambda(table_65 i_67)" +"(begin" +" 'for-loop" +"(if i_67" +"(let-values(((sc_18)" +"(unsafe-immutable-hash-iterate-key ht_53 i_67)))" +"(let-values(((table_66)" +"(let-values(((table_67) table_65))" +"(let-values(((table_68)" +"(let-values()" +"(let-values(((key_26 val_16)" +"(let-values()" +"(values" +"(let-values()" +"(generalize-scope" +" sc_18))" +" #t))))" +"(hash-set" +" table_67" +" key_26" +" val_16)))))" +"(values table_68)))))" +"(if(not #f)" +"(for-loop_62" +" table_66" +"(unsafe-immutable-hash-iterate-next ht_53 i_67))" +" table_66)))" +" table_65)))))" +" for-loop_62)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_53))))" +" shifted-multi-scope?" +"(seteq)" +"(seteq)))" +"((dest-smss_0 dest-scs_0)" +"(set-partition" +"(let-values(((ht_54) dest-scopes_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_54)))" +"((letrec-values(((for-loop_63)" +"(lambda(table_69 i_68)" +"(begin" +" 'for-loop" +"(if i_68" +"(let-values(((sc_19)" +"(unsafe-immutable-hash-iterate-key ht_54 i_68)))" +"(let-values(((table_70)" +"(let-values(((table_71) table_69))" +"(let-values(((table_72)" +"(let-values()" +"(let-values(((key_27 val_17)" +"(let-values()" +"(values" +"(let-values()" +"(generalize-scope" +" sc_19))" +" #t))))" +"(hash-set" +" table_71" +" key_27" +" val_17)))))" +"(values table_72)))))" +"(if(not #f)" +"(for-loop_63" +" table_70" +"(unsafe-immutable-hash-iterate-next ht_54 i_68))" +" table_70)))" +" table_69)))))" +" for-loop_63)" +" '#hasheq()" +"(unsafe-immutable-hash-iterate-first ht_54))))" +" shifted-multi-scope?" +"(seteq)" +"(seteq))))" +"(let-values(((scs76_0) #f))" +"(let-values(((prev-result_2) #f))" +"(let-values(((swap-scs_0)" +"(lambda(scs_14)" +"(begin" +" 'swap-scs" +"(if(eq? scs76_0 scs_14)" +"(let-values() prev-result_2)" +"(let-values()" +"(let-values(((r_24)" +"(let-values()" +"(if(subset? src-scs_0 scs_14)" +"(set-union(set-subtract scs_14 src-scs_0) dest-scs_0)" +" scs_14))))" +"(begin(set! scs76_0 scs_14)(set! prev-result_2 r_24) r_24))))))))" +"(let-values(((smss77_0) #f))" +"(let-values(((prev-result_3) #f))" +"(let-values(((swap-smss_0)" +"(lambda(smss_22)" +"(begin" +" 'swap-smss" +"(if(eq? smss77_0 smss_22)" +"(let-values() prev-result_3)" +"(let-values()" +"(let-values(((r_25)" +"(let-values()" +"(fallback-update-first" +" smss_22" +"(lambda(smss_23)" +"(if(subset? src-smss_0 smss_23)" +"(set-union(set-subtract smss_23 src-smss_0) dest-smss_0)" +" smss_23))))))" +"(begin(set! smss77_0 smss_22)(set! prev-result_3 r_25) r_25))))))))" +"(let-values(((s_133) s_132)" +"((f_33)(lambda(tail?_34 d_6)(begin 'f d_6)))" +"((d->s_3)" +"(lambda(s_134 d_7)" +"(begin" +" 'd->s" +"(let-values(((the-struct_27) s_134))" +"(if(syntax?$1 the-struct_27)" +"(let-values(((content78_0) d_7)" +"((scopes79_0)(swap-scs_0(syntax-scopes s_134)))" +"((shifted-multi-scopes80_0)" +"(swap-smss_0(syntax-shifted-multi-scopes s_134))))" +"(syntax1.1" +" content78_0" +" scopes79_0" +" shifted-multi-scopes80_0" +"(syntax-scope-propagations+tamper the-struct_27)" +"(syntax-mpi-shifts the-struct_27)" +"(syntax-srcloc the-struct_27)" +"(syntax-props the-struct_27)" +"(syntax-inspector the-struct_27)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_27))))))" +"((s-e_3) syntax-e/no-taint)" +"((seen_15) #f))" +"((letrec-values(((loop_73)" +"(lambda(s_135)" +"(begin" +" 'loop" +"(let-values(((s_136) s_135)" +"((f_34)" +"(lambda(tail?_35 v_81)" +"(begin" +" 'f" +"(if(syntax?$1 v_81)" +"(let-values()(d->s_3 v_81(loop_73(s-e_3 v_81))))" +"(let-values()(f_33 tail?_35 v_81))))))" +"((seen_16) seen_15))" +"((letrec-values(((loop_32)" +"(lambda(tail?_36 s_137 prev-depth_7)" +"(begin" +" 'loop" +"(let-values(((depth_7)(add1 prev-depth_7)))" +"(if(if seen_16(> depth_7 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_36" +" s_137" +"(lambda(tail?_37 s_138)" +"(f_34 tail?_37 s_138))" +" seen_16))" +"(if(null? s_137)" +"(let-values()(f_34 tail?_36 s_137))" +"(if(pair? s_137)" +"(let-values()" +"(f_34" +" tail?_36" +"(cons" +"(loop_32 #f(car s_137) depth_7)" +"(loop_32 #t(cdr s_137) depth_7))))" +"(if(let-values(((or-part_124)" +"(symbol? s_137)))" +"(if or-part_124" +" or-part_124" +"(let-values(((or-part_125)" +"(boolean? s_137)))" +"(if or-part_125" +" or-part_125" +"(number? s_137)))))" +"(let-values()(f_34 #f s_137))" +"(if(let-values(((or-part_126)" +"(vector? s_137)))" +"(if or-part_126" +" or-part_126" +"(let-values(((or-part_127)" +"(box? s_137)))" +"(if or-part_127" +" or-part_127" +"(let-values(((or-part_128)" +"(prefab-struct-key" +" s_137)))" +"(if or-part_128" +" or-part_128" +"(hash? s_137)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_36" +" s_137" +"(lambda(tail?_38 s_139)" +"(f_34 tail?_38 s_139))" +" seen_16))" +"(let-values()" +"(f_34 #f s_137))))))))))))" +" loop_32)" +" #f" +" s_136" +" 0))))))" +" loop_73)" +" s_133)))))))))))))" +"(define-values" +"(syntax-scope-set)" +"(lambda(s_140 phase_7)" +"(begin(scope-set-at-fallback s_140(fallback-first(syntax-shifted-multi-scopes s_140)) phase_7))))" +"(define-values" +"(scope-set-at-fallback)" +"(lambda(s_141 smss_24 phase_8)" +"(begin" +"(let-values(((ht_55) smss_24))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_55)))" +"((letrec-values(((for-loop_64)" +"(lambda(scopes_9 i_69)" +"(begin" +" 'for-loop" +"(if i_69" +"(let-values(((sms_10)(unsafe-immutable-hash-iterate-key ht_55 i_69)))" +"(let-values(((scopes_10)" +"(let-values(((scopes_11) scopes_9))" +"(if(let-values(((or-part_129)(label-phase? phase_8)))" +"(if or-part_129" +" or-part_129" +"(not" +"(shifted-to-label-phase?" +"(shifted-multi-scope-phase sms_10)))))" +"(let-values(((scopes_12) scopes_11))" +"(let-values(((scopes_13)" +"(let-values()" +"(set-add" +" scopes_12" +"(multi-scope-to-scope-at-phase" +"(shifted-multi-scope-multi-scope sms_10)" +"(let-values(((ph_0)" +"(shifted-multi-scope-phase" +" sms_10)))" +"(if(shifted-to-label-phase? ph_0)" +"(shifted-to-label-phase-from ph_0)" +"(phase- ph_0 phase_8))))))))" +"(values scopes_13)))" +" scopes_11))))" +"(if(not #f)" +"(for-loop_64 scopes_10(unsafe-immutable-hash-iterate-next ht_55 i_69))" +" scopes_10)))" +" scopes_9)))))" +" for-loop_64)" +"(syntax-scopes s_141)" +"(unsafe-immutable-hash-iterate-first ht_55)))))))" +"(define-values" +"(find-max-scope)" +"(lambda(scopes_14)" +"(begin" +"(begin" +" (if (set-empty? scopes_14) (let-values () (error \"cannot bind in empty scope set\")) (void))" +"(let-values(((ht_56) scopes_14))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_56)))" +"((letrec-values(((for-loop_65)" +"(lambda(max-sc_0 i_70)" +"(begin" +" 'for-loop" +"(if i_70" +"(let-values(((sc_20)(unsafe-immutable-hash-iterate-key ht_56 i_70)))" +"(let-values(((max-sc_1)" +"(let-values(((max-sc_2) max-sc_0))" +"(let-values(((max-sc_3)" +"(let-values()" +"(if(scope>? sc_20 max-sc_2) sc_20 max-sc_2))))" +"(values max-sc_3)))))" +"(if(not #f)" +"(for-loop_65 max-sc_1(unsafe-immutable-hash-iterate-next ht_56 i_70))" +" max-sc_1)))" +" max-sc_0)))))" +" for-loop_65)" +"(set-first scopes_14)" +"(unsafe-immutable-hash-iterate-first ht_56))))))))" +"(define-values" +"(add-binding-in-scopes!20.1)" +"(lambda(just-for-nominal?15_0 just-for-nominal?16_0 scopes17_0 sym18_0 binding19_0)" +"(begin" +" 'add-binding-in-scopes!20" +"(let-values(((scopes_15) scopes17_0))" +"(let-values(((sym_11) sym18_0))" +"(let-values(((binding_4) binding19_0))" +"(let-values(((just-for-nominal?_1)(if just-for-nominal?16_0 just-for-nominal?15_0 #f)))" +"(let-values()" +"(let-values(((max-sc_4)(find-max-scope scopes_15)))" +"(let-values(((bt_7)" +"(binding-table-add" +"(scope-binding-table max-sc_4)" +" scopes_15" +" sym_11" +" binding_4" +" just-for-nominal?_1)))" +"(begin(set-scope-binding-table! max-sc_4 bt_7)(clear-resolve-cache! sym_11))))))))))))" +"(define-values" +"(add-bulk-binding-in-scopes!)" +"(lambda(scopes_16 bulk-binding_0)" +"(begin" +"(let-values(((max-sc_5)(find-max-scope scopes_16)))" +"(let-values(((bt_8)(binding-table-add-bulk(scope-binding-table max-sc_5) scopes_16 bulk-binding_0)))" +"(begin(set-scope-binding-table! max-sc_5 bt_8)(clear-resolve-cache!)))))))" +"(define-values" +"(syntax-any-macro-scopes?)" +"(lambda(s_142)" +"(begin" +"(let-values(((ht_57)(syntax-scopes s_142)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_57)))" +"((letrec-values(((for-loop_66)" +"(lambda(result_42 i_71)" +"(begin" +" 'for-loop" +"(if i_71" +"(let-values(((sc_21)(unsafe-immutable-hash-iterate-key ht_57 i_71)))" +"(let-values(((result_43)" +"(let-values()" +"(let-values(((result_44)" +"(let-values()" +"(let-values()(eq?(scope-kind sc_21) 'macro)))))" +"(values result_44)))))" +"(if(if(not((lambda x_35 result_43) sc_21))(not #f) #f)" +"(for-loop_66 result_43(unsafe-immutable-hash-iterate-next ht_57 i_71))" +" result_43)))" +" result_42)))))" +" for-loop_66)" +" #f" +"(unsafe-immutable-hash-iterate-first ht_57)))))))" +"(define-values" +"(resolve33.1)" +"(lambda(ambiguous-value23_0" +" ambiguous-value27_0" +" exactly?24_0" +" exactly?28_0" +" extra-shifts26_0" +" extra-shifts30_0" +" get-scopes?25_0" +" get-scopes?29_0" +" s31_0" +" phase32_0)" +"(begin" +" 'resolve33" +"(let-values(((s_143) s31_0))" +"(let-values(((phase_9) phase32_0))" +"(let-values(((ambiguous-value_0)(if ambiguous-value27_0 ambiguous-value23_0 #f)))" +"(let-values(((exactly?_0)(if exactly?28_0 exactly?24_0 #f)))" +"(let-values(((get-scopes?_0)(if get-scopes?29_0 get-scopes?25_0 #f)))" +"(let-values(((extra-shifts_2)(if extra-shifts30_0 extra-shifts26_0 null)))" +"(let-values()" +"(let-values(((sym_12)(syntax-content s_143)))" +"((letrec-values(((fallback-loop_0)" +"(lambda(smss_25)" +"(begin" +" 'fallback-loop" +"(let-values(((c1_21)" +"(if(not exactly?_0)" +"(if(not get-scopes?_0)" +"(resolve-cache-get" +" sym_12" +" phase_9" +"(syntax-scopes s_143)" +"(fallback-first smss_25))" +" #f)" +" #f)))" +"(if c1_21" +"((lambda(b_24)" +"(if(eq? b_24 '#:none)" +"(let-values()" +"(if(fallback? smss_25)" +"(fallback-loop_0(fallback-rest smss_25))" +" #f))" +"(let-values() b_24)))" +" c1_21)" +"(let-values()" +"(let-values(((scopes_17)" +"(scope-set-at-fallback" +" s_143" +"(fallback-first smss_25)" +" phase_9)))" +"(let-values(((best-scopes_0 best-binding_0)" +"(let-values(((ht_58) scopes_17))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash-keys ht_58)))" +"((letrec-values(((for-loop_67)" +"(lambda(best-scopes_1" +" best-binding_1" +" i_72)" +"(begin" +" 'for-loop" +"(if i_72" +"(let-values(((sc_22)" +"(unsafe-immutable-hash-iterate-key" +" ht_58" +" i_72)))" +"(let-values(((best-scopes_2" +" best-binding_2)" +"(let-values(((ht_59" +" bulk-bindings_2)" +"(let-values(((table_73)" +"(scope-binding-table" +" sc_22)))" +"(if(hash?" +" table_73)" +"(values" +"(hash-ref" +" table_73" +" sym_12" +" '#hash())" +" null)" +"(values" +"(hash-ref" +"(table-with-bulk-bindings-syms" +" table_73)" +" sym_12" +" '#hash())" +"(table-with-bulk-bindings-bulk-bindings" +" table_73)))))" +"((s_144)" +" s_143)" +"((extra-shifts_3)" +" extra-shifts_2))" +"(begin" +" #t" +"((letrec-values(((for-loop_68)" +"(lambda(best-scopes_3" +" best-binding_3" +" i_73)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" i_73))" +"(let-values(((b-scopes_0)" +"(if(pair?" +" i_73)" +"(let-values()" +"(bulk-binding-at-scopes" +"(car" +" i_73)))" +"(let-values()" +"(hash-iterate-key" +" ht_59" +" i_73))))" +"((binding_5)" +"(if(pair?" +" i_73)" +"(let-values()" +"(let-values(((bulk_3)" +"(bulk-binding-at-bulk" +"(car" +" i_73))))" +"(let-values(((b-info_0)" +"(hash-ref" +"(bulk-binding-symbols" +" bulk_3" +" s_144" +" extra-shifts_3)" +" sym_12" +" #f)))" +"(if b-info_0" +"((bulk-binding-create" +" bulk_3)" +" bulk_3" +" b-info_0" +" sym_12)" +" #f))))" +"(let-values()" +"(hash-iterate-value" +" ht_59" +" i_73)))))" +"(let-values(((best-scopes_4" +" best-binding_4)" +"(let-values(((best-scopes_5)" +" best-scopes_3)" +"((best-binding_5)" +" best-binding_3))" +"(if(if b-scopes_0" +"(if binding_5" +"(subset?" +" b-scopes_0" +" scopes_17)" +" #f)" +" #f)" +"(let-values(((best-scopes_6)" +" best-scopes_5)" +"((best-binding_6)" +" best-binding_5))" +"(let-values(((best-scopes_7" +" best-binding_7)" +"(let-values()" +"(if(pair?" +" best-scopes_6)" +"(let-values()" +"(if(let-values(((lst_46)" +" best-scopes_6))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_46)))" +"((letrec-values(((for-loop_69)" +"(lambda(result_45" +" lst_47)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_47)" +"(let-values(((amb-scopes_0)" +"(unsafe-car" +" lst_47))" +"((rest_20)" +"(unsafe-cdr" +" lst_47)))" +"(let-values(((result_46)" +"(let-values()" +"(let-values(((result_47)" +"(let-values()" +"(let-values()" +"(subset?" +" amb-scopes_0" +" b-scopes_0)))))" +"(values" +" result_47)))))" +"(if(if(not" +"((lambda x_36" +"(not" +" result_46))" +" amb-scopes_0))" +"(not" +" #f)" +" #f)" +"(for-loop_69" +" result_46" +" rest_20)" +" result_46)))" +" result_45)))))" +" for-loop_69)" +" #t" +" lst_46)))" +"(let-values()" +"(values" +" b-scopes_0" +" binding_5))" +"(let-values()" +"(values" +"(cons" +" b-scopes_0" +" best-scopes_6)" +" #f))))" +"(if(not" +" best-scopes_6)" +"(let-values()" +"(values" +" b-scopes_0" +" binding_5))" +"(if(subset?" +" b-scopes_0" +" best-scopes_6)" +"(let-values()" +"(values" +" best-scopes_6" +" best-binding_6))" +"(if(subset?" +" best-scopes_6" +" b-scopes_0)" +"(let-values()" +"(values" +" b-scopes_0" +" binding_5))" +"(let-values()" +"(values" +"(list" +" best-scopes_6" +" b-scopes_0)" +" #f)))))))))" +"(values" +" best-scopes_7" +" best-binding_7)))" +"(values" +" best-scopes_5" +" best-binding_5)))))" +"(if(not" +" #f)" +"(for-loop_68" +" best-scopes_4" +" best-binding_4" +"(if(pair?" +" i_73)" +"(let-values()" +"(cdr" +" i_73))" +"(let-values()" +"(let-values(((or-part_130)" +"(hash-iterate-next" +" ht_59" +" i_73)))" +"(if or-part_130" +" or-part_130" +" bulk-bindings_2)))))" +"(values" +" best-scopes_4" +" best-binding_4))))" +"(values" +" best-scopes_3" +" best-binding_3))))))" +" for-loop_68)" +" best-scopes_1" +" best-binding_1" +"(let-values(((or-part_131)" +"(hash-iterate-first" +" ht_59)))" +"(if or-part_131" +" or-part_131" +" bulk-bindings_2)))))))" +"(if(not #f)" +"(for-loop_67" +" best-scopes_2" +" best-binding_2" +"(unsafe-immutable-hash-iterate-next" +" ht_58" +" i_72))" +"(values" +" best-scopes_2" +" best-binding_2))))" +"(values" +" best-scopes_1" +" best-binding_1))))))" +" for-loop_67)" +" #f" +" #f" +"(unsafe-immutable-hash-iterate-first ht_58))))))" +"(if(pair? best-scopes_0)" +"(let-values()" +"(if(fallback? smss_25)" +"(fallback-loop_0(fallback-rest smss_25))" +" ambiguous-value_0))" +"(if best-scopes_0" +"(let-values()" +"(begin" +"(resolve-cache-set!" +" sym_12" +" phase_9" +"(syntax-scopes s_143)" +"(fallback-first smss_25)" +" best-binding_0)" +"(if(let-values(((or-part_132)(not exactly?_0)))" +"(if or-part_132" +" or-part_132" +"(eqv?" +"(set-count scopes_17)" +"(set-count best-scopes_0))))" +"(if get-scopes?_0 best-scopes_0 best-binding_0)" +" #f)))" +"(let-values()" +"(begin" +"(resolve-cache-set!" +" sym_12" +" phase_9" +"(syntax-scopes s_143)" +"(fallback-first smss_25)" +" '#:none)" +"(if(fallback? smss_25)" +"(fallback-loop_0(fallback-rest smss_25))" +" #f))))))))))))))" +" fallback-loop_0)" +"(syntax-shifted-multi-scopes s_143)))))))))))))" +"(define-values" +"(bound-identifier=?$1)" +"(lambda(a_32 b_25 phase_10)" +"(begin" +" 'bound-identifier=?" +"(if(eq?(syntax-e$1 a_32)(syntax-e$1 b_25))" +"(equal?(syntax-scope-set a_32 phase_10)(syntax-scope-set b_25 phase_10))" +" #f))))" +"(define-values" +"(syntax-property$1)" +"(case-lambda" +"((s_0 key_11)" +"(begin" +" 'syntax-property" +"(let-values((()" +"(begin" +" (if (syntax?$1 s_0) (void) (let-values () (raise-argument-error 'syntax-property \"syntax?\" s_0)))" +"(values))))" +"(let-values(((v_27)(hash-ref(syntax-props s_0) key_11 #f)))(plain-property-value v_27)))))" +"((s_1 key_12 val_3)" +"(let-values((()" +"(begin" +" (if (syntax?$1 s_1) (void) (let-values () (raise-argument-error 'syntax-property \"syntax?\" s_1)))" +"(values))))" +"(let-values(((pval_0)(if(eq? key_12 'paren-shape)(preserved-property-value1.1 val_3) val_3)))" +"(let-values(((the-struct_28) s_1))" +"(if(syntax?$1 the-struct_28)" +"(let-values(((props1_0)(hash-set(syntax-props s_1) key_12 pval_0)))" +"(syntax1.1" +"(syntax-content the-struct_28)" +"(syntax-scopes the-struct_28)" +"(syntax-shifted-multi-scopes the-struct_28)" +"(syntax-scope-propagations+tamper the-struct_28)" +"(syntax-mpi-shifts the-struct_28)" +"(syntax-srcloc the-struct_28)" +" props1_0" +"(syntax-inspector the-struct_28)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_28))))))" +"((s_145 key_28 val_18 preserved?_0)" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_145)" +"(void)" +" (let-values () (raise-argument-error 'syntax-property \"syntax?\" s_145)))" +"(values))))" +"(let-values((()" +"(begin" +"(if preserved?_0" +"(let-values()" +"(if(if(symbol? key_28)(symbol-interned? key_28) #f)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-property" +" \"key for a perserved property must be an interned symbol\"" +" \"given key\"" +" key_28" +" \"given value\"" +" val_18))))" +"(void))" +"(values))))" +"(let-values(((pval_1)(if preserved?_0(preserved-property-value1.1 val_18) val_18)))" +"(let-values(((the-struct_29) s_145))" +"(if(syntax?$1 the-struct_29)" +"(let-values(((props2_0)(hash-set(syntax-props s_145) key_28 pval_1)))" +"(syntax1.1" +"(syntax-content the-struct_29)" +"(syntax-scopes the-struct_29)" +"(syntax-shifted-multi-scopes the-struct_29)" +"(syntax-scope-propagations+tamper the-struct_29)" +"(syntax-mpi-shifts the-struct_29)" +"(syntax-srcloc the-struct_29)" +" props2_0" +"(syntax-inspector the-struct_29)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_29)))))))))" +"(define-values" +"(1/syntax-property-preserved?)" +"(lambda(s_146 key_29)" +"(begin" +" 'syntax-property-preserved?" +"(begin" +" (if (syntax?$1 s_146) (void) (let-values () (raise-argument-error 'syntax-property-preserved \"syntax?\" s_146)))" +"(if(if(symbol? key_29)(symbol-interned? key_29) #f)" +"(void)" +" (let-values () (raise-argument-error 'syntax-property \"(and/c symbol? symbol-interned?)\" key_29)))" +"(preserved-property-value?(hash-ref(syntax-props s_146) key_29 #f))))))" +"(define-values" +"(1/syntax-property-symbol-keys)" +"(lambda(s_147)" +"(begin" +" 'syntax-property-symbol-keys" +"(begin" +" (if (syntax?$1 s_147) (void) (let-values () (raise-argument-error 'syntax-property-symbol-keys \"syntax\" s_147)))" +"(reverse$1" +"(let-values(((ht_60)(syntax-props s_147)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_60)))" +"((letrec-values(((for-loop_70)" +"(lambda(fold-var_30 i_74)" +"(begin" +" 'for-loop" +"(if i_74" +"(let-values(((k_16 v_82)(unsafe-immutable-hash-iterate-key+value ht_60 i_74)))" +"(let-values(((fold-var_31)" +"(let-values(((fold-var_32) fold-var_30))" +"(if(if(symbol? k_16)(symbol-interned? k_16) #f)" +"(let-values(((fold-var_33) fold-var_32))" +"(let-values(((fold-var_34)" +"(let-values()" +"(cons(let-values() k_16) fold-var_33))))" +"(values fold-var_34)))" +" fold-var_32))))" +"(if(not #f)" +"(for-loop_70 fold-var_31(unsafe-immutable-hash-iterate-next ht_60 i_74))" +" fold-var_31)))" +" fold-var_30)))))" +" for-loop_70)" +" null" +"(unsafe-immutable-hash-iterate-first ht_60)))))))))" +"(define-values" +"(syntax-property-remove)" +"(lambda(s_72 key_30)" +"(begin" +"(if(hash-ref(syntax-props s_72) key_30 #f)" +"(let-values(((the-struct_30) s_72))" +"(if(syntax?$1 the-struct_30)" +"(let-values(((props3_0)(hash-remove(syntax-props s_72) key_30)))" +"(syntax1.1" +"(syntax-content the-struct_30)" +"(syntax-scopes the-struct_30)" +"(syntax-shifted-multi-scopes the-struct_30)" +"(syntax-scope-propagations+tamper the-struct_30)" +"(syntax-mpi-shifts the-struct_30)" +"(syntax-srcloc the-struct_30)" +" props3_0" +"(syntax-inspector the-struct_30)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_30)))" +" s_72))))" +"(define-values" +"(struct:full-binding full-binding1.1 full-binding? full-binding-frame-id full-binding-free=id)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'full-binding" +" #f" +" 2" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons prop:binding-reach-scopes(lambda(b_26)(binding-free=id b_26))))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'full-binding)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'frame-id)" +"(make-struct-field-accessor -ref_0 1 'free=id))))" +"(define-values(binding-frame-id)(lambda(b_27)(begin(if(full-binding? b_27)(full-binding-frame-id b_27) #f))))" +"(define-values(binding-free=id)(lambda(b_11)(begin(if(full-binding? b_11)(full-binding-free=id b_11) #f))))" +"(define-values" +"(make-module-binding22.1)" +"(lambda(extra-inspector8_0" +" extra-inspector17_0" +" extra-nominal-bindings9_0" +" extra-nominal-bindings18_0" +" frame-id6_0" +" frame-id15_0" +" free=id7_0" +" free=id16_0" +" nominal-module2_0" +" nominal-module11_0" +" nominal-phase3_0" +" nominal-phase12_0" +" nominal-require-phase5_0" +" nominal-require-phase14_0" +" nominal-sym4_0" +" nominal-sym13_0" +" wrt1_0" +" wrt10_0" +" module19_0" +" phase20_0" +" sym21_0)" +"(begin" +" 'make-module-binding22" +"(let-values(((module_0) module19_0))" +"(let-values(((phase_11) phase20_0))" +"(let-values(((sym_13) sym21_0))" +"(let-values()" +"(let-values(((nominal-module_0)(if nominal-module11_0 nominal-module2_0 module_0)))" +"(let-values(((nominal-phase_0)(if nominal-phase12_0 nominal-phase3_0 phase_11)))" +"(let-values(((nominal-sym_0)(if nominal-sym13_0 nominal-sym4_0 sym_13)))" +"(let-values(((nominal-require-phase_0)(if nominal-require-phase14_0 nominal-require-phase5_0 0)))" +"(let-values(((frame-id_0)(if frame-id15_0 frame-id6_0 #f)))" +"(let-values(((free=id_0)(if free=id16_0 free=id7_0 #f)))" +"(let-values(((extra-inspector_0)(if extra-inspector17_0 extra-inspector8_0 #f)))" +"(let-values(((extra-nominal-bindings_0)" +"(if extra-nominal-bindings18_0 extra-nominal-bindings9_0 null)))" +"(let-values()" +"(if(let-values(((or-part_79) frame-id_0))" +"(if or-part_79" +" or-part_79" +"(let-values(((or-part_80) free=id_0))" +"(if or-part_80" +" or-part_80" +"(let-values(((or-part_81) extra-inspector_0))" +"(if or-part_81" +" or-part_81" +"(not" +"(if(eqv? nominal-phase_0 phase_11)" +"(if(eq? nominal-sym_0 sym_13)" +"(if(eqv? nominal-require-phase_0 0)" +"(null? extra-nominal-bindings_0)" +" #f)" +" #f)" +" #f))))))))" +"(let-values()" +"(full-module-binding51.1" +" frame-id_0" +" free=id_0" +" module_0" +" phase_11" +" sym_13" +" nominal-module_0" +" nominal-phase_0" +" nominal-sym_0" +" nominal-require-phase_0" +" extra-inspector_0" +" extra-nominal-bindings_0))" +"(let-values()" +"(simple-module-binding52.1" +" module_0" +" phase_11" +" sym_13" +" nominal-module_0)))))))))))))))))))" +"(define-values" +"(module-binding-update48.1)" +"(lambda(extra-inspector34_0" +" extra-inspector45_0" +" extra-nominal-bindings35_0" +" extra-nominal-bindings46_0" +" frame-id32_0" +" frame-id43_0" +" free=id33_0" +" free=id44_0" +" module25_0" +" module36_0" +" nominal-module28_0" +" nominal-module39_0" +" nominal-phase29_0" +" nominal-phase40_0" +" nominal-require-phase31_0" +" nominal-require-phase42_0" +" nominal-sym30_0" +" nominal-sym41_0" +" phase26_0" +" phase37_0" +" sym27_0" +" sym38_0" +" b47_0)" +"(begin" +" 'module-binding-update48" +"(let-values(((b_28) b47_0))" +"(let-values(((module_1)(if module36_0 module25_0(module-binding-module b_28))))" +"(let-values(((phase_12)(if phase37_0 phase26_0(module-binding-phase b_28))))" +"(let-values(((sym_14)(if sym38_0 sym27_0(module-binding-sym b_28))))" +"(let-values(((nominal-module_1)" +"(if nominal-module39_0 nominal-module28_0(module-binding-nominal-module b_28))))" +"(let-values(((nominal-phase_1)" +"(if nominal-phase40_0 nominal-phase29_0(module-binding-nominal-phase b_28))))" +"(let-values(((nominal-sym_1)(if nominal-sym41_0 nominal-sym30_0(module-binding-nominal-sym b_28))))" +"(let-values(((nominal-require-phase_1)" +"(if nominal-require-phase42_0" +" nominal-require-phase31_0" +"(module-binding-nominal-require-phase b_28))))" +"(let-values(((frame-id_1)(if frame-id43_0 frame-id32_0(binding-frame-id b_28))))" +"(let-values(((free=id_1)(if free=id44_0 free=id33_0(binding-free=id b_28))))" +"(let-values(((extra-inspector_1)" +"(if extra-inspector45_0" +" extra-inspector34_0" +"(module-binding-extra-inspector b_28))))" +"(let-values(((extra-nominal-bindings_1)" +"(if extra-nominal-bindings46_0" +" extra-nominal-bindings35_0" +"(module-binding-extra-nominal-bindings b_28))))" +"(let-values()" +"(let-values(((nominal-module56_0) nominal-module_1)" +"((nominal-phase57_0) nominal-phase_1)" +"((nominal-sym58_0) nominal-sym_1)" +"((nominal-require-phase59_0) nominal-require-phase_1)" +"((frame-id60_0) frame-id_1)" +"((free=id61_0) free=id_1)" +"((extra-inspector62_0) extra-inspector_1)" +"((extra-nominal-bindings63_0) extra-nominal-bindings_1))" +"(make-module-binding22.1" +" extra-inspector62_0" +" #t" +" extra-nominal-bindings63_0" +" #t" +" frame-id60_0" +" #t" +" free=id61_0" +" #t" +" nominal-module56_0" +" #t" +" nominal-phase57_0" +" #t" +" nominal-require-phase59_0" +" #t" +" nominal-sym58_0" +" #t" +" #f" +" #f" +" module_1" +" phase_12" +" sym_14))))))))))))))))))" +"(define-values" +"(module-binding?)" +"(lambda(b_29)" +"(begin" +"(let-values(((or-part_133)(simple-module-binding? b_29)))" +"(if or-part_133 or-part_133(full-module-binding? b_29))))))" +"(define-values" +"(struct:full-module-binding" +" full-module-binding51.1" +" full-module-binding?" +" full-module-binding-module" +" full-module-binding-phase" +" full-module-binding-sym" +" full-module-binding-nominal-module" +" full-module-binding-nominal-phase" +" full-module-binding-nominal-sym" +" full-module-binding-nominal-require-phase" +" full-module-binding-extra-inspector" +" full-module-binding-extra-nominal-bindings)" +"(let-values(((struct:_25 make-_25 ?_25 -ref_25 -set!_25)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'full-module-binding" +" struct:full-binding" +" 9" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(b_30 ser-push!_10 state_18)" +"(let-values(((simplified-b_0)" +"(if(full-binding-frame-id b_30)" +"(let-values(((temp66_0) #f))" +"(module-binding-update48.1" +" #f" +" #f" +" #f" +" #f" +" temp66_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" b_30))" +" b_30)))" +"(if(full-module-binding? simplified-b_0)" +"(let-values()" +"(begin" +"(ser-push!_10 'tag '#:module-binding)" +"(ser-push!_10(full-module-binding-module b_30))" +"(ser-push!_10(full-module-binding-sym b_30))" +"(ser-push!_10(full-module-binding-phase b_30))" +"(ser-push!_10(full-module-binding-nominal-module b_30))" +"(ser-push!_10(full-module-binding-nominal-phase b_30))" +"(ser-push!_10(full-module-binding-nominal-sym b_30))" +"(ser-push!_10(full-module-binding-nominal-require-phase b_30))" +"(ser-push!_10(full-binding-free=id b_30))" +"(if(full-module-binding-extra-inspector b_30)" +"(ser-push!_10 'tag '#:inspector)" +"(ser-push!_10 #f))" +"(ser-push!_10(full-module-binding-extra-nominal-bindings b_30))))" +"(let-values()(ser-push!_10 simplified-b_0)))))))" +" #f" +" #f" +" '(0 1 2 3 4 5 6 7 8)" +" #f" +" 'full-module-binding)))))" +"(values" +" struct:_25" +" make-_25" +" ?_25" +"(make-struct-field-accessor -ref_25 0 'module)" +"(make-struct-field-accessor -ref_25 1 'phase)" +"(make-struct-field-accessor -ref_25 2 'sym)" +"(make-struct-field-accessor -ref_25 3 'nominal-module)" +"(make-struct-field-accessor -ref_25 4 'nominal-phase)" +"(make-struct-field-accessor -ref_25 5 'nominal-sym)" +"(make-struct-field-accessor -ref_25 6 'nominal-require-phase)" +"(make-struct-field-accessor -ref_25 7 'extra-inspector)" +"(make-struct-field-accessor -ref_25 8 'extra-nominal-bindings))))" +"(define-values" +"(struct:simple-module-binding" +" simple-module-binding52.1" +" simple-module-binding?" +" simple-module-binding-module" +" simple-module-binding-phase" +" simple-module-binding-sym" +" simple-module-binding-nominal-module)" +"(let-values(((struct:_26 make-_26 ?_26 -ref_26 -set!_26)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'simple-module-binding" +" #f" +" 4" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(b_31 ser-push!_11 state_19)" +"(begin" +"(ser-push!_11 'tag '#:simple-module-binding)" +"(ser-push!_11(simple-module-binding-module b_31))" +"(ser-push!_11(simple-module-binding-sym b_31))" +"(ser-push!_11(simple-module-binding-phase b_31))" +"(ser-push!_11(simple-module-binding-nominal-module b_31))))))" +" #f" +" #f" +" '(0 1 2 3)" +" #f" +" 'simple-module-binding)))))" +"(values" +" struct:_26" +" make-_26" +" ?_26" +"(make-struct-field-accessor -ref_26 0 'module)" +"(make-struct-field-accessor -ref_26 1 'phase)" +"(make-struct-field-accessor -ref_26 2 'sym)" +"(make-struct-field-accessor -ref_26 3 'nominal-module))))" +"(define-values" +"(deserialize-full-module-binding)" +"(lambda(module_2" +" sym_15" +" phase_13" +" nominal-module_2" +" nominal-phase_2" +" nominal-sym_2" +" nominal-require-phase_2" +" free=id_2" +" extra-inspector_2" +" extra-nominal-bindings_2)" +"(begin" +"(let-values(((nominal-module71_0) nominal-module_2)" +"((nominal-phase72_0) nominal-phase_2)" +"((nominal-sym73_0) nominal-sym_2)" +"((nominal-require-phase74_0) nominal-require-phase_2)" +"((free=id75_0) free=id_2)" +"((extra-inspector76_0) extra-inspector_2)" +"((extra-nominal-bindings77_0) extra-nominal-bindings_2))" +"(make-module-binding22.1" +" extra-inspector76_0" +" #t" +" extra-nominal-bindings77_0" +" #t" +" #f" +" #f" +" free=id75_0" +" #t" +" nominal-module71_0" +" #t" +" nominal-phase72_0" +" #t" +" nominal-require-phase74_0" +" #t" +" nominal-sym73_0" +" #t" +" #f" +" #f" +" module_2" +" phase_13" +" sym_15)))))" +"(define-values" +"(deserialize-simple-module-binding)" +"(lambda(module_3 sym_16 phase_14 nominal-module_3)" +"(begin(simple-module-binding52.1 module_3 phase_14 sym_16 nominal-module_3))))" +"(define-values" +"(module-binding-module)" +"(lambda(b_32)" +"(begin(if(simple-module-binding? b_32)(simple-module-binding-module b_32)(full-module-binding-module b_32)))))" +"(define-values" +"(module-binding-phase)" +"(lambda(b_33)" +"(begin(if(simple-module-binding? b_33)(simple-module-binding-phase b_33)(full-module-binding-phase b_33)))))" +"(define-values" +"(module-binding-sym)" +"(lambda(b_34)" +"(begin(if(simple-module-binding? b_34)(simple-module-binding-sym b_34)(full-module-binding-sym b_34)))))" +"(define-values" +"(module-binding-nominal-module)" +"(lambda(b_35)" +"(begin" +"(if(simple-module-binding? b_35)" +"(simple-module-binding-nominal-module b_35)" +"(full-module-binding-nominal-module b_35)))))" +"(define-values" +"(module-binding-nominal-phase)" +"(lambda(b_36)" +"(begin" +"(if(simple-module-binding? b_36)(simple-module-binding-phase b_36)(full-module-binding-nominal-phase b_36)))))" +"(define-values" +"(module-binding-nominal-sym)" +"(lambda(b_37)" +"(begin(if(simple-module-binding? b_37)(simple-module-binding-sym b_37)(full-module-binding-nominal-sym b_37)))))" +"(define-values" +"(module-binding-nominal-require-phase)" +"(lambda(b_38)(begin(if(simple-module-binding? b_38) 0(full-module-binding-nominal-require-phase b_38)))))" +"(define-values" +"(module-binding-extra-inspector)" +"(lambda(b_39)(begin(if(simple-module-binding? b_39) #f(full-module-binding-extra-inspector b_39)))))" +"(define-values" +"(module-binding-extra-nominal-bindings)" +"(lambda(b_40)(begin(if(simple-module-binding? b_40) null(full-module-binding-extra-nominal-bindings b_40)))))" +"(define-values" +"(local-binding?)" +"(lambda(b_41)" +"(begin(let-values(((or-part_0)(full-local-binding? b_41)))(if or-part_0 or-part_0(symbol? b_41))))))" +"(define-values" +"(struct:full-local-binding full-local-binding1.1 full-local-binding? full-local-binding-key)" +"(let-values(((struct:_27 make-_27 ?_27 -ref_27 -set!_27)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'full-local-binding" +" struct:full-binding" +" 1" +" 0" +" #f" +"(list" +"(cons prop:authentic #t)" +"(cons" +" prop:serialize" +"(lambda(b_42 ser-push!_12 state_20)" +"(begin" +"(ser-push!_12 'tag '#:local-binding)" +"(ser-push!_12(full-local-binding-key b_42))" +"(ser-push!_12(full-binding-free=id b_42))))))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'full-local-binding)))))" +"(values struct:_27 make-_27 ?_27(make-struct-field-accessor -ref_27 0 'key))))" +"(define-values" +"(deserialize-full-local-binding)" +"(lambda(key_31 free=id_3)(begin(full-local-binding1.1 #f free=id_3 key_31))))" +"(define-values" +"(make-local-binding7.1)" +"(lambda(frame-id2_0 frame-id4_0 free=id3_0 free=id5_0 key6_0)" +"(begin" +" 'make-local-binding7" +"(let-values(((key_32) key6_0))" +"(let-values(((frame-id_2)(if frame-id4_0 frame-id2_0 #f)))" +"(let-values(((free=id_4)(if free=id5_0 free=id3_0 #f)))" +"(let-values()" +"(if(if(not frame-id_2)(not free=id_4) #f)" +"(let-values() key_32)" +"(let-values()(full-local-binding1.1 frame-id_2 free=id_4 key_32))))))))))" +"(define-values" +"(local-binding-update17.1)" +"(lambda(frame-id11_0 frame-id14_0 free=id12_0 free=id15_0 key10_0 key13_0 b16_0)" +"(begin" +" 'local-binding-update17" +"(let-values(((b_43) b16_0))" +"(let-values(((key_33)(if key13_0 key10_0(local-binding-key b_43))))" +"(let-values(((frame-id_3)(if frame-id14_0 frame-id11_0(binding-frame-id b_43))))" +"(let-values(((free=id_5)(if free=id15_0 free=id12_0(binding-free=id b_43))))" +"(let-values()" +"(let-values(((frame-id22_0) frame-id_3)((free=id23_0) free=id_5))" +"(make-local-binding7.1 frame-id22_0 #t free=id23_0 #t key_33))))))))))" +"(define-values" +"(local-binding-key)" +"(lambda(b_44)(begin(if(full-local-binding? b_44)(full-local-binding-key b_44) b_44))))" +"(define-values" +"(1/prop:rename-transformer 1/rename-transformer? rename-transformer-value)" +"(make-struct-type-property" +" 'rename-transformer" +"(lambda(v_26 info_1)" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_11)(exact-nonnegative-integer? v_26)))" +"(if or-part_11" +" or-part_11" +"(let-values(((or-part_2)(identifier? v_26)))" +"(if or-part_2 or-part_2(if(procedure? v_26)(procedure-arity-includes? v_26 1) #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:rename-transformer" +"(string-append" +" \"(or/c exact-nonnegative-integer?\\n\"" +" \" identifier?\\n\"" +" \" (procedure-arity-includes? proc 1))\")" +" v_26)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(exact-nonnegative-integer? v_26)" +"(let-values()" +"(begin" +"(if(<= v_26(list-ref info_1 1))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:rename-transformer" +" \"field index >= initialized-field count for structure type\"" +" \"field index\"" +" v_26" +" \"initialized-field count\"" +"(list-ref info_1 1))))" +"(if(member v_26(list-ref info_1 5))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:rename-transformer" +" \"field index not declared immutable\"" +" \"field index\"" +" v_26)))))" +"(void))" +"(values))))" +"(let-values(((ref_0)(list-ref info_1 3)))" +"(if(identifier? v_26)" +"(let-values()(lambda(t_33) v_26))" +"(if(integer? v_26)" +"(let-values()" +"(lambda(t_34)" +"(let-values(((val_19)(ref_0 t_34 v_26)))" +"(if(identifier? val_19) val_19(datum->syntax$1 #f '?)))))" +"(let-values()" +"(lambda(t_13)" +"(let-values(((id_0)(call-with-continuation-prompt(lambda()(v_26 t_13)))))" +"(begin" +"(if(identifier? id_0)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'prop:rename-transformer" +" \"contract violation for given value; expected an identifier\"" +" \"given\"" +" id_0)))" +" id_0))))))))))))" +"(define-values" +"(struct:id-rename-transformer id-rename-transformer1.1 id-rename-transformer? id-rename-transformer-id)" +"(let-values(((struct:_28 make-_28 ?_28 -ref_28 -set!_28)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'rename-transformer" +" #f" +" 1" +" 0" +" #f" +"(list(cons 1/prop:rename-transformer 0))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'id-rename-transformer)))))" +"(values struct:_28 make-_28 ?_28(make-struct-field-accessor -ref_28 0 'id))))" +"(define-values" +"(1/make-rename-transformer)" +"(lambda(id_1)" +"(begin" +" 'make-rename-transformer" +"(begin" +"(if(identifier? id_1)" +"(void)" +" (let-values () (raise-argument-error 'make-rename-transformer \"identifier?\" id_1)))" +"(id-rename-transformer1.1 id_1)))))" +"(define-values" +"(1/rename-transformer-target)" +"(lambda(t_35)(begin 'rename-transformer-target((rename-transformer-value t_35) t_35))))" +"(define-values" +"(free-identifier=?$1)" +"(lambda(a_33 b_45 a-phase_0 b-phase_0)" +"(begin" +" 'free-identifier=?" +"(let-values(((ab_0)" +"(let-values(((temp49_0) #t))" +"(resolve+shift30.1 #f #f #f #f #f #f #f #f temp49_0 #t a_33 a-phase_0))))" +"(let-values(((bb_0)" +"(let-values(((temp52_0) #t))" +"(resolve+shift30.1 #f #f #f #f #f #f #f #f temp52_0 #t b_45 b-phase_0))))" +"(if(let-values(((or-part_27)(symbol? ab_0)))(if or-part_27 or-part_27(symbol? bb_0)))" +"(let-values()(eq? ab_0 bb_0))" +"(let-values()(same-binding? ab_0 bb_0))))))))" +"(define-values" +"(same-binding?)" +"(lambda(ab_1 bb_1)" +"(begin" +"(if(module-binding? ab_1)" +"(let-values()" +"(if(module-binding? bb_1)" +"(if(eq?(module-binding-sym ab_1)(module-binding-sym bb_1))" +"(if(eqv?(module-binding-phase ab_1)(module-binding-phase bb_1))" +"(eq?" +"(1/module-path-index-resolve(module-binding-module ab_1))" +"(1/module-path-index-resolve(module-binding-module bb_1)))" +" #f)" +" #f)" +" #f))" +"(if(local-binding? ab_1)" +"(let-values()(if(local-binding? bb_1)(eq?(local-binding-key ab_1)(local-binding-key bb_1)) #f))" +" (let-values () (error \"bad binding\" ab_1)))))))" +"(define-values" +"(same-binding-nominals?)" +"(lambda(ab_2 bb_2)" +"(begin" +"(if(eq?" +"(1/module-path-index-resolve(module-binding-nominal-module ab_2))" +"(1/module-path-index-resolve(module-binding-nominal-module bb_2)))" +"(if(eqv?(module-binding-nominal-require-phase ab_2)(module-binding-nominal-require-phase bb_2))" +"(eqv?(module-binding-nominal-sym ab_2)(module-binding-nominal-sym bb_2))" +" #f)" +" #f))))" +"(define-values" +"(identifier-binding-symbol$1)" +"(lambda(id_2 phase_15)" +"(begin" +" 'identifier-binding-symbol" +"(let-values(((b_46)" +"(let-values(((temp55_0) #t))" +"(resolve+shift30.1 #f #f #f #f #f #f #f #f temp55_0 #t id_2 phase_15))))" +"(if(symbol? b_46)" +"(let-values() b_46)" +"(if(module-binding? b_46)" +"(let-values()(module-binding-sym b_46))" +"(if(local-binding? b_46)(let-values()(local-binding-key b_46))(let-values()(syntax-e$1 id_2)))))))))" +"(define-values" +"(identifier-binding$1)" +"(let-values(((identifier-binding5_0)" +"(lambda(id3_0 phase4_0 top-level-symbol?1_0 top-level-symbol?2_0)" +"(begin" +" 'identifier-binding5" +"(let-values(((id_3) id3_0))" +"(let-values(((phase_16) phase4_0))" +"(let-values(((top-level-symbol?_0)(if top-level-symbol?2_0 top-level-symbol?1_0 #f)))" +"(let-values()" +"(let-values(((b_26)" +"(let-values(((id56_0) id_3)((phase57_0) phase_16))" +"(resolve+shift30.1 #f #f #f #f #f #f #f #f #f #f id56_0 phase57_0))))" +"(if(module-binding? b_26)" +"(let-values()" +"(if(top-level-module-path-index?(module-binding-module b_26))" +"(if top-level-symbol?_0(list(module-binding-nominal-sym b_26)) #f)" +"(list" +"(module-binding-module b_26)" +"(module-binding-sym b_26)" +"(module-binding-nominal-module b_26)" +"(module-binding-nominal-sym b_26)" +"(module-binding-phase b_26)" +"(module-binding-nominal-require-phase b_26)" +"(module-binding-nominal-phase b_26))))" +"(if(local-binding? b_26)(let-values() 'lexical)(let-values() #f))))))))))))" +"(case-lambda" +"((id_4 phase_17)(begin 'identifier-binding(identifier-binding5_0 id_4 phase_17 #f #f)))" +"((id_1 phase_18 top-level-symbol?1_1)(identifier-binding5_0 id_1 phase_18 top-level-symbol?1_1 #t)))))" +"(define-values" +"(maybe-install-free=id!)" +"(lambda(val_20 id_5 phase_19)" +"(begin" +"(if(1/rename-transformer? val_20)" +"(let-values()" +"(let-values(((free=id_6)(1/rename-transformer-target val_20)))" +"(if(syntax-property$1 free=id_6 'not-free-identifier=?)" +"(void)" +"(let-values()" +"(let-values(((b_47)" +"(let-values(((temp63_0) #t)((temp64_0) #t))" +"(resolve+shift30.1 #f #f temp63_0 #t #f #f temp64_0 #t #f #f id_5 phase_19))))" +"(let-values(((temp58_0)(syntax-scope-set id_5 phase_19))" +"((temp59_0)(syntax-e$1 id_5))" +"((temp60_0)(binding-set-free=id b_47 free=id_6)))" +"(add-binding-in-scopes!20.1 #f #f temp58_0 temp59_0 temp60_0)))))))" +"(void)))))" +"(define-values" +"(binding-set-free=id)" +"(lambda(b_48 free=id_7)" +"(begin" +"(if(module-binding? b_48)" +"(let-values()" +"(let-values(((free=id66_0) free=id_7))" +"(module-binding-update48.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" free=id66_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" b_48)))" +"(if(local-binding? b_48)" +"(let-values()" +"(let-values(((free=id68_0) free=id_7))(local-binding-update17.1 #f #f free=id68_0 #t #f #f b_48)))" +" (let-values () (error \"bad binding for free=id:\" b_48)))))))" +"(define-values" +"(struct:non-source-shift non-source-shift7.1 non-source-shift? non-source-shift-from non-source-shift-to)" +"(let-values(((struct:_29 make-_29 ?_29 -ref_29 -set!_29)" +"(let-values()" +"(let-values()" +"(make-struct-type 'non-source-shift #f 2 0 #f null 'prefab #f '(0 1) #f 'non-source-shift)))))" +"(values" +" struct:_29" +" make-_29" +" ?_29" +"(make-struct-field-accessor -ref_29 0 'from)" +"(make-struct-field-accessor -ref_29 1 'to))))" +"(define-values(shift-from)(lambda(s_148)(begin(if(pair? s_148)(car s_148)(non-source-shift-from s_148)))))" +"(define-values(shift-to)(lambda(s_11)(begin(if(pair? s_11)(cdr s_11)(non-source-shift-to s_11)))))" +"(define-values" +"(syntax-module-path-index-shift15.1)" +"(lambda(non-source?8_0 non-source?9_0 s12_0 from-mpi13_0 to-mpi14_0 inspector10_0 inspector11_0)" +"(begin" +" 'syntax-module-path-index-shift15" +"(let-values(((s_149) s12_0))" +"(let-values(((from-mpi_1) from-mpi13_0))" +"(let-values(((to-mpi_1) to-mpi14_0))" +"(let-values(((inspector_3)(if inspector11_0 inspector10_0 #f)))" +"(let-values(((non-source?_0)(if non-source?9_0 non-source?8_0 #f)))" +"(let-values()" +"(if(eq? from-mpi_1 to-mpi_1)" +"(let-values()(if inspector_3(syntax-set-inspector s_149 inspector_3) s_149))" +"(let-values()" +"(let-values(((shift_0)" +"(if non-source?_0" +"(non-source-shift7.1 from-mpi_1 to-mpi_1)" +"(cons from-mpi_1 to-mpi_1))))" +"(let-values(((the-struct_31) s_149))" +"(if(syntax?$1 the-struct_31)" +"(let-values(((mpi-shifts70_0)(cons shift_0(syntax-mpi-shifts s_149)))" +"((inspector71_1)" +"(let-values(((or-part_68)(syntax-inspector s_149)))" +"(if or-part_68 or-part_68 inspector_3)))" +"((scope-propagations+tamper72_0)" +"(if(datum-has-elements?(syntax-content s_149))" +"(propagation-mpi-shift" +"(syntax-scope-propagations+tamper s_149)" +"(lambda(s_21)(cons shift_0 s_21))" +" inspector_3" +"(syntax-scopes s_149)" +"(syntax-shifted-multi-scopes s_149)" +"(syntax-mpi-shifts s_149))" +"(syntax-scope-propagations+tamper s_149))))" +"(syntax1.1" +"(syntax-content the-struct_31)" +"(syntax-scopes the-struct_31)" +"(syntax-shifted-multi-scopes the-struct_31)" +" scope-propagations+tamper72_0" +" mpi-shifts70_0" +"(syntax-srcloc the-struct_31)" +"(syntax-props the-struct_31)" +" inspector71_1))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_31)))))))))))))))" +"(define-values" +"(resolve+shift30.1)" +"(lambda(ambiguous-value18_0" +" ambiguous-value23_1" +" exactly?19_0" +" exactly?24_1" +" extra-shifts22_0" +" extra-shifts27_0" +" immediate?20_0" +" immediate?25_0" +" unbound-sym?21_0" +" unbound-sym?26_0" +" s28_0" +" phase29_0)" +"(begin" +" 'resolve+shift30" +"(let-values(((s_150) s28_0))" +"(let-values(((phase_20) phase29_0))" +"(let-values(((ambiguous-value_1)(if ambiguous-value23_1 ambiguous-value18_0 #f)))" +"(let-values(((exactly?_1)(if exactly?24_1 exactly?19_0 #f)))" +"(let-values(((immediate?_0)(if immediate?25_0 immediate?20_0 exactly?_1)))" +"(let-values(((unbound-sym?_0)(if unbound-sym?26_0 unbound-sym?21_0 #f)))" +"(let-values(((extra-shifts_4)(if extra-shifts27_0 extra-shifts22_0 null)))" +"(let-values()" +"(let-values(((immediate-b_0)" +"(let-values(((ambiguous-value75_0) ambiguous-value_1)" +"((exactly?76_0) exactly?_1)" +"((extra-shifts77_0) extra-shifts_4))" +"(resolve33.1" +" ambiguous-value75_0" +" #t" +" exactly?76_0" +" #t" +" extra-shifts77_0" +" #t" +" #f" +" #f" +" s_150" +" phase_20))))" +"(let-values(((b_49)" +"(if(if immediate-b_0" +"(if(not immediate?_0)(binding-free=id immediate-b_0) #f)" +" #f)" +"(let-values(((temp78_0)(binding-free=id immediate-b_0))" +"((phase79_0) phase_20)" +"((temp80_0)(append extra-shifts_4(syntax-mpi-shifts s_150)))" +"((ambiguous-value81_0) ambiguous-value_1)" +"((exactly?82_0) exactly?_1)" +"((unbound-sym?83_0) unbound-sym?_0))" +"(resolve+shift30.1" +" ambiguous-value81_0" +" #t" +" exactly?82_0" +" #t" +" temp80_0" +" #t" +" #f" +" #f" +" unbound-sym?83_0" +" #t" +" temp78_0" +" phase79_0))" +" immediate-b_0)))" +"(if(module-binding? b_49)" +"(let-values()" +"(let-values(((mpi-shifts_2)(syntax-mpi-shifts s_150)))" +"(if(null? mpi-shifts_2)" +"(let-values() b_49)" +"(let-values()" +"(let-values(((mod_0)(module-binding-module b_49)))" +"(let-values(((shifted-mod_0)(apply-syntax-shifts mod_0 mpi-shifts_2)))" +"(let-values(((nominal-mod_0)(module-binding-nominal-module b_49)))" +"(let-values(((shifted-nominal-mod_0)" +"(if(eq? mod_0 nominal-mod_0)" +" shifted-mod_0" +"(apply-syntax-shifts nominal-mod_0 mpi-shifts_2))))" +"(if(if(eq? mod_0 shifted-mod_0)" +"(if(eq? nominal-mod_0 shifted-nominal-mod_0)" +"(if(not(binding-free=id b_49))" +"(null?(module-binding-extra-nominal-bindings b_49))" +" #f)" +" #f)" +" #f)" +" b_49" +"(let-values(((shifted-mod85_0) shifted-mod_0)" +"((shifted-nominal-mod86_0) shifted-nominal-mod_0)" +"((temp87_0)" +"(if(binding-free=id b_49)" +"(let-values(((temp89_0)(binding-free=id b_49))" +"((s90_0) s_150))" +"(syntax-transfer-shifts39.1 #f #f temp89_0 s90_0 #f #f))" +" #f))" +"((temp88_0)" +"(reverse$1" +"(let-values(((lst_48)" +"(module-binding-extra-nominal-bindings" +" b_49)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_48)))" +"((letrec-values(((for-loop_71)" +"(lambda(fold-var_35 lst_49)" +"(begin" +" 'for-loop" +"(if(pair? lst_49)" +"(let-values(((b_50)" +"(unsafe-car" +" lst_49))" +"((rest_21)" +"(unsafe-cdr" +" lst_49)))" +"(let-values(((fold-var_36)" +"(let-values(((fold-var_37)" +" fold-var_35))" +"(let-values(((fold-var_38)" +"(let-values()" +"(cons" +"(let-values()" +"(apply-syntax-shifts-to-binding" +" b_50" +" mpi-shifts_2))" +" fold-var_37))))" +"(values" +" fold-var_38)))))" +"(if(not #f)" +"(for-loop_71" +" fold-var_36" +" rest_21)" +" fold-var_36)))" +" fold-var_35)))))" +" for-loop_71)" +" null" +" lst_48))))))" +"(module-binding-update48.1" +" #f" +" #f" +" temp88_0" +" #t" +" #f" +" #f" +" temp87_0" +" #t" +" shifted-mod85_0" +" #t" +" shifted-nominal-mod86_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" b_49)))))))))))" +"(if(if(not b_49) unbound-sym?_0 #f)" +"(let-values()(syntax-e$1 s_150))" +"(let-values() b_49))))))))))))))))" +"(define-values" +"(apply-syntax-shifts)" +"(lambda(mpi_11 shifts_0)" +"(begin" +"(if(null? shifts_0)" +"(let-values() mpi_11)" +"(let-values()" +"(let-values(((shifted-mpi_1)(apply-syntax-shifts mpi_11(cdr shifts_0))))" +"(let-values(((shift_1)(car shifts_0)))" +"(module-path-index-shift shifted-mpi_1(shift-from shift_1)(shift-to shift_1)))))))))" +"(define-values" +"(apply-syntax-shifts-to-binding)" +"(lambda(b_51 shifts_1)" +"(begin" +"(if(null? shifts_1)" +"(let-values() b_51)" +"(let-values()" +"(let-values(((shifted-b_0)(apply-syntax-shifts-to-binding b_51(cdr shifts_1))))" +"(let-values(((shift_2)(car shifts_1)))" +"(binding-module-path-index-shift shifted-b_0(shift-from shift_2)(shift-to shift_2)))))))))" +"(define-values" +"(binding-module-path-index-shift)" +"(lambda(b_52 from-mpi_2 to-mpi_2)" +"(begin" +"(if(module-binding? b_52)" +"(let-values()" +"(let-values(((temp92_0)(module-path-index-shift(module-binding-module b_52) from-mpi_2 to-mpi_2))" +"((temp93_0)(module-path-index-shift(module-binding-nominal-module b_52) from-mpi_2 to-mpi_2))" +"((temp94_0)" +"(reverse$1" +"(let-values(((lst_32)(module-binding-extra-nominal-bindings b_52)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_32)))" +"((letrec-values(((for-loop_25)" +"(lambda(fold-var_39 lst_33)" +"(begin" +" 'for-loop" +"(if(pair? lst_33)" +"(let-values(((b_53)(unsafe-car lst_33))" +"((rest_13)(unsafe-cdr lst_33)))" +"(let-values(((fold-var_21)" +"(let-values(((fold-var_40) fold-var_39))" +"(let-values(((fold-var_41)" +"(let-values()" +"(cons" +"(let-values()" +"(binding-module-path-index-shift" +" b_53" +" from-mpi_2" +" to-mpi_2))" +" fold-var_40))))" +"(values fold-var_41)))))" +"(if(not #f)(for-loop_25 fold-var_21 rest_13) fold-var_21)))" +" fold-var_39)))))" +" for-loop_25)" +" null" +" lst_32))))))" +"(module-binding-update48.1" +" #f" +" #f" +" temp94_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp92_0" +" #t" +" temp93_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" b_52)))" +"(let-values() b_52)))))" +"(define-values" +"(syntax-transfer-shifts39.1)" +"(lambda(non-source?33_0 non-source?34_0 to-s37_0 from-s38_0 inspector35_0 inspector36_0)" +"(begin" +" 'syntax-transfer-shifts39" +"(let-values(((to-s_0) to-s37_0))" +"(let-values(((from-s_1) from-s38_0))" +"(let-values(((inspector_4)(if inspector36_0 inspector35_0 #f)))" +"(let-values(((non-source?_1)(if non-source?34_0 non-source?33_0 #f)))" +"(let-values()" +"(let-values(((shifts_2)(syntax-mpi-shifts from-s_1)))" +"(if(if(null? shifts_2) inspector_4 #f)" +"(let-values()(syntax-set-inspector to-s_0 inspector_4))" +"(let-values()" +"(let-values(((lst_50)(reverse$1 shifts_2))((start_12) 0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_50)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_12)))" +"((letrec-values(((for-loop_72)" +"(lambda(s_151 lst_51 pos_9)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_51) #t #f)" +"(let-values(((shift_3)(unsafe-car lst_51))" +"((rest_22)(unsafe-cdr lst_51))" +"((i_75) pos_9))" +"(let-values(((s_152)" +"(let-values(((s_153) s_151))" +"(let-values(((s_90)" +"(let-values()" +"(let-values(((temp96_0)" +"(shift-from shift_3))" +"((temp97_0)" +"(shift-to shift_3))" +"((temp98_0)" +"(if(zero? i_75)" +" inspector_4" +" #f))" +"((non-source?99_0)" +" non-source?_1))" +"(syntax-module-path-index-shift15.1" +" non-source?99_0" +" #t" +" s_153" +" temp96_0" +" temp97_0" +" temp98_0" +" #t)))))" +"(values s_90)))))" +"(if(not #f)(for-loop_72 s_152 rest_22(+ pos_9 1)) s_152)))" +" s_151)))))" +" for-loop_72)" +" to-s_0" +" lst_50" +" start_12))))))))))))))" +"(define-values" +"(syntax-set-inspector)" +"(lambda(s_97 insp_3)" +"(begin" +"(let-values(((the-struct_32) s_97))" +"(if(syntax?$1 the-struct_32)" +"(let-values(((inspector100_0)" +"(let-values(((or-part_134)(syntax-inspector s_97)))(if or-part_134 or-part_134 insp_3)))" +"((scope-propagations+tamper101_0)" +"(if(datum-has-elements?(syntax-content s_97))" +"(propagation-mpi-shift" +"(syntax-scope-propagations+tamper s_97)" +" #f" +" insp_3" +"(syntax-scopes s_97)" +"(syntax-shifted-multi-scopes s_97)" +"(syntax-mpi-shifts s_97))" +"(syntax-scope-propagations+tamper s_97))))" +"(syntax1.1" +"(syntax-content the-struct_32)" +"(syntax-scopes the-struct_32)" +"(syntax-shifted-multi-scopes the-struct_32)" +" scope-propagations+tamper101_0" +"(syntax-mpi-shifts the-struct_32)" +"(syntax-srcloc the-struct_32)" +"(syntax-props the-struct_32)" +" inspector100_0))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_32))))))" +"(define-values" +"(1/syntax-source-module)" +"(let-values(((syntax-source-module45_0)" +"(lambda(s44_0 source?42_0 source?43_0)" +"(begin" +" 'syntax-source-module45" +"(let-values(((s_154) s44_0))" +"(let-values()" +"(let-values()" +"(begin" +"(if(syntax?$1 s_154)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"syntax?\" s_154)))" +"(let-values(((lst_52)(reverse$1(syntax-mpi-shifts s_154))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_52)))" +"((letrec-values(((for-loop_73)" +"(lambda(result_48 lst_53)" +"(begin" +" 'for-loop" +"(if(pair? lst_53)" +"(let-values(((shift_4)(unsafe-car lst_53))" +"((rest_23)(unsafe-cdr lst_53)))" +"(let-values(((result_49)" +"(let-values(((result_50) result_48))" +"(if(non-source-shift? shift_4)" +" result_50" +"(let-values()" +"(let-values(((result_51)" +"(let-values()" +"(let-values()" +"(let-values(((from-mpi_3)" +"(car" +" shift_4)))" +"(let-values(((path_5" +" base_14)" +"(1/module-path-index-split" +" from-mpi_3)))" +"(if(not path_5)" +"(if(module-path-index-resolved" +" from-mpi_3)" +"(apply-syntax-shifts" +" from-mpi_3" +"(syntax-mpi-shifts" +" s_154))" +" #f)" +" #f)))))))" +"(values result_51)))))))" +"(if(if(not((lambda x_37 result_49) shift_4))(not #f) #f)" +"(for-loop_73 result_49 rest_23)" +" result_49)))" +" result_48)))))" +" for-loop_73)" +" #f" +" lst_52)))))))))))" +"(case-lambda" +"((s_155)(begin 'syntax-source-module(syntax-source-module45_0 s_155 #f #f)))" +"((s_156 source?42_1)(syntax-source-module45_0 s_156 source?42_1 #t)))))" +"(define-values" +"(1/identifier-prune-to-source-module)" +"(lambda(id_6)" +"(begin" +" 'identifier-prune-to-source-module" +"(begin" +"(if(identifier? id_6)" +"(void)" +" (let-values () (raise-argument-error 'identifier-prune-to-source-module \"identifier?\" id_6)))" +"(let-values(((the-struct_33)(datum->syntax$1 #f(syntax-e$1 id_6) id_6 id_6)))" +"(if(syntax?$1 the-struct_33)" +"(let-values(((mpi-shifts102_0)(syntax-mpi-shifts id_6)))" +"(syntax1.1" +"(syntax-content the-struct_33)" +"(syntax-scopes the-struct_33)" +"(syntax-shifted-multi-scopes the-struct_33)" +"(syntax-scope-propagations+tamper the-struct_33)" +" mpi-shifts102_0" +"(syntax-srcloc the-struct_33)" +"(syntax-props the-struct_33)" +"(syntax-inspector the-struct_33)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_33)))))))" +"(define-values(built-in-symbols)(make-hasheq))" +"(define-values(register-built-in-symbol!)(lambda(s_0)(begin(hash-set! built-in-symbols s_0 #t))))" +"(define-values(built-in-symbol?)(lambda(s_157)(begin(hash-ref built-in-symbols s_157 #f))))" +"(define-values" +"(make-built-in-symbol!)" +"(lambda(s_158)" +"(begin" +" (let-values (((built-in-s_0) (string->symbol (format \".~s\" s_158))))" +"(begin(register-built-in-symbol! built-in-s_0) built-in-s_0)))))" +"(void" +"(begin" +"(for-each2" +" register-built-in-symbol!" +" '(lambda case-lambda" +" if" +" begin" +" begin0" +" let-values" +" letrec-values" +" set!" +" quote" +" with-continuation-mark" +" #%variable-reference))" +"(for-each2" +" register-built-in-symbol!" +" '(check-not-undefined" +" instance-variable-box" +" variable-reference" +" variable-reference?" +" variable-reference->instance" +" variable-reference-constant?" +" variable-reference-from-unsafe?))" +"(for-each2" +" register-built-in-symbol!" +" '(let letrec* define" +" or" +" and" +" pariah" +" variable-set!" +" variable-ref" +" variable-ref/no-check" +" make-instance-variable-reference" +" annotation?" +" annotation-expression" +" #%app" +" #%call-with-values" +" make-pthread-parameter))))" +"(define-values(phase-shift-id)(make-built-in-symbol! 'phase))" +"(define-values(dest-phase-id)(make-built-in-symbol! 'dest-phase))" +"(define-values(ns-id)(make-built-in-symbol! 'namespace))" +"(define-values(self-id)(make-built-in-symbol! 'self))" +"(define-values(syntax-literals-id)(make-built-in-symbol! 'syntax-literals))" +"(define-values(get-syntax-literal!-id)(make-built-in-symbol! 'get-syntax-literal!))" +"(define-values(bulk-binding-registry-id)(make-built-in-symbol! 'bulk-binding-registry))" +"(define-values(inspector-id)(make-built-in-symbol! 'inspector))" +"(define-values(deserialize-syntax-id)(make-built-in-symbol! 'deserialize-syntax))" +"(define-values(deserialized-syntax-vector-id)(make-built-in-symbol! 'deserialized-syntax-vector))" +"(define-values(set-transformer!-id)(make-built-in-symbol! 'set-transformer!))" +"(define-values(top-level-bind!-id)(make-built-in-symbol! 'top-level-bind!))" +"(define-values(top-level-require!-id)(make-built-in-symbol! 'top-level-require!))" +"(define-values(mpi-vector-id)(make-built-in-symbol! 'mpi-vector))" +"(define-values" +"(struct:provided provided1.1 provided? provided-binding provided-protected? provided-syntax?)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'provided" +" #f" +" 3" +" 0" +" #f" +"(list" +"(cons" +" prop:serialize" +"(lambda(p_29 ser-push!_13 state_21)" +"(begin" +"(ser-push!_13 'tag '#:provided)" +"(ser-push!_13(provided-binding p_29))" +"(ser-push!_13(provided-protected? p_29))" +"(ser-push!_13(provided-syntax? p_29))))))" +" #f" +" #f" +" '(0 1 2)" +" #f" +" 'provided)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'binding)" +"(make-struct-field-accessor -ref_0 1 'protected?)" +"(make-struct-field-accessor -ref_0 2 'syntax?))))" +"(define-values(provided-as-binding)(lambda(v_83)(begin(if(provided? v_83)(provided-binding v_83) v_83))))" +"(define-values(provided-as-protected?)(lambda(v_5)(begin(if(provided? v_5)(provided-protected? v_5) #f))))" +"(define-values(provided-as-transformer?)(lambda(v_33)(begin(if(provided? v_33)(provided-syntax? v_33) #f))))" +"(define-values" +"(deserialize-provided)" +"(lambda(binding_6 protected?_0 syntax?_1)(begin(provided1.1 binding_6 protected?_0 syntax?_1))))" +"(define-values" +"(provide-binding-to-require-binding11.1)" +"(lambda(mpi2_0 phase-shift4_0 provide-phase-level3_0 self1_0 binding/p9_0 sym10_0)" +"(begin" +" 'provide-binding-to-require-binding11" +"(let-values(((binding/p_0) binding/p9_0))" +"(let-values(((sym_17) sym10_0))" +"(let-values(((self_1) self1_0))" +"(let-values(((mpi_12) mpi2_0))" +"(let-values(((provide-phase-level_0) provide-phase-level3_0))" +"(let-values(((phase-shift_0) phase-shift4_0))" +"(let-values()" +"(let-values(((binding_7)(provided-as-binding binding/p_0)))" +"(let-values(((from-mod_0)(module-binding-module binding_7)))" +"(let-values(((temp18_1)(module-path-index-shift from-mod_0 self_1 mpi_12))" +"((mpi19_0) mpi_12)" +"((provide-phase-level20_0) provide-phase-level_0)" +"((sym21_1) sym_17)" +"((phase-shift22_0) phase-shift_0)" +"((temp23_1) #f)" +"((temp24_2)" +"(if(not(provided-as-protected? binding/p_0))" +"(module-binding-extra-inspector binding_7)" +" #f))" +"((null25_0) null))" +"(module-binding-update48.1" +" temp24_2" +" #t" +" null25_0" +" #t" +" temp23_1" +" #t" +" #f" +" #f" +" temp18_1" +" #t" +" mpi19_0" +" #t" +" provide-phase-level20_0" +" #t" +" phase-shift22_0" +" #t" +" sym21_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" binding_7))))))))))))))" +"(define-values" +"(struct:bulk-binding" +" bulk-binding14.1" +" bulk-binding?" +" bulk-binding-provides" +" bulk-binding-prefix" +" bulk-binding-excepts" +" bulk-binding-self" +" bulk-binding-mpi" +" bulk-binding-provide-phase-level" +" bulk-binding-phase-shift" +" bulk-binding-bulk-binding-registry" +" set-bulk-binding-provides!" +" set-bulk-binding-self!)" +"(let-values(((struct:_30 make-_30 ?_30 -ref_30 -set!_30)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding" +" #f" +" 8" +" 0" +" #f" +"(list" +"(cons" +" prop:serialize" +"(lambda(b_54 ser-push!_14 reachable-scopes_5)" +"(begin" +"(ser-push!_14 'tag '#:bulk-binding)" +"(ser-push!_14(bulk-binding-prefix b_54))" +"(ser-push!_14(bulk-binding-excepts b_54))" +"(ser-push!_14(bulk-binding-mpi b_54))" +"(ser-push!_14(bulk-binding-provide-phase-level b_54))" +"(ser-push!_14(bulk-binding-phase-shift b_54))" +"(ser-push!_14 'tag '#:bulk-binding-registry))))" +"(cons" +" prop:bulk-binding" +"(bulk-binding-class3.1" +"(lambda(b_55 mpi-shifts_3)" +"(let-values(((or-part_135)(bulk-binding-provides b_55)))" +"(if or-part_135" +" or-part_135" +"(let-values(((mod-name_1)" +"(1/module-path-index-resolve" +"(apply-syntax-shifts(bulk-binding-mpi b_55) mpi-shifts_3))))" +"(let-values((()" +"(begin" +"(if(bulk-binding-bulk-binding-registry b_55)" +"(void)" +"(let-values()" +"(error" +" \"namespace mismatch: no bulk-binding registry available:\"" +" mod-name_1)))" +"(values))))" +"(let-values(((table_74)" +"(bulk-binding-registry-table" +"(bulk-binding-bulk-binding-registry b_55))))" +"(let-values(((bulk-provide_0)(hash-ref table_74 mod-name_1 #f)))" +"(let-values((()" +"(begin" +"(if bulk-provide_0" +"(void)" +"(let-values()" +"(error" +" \"namespace mismatch: bulk bindings not found in registry for module:\"" +" mod-name_1)))" +"(values))))" +"(let-values((()" +"(begin" +"(set-bulk-binding-self! b_55(bulk-provide-self bulk-provide_0))" +"(values))))" +"(let-values(((provides_0)" +"(hash-ref" +"(bulk-provide-provides bulk-provide_0)" +"(bulk-binding-provide-phase-level b_55))))" +"(let-values(((excepts_0)(bulk-binding-excepts b_55)))" +"(let-values(((prefix_0)(bulk-binding-prefix b_55)))" +"(let-values(((adjusted-provides_0)" +"(if(let-values(((or-part_136) prefix_0))" +"(if or-part_136" +" or-part_136" +"(positive?(hash-count excepts_0))))" +"(let-values()" +"(bulk-provides-add-prefix-remove-exceptions" +" provides_0" +" prefix_0" +" excepts_0))" +"(let-values() provides_0))))" +"(begin" +"(set-bulk-binding-provides! b_55 adjusted-provides_0)" +" adjusted-provides_0))))))))))))))" +"(lambda(b_56 binding_8 sym_18)" +"(let-values(((temp28_1)" +"(if(bulk-binding-prefix b_56)" +"(string->symbol" +"(substring" +"(symbol->string sym_18)" +"(string-length(symbol->string(bulk-binding-prefix b_56)))))" +" sym_18))" +"((temp29_0)(bulk-binding-self b_56))" +"((temp30_0)(bulk-binding-mpi b_56))" +"((temp31_0)(bulk-binding-provide-phase-level b_56))" +"((temp32_0)(bulk-binding-phase-shift b_56)))" +"(provide-binding-to-require-binding11.1" +" temp30_0" +" temp32_0" +" temp31_0" +" temp29_0" +" binding_8" +" temp28_1))))))" +"(current-inspector)" +" #f" +" '(1 2 4 5 6 7)" +" #f" +" 'bulk-binding)))))" +"(values" +" struct:_30" +" make-_30" +" ?_30" +"(make-struct-field-accessor -ref_30 0 'provides)" +"(make-struct-field-accessor -ref_30 1 'prefix)" +"(make-struct-field-accessor -ref_30 2 'excepts)" +"(make-struct-field-accessor -ref_30 3 'self)" +"(make-struct-field-accessor -ref_30 4 'mpi)" +"(make-struct-field-accessor -ref_30 5 'provide-phase-level)" +"(make-struct-field-accessor -ref_30 6 'phase-shift)" +"(make-struct-field-accessor -ref_30 7 'bulk-binding-registry)" +"(make-struct-field-mutator -set!_30 0 'provides)" +"(make-struct-field-mutator -set!_30 3 'self))))" +"(define-values" +"(deserialize-bulk-binding)" +"(lambda(prefix_1 excepts_1 mpi_13 provide-phase-level_1 phase-shift_1 bulk-binding-registry_0)" +"(begin" +"(bulk-binding14.1 #f prefix_1 excepts_1 #f mpi_13 provide-phase-level_1 phase-shift_1 bulk-binding-registry_0))))" +"(define-values" +"(bulk-provides-add-prefix-remove-exceptions)" +"(lambda(provides_1 prefix_2 excepts_2)" +"(begin" +"(let-values(((ht_35) provides_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_35)))" +"((letrec-values(((for-loop_35)" +"(lambda(table_28 i_47)" +"(begin" +" 'for-loop" +"(if i_47" +"(let-values(((sym_2 val_21)(hash-iterate-key+value ht_35 i_47)))" +"(let-values(((table_75)" +"(let-values(((table_76) table_28))" +"(if(hash-ref excepts_2 sym_2 #f)" +" table_76" +"(let-values(((table_77) table_76))" +"(let-values(((table_78)" +"(let-values()" +"(let-values(((key_34 val_22)" +"(let-values()" +"(values" +"(if prefix_2" +"(string->symbol" +"(format" +" \"~a~a\"" +" prefix_2" +" sym_2))" +" sym_2)" +" val_21))))" +"(hash-set table_77 key_34 val_22)))))" +"(values table_78)))))))" +"(if(not #f)(for-loop_35 table_75(hash-iterate-next ht_35 i_47)) table_75)))" +" table_28)))))" +" for-loop_35)" +" '#hash()" +"(hash-iterate-first ht_35)))))))" +"(define-values" +"(struct:bulk-provide bulk-provide15.1 bulk-provide? bulk-provide-self bulk-provide-provides)" +"(let-values(((struct:_31 make-_31 ?_31 -ref_31 -set!_31)" +"(let-values()" +"(let-values()" +"(make-struct-type 'bulk-provide #f 2 0 #f null(current-inspector) #f '(0 1) #f 'bulk-provide)))))" +"(values" +" struct:_31" +" make-_31" +" ?_31" +"(make-struct-field-accessor -ref_31 0 'self)" +"(make-struct-field-accessor -ref_31 1 'provides))))" +"(define-values" +"(struct:bulk-binding-registry bulk-binding-registry16.1 bulk-binding-registry? bulk-binding-registry-table)" +"(let-values(((struct:_32 make-_32 ?_32 -ref_32 -set!_32)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-binding-registry" +" #f" +" 1" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'bulk-binding-registry)))))" +"(values struct:_32 make-_32 ?_32(make-struct-field-accessor -ref_32 0 'table))))" +"(define-values(make-bulk-binding-registry)(lambda()(begin(bulk-binding-registry16.1(make-hasheq)))))" +"(define-values" +"(register-bulk-provide!)" +"(lambda(bulk-binding-registry_1 mod-name_2 self_2 provides_2)" +"(begin" +"(hash-set!" +"(bulk-binding-registry-table bulk-binding-registry_1)" +" mod-name_2" +"(bulk-provide15.1 self_2 provides_2)))))" +"(define-values" +"(registered-bulk-provide?)" +"(lambda(bulk-binding-registry_2 mod-name_3)" +"(begin(if(hash-ref(bulk-binding-registry-table bulk-binding-registry_2) mod-name_3 #f) #t #f))))" +"(define-values(generate-lift-key)(lambda()(begin(gensym 'lift))))" +"(define-values" +"(struct:root-expand-context/outer" +" root-expand-context/outer1.1" +" root-expand-context/outer?" +" root-expand-context/outer-inner" +" root-expand-context/outer-post-expansion-scope" +" root-expand-context/outer-use-site-scopes" +" root-expand-context/outer-frame-id)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'root-expand-context" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'root-expand-context/outer)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'inner)" +"(make-struct-field-accessor -ref_0 1 'post-expansion-scope)" +"(make-struct-field-accessor -ref_0 2 'use-site-scopes)" +"(make-struct-field-accessor -ref_0 3 'frame-id))))" +"(define-values" +"(struct:root-expand-context/inner" +" root-expand-context/inner2.1" +" root-expand-context/inner?" +" root-expand-context/inner-module-scopes" +" root-expand-context/inner-top-level-bind-scope" +" root-expand-context/inner-all-scopes-stx" +" root-expand-context/inner-defined-syms" +" root-expand-context/inner-counter" +" root-expand-context/inner-lift-key)" +"(let-values(((struct:_33 make-_33 ?_33 -ref_33 -set!_33)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'root-expand-context/inner" +" #f" +" 6" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5)" +" #f" +" 'root-expand-context/inner)))))" +"(values" +" struct:_33" +" make-_33" +" ?_33" +"(make-struct-field-accessor -ref_33 0 'module-scopes)" +"(make-struct-field-accessor -ref_33 1 'top-level-bind-scope)" +"(make-struct-field-accessor -ref_33 2 'all-scopes-stx)" +"(make-struct-field-accessor -ref_33 3 'defined-syms)" +"(make-struct-field-accessor -ref_33 4 'counter)" +"(make-struct-field-accessor -ref_33 5 'lift-key))))" +"(define-values" +"(root-expand-context/make)" +"(lambda(module-scopes_0" +" post-expansion-scope_0" +" top-level-bind-scope_0" +" all-scopes-stx_0" +" use-site-scopes_0" +" defined-syms_0" +" frame-id_4" +" counter_0" +" lift-key_0)" +"(begin" +"(root-expand-context/outer1.1" +"(root-expand-context/inner2.1" +" module-scopes_0" +" top-level-bind-scope_0" +" all-scopes-stx_0" +" defined-syms_0" +" counter_0" +" lift-key_0)" +" post-expansion-scope_0" +" use-site-scopes_0" +" frame-id_4))))" +"(define-values" +"(root-expand-context-post-expansion-scope)" +"(lambda(v_84)(begin(root-expand-context/outer-post-expansion-scope v_84))))" +"(define-values" +"(root-expand-context-use-site-scopes)" +"(lambda(v_85)(begin(root-expand-context/outer-use-site-scopes v_85))))" +"(define-values(root-expand-context-frame-id)(lambda(v_86)(begin(root-expand-context/outer-frame-id v_86))))" +"(define-values" +"(root-expand-context-module-scopes)" +"(lambda(v_61)(begin(root-expand-context/inner-module-scopes(root-expand-context/outer-inner v_61)))))" +"(define-values" +"(root-expand-context-top-level-bind-scope)" +"(lambda(v_87)(begin(root-expand-context/inner-top-level-bind-scope(root-expand-context/outer-inner v_87)))))" +"(define-values" +"(root-expand-context-all-scopes-stx)" +"(lambda(v_88)(begin(root-expand-context/inner-all-scopes-stx(root-expand-context/outer-inner v_88)))))" +"(define-values" +"(root-expand-context-defined-syms)" +"(lambda(v_89)(begin(root-expand-context/inner-defined-syms(root-expand-context/outer-inner v_89)))))" +"(define-values" +"(root-expand-context-counter)" +"(lambda(v_90)(begin(root-expand-context/inner-counter(root-expand-context/outer-inner v_90)))))" +"(define-values" +"(root-expand-context-lift-key)" +"(lambda(v_44)(begin(root-expand-context/inner-lift-key(root-expand-context/outer-inner v_44)))))" +"(define-values" +"(make-root-expand-context11.1)" +"(lambda(all-scopes-stx6_0" +" all-scopes-stx10_0" +" initial-scopes3_0" +" initial-scopes7_0" +" outside-scope4_0" +" outside-scope8_0" +" post-expansion-scope5_0" +" post-expansion-scope9_0)" +"(begin" +" 'make-root-expand-context11" +"(let-values(((initial-scopes_0)(if initial-scopes7_0 initial-scopes3_0 null)))" +"(let-values(((outside-scope_0)(if outside-scope8_0 outside-scope4_0 top-level-common-scope)))" +"(let-values(((post-expansion-scope_1)" +"(if post-expansion-scope9_0 post-expansion-scope5_0(new-multi-scope 'top-level))))" +"(let-values(((all-scopes-stx_1)(if all-scopes-stx10_0 all-scopes-stx6_0 #f)))" +"(let-values()" +"(let-values(((module-scopes_1)(list* post-expansion-scope_1 outside-scope_0 initial-scopes_0)))" +"(root-expand-context/make" +" module-scopes_1" +" post-expansion-scope_1" +"(new-scope 'module)" +"(let-values(((or-part_137) all-scopes-stx_1))" +"(if or-part_137 or-part_137(add-scopes empty-syntax module-scopes_1)))" +"(box null)" +"(make-hasheqv)" +" (string->uninterned-symbol \"root-frame\")" +"(box 0)" +"(generate-lift-key)))))))))))" +"(define-values" +"(root-expand-context-encode-for-module)" +"(lambda(ctx_0 orig-self_0 new-self_0)" +"(begin" +"(datum->syntax$1" +" #f" +"(vector" +"(add-scopes empty-syntax(root-expand-context-module-scopes ctx_0))" +"(add-scope empty-syntax(root-expand-context-post-expansion-scope ctx_0))" +"(let-values(((temp16_1)(root-expand-context-all-scopes-stx ctx_0))" +"((orig-self17_0) orig-self_0)" +"((new-self18_0) new-self_0))" +"(syntax-module-path-index-shift15.1 #f #f temp16_1 orig-self17_0 new-self18_0 #f #f))" +"(add-scopes empty-syntax(unbox(root-expand-context-use-site-scopes ctx_0)))" +"(let-values(((ht_61)(root-expand-context-defined-syms ctx_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_61)))" +"((letrec-values(((for-loop_74)" +"(lambda(table_76 i_76)" +"(begin" +" 'for-loop" +"(if i_76" +"(let-values(((phase_21 ht_62)(hash-iterate-key+value ht_61 i_76)))" +"(let-values(((table_79)" +"(let-values(((table_80) table_76))" +"(let-values(((table_33)" +"(let-values()" +"(let-values(((key_35 val_23)" +"(let-values()" +"(values phase_21 ht_62))))" +"(hash-set table_80 key_35 val_23)))))" +"(values table_33)))))" +"(if(not #f)(for-loop_74 table_79(hash-iterate-next ht_61 i_76)) table_79)))" +" table_76)))))" +" for-loop_74)" +" '#hasheqv()" +"(hash-iterate-first ht_61))))" +"(root-expand-context-frame-id ctx_0)" +"(unbox(root-expand-context-counter ctx_0)))))))" +"(define-values" +"(root-expand-context-decode-for-module)" +"(lambda(vec-s_0)" +"(begin" +"(let-values(((vec_24)(if(syntax?$1 vec-s_0)(syntax-e$1 vec-s_0) #f)))" +"(begin" +"(if(if(vector? vec_24)" +"(if(=(vector-length vec_24) 7)" +"(if(syntax?$1(vector-ref vec_24 0))" +"(if(syntax-with-one-scope?(vector-ref vec_24 1))" +"(if(syntax?$1(vector-ref vec_24 2))" +"(if(syntax?$1(vector-ref vec_24 3))" +"(if(defined-syms-hash?(syntax-e$1(vector-ref vec_24 4)))" +"(if(symbol?(syntax-e$1(vector-ref vec_24 5)))" +"(exact-nonnegative-integer?(syntax-e$1(vector-ref vec_24 6)))" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)" +"(void)" +" (let-values () (error 'root-expand-context-decode-for-module \"bad encoding: ~s\" vec-s_0)))" +"(root-expand-context/make" +"(extract-scope-list(vector-ref vec_24 0))" +"(extract-scope(vector-ref vec_24 1))" +"(new-scope 'module)" +"(vector-ref vec_24 2)" +"(box(extract-scope-list(vector-ref vec_24 3)))" +"(unpack-defined-syms(vector-ref vec_24 4))" +"(syntax-e$1(vector-ref vec_24 5))" +"(box(syntax-e$1(vector-ref vec_24 6)))" +"(generate-lift-key)))))))" +"(define-values" +"(defined-syms-hash?)" +"(lambda(v_38)" +"(begin" +"(let-values(((ht_37) v_38))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_37)))" +"((letrec-values(((for-loop_36)" +"(lambda(result_52 i_48)" +"(begin" +" 'for-loop" +"(if i_48" +"(let-values(((phase_22 ht-s_0)(hash-iterate-key+value ht_37 i_48)))" +"(let-values(((result_53)" +"(let-values()" +"(let-values(((result_54)" +"(let-values()" +"(let-values()" +"(if(phase? phase_22)" +"(if(hash?(syntax-e$1 ht-s_0))" +"(let-values(((ht_63)(syntax-e$1 ht-s_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_63)))" +"((letrec-values(((for-loop_75)" +"(lambda(result_55 i_77)" +"(begin" +" 'for-loop" +"(if i_77" +"(let-values(((sym_19" +" id_7)" +"(hash-iterate-key+value" +" ht_63" +" i_77)))" +"(let-values(((result_31)" +"(let-values()" +"(let-values(((result_56)" +"(let-values()" +"(let-values()" +"(if(symbol?" +" sym_19)" +"(identifier?" +" id_7)" +" #f)))))" +"(values" +" result_56)))))" +"(if(if(not" +"((lambda x_38" +"(not" +" result_31))" +" sym_19" +" id_7))" +"(not #f)" +" #f)" +"(for-loop_75" +" result_31" +"(hash-iterate-next" +" ht_63" +" i_77))" +" result_31)))" +" result_55)))))" +" for-loop_75)" +" #t" +"(hash-iterate-first ht_63))))" +" #f)" +" #f)))))" +"(values result_54)))))" +"(if(if(not((lambda x_39(not result_53)) phase_22 ht-s_0))(not #f) #f)" +"(for-loop_36 result_53(hash-iterate-next ht_37 i_48))" +" result_53)))" +" result_52)))))" +" for-loop_36)" +" #t" +"(hash-iterate-first ht_37)))))))" +"(define-values" +"(extract-scope-list)" +"(lambda(stx_8)(begin(map2 generalize-scope(set->list(syntax-scope-set stx_8 0))))))" +"(define-values" +"(syntax-with-one-scope?)" +"(lambda(stx_9)(begin(if(syntax?$1 stx_9)(= 1(set-count(syntax-scope-set stx_9 0))) #f))))" +"(define-values" +"(extract-scope)" +"(lambda(stx_10)(begin(let-values(((s_159)(syntax-scope-set stx_10 0)))(generalize-scope(set-first s_159))))))" +"(define-values" +"(unpack-defined-syms)" +"(lambda(v_91)" +"(begin" +"(hash-copy" +"(let-values(((ht_64)(syntax-e$1 v_91)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_64)))" +"((letrec-values(((for-loop_12)" +"(lambda(table_36 i_78)" +"(begin" +" 'for-loop" +"(if i_78" +"(let-values(((phase_23 ht-s_1)(hash-iterate-key+value ht_64 i_78)))" +"(let-values(((table_38)" +"(let-values(((table_81) table_36))" +"(let-values(((table_82)" +"(let-values()" +"(let-values(((key_36 val_24)" +"(let-values()" +"(values" +" phase_23" +"(hash-copy" +"(let-values(((ht_65)" +"(syntax-e$1" +" ht-s_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_65)))" +"((letrec-values(((for-loop_76)" +"(lambda(table_83" +" i_79)" +"(begin" +" 'for-loop" +"(if i_79" +"(let-values(((sym_20" +" id_8)" +"(hash-iterate-key+value" +" ht_65" +" i_79)))" +"(let-values(((table_84)" +"(let-values(((table_85)" +" table_83))" +"(let-values(((table_86)" +"(let-values()" +"(let-values(((key_37" +" val_25)" +"(let-values()" +"(values" +" sym_20" +" id_8))))" +"(hash-set" +" table_85" +" key_37" +" val_25)))))" +"(values" +" table_86)))))" +"(if(not" +" #f)" +"(for-loop_76" +" table_84" +"(hash-iterate-next" +" ht_65" +" i_79))" +" table_84)))" +" table_83)))))" +" for-loop_76)" +" '#hash()" +"(hash-iterate-first" +" ht_65)))))))))" +"(hash-set table_81 key_36 val_24)))))" +"(values table_82)))))" +"(if(not #f)(for-loop_12 table_38(hash-iterate-next ht_64 i_78)) table_38)))" +" table_36)))))" +" for-loop_12)" +" '#hasheqv()" +"(hash-iterate-first ht_64))))))))" +"(define-values(1/primitive-table) primitive-table)" +"(define-values(1/primitive->compiled-position) primitive->compiled-position)" +"(define-values(1/compiled-position->primitive) compiled-position->primitive)" +"(define-values(1/primitive-in-category?) primitive-in-category?)" +"(define-values(1/linklet?) linklet?)" +"(define-values(1/compile-linklet) compile-linklet)" +"(define-values(1/recompile-linklet) recompile-linklet)" +"(define-values(1/eval-linklet) eval-linklet)" +"(define-values(1/read-compiled-linklet) read-compiled-linklet)" +"(define-values(1/instantiate-linklet) instantiate-linklet)" +"(define-values(1/linklet-import-variables) linklet-import-variables)" +"(define-values(1/linklet-export-variables) linklet-export-variables)" +"(define-values(1/instance?) instance?)" +"(define-values(1/make-instance) make-instance)" +"(define-values(1/instance-name) instance-name)" +"(define-values(1/instance-data) instance-data)" +"(define-values(1/instance-variable-names) instance-variable-names)" +"(define-values(1/instance-variable-value) instance-variable-value)" +"(define-values(1/instance-set-variable-value!) instance-set-variable-value!)" +"(define-values(1/instance-unset-variable!) instance-unset-variable!)" +"(define-values(1/linklet-directory?) linklet-directory?)" +"(define-values(1/hash->linklet-directory) hash->linklet-directory)" +"(define-values(1/linklet-directory->hash) linklet-directory->hash)" +"(define-values(1/linklet-bundle?) linklet-bundle?)" +"(define-values(1/hash->linklet-bundle) hash->linklet-bundle)" +"(define-values(1/linklet-bundle->hash) linklet-bundle->hash)" +"(define-values(1/variable-reference?) variable-reference?)" +"(define-values(1/variable-reference->instance) variable-reference->instance)" +"(define-values(1/variable-reference-constant?) variable-reference-constant?)" +"(define-values(1/variable-reference-from-unsafe?) variable-reference-from-unsafe?)" +"(void" +"(if 1/variable-reference-constant?" +"(void)" +" (let-values () (error \"broken '#%linklet primitive table; maybe you need to use \\\"bootstrap-run.rkt\\\"\"))))" +"(define-values" +"(struct:module-registry module-registry1.1 module-registry? module-registry-declarations module-registry-lock-box)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-registry" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'module-registry)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'declarations)" +"(make-struct-field-accessor -ref_0 1 'lock-box))))" +"(define-values(make-module-registry)(lambda()(begin(module-registry1.1(make-hasheq)(box #f)))))" +"(define-values" +"(registry-call-with-lock)" +"(lambda(r_26 proc_2)" +"(begin" +"(let-values(((lock-box_0)(module-registry-lock-box r_26)))" +"((letrec-values(((loop_52)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((v_32)(unbox lock-box_0)))" +"(if(let-values(((or-part_77)(not v_32)))" +"(if or-part_77 or-part_77(sync/timeout 0(car v_32)(cdr v_32))))" +"(let-values()" +"(let-values(((sema_0)(make-semaphore)))" +"(let-values(((lock_0)(cons(semaphore-peek-evt sema_0)(current-thread))))" +"((dynamic-wind" " void" "(lambda()" -"(let((bstr(read-bytes 8192 p)))" -"(if(and(bytes? bstr)" -"((bytes-length bstr) . >= . 8192))" +"(if(box-cas! lock-box_0 v_32 lock_0)" +"(let-values()(begin(proc_2) void))" +"(let-values()(loop_52))))" +"(lambda()(semaphore-post sema_0)))))))" +"(if(eq?(current-thread)(cdr v_32))" +"(let-values()(proc_2))" +"(let-values()(begin(sync(car v_32)(cdr v_32))(loop_52))))))))))" +" loop_52))))))" +"(define-values" +"(struct:namespace" +" namespace1.1" +" 1/namespace?" +" namespace-mpi" +" namespace-source-name" +" namespace-root-expand-ctx" +" namespace-phase" +" namespace-0-phase" +" namespace-phase-to-namespace" +" namespace-phase-level-to-definitions" +" 1/namespace-module-registry" +" namespace-bulk-binding-registry" +" namespace-submodule-declarations" +" namespace-root-namespace" +" namespace-declaration-inspector" +" namespace-inspector" +" namespace-available-module-instances" +" namespace-module-instances" +" set-namespace-inspector!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'namespace" +" #f" +" 15" +" 0" +" #f" +"(list" +"(cons" +" prop:custom-write" +"(lambda(ns_0 port_9 mode_9)" +" (let-values ((() (begin (write-string \"#name ns_0)))" +"(void))" +"(values))))" +"(let-values(((0-phase_0)(namespace-0-phase ns_0)))" +"(let-values(((phase-level_0)(phase-(namespace-phase ns_0) 0-phase_0)))" +"(begin" +"(if(zero-phase? phase-level_0)" +"(void)" +" (let-values () (fprintf port_9 \":~s\" phase-level_0)))" +"(if(zero-phase? 0-phase_0)" +"(void)" +"(let-values()" +" (fprintf port_9 \"~a~s\" (if (positive? 0-phase_0) \"+\" \"\") 0-phase_0)))" +" (write-string \">\" port_9))))))))))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11 13 14)" +" #f" +" 'namespace)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'mpi)" +"(make-struct-field-accessor -ref_0 1 'source-name)" +"(make-struct-field-accessor -ref_0 2 'root-expand-ctx)" +"(make-struct-field-accessor -ref_0 3 'phase)" +"(make-struct-field-accessor -ref_0 4 '0-phase)" +"(make-struct-field-accessor -ref_0 5 'phase-to-namespace)" +"(make-struct-field-accessor -ref_0 6 'phase-level-to-definitions)" +"(make-struct-field-accessor -ref_0 7 'module-registry)" +"(make-struct-field-accessor -ref_0 8 'bulk-binding-registry)" +"(make-struct-field-accessor -ref_0 9 'submodule-declarations)" +"(make-struct-field-accessor -ref_0 10 'root-namespace)" +"(make-struct-field-accessor -ref_0 11 'declaration-inspector)" +"(make-struct-field-accessor -ref_0 12 'inspector)" +"(make-struct-field-accessor -ref_0 13 'available-module-instances)" +"(make-struct-field-accessor -ref_0 14 'module-instances)" +"(make-struct-field-mutator -set!_0 12 'inspector))))" +"(define-values" +"(struct:definitions definitions2.1 definitions? definitions-variables definitions-transformers)" +"(let-values(((struct:_34 make-_34 ?_34 -ref_34 -set!_34)" +"(let-values()" +"(let-values()" +"(make-struct-type 'definitions #f 2 0 #f null(current-inspector) #f '(0 1) #f 'definitions)))))" +"(values" +" struct:_34" +" make-_34" +" ?_34" +"(make-struct-field-accessor -ref_34 0 'variables)" +"(make-struct-field-accessor -ref_34 1 'transformers))))" +"(define-values(make-namespace)(lambda()(begin(let-values()(new-namespace9.1 #f #f #f #f #f #f)))))" +"(define-values" +"(new-namespace9.1)" +"(lambda(register?4_0 register?6_0 root-expand-ctx3_0 root-expand-ctx5_0 share-from-ns7_0 share-from-ns8_0)" +"(begin" +" 'new-namespace9" +"(let-values(((share-from-ns_0)(if share-from-ns8_0 share-from-ns7_0 #f)))" +"(let-values(((root-expand-ctx_0)" +"(if root-expand-ctx5_0" +" root-expand-ctx3_0" +"(let-values()(make-root-expand-context11.1 #f #f #f #f #f #f #f #f)))))" +"(let-values(((register?_0)(if register?6_0 register?4_0 #t)))" +"(let-values()" +"(let-values(((phase_24)(if share-from-ns_0(namespace-phase share-from-ns_0) 0)))" +"(let-values(((ns_1)" +"(namespace1.1" +" top-level-module-path-index" +" #f" +"(box root-expand-ctx_0)" +" phase_24" +" phase_24" +"(make-small-hasheqv)" +"(make-small-hasheqv)" +"(if share-from-ns_0(1/namespace-module-registry share-from-ns_0)(make-module-registry))" +"(if share-from-ns_0" +"(namespace-bulk-binding-registry share-from-ns_0)" +"(make-bulk-binding-registry))" +"(make-small-hasheq)" +"(if share-from-ns_0" +"(let-values(((or-part_138)(namespace-root-namespace share-from-ns_0)))" +"(if or-part_138 or-part_138 share-from-ns_0))" +" #f)" +" #f" +"(make-inspector(current-code-inspector))" +"(if share-from-ns_0" +"(namespace-available-module-instances share-from-ns_0)" +"(make-hasheqv))" +"(if share-from-ns_0(namespace-module-instances share-from-ns_0)(make-hasheqv)))))" +"(begin" +"(if register?_0" +"(let-values()(small-hash-set!(namespace-phase-to-namespace ns_1) phase_24 ns_1))" +"(void))" +" ns_1))))))))))" +"(define-values" +"(1/current-namespace)" +"(make-parameter" +"(make-namespace)" +"(lambda(v_92)" +"(begin" +" (if (1/namespace? v_92) (void) (let-values () (raise-argument-error 'current-namespace \"namespace?\" v_92)))" +" v_92))))" +"(define-values" +"(namespace-get-root-expand-ctx)" +"(lambda(ns_2)(begin(force(unbox(namespace-root-expand-ctx ns_2))))))" +"(define-values" +"(namespace-set-root-expand-ctx!)" +"(lambda(ns_3 root-ctx_0)(begin(set-box!(namespace-root-expand-ctx ns_3) root-ctx_0))))" +"(define-values" +"(namespace->module)" +"(lambda(ns_4 name_17)" +"(begin" +"(let-values(((or-part_139)(small-hash-ref(namespace-submodule-declarations ns_4) name_17 #f)))" +"(if or-part_139" +" or-part_139" +"(hash-ref(module-registry-declarations(1/namespace-module-registry ns_4)) name_17 #f))))))" +"(define-values" +"(namespace->namespace-at-phase)" +"(lambda(ns_5 phase_25)" +"(begin" +"(let-values(((or-part_140)(small-hash-ref(namespace-phase-to-namespace ns_5) phase_25 #f)))" +"(if or-part_140" +" or-part_140" +"(let-values(((p-ns_0)" +"(let-values(((the-struct_34) ns_5))" +"(if(1/namespace? the-struct_34)" +"(let-values(((phase22_0) phase_25))" +"(namespace1.1" +"(namespace-mpi the-struct_34)" +"(namespace-source-name the-struct_34)" +"(namespace-root-expand-ctx the-struct_34)" +" phase22_0" +"(namespace-0-phase the-struct_34)" +"(namespace-phase-to-namespace the-struct_34)" +"(namespace-phase-level-to-definitions the-struct_34)" +"(1/namespace-module-registry the-struct_34)" +"(namespace-bulk-binding-registry the-struct_34)" +"(namespace-submodule-declarations the-struct_34)" +"(namespace-root-namespace the-struct_34)" +"(namespace-declaration-inspector the-struct_34)" +"(namespace-inspector the-struct_34)" +"(namespace-available-module-instances the-struct_34)" +"(namespace-module-instances the-struct_34)))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_34)))))" +"(begin(small-hash-set!(namespace-phase-to-namespace ns_5) phase_25 p-ns_0) p-ns_0)))))))" +"(define-values" +"(namespace->name)" +"(lambda(ns_6)" +"(begin" +"(let-values(((n_20)(namespace-source-name ns_6)))" +"(let-values(((s_52)" +"(if(not n_20)" +"(let-values() 'top-level)" +"(if(symbol? n_20)" +" (let-values () (format \"'~s\" n_20))" +" (let-values () (string-append \"\\\"\" (path->string n_20) \"\\\"\"))))))" +"(let-values(((r_27)(1/resolved-module-path-name(1/module-path-index-resolve(namespace-mpi ns_6)))))" +" (if (pair? r_27) (string-append \"(submod \" s_52 \" \" (substring (format \"~s\" (cdr r_27)) 1)) s_52)))))))" +"(define-values" +"(namespace->definitions)" +"(lambda(ns_7 phase-level_1)" +"(begin" +"(let-values(((d_8)(small-hash-ref(namespace-phase-level-to-definitions ns_7) phase-level_1 #f)))" +"(let-values(((or-part_48) d_8))" +"(if or-part_48" +" or-part_48" +"(let-values()" +"(let-values(((p-ns_1)" +"(namespace->namespace-at-phase ns_7(phase+(namespace-0-phase ns_7) phase-level_1))))" +"(let-values(((d_9)(definitions2.1(1/make-instance(namespace->name p-ns_1) p-ns_1)(make-hasheq))))" +"(begin(small-hash-set!(namespace-phase-level-to-definitions ns_7) phase-level_1 d_9) d_9))))))))))" +"(define-values" +"(namespace-set-variable!)" +"(let-values(((namespace-set-variable!18_0)" +"(lambda(ns14_0 phase-level15_0 name16_1 val17_0 as-constant?12_0 as-constant?13_0)" +"(begin" +" 'namespace-set-variable!18" +"(let-values(((ns_8) ns14_0))" +"(let-values(((phase-level_2) phase-level15_0))" +"(let-values(((name_18) name16_1))" +"(let-values(((val_26) val17_0))" +"(let-values(((as-constant?_0)(if as-constant?13_0 as-constant?12_0 #f)))" +"(let-values()" +"(let-values(((d_10)(namespace->definitions ns_8 phase-level_2)))" +"(1/instance-set-variable-value!" +"(definitions-variables d_10)" +" name_18" +" val_26" +"(if as-constant?_0 'constant #f)))))))))))))" +"(case-lambda" +"((ns_9 phase-level_3 name_19 val_27)(begin(namespace-set-variable!18_0 ns_9 phase-level_3 name_19 val_27 #f #f)))" +"((ns_10 phase-level_4 name_20 val_28 as-constant?12_1)" +"(namespace-set-variable!18_0 ns_10 phase-level_4 name_20 val_28 as-constant?12_1 #t)))))" +"(define-values" +"(namespace-set-consistent!)" +"(lambda(ns_11 phase-level_5 name_21 val_29)" +"(begin" +"(let-values(((d_11)(namespace->definitions ns_11 phase-level_5)))" +"(1/instance-set-variable-value!(definitions-variables d_11) name_21 val_29 'consistent)))))" +"(define-values" +"(namespace-unset-variable!)" +"(lambda(ns_12 phase-level_6 name_22)" +"(begin" +"(let-values(((d_12)(namespace->definitions ns_12 phase-level_6)))" +"(1/instance-unset-variable!(definitions-variables d_12) name_22)))))" +"(define-values" +"(namespace-set-transformer!)" +"(lambda(ns_13 phase-level_7 name_23 val_30)" +"(begin" +"(let-values(((d_13)(namespace->definitions ns_13(add1 phase-level_7))))" +"(hash-set!(definitions-transformers d_13) name_23 val_30)))))" +"(define-values" +"(namespace-unset-transformer!)" +"(lambda(ns_14 phase-level_8 name_24)" +"(begin" +"(let-values(((d_14)(namespace->definitions ns_14(add1 phase-level_8))))" +"(hash-remove!(definitions-transformers d_14) name_24)))))" +"(define-values" +"(namespace-get-variable)" +"(lambda(ns_15 phase-level_9 name_16 fail-k_0)" +"(begin" +"(let-values(((d_15)(namespace->definitions ns_15 phase-level_9)))" +"(1/instance-variable-value(definitions-variables d_15) name_16 fail-k_0)))))" +"(define-values" +"(namespace-get-transformer)" +"(lambda(ns_16 phase-level_10 name_25 fail-k_1)" +"(begin" +"(let-values(((d_16)(namespace->definitions ns_16(add1 phase-level_10))))" +"(hash-ref(definitions-transformers d_16) name_25 fail-k_1)))))" +"(define-values" +"(namespace->instance)" +"(lambda(ns_17 phase-shift_2)(begin(definitions-variables(namespace->definitions ns_17 phase-shift_2)))))" +"(define-values" +"(namespace-same-instance?)" +"(lambda(a-ns_0 b-ns_0)" +"(begin" +"(eq?" +"(small-hash-ref(namespace-phase-level-to-definitions a-ns_0) 0 'no-a)" +"(small-hash-ref(namespace-phase-level-to-definitions b-ns_0) 0 'no-b)))))" +"(define-values(original-property-sym)(gensym 'original))" +"(define-values" +"(syntax->list$1)" +"(lambda(s_0)" +"(begin" +" 'syntax->list" +"(let-values(((l_46)" +"((letrec-values(((loop_74)" +"(lambda(s_1)" +"(begin" +" 'loop" +"(if(pair? s_1)" +"(let-values()(cons(car s_1)(loop_74(cdr s_1))))" +"(if(syntax?$1 s_1)" +"(let-values()(loop_74(syntax-e$1 s_1)))" +"(let-values() s_1)))))))" +" loop_74)" +" s_0)))" +"(if(list? l_46) l_46 #f)))))" +"(define-values(missing$1)(gensym))" +"(define-values" +"(syntax-track-origin$1)" +"(let-values(((syntax-track-origin5_0)" +"(lambda(new-stx3_0 old-stx4_0 id1_0 id2_0)" +"(begin" +" 'syntax-track-origin5" +"(let-values(((new-stx_0) new-stx3_0))" +"(let-values(((old-stx_0) old-stx4_0))" +"(let-values(((id_9)" +"(if id2_0" +" id1_0" +"(if(identifier? old-stx_0)" +" old-stx_0" +"(let-values(((v_93)(syntax-e/no-taint old-stx_0)))" +"(if(pair? v_93)(car v_93) #f))))))" +"(let-values()" +"(let-values(((old-props_0)(syntax-props old-stx_0)))" +"(if(zero?(hash-count old-props_0))" +"(let-values()" +"(if id_9" +"(syntax-property$1" +" new-stx_0" +" 'origin" +"(cons id_9(hash-ref(syntax-props new-stx_0) 'origin null)))" +" new-stx_0))" +"(let-values()" +"(let-values(((new-props_0)(syntax-props new-stx_0)))" +"(if(zero?(hash-count new-props_0))" +"(let-values()" +"(if id_9" +"(let-values()" +"(let-values(((old-origin_0)" +"(plain-property-value" +"(hash-ref old-props_0 'origin missing$1))))" +"(let-values(((origin_0)" +"(if(eq? old-origin_0 missing$1)" +"(list id_9)" +"(cons id_9 old-origin_0))))" +"(let-values(((the-struct_35) new-stx_0))" +"(if(syntax?$1 the-struct_35)" +"(let-values(((props7_0)(hash-set old-props_0 'origin origin_0)))" +"(syntax1.1" +"(syntax-content the-struct_35)" +"(syntax-scopes the-struct_35)" +"(syntax-shifted-multi-scopes the-struct_35)" +"(syntax-scope-propagations+tamper the-struct_35)" +"(syntax-mpi-shifts the-struct_35)" +"(syntax-srcloc the-struct_35)" +" props7_0" +"(syntax-inspector the-struct_35)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_35))))))" +"(let-values()" +"(let-values(((the-struct_36) new-stx_0))" +"(if(syntax?$1 the-struct_36)" +"(let-values(((props8_0) old-props_0))" +"(syntax1.1" +"(syntax-content the-struct_36)" +"(syntax-scopes the-struct_36)" +"(syntax-shifted-multi-scopes the-struct_36)" +"(syntax-scope-propagations+tamper the-struct_36)" +"(syntax-mpi-shifts the-struct_36)" +"(syntax-srcloc the-struct_36)" +" props8_0" +"(syntax-inspector the-struct_36)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_36))))))" +"(let-values()" +"(let-values(((old-props-with-origin_0)" +"(if id_9" +"(hash-set" +" old-props_0" +" 'origin" +"(cons id_9(hash-ref old-props_0 'origin null)))" +" old-props_0)))" +"(let-values(((updated-props_0)" +"(if(<" +"(hash-count old-props-with-origin_0)" +"(hash-count new-props_0))" +"(let-values()" +"(let-values(((ht_60) old-props-with-origin_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_60)))" +"((letrec-values(((for-loop_70)" +"(lambda(new-props_1 i_74)" +"(begin" +" 'for-loop" +"(if i_74" +"(let-values(((k_16 v_82)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_60" +" i_74)))" +"(let-values(((new-props_2)" +"(let-values(((new-props_3)" +" new-props_1))" +"(let-values(((new-props_4)" +"(let-values()" +"(let-values(((new-v_0)" +"(hash-ref" +" new-props_3" +" k_16" +" missing$1)))" +"(hash-set" +" new-props_3" +" k_16" +"(if(eq?" +" new-v_0" +" missing$1)" +" v_82" +"(cons/preserve" +" new-v_0" +" v_82)))))))" +"(values" +" new-props_4)))))" +"(if(not #f)" +"(for-loop_70" +" new-props_2" +"(unsafe-immutable-hash-iterate-next" +" ht_60" +" i_74))" +" new-props_2)))" +" new-props_1)))))" +" for-loop_70)" +" new-props_0" +"(unsafe-immutable-hash-iterate-first ht_60)))))" +"(let-values()" +"(let-values(((ht_66) new-props_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash ht_66)))" +"((letrec-values(((for-loop_77)" +"(lambda(old-props_1 i_80)" +"(begin" +" 'for-loop" +"(if i_80" +"(let-values(((k_17 v_5)" +"(unsafe-immutable-hash-iterate-key+value" +" ht_66" +" i_80)))" +"(let-values(((old-props_2)" +"(let-values(((old-props_3)" +" old-props_1))" +"(let-values(((old-props_4)" +"(let-values()" +"(let-values(((old-v_0)" +"(hash-ref" +" old-props_3" +" k_17" +" missing$1)))" +"(hash-set" +" old-props_3" +" k_17" +"(if(eq?" +" old-v_0" +" missing$1)" +" v_5" +"(cons/preserve" +" v_5" +" old-v_0)))))))" +"(values" +" old-props_4)))))" +"(if(not #f)" +"(for-loop_77" +" old-props_2" +"(unsafe-immutable-hash-iterate-next" +" ht_66" +" i_80))" +" old-props_2)))" +" old-props_1)))))" +" for-loop_77)" +" old-props-with-origin_0" +"(unsafe-immutable-hash-iterate-first ht_66))))))))" +"(let-values(((the-struct_37) new-stx_0))" +"(if(syntax?$1 the-struct_37)" +"(let-values(((props9_0) updated-props_0))" +"(syntax1.1" +"(syntax-content the-struct_37)" +"(syntax-scopes the-struct_37)" +"(syntax-shifted-multi-scopes the-struct_37)" +"(syntax-scope-propagations+tamper the-struct_37)" +"(syntax-mpi-shifts the-struct_37)" +"(syntax-srcloc the-struct_37)" +" props9_0" +"(syntax-inspector the-struct_37)))" +"(raise-argument-error" +" 'struct-copy" +" \"syntax?\"" +" the-struct_37)))))))))))))))))))" +"(case-lambda" +"((new-stx_1 old-stx_1)(begin 'syntax-track-origin(syntax-track-origin5_0 new-stx_1 old-stx_1 #f #f)))" +"((new-stx_2 old-stx_2 id1_1)(syntax-track-origin5_0 new-stx_2 old-stx_2 id1_1 #t)))))" +"(define-values" +"(cons/preserve)" +"(lambda(a_34 b_57)" +"(begin" +"(if(let-values(((or-part_31)(preserved-property-value? a_34)))" +"(if or-part_31 or-part_31(preserved-property-value? b_57)))" +"(preserved-property-value1.1(cons(plain-property-value a_34)(plain-property-value b_57)))" +"(cons a_34 b_57)))))" +"(define-values" +"(syntax-track-origin*)" +"(lambda(old-stxes_0 new-stx_3)" +"(begin" +"(let-values(((lst_54) old-stxes_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_54)))" +"((letrec-values(((for-loop_78)" +"(lambda(new-stx_4 lst_55)" +"(begin" +" 'for-loop" +"(if(pair? lst_55)" +"(let-values(((old-stx_3)(unsafe-car lst_55))((rest_24)(unsafe-cdr lst_55)))" +"(let-values(((new-stx_5)" +"(let-values(((new-stx_6) new-stx_4))" +"(let-values(((new-stx_7)" +"(let-values()" +"(syntax-track-origin$1 new-stx_6 old-stx_3))))" +"(values new-stx_7)))))" +"(if(not #f)(for-loop_78 new-stx_5 rest_24) new-stx_5)))" +" new-stx_4)))))" +" for-loop_78)" +" new-stx_3" +" lst_54))))))" +"(define-values" +"(1/struct:exn:fail:syntax make-exn:fail:syntax$1 1/exn:fail:syntax? 1/exn:fail:syntax-exprs)" +"(let-values(((struct:_27 make-_27 ?_27 -ref_27 -set!_27)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:syntax" +" struct:exn:fail" +" 1" +" 0" +" #f" +"(list" +"(cons" +" prop:exn:srclocs" +"(lambda(e_16)(filter values(map2 syntax-srcloc(1/exn:fail:syntax-exprs e_16))))))" +" #f" +" #f" +" '(0)" +"(lambda(str_1 cm_0 exprs_0 info_2)" +"(begin" +"(if(if(list? exprs_0)(andmap2 syntax?$1 exprs_0) #f)" +"(void)" +" (let-values () (raise-argument-error 'exn:fail:syntax \"(listof syntax?)\" exprs_0)))" +"(values str_1 cm_0 exprs_0)))" +" 'exn:fail:syntax)))))" +"(values struct:_27 make-_27 ?_27(make-struct-field-accessor -ref_27 0 'exprs))))" +"(define-values" +"(1/struct:exn:fail:syntax:unbound make-exn:fail:syntax:unbound$1 1/exn:fail:syntax:unbound?)" +"(let-values(((struct:_35 make-_35 ?_35 -ref_35 -set!_35)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:syntax:unbound" +" 1/struct:exn:fail:syntax" +" 0" +" 0" +" #f" +" null" +" #f" +" #f" +" '()" +" #f" +" 'exn:fail:syntax:unbound)))))" +"(values struct:_35 make-_35 ?_35)))" +"(define-values" +"(raise-syntax-error$1)" +"(let-values(((raise-syntax-error11_0)" +"(lambda(given-name9_0" +" message10_0" +" expr1_0" +" sub-expr2_0" +" extra-sources3_0" +" message-suffix4_0" +" expr5_0" +" sub-expr6_0" +" extra-sources7_0" +" message-suffix8_0)" +"(begin" +" 'raise-syntax-error11" +"(let-values(((given-name_0) given-name9_0))" +"(let-values(((message_0) message10_0))" +"(let-values(((expr_0)(if expr5_0 expr1_0 #f)))" +"(let-values(((sub-expr_0)(if sub-expr6_0 sub-expr2_0 #f)))" +"(let-values(((extra-sources_0)(if extra-sources7_0 extra-sources3_0 null)))" +" (let-values (((message-suffix_0) (if message-suffix8_0 message-suffix4_0 \"\")))" +"(let-values()" +"(do-raise-syntax-error" +" make-exn:fail:syntax$1" +" given-name_0" +" message_0" +" expr_0" +" sub-expr_0" +" extra-sources_0" +" message-suffix_0))))))))))))" +"(case-lambda" +"((given-name_1 message_1)" +"(begin 'raise-syntax-error(raise-syntax-error11_0 given-name_1 message_1 #f #f #f #f #f #f #f #f)))" +"((given-name_2 message_2 expr_1 sub-expr_1 extra-sources_1 message-suffix4_1)" +"(raise-syntax-error11_0 given-name_2 message_2 expr_1 sub-expr_1 extra-sources_1 message-suffix4_1 #t #t #t #t))" +"((given-name_3 message_3 expr_2 sub-expr_2 extra-sources3_1)" +"(raise-syntax-error11_0 given-name_3 message_3 expr_2 sub-expr_2 extra-sources3_1 #f #t #t #t #f))" +"((given-name_4 message_4 expr_3 sub-expr2_1)" +"(raise-syntax-error11_0 given-name_4 message_4 expr_3 sub-expr2_1 #f #f #t #t #f #f))" +"((given-name_5 message_5 expr1_1)(raise-syntax-error11_0 given-name_5 message_5 expr1_1 #f #f #f #t #f #f #f)))))" +"(define-values" +"(raise-unbound-syntax-error)" +"(let-values(((raise-unbound-syntax-error23_0)" +"(lambda(given-name21_0" +" message22_0" +" expr13_0" +" sub-expr14_0" +" extra-sources15_0" +" message-suffix16_0" +" expr17_0" +" sub-expr18_0" +" extra-sources19_0" +" message-suffix20_0)" +"(begin" +" 'raise-unbound-syntax-error23" +"(let-values(((given-name_6) given-name21_0))" +"(let-values(((message_6) message22_0))" +"(let-values(((expr_4)(if expr17_0 expr13_0 #f)))" +"(let-values(((sub-expr_3)(if sub-expr18_0 sub-expr14_0 #f)))" +"(let-values(((extra-sources_2)(if extra-sources19_0 extra-sources15_0 null)))" +" (let-values (((message-suffix_1) (if message-suffix20_0 message-suffix16_0 \"\")))" +"(let-values()" +"(do-raise-syntax-error" +" make-exn:fail:syntax:unbound$1" +" given-name_6" +" message_6" +" expr_4" +" sub-expr_3" +" extra-sources_2" +" message-suffix_1))))))))))))" +"(case-lambda" +"((given-name_7 message_7)(begin(raise-unbound-syntax-error23_0 given-name_7 message_7 #f #f #f #f #f #f #f #f)))" +"((given-name_8 message_8 expr_5 sub-expr_4 extra-sources_3 message-suffix16_1)" +"(raise-unbound-syntax-error23_0" +" given-name_8" +" message_8" +" expr_5" +" sub-expr_4" +" extra-sources_3" +" message-suffix16_1" +" #t" +" #t" +" #t" +" #t))" +"((given-name_9 message_9 expr_6 sub-expr_5 extra-sources15_1)" +"(raise-unbound-syntax-error23_0 given-name_9 message_9 expr_6 sub-expr_5 extra-sources15_1 #f #t #t #t #f))" +"((given-name_10 message_10 expr_7 sub-expr14_1)" +"(raise-unbound-syntax-error23_0 given-name_10 message_10 expr_7 sub-expr14_1 #f #f #t #t #f #f))" +"((given-name_11 message_11 expr13_1)" +"(raise-unbound-syntax-error23_0 given-name_11 message_11 expr13_1 #f #f #f #t #f #f #f)))))" +"(define-values" +"(do-raise-syntax-error)" +"(lambda(exn:fail:syntax_0 given-name_12 message_12 expr_8 sub-expr_6 extra-sources_4 message-suffix_2)" +"(begin" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_141)(not given-name_12)))" +"(if or-part_141 or-part_141(symbol? given-name_12)))" +"(void)" +" (let-values () (raise-argument-error 'raise-syntax-error \"(or/c symbol? #f)\" given-name_12)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(string? message_12)" +"(void)" +" (let-values () (raise-argument-error 'raise-syntax-error \"string?\" message_12)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(if(list? extra-sources_4)(andmap2 syntax?$1 extra-sources_4) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'raise-syntax-error \"(listof syntax?)\" extra-sources_4)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(string? message-suffix_2)" +"(void)" +" (let-values () (raise-argument-error 'raise-syntax-error \"string?\" message-suffix_2)))" +"(values))))" +"(let-values(((name_26)" +"(format" +" \"~a\"" +"(let-values(((or-part_142) given-name_12))" +"(if or-part_142" +" or-part_142" +"(let-values(((or-part_143)(extract-form-name expr_8)))" +"(if or-part_143 or-part_143 '?)))))))" +"(let-values(((at-message_0)" +"(let-values(((or-part_144)" +"(if sub-expr_6" +"(if(error-print-source-location)" +" (format \"\\n at: ~.s\" (syntax->datum$1 (datum->syntax$1 #f sub-expr_6)))" +" #f)" +" #f)))" +" (if or-part_144 or-part_144 \"\"))))" +"(let-values(((in-message_0)" +"(let-values(((or-part_145)" +"(if expr_8" +"(if(error-print-source-location)" +" (format \"\\n in: ~.s\" (syntax->datum$1 (datum->syntax$1 #f expr_8)))" +" #f)" +" #f)))" +" (if or-part_145 or-part_145 \"\"))))" +"(let-values(((src-loc-str_0)" +"(let-values(((or-part_138)(extract-source-location sub-expr_6)))" +"(if or-part_138" +" or-part_138" +"(let-values(((or-part_146)(extract-source-location expr_8)))" +" (if or-part_146 or-part_146 \"\"))))))" +"(raise" +"(exn:fail:syntax_0" +" (string-append src-loc-str_0 name_26 \": \" message_12 at-message_0 in-message_0 message-suffix_2)" +"(current-continuation-marks)" +"(map2" +" syntax-taint$1" +"(if(let-values(((or-part_147) sub-expr_6))(if or-part_147 or-part_147 expr_8))" +"(cons" +"(datum->syntax$1" +" #f" +"(let-values(((or-part_57) sub-expr_6))(if or-part_57 or-part_57 expr_8)))" +" extra-sources_4)" +" extra-sources_4)))))))))))))))" +"(define-values" +"(extract-form-name)" +"(lambda(s_160)" +"(begin" +"(if(syntax?$1 s_160)" +"(let-values()" +"(let-values(((e_17)(syntax-e$1 s_160)))" +"(if(symbol? e_17)" +"(let-values() e_17)" +"(if(if(pair? e_17)(identifier?(car e_17)) #f)" +"(let-values()(syntax-e$1(car e_17)))" +"(let-values() #f)))))" +"(let-values() #f)))))" +"(define-values" +"(extract-source-location)" +"(lambda(s_84)" +"(begin" +"(if(syntax?$1 s_84)" +"(if(syntax-srcloc s_84)" +" (let-values (((str_2) (srcloc->string (syntax-srcloc s_84)))) (if str_2 (string-append str_2 \": \") #f))" +" #f)" +" #f))))" +"(define-values" +"(struct:module-use module-use1.1 module-use? module-use-module module-use-phase)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()(make-struct-type 'module-use #f 2 0 #f null #f #f '(0 1) #f 'module-use)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'module)" +"(make-struct-field-accessor -ref_0 1 'phase))))" +"(define-values" +"(struct:module" +" module1.1" +" module?" +" module-source-name" +" module-self" +" module-requires" +" module-provides" +" module-access" +" module-language-info" +" module-min-phase-level" +" module-max-phase-level" +" module-phase-level-linklet-info-callback" +" module-force-bulk-binding" +" module-prepare-instance" +" module-instantiate-phase" +" module-primitive?" +" module-is-predefined?" +" module-cross-phase-persistent?" +" module-no-protected?" +" module-inspector" +" module-submodule-names" +" module-supermodule-name" +" module-get-all-variables" +" set-module-access!)" +"(let-values(((struct:_1 make-_1 ?_1 -ref_1 -set!_1)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module" +" #f" +" 20" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)" +" #f" +" 'module)))))" +"(values" +" struct:_1" +" make-_1" +" ?_1" +"(make-struct-field-accessor -ref_1 0 'source-name)" +"(make-struct-field-accessor -ref_1 1 'self)" +"(make-struct-field-accessor -ref_1 2 'requires)" +"(make-struct-field-accessor -ref_1 3 'provides)" +"(make-struct-field-accessor -ref_1 4 'access)" +"(make-struct-field-accessor -ref_1 5 'language-info)" +"(make-struct-field-accessor -ref_1 6 'min-phase-level)" +"(make-struct-field-accessor -ref_1 7 'max-phase-level)" +"(make-struct-field-accessor -ref_1 8 'phase-level-linklet-info-callback)" +"(make-struct-field-accessor -ref_1 9 'force-bulk-binding)" +"(make-struct-field-accessor -ref_1 10 'prepare-instance)" +"(make-struct-field-accessor -ref_1 11 'instantiate-phase)" +"(make-struct-field-accessor -ref_1 12 'primitive?)" +"(make-struct-field-accessor -ref_1 13 'is-predefined?)" +"(make-struct-field-accessor -ref_1 14 'cross-phase-persistent?)" +"(make-struct-field-accessor -ref_1 15 'no-protected?)" +"(make-struct-field-accessor -ref_1 16 'inspector)" +"(make-struct-field-accessor -ref_1 17 'submodule-names)" +"(make-struct-field-accessor -ref_1 18 'supermodule-name)" +"(make-struct-field-accessor -ref_1 19 'get-all-variables)" +"(make-struct-field-mutator -set!_1 4 'access))))" +"(define-values" +"(struct:module-linklet-info" +" module-linklet-info2.1" +" module-linklet-info?" +" module-linklet-info-linklet-or-instance" +" module-linklet-info-module-uses" +" module-linklet-info-self" +" module-linklet-info-inspector" +" module-linklet-info-extra-inspector" +" module-linklet-info-extra-inspectorsss)" +"(let-values(((struct:_36 make-_36 ?_36 -ref_36 -set!_36)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-linklet-info" +" #f" +" 6" +" 0" +" #f" +" null" +" #f" +" #f" +" '(0 1 2 3 4 5)" +" #f" +" 'module-linklet-info)))))" +"(values" +" struct:_36" +" make-_36" +" ?_36" +"(make-struct-field-accessor -ref_36 0 'linklet-or-instance)" +"(make-struct-field-accessor -ref_36 1 'module-uses)" +"(make-struct-field-accessor -ref_36 2 'self)" +"(make-struct-field-accessor -ref_36 3 'inspector)" +"(make-struct-field-accessor -ref_36 4 'extra-inspector)" +"(make-struct-field-accessor -ref_36 5 'extra-inspectorsss))))" +"(define-values" +"(make-module39.1)" +"(lambda(cross-phase-persistent?16_0" +" cross-phase-persistent?34_0" +" force-bulk-binding-callback10_0" +" force-bulk-binding-callback28_0" +" get-all-variables20_0" +" get-all-variables38_0" +" instantiate-phase-callback9_0" +" language-info13_0" +" language-info31_0" +" max-phase-level8_0" +" max-phase-level26_0" +" min-phase-level7_0" +" min-phase-level25_0" +" no-protected?17_0" +" no-protected?35_0" +" phase-level-linklet-info-callback12_0" +" phase-level-linklet-info-callback30_0" +" predefined?15_0" +" predefined?33_0" +" prepare-instance-callback11_0" +" prepare-instance-callback29_0" +" primitive?14_0" +" primitive?32_0" +" provides6_0" +" requires5_0" +" requires23_0" +" self4_0" +" source-name3_0" +" source-name21_0" +" submodule-names18_0" +" submodule-names36_0" +" supermodule-name19_0" +" supermodule-name37_0)" +"(begin" +" 'make-module39" +"(let-values(((source-name_0)(if source-name21_0 source-name3_0 #f)))" +"(let-values(((self_3) self4_0))" +"(let-values(((requires_0)(if requires23_0 requires5_0 null)))" +"(let-values(((provides_3) provides6_0))" +"(let-values(((min-phase-level_0)(if min-phase-level25_0 min-phase-level7_0 0)))" +"(let-values(((max-phase-level_0)(if max-phase-level26_0 max-phase-level8_0 0)))" +"(let-values(((instantiate-phase_0) instantiate-phase-callback9_0))" +"(let-values(((force-bulk-binding_0)" +"(if force-bulk-binding-callback28_0 force-bulk-binding-callback10_0 void)))" +"(let-values(((prepare-instance_0)" +"(if prepare-instance-callback29_0 prepare-instance-callback11_0 void)))" +"(let-values(((phase-level-linklet-info-callback_0)" +"(if phase-level-linklet-info-callback30_0" +" phase-level-linklet-info-callback12_0" +"(lambda(phase-level_10 ns_18 insp_4)" +"(begin 'phase-level-linklet-info-callback #f)))))" +"(let-values(((language-info_0)(if language-info31_0 language-info13_0 #f)))" +"(let-values(((primitive?_0)(if primitive?32_0 primitive?14_0 #f)))" +"(let-values(((predefined?_0)(if predefined?33_0 predefined?15_0 #f)))" +"(let-values(((cross-phase-persistent?_0)" +"(if cross-phase-persistent?34_0" +" cross-phase-persistent?16_0" +" primitive?_0)))" +"(let-values(((no-protected?_0)(if no-protected?35_0 no-protected?17_0 #f)))" +"(let-values(((submodule-names_0)" +"(if submodule-names36_0 submodule-names18_0 null)))" +"(let-values(((supermodule-name_0)" +"(if supermodule-name37_0 supermodule-name19_0 #f)))" +"(let-values(((get-all-variables_0)" +"(if get-all-variables38_0" +" get-all-variables20_0" +"(lambda()(begin 'get-all-variables null)))))" +"(let-values()" +"(module1.1" +" source-name_0" +" self_3" +"(unresolve-requires requires_0)" +" provides_3" +" #f" +" language-info_0" +" min-phase-level_0" +" max-phase-level_0" +" phase-level-linklet-info-callback_0" +" force-bulk-binding_0" +" prepare-instance_0" +" instantiate-phase_0" +" primitive?_0" +" predefined?_0" +" cross-phase-persistent?_0" +" no-protected?_0" +"(current-code-inspector)" +" submodule-names_0" +" supermodule-name_0" +" get-all-variables_0)))))))))))))))))))))))" +"(define-values" +"(struct:module-instance" +" module-instance42.1" +" module-instance?" +" module-instance-namespace" +" module-instance-module" +" module-instance-shifted-requires" +" module-instance-phase-level-to-state" +" module-instance-made-available?" +" module-instance-attached?" +" module-instance-data-box" +" set-module-instance-shifted-requires!" +" set-module-instance-made-available?!" +" set-module-instance-attached?!)" +"(let-values(((struct:_37 make-_37 ?_37 -ref_37 -set!_37)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-instance" +" #f" +" 7" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1 3 6)" +" #f" +" 'module-instance)))))" +"(values" +" struct:_37" +" make-_37" +" ?_37" +"(make-struct-field-accessor -ref_37 0 'namespace)" +"(make-struct-field-accessor -ref_37 1 'module)" +"(make-struct-field-accessor -ref_37 2 'shifted-requires)" +"(make-struct-field-accessor -ref_37 3 'phase-level-to-state)" +"(make-struct-field-accessor -ref_37 4 'made-available?)" +"(make-struct-field-accessor -ref_37 5 'attached?)" +"(make-struct-field-accessor -ref_37 6 'data-box)" +"(make-struct-field-mutator -set!_37 2 'shifted-requires)" +"(make-struct-field-mutator -set!_37 4 'made-available?)" +"(make-struct-field-mutator -set!_37 5 'attached?))))" +"(define-values" +"(make-module-instance)" +"(lambda(m-ns_0 m_1)(begin(module-instance42.1 m-ns_0 m_1 #f(make-small-hasheqv) #f #f(box #f)))))" +"(define-values" +"(make-module-namespace50.1)" +"(lambda(for-submodule?45_0 mpi43_0 root-expand-context44_0 ns49_0)" +"(begin" +" 'make-module-namespace50" +"(let-values(((ns_19) ns49_0))" +"(let-values(((name-mpi_0) mpi43_0))" +"(let-values(((root-expand-ctx_1) root-expand-context44_0))" +"(let-values(((for-submodule?_0) for-submodule?45_0))" +"(let-values()" +"(let-values(((phase_26) 0))" +"(let-values(((name_27)(1/module-path-index-resolve name-mpi_0)))" +"(let-values(((m-ns_1)" +"(let-values(((the-struct_38)" +"(let-values(((root-expand-ctx161_0) root-expand-ctx_1)" +"((temp162_0) #f))" +"(new-namespace9.1 temp162_0 #t root-expand-ctx161_0 #t ns_19 #t))))" +"(if(1/namespace? the-struct_38)" +"(let-values(((mpi152_0) name-mpi_0)" +"((source-name153_0)(resolved-module-path-root-name name_27))" +"((phase154_0) phase_26)" +"((0-phase155_0) phase_26)" +"((submodule-declarations156_0)" +"(if for-submodule?_0" +"(namespace-submodule-declarations ns_19)" +"(make-small-hasheq)))" +"((available-module-instances157_0)(make-hasheqv))" +"((module-instances158_0)(make-hasheqv))" +"((declaration-inspector159_0)(current-code-inspector)))" +"(namespace1.1" +" mpi152_0" +" source-name153_0" +"(namespace-root-expand-ctx the-struct_38)" +" phase154_0" +" 0-phase155_0" +"(namespace-phase-to-namespace the-struct_38)" +"(namespace-phase-level-to-definitions the-struct_38)" +"(1/namespace-module-registry the-struct_38)" +"(namespace-bulk-binding-registry the-struct_38)" +" submodule-declarations156_0" +"(namespace-root-namespace the-struct_38)" +" declaration-inspector159_0" +"(namespace-inspector the-struct_38)" +" available-module-instances157_0" +" module-instances158_0))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_38)))))" +"(let-values((()" +"(begin" +"(small-hash-set!(namespace-phase-to-namespace m-ns_1) phase_26 m-ns_1)" +"(values))))" +"(let-values(((at-phase_0)(make-hasheq)))" +"(begin" +"(hash-set!(namespace-module-instances m-ns_1) phase_26 at-phase_0)" +"(hash-set! at-phase_0 name_27(make-module-instance m-ns_1 #f))" +" m-ns_1))))))))))))))" +"(define-values" +"(declare-module!58.1)" +"(lambda(with-submodules?53_0 with-submodules?54_0 ns55_0 m56_0 mod-name57_0)" +"(begin" +" 'declare-module!58" +"(let-values(((ns_20) ns55_0))" +"(let-values(((m_2) m56_0))" +"(let-values(((mod-name_4) mod-name57_0))" +"(let-values(((with-submodules?_0)(if with-submodules?54_0 with-submodules?53_0 #t)))" +"(let-values()" +"(let-values(((prior-m_0)" +"(if with-submodules?_0" +"(hash-ref" +"(module-registry-declarations(1/namespace-module-registry ns_20))" +" mod-name_4" +" #f)" +" #f)))" +"(let-values(((prior-mi_0)" +"(if prior-m_0" +"(if(not(eq? m_2 prior-m_0))" +"(let-values(((ns163_0) ns_20)" +"((mod-name164_0) mod-name_4)" +"((temp165_0)(namespace-phase ns_20)))" +"(namespace->module-instance70.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns163_0" +" mod-name164_0" +" temp165_0))" +" #f)" +" #f)))" +"(begin" +"(if(if prior-m_0(not(eq? m_2 prior-m_0)) #f)" +"(let-values()(check-redeclaration-ok prior-m_0 prior-mi_0 mod-name_4))" +"(void))" +"(if with-submodules?_0" +"(hash-set!(module-registry-declarations(1/namespace-module-registry ns_20)) mod-name_4 m_2)" +"(small-hash-set!(namespace-submodule-declarations ns_20) mod-name_4 m_2))" +"(if with-submodules?_0" +"(let-values()" +"(begin" +"(register-bulk-provide!" +"(namespace-bulk-binding-registry ns_20)" +" mod-name_4" +"(module-self m_2)" +"(module-provides m_2))" +"((1/current-module-name-resolver) mod-name_4 #f)))" +"(void))" +"(if prior-mi_0" +"(let-values()" +"(let-values(((m-ns_2)(module-instance-namespace prior-mi_0)))" +"(let-values(((states_0)(module-instance-phase-level-to-state prior-mi_0)))" +"(let-values(((phase_27)(namespace-phase ns_20)))" +"(let-values(((visit?_0)(eq? 'started(small-hash-ref states_0(add1 phase_27) #f))))" +"(let-values(((run?_0)(eq? 'started(small-hash-ref states_0 phase_27 #f))))" +"(let-values(((at-phase_1)(hash-ref(namespace-module-instances ns_20) phase_27)))" +"(begin" +"(hash-set! at-phase_1 mod-name_4(make-module-instance m-ns_2 m_2))" +"(if visit?_0" +"(let-values()" +"(let-values(((ns166_0) ns_20)" +"((temp167_0)(namespace-mpi m-ns_2))" +"((phase168_0) phase_27))" +"(namespace-module-visit!104.1 #f #f ns166_0 temp167_0 phase168_0)))" +"(void))" +"(if run?_0" +"(let-values()" +"(let-values(((ns169_0) ns_20)" +"((temp170_0)(namespace-mpi m-ns_2))" +"((phase171_0) phase_27))" +"(namespace-module-instantiate!96.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns169_0" +" temp170_0" +" phase171_0)))" +"(void))))))))))" +"(void)))))))))))))" +"(define-values" +"(check-redeclaration-ok)" +"(lambda(prior-m_1 prior-mi_1 mod-name_5)" +"(begin" +"(begin" +"(if(module-cross-phase-persistent? prior-m_1)" +"(let-values()" +" (raise-arguments-error 'module \"cannot redeclare cross-phase persistent module\" \"module name\" mod-name_5))" +"(void))" +"(if(if prior-mi_1" +"(let-values(((or-part_148)(module-instance-attached? prior-mi_1)))" +"(if or-part_148" +" or-part_148" +"(not" +"(inspector-superior?" +"(current-code-inspector)" +"(namespace-inspector(module-instance-namespace prior-mi_1))))))" +" #f)" +"(let-values()" +" (raise-arguments-error 'module \"current code inspector cannot redeclare module\" \"module name\" mod-name_5))" +"(void))))))" +"(define-values" +"(raise-unknown-module-error)" +" (lambda (who_8 mod-name_6) (begin (raise-arguments-error who_8 \"unknown module\" \"module name\" mod-name_6))))" +"(define-values" +"(namespace->module-linklet-info)" +"(lambda(ns_21 name_28 phase-level_11)" +"(begin" +"(let-values(((m_3)(namespace->module ns_21 name_28)))" +"(if m_3((module-phase-level-linklet-info-callback m_3) phase-level_11 ns_21(module-inspector m_3)) #f)))))" +"(define-values" +"(namespace->module-instance70.1)" +"(lambda(check-available-at-phase-level62_0" +" check-available-at-phase-level65_0" +" complain-on-failure?61_0" +" complain-on-failure?64_0" +" unavailable-callback63_0" +" unavailable-callback66_0" +" ns67_0" +" name68_0" +" 0-phase69_0)" +"(begin" +" 'namespace->module-instance70" +"(let-values(((ns_22) ns67_0))" +"(let-values(((name_29) name68_0))" +"(let-values(((0-phase_1) 0-phase69_0))" +"(let-values(((complain-on-failure?_0)(if complain-on-failure?64_0 complain-on-failure?61_0 #f)))" +"(let-values(((check-available-at-phase-level_0)" +"(if check-available-at-phase-level65_0 check-available-at-phase-level62_0 #f)))" +"(let-values(((unavailable-callback_0)(if unavailable-callback66_0 unavailable-callback63_0 void)))" +"(let-values()" +"(let-values(((mi_0)" +"(let-values(((or-part_149)" +"(hash-ref" +"(hash-ref(namespace-module-instances ns_22) 0-phase_1 '#hasheq())" +" name_29" +" #f)))" +"(if or-part_149" +" or-part_149" +"(let-values(((or-part_150)" +"(let-values(((c-ns_0)" +"(let-values(((or-part_113)" +"(namespace-root-namespace ns_22)))" +"(if or-part_113 or-part_113 ns_22))))" +"(hash-ref(namespace-module-instances c-ns_0) name_29 #f))))" +"(if or-part_150" +" or-part_150" +"(if complain-on-failure?_0" +" (error \"no module instance found:\" name_29 0-phase_1)" +" #f)))))))" +"(if(if mi_0 check-available-at-phase-level_0 #f)" +"(check-availablilty mi_0 check-available-at-phase-level_0 unavailable-callback_0)" +" mi_0))))))))))))" +"(define-values" +"(namespace-install-module-namespace!)" +"(lambda(ns_23 name_30 0-phase_2 m_4 existing-m-ns_0)" +"(begin" +"(let-values(((m-ns_3)" +"(let-values(((the-struct_39) ns_23))" +"(if(1/namespace? the-struct_39)" +"(let-values(((mpi172_0)(namespace-mpi existing-m-ns_0))" +"((source-name173_0)(namespace-source-name existing-m-ns_0))" +"((root-expand-ctx174_0)(box(unbox(namespace-root-expand-ctx existing-m-ns_0))))" +"((phase175_0)(namespace-phase existing-m-ns_0))" +"((0-phase176_0)(namespace-0-phase existing-m-ns_0))" +"((phase-to-namespace177_0)(make-small-hasheqv))" +"((phase-level-to-definitions178_0)" +"(if(module-cross-phase-persistent? m_4)" +"(namespace-phase-level-to-definitions existing-m-ns_0)" +"(make-small-hasheqv)))" +"((declaration-inspector179_0)(module-inspector m_4))" +"((inspector180_0)(namespace-inspector existing-m-ns_0)))" +"(namespace1.1" +" mpi172_0" +" source-name173_0" +" root-expand-ctx174_0" +" phase175_0" +" 0-phase176_0" +" phase-to-namespace177_0" +" phase-level-to-definitions178_0" +"(1/namespace-module-registry the-struct_39)" +"(namespace-bulk-binding-registry the-struct_39)" +"(namespace-submodule-declarations the-struct_39)" +"(namespace-root-namespace the-struct_39)" +" declaration-inspector179_0" +" inspector180_0" +"(namespace-available-module-instances the-struct_39)" +"(namespace-module-instances the-struct_39)))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_39)))))" +"(let-values(((mi_1)(make-module-instance m-ns_3 m_4)))" +"(if(module-cross-phase-persistent? m_4)" +"(let-values()" +"(begin" +"(small-hash-set!(namespace-phase-to-namespace m-ns_3) 0 m-ns_3)" +"(small-hash-set!" +"(namespace-phase-level-to-definitions m-ns_3)" +" 0" +"(namespace->definitions existing-m-ns_0 0))" +"(small-hash-set!(namespace-phase-to-namespace m-ns_3) 1(namespace->namespace-at-phase m-ns_3 1))" +"(small-hash-set!" +"(namespace-phase-level-to-definitions m-ns_3)" +" 1" +"(namespace->definitions existing-m-ns_0 1))" +"(hash-set!" +"(namespace-module-instances" +"(let-values(((or-part_151)(namespace-root-namespace ns_23)))(if or-part_151 or-part_151 ns_23)))" +" name_30" +" mi_1)" +"(small-hash-set!(module-instance-phase-level-to-state mi_1) 0 'started)))" +"(let-values()" +"(let-values((()" +"(begin(small-hash-set!(namespace-phase-to-namespace m-ns_3) 0-phase_2 m-ns_3)(values))))" +"(let-values((()" +"(begin" +"(small-hash-set!" +"(namespace-phase-level-to-definitions m-ns_3)" +" 0" +"(namespace->definitions existing-m-ns_0 0))" +"(values))))" +"(let-values((()" +"(begin" +"(small-hash-set!(module-instance-phase-level-to-state mi_1) 0 'started)" +"(values))))" +"(let-values(((at-phase_2)" +"(let-values(((or-part_152)" +"(hash-ref(namespace-module-instances ns_23) 0-phase_2 #f)))" +"(if or-part_152" +" or-part_152" +"(let-values(((at-phase_3)(make-hasheq)))" +"(begin" +"(hash-set!(namespace-module-instances ns_23) 0-phase_2 at-phase_3)" +" at-phase_3))))))" +"(hash-set! at-phase_2 name_30 mi_1))))))))))))" +"(define-values" +"(namespace-create-module-instance!)" +"(lambda(ns_24 name_31 0-phase_3 m_5 mpi_14)" +"(begin" +"(let-values(((m-ns_4)" +"(let-values(((the-struct_40) ns_24))" +"(if(1/namespace? the-struct_40)" +"(let-values(((mpi181_0) mpi_14)" +"((source-name182_0)" +"(let-values(((or-part_153)(module-source-name m_5)))" +"(if or-part_153" +" or-part_153" +"(resolved-module-path-root-name(1/module-path-index-resolve mpi_14)))))" +"((root-expand-ctx183_0)(box #f))" +"((phase184_0) 0-phase_3)" +"((0-phase185_0) 0-phase_3)" +"((phase-to-namespace186_0)(make-small-hasheqv))" +"((phase-level-to-definitions187_0)(make-small-hasheqv))" +"((declaration-inspector188_0)(module-inspector m_5))" +"((inspector189_0)(make-inspector(module-inspector m_5))))" +"(namespace1.1" +" mpi181_0" +" source-name182_0" +" root-expand-ctx183_0" +" phase184_0" +" 0-phase185_0" +" phase-to-namespace186_0" +" phase-level-to-definitions187_0" +"(1/namespace-module-registry the-struct_40)" +"(namespace-bulk-binding-registry the-struct_40)" +"(namespace-submodule-declarations the-struct_40)" +"(namespace-root-namespace the-struct_40)" +" declaration-inspector188_0" +" inspector189_0" +"(namespace-available-module-instances the-struct_40)" +"(namespace-module-instances the-struct_40)))" +" (raise-argument-error 'struct-copy \"namespace?\" the-struct_40)))))" +"(let-values((()(begin(small-hash-set!(namespace-phase-to-namespace m-ns_4) 0-phase_3 m-ns_4)(values))))" +"(let-values(((mi_2)(make-module-instance m-ns_4 m_5)))" +"(begin" +"(if(module-cross-phase-persistent? m_5)" +"(hash-set!(namespace-module-instances ns_24) name_31 mi_2)" +"(let-values(((at-phase_4)" +"(let-values(((or-part_154)(hash-ref(namespace-module-instances ns_24) 0-phase_3 #f)))" +"(if or-part_154" +" or-part_154" +"(let-values(((at-phase_5)(make-hasheq)))" +"(begin" +"(hash-set!(namespace-module-instances ns_24) 0-phase_3 at-phase_5)" +" at-phase_5))))))" +"(hash-set! at-phase_4 name_31 mi_2)))" +" mi_2)))))))" +"(define-values" +"(check-availablilty)" +"(lambda(mi_3 check-available-at-phase-level_1 unavailable-callback_1)" +"(begin" +"(let-values(((m_6)(module-instance-module mi_3)))" +"(if(if m_6" +"(if(<=(module-min-phase-level m_6)(add1 check-available-at-phase-level_1)(module-max-phase-level m_6))" +"(not" +"(small-hash-ref" +"(module-instance-phase-level-to-state mi_3)" +"(add1 check-available-at-phase-level_1)" +" #f))" +" #f)" +" #f)" +"(unavailable-callback_1 mi_3)" +" mi_3)))))" +"(define-values" +"(namespace->module-namespace82.1)" +"(lambda(check-available-at-phase-level74_0" +" check-available-at-phase-level77_0" +" complain-on-failure?73_0" +" complain-on-failure?76_0" +" unavailable-callback75_0" +" unavailable-callback78_0" +" ns79_0" +" name80_0" +" 0-phase81_0)" +"(begin" +" 'namespace->module-namespace82" +"(let-values(((ns_25) ns79_0))" +"(let-values(((name_32) name80_0))" +"(let-values(((0-phase_4) 0-phase81_0))" +"(let-values(((complain-on-failure?_1)(if complain-on-failure?76_0 complain-on-failure?73_0 #f)))" +"(let-values(((check-available-at-phase-level_2)" +"(if check-available-at-phase-level77_0 check-available-at-phase-level74_0 #f)))" +"(let-values(((unavailable-callback_2)(if unavailable-callback78_0 unavailable-callback75_0 void)))" +"(let-values()" +"(let-values(((mi_4)" +"(let-values(((complain-on-failure?193_0) complain-on-failure?_1)" +"((check-available-at-phase-level194_0) check-available-at-phase-level_2)" +"((unavailable-callback195_0) unavailable-callback_2))" +"(namespace->module-instance70.1" +" check-available-at-phase-level194_0" +" #t" +" complain-on-failure?193_0" +" #t" +" unavailable-callback195_0" +" #t" +" ns_25" +" name_32" +" 0-phase_4))))" +"(if mi_4(module-instance-namespace mi_4) #f))))))))))))" +"(define-values" +"(namespace-record-module-instance-attached!)" +"(lambda(ns_26 mod-name_7 phase_28)" +"(begin" +"(let-values(((mi_5)" +"(let-values(((ns196_0) ns_26)((mod-name197_0) mod-name_7)((phase198_0) phase_28))" +"(namespace->module-instance70.1 #f #f #f #f #f #f ns196_0 mod-name197_0 phase198_0))))" +"(set-module-instance-attached?! mi_5 #t)))))" +"(define-values" +"(module-force-bulk-binding!)" +"(lambda(m_7 ns_27)(begin((module-force-bulk-binding m_7)(namespace-bulk-binding-registry ns_27)))))" +"(define-values" +"(namespace-module-instantiate!96.1)" +"(lambda(otherwise-available?87_0" +" otherwise-available?91_0" +" run-phase85_0" +" run-phase89_0" +" seen88_0" +" seen92_0" +" skip-run?86_0" +" skip-run?90_0" +" ns93_0" +" mpi94_0" +" instance-phase95_0)" +"(begin" +" 'namespace-module-instantiate!96" +"(let-values(((ns_28) ns93_0))" +"(let-values(((mpi_15) mpi94_0))" +"(let-values(((instance-phase_0) instance-phase95_0))" +"(let-values(((run-phase_0)(if run-phase89_0 run-phase85_0(namespace-phase ns_28))))" +"(let-values(((skip-run?_0)(if skip-run?90_0 skip-run?86_0 #f)))" +"(let-values(((otherwise-available?_0)(if otherwise-available?91_0 otherwise-available?87_0 #t)))" +"(let-values(((seen_17)(if seen92_0 seen88_0 '#hasheq())))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/module-path-index? mpi_15)" +"(void)" +" (let-values () (error \"not a module path index:\" mpi_15)))" +"(values))))" +"(let-values(((name_33)(1/module-path-index-resolve mpi_15 #t)))" +"(let-values(((m_8)(namespace->module ns_28 name_33)))" +"(let-values((()" +"(begin" +"(if m_8" +"(void)" +"(let-values()(raise-unknown-module-error 'instantiate name_33)))" +"(values))))" +"(let-values(((instantiate!_0)" +"(lambda(instance-phase_1 run-phase_1 ns_29)" +"(begin" +" 'instantiate!" +"(let-values(((mi_6)" +"(let-values(((or-part_155)" +"(let-values(((ns205_0) ns_29)" +"((name206_0) name_33)" +"((instance-phase207_0)" +" instance-phase_1))" +"(namespace->module-instance70.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns205_0" +" name206_0" +" instance-phase207_0))))" +"(if or-part_155" +" or-part_155" +"(namespace-create-module-instance!" +" ns_29" +" name_33" +" instance-phase_1" +" m_8" +" mpi_15)))))" +"(let-values(((run-phase201_0) run-phase_1)" +"((skip-run?202_0) skip-run?_0)" +"((otherwise-available?203_0) otherwise-available?_0)" +"((seen204_0) seen_17))" +"(run-module-instance!125.1" +" otherwise-available?203_0" +" run-phase201_0" +" seen204_0" +" #t" +" skip-run?202_0" +" mi_6" +" ns_29)))))))" +"(if(module-cross-phase-persistent? m_8)" +"(let-values()" +"(instantiate!_0" +" 0" +" 0" +"(let-values(((or-part_156)(namespace-root-namespace ns_28)))" +"(if or-part_156 or-part_156 ns_28))))" +"(let-values()(instantiate!_0 instance-phase_0 run-phase_0 ns_28)))))))))))))))))))" +"(define-values" +"(namespace-module-visit!104.1)" +"(lambda(visit-phase99_0 visit-phase100_0 ns101_0 mpi102_0 instance-phase103_0)" +"(begin" +" 'namespace-module-visit!104" +"(let-values(((ns_30) ns101_0))" +"(let-values(((mpi_16) mpi102_0))" +"(let-values(((instance-phase_2) instance-phase103_0))" +"(let-values(((visit-phase_0)(if visit-phase100_0 visit-phase99_0(namespace-phase ns_30))))" +"(let-values()" +"(let-values(((temp211_0)(add1 visit-phase_0)))" +"(namespace-module-instantiate!96.1" +" #f" +" #f" +" temp211_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" ns_30" +" mpi_16" +" instance-phase_2))))))))))" +"(define-values" +"(namespace-module-make-available!112.1)" +"(lambda(visit-phase107_0 visit-phase108_0 ns109_0 mpi110_0 instance-phase111_0)" +"(begin" +" 'namespace-module-make-available!112" +"(let-values(((ns_31) ns109_0))" +"(let-values(((mpi_17) mpi110_0))" +"(let-values(((instance-phase_3) instance-phase111_0))" +"(let-values(((visit-phase_1)(if visit-phase108_0 visit-phase107_0(namespace-phase ns_31))))" +"(let-values()" +"(let-values(((temp215_0)(add1 visit-phase_1))((temp216_0) #t))" +"(namespace-module-instantiate!96.1" +" #f" +" #f" +" temp215_0" +" #t" +" #f" +" #f" +" temp216_0" +" #t" +" ns_31" +" mpi_17" +" instance-phase_3))))))))))" +"(define-values" +"(run-module-instance!125.1)" +"(lambda(otherwise-available?117_0 run-phase115_0 seen118_0 seen122_0 skip-run?116_0 mi123_0 ns124_0)" +"(begin" +" 'run-module-instance!125" +"(let-values(((mi_7) mi123_0))" +"(let-values(((ns_32) ns124_0))" +"(let-values(((run-phase_2) run-phase115_0))" +"(let-values(((skip-run?_1) skip-run?116_0))" +"(let-values(((otherwise-available?_1) otherwise-available?117_0))" +"(let-values(((seen_18)(if seen122_0 seen118_0 '#hasheq())))" +"(let-values()" +"(let-values()" +"(let-values(((m-ns_5)(module-instance-namespace mi_7)))" +"(let-values(((instance-phase_4)(namespace-0-phase m-ns_5)))" +"(let-values(((run-phase-level_0)(phase- run-phase_2 instance-phase_4)))" +"(if(if(let-values(((or-part_157) skip-run?_1))" +"(if or-part_157" +" or-part_157" +"(eq?" +" 'started" +"(small-hash-ref" +"(module-instance-phase-level-to-state mi_7)" +" run-phase-level_0" +" #f))))" +"(let-values(((or-part_158)(not otherwise-available?_1)))" +"(if or-part_158 or-part_158(module-instance-made-available? mi_7)))" +" #f)" +"(void)" +"(let-values()" +"(let-values(((m_9)(module-instance-module mi_7)))" +"(let-values(((mpi_18)(namespace-mpi m-ns_5)))" +"(let-values(((phase-shift_3) instance-phase_4))" +"(let-values(((bulk-binding-registry_3)(namespace-bulk-binding-registry m-ns_5)))" +"(begin" +"(if(hash-ref seen_18 mi_7 #f)" +"(let-values()" +" (error 'require \"import cycle detected during module instantiation\"))" +"(void))" +"(if(module-instance-shifted-requires mi_7)" +"(void)" +"(let-values()" +"(set-module-instance-shifted-requires!" +" mi_7" +"(reverse$1" +"(let-values(((lst_56)(module-requires m_9)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_56)))" +"((letrec-values(((for-loop_79)" +"(lambda(fold-var_42 lst_57)" +"(begin" +" 'for-loop" +"(if(pair? lst_57)" +"(let-values(((phase+mpis_0)" +"(unsafe-car lst_57))" +"((rest_25)" +"(unsafe-cdr lst_57)))" +"(let-values(((fold-var_43)" +"(let-values(((fold-var_44)" +" fold-var_42))" +"(let-values(((fold-var_45)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +"(car" +" phase+mpis_0)" +"(reverse$1" +"(let-values(((lst_58)" +"(cdr" +" phase+mpis_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_58)))" +"((letrec-values(((for-loop_80)" +"(lambda(fold-var_46" +" lst_59)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_59)" +"(let-values(((req-mpi_0)" +"(unsafe-car" +" lst_59))" +"((rest_26)" +"(unsafe-cdr" +" lst_59)))" +"(let-values(((fold-var_47)" +"(let-values(((fold-var_48)" +" fold-var_46))" +"(let-values(((fold-var_49)" +"(let-values()" +"(cons" +"(let-values()" +"(module-path-index-shift" +" req-mpi_0" +"(module-self" +" m_9)" +" mpi_18))" +" fold-var_48))))" +"(values" +" fold-var_49)))))" +"(if(not" +" #f)" +"(for-loop_80" +" fold-var_47" +" rest_26)" +" fold-var_47)))" +" fold-var_46)))))" +" for-loop_80)" +" null" +" lst_58))))))" +" fold-var_44))))" +"(values fold-var_45)))))" +"(if(not #f)" +"(for-loop_79 fold-var_43 rest_25)" +" fold-var_43)))" +" fold-var_42)))))" +" for-loop_79)" +" null" +" lst_56)))))))" +"(let-values(((lst_60)(module-instance-shifted-requires mi_7)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_60)))" +"((letrec-values(((for-loop_81)" +"(lambda(lst_61)" +"(begin" +" 'for-loop" +"(if(pair? lst_61)" +"(let-values(((phase+mpis_1)(unsafe-car lst_61))" +"((rest_27)(unsafe-cdr lst_61)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((req-phase_0)" +"(car" +" phase+mpis_1)))" +"(begin" +"(let-values(((lst_62)" +"(cdr" +" phase+mpis_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_62)))" +"((letrec-values(((for-loop_82)" +"(lambda(lst_63)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_63)" +"(let-values(((req-mpi_1)" +"(unsafe-car" +" lst_63))" +"((rest_28)" +"(unsafe-cdr" +" lst_63)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((temp219_0)" +"(phase+" +" instance-phase_4" +" req-phase_0))" +"((run-phase220_0)" +" run-phase_2)" +"((skip-run?221_0)" +" skip-run?_1)" +"((otherwise-available?222_0)" +" otherwise-available?_1)" +"((temp223_0)" +"(hash-set" +" seen_18" +" mi_7" +" #t)))" +"(namespace-module-instantiate!96.1" +" otherwise-available?222_0" +" #t" +" run-phase220_0" +" #t" +" temp223_0" +" #t" +" skip-run?221_0" +" #t" +" ns_32" +" req-mpi_1" +" temp219_0)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_82" +" rest_28)" +"(values))))" +"(values))))))" +" for-loop_82)" +" lst_62)))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_81 rest_27)(values))))" +"(values))))))" +" for-loop_81)" +" lst_60)))" +"(void)" +"(if(label-phase? instance-phase_4)" +"(void)" +"(let-values()" +"(begin" +"(let-values(((start_13)(module-max-phase-level m_9))" +"((end_9)(sub1(module-min-phase-level m_9)))" +"((inc_3) -1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_13 end_9 inc_3)))" +"((letrec-values(((for-loop_83)" +"(lambda(pos_10)" +"(begin" +" 'for-loop" +"(if(> pos_10 end_9)" +"(let-values(((phase-level_12) pos_10))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((phase_29)" +"(phase+" +" phase-level_12" +" phase-shift_3)))" +"(if(if(not" +" skip-run?_1)" +"(eqv?" +" phase_29" +" run-phase_2)" +" #f)" +"(let-values()" +"(if(eq?" +" 'started" +"(small-hash-ref" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_12" +" #f))" +"(void)" +"(let-values()" +"(let-values((()" +"(begin" +"(small-hash-set!" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_12" +" 'started)" +"(values))))" +"(let-values((()" +"(begin" +"(void" +"(namespace->definitions" +" m-ns_5" +" phase-level_12))" +"(values))))" +"(let-values(((p-ns_2)" +"(namespace->namespace-at-phase" +" m-ns_5" +" phase_29)))" +"(let-values(((insp_5)" +"(module-inspector" +" m_9)))" +"(let-values(((data-box_0)" +"(module-instance-data-box" +" mi_7)))" +"(let-values(((prep_0)" +"(module-prepare-instance" +" m_9)))" +"(let-values(((go_0)" +"(module-instantiate-phase" +" m_9)))" +"(begin" +"(prep_0" +" data-box_0" +" p-ns_2" +" phase-shift_3" +" mpi_18" +" bulk-binding-registry_3" +" insp_5)" +"(go_0" +" data-box_0" +" p-ns_2" +" phase-shift_3" +" phase-level_12" +" mpi_18" +" bulk-binding-registry_3" +" insp_5))))))))))))" +"(if(if otherwise-available?_1" +"(if(not" +"(negative?" +" run-phase_2))" +"(not" +"(small-hash-ref" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_12" +" #f))" +" #f)" +" #f)" +"(let-values()" +"(begin" +"(hash-update!" +"(namespace-available-module-instances" +" ns_32)" +" phase_29" +"(lambda(l_47)" +"(cons" +" mi_7" +" l_47))" +" null)" +"(small-hash-set!" +"(module-instance-phase-level-to-state" +" mi_7)" +" phase-level_12" +" 'available)))" +"(void)))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_83(+ pos_10 inc_3))" +"(values))))" +"(values))))))" +" for-loop_83)" +" start_13)))" +"(void))))" +"(if otherwise-available?_1" +"(let-values()(set-module-instance-made-available?! mi_7 #t))" +"(void))" +"(if skip-run?_1" +"(void)" +"(let-values()" +"(small-hash-set!" +"(module-instance-phase-level-to-state mi_7)" +" run-phase-level_0" +" 'started))))))))))))))))))))))))" +"(define-values" +"(namespace-visit-available-modules!)" +"(let-values(((namespace-visit-available-modules!131_0)" +"(lambda(ns130_0 run-phase128_0 run-phase129_0)" +"(begin" +" 'namespace-visit-available-modules!131" +"(let-values(((ns_33) ns130_0))" +"(let-values(((run-phase_3)(if run-phase129_0 run-phase128_0(namespace-phase ns_33))))" +"(let-values()(namespace-run-available-modules! ns_33(add1 run-phase_3)))))))))" +"(case-lambda" +"((ns_34)(begin(namespace-visit-available-modules!131_0 ns_34 #f #f)))" +"((ns_35 run-phase128_1)(namespace-visit-available-modules!131_0 ns_35 run-phase128_1 #t)))))" +"(define-values" +"(namespace-run-available-modules!)" +"(let-values(((namespace-run-available-modules!136_0)" +"(lambda(ns135_0 run-phase133_0 run-phase134_0)" +"(begin" +" 'namespace-run-available-modules!136" +"(let-values(((ns_36) ns135_0))" +"(let-values(((run-phase_4)(if run-phase134_0 run-phase133_0(namespace-phase ns_36))))" +"(let-values()" +"(if(null?(hash-ref(namespace-available-module-instances ns_36) run-phase_4 null))" +"(void)" +"(let-values()" +"(registry-call-with-lock" +"(1/namespace-module-registry ns_36)" +"(lambda()" +"((letrec-values(((loop_75)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((mis_0)" +"(hash-ref" +"(namespace-available-module-instances ns_36)" +" run-phase_4" +" null)))" +"(if(null? mis_0)" +"(void)" +"(let-values()" +"(begin" +"(hash-set!" +"(namespace-available-module-instances ns_36)" +" run-phase_4" +" null)" +"(let-values(((lst_64)(reverse$1 mis_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_64)))" +"((letrec-values(((for-loop_84)" +"(lambda(lst_65)" +"(begin" +" 'for-loop" +"(if(pair? lst_65)" +"(let-values(((mi_8)" +"(unsafe-car" +" lst_65))" +"((rest_29)" +"(unsafe-cdr" +" lst_65)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((run-phase226_0)" +" run-phase_4)" +"((temp227_0)" +" #f)" +"((temp228_0)" +" #f))" +"(run-module-instance!125.1" +" temp228_0" +" run-phase226_0" +" #f" +" #f" +" temp227_0" +" mi_8" +" ns_36)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_84 rest_29)" +"(values))))" +"(values))))))" +" for-loop_84)" +" lst_64)))" +"(void)" +"(loop_75)))))))))" +" loop_75)))))))))))))" +"(case-lambda" +"((ns_37)(begin(namespace-run-available-modules!136_0 ns_37 #f #f)))" +"((ns_38 run-phase133_1)(namespace-run-available-modules!136_0 ns_38 run-phase133_1 #t)))))" +"(define-values" +"(namespace-primitive-module-visit!)" +"(lambda(ns_39 name_34)" +"(begin" +"(let-values(((mi_9)(hash-ref(namespace-module-instances ns_39)(1/make-resolved-module-path name_34))))" +"(let-values(((temp231_0) 1)((temp232_0) #f)((temp233_0) #t))" +"(run-module-instance!125.1 temp233_0 temp231_0 #f #f temp232_0 mi_9 ns_39))))))" +"(define-values" +"(namespace-module-use->module+linklet-instances146.1)" +"(lambda(phase-shift140_0 shift-from138_0 shift-from141_0 shift-to139_0 shift-to142_0 ns144_0 mu145_0)" +"(begin" +" 'namespace-module-use->module+linklet-instances146" +"(let-values(((ns_40) ns144_0))" +"(let-values(((mu_0) mu145_0))" +"(let-values(((shift-from_0)(if shift-from141_0 shift-from138_0 #f)))" +"(let-values(((shift-to_0)(if shift-to142_0 shift-to139_0 #f)))" +"(let-values(((phase-shift_4) phase-shift140_0))" +"(let-values()" +"(let-values(((mod_1)(module-use-module mu_0)))" +"(let-values(((mi_10)" +"(let-values(((temp235_0)" +"(1/module-path-index-resolve" +"(if shift-from_0" +"(module-path-index-shift mod_1 shift-from_0 shift-to_0)" +" mod_1)))" +"((phase-shift236_0) phase-shift_4)" +"((temp237_0) #t))" +"(namespace->module-instance70.1" +" #f" +" #f" +" temp237_0" +" #t" +" #f" +" #f" +" ns_40" +" temp235_0" +" phase-shift236_0))))" +"(let-values(((m-ns_6)(module-instance-namespace mi_10)))" +"(let-values(((d_17)" +"(small-hash-ref" +"(namespace-phase-level-to-definitions m-ns_6)" +"(module-use-phase mu_0)" +" #f)))" +"(if d_17" +"(values mi_10(definitions-variables d_17))" +"(error" +" 'eval" +"(string-append" +" \"namespace mismatch: phase level not found;\\n\"" +" \" module: ~a\\n\"" +" \" phase level: ~a\\n\"" +" \" found phase levels: ~a\")" +" mod_1" +"(module-use-phase mu_0)" +"(small-hash-keys(namespace-phase-level-to-definitions m-ns_6)))))))))))))))))" +"(define-values" +"(unresolve-requires)" +"(lambda(requires_1)" +"(begin" +"(reverse$1" +"(let-values(((lst_66) requires_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_66)))" +"((letrec-values(((for-loop_85)" +"(lambda(fold-var_50 lst_67)" +"(begin" +" 'for-loop" +"(if(pair? lst_67)" +"(let-values(((phase+mpis_2)(unsafe-car lst_67))((rest_30)(unsafe-cdr lst_67)))" +"(let-values(((fold-var_51)" +"(let-values(((fold-var_52) fold-var_50))" +"(let-values(((fold-var_53)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +"(car phase+mpis_2)" +"(reverse$1" +"(let-values(((lst_68)(cdr phase+mpis_2)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_68)))" +"((letrec-values(((for-loop_86)" +"(lambda(fold-var_54" +" lst_69)" +"(begin" +" 'for-loop" +"(if(pair? lst_69)" +"(let-values(((req-mpi_2)" +"(unsafe-car" +" lst_69))" +"((rest_31)" +"(unsafe-cdr" +" lst_69)))" +"(let-values(((fold-var_55)" +"(let-values(((fold-var_56)" +" fold-var_54))" +"(let-values(((fold-var_57)" +"(let-values()" +"(cons" +"(let-values()" +"(module-path-index-unresolve" +" req-mpi_2))" +" fold-var_56))))" +"(values" +" fold-var_57)))))" +"(if(not #f)" +"(for-loop_86" +" fold-var_55" +" rest_31)" +" fold-var_55)))" +" fold-var_54)))))" +" for-loop_86)" +" null" +" lst_68))))))" +" fold-var_52))))" +"(values fold-var_53)))))" +"(if(not #f)(for-loop_85 fold-var_51 rest_30) fold-var_51)))" +" fold-var_50)))))" +" for-loop_85)" +" null" +" lst_66)))))))" +"(define-values" +"(module-compute-access!)" +"(lambda(m_10)" +"(begin" +"(let-values(((access_0)" +"(let-values(((ht_67)(module-provides m_10)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_67)))" +"((letrec-values(((for-loop_87)" +"(lambda(table_87 i_81)" +"(begin" +" 'for-loop" +"(if i_81" +"(let-values(((phase_30 at-phase_6)" +"(hash-iterate-key+value ht_67 i_81)))" +"(let-values(((table_88)" +"(let-values(((table_89) table_87))" +"(let-values(((table_90)" +"(let-values()" +"(let-values(((key_38 val_31)" +"(let-values()" +"(values" +" phase_30" +"(let-values(((ht_68)" +" at-phase_6))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_68)))" +"((letrec-values(((for-loop_88)" +"(lambda(table_91" +" i_82)" +"(begin" +" 'for-loop" +"(if i_82" +"(let-values(((sym_21" +" binding/p_1)" +"(hash-iterate-key+value" +" ht_68" +" i_82)))" +"(let-values(((table_92)" +"(let-values(((table_93)" +" table_91))" +"(let-values(((table_94)" +"(let-values()" +"(let-values(((key_39" +" val_32)" +"(let-values()" +"(values" +"(module-binding-sym" +"(provided-as-binding" +" binding/p_1))" +"(if(provided-as-protected?" +" binding/p_1)" +" 'protected" +" 'provided)))))" +"(hash-set" +" table_93" +" key_39" +" val_32)))))" +"(values" +" table_94)))))" +"(if(not" +" #f)" +"(for-loop_88" +" table_92" +"(hash-iterate-next" +" ht_68" +" i_82))" +" table_92)))" +" table_91)))))" +" for-loop_88)" +" '#hash()" +"(hash-iterate-first" +" ht_68))))))))" +"(hash-set" +" table_89" +" key_38" +" val_31)))))" +"(values table_90)))))" +"(if(not #f)" +"(for-loop_87 table_88(hash-iterate-next ht_67 i_81))" +" table_88)))" +" table_87)))))" +" for-loop_87)" +" '#hasheqv()" +"(hash-iterate-first ht_67))))))" +"(begin(set-module-access! m_10 access_0) access_0)))))" +"(define-values" +"(binding->module-instance)" +"(lambda(b_41 ns_41 phase_31 id_10)" +"(begin" +"(let-values(((at-phase_7)(phase- phase_31(module-binding-phase b_41))))" +"(let-values(((mi_11)" +"(let-values(((temp2_0)(1/module-path-index-resolve(module-binding-module b_41)))" +"((at-phase3_0) at-phase_7)" +"((temp4_0)(module-binding-phase b_41))" +"((temp5_0)(lambda(mi_12) 'unavailable)))" +"(namespace->module-instance70.1 temp4_0 #t #f #f temp5_0 #t ns_41 temp2_0 at-phase3_0))))" +"(begin" +"(if(eq? mi_11 'unavailable)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +"(format" +"(string-append" +" \"module mismatch;\\n\"" +" \" attempted to use a module that is not available\\n\"" +" \" possible cause:\\n\"" +" \" using (dynamic-require .... #f)\\n\"" +" \" but need (dynamic-require .... 0)\\n\"" +" \" module: ~s\\n\"" +" \" phase: ~s\")" +"(module-binding-module b_41)" +"(phase+ at-phase_7(module-binding-phase b_41)))" +" id_10))" +"(void))" +"(if mi_11" +"(void)" +"(let-values()" +"(error" +" 'expand" +"(string-append" +" \"namespace mismatch; cannot locate module instance\\n\"" +" \" module: ~s\\n\"" +" \" use phase: ~a\\n\"" +" \" definition phase: ~a\\n\"" +" \" for identifier: ~s\")" +"(module-binding-module b_41)" +" phase_31" +"(module-binding-phase b_41)" +" id_10)))" +" mi_11))))))" +"(define-values" +"(check-access)" +"(lambda(b_41 mi_13 id_11 in-s_0 what_0)" +"(begin" +"(let-values(((m_11)(module-instance-module mi_13)))" +"(if(if m_11(not(module-no-protected? m_11)) #f)" +"(let-values()" +"(let-values(((access_1)" +"(let-values(((or-part_27)(module-access m_11)))" +"(if or-part_27 or-part_27(module-compute-access! m_11)))))" +"(let-values(((a_35)" +"(hash-ref" +"(hash-ref access_1(module-binding-phase b_41) '#hasheq())" +"(module-binding-sym b_41)" +" 'unexported)))" +"(if(let-values(((or-part_10)(eq? a_35 'unexported)))" +"(if or-part_10 or-part_10(eq? a_35 'protected)))" +"(let-values()" +"(if(let-values(((or-part_159)" +"(inspector-superior?" +"(let-values(((or-part_12)(syntax-inspector id_11)))" +"(if or-part_12 or-part_12(current-code-inspector)))" +"(namespace-inspector(module-instance-namespace mi_13)))))" +"(if or-part_159" +" or-part_159" +"(if(module-binding-extra-inspector b_41)" +"(inspector-superior?" +"(module-binding-extra-inspector b_41)" +"(namespace-inspector(module-instance-namespace mi_13)))" +" #f)))" +"(void)" +"(let-values()" +"(let-values(((complain-id_0)" +"(let-values(((c-id_0)" +"(let-values(((or-part_3) in-s_0))" +"(if or-part_3 or-part_3(module-binding-sym b_41)))))" +"(if(not" +"(eq?" +"(if(syntax?$1 c-id_0)(syntax-content c-id_0) c-id_0)" +"(syntax-content id_11)))" +" c-id_0" +" #f))))" +"(raise-syntax-error$1" +" #f" +"(format" +" \"access disallowed by code inspector to ~a ~a\\n from module: ~a\"" +" a_35" +" what_0" +"(1/module-path-index-resolve(namespace-mpi(module-instance-namespace mi_13))))" +" complain-id_0" +" id_11" +" null)))))" +"(void)))))" +"(void))))))" +"(define-values" +"(resolve+shift/extra-inspector)" +"(lambda(id_12 phase_32 ns_42)" +"(begin" +"((letrec-values(((loop_76)" +"(lambda(id_13 in-s_1)" +"(begin" +" 'loop" +"(let-values(((b_58)" +"(let-values(((temp3_0) #t))" +"(resolve+shift30.1 #f #f #f #f #f #f temp3_0 #t #f #f id_13 phase_32))))" +"(let-values(((c1_22)(binding-free=id b_58)))" +"(if c1_22" +"((lambda(next-id_0)" +"(let-values((()" +"(begin" +"(if(if(module-binding? b_58)" +"(not" +"(top-level-module-path-index?(module-binding-module b_58)))" +" #f)" +"(let-values()" +"(let-values(((mi_14)" +"(binding->module-instance" +" b_58" +" ns_42" +" phase_32" +" id_13)))" +" (check-access b_58 mi_14 id_13 in-s_1 \"provided binding\")))" +"(void))" +"(values))))" +"(let-values(((next-b_0)" +"(loop_76" +" next-id_0" +"(let-values(((or-part_160) in-s_1))" +"(if or-part_160 or-part_160 id_13)))))" +"(if(not next-b_0)" +"(let-values() b_58)" +"(if(if(module-binding? next-b_0)" +"(if(not(module-binding-extra-inspector next-b_0))" +"(syntax-inspector id_13)" +" #f)" +" #f)" +"(let-values()" +"(let-values(((temp5_1)(syntax-inspector id_13)))" +"(module-binding-update48.1" +" temp5_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" next-b_0)))" +"(let-values() next-b_0))))))" +" c1_22)" +"(let-values() b_58))))))))" +" loop_76)" +" id_12" +" #f))))" +"(define-values" +"(1/prop:set!-transformer 1/set!-transformer? set!-transformer-value)" +"(make-struct-type-property" +" 'set!-transformer" +"(lambda(v_26 info_1)" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_11)" +"(if(procedure? v_26)" +"(let-values(((or-part_2)(procedure-arity-includes? v_26 1)))" +"(if or-part_2 or-part_2(procedure-arity-includes? v_26 2)))" +" #f)))" +"(if or-part_11 or-part_11(exact-nonnegative-integer? v_26)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:set!-transformer" +"(string-append" +" \"(or/c (procedure-arity-includes? proc 1)\\n\"" +" \" (procedure-arity-includes? proc 2)\\n\"" +" \" exact-nonnegative-integer?)\")" +" v_26)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(exact-nonnegative-integer? v_26)" +"(let-values()" +"(begin" +"(if(<= v_26(list-ref info_1 1))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:set!-transformer" +" \"field index >= initialized-field count for structure type\"" +" \"field index\"" +" v_26" +" \"initialized-field count\"" +"(list-ref info_1 1))))" +"(if(member v_26(list-ref info_1 5))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'guard-for-prop:set!-transformer" +" \"field index not declared immutable\"" +" \"field index\"" +" v_26)))))" +"(void))" +"(values))))" +"(let-values(((ref_0)(list-ref info_1 3)))" +"(if(integer? v_26)" +"(let-values()" +"(lambda(t_33)" +"(let-values(((p_30)(ref_0 t_33 v_26)))" +"(if(if(procedure? p_30)(procedure-arity-includes? p_30 1) #f)" +" p_30" +" (lambda (s_3) (error \"bad syntax:\" s_3))))))" +"(let-values()(lambda(t_13) v_26)))))))))" +"(define-values" +"(1/make-set!-transformer)" +"(let-values()" +"(let-values(((struct:set!-transformer_0 set!-transformer1_0 set!-transformer?_0 set!-transformer-proc_0)" +"(let-values(((struct:_38 make-_38 ?_38 -ref_38 -set!_38)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'set!-transformer" +" #f" +" 1" +" 0" +" #f" +"(list(cons 1/prop:set!-transformer 0))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'set!-transformer)))))" +"(values struct:_38 make-_38 ?_38(make-struct-field-accessor -ref_38 0 'proc)))))" +"(lambda(proc_3)" +"(begin" +" 'make-set!-transformer" +"(begin" +"(if(if(procedure? proc_3)(procedure-arity-includes? proc_3 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'make-set!-transformer \"(procedure-arity-includes/c 1)\" proc_3)))" +"(set!-transformer1_0 proc_3)))))))" +"(define-values" +"(1/set!-transformer-procedure)" +"(lambda(t_36)" +"(begin" +" 'set!-transformer-procedure" +"(let-values(((v_94)((set!-transformer-value t_36) t_36)))" +"(if(procedure-arity-includes? v_94 1) v_94(lambda(s_161)(v_94 t_36 s_161)))))))" +"(define-values(empty-env) '#hasheq())" +"(define-values(env-extend)(lambda(env_0 key_40 val_19)(begin(hash-set env_0 key_40 val_19))))" +"(define-values(variable)(gensym 'variable))" +"(define-values" +"(variable?)" +"(lambda(t_13)" +"(begin(let-values(((or-part_10)(eq? t_13 variable)))(if or-part_10 or-part_10(local-variable? t_13))))))" +"(define-values" +"(struct:local-variable local-variable1.1 local-variable? local-variable-id)" +"(let-values(((struct:_28 make-_28 ?_28 -ref_28 -set!_28)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'local-variable" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'local-variable)))))" +"(values struct:_28 make-_28 ?_28(make-struct-field-accessor -ref_28 0 'id))))" +"(define-values" +"(substitute-variable6.1)" +"(lambda(no-stops?2_0 id4_0 t5_0)" +"(begin" +" 'substitute-variable6" +"(let-values(((id_14) id4_0))" +"(let-values(((t_37) t5_0))" +"(let-values(((no-stops?_0) no-stops?2_0))" +"(let-values()" +"(if(if no-stops?_0(local-variable? t_37) #f)" +"(let-values(((bind-id_0)(local-variable-id t_37)))" +"(syntax-rearm$1" +"(datum->syntax$1(syntax-disarm$1 bind-id_0)(syntax-e$1 bind-id_0) id_14 id_14)" +" id_14))" +" id_14))))))))" +"(define-values(missing)(gensym 'missing))" +"(define-values" +"(transformer?)" +"(lambda(t_38)" +"(begin" +"(let-values(((or-part_21)(procedure? t_38)))" +"(if or-part_21" +" or-part_21" +"(let-values(((or-part_161)(1/set!-transformer? t_38)))" +"(if or-part_161 or-part_161(1/rename-transformer? t_38))))))))" +"(define-values" +"(transformer->procedure)" +"(lambda(t_18)" +"(begin" +"(if(1/set!-transformer? t_18)" +"(let-values()(1/set!-transformer-procedure t_18))" +"(if(1/rename-transformer? t_18)(let-values()(lambda(s_162) s_162))(let-values() t_18))))))" +"(define-values" +"(struct:core-form core-form9.1 core-form? core-form-expander core-form-name)" +"(let-values(((struct:_20 make-_20 ?_20 -ref_20 -set!_20)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'core-form" +" #f" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +" #f" +" #f" +" '(0 1)" +" #f" +" 'core-form)))))" +"(values" +" struct:_20" +" make-_20" +" ?_20" +"(make-struct-field-accessor -ref_20 0 'expander)" +"(make-struct-field-accessor -ref_20 1 'name))))" +"(define-values" +"(add-binding!17.1)" +"(lambda(in10_0 in12_0 just-for-nominal?11_0 just-for-nominal?13_0 id14_0 binding15_0 phase16_0)" +"(begin" +" 'add-binding!17" +"(let-values(((id_15) id14_0))" +"(let-values(((binding_9) binding15_0))" +"(let-values(((phase_33) phase16_0))" +"(let-values(((in-s_2)(if in12_0 in10_0 #f)))" +"(let-values(((just-for-nominal?_2)(if just-for-nominal?13_0 just-for-nominal?11_0 #f)))" +"(let-values()" +"(begin" +"(check-id-taint id_15 in-s_2)" +"(let-values(((temp53_0)(syntax-scope-set id_15 phase_33))" +"((temp54_0)(syntax-e$1 id_15))" +"((binding55_0) binding_9)" +"((just-for-nominal?56_0) just-for-nominal?_2))" +"(add-binding-in-scopes!20.1 just-for-nominal?56_0 #t temp53_0 temp54_0 binding55_0))))))))))))" +"(define-values" +"(add-bulk-binding!25.1)" +"(lambda(in20_0 in21_0 s22_0 binding23_0 phase24_0)" +"(begin" +" 'add-bulk-binding!25" +"(let-values(((s_28) s22_0))" +"(let-values(((binding_10) binding23_0))" +"(let-values(((phase_34) phase24_0))" +"(let-values(((in-s_3)(if in21_0 in20_0 #f)))" +"(let-values()" +"(begin" +"(if(syntax-tainted?$1 s_28)" +" (let-values () (raise-syntax-error$1 #f \"cannot bind from tainted syntax\" in-s_3 s_28))" +"(void))" +"(add-bulk-binding-in-scopes!(syntax-scope-set s_28 phase_34) binding_10))))))))))" +"(define-values" +"(add-local-binding!35.1)" +"(lambda(frame-id28_0 frame-id30_0 in29_0 in31_0 id32_0 phase33_0 counter34_0)" +"(begin" +" 'add-local-binding!35" +"(let-values(((id_16) id32_0))" +"(let-values(((phase_35) phase33_0))" +"(let-values(((counter_1) counter34_0))" +"(let-values(((frame-id_5)(if frame-id30_0 frame-id28_0 #f)))" +"(let-values(((in-s_4)(if in31_0 in29_0 #f)))" +"(let-values()" +"(let-values((()(begin(check-id-taint id_16 in-s_4)(values))))" +"(let-values((()(begin(set-box! counter_1(add1(unbox counter_1)))(values))))" +"(let-values(((key_41)" +" (string->uninterned-symbol (format \"~a_~a\" (syntax-e$1 id_16) (unbox counter_1)))))" +"(begin" +"(let-values(((temp57_0)(syntax-scope-set id_16 phase_35))" +"((temp58_1)(syntax-e$1 id_16))" +"((temp59_1)" +"(let-values(((frame-id61_0) frame-id_5))" +"(make-local-binding7.1 frame-id61_0 #t #f #f key_41))))" +"(add-binding-in-scopes!20.1 #f #f temp57_0 temp58_1 temp59_1))" +" key_41)))))))))))))" +"(define-values" +"(check-id-taint)" +"(lambda(id_17 in-s_5)" +"(begin" +"(if(syntax-tainted?$1 id_17)" +" (let-values () (raise-syntax-error$1 #f \"cannot bind tainted identifier\" in-s_5 id_17))" +"(void)))))" +"(define-values" +"(binding-lookup48.1)" +"(lambda(in38_0" +" in40_0" +" out-of-context-as-variable?39_0" +" out-of-context-as-variable?41_0" +" b42_0" +" env43_0" +" lift-envs44_0" +" ns45_0" +" phase46_0" +" id47_0)" +"(begin" +" 'binding-lookup48" +"(let-values(((b_59) b42_0))" +"(let-values(((env_1) env43_0))" +"(let-values(((lift-envs_0) lift-envs44_0))" +"(let-values(((ns_14) ns45_0))" +"(let-values(((phase_36) phase46_0))" +"(let-values(((id_18) id47_0))" +"(let-values(((in-s_6)(if in40_0 in38_0 #f)))" +"(let-values(((out-of-context-as-variable?_0)" +"(if out-of-context-as-variable?41_0 out-of-context-as-variable?39_0 #f)))" +"(let-values()" +"(if(module-binding? b_59)" +"(let-values()" +"(let-values(((top-level?_0)(top-level-module-path-index?(module-binding-module b_59))))" +"(let-values(((mi_15)" +"(if(not top-level?_0)" +"(binding->module-instance b_59 ns_14 phase_36 id_18)" +" #f)))" +"(let-values(((m_12)(if mi_15(module-instance-module mi_15) #f)))" +"(let-values(((primitive?_1)(if m_12(module-primitive? m_12) #f)))" +"(let-values(((m-ns_7)" +"(if top-level?_0" +" ns_14" +"(if mi_15(module-instance-namespace mi_15) #f))))" +"(let-values((()(begin(check-taint id_18)(values))))" +"(let-values(((t_39)" +"(namespace-get-transformer" +" m-ns_7" +"(module-binding-phase b_59)" +"(module-binding-sym b_59)" +" variable)))" +"(let-values((()" +"(begin" +"(if mi_15" +"(let-values()" +"(check-access" +" b_59" +" mi_15" +" id_18" +" in-s_6" +" (if (variable? t_39) \"variable\" \"transformer\")))" +"(void))" +"(values))))" +"(let-values(((insp_6)" +"(if mi_15" +"(if(module-instance-module mi_15)" +"(module-inspector(module-instance-module mi_15))" +" #f)" +" #f)))" +"(values t_39 primitive?_1 insp_6)))))))))))" +"(if(local-binding? b_59)" +"(let-values()" +"(let-values(((t_40)(hash-ref env_1(local-binding-key b_59) missing)))" +"(if(eq? t_40 missing)" +"(let-values()" +"(values" +"(let-values(((or-part_95)" +"(let-values(((lst_70) lift-envs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_70)))" +"((letrec-values(((for-loop_89)" +"(lambda(result_57 lst_32)" +"(begin" +" 'for-loop" +"(if(pair? lst_32)" +"(let-values(((lift-env_0)" +"(unsafe-car lst_32))" +"((rest_32)" +"(unsafe-cdr lst_32)))" +"(let-values(((result_58)" +"(let-values()" +"(let-values(((result_59)" +"(let-values()" +"(let-values()" +"(hash-ref" +"(unbox" +" lift-env_0)" +"(local-binding-key" +" b_59)" +" #f)))))" +"(values" +" result_59)))))" +"(if(if(not" +"((lambda x_40 result_58)" +" lift-env_0))" +"(not #f)" +" #f)" +"(for-loop_89 result_58 rest_32)" +" result_58)))" +" result_57)))))" +" for-loop_89)" +" #f" +" lst_70)))))" +"(if or-part_95" +" or-part_95" +"(if out-of-context-as-variable?_0" +" variable" +" (error \"identifier used out of context:\" id_18))))" +" #f" +" #f))" +"(let-values()(begin(check-taint id_18)(values t_40 #f #f))))))" +" (let-values () (error \"internal error: unknown binding for lookup:\" b_59))))))))))))))))" +"(define-values" +"(check-taint)" +"(lambda(id_19)" +"(begin" +"(if(syntax-tainted?$1 id_19)" +" (let-values () (raise-syntax-error$1 #f \"cannot use identifier tainted by macro transformation\" id_19))" +"(void)))))" +"(define-values(cons-ish)(lambda(a_36 b_60)(begin(if(null? b_60) a_36(cons a_36 b_60)))))" +"(define-values" +"(free-id-set)" +"(lambda(phase_37 ids_0)" +"(begin" +"(let-values(((lst_71) ids_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_71)))" +"((letrec-values(((for-loop_90)" +"(lambda(ht_69 lst_72)" +"(begin" +" 'for-loop" +"(if(pair? lst_72)" +"(let-values(((id_20)(unsafe-car lst_72))((rest_33)(unsafe-cdr lst_72)))" +"(let-values(((ht_70)" +"(let-values(((ht_71) ht_69))" +"(let-values(((ht_72)" +"(let-values()" +"(let-values(((sym_22)" +"(identifier-binding-symbol$1" +" id_20" +" phase_37)))" +"(hash-set" +" ht_71" +" sym_22" +"(cons-ish" +" id_20" +"(hash-ref ht_71 sym_22 null)))))))" +"(values ht_72)))))" +"(if(not #f)(for-loop_90 ht_70 rest_33) ht_70)))" +" ht_69)))))" +" for-loop_90)" +" '#hasheq()" +" lst_71))))))" +"(define-values(empty-free-id-set)(free-id-set 0 null))" +"(define-values(free-id-set-empty?)(lambda(fs_0)(begin(eq? fs_0 empty-free-id-set))))" +"(define-values" +"(free-id-set-member?)" +"(lambda(fs_1 phase_15 given-id_0)" +"(begin" +"(if(zero?(hash-count fs_1))" +" #f" +"(let-values(((lst_73)(hash-ref fs_1(identifier-binding-symbol$1 given-id_0 phase_15) null)))" +"(begin" +"(void)" +"((letrec-values(((for-loop_91)" +"(lambda(result_3 lst_74)" +"(begin" +" 'for-loop" +"(if(not(null? lst_74))" +"(let-values(((id_21)(if(pair? lst_74)(car lst_74) lst_74))" +"((rest_34)(if(pair? lst_74)(cdr lst_74) null)))" +"(let-values(((result_60)" +"(let-values()" +"(let-values(((result_61)" +"(let-values()" +"(let-values()" +"(free-identifier=?$1" +" id_21" +" given-id_0" +" phase_15" +" phase_15)))))" +"(values result_61)))))" +"(if(if(not((lambda x_41 result_60) id_21))(not #f) #f)" +"(for-loop_91 result_60 rest_34)" +" result_60)))" +" result_3)))))" +" for-loop_91)" +" #f" +" lst_73)))))))" +"(define-values" +"(free-id-set-empty-or-just-module*?)" +"(lambda(fs_2)(begin(let-values(((c_17)(hash-count fs_2)))(<= c_17 1)))))" +"(define-values" +"(struct:expand-context/outer" +" expand-context/outer1.1" +" expand-context/outer?" +" expand-context/outer-context" +" expand-context/outer-env" +" expand-context/outer-post-expansion-scope-action" +" expand-context/outer-scopes" +" expand-context/outer-def-ctx-scopes" +" expand-context/outer-binding-layer" +" expand-context/outer-reference-records" +" expand-context/outer-only-immediate?" +" expand-context/outer-need-eventually-defined" +" expand-context/outer-current-introduction-scopes" +" expand-context/outer-name)" +"(let-values(((struct:_39 make-_39 ?_39 -ref_39 -set!_39)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expand-context" +" struct:root-expand-context/outer" +" 11" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10)" +" #f" +" 'expand-context/outer)))))" +"(values" +" struct:_39" +" make-_39" +" ?_39" +"(make-struct-field-accessor -ref_39 0 'context)" +"(make-struct-field-accessor -ref_39 1 'env)" +"(make-struct-field-accessor -ref_39 2 'post-expansion-scope-action)" +"(make-struct-field-accessor -ref_39 3 'scopes)" +"(make-struct-field-accessor -ref_39 4 'def-ctx-scopes)" +"(make-struct-field-accessor -ref_39 5 'binding-layer)" +"(make-struct-field-accessor -ref_39 6 'reference-records)" +"(make-struct-field-accessor -ref_39 7 'only-immediate?)" +"(make-struct-field-accessor -ref_39 8 'need-eventually-defined)" +"(make-struct-field-accessor -ref_39 9 'current-introduction-scopes)" +"(make-struct-field-accessor -ref_39 10 'name))))" +"(define-values" +"(struct:expand-context/inner" +" expand-context/inner2.1" +" expand-context/inner?" +" expand-context/inner-to-parsed?" +" expand-context/inner-phase" +" expand-context/inner-namespace" +" expand-context/inner-just-once?" +" expand-context/inner-module-begin-k" +" expand-context/inner-allow-unbound?" +" expand-context/inner-in-local-expand?" +" expand-context/inner-stops" +" expand-context/inner-declared-submodule-names" +" expand-context/inner-lifts" +" expand-context/inner-lift-envs" +" expand-context/inner-module-lifts" +" expand-context/inner-require-lifts" +" expand-context/inner-to-module-lifts" +" expand-context/inner-requires+provides" +" expand-context/inner-observer" +" expand-context/inner-for-serializable?" +" expand-context/inner-should-not-encounter-macros?)" +"(let-values(((struct:_40 make-_40 ?_40 -ref_40 -set!_40)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expand-context/inner" +" struct:root-expand-context/inner" +" 18" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)" +" #f" +" 'expand-context/inner)))))" +"(values" +" struct:_40" +" make-_40" +" ?_40" +"(make-struct-field-accessor -ref_40 0 'to-parsed?)" +"(make-struct-field-accessor -ref_40 1 'phase)" +"(make-struct-field-accessor -ref_40 2 'namespace)" +"(make-struct-field-accessor -ref_40 3 'just-once?)" +"(make-struct-field-accessor -ref_40 4 'module-begin-k)" +"(make-struct-field-accessor -ref_40 5 'allow-unbound?)" +"(make-struct-field-accessor -ref_40 6 'in-local-expand?)" +"(make-struct-field-accessor -ref_40 7 'stops)" +"(make-struct-field-accessor -ref_40 8 'declared-submodule-names)" +"(make-struct-field-accessor -ref_40 9 'lifts)" +"(make-struct-field-accessor -ref_40 10 'lift-envs)" +"(make-struct-field-accessor -ref_40 11 'module-lifts)" +"(make-struct-field-accessor -ref_40 12 'require-lifts)" +"(make-struct-field-accessor -ref_40 13 'to-module-lifts)" +"(make-struct-field-accessor -ref_40 14 'requires+provides)" +"(make-struct-field-accessor -ref_40 15 'observer)" +"(make-struct-field-accessor -ref_40 16 'for-serializable?)" +"(make-struct-field-accessor -ref_40 17 'should-not-encounter-macros?))))" +"(define-values" +"(expand-context/make)" +"(lambda(module-scopes_2" +" post-expansion-scope_2" +" top-level-bind-scope_1" +" all-scopes-stx_2" +" use-site-scopes_1" +" defined-syms_1" +" frame-id_6" +" counter_2" +" lift-key_1" +" to-parsed?_0" +" context_0" +" phase_38" +" namespace_0" +" env_2" +" post-expansion-scope-action_0" +" scopes_18" +" def-ctx-scopes_0" +" binding-layer_0" +" reference-records_0" +" only-immediate?_0" +" just-once?_0" +" module-begin-k_0" +" need-eventually-defined_0" +" allow-unbound?_0" +" in-local-expand?_0" +" stops_0" +" current-introduction-scopes_0" +" declared-submodule-names_0" +" lifts_0" +" lift-envs_1" +" module-lifts_0" +" require-lifts_0" +" to-module-lifts_0" +" requires+provides_0" +" name_35" +" observer_0" +" for-serializable?_0" +" should-not-encounter-macros?_0)" +"(begin" +"(expand-context/outer1.1" +"(expand-context/inner2.1" +" module-scopes_2" +" top-level-bind-scope_1" +" all-scopes-stx_2" +" defined-syms_1" +" counter_2" +" lift-key_1" +" to-parsed?_0" +" phase_38" +" namespace_0" +" just-once?_0" +" module-begin-k_0" +" allow-unbound?_0" +" in-local-expand?_0" +" stops_0" +" declared-submodule-names_0" +" lifts_0" +" lift-envs_1" +" module-lifts_0" +" require-lifts_0" +" to-module-lifts_0" +" requires+provides_0" +" observer_0" +" for-serializable?_0" +" should-not-encounter-macros?_0)" +" post-expansion-scope_2" +" use-site-scopes_1" +" frame-id_6" +" context_0" +" env_2" +" post-expansion-scope-action_0" +" scopes_18" +" def-ctx-scopes_0" +" binding-layer_0" +" reference-records_0" +" only-immediate?_0" +" need-eventually-defined_0" +" current-introduction-scopes_0" +" name_35))))" +"(define-values(expand-context-context)(lambda(v_95)(begin(expand-context/outer-context v_95))))" +"(define-values(expand-context-env)(lambda(v_96)(begin(expand-context/outer-env v_96))))" +"(define-values" +"(expand-context-post-expansion-scope-action)" +"(lambda(v_97)(begin(expand-context/outer-post-expansion-scope-action v_97))))" +"(define-values(expand-context-scopes)(lambda(v_98)(begin(expand-context/outer-scopes v_98))))" +"(define-values(expand-context-def-ctx-scopes)(lambda(v_99)(begin(expand-context/outer-def-ctx-scopes v_99))))" +"(define-values(expand-context-binding-layer)(lambda(v_100)(begin(expand-context/outer-binding-layer v_100))))" +"(define-values" +"(expand-context-reference-records)" +"(lambda(v_101)(begin(expand-context/outer-reference-records v_101))))" +"(define-values(expand-context-only-immediate?)(lambda(v_102)(begin(expand-context/outer-only-immediate? v_102))))" +"(define-values" +"(expand-context-need-eventually-defined)" +"(lambda(v_103)(begin(expand-context/outer-need-eventually-defined v_103))))" +"(define-values" +"(expand-context-current-introduction-scopes)" +"(lambda(v_104)(begin(expand-context/outer-current-introduction-scopes v_104))))" +"(define-values(expand-context-name)(lambda(v_105)(begin(expand-context/outer-name v_105))))" +"(define-values" +"(expand-context-to-parsed?)" +"(lambda(v_106)(begin(expand-context/inner-to-parsed?(root-expand-context/outer-inner v_106)))))" +"(define-values" +"(expand-context-phase)" +"(lambda(v_107)(begin(expand-context/inner-phase(root-expand-context/outer-inner v_107)))))" +"(define-values" +"(expand-context-namespace)" +"(lambda(v_108)(begin(expand-context/inner-namespace(root-expand-context/outer-inner v_108)))))" +"(define-values" +"(expand-context-just-once?)" +"(lambda(v_109)(begin(expand-context/inner-just-once?(root-expand-context/outer-inner v_109)))))" +"(define-values" +"(expand-context-module-begin-k)" +"(lambda(v_110)(begin(expand-context/inner-module-begin-k(root-expand-context/outer-inner v_110)))))" +"(define-values" +"(expand-context-allow-unbound?)" +"(lambda(v_111)(begin(expand-context/inner-allow-unbound?(root-expand-context/outer-inner v_111)))))" +"(define-values" +"(expand-context-in-local-expand?)" +"(lambda(v_112)(begin(expand-context/inner-in-local-expand?(root-expand-context/outer-inner v_112)))))" +"(define-values" +"(expand-context-stops)" +"(lambda(v_113)(begin(expand-context/inner-stops(root-expand-context/outer-inner v_113)))))" +"(define-values" +"(expand-context-declared-submodule-names)" +"(lambda(v_114)(begin(expand-context/inner-declared-submodule-names(root-expand-context/outer-inner v_114)))))" +"(define-values" +"(expand-context-lifts)" +"(lambda(v_115)(begin(expand-context/inner-lifts(root-expand-context/outer-inner v_115)))))" +"(define-values" +"(expand-context-lift-envs)" +"(lambda(v_116)(begin(expand-context/inner-lift-envs(root-expand-context/outer-inner v_116)))))" +"(define-values" +"(expand-context-module-lifts)" +"(lambda(v_117)(begin(expand-context/inner-module-lifts(root-expand-context/outer-inner v_117)))))" +"(define-values" +"(expand-context-require-lifts)" +"(lambda(v_118)(begin(expand-context/inner-require-lifts(root-expand-context/outer-inner v_118)))))" +"(define-values" +"(expand-context-to-module-lifts)" +"(lambda(v_119)(begin(expand-context/inner-to-module-lifts(root-expand-context/outer-inner v_119)))))" +"(define-values" +"(expand-context-requires+provides)" +"(lambda(v_120)(begin(expand-context/inner-requires+provides(root-expand-context/outer-inner v_120)))))" +"(define-values" +"(expand-context-observer)" +"(lambda(v_121)(begin(expand-context/inner-observer(root-expand-context/outer-inner v_121)))))" +"(define-values" +"(expand-context-for-serializable?)" +"(lambda(v_122)(begin(expand-context/inner-for-serializable?(root-expand-context/outer-inner v_122)))))" +"(define-values" +"(expand-context-should-not-encounter-macros?)" +"(lambda(v_123)(begin(expand-context/inner-should-not-encounter-macros?(root-expand-context/outer-inner v_123)))))" +"(define-values" +"(make-expand-context10.1)" +"(lambda(for-serializable?4_0 for-serializable?7_0 observable?5_0 observable?8_0 to-parsed?3_0 to-parsed?6_0 ns9_0)" +"(begin" +" 'make-expand-context10" +"(let-values(((ns_43) ns9_0))" +"(let-values(((to-parsed?_1)(if to-parsed?6_0 to-parsed?3_0 #f)))" +"(let-values(((for-serializable?_1)(if for-serializable?7_0 for-serializable?4_0 #f)))" +"(let-values(((observable?_0)(if observable?8_0 observable?5_0 #f)))" +"(let-values()" +"(let-values(((root-ctx_1)(namespace-get-root-expand-ctx ns_43)))" +"(expand-context/make" +"(root-expand-context-module-scopes root-ctx_1)" +"(root-expand-context-post-expansion-scope root-ctx_1)" +"(root-expand-context-top-level-bind-scope root-ctx_1)" +"(root-expand-context-all-scopes-stx root-ctx_1)" +"(root-expand-context-use-site-scopes root-ctx_1)" +"(root-expand-context-defined-syms root-ctx_1)" +"(root-expand-context-frame-id root-ctx_1)" +"(root-expand-context-counter root-ctx_1)" +"(root-expand-context-lift-key root-ctx_1)" +" to-parsed?_1" +" 'top-level" +"(namespace-phase ns_43)" +" ns_43" +" empty-env" +" push-scope" +" null" +" #f" +"(root-expand-context-frame-id root-ctx_1)" +" null" +" #f" +" #f" +" #f" +" #f" +" #t" +" #f" +" empty-free-id-set" +" null" +" '#hasheq()" +" #f" +" '()" +" #f" +" #f" +" #f" +" #f" +" #f" +"(if observable?_0(current-expand-observe) #f)" +" for-serializable?_1" +" #f))))))))))" +"(define-values" +"(copy-root-expand-context)" +"(lambda(ctx_1 root-ctx_2)" +"(begin" +"(let-values(((v_124) ctx_1))" +"(let-values(((the-struct_41) v_124))" +"(if(expand-context/outer? the-struct_41)" +"(let-values(((post-expansion-scope28_0)(root-expand-context-post-expansion-scope root-ctx_2))" +"((use-site-scopes29_0)(root-expand-context-use-site-scopes root-ctx_2))" +"((frame-id30_1)(root-expand-context-frame-id root-ctx_2))" +"((binding-layer31_0)(root-expand-context-frame-id root-ctx_2))" +"((inner32_0)" +"(let-values(((the-struct_42)(root-expand-context/outer-inner v_124)))" +"(if(expand-context/inner? the-struct_42)" +"(let-values(((module-scopes33_0)(root-expand-context-module-scopes root-ctx_2))" +"((top-level-bind-scope34_0)" +"(root-expand-context-top-level-bind-scope root-ctx_2))" +"((all-scopes-stx35_0)(root-expand-context-all-scopes-stx root-ctx_2))" +"((defined-syms36_0)(root-expand-context-defined-syms root-ctx_2))" +"((counter37_0)(root-expand-context-counter root-ctx_2))" +"((lift-key38_0)(root-expand-context-lift-key root-ctx_2)))" +"(expand-context/inner2.1" +" module-scopes33_0" +" top-level-bind-scope34_0" +" all-scopes-stx35_0" +" defined-syms36_0" +" counter37_0" +" lift-key38_0" +"(expand-context/inner-to-parsed? the-struct_42)" +"(expand-context/inner-phase the-struct_42)" +"(expand-context/inner-namespace the-struct_42)" +"(expand-context/inner-just-once? the-struct_42)" +"(expand-context/inner-module-begin-k the-struct_42)" +"(expand-context/inner-allow-unbound? the-struct_42)" +"(expand-context/inner-in-local-expand? the-struct_42)" +"(expand-context/inner-stops the-struct_42)" +"(expand-context/inner-declared-submodule-names the-struct_42)" +"(expand-context/inner-lifts the-struct_42)" +"(expand-context/inner-lift-envs the-struct_42)" +"(expand-context/inner-module-lifts the-struct_42)" +"(expand-context/inner-require-lifts the-struct_42)" +"(expand-context/inner-to-module-lifts the-struct_42)" +"(expand-context/inner-requires+provides the-struct_42)" +"(expand-context/inner-observer the-struct_42)" +"(expand-context/inner-for-serializable? the-struct_42)" +"(expand-context/inner-should-not-encounter-macros? the-struct_42)))" +" (raise-argument-error 'struct-copy \"expand-context/inner?\" the-struct_42)))))" +"(expand-context/outer1.1" +" inner32_0" +" post-expansion-scope28_0" +" use-site-scopes29_0" +" frame-id30_1" +"(expand-context/outer-context the-struct_41)" +"(expand-context/outer-env the-struct_41)" +"(expand-context/outer-post-expansion-scope-action the-struct_41)" +"(expand-context/outer-scopes the-struct_41)" +"(expand-context/outer-def-ctx-scopes the-struct_41)" +" binding-layer31_0" +"(expand-context/outer-reference-records the-struct_41)" +"(expand-context/outer-only-immediate? the-struct_41)" +"(expand-context/outer-need-eventually-defined the-struct_41)" +"(expand-context/outer-current-introduction-scopes the-struct_41)" +"(expand-context/outer-name the-struct_41)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_41)))))))" +"(define-values(current-expand-context)(make-parameter #f))" +"(define-values" +"(get-current-expand-context17.1)" +"(lambda(fail-ok?13_0 fail-ok?14_0 who15_0 who16_0)" +"(begin" +" 'get-current-expand-context17" +"(let-values(((who_9)(if who16_0 who15_0 'unexpected)))" +"(let-values(((fail-ok?_0)(if fail-ok?14_0 fail-ok?13_0 #f)))" +"(let-values()" +"(let-values(((or-part_162)(force(current-expand-context))))" +"(if or-part_162" +" or-part_162" +" (if fail-ok?_0 #f (raise-arguments-error who_9 \"not currently expanding\"))))))))))" +"(define-values" +"(current-expand-observe)" +"(make-parameter" +" #f" +"(lambda(v_125)" +"(begin" +"(if(let-values(((or-part_163)(not v_125)))" +"(if or-part_163 or-part_163(if(procedure? v_125)(procedure-arity-includes? v_125 2) #f)))" +"(void)" +"(let-values()" +" (raise-argument-error 'current-expand-observe \"(or/c (procedure-arity-includes/c 2) #f)\" v_125)))" +" v_125))))" +"(define-values" +"(as-expression-context)" +"(lambda(ctx_2)" +"(begin" +"(if(if(eq? 'expression(expand-context-context ctx_2))(not(expand-context-name ctx_2)) #f)" +"(let-values() ctx_2)" +"(let-values()" +"(let-values(((v_126) ctx_2))" +"(let-values(((the-struct_43) v_126))" +"(if(expand-context/outer? the-struct_43)" +"(let-values(((context39_0) 'expression)" +"((name40_0) #f)" +"((post-expansion-scope41_0) #f)" +"((inner42_0)(root-expand-context/outer-inner v_126)))" +"(expand-context/outer1.1" +" inner42_0" +" post-expansion-scope41_0" +"(root-expand-context/outer-use-site-scopes the-struct_43)" +"(root-expand-context/outer-frame-id the-struct_43)" +" context39_0" +"(expand-context/outer-env the-struct_43)" +"(expand-context/outer-post-expansion-scope-action the-struct_43)" +"(expand-context/outer-scopes the-struct_43)" +"(expand-context/outer-def-ctx-scopes the-struct_43)" +"(expand-context/outer-binding-layer the-struct_43)" +"(expand-context/outer-reference-records the-struct_43)" +"(expand-context/outer-only-immediate? the-struct_43)" +"(expand-context/outer-need-eventually-defined the-struct_43)" +"(expand-context/outer-current-introduction-scopes the-struct_43)" +" name40_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_43)))))))))" +"(define-values" +"(as-begin-expression-context)" +"(lambda(ctx_3)" +"(begin" +"(if(not(expand-context-name ctx_3))" +"(let-values() ctx_3)" +"(let-values()" +"(let-values(((v_127) ctx_3))" +"(let-values(((the-struct_44) v_127))" +"(if(expand-context/outer? the-struct_44)" +"(let-values(((name43_0) #f)((inner44_0)(root-expand-context/outer-inner v_127)))" +"(expand-context/outer1.1" +" inner44_0" +"(root-expand-context/outer-post-expansion-scope the-struct_44)" +"(root-expand-context/outer-use-site-scopes the-struct_44)" +"(root-expand-context/outer-frame-id the-struct_44)" +"(expand-context/outer-context the-struct_44)" +"(expand-context/outer-env the-struct_44)" +"(expand-context/outer-post-expansion-scope-action the-struct_44)" +"(expand-context/outer-scopes the-struct_44)" +"(expand-context/outer-def-ctx-scopes the-struct_44)" +"(expand-context/outer-binding-layer the-struct_44)" +"(expand-context/outer-reference-records the-struct_44)" +"(expand-context/outer-only-immediate? the-struct_44)" +"(expand-context/outer-need-eventually-defined the-struct_44)" +"(expand-context/outer-current-introduction-scopes the-struct_44)" +" name43_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_44)))))))))" +"(define-values" +"(as-tail-context23.1)" +"(lambda(wrt20_0 ctx22_0)" +"(begin" +" 'as-tail-context23" +"(let-values(((ctx_4) ctx22_0))" +"(let-values(((wrt-ctx_0) wrt20_0))" +"(let-values()" +"(if(expand-context-name wrt-ctx_0)" +"(let-values()" +"(let-values(((v_128) ctx_4))" +"(let-values(((the-struct_45) v_128))" +"(if(expand-context/outer? the-struct_45)" +"(let-values(((name45_0)(expand-context-name wrt-ctx_0))" +"((inner46_0)(root-expand-context/outer-inner v_128)))" +"(expand-context/outer1.1" +" inner46_0" +"(root-expand-context/outer-post-expansion-scope the-struct_45)" +"(root-expand-context/outer-use-site-scopes the-struct_45)" +"(root-expand-context/outer-frame-id the-struct_45)" +"(expand-context/outer-context the-struct_45)" +"(expand-context/outer-env the-struct_45)" +"(expand-context/outer-post-expansion-scope-action the-struct_45)" +"(expand-context/outer-scopes the-struct_45)" +"(expand-context/outer-def-ctx-scopes the-struct_45)" +"(expand-context/outer-binding-layer the-struct_45)" +"(expand-context/outer-reference-records the-struct_45)" +"(expand-context/outer-only-immediate? the-struct_45)" +"(expand-context/outer-need-eventually-defined the-struct_45)" +"(expand-context/outer-current-introduction-scopes the-struct_45)" +" name45_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_45)))))" +"(let-values() ctx_4))))))))" +"(define-values" +"(as-named-context)" +"(lambda(ctx_5 ids_1)" +"(begin" +"(if(if(pair? ids_1)(null?(cdr ids_1)) #f)" +"(let-values()" +"(let-values(((v_129) ctx_5))" +"(let-values(((the-struct_46) v_129))" +"(if(expand-context/outer? the-struct_46)" +"(let-values(((name47_0)(car ids_1))((inner48_0)(root-expand-context/outer-inner v_129)))" +"(expand-context/outer1.1" +" inner48_0" +"(root-expand-context/outer-post-expansion-scope the-struct_46)" +"(root-expand-context/outer-use-site-scopes the-struct_46)" +"(root-expand-context/outer-frame-id the-struct_46)" +"(expand-context/outer-context the-struct_46)" +"(expand-context/outer-env the-struct_46)" +"(expand-context/outer-post-expansion-scope-action the-struct_46)" +"(expand-context/outer-scopes the-struct_46)" +"(expand-context/outer-def-ctx-scopes the-struct_46)" +"(expand-context/outer-binding-layer the-struct_46)" +"(expand-context/outer-reference-records the-struct_46)" +"(expand-context/outer-only-immediate? the-struct_46)" +"(expand-context/outer-need-eventually-defined the-struct_46)" +"(expand-context/outer-current-introduction-scopes the-struct_46)" +" name47_0))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_46)))))" +"(let-values() ctx_5)))))" +"(define-values" +"(as-to-parsed-context)" +"(lambda(ctx_6)" +"(begin" +"(let-values(((v_130) ctx_6))" +"(let-values(((the-struct_47) v_130))" +"(if(expand-context/outer? the-struct_47)" +"(let-values(((inner49_0)" +"(let-values(((the-struct_48)(root-expand-context/outer-inner v_130)))" +"(if(expand-context/inner? the-struct_48)" +"(let-values(((to-parsed?50_0) #t)" +"((observer51_0) #f)" +"((should-not-encounter-macros?52_0) #t))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes the-struct_48)" +"(root-expand-context/inner-top-level-bind-scope the-struct_48)" +"(root-expand-context/inner-all-scopes-stx the-struct_48)" +"(root-expand-context/inner-defined-syms the-struct_48)" +"(root-expand-context/inner-counter the-struct_48)" +"(root-expand-context/inner-lift-key the-struct_48)" +" to-parsed?50_0" +"(expand-context/inner-phase the-struct_48)" +"(expand-context/inner-namespace the-struct_48)" +"(expand-context/inner-just-once? the-struct_48)" +"(expand-context/inner-module-begin-k the-struct_48)" +"(expand-context/inner-allow-unbound? the-struct_48)" +"(expand-context/inner-in-local-expand? the-struct_48)" +"(expand-context/inner-stops the-struct_48)" +"(expand-context/inner-declared-submodule-names the-struct_48)" +"(expand-context/inner-lifts the-struct_48)" +"(expand-context/inner-lift-envs the-struct_48)" +"(expand-context/inner-module-lifts the-struct_48)" +"(expand-context/inner-require-lifts the-struct_48)" +"(expand-context/inner-to-module-lifts the-struct_48)" +"(expand-context/inner-requires+provides the-struct_48)" +" observer51_0" +"(expand-context/inner-for-serializable? the-struct_48)" +" should-not-encounter-macros?52_0))" +" (raise-argument-error 'struct-copy \"expand-context/inner?\" the-struct_48)))))" +"(expand-context/outer1.1" +" inner49_0" +"(root-expand-context/outer-post-expansion-scope the-struct_47)" +"(root-expand-context/outer-use-site-scopes the-struct_47)" +"(root-expand-context/outer-frame-id the-struct_47)" +"(expand-context/outer-context the-struct_47)" +"(expand-context/outer-env the-struct_47)" +"(expand-context/outer-post-expansion-scope-action the-struct_47)" +"(expand-context/outer-scopes the-struct_47)" +"(expand-context/outer-def-ctx-scopes the-struct_47)" +"(expand-context/outer-binding-layer the-struct_47)" +"(expand-context/outer-reference-records the-struct_47)" +"(expand-context/outer-only-immediate? the-struct_47)" +"(expand-context/outer-need-eventually-defined the-struct_47)" +"(expand-context/outer-current-introduction-scopes the-struct_47)" +"(expand-context/outer-name the-struct_47)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_47)))))))" +"(define-values" +"(to-syntax-list.1)" +"(lambda(s_102)" +"(begin" +" 'to-syntax-list" +"(if(list? s_102)" +"(let-values() s_102)" +"(if(pair? s_102)" +"(let-values()(let-values(((r_28)(to-syntax-list.1(cdr s_102))))(if r_28(cons(car s_102) r_28) #f)))" +"(if(syntax?$1 s_102)(let-values()(to-syntax-list.1(syntax-e$1 s_102)))(let-values() #f)))))))" +"(define-values(core-scope)(new-multi-scope))" +"(define-values(core-stx)(add-scope empty-syntax core-scope))" +"(define-values(core-module-name)(1/make-resolved-module-path '#%core))" +"(define-values(core-mpi)(1/module-path-index-join ''#%core #f))" +"(define-values(id-cache-0)(make-hasheq))" +"(define-values(id-cache-1)(make-hasheq))" +"(define-values" +"(core-id)" +"(lambda(sym_8 phase_32)" +"(begin" +"(if(eqv? phase_32 0)" +"(let-values()" +"(let-values(((or-part_6)(hash-ref id-cache-0 sym_8 #f)))" +"(if or-part_6" +" or-part_6" +"(let-values(((s_147)(datum->syntax$1 core-stx sym_8)))" +"(begin(hash-set! id-cache-0 sym_8 s_147) s_147)))))" +"(if(eq? phase_32 1)" +"(let-values()" +"(let-values(((or-part_28)(hash-ref id-cache-1 sym_8 #f)))" +"(if or-part_28" +" or-part_28" +"(let-values(((s_10)(datum->syntax$1(syntax-shift-phase-level$1 core-stx 1) sym_8)))" +"(begin(hash-set! id-cache-1 sym_8 s_10) s_10)))))" +"(let-values()(datum->syntax$1(syntax-shift-phase-level$1 core-stx phase_32) sym_8)))))))" +"(define-values(core-forms) '#hasheq())" +"(define-values(core-primitives) '#hasheq())" +"(define-values" +"(add-core-form!*)" +"(lambda(sym_23 proc_4)" +"(begin(begin(add-core-binding! sym_23)(set! core-forms(hash-set core-forms sym_23 proc_4))))))" +"(define-values" +"(add-core-primitive!)" +"(lambda(sym_13 val_33)" +"(begin(begin(add-core-binding! sym_13)(set! core-primitives(hash-set core-primitives sym_13 val_33))))))" +"(define-values" +"(add-core-binding!)" +"(lambda(sym_24)" +"(begin" +"(let-values(((temp1_0)(datum->syntax$1 core-stx sym_24))" +"((temp2_1)" +"(let-values(((core-mpi4_0) core-mpi)((temp5_2) 0)((sym6_0) sym_24))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" core-mpi4_0" +" temp5_2" +" sym6_0)))" +"((temp3_1) 0))" +"(add-binding!17.1 #f #f #f #f temp1_0 temp2_1 temp3_1)))))" +"(define-values" +"(declare-core-module!)" +"(lambda(ns_44)" +"(begin" +"(let-values(((ns7_0) ns_44)" +"((temp8_0)" +"(let-values(((temp10_0) #t)" +"((temp11_0) #t)" +"((temp12_0) #t)" +"((core-mpi13_0) core-mpi)" +"((temp14_1)" +"(hasheqv" +" 0" +"(let-values(((lst_75)(list core-primitives core-forms))((lst_76) '(#f #t)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_75)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_76)))" +"((letrec-values(((for-loop_92)" +"(lambda(table_95 lst_77 lst_78)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_77)(pair? lst_78) #f)" +"(let-values(((syms_12)(unsafe-car lst_77))" +"((rest_35)(unsafe-cdr lst_77))" +"((syntax?_2)(unsafe-car lst_78))" +"((rest_36)(unsafe-cdr lst_78)))" +"(let-values(((table_96)" +"(let-values(((table_97) table_95))" +"(let-values(((ht_73) syms_12))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-keys ht_73)))" +"((letrec-values(((for-loop_93)" +"(lambda(table_98" +" i_83)" +"(begin" +" 'for-loop" +"(if i_83" +"(let-values(((sym_10)" +"(hash-iterate-key" +" ht_73" +" i_83)))" +"(let-values(((table_99)" +"(let-values(((table_100)" +" table_98))" +"(let-values(((table_101)" +"(let-values()" +"(let-values(((key_33" +" val_34)" +"(let-values()" +"(let-values(((b_61)" +"(let-values(((core-mpi17_0)" +" core-mpi)" +"((temp18_2)" +" 0)" +"((sym19_0)" +" sym_10))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" core-mpi17_0" +" temp18_2" +" sym19_0))))" +"(values" +" sym_10" +"(if syntax?_2" +"(provided1.1" +" b_61" +" #f" +" #t)" +" b_61))))))" +"(hash-set" +" table_100" +" key_33" +" val_34)))))" +"(values" +" table_101)))))" +"(if(not" +" #f)" +"(for-loop_93" +" table_99" +"(hash-iterate-next" +" ht_73" +" i_83))" +" table_99)))" +" table_98)))))" +" for-loop_93)" +" table_97" +"(hash-iterate-first ht_73)))))))" +"(if(not #f)" +"(for-loop_92 table_96 rest_35 rest_36)" +" table_96)))" +" table_95)))))" +" for-loop_92)" +" '#hasheq()" +" lst_75" +" lst_76)))))" +"((temp15_1)" +"(lambda(phase-level_13 ns_45 insp_7)" +"(if(zero? phase-level_13)" +"(let-values(((ns_46)" +"(let-values(((ns20_0) ns_45)" +"((core-module-name21_0) core-module-name)" +"((temp22_1) 0))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns20_0" +" core-module-name21_0" +" temp22_1))))" +"(if ns_46" +"(module-linklet-info2.1(namespace->instance ns_46 0) #f core-mpi #f #f #f)" +" #f))" +" #f)))" +"((temp16_2)" +"(lambda(data-box_1" +" ns_47" +" phase_39" +" phase-level_14" +" self_4" +" bulk-binding-registry_4" +" insp_8)" +"(let-values(((tmp_14) phase-level_14))" +"(if(equal? tmp_14 0)" +"(let-values()" +"(begin" +"(let-values(((ht_74) core-primitives))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_74)))" +"((letrec-values(((for-loop_94)" +"(lambda(i_84)" +"(begin" +" 'for-loop" +"(if i_84" +"(let-values(((sym_25 val_35)" +"(hash-iterate-key+value" +" ht_74" +" i_84)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-consistent!" +" ns_47" +" 0" +" sym_25" +" val_35))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_94" +"(hash-iterate-next ht_74 i_84))" +"(values))))" +"(values))))))" +" for-loop_94)" +"(hash-iterate-first ht_74))))" +"(void)" +"(let-values(((ht_75) core-forms))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_75)))" +"((letrec-values(((for-loop_53)" +"(lambda(i_27)" +"(begin" +" 'for-loop" +"(if i_27" +"(let-values(((sym_26 proc_5)" +"(hash-iterate-key+value" +" ht_75" +" i_27)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-transformer!" +" ns_47" +" 0" +" sym_26" +"(core-form9.1" +" proc_5" +" sym_26)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_53" +"(hash-iterate-next ht_75 i_27))" +"(values))))" +"(values))))))" +" for-loop_53)" +"(hash-iterate-first ht_75))))" +"(void)))" +"(let-values()(void)))))))" +"(make-module39.1" +" temp10_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp16_2" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp11_0" +" #t" +" temp15_1" +" #t" +" temp12_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp14_1" +" #f" +" #f" +" core-mpi13_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f)))" +"((core-module-name9_0) core-module-name))" +"(declare-module!58.1 #f #f ns7_0 temp8_0 core-module-name9_0)))))" +"(define-values" +"(core-form-sym)" +"(lambda(s_22 phase_33)" +"(begin" +"(let-values(((ok?_0 id23_0 _24_0)" +"(let-values(((s_163) s_22))" +"(if(let-values(((s_164)(if(syntax?$1 s_163)(syntax-e$1 s_163) s_163)))" +"(if(pair? s_164)" +"(if(let-values(((s_68)(car s_164)))" +"(let-values(((or-part_137)(if(syntax?$1 s_68)(symbol?(syntax-e$1 s_68)) #f)))" +"(if or-part_137 or-part_137(symbol? s_68))))" +"(let-values(((s_165)(cdr s_164))) #t)" +" #f)" +" #f))" +"(let-values()" +"(let-values(((id23_1 _24_1)" +"(let-values(((s_166)(if(syntax?$1 s_163)(syntax-e$1 s_163) s_163)))" +"(let-values(((id25_0)(let-values(((s_167)(car s_166))) s_167))" +"((_26_0)(let-values(((s_168)(cdr s_166))) s_168)))" +"(values id25_0 _26_0)))))" +"(values #t id23_1 _24_1)))" +"(values #f #f #f)))))" +"(if ok?_0" +"(let-values(((b_62)" +"(let-values(((temp27_1) id23_0)((phase28_0) phase_33))" +"(resolve+shift30.1 #f #f #f #f #f #f #f #f #f #f temp27_1 phase28_0))))" +"(if(module-binding? b_62)" +"(if(eq? core-module-name(1/module-path-index-resolve(module-binding-module b_62)))" +"(module-binding-sym b_62)" +" #f)" +" #f))" +" #f)))))" +"(define-values" +"(taint-dispatch)" +"(lambda(s_0 proc_6 phase_31)" +"(begin" +"((letrec-values(((loop_33)" +"(lambda(s_169 mode_10)" +"(begin" +" 'loop" +"(let-values(((tmp_4) mode_10))" +"(if(equal? tmp_4 'none)" +"(let-values() s_169)" +"(if(equal? tmp_4 'opaque)" +"(let-values()(proc_6 s_169))" +"(if(equal? tmp_4 'transparent)" +"(let-values()" +"(let-values(((c_18)" +"(let-values(((s_170)" +"(let-values(((or-part_13)(syntax->list$1 s_169)))" +"(if or-part_13 or-part_13(syntax-e$1 s_169))))" +"((f_35)(lambda(tail?_39 d_18)(begin 'f d_18)))" +"((s->_3)" +"(lambda(s_171)" +"(begin" +" 's->" +"(loop_33" +" s_171" +"(syntax-taint-mode-property s_171)))))" +"((seen_19) #f))" +"(let-values(((s_146) s_170)" +"((f_36)" +"(lambda(tail?_40 v_62)" +"(begin" +" 'f" +"(if(syntax?$1 v_62)" +"(let-values()(s->_3 v_62))" +"(let-values()(f_35 tail?_40 v_62))))))" +"((seen_20) seen_19))" +"((letrec-values(((loop_7)" +"(lambda(tail?_41 s_172 prev-depth_8)" +"(begin" +" 'loop" +"(let-values(((depth_8)" +"(add1 prev-depth_8)))" +"(if(if seen_20(> depth_8 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_41" +" s_172" +"(lambda(tail?_42 s_173)" +"(f_36 tail?_42 s_173))" +" seen_20))" +"(if(null? s_172)" +"(let-values()" +"(f_36 tail?_41 s_172))" +"(if(pair? s_172)" +"(let-values()" +"(f_36" +" tail?_41" +"(cons" +"(loop_7" +" #f" +"(car s_172)" +" depth_8)" +"(loop_7" +" #t" +"(cdr s_172)" +" depth_8))))" +"(if(let-values(((or-part_164)" +"(symbol?" +" s_172)))" +"(if or-part_164" +" or-part_164" +"(let-values(((or-part_76)" +"(boolean?" +" s_172)))" +"(if or-part_76" +" or-part_76" +"(number? s_172)))))" +"(let-values()(f_36 #f s_172))" +"(if(let-values(((or-part_77)" +"(vector?" +" s_172)))" +"(if or-part_77" +" or-part_77" +"(let-values(((or-part_29)" +"(box?" +" s_172)))" +"(if or-part_29" +" or-part_29" +"(let-values(((or-part_78)" +"(prefab-struct-key" +" s_172)))" +"(if or-part_78" +" or-part_78" +"(hash?" +" s_172)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_41" +" s_172" +"(lambda(tail?_43 s_174)" +"(f_36 tail?_43 s_174))" +" seen_20))" +"(let-values()" +"(f_36 #f s_172))))))))))))" +" loop_7)" +" #f" +" s_146" +" 0)))))" +"(datum->syntax$1" +" #f" +" c_18" +" s_169" +"(if(syntax-any-macro-scopes? s_169)" +"(syntax-property-remove s_169 original-property-sym)" +" s_169))))" +"(if(equal? tmp_4 'transparent-binding)" +"(let-values()" +"(let-values(((c_19)(syntax-e$1 s_169)))" +"(if(pair? c_19)" +"(let-values()" +"(let-values(((cd_0)(cdr c_19)))" +"(if(let-values(((or-part_71)(pair? cd_0)))" +"(if or-part_71" +" or-part_71" +"(if(syntax?$1 cd_0)(pair?(syntax-e$1 cd_0)) #f)))" +"(let-values()" +"(let-values(((d_19)(if(syntax?$1 cd_0)(syntax-e$1 cd_0) cd_0)))" +"(datum->syntax$1" +" #f" +"(cons" +"(loop_33(car c_19)(syntax-taint-mode-property(car c_19)))" +"(cons" +"(loop_33(car d_19) 'transparent)" +"(let-values(((s_175)" +"(let-values(((or-part_165)" +"(syntax->list$1(cdr d_19))))" +"(if or-part_165 or-part_165(cdr d_19))))" +"((f_7)(lambda(tail?_44 d_20)(begin 'f d_20)))" +"((s->_4)" +"(lambda(s_176)" +"(begin" +" 's->" +"(loop_33" +" s_176" +"(syntax-taint-mode-property s_176)))))" +"((seen_21) #f))" +"(let-values(((s_80) s_175)" +"((f_8)" +"(lambda(tail?_45 v_39)" +"(begin" +" 'f" +"(if(syntax?$1 v_39)" +"(let-values()(s->_4 v_39))" +"(let-values()(f_7 tail?_45 v_39))))))" +"((seen_22) seen_21))" +"((letrec-values(((loop_77)" +"(lambda(tail?_46 s_177 prev-depth_9)" +"(begin" +" 'loop" +"(let-values(((depth_9)" +"(add1 prev-depth_9)))" +"(if(if seen_22(> depth_9 32) #f)" +"(let-values()" +"(datum-map-slow" +" tail?_46" +" s_177" +"(lambda(tail?_47 s_178)" +"(f_8 tail?_47 s_178))" +" seen_22))" +"(if(null? s_177)" +"(let-values()" +"(f_8 tail?_46 s_177))" +"(if(pair? s_177)" +"(let-values()" +"(f_8" +" tail?_46" +"(cons" +"(loop_77" +" #f" +"(car s_177)" +" depth_9)" +"(loop_77" +" #t" +"(cdr s_177)" +" depth_9))))" +"(if(let-values(((or-part_166)" +"(symbol?" +" s_177)))" +"(if or-part_166" +" or-part_166" +"(let-values(((or-part_167)" +"(boolean?" +" s_177)))" +"(if or-part_167" +" or-part_167" +"(number?" +" s_177)))))" +"(let-values()" +"(f_8 #f s_177))" +"(if(let-values(((or-part_168)" +"(vector?" +" s_177)))" +"(if or-part_168" +" or-part_168" +"(let-values(((or-part_169)" +"(box?" +" s_177)))" +"(if or-part_169" +" or-part_169" +"(let-values(((or-part_33)" +"(prefab-struct-key" +" s_177)))" +"(if or-part_33" +" or-part_33" +"(hash?" +" s_177)))))))" +"(let-values()" +"(datum-map-slow" +" tail?_46" +" s_177" +"(lambda(tail?_48" +" s_179)" +"(f_8" +" tail?_48" +" s_179))" +" seen_22))" +"(let-values()" +"(f_8" +" #f" +" s_177))))))))))))" +" loop_77)" +" #f" +" s_80" +" 0)))))" +" s_169" +"(if(syntax-any-macro-scopes? s_169)" +"(syntax-property-remove s_169 original-property-sym)" +" s_169))))" +"(let-values()(loop_33 s_169 'transparent)))))" +"(let-values()(loop_33 s_169 'transparent)))))" +"(let-values()" +"(let-values(((c_20)(syntax-e$1 s_169)))" +"(let-values(((tmp_15)(core-form-sym c_20 phase_31)))" +"(if(if(equal? tmp_15 'begin)" +" #t" +"(if(equal? tmp_15 'begin-for-syntax)" +" #t" +"(equal? tmp_15 '#%module-begin)))" +"(let-values()(loop_33 s_169 'transparent))" +"(if(if(equal? tmp_15 'define-values)" +" #t" +"(equal? tmp_15 'define-syntaxes))" +"(let-values()(loop_33 s_169 'transparent-binding))" +"(let-values()(loop_33 s_169 'opaque))))))))))))))))" +" loop_33)" +" s_0" +"(syntax-taint-mode-property s_0)))))" +"(define-values" +"(syntax-taint-mode-property)" +"(lambda(s_180)" +"(begin" +"(let-values(((or-part_170)(syntax-property$1 s_180 'taint-mode)))" +"(if or-part_170 or-part_170(syntax-property$1 s_180 'certify-mode))))))" +"(define-values" +"(syntax-remove-taint-dispatch-properties)" +"(lambda(s_181)(begin(syntax-property-remove(syntax-property-remove s_181 'taint-mode) 'certify-mode))))" +"(define-values(current-module-code-inspector)(make-parameter #f))" +"(define-values" +"(syntax-debug-info$1)" +"(lambda(s_0 phase_40 all-bindings?_0)" +"(begin" +" 'syntax-debug-info" +"(let-values(((hts_0)" +"(reverse$1" +"(let-values(((lst_72)(fallback->list(syntax-shifted-multi-scopes s_0))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_72)))" +"((letrec-values(((for-loop_95)" +"(lambda(fold-var_58 lst_79)" +"(begin" +" 'for-loop" +"(if(pair? lst_79)" +"(let-values(((smss_26)(unsafe-car lst_79))" +"((rest_37)(unsafe-cdr lst_79)))" +"(let-values(((fold-var_59)" +"(let-values(((fold-var_60) fold-var_58))" +"(let-values(((fold-var_61)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((init-ht_0)" +"(if(identifier?" +" s_0)" +"(hasheq" +" 'name" +"(syntax-e$1 s_0))" +" '#hasheq())))" +"(let-values(((s-scs_0)" +"(scope-set-at-fallback" +" s_0" +" smss_26" +" phase_40)))" +"(let-values(((context_1)" +"(scope-set->context" +" s-scs_0)))" +"(let-values(((context-ht_0)" +"(hash-set" +" init-ht_0" +" 'context" +" context_1)))" +"(let-values(((sym_17)" +"(syntax-e$1" +" s_0)))" +"(let-values(((bindings_0)" +"(if(identifier?" +" s_0)" +"(let-values()" +"(let-values(((bindings_1" +" covered-scopess_0)" +"(let-values(((ht_76)" +" s-scs_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash-keys" +" ht_76)))" +"((letrec-values(((for-loop_96)" +"(lambda(bindings_2" +" covered-scope-sets_0" +" i_85)" +"(begin" +" 'for-loop" +"(if i_85" +"(let-values(((sc_23)" +"(unsafe-immutable-hash-iterate-key" +" ht_76" +" i_85)))" +"(let-values(((bindings_3" +" covered-scope-sets_1)" +"(let-values(((ht_77" +" bulk-bindings_3)" +"(let-values(((table_102)" +"(scope-binding-table" +" sc_23)))" +"(if(hash?" +" table_102)" +"(values" +"(hash-ref" +" table_102" +" sym_17" +" '#hash())" +" null)" +"(values" +"(hash-ref" +"(table-with-bulk-bindings-syms" +" table_102)" +" sym_17" +" '#hash())" +"(table-with-bulk-bindings-bulk-bindings" +" table_102)))))" +"((s_182)" +" s_0)" +"((extra-shifts_5)" +" null))" +"(begin" +" #t" +"((letrec-values(((for-loop_97)" +"(lambda(bindings_4" +" covered-scope-sets_2" +" i_86)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" i_86))" +"(let-values(((scs_15)" +"(if(pair?" +" i_86)" +"(let-values()" +"(bulk-binding-at-scopes" +"(car" +" i_86)))" +"(let-values()" +"(hash-iterate-key" +" ht_77" +" i_86))))" +"((b_63)" +"(if(pair?" +" i_86)" +"(let-values()" +"(let-values(((bulk_4)" +"(bulk-binding-at-bulk" +"(car" +" i_86))))" +"(let-values(((b-info_1)" +"(hash-ref" +"(bulk-binding-symbols" +" bulk_4" +" s_182" +" extra-shifts_5)" +" sym_17" +" #f)))" +"(if b-info_1" +"((bulk-binding-create" +" bulk_4)" +" bulk_4" +" b-info_1" +" sym_17)" +" #f))))" +"(let-values()" +"(hash-iterate-value" +" ht_77" +" i_86)))))" +"(let-values(((bindings_5" +" covered-scope-sets_3)" +"(let-values(((bindings_6)" +" bindings_4)" +"((covered-scope-sets_4)" +" covered-scope-sets_2))" +"(if(if scs_15" +"(if b_63" +"(if(let-values(((or-part_30)" +" all-bindings?_0))" +"(if or-part_30" +" or-part_30" +"(subset?" +" scs_15" +" s-scs_0)))" +"(not" +"(set-member?" +" covered-scope-sets_4" +" scs_15))" +" #f)" +" #f)" +" #f)" +"(let-values(((bindings_7)" +" bindings_6)" +"((covered-scope-sets_5)" +" covered-scope-sets_4))" +"(let-values(((bindings_8" +" covered-scope-sets_6)" +"(let-values()" +"(values" +"(cons" +"(hash" +" 'name" +"(syntax-e$1" +" s_0)" +" 'context" +"(scope-set->context" +" scs_15)" +" 'match?" +"(subset?" +" scs_15" +" s-scs_0)" +"(if(local-binding?" +" b_63)" +" 'local" +" 'module)" +"(if(local-binding?" +" b_63)" +"(local-binding-key" +" b_63)" +"(vector" +"(module-binding-sym" +" b_63)" +"(module-binding-module" +" b_63)" +"(module-binding-phase" +" b_63))))" +" bindings_7)" +"(set-add" +" covered-scope-sets_5" +" scs_15)))))" +"(values" +" bindings_8" +" covered-scope-sets_6)))" +"(values" +" bindings_6" +" covered-scope-sets_4)))))" +"(if(not" +" #f)" +"(for-loop_97" +" bindings_5" +" covered-scope-sets_3" +"(if(pair?" +" i_86)" +"(let-values()" +"(cdr" +" i_86))" +"(let-values()" +"(let-values(((or-part_7)" +"(hash-iterate-next" +" ht_77" +" i_86)))" +"(if or-part_7" +" or-part_7" +" bulk-bindings_3)))))" +"(values" +" bindings_5" +" covered-scope-sets_3))))" +"(values" +" bindings_4" +" covered-scope-sets_2))))))" +" for-loop_97)" +" bindings_2" +" covered-scope-sets_0" +"(let-values(((or-part_8)" +"(hash-iterate-first" +" ht_77)))" +"(if or-part_8" +" or-part_8" +" bulk-bindings_3)))))))" +"(if(not" +" #f)" +"(for-loop_96" +" bindings_3" +" covered-scope-sets_1" +"(unsafe-immutable-hash-iterate-next" +" ht_76" +" i_85))" +"(values" +" bindings_3" +" covered-scope-sets_1))))" +"(values" +" bindings_2" +" covered-scope-sets_0))))))" +" for-loop_96)" +" null" +"(set)" +"(unsafe-immutable-hash-iterate-first" +" ht_76))))))" +" bindings_1))" +"(let-values()" +" null))))" +"(if(null? bindings_0)" +" context-ht_0" +"(hash-set" +" context-ht_0" +" 'bindings" +" bindings_0)))))))))" +" fold-var_60))))" +"(values fold-var_61)))))" +"(if(not #f)(for-loop_95 fold-var_59 rest_37) fold-var_59)))" +" fold-var_58)))))" +" for-loop_95)" +" null" +" lst_72))))))" +"(let-values(((ht_69)(car hts_0)))(if(null?(cdr hts_0)) ht_69(hash-set ht_69 'fallbacks(cdr hts_0))))))))" +"(define-values" +"(scope-set->context)" +"(lambda(scs_16)" +"(begin" +"(let-values(((temp1_1)" +"(reverse$1" +"(let-values(((ht_78) scs_16))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_78)))" +"((letrec-values(((for-loop_27)" +"(lambda(fold-var_17 i_87)" +"(begin" +" 'for-loop" +"(if i_87" +"(let-values(((sc_24)(unsafe-immutable-hash-iterate-key ht_78 i_87)))" +"(let-values(((fold-var_18)" +"(let-values(((fold-var_19) fold-var_17))" +"(let-values(((fold-var_20)" +"(let-values()" +"(cons" +"(let-values()" +"(if(representative-scope? sc_24)" +"(vector" +"(scope-id sc_24)" +"(scope-kind sc_24)" +"(multi-scope-name" +"(representative-scope-owner" +" sc_24)))" +"(vector" +"(scope-id sc_24)" +"(scope-kind sc_24))))" +" fold-var_19))))" +"(values fold-var_20)))))" +"(if(not #f)" +"(for-loop_27" +" fold-var_18" +"(unsafe-immutable-hash-iterate-next ht_78 i_87))" +" fold-var_18)))" +" fold-var_17)))))" +" for-loop_27)" +" null" +"(unsafe-immutable-hash-iterate-first ht_78))))))" +"((<2_0) <)" +"((temp3_2)(lambda(v_131)(vector-ref v_131 0))))" +"(sort7.1 #f #f temp3_2 #t temp1_1 <2_0)))))" +"(define-values" +"(raise-ambiguous-error)" +"(lambda(id_22 ctx_7)" +"(begin" +"(raise-syntax-error$1" +" #f" +" \"identifier's binding is ambiguous\"" +" id_22" +" #f" +" null" +"(syntax-debug-info-string id_22 ctx_7)))))" +"(define-values" +"(syntax-debug-info-string)" +"(lambda(s_158 ctx_8)" +"(begin" +"(let-values(((info_3)(syntax-debug-info$1 s_158(expand-context-phase ctx_8) #t)))" +"(if(not" +"(let-values(((or-part_26)(pair?(hash-ref info_3 'bindings null))))" +"(if or-part_26" +" or-part_26" +"(let-values(((lst_6)(hash-ref info_3 'fallbacks null)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_6)))" +"((letrec-values(((for-loop_98)" +"(lambda(result_62 lst_80)" +"(begin" +" 'for-loop" +"(if(pair? lst_80)" +"(let-values(((fb-info_0)(unsafe-car lst_80))" +"((rest_38)(unsafe-cdr lst_80)))" +"(let-values(((result_1)" +"(let-values()" +"(let-values(((result_63)" +"(let-values()" +"(let-values()" +"(pair?" +"(hash-ref" +" fb-info_0" +" 'bindings" +" null))))))" +"(values result_63)))))" +"(if(if(not((lambda x_28 result_1) fb-info_0))(not #f) #f)" +"(for-loop_98 result_1 rest_38)" +" result_1)))" +" result_62)))))" +" for-loop_98)" +" #f" +" lst_6))))))" +" (let-values () \"\")" +"(let-values()" +"(let-values(((relevant-scope-sets_0)" +"((letrec-values(((loop_76)" +"(lambda(info_4 layer_0)" +"(begin" +" 'loop" +"(apply" +" append" +"(cons" +"(hash-ref info_4 'context)" +"(reverse$1" +"(let-values(((lst_81)(hash-ref info_4 'bindings null)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_81)))" +"((letrec-values(((for-loop_99)" +"(lambda(fold-var_62 lst_82)" +"(begin" +" 'for-loop" +"(if(pair? lst_82)" +"(let-values(((b_26)(unsafe-car lst_82))" +"((rest_39)" +"(unsafe-cdr lst_82)))" +"(let-values(((fold-var_33)" +"(let-values(((fold-var_34)" +" fold-var_62))" +"(let-values(((fold-var_63)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +" b_26" +" 'context))" +" fold-var_34))))" +"(values" +" fold-var_63)))))" +"(if(not #f)" +"(for-loop_99 fold-var_33 rest_39)" +" fold-var_33)))" +" fold-var_62)))))" +" for-loop_99)" +" null" +" lst_81)))))" +"(let-values(((fallbacks_0)(hash-ref info_4 'fallbacks null)))" +"(reverse$1" +"(let-values(((lst_83) fallbacks_0)((start_14)(add1 layer_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_83)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_14)))" +"((letrec-values(((for-loop_100)" +"(lambda(fold-var_64 lst_84 pos_11)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_84) #t #f)" +"(let-values(((fallback_0)" +"(unsafe-car lst_84))" +"((rest_40)" +"(unsafe-cdr lst_84))" +"((layer_1) pos_11))" +"(let-values(((fold-var_9)" +"(let-values(((fold-var_65)" +" fold-var_64))" +"(let-values(((fold-var_66)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_76" +" fallback_0" +" layer_1))" +" fold-var_65))))" +"(values" +" fold-var_66)))))" +"(if(not #f)" +"(for-loop_100" +" fold-var_9" +" rest_40" +"(+ pos_11 1))" +" fold-var_9)))" +" fold-var_64)))))" +" for-loop_100)" +" null" +" lst_83" +" start_14))))))))))" +" loop_76)" +" info_3" +" 0)))" +"(let-values(((common-scopes_0)" +"(if(null? relevant-scope-sets_0)" +"(set)" +"(let-values(((lst_75) relevant-scope-sets_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_75)))" +"((letrec-values(((for-loop_101)" +"(lambda(s_183 lst_85)" +"(begin" +" 'for-loop" +"(if(pair? lst_85)" +"(let-values(((l_48)(unsafe-car lst_85))" +"((rest_41)(unsafe-cdr lst_85)))" +"(let-values(((s_81)" +"(let-values(((s_184) s_183))" +"(let-values(((s_185)" +"(let-values()" +"(set-intersect" +" s_184" +"(list->set l_48)))))" +"(values s_185)))))" +"(if(not #f)(for-loop_101 s_81 rest_41) s_81)))" +" s_183)))))" +" for-loop_101)" +"(list->set(car relevant-scope-sets_0))" +" lst_75))))))" +"(string-append" +"((letrec-values(((loop_77)" +"(lambda(info_5 layer_2)" +"(begin" +" 'loop" +"(string-append" +" \"\\n context\"" +"(layer->string layer_2)" +" \"...:\"" +"(describe-context(hash-ref info_5 'context) common-scopes_0)" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_86)" +"(let-values(((temp1_2)(hash-ref info_5 'bindings null))" +"((temp2_2)" +"(lambda(a_37 b_64)" +"(begin" +" 'temp2" +"(if(hash-ref a_37 'match? #f)" +"(not(hash-ref b_64 'match? #f))" +" #f)))))" +"(sort7.1 #f #f #f #f temp1_2 temp2_2))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_86)))" +"((letrec-values(((for-loop_102)" +"(lambda(fold-var_67 lst_87)" +"(begin" +" 'for-loop" +"(if(pair? lst_87)" +"(let-values(((b_23)(unsafe-car lst_87))" +"((rest_42)(unsafe-cdr lst_87)))" +"(let-values(((fold-var_20)" +"(let-values(((fold-var_68)" +" fold-var_67))" +"(let-values(((fold-var_69)" +"(let-values()" +"(cons" +"(let-values()" +"(string-append" +" \"\\n \"" +"(if(hash-ref" +" b_23" +" 'match?" +" #f)" +" \"matching\"" +" \"other\")" +" \" binding\"" +"(layer->string" +" layer_2)" +" \"...:\"" +" \"\\n \"" +"(if(hash-ref" +" b_23" +" 'local" +" #f)" +" \"local\"" +"(format" +" \"~a\"" +"(hash-ref" +" b_23" +" 'module" +" #f)))" +"(describe-context" +"(hash-ref" +" b_23" +" 'context)" +" common-scopes_0)))" +" fold-var_68))))" +"(values fold-var_69)))))" +"(if(not #f)" +"(for-loop_102 fold-var_20 rest_42)" +" fold-var_20)))" +" fold-var_67)))))" +" for-loop_102)" +" null" +" lst_86)))))" +"(let-values(((fallbacks_1)(hash-ref info_5 'fallbacks null)))" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_88) fallbacks_1)((start_15)(add1 layer_2)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_88)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_15)))" +"((letrec-values(((for-loop_103)" +"(lambda(fold-var_70 lst_89 pos_12)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_89) #t #f)" +"(let-values(((fallback_1)(unsafe-car lst_89))" +"((rest_0)(unsafe-cdr lst_89))" +"((layer_3) pos_12))" +"(let-values(((fold-var_71)" +"(let-values(((fold-var_72)" +" fold-var_70))" +"(let-values(((fold-var_73)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_77" +" fallback_1" +" layer_3))" +" fold-var_72))))" +"(values fold-var_73)))))" +"(if(not #f)" +"(for-loop_103" +" fold-var_71" +" rest_0" +"(+ pos_12 1))" +" fold-var_71)))" +" fold-var_70)))))" +" for-loop_103)" +" null" +" lst_88" +" start_15)))))))))))" +" loop_77)" +" info_3" +" 0)" +"(if(set-empty? common-scopes_0)" +" \"\"" +"(string-append" +" \"\\n common scopes...:\"" +"(describe-context" +"(reverse$1" +"(let-values(((lst_9)(hash-ref info_3 'context)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_9)))" +"((letrec-values(((for-loop_1)" +"(lambda(fold-var_74 lst_10)" +"(begin" +" 'for-loop" +"(if(pair? lst_10)" +"(let-values(((s_186)(unsafe-car lst_10))" +"((rest_1)(unsafe-cdr lst_10)))" +"(let-values(((fold-var_75)" +"(let-values(((fold-var_76) fold-var_74))" +"(if(set-member? common-scopes_0 s_186)" +"(let-values(((fold-var_5) fold-var_76))" +"(let-values(((fold-var_6)" +"(let-values()" +"(cons" +"(let-values() s_186)" +" fold-var_5))))" +"(values fold-var_6)))" +" fold-var_76))))" +"(if(not #f)(for-loop_1 fold-var_75 rest_1) fold-var_75)))" +" fold-var_74)))))" +" for-loop_1)" +" null" +" lst_9))))" +"(set)))))))))))))" +"(define-values" +"(describe-context)" +"(lambda(scopes_19 common-scopes_1)" +"(begin" +"(let-values(((strs_0)" +"((letrec-values(((loop_55)" +"(lambda(strs_1 scopes_20)" +"(begin" +" 'loop" +"(if(null? scopes_20)" +"(let-values()(reverse$1 strs_1))" +"(let-values()" +" (let-values (((str_3) (format \" ~a\" (car scopes_20))))" +"(if(if(pair? strs_1)" +"(<(+(string-length str_3)(string-length(car strs_1))) 72)" +" #f)" +"(loop_55" +"(cons(string-append(car strs_1) str_3)(cdr strs_1))" +"(cdr scopes_20))" +"(loop_55(cons str_3 strs_1)(cdr scopes_20))))))))))" +" loop_55)" +" null" +"(if(set-empty? common-scopes_1)" +" scopes_19" +"(append" +"(reverse$1" +"(let-values(((lst_90) scopes_19))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_90)))" +"((letrec-values(((for-loop_104)" +"(lambda(fold-var_77 lst_91)" +"(begin" +" 'for-loop" +"(if(pair? lst_91)" +"(let-values(((s_187)(unsafe-car lst_91))" +"((rest_43)(unsafe-cdr lst_91)))" +"(let-values(((fold-var_78)" +"(let-values(((fold-var_79) fold-var_77))" +"(if(not(set-member? common-scopes_1 s_187))" +"(let-values(((fold-var_80) fold-var_79))" +"(let-values(((fold-var_81)" +"(let-values()" +"(cons" +"(let-values() s_187)" +" fold-var_80))))" +"(values fold-var_81)))" +" fold-var_79))))" +"(if(not #f)(for-loop_104 fold-var_78 rest_43) fold-var_78)))" +" fold-var_77)))))" +" for-loop_104)" +" null" +" lst_90))))" +" (list \"[common scopes]\"))))))" +"(if(null? strs_0)" +" (let-values () \"\\n [empty]\")" +"(let-values()" +"(apply" +" string-append" +"(reverse$1" +"(let-values(((lst_92) strs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_92)))" +"((letrec-values(((for-loop_105)" +"(lambda(fold-var_82 lst_93)" +"(begin" +" 'for-loop" +"(if(pair? lst_93)" +"(let-values(((str_4)(unsafe-car lst_93))((rest_44)(unsafe-cdr lst_93)))" +"(let-values(((fold-var_83)" +"(let-values(((fold-var_84) fold-var_82))" +"(let-values(((fold-var_14)" +"(let-values()" +"(cons" +"(let-values()" +" (string-append \"\\n \" str_4))" +" fold-var_84))))" +"(values fold-var_14)))))" +"(if(not #f)(for-loop_105 fold-var_83 rest_44) fold-var_83)))" +" fold-var_82)))))" +" for-loop_105)" +" null" +" lst_92)))))))))))" +" (define-values (layer->string) (lambda (layer_4) (begin (if (zero? layer_4) \"\" (format \" at layer ~a\" layer_4)))))" +"(define-values" +"(raise-syntax-implicit-error)" +"(lambda(s_0 sym_27 trigger-id_0 ctx_8)" +"(begin" +"(let-values(((phase_41)(expand-context-phase ctx_8)))" +"(let-values(((what_1)" +"(let-values(((tmp_16) sym_27))" +"(if(equal? tmp_16 '#%app)" +" (let-values () \"function application\")" +"(if(equal? tmp_16 '#%datum)" +" (let-values () \"literal data\")" +"(if(equal? tmp_16 '#%top)" +"(let-values()" +"(if(expand-context-allow-unbound? ctx_8)" +" \"reference to a top-level identifier\"" +" \"reference to an unbound identifier\"))" +"(let-values()(void))))))))" +"(let-values(((unbound?_0)" +"(if trigger-id_0" +"(not" +"(let-values(((trigger-id1_0) trigger-id_0)((phase2_0) phase_41))" +"(resolve33.1 #f #f #f #f #f #f #f #f trigger-id1_0 phase2_0)))" +" #f)))" +"(raise-syntax-error$1" +" #f" +"(format" +"(if unbound?_0" +" \"unbound identifier;\\n also, no ~a transformer is bound~a\"" +" (string-append what_1 \" is not allowed;\\n no ~a syntax transformer is bound~a\"))" +" sym_27" +"(let-values(((tmp_17) phase_41))" +"(if(equal? tmp_17 0)" +" (let-values () \"\")" +"(if(equal? tmp_17 1)" +" (let-values () \" in the transformer phase\")" +" (let-values () (format \" at phase ~a\" phase_41))))))" +"(if unbound?_0 trigger-id_0 #f)" +"(if unbound?_0(if(not(eq?(syntax-e$1 s_0)(syntax-e$1 trigger-id_0))) s_0 #f) #f)" +" null" +" (if unbound?_0 (syntax-debug-info-string trigger-id_0 ctx_8) \"\"))))))))" +"(define-values(make-check-no-duplicate-table)(lambda()(begin '#hasheq())))" +"(define-values" +"(check-no-duplicate-ids8.1)" +"(lambda(what1_0 what2_0 ids5_0 phase6_0 s7_1 ht3_0 ht4_0)" +"(begin" +" 'check-no-duplicate-ids8" +"(let-values(((ids_2) ids5_0))" +"(let-values(((phase_42) phase6_0))" +"(let-values(((s_145) s7_1))" +"(let-values(((ht_72)(if ht4_0 ht3_0(make-check-no-duplicate-table))))" +" (let-values (((what_2) (if what2_0 what1_0 \"binding name\")))" +"(let-values()" +"((letrec-values(((loop_78)" +"(lambda(v_132 ht_79)" +"(begin" +" 'loop" +"(if(identifier? v_132)" +"(let-values()" +"(let-values(((l_7)(hash-ref ht_79(syntax-e$1 v_132) null)))" +"(begin" +"(let-values(((lst_73) l_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_73)))" +"((letrec-values(((for-loop_91)" +"(lambda(lst_94)" +"(begin" +" 'for-loop" +"(if(pair? lst_94)" +"(let-values(((id_13)(unsafe-car lst_94))" +"((rest_45)" +"(unsafe-cdr lst_94)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(bound-identifier=?$1" +" id_13" +" v_132" +" phase_42)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +"(string-append" +" \"duplicate \"" +" what_2)" +" s_145" +" v_132))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_91 rest_45)" +"(values))))" +"(values))))))" +" for-loop_91)" +" lst_73)))" +"(void)" +"(hash-set ht_79(syntax-e$1 v_132)(cons v_132 l_7)))))" +"(if(pair? v_132)" +"(let-values()(loop_78(cdr v_132)(loop_78(car v_132) ht_79)))" +"(let-values() ht_79)))))))" +" loop_78)" +" ids_2" +" ht_72))))))))))" +"(define-values" +"(remove-use-site-scopes)" +"(lambda(s_0 ctx_7)" +"(begin" +"(let-values(((use-sites_0)(root-expand-context-use-site-scopes ctx_7)))" +"(if(if use-sites_0(pair?(unbox use-sites_0)) #f)" +"(if(syntax?$1 s_0)" +"(remove-scopes s_0(unbox use-sites_0))" +"(reverse$1" +"(let-values(((lst_95) s_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_95)))" +"((letrec-values(((for-loop_106)" +"(lambda(fold-var_85 lst_6)" +"(begin" +" 'for-loop" +"(if(pair? lst_6)" +"(let-values(((id_9)(unsafe-car lst_6))((rest_46)(unsafe-cdr lst_6)))" +"(let-values(((fold-var_86)" +"(let-values(((fold-var_87) fold-var_85))" +"(let-values(((fold-var_59)" +"(let-values()" +"(cons" +"(let-values()" +"(remove-scopes id_9(unbox use-sites_0)))" +" fold-var_87))))" +"(values fold-var_59)))))" +"(if(not #f)(for-loop_106 fold-var_86 rest_46) fold-var_86)))" +" fold-var_85)))))" +" for-loop_106)" +" null" +" lst_95)))))" +" s_0)))))" +"(define-values" +"(struct:compile-context" +" compile-context1.1" +" compile-context?" +" compile-context-namespace" +" compile-context-phase" +" compile-context-self" +" compile-context-module-self" +" compile-context-full-module-name" +" compile-context-lazy-syntax-literals?" +" compile-context-header)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'compile-context" +" #f" +" 7" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'compile-context)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'namespace)" +"(make-struct-field-accessor -ref_0 1 'phase)" +"(make-struct-field-accessor -ref_0 2 'self)" +"(make-struct-field-accessor -ref_0 3 'module-self)" +"(make-struct-field-accessor -ref_0 4 'full-module-name)" +"(make-struct-field-accessor -ref_0 5 'lazy-syntax-literals?)" +"(make-struct-field-accessor -ref_0 6 'header))))" +"(define-values" +"(make-compile-context14.1)" +"(lambda(full-module-name6_0" +" full-module-name12_0" +" lazy-syntax-literals?7_0" +" lazy-syntax-literals?13_0" +" module-self5_0" +" module-self11_0" +" namespace2_0" +" namespace8_0" +" phase3_0" +" phase9_0" +" self4_1" +" self10_0)" +"(begin" +" 'make-compile-context14" +"(let-values(((namespace_1)(if namespace8_0 namespace2_0(1/current-namespace))))" +"(let-values(((phase_43)(if phase9_0 phase3_0(namespace-phase namespace_1))))" +"(let-values(((self_5)(if self10_0 self4_1(namespace-mpi namespace_1))))" +"(let-values(((module-self_0)(if module-self11_0 module-self5_0 #f)))" +"(let-values(((full-module-name_0)(if full-module-name12_0 full-module-name6_0 #f)))" +"(let-values(((lazy-syntax-literals?_0)" +"(if lazy-syntax-literals?13_0 lazy-syntax-literals?7_0(if module-self_0 #t #f))))" +"(let-values()" +"(begin" +"(if(if module-self_0(not full-module-name_0) #f)" +" (let-values () (error \"internal error: module-self provided without full name\"))" +"(void))" +"(compile-context1.1" +" namespace_1" +" phase_43" +" self_5" +" module-self_0" +" full-module-name_0" +" lazy-syntax-literals?_0" +" #f))))))))))))" +"(define-values" +"(struct:mpi-intern-table mpi-intern-table1.1 mpi-intern-table? mpi-intern-table-normal mpi-intern-table-fast)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'mpi-intern-table" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'mpi-intern-table)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'normal)" +"(make-struct-field-accessor -ref_0 1 'fast))))" +"(define-values" +"(make-module-path-index-intern-table)" +"(lambda()(begin(mpi-intern-table1.1(make-hash)(make-hasheq)))))" +"(define-values" +"(intern-module-path-index!)" +"(lambda(t_41 mpi_19)" +"(begin" +"(let-values(((or-part_160)(hash-ref(mpi-intern-table-fast t_41) mpi_19 #f)))" +"(if or-part_160" +" or-part_160" +"(let-values(((name_2 base_15)(1/module-path-index-split mpi_19)))" +"(if(not name_2)" +"(let-values()(begin(hash-set!(mpi-intern-table-fast t_41) mpi_19 mpi_19) mpi_19))" +"(let-values()" +"(let-values(((interned-base_0)(if base_15(intern-module-path-index! t_41 base_15) #f)))" +"(let-values(((at-name_0)" +"(let-values(((or-part_79)(hash-ref(mpi-intern-table-normal t_41) name_2 #f)))" +"(if or-part_79" +" or-part_79" +"(let-values(((at-name_1)(make-hasheq)))" +"(begin(hash-set!(mpi-intern-table-normal t_41) name_2 at-name_1) at-name_1))))))" +"(let-values(((i-mpi_0)" +"(let-values(((or-part_81)(hash-ref at-name_0 interned-base_0 #f)))" +"(if or-part_81" +" or-part_81" +"(let-values(((mpi_20)" +"(if(eq? base_15 interned-base_0)" +" mpi_19" +"(let-values(((the-struct_49) mpi_19))" +"(if(1/module-path-index? the-struct_49)" +"(let-values(((base3_0) interned-base_0))" +"(module-path-index2.1" +"(module-path-index-path the-struct_49)" +" base3_0" +"(module-path-index-resolved the-struct_49)" +"(module-path-index-shift-cache the-struct_49)))" +"(raise-argument-error" +" 'struct-copy" +" \"module-path-index?\"" +" the-struct_49))))))" +"(begin(hash-set! at-name_0 interned-base_0 mpi_20) mpi_20))))))" +"(begin(hash-set!(mpi-intern-table-fast t_41) mpi_19 i-mpi_0) i-mpi_0))))))))))))" +"(define-values" +"(unsafe-vector-ref-id)" +"(if(eq?(system-type 'vm) 'chez-scheme)(let-values() 'unsafe-vector*-ref)(let-values() 'vector*-ref)))" +"(define-values" +"(struct:module-path-index-table" +" module-path-index-table1.1" +" module-path-index-table?" +" module-path-index-table-positions" +" module-path-index-table-intern)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-path-index-table" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'module-path-index-table)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'positions)" +"(make-struct-field-accessor -ref_0 1 'intern))))" +"(define-values" +"(make-module-path-index-table)" +"(lambda()(begin(module-path-index-table1.1(make-hasheq)(make-module-path-index-intern-table)))))" +"(define-values" +"(add-module-path-index!)" +"(lambda(mpis_0 mpi_19)" +"(begin" +"(let-values(((pos_13)(add-module-path-index!/pos mpis_0 mpi_19)))" +"(if pos_13(list unsafe-vector-ref-id mpi-vector-id pos_13) #f)))))" +"(define-values" +"(add-module-path-index!/pos)" +"(lambda(mpis_1 mpi_21)" +"(begin" +"(if(not mpi_21)" +"(let-values() #f)" +"(if mpi_21" +"(let-values()" +"(let-values(((mpi_22)(intern-module-path-index!(module-path-index-table-intern mpis_1) mpi_21))" +"((positions_0)(module-path-index-table-positions mpis_1)))" +"(let-values(((or-part_78)(hash-ref positions_0 mpi_22 #f)))" +"(if or-part_78" +" or-part_78" +"(let-values(((pos_14)(hash-count positions_0)))" +"(begin(hash-set! positions_0 mpi_22 pos_14) pos_14))))))" +"(void))))))" +"(define-values" +"(generate-module-path-index-deserialize)" +"(lambda(mpis_2)" +"(begin" +"(let-values(((positions_1)(module-path-index-table-positions mpis_2)))" +"(let-values(((gen-order_0)(make-hasheqv)))" +"(let-values(((rev-positions_0)" +"(let-values(((ht_80) positions_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_80)))" +"((letrec-values(((for-loop_107)" +"(lambda(table_103 i_88)" +"(begin" +" 'for-loop" +"(if i_88" +"(let-values(((k_18 v_133)(hash-iterate-key+value ht_80 i_88)))" +"(let-values(((table_95)" +"(let-values(((table_104) table_103))" +"(let-values(((table_105)" +"(let-values()" +"(let-values(((key_42 val_36)" +"(let-values()" +"(values" +" v_133" +" k_18))))" +"(hash-set" +" table_104" +" key_42" +" val_36)))))" +"(values table_105)))))" +"(if(not #f)" +"(for-loop_107 table_95(hash-iterate-next ht_80 i_88))" +" table_95)))" +" table_103)))))" +" for-loop_107)" +" '#hasheqv()" +"(hash-iterate-first ht_80))))))" +"(let-values((()" +"(begin" +"(let-values(((start_16) 0)((end_10)(hash-count rev-positions_0))((inc_4) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_16 end_10 inc_4)))" +"((letrec-values(((for-loop_21)" +"(lambda(pos_15)" +"(begin" +" 'for-loop" +"(if(< pos_15 end_10)" +"(let-values(((i_89) pos_15))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((mpi_23)" +"(hash-ref" +" rev-positions_0" +" i_89)))" +"((letrec-values(((loop_79)" +"(lambda(mpi_24)" +"(begin" +" 'loop" +"(if(hash-ref" +" gen-order_0" +" mpi_24" +" #f)" +"(void)" +"(let-values()" +"(let-values(((name_36" +" base_16)" +"(1/module-path-index-split" +" mpi_24)))" +"(begin" +"(if base_16" +"(let-values()" +"(loop_79" +" base_16))" +"(void))" +"(hash-set!" +" gen-order_0" +" mpi_24" +"(hash-count" +" gen-order_0))))))))))" +" loop_79)" +" mpi_23)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_21(+ pos_15 inc_4))(values))))" +"(values))))))" +" for-loop_21)" +" start_16)))" +"(values))))" +"(let-values()" +"(let-values(((rev-gen-order_0)" +"(let-values(((ht_81) gen-order_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_81)))" +"((letrec-values(((for-loop_108)" +"(lambda(table_106 i_90)" +"(begin" +" 'for-loop" +"(if i_90" +"(let-values(((k_19 v_134)" +"(hash-iterate-key+value ht_81 i_90)))" +"(let-values(((table_15)" +"(let-values(((table_55) table_106))" +"(let-values(((table_56)" +"(let-values()" +"(let-values(((key_43" +" val_37)" +"(let-values()" +"(values" +" v_134" +" k_19))))" +"(hash-set" +" table_55" +" key_43" +" val_37)))))" +"(values table_56)))))" +"(if(not #f)" +"(for-loop_108 table_15(hash-iterate-next ht_81 i_90))" +" table_15)))" +" table_106)))))" +" for-loop_108)" +" '#hasheqv()" +"(hash-iterate-first ht_81))))))" +"(let-values(((gens_0)" +"(let-values(((len_11)(hash-count gen-order_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_11)" +"(void)" +"(let-values()" +" (raise-argument-error 'for/vector \"exact-nonnegative-integer?\" len_11)))" +"(let-values(((v_36)(make-vector len_11 0)))" +"(begin" +"(if(zero? len_11)" +"(void)" +"(let-values()" +"(let-values(((start_17) 0)((end_11)(hash-count gen-order_0))((inc_5) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_17 end_11 inc_5)))" +"((letrec-values(((for-loop_29)" +"(lambda(i_91 pos_16)" +"(begin" +" 'for-loop" +"(if(< pos_16 end_11)" +"(let-values(((i_92) pos_16))" +"(let-values(((i_93)" +"(let-values(((i_26) i_91))" +"(let-values(((i_94)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_36" +" i_26" +"(let-values()" +"(let-values(((mpi_25)" +"(hash-ref" +" rev-gen-order_0" +" i_92)))" +"(let-values(((path_6" +" base_17)" +"(1/module-path-index-split" +" mpi_25)))" +"(if(top-level-module-path-index?" +" mpi_25)" +"(let-values()" +" 'top)" +"(if(not" +" path_6)" +"(let-values()" +"(box" +"(let-values(((or-part_34)" +"(1/resolved-module-path-name" +"(module-path-index-resolved" +" mpi_25))))" +"(if or-part_34" +" or-part_34" +" 'self))))" +"(if(not" +" base_17)" +"(let-values()" +"(vector" +" path_6))" +"(if base_17" +"(let-values()" +"(vector" +" path_6" +"(hash-ref" +" gen-order_0" +" base_17)))" +"(void)))))))))" +"(unsafe-fx+" +" 1" +" i_26)))))" +"(values i_94)))))" +"(if(if(not" +"((lambda x_42" +"(unsafe-fx= i_93 len_11))" +" i_92))" +"(not #f)" +" #f)" +"(for-loop_29 i_93(+ pos_16 inc_5))" +" i_93)))" +" i_91)))))" +" for-loop_29)" +" 0" +" start_17)))))" +" v_36))))))" +"(list" +" 'deserialize-module-path-indexes" +"(list 'quote gens_0)" +"(list" +" 'quote" +"(let-values(((vec_25 i_27)" +"(let-values(((start_18) 0)((end_12)(hash-count rev-positions_0))((inc_6) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_18 end_12 inc_6)))" +"((letrec-values(((for-loop_109)" +"(lambda(vec_13 i_95 pos_17)" +"(begin" +" 'for-loop" +"(if(< pos_17 end_12)" +"(let-values(((i_96) pos_17))" +"(let-values(((vec_26 i_97)" +"(let-values(((vec_27) vec_13)" +"((i_98) i_95))" +"(let-values(((vec_28 i_99)" +"(let-values()" +"(let-values(((new-vec_2)" +"(if(eq?" +" i_98" +"(unsafe-vector*-length" +" vec_27))" +"(grow-vector" +" vec_27)" +" vec_27)))" +"(begin" +"(unsafe-vector*-set!" +" new-vec_2" +" i_98" +"(let-values()" +"(hash-ref" +" gen-order_0" +"(hash-ref" +" rev-positions_0" +" i_96))))" +"(values" +" new-vec_2" +"(unsafe-fx+" +" i_98" +" 1)))))))" +"(values vec_28 i_99)))))" +"(if(not #f)" +"(for-loop_109 vec_26 i_97(+ pos_17 inc_6))" +"(values vec_26 i_97))))" +"(values vec_13 i_95))))))" +" for-loop_109)" +"(make-vector 16)" +" 0" +" start_18)))))" +"(shrink-vector vec_25 i_27))))))))))))))" +"(define-values" +"(deserialize-module-path-indexes)" +"(lambda(gen-vec_0 order-vec_0)" +"(begin" +"(let-values(((gen_0)(make-vector(vector-length gen-vec_0) #f)))" +"(begin" +"(let-values(((vec_29 len_12)" +"(let-values(((vec_30) gen-vec_0))" +"(begin(check-vector vec_30)(values vec_30(unsafe-vector-length vec_30)))))" +"((start_19) 0))" +"(begin" +" #f" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_19)))" +"((letrec-values(((for-loop_110)" +"(lambda(pos_18 pos_19)" +"(begin" +" 'for-loop" +"(if(if(unsafe-fx< pos_18 len_12) #t #f)" +"(let-values(((d_21)(unsafe-vector-ref vec_29 pos_18))((i_100) pos_19))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(vector-set!" +" gen_0" +" i_100" +"(if(eq? d_21 'top)" +"(let-values()" +"(deserialize-module-path-index))" +"(if(box? d_21)" +"(let-values()" +"(deserialize-module-path-index" +"(unbox d_21)))" +"(let-values()" +"(deserialize-module-path-index" +"(vector*-ref d_21 0)" +"(if(>(vector*-length d_21) 1)" +"(vector*-ref" +" gen_0" +"(vector*-ref d_21 1))" +" #f)))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_110(unsafe-fx+ 1 pos_18)(+ pos_19 1))(values))))" +"(values))))))" +" for-loop_110)" +" 0" +" start_19)))" +"(void)" +"(let-values(((len_13)(vector-length order-vec_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_13)" +"(void)" +" (let-values () (raise-argument-error 'for/vector \"exact-nonnegative-integer?\" len_13)))" +"(let-values(((v_135)(make-vector len_13 0)))" +"(begin" +"(if(zero? len_13)" +"(void)" +"(let-values()" +"(let-values(((vec_31 len_14)" +"(let-values(((vec_32) order-vec_0))" +"(begin(check-vector vec_32)(values vec_32(unsafe-vector-length vec_32))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_111)" +"(lambda(i_101 pos_20)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_20 len_14)" +"(let-values(((p_26)(unsafe-vector-ref vec_31 pos_20)))" +"(let-values(((i_102)" +"(let-values(((i_103) i_101))" +"(let-values(((i_23)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_135" +" i_103" +"(let-values()" +"(vector*-ref gen_0 p_26)))" +"(unsafe-fx+ 1 i_103)))))" +"(values i_23)))))" +"(if(if(not((lambda x_43(unsafe-fx= i_102 len_13)) p_26))" +"(not #f)" +" #f)" +"(for-loop_111 i_102(unsafe-fx+ 1 pos_20))" +" i_102)))" +" i_101)))))" +" for-loop_111)" +" 0" +" 0)))))" +" v_135)))))))))" +"(define-values" +"(mpis-as-vector)" +"(lambda(mpis_3)" +"(begin" +"(let-values(((positions_2)(module-path-index-table-positions mpis_3)))" +"(let-values(((vec_33)(make-vector(hash-count positions_2) #f)))" +"(begin" +"(let-values(((ht_82) positions_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_82)))" +"((letrec-values(((for-loop_112)" +"(lambda(i_46)" +"(begin" +" 'for-loop" +"(if i_46" +"(let-values(((mpi_2 pos_21)(hash-iterate-key+value ht_82 i_46)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(vector-set! vec_33 pos_21 mpi_2))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_112(hash-iterate-next ht_82 i_46))(values))))" +"(values))))))" +" for-loop_112)" +"(hash-iterate-first ht_82))))" +"(void)" +" vec_33))))))" +"(define-values" +"(serialize-module-uses)" +"(lambda(mus_0 mpis_4)" +"(begin" +"(reverse$1" +"(let-values(((lst_96) mus_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_96)))" +"((letrec-values(((for-loop_6)" +"(lambda(fold-var_0 lst_97)" +"(begin" +" 'for-loop" +"(if(pair? lst_97)" +"(let-values(((mu_1)(unsafe-car lst_97))((rest_47)(unsafe-cdr lst_97)))" +"(let-values(((fold-var_2)" +"(let-values(((fold-var_3) fold-var_0))" +"(let-values(((fold-var_88)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +" 'module-use" +"(add-module-path-index!" +" mpis_4" +"(module-use-module mu_1))" +"(module-use-phase mu_1)))" +" fold-var_3))))" +"(values fold-var_88)))))" +"(if(not #f)(for-loop_6 fold-var_2 rest_47) fold-var_2)))" +" fold-var_0)))))" +" for-loop_6)" +" null" +" lst_96)))))))" +"(define-values" +"(interned-literal?)" +"(lambda(v_38)" +"(begin" +"(let-values(((or-part_139)(null? v_38)))" +"(if or-part_139" +" or-part_139" +"(let-values(((or-part_171)(boolean? v_38)))" +"(if or-part_171" +" or-part_171" +"(let-values(((or-part_172)" +"(if(fixnum? v_38)(if(< v_38(sub1(expt 2 30)))(> v_38(-(expt 2 30))) #f) #f)))" +"(if or-part_172" +" or-part_172" +"(let-values(((or-part_140)(symbol? v_38)))" +"(if or-part_140" +" or-part_140" +"(let-values(((or-part_173)(char? v_38)))" +"(if or-part_173 or-part_173(keyword? v_38))))))))))))))" +"(define-values" +"(serialize-phase-to-link-module-uses)" +"(lambda(phase-to-link-module-uses_0 mpis_5)" +"(begin" +"(let-values(((phases-in-order_0)" +"(let-values(((temp10_1)(hash-keys phase-to-link-module-uses_0))((<11_0) <))" +"(sort7.1 #f #f #f #f temp10_1 <11_0))))" +"(list*" +" 'hasheqv" +"(apply" +" append" +"(reverse$1" +"(let-values(((lst_98) phases-in-order_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_98)))" +"((letrec-values(((for-loop_113)" +"(lambda(fold-var_38 lst_99)" +"(begin" +" 'for-loop" +"(if(pair? lst_99)" +"(let-values(((phase_44)(unsafe-car lst_99))((rest_48)(unsafe-cdr lst_99)))" +"(let-values(((fold-var_89)" +"(let-values(((fold-var_90) fold-var_38))" +"(let-values(((fold-var_91)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +" phase_44" +"(list*" +" 'list" +"(serialize-module-uses" +"(hash-ref" +" phase-to-link-module-uses_0" +" phase_44)" +" mpis_5))))" +" fold-var_90))))" +"(values fold-var_91)))))" +"(if(not #f)(for-loop_113 fold-var_89 rest_48) fold-var_89)))" +" fold-var_38)))))" +" for-loop_113)" +" null" +" lst_98))))))))))" +"(define-values" +"(generate-deserialize6.1)" +"(lambda(syntax-support?2_0 syntax-support?3_0 v4_0 mpis5_0)" +"(begin" +" 'generate-deserialize6" +"(let-values(((v_136) v4_0))" +"(let-values(((mpis_6) mpis5_0))" +"(let-values(((syntax-support?_0)(if syntax-support?3_0 syntax-support?2_0 #t)))" +"(let-values()" +"(let-values(((reachable-scopes_6)(find-reachable-scopes v_136)))" +"(let-values(((state_22)(make-serialize-state reachable-scopes_6)))" +"(let-values(((mutables_0)(make-hasheq)))" +"(let-values(((objs_0)(make-hasheq)))" +"(let-values(((shares_0)(make-hasheq)))" +"(let-values(((obj-step_0) 0))" +"(let-values(((frontier_0) null))" +"(letrec-values(((add-frontier!_0)" +"(case-lambda" +"((v_137)(begin 'add-frontier!(set! frontier_0(cons v_137 frontier_0))))" +"((kind_3 v_73)(add-frontier!_0 v_73)))))" +"(let-values((()" +"(begin" +"((letrec-values(((frontier-loop_0)" +"(lambda(v_138)" +"(begin" +" 'frontier-loop" +"(begin" +"((letrec-values(((loop_80)" +"(lambda(v_96)" +"(begin" +" 'loop" +"(if(let-values(((or-part_174)" +"(interned-literal?" +" v_96)))" +"(if or-part_174" +" or-part_174" +"(1/module-path-index?" +" v_96)))" +"(let-values()(void))" +"(if(hash-ref" +" objs_0" +" v_96" +" #f)" +"(let-values()" +"(if(hash-ref" +" mutables_0" +" v_96" +" #f)" +"(void)" +"(let-values()" +"(hash-set!" +" shares_0" +" v_96" +" #t))))" +"(let-values()" +"(begin" +"(if(serialize-fill!?" +" v_96)" +"(let-values()" +"(begin" +"(hash-set!" +" mutables_0" +" v_96" +"(hash-count" +" mutables_0))" +"((serialize-fill!-ref" +" v_96)" +" v_96" +" add-frontier!_0" +" state_22)))" +"(if(serialize?" +" v_96)" +"(let-values()" +"((serialize-ref" +" v_96)" +" v_96" +"(case-lambda" +"((sub-v_0)" +"(loop_80" +" sub-v_0))" +"((kind_4" +" sub-v_1)" +"(loop_80" +" sub-v_1)))" +" state_22))" +"(if(pair? v_96)" +"(let-values()" +"(begin" +"(loop_80" +"(car" +" v_96))" +"(loop_80" +"(cdr" +" v_96))))" +"(if(vector?" +" v_96)" +"(let-values()" +"(if(let-values(((or-part_92)" +"(immutable?" +" v_96)))" +"(if or-part_92" +" or-part_92" +"(zero?" +"(vector-length" +" v_96))))" +"(begin" +"(let-values(((vec_34" +" len_15)" +"(let-values(((vec_35)" +" v_96))" +"(begin" +"(check-vector" +" vec_35)" +"(values" +" vec_35" +"(unsafe-vector-length" +" vec_35))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_114)" +"(lambda(pos_22)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_22" +" len_15)" +"(let-values(((e_18)" +"(unsafe-vector-ref" +" vec_34" +" pos_22)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_80" +" e_18))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_114" +"(unsafe-fx+" +" 1" +" pos_22))" +"(values))))" +"(values))))))" +" for-loop_114)" +" 0)))" +"(void))" +"(begin" +"(hash-set!" +" mutables_0" +" v_96" +"(hash-count" +" mutables_0))" +"(begin" +"(let-values(((vec_36" +" len_16)" +"(let-values(((vec_37)" +" v_96))" +"(begin" +"(check-vector" +" vec_37)" +"(values" +" vec_37" +"(unsafe-vector-length" +" vec_37))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_115)" +"(lambda(pos_23)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_23" +" len_16)" +"(let-values(((e_19)" +"(unsafe-vector-ref" +" vec_36" +" pos_23)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(add-frontier!_0" +" e_19))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_115" +"(unsafe-fx+" +" 1" +" pos_23))" +"(values))))" +"(values))))))" +" for-loop_115)" +" 0)))" +"(void)))))" +"(if(box?" +" v_96)" +"(let-values()" +"(if(immutable?" +" v_96)" +"(loop_80" +"(unbox" +" v_96))" +"(begin" +"(hash-set!" +" mutables_0" +" v_96" +"(hash-count" +" mutables_0))" +"(add-frontier!_0" +"(unbox" +" v_96)))))" +"(if(hash?" +" v_96)" +"(let-values()" +"(if(immutable?" +" v_96)" +"(begin" +"(let-values(((lst_100)" +"(sorted-hash-keys" +" v_96)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_100)))" +"((letrec-values(((for-loop_116)" +"(lambda(lst_101)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_101)" +"(let-values(((k_20)" +"(unsafe-car" +" lst_101))" +"((rest_49)" +"(unsafe-cdr" +" lst_101)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(loop_80" +" k_20)" +"(loop_80" +"(hash-ref" +" v_96" +" k_20))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_116" +" rest_49)" +"(values))))" +"(values))))))" +" for-loop_116)" +" lst_100)))" +"(void))" +"(begin" +"(hash-set!" +" mutables_0" +" v_96" +"(hash-count" +" mutables_0))" +"(begin" +"(let-values(((lst_102)" +"(sorted-hash-keys" +" v_96)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_102)))" +"((letrec-values(((for-loop_117)" +"(lambda(lst_103)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_103)" +"(let-values(((k_21)" +"(unsafe-car" +" lst_103))" +"((rest_50)" +"(unsafe-cdr" +" lst_103)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(add-frontier!_0" +" k_21)" +"(add-frontier!_0" +"(hash-ref" +" v_96" +" k_21))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_117" +" rest_50)" +"(values))))" +"(values))))))" +" for-loop_117)" +" lst_102)))" +"(void)))))" +"(if(prefab-struct-key" +" v_96)" +"(let-values()" +"(begin" +"(let-values(((v*_2" +" start*_1" +" stop*_2" +" step*_1)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_44)" +"(vector?" +" x_44))" +"(lambda(x_45)" +"(unsafe-vector-length" +" x_45))" +"(struct->vector" +" v_96)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_72)" +"(lambda(idx_1)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" idx_1" +" stop*_2)" +"(let-values(((e_20)" +"(unsafe-vector-ref" +" v*_2" +" idx_1)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_80" +" e_20))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_72" +"(unsafe-fx+" +" idx_1" +" 1))" +"(values))))" +"(values))))))" +" for-loop_72)" +" start*_1)))" +"(void)))" +"(if(srcloc?" +" v_96)" +"(let-values()" +"(begin" +"(let-values(((v*_3" +" start*_2" +" stop*_3" +" step*_2)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_46)" +"(vector?" +" x_46))" +"(lambda(x_47)" +"(unsafe-vector-length" +" x_47))" +"(struct->vector" +" v_96)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_118)" +"(lambda(idx_2)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" idx_2" +" stop*_3)" +"(let-values(((e_21)" +"(unsafe-vector-ref" +" v*_3" +" idx_2)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_80" +" e_21))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_118" +"(unsafe-fx+" +" idx_2" +" 1))" +"(values))))" +"(values))))))" +" for-loop_118)" +" start*_2)))" +"(void)))" +"(let-values()" +"(void))))))))))" +"(hash-set!" +" objs_0" +" v_96" +" obj-step_0)" +"(set! obj-step_0" +"(add1" +" obj-step_0))))))))))" +" loop_80)" +" v_138)" +"(if(null? frontier_0)" +"(void)" +"(let-values()" +"(let-values(((l_49) frontier_0))" +"(begin" +"(set! frontier_0 null)" +"(let-values(((lst_104) l_49))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_104)))" +"((letrec-values(((for-loop_119)" +"(lambda(lst_105)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_105)" +"(let-values(((v_139)" +"(unsafe-car" +" lst_105))" +"((rest_51)" +"(unsafe-cdr" +" lst_105)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(frontier-loop_0" +" v_139))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_119" +" rest_51)" +"(values))))" +"(values))))))" +" for-loop_119)" +" lst_104)))" +"(void))))))))))" +" frontier-loop_0)" +" v_136)" +"(values))))" +"(let-values(((num-mutables_0)(hash-count mutables_0)))" +"(let-values(((share-step-positions_0)" +"(let-values(((share-steps_0)" +"(reverse$1" +"(let-values(((ht_83) shares_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_83)))" +"((letrec-values(((for-loop_120)" +"(lambda(fold-var_92 i_104)" +"(begin" +" 'for-loop" +"(if i_104" +"(let-values(((obj_0)" +"(hash-iterate-key" +" ht_83" +" i_104)))" +"(let-values(((fold-var_93)" +"(let-values(((fold-var_94)" +" fold-var_92))" +"(let-values(((fold-var_95)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +" objs_0" +" obj_0))" +" fold-var_94))))" +"(values" +" fold-var_95)))))" +"(if(not #f)" +"(for-loop_120" +" fold-var_93" +"(hash-iterate-next" +" ht_83" +" i_104))" +" fold-var_93)))" +" fold-var_92)))))" +" for-loop_120)" +" null" +"(hash-iterate-first ht_83)))))))" +"(let-values(((lst_106)" +"(let-values(((share-steps12_0) share-steps_0)" +"((<13_0) <))" +"(sort7.1 #f #f #f #f share-steps12_0 <13_0)))" +"((start_20) num-mutables_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_106)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_20)))" +"((letrec-values(((for-loop_121)" +"(lambda(table_107 lst_107 pos_24)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_107) #t #f)" +"(let-values(((step_3)" +"(unsafe-car lst_107))" +"((rest_52)" +"(unsafe-cdr lst_107))" +"((pos_25) pos_24))" +"(let-values(((table_108)" +"(let-values(((table_109)" +" table_107))" +"(let-values(((table_110)" +"(let-values()" +"(let-values(((key_44" +" val_38)" +"(let-values()" +"(values" +" step_3" +" pos_25))))" +"(hash-set" +" table_109" +" key_44" +" val_38)))))" +"(values table_110)))))" +"(if(not #f)" +"(for-loop_121" +" table_108" +" rest_52" +"(+ pos_24 1))" +" table_108)))" +" table_107)))))" +" for-loop_121)" +" '#hasheqv()" +" lst_106" +" start_20))))))" +"(let-values(((stream_0) null))" +"(let-values(((stream-size_0) 0))" +"(let-values(((next-push-position_0)" +"(lambda()(begin 'next-push-position stream-size_0))))" +"(let-values(((quoted?_0)" +"(lambda(pos_26)" +"(begin" +" 'quoted?" +"(let-values(((v_140)" +"(list-ref" +" stream_0" +"(- stream-size_0(add1 pos_26)))))" +"(let-values(((or-part_175)(not(keyword? v_140))))" +"(if or-part_175 or-part_175(eq? '#:quote v_140))))))))" +"(let-values(((ser-reset!_0)" +"(lambda(pos_27)" +"(begin" +" 'ser-reset!" +"(begin" +"(set! stream_0" +"(list-tail stream_0(- stream-size_0 pos_27)))" +"(set! stream-size_0 pos_27))))))" +"(let-values(((reap-stream!_0)" +"(lambda()" +"(begin" +" 'reap-stream!" +"(begin0" +"(list->vector(reverse$1 stream_0))" +"(set! stream_0 null)" +"(set! stream-size_0 0))))))" +"(letrec-values(((ser-push!_15)" +"(case-lambda" +"((v_141)" +"(begin" +" 'ser-push!" +"(if(hash-ref shares_0 v_141 #f)" +"(let-values()" +"(let-values(((n_21)" +"(hash-ref" +" share-step-positions_0" +"(hash-ref objs_0 v_141))))" +"(begin" +"(ser-push!_15 'tag '#:ref)" +"(ser-push!_15 'exact n_21))))" +"(let-values(((c1_23)" +"(hash-ref mutables_0 v_141 #f)))" +"(if c1_23" +"((lambda(n_22)" +"(begin" +"(ser-push!_15 'tag '#:ref)" +"(ser-push!_15 'exact n_22)))" +" c1_23)" +"(let-values()" +"(ser-push-encoded!_0 v_141)))))))" +"((kind_5 v_142)" +"(let-values(((tmp_18) kind_5))" +"(if(equal? tmp_18 'exact)" +"(let-values()" +"(begin" +"(set! stream_0(cons v_142 stream_0))" +"(set! stream-size_0(add1 stream-size_0))))" +"(if(equal? tmp_18 'tag)" +"(let-values()(ser-push!_15 'exact v_142))" +"(if(equal? tmp_18 'reference)" +"(let-values()" +"(if(hash-ref shares_0 v_142 #f)" +"(let-values()" +"(let-values(((n_23)" +"(hash-ref" +" share-step-positions_0" +"(hash-ref" +" objs_0" +" v_142))))" +"(ser-push!_15 'exact n_23)))" +"(let-values(((c2_1)" +"(hash-ref" +" mutables_0" +" v_142" +" #f)))" +"(if c2_1" +"((lambda(n_24)" +"(ser-push!_15 'exact n_24))" +" c2_1)" +"(let-values()" +"(ser-push!_15 v_142))))))" +"(let-values()(ser-push!_15 v_142)))))))))" +"((ser-push-encoded!_0)" +"(lambda(v_143)" +"(begin" +" 'ser-push-encoded!" +"(if(keyword? v_143)" +"(let-values()" +"(begin" +"(ser-push!_15 'tag '#:quote)" +"(ser-push!_15 'exact v_143)))" +"(if(1/module-path-index? v_143)" +"(let-values()" +"(begin" +"(ser-push!_15 'tag '#:mpi)" +"(ser-push!_15" +" 'exact" +"(add-module-path-index!/pos" +" mpis_6" +" v_143))))" +"(if(serialize? v_143)" +"(let-values()" +"((serialize-ref v_143)" +" v_143" +" ser-push!_15" +" state_22))" +"(if(if(list? v_143)" +"(if(pair? v_143)" +"(pair?(cdr v_143))" +" #f)" +" #f)" +"(let-values()" +"(let-values(((start-pos_0)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'tag" +" '#:list)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'exact" +"(length v_143))" +"(values))))" +"(let-values(((all-quoted?_0)" +"(let-values(((lst_108)" +" v_143))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_108)))" +"((letrec-values(((for-loop_122)" +"(lambda(all-quoted?_1" +" lst_42)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_42)" +"(let-values(((i_105)" +"(unsafe-car" +" lst_42))" +"((rest_53)" +"(unsafe-cdr" +" lst_42)))" +"(let-values(((all-quoted?_2)" +"(let-values(((all-quoted?_3)" +" all-quoted?_1))" +"(let-values(((all-quoted?_4)" +"(let-values()" +"(let-values(((i-pos_0)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_15" +" i_105)" +"(if all-quoted?_3" +"(quoted?_0" +" i-pos_0)" +" #f))))))" +"(values" +" all-quoted?_4)))))" +"(if(not" +" #f)" +"(for-loop_122" +" all-quoted?_2" +" rest_53)" +" all-quoted?_2)))" +" all-quoted?_1)))))" +" for-loop_122)" +" #t" +" lst_108)))))" +"(if all-quoted?_0" +"(let-values()" +"(begin" +"(ser-reset!_0 start-pos_0)" +"(ser-push-optional-quote!_0)" +"(ser-push!_15" +" 'exact" +" v_143)))" +"(void)))))))" +"(if(pair? v_143)" +"(let-values()" +"(let-values(((start-pos_1)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'tag" +" '#:cons)" +"(values))))" +"(let-values(((a-pos_0)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_15" +"(car v_143))" +"(values))))" +"(let-values(((d-pos_0)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_15(cdr v_143))" +"(if(if(quoted?_0 a-pos_0)" +"(quoted?_0 d-pos_0)" +" #f)" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_1)" +"(ser-push-optional-quote!_0)" +"(ser-push!_15" +" 'exact" +" v_143)))" +"(void)))))))))" +"(if(box? v_143)" +"(let-values()" +"(let-values(((start-pos_2)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'tag" +" '#:box)" +"(values))))" +"(let-values(((v-pos_0)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_15(unbox v_143))" +"(if(quoted?_0 v-pos_0)" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_2)" +"(ser-push-optional-quote!_0)" +"(ser-push!_15" +" 'exact" +" v_143)))" +"(void)))))))" +"(if(vector? v_143)" +"(let-values()" +"(let-values(((start-pos_3)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'tag" +" '#:vector)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'exact" +"(vector-length" +" v_143))" +"(values))))" +"(let-values(((all-quoted?_5)" +"(let-values(((vec_38" +" len_17)" +"(let-values(((vec_39)" +" v_143))" +"(begin" +"(check-vector" +" vec_39)" +"(values" +" vec_39" +"(unsafe-vector-length" +" vec_39))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_123)" +"(lambda(all-quoted?_6" +" pos_28)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_28" +" len_17)" +"(let-values(((i_106)" +"(unsafe-vector-ref" +" vec_38" +" pos_28)))" +"(let-values(((all-quoted?_7)" +"(let-values(((all-quoted?_8)" +" all-quoted?_6))" +"(let-values(((all-quoted?_9)" +"(let-values()" +"(let-values(((i-pos_1)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_15" +" i_106)" +"(if all-quoted?_8" +"(quoted?_0" +" i-pos_1)" +" #f))))))" +"(values" +" all-quoted?_9)))))" +"(if(not" +" #f)" +"(for-loop_123" +" all-quoted?_7" +"(unsafe-fx+" +" 1" +" pos_28))" +" all-quoted?_7)))" +" all-quoted?_6)))))" +" for-loop_123)" +" #t" +" 0)))))" +"(if all-quoted?_5" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_3)" +"(ser-push-optional-quote!_0)" +"(ser-push!_15" +" 'exact" +" v_143)))" +"(void)))))))" +"(if(hash? v_143)" +"(let-values()" +"(let-values(((start-pos_4)" +"(next-push-position_0)))" +"(let-values(((as-set?_0)" +"(let-values(((ht_84)" +" v_143))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-values" +" ht_84)))" +"((letrec-values(((for-loop_124)" +"(lambda(result_64" +" i_107)" +"(begin" +" 'for-loop" +"(if i_107" +"(let-values(((val_39)" +"(hash-iterate-value" +" ht_84" +" i_107)))" +"(let-values(((result_65)" +"(let-values()" +"(let-values(((result_66)" +"(let-values()" +"(let-values()" +"(eq?" +" val_39" +" #t)))))" +"(values" +" result_66)))))" +"(if(if(not" +"((lambda x_48" +"(not" +" result_65))" +" val_39))" +"(not" +" #f)" +" #f)" +"(for-loop_124" +" result_65" +"(hash-iterate-next" +" ht_84" +" i_107))" +" result_65)))" +" result_64)))))" +" for-loop_124)" +" #t" +"(hash-iterate-first" +" ht_84))))))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'tag" +"(if as-set?_0" +"(if(hash-eq?" +" v_143)" +"(let-values()" +" '#:seteq)" +"(if(hash-eqv?" +" v_143)" +"(let-values()" +" '#:seteqv)" +"(let-values()" +" '#:set)))" +"(if(hash-eq?" +" v_143)" +"(let-values()" +" '#:hasheq)" +"(if(hash-eqv?" +" v_143)" +"(let-values()" +" '#:hasheqv)" +"(let-values()" +" '#:hash)))))" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'exact" +"(hash-count" +" v_143))" +"(values))))" +"(let-values(((ks_0)" +"(sorted-hash-keys" +" v_143)))" +"(let-values(((all-quoted?_10)" +"(let-values(((lst_109)" +" ks_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_109)))" +"((letrec-values(((for-loop_125)" +"(lambda(all-quoted?_11" +" lst_110)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_110)" +"(let-values(((k_22)" +"(unsafe-car" +" lst_110))" +"((rest_54)" +"(unsafe-cdr" +" lst_110)))" +"(let-values(((all-quoted?_12)" +"(let-values(((all-quoted?_13)" +" all-quoted?_11))" +"(let-values(((all-quoted?_14)" +"(let-values()" +"(let-values(((k-pos_0)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" k_22)" +"(values))))" +"(let-values(((v-pos_1)" +"(next-push-position_0)))" +"(begin" +"(if as-set?_0" +"(void)" +"(let-values()" +"(ser-push!_15" +"(hash-ref" +" v_143" +" k_22))))" +"(if all-quoted?_13" +"(if(quoted?_0" +" k-pos_0)" +"(let-values(((or-part_176)" +" as-set?_0))" +"(if or-part_176" +" or-part_176" +"(quoted?_0" +" v-pos_1)))" +" #f)" +" #f))))))))" +"(values" +" all-quoted?_14)))))" +"(if(not" +" #f)" +"(for-loop_125" +" all-quoted?_12" +" rest_54)" +" all-quoted?_12)))" +" all-quoted?_11)))))" +" for-loop_125)" +" #t" +" lst_109)))))" +"(if all-quoted?_10" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_4)" +"(ser-push-optional-quote!_0)" +"(ser-push!_15" +" 'exact" +" v_143)))" +"(void)))))))))" +"(let-values(((c3_0)" +"(prefab-struct-key" +" v_143)))" +"(if c3_0" +"((lambda(k_23)" +"(let-values(((vec_40)" +"(struct->vector" +" v_143)))" +"(let-values(((start-pos_5)" +"(next-push-position_0)))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'tag" +" '#:prefab)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'exact" +" k_23)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'exact" +"(sub1" +"(vector-length" +" vec_40)))" +"(values))))" +"(let-values(((all-quoted?_15)" +"(let-values(((v*_4" +" start*_3" +" stop*_4" +" step*_3)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_49)" +"(vector?" +" x_49))" +"(lambda(x_50)" +"(unsafe-vector-length" +" x_50))" +" vec_40" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_126)" +"(lambda(all-quoted?_16" +" idx_3)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" idx_3" +" stop*_4)" +"(let-values(((i_108)" +"(unsafe-vector-ref" +" v*_4" +" idx_3)))" +"(let-values(((all-quoted?_17)" +"(let-values(((all-quoted?_18)" +" all-quoted?_16))" +"(let-values(((all-quoted?_19)" +"(let-values()" +"(let-values(((i-pos_2)" +"(next-push-position_0)))" +"(begin" +"(ser-push!_15" +" i_108)" +"(if all-quoted?_18" +"(quoted?_0" +" i-pos_2)" +" #f))))))" +"(values" +" all-quoted?_19)))))" +"(if(not" +" #f)" +"(for-loop_126" +" all-quoted?_17" +"(unsafe-fx+" +" idx_3" +" 1))" +" all-quoted?_17)))" +" all-quoted?_16)))))" +" for-loop_126)" +" #t" +" start*_3)))))" +"(if all-quoted?_15" +"(let-values()" +"(begin" +"(ser-reset!_0" +" start-pos_5)" +"(ser-push-optional-quote!_0)" +"(ser-push!_15" +" 'exact" +" v_143)))" +"(void)))))))))" +" c3_0)" +"(if(srcloc? v_143)" +"(let-values()" +"(begin" +"(ser-push!_15" +" 'tag" +" '#:srcloc)" +"(ser-push!_15" +"(srcloc-source v_143))" +"(ser-push!_15" +"(srcloc-line v_143))" +"(ser-push!_15" +"(srcloc-column v_143))" +"(ser-push!_15" +"(srcloc-position v_143))" +"(ser-push!_15" +"(srcloc-span v_143))))" +"(let-values()" +"(begin" +"(ser-push-optional-quote!_0)" +"(ser-push!_15" +" 'exact" +" v_143)))))))))))))))))" +"((ser-push-optional-quote!_0)" +"(lambda()(begin 'ser-push-optional-quote!(void)))))" +"(let-values(((ser-shell!_0)" +"(lambda(v_144)" +"(begin" +" 'ser-shell!" +"(if(serialize-fill!? v_144)" +"(let-values()" +"((serialize-ref v_144)" +" v_144" +" ser-push!_15" +" state_22))" +"(if(box? v_144)" +"(let-values()(ser-push!_15 'tag '#:box))" +"(if(vector? v_144)" +"(let-values()" +"(begin" +"(ser-push!_15 'tag '#:vector)" +"(ser-push!_15" +" 'exact" +"(vector-length v_144))))" +"(if(hash? v_144)" +"(let-values()" +"(ser-push!_15" +" 'tag" +"(if(hash-eq? v_144)" +"(let-values() '#:hasheq)" +"(if(hash-eqv? v_144)" +"(let-values() '#:hasheqv)" +"(let-values() '#:hash)))))" +"(let-values()" +"(error" +" 'ser-shell" +" \"unknown mutable: ~e\"" +" v_144))))))))))" +"(let-values(((ser-shell-fill!_0)" +"(lambda(v_145)" +"(begin" +" 'ser-shell-fill!" +"(if(serialize-fill!? v_145)" +"(let-values()" +"((serialize-fill!-ref v_145)" +" v_145" +" ser-push!_15" +" state_22))" +"(if(box? v_145)" +"(let-values()" +"(begin" +"(ser-push!_15 'tag '#:set-box!)" +"(ser-push!_15(unbox v_145))))" +"(if(vector? v_145)" +"(let-values()" +"(begin" +"(ser-push!_15 'tag '#:set-vector!)" +"(ser-push!_15" +" 'exact" +"(vector-length v_145))" +"(let-values(((vec_41 len_18)" +"(let-values(((vec_42)" +" v_145))" +"(begin" +"(check-vector vec_42)" +"(values" +" vec_42" +"(unsafe-vector-length" +" vec_42))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_127)" +"(lambda(pos_29)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_29" +" len_18)" +"(let-values(((v_146)" +"(unsafe-vector-ref" +" vec_41" +" pos_29)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-push!_15" +" v_146))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_127" +"(unsafe-fx+" +" 1" +" pos_29))" +"(values))))" +"(values))))))" +" for-loop_127)" +" 0)))" +"(void)))" +"(if(hash? v_145)" +"(let-values()" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'tag" +" '#:set-hash!)" +"(values))))" +"(let-values((()" +"(begin" +"(ser-push!_15" +" 'exact" +"(hash-count v_145))" +"(values))))" +"(let-values(((ks_1)" +"(sorted-hash-keys" +" v_145)))" +"(begin" +"(let-values(((lst_111) ks_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_111)))" +"((letrec-values(((for-loop_128)" +"(lambda(lst_112)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_112)" +"(let-values(((k_24)" +"(unsafe-car" +" lst_112))" +"((rest_55)" +"(unsafe-cdr" +" lst_112)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(ser-push!_15" +" k_24)" +"(ser-push!_15" +"(hash-ref" +" v_145" +" k_24))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_128" +" rest_55)" +"(values))))" +"(values))))))" +" for-loop_128)" +" lst_111)))" +"(void))))))" +"(let-values()" +"(error" +" 'ser-shell-fill" +" \"unknown mutable: ~e\"" +" v_145))))))))))" +"(let-values(((rev-mutables_0)" +"(let-values(((ht_85) mutables_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_85)))" +"((letrec-values(((for-loop_129)" +"(lambda(table_111 i_109)" +"(begin" +" 'for-loop" +"(if i_109" +"(let-values(((k_25" +" v_147)" +"(hash-iterate-key+value" +" ht_85" +" i_109)))" +"(let-values(((table_112)" +"(let-values(((table_113)" +" table_111))" +"(let-values(((table_114)" +"(let-values()" +"(let-values(((key_45" +" val_40)" +"(let-values()" +"(values" +" v_147" +" k_25))))" +"(hash-set" +" table_113" +" key_45" +" val_40)))))" +"(values" +" table_114)))))" +"(if(not #f)" +"(for-loop_129" +" table_112" +"(hash-iterate-next" +" ht_85" +" i_109))" +" table_112)))" +" table_111)))))" +" for-loop_129)" +" '#hasheqv()" +"(hash-iterate-first ht_85))))))" +"(let-values(((mutable-shell-bindings_0)" +"(begin" +"(begin" +"(let-values(((start_21) 0)" +"((end_13)" +"(hash-count mutables_0))" +"((inc_7) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range start_21 end_13 inc_7)))" +"((letrec-values(((for-loop_130)" +"(lambda(pos_30)" +"(begin" +" 'for-loop" +"(if(<" +" pos_30" +" end_13)" +"(let-values(((i_8)" +" pos_30))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-shell!_0" +"(hash-ref" +" rev-mutables_0" +" i_8)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_130" +"(+" +" pos_30" +" inc_7))" +"(values))))" +"(values))))))" +" for-loop_130)" +" start_21)))" +"(void))" +"(reap-stream!_0))))" +"(let-values(((rev-shares_0)" +"(let-values(((ht_86) shares_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-keys ht_86)))" +"((letrec-values(((for-loop_131)" +"(lambda(table_115 i_110)" +"(begin" +" 'for-loop" +"(if i_110" +"(let-values(((obj_1)" +"(hash-iterate-key" +" ht_86" +" i_110)))" +"(let-values(((table_116)" +"(let-values(((table_117)" +" table_115))" +"(let-values(((table_118)" +"(let-values()" +"(let-values(((key_46" +" val_41)" +"(let-values()" +"(values" +"(hash-ref" +" share-step-positions_0" +"(hash-ref" +" objs_0" +" obj_1))" +" obj_1))))" +"(hash-set" +" table_117" +" key_46" +" val_41)))))" +"(values" +" table_118)))))" +"(if(not #f)" +"(for-loop_131" +" table_116" +"(hash-iterate-next" +" ht_86" +" i_110))" +" table_116)))" +" table_115)))))" +" for-loop_131)" +" '#hasheqv()" +"(hash-iterate-first ht_86))))))" +"(let-values(((shared-bindings_0)" +"(begin" +"(begin" +"(let-values(((start_22) num-mutables_0)" +"((end_14)" +"(+" +" num-mutables_0" +"(hash-count shares_0)))" +"((inc_8) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range" +" start_22" +" end_14" +" inc_8)))" +"((letrec-values(((for-loop_132)" +"(lambda(pos_31)" +"(begin" +" 'for-loop" +"(if(<" +" pos_31" +" end_14)" +"(let-values(((i_111)" +" pos_31))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-push-encoded!_0" +"(hash-ref" +" rev-shares_0" +" i_111)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_132" +"(+" +" pos_31" +" inc_8))" +"(values))))" +"(values))))))" +" for-loop_132)" +" start_22)))" +"(void))" +"(reap-stream!_0))))" +"(let-values(((mutable-fills_0)" +"(begin" +"(begin" +"(let-values(((start_23) 0)" +"((end_15)" +"(hash-count mutables_0))" +"((inc_9) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range" +" start_23" +" end_15" +" inc_9)))" +"((letrec-values(((for-loop_133)" +"(lambda(pos_32)" +"(begin" +" 'for-loop" +"(if(<" +" pos_32" +" end_15)" +"(let-values(((i_112)" +" pos_32))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(ser-shell-fill!_0" +"(hash-ref" +" rev-mutables_0" +" i_112)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_133" +"(+" +" pos_32" +" inc_9))" +"(values))))" +"(values))))))" +" for-loop_133)" +" start_23)))" +"(void))" +"(reap-stream!_0))))" +"(list" +" 'deserialize" +" mpi-vector-id" +"(if syntax-support?_0 inspector-id #f)" +"(if syntax-support?_0 bulk-binding-registry-id #f)" +"(list 'quote(hash-count mutables_0))" +"(list 'quote mutable-shell-bindings_0)" +"(list 'quote(hash-count shares_0))" +"(list 'quote shared-bindings_0)" +"(list 'quote mutable-fills_0)" +"(list" +" 'quote" +"(begin" +"(ser-push!_15 v_136)" +"(reap-stream!_0))))))))))))))))))))))))))))))))))))" +"(define-values" +"(sorted-hash-keys)" +"(lambda(ht_87)" +"(begin" +"(let-values(((ks_2)(hash-keys ht_87)))" +"(if(null? ks_2)" +"(let-values() ks_2)" +"(if(null?(cdr ks_2))" +"(let-values() ks_2)" +"(if(andmap2 symbol? ks_2)" +"(let-values()" +"(let-values(((ks14_0) ks_2)((symbolsyntax . 5)" +"(#:syntax+props . 6)" +"(#:representative-scope . 22))" +" tmp_20" +"(lambda() 0))" +" 0)))" +"(if(unsafe-fx< index_0 13)" +"(if(unsafe-fx< index_0 6)" +"(if(unsafe-fx< index_0 2)" +"(if(unsafe-fx< index_0 1)" +"(let-values()(values(vector*-ref vec_45 pos_50)(add1 pos_50)))" +"(let-values()(values(vector*-ref shared_2(vector*-ref vec_45(add1 pos_50)))(+ pos_50 2))))" +"(if(unsafe-fx< index_0 3)" +"(let-values()(values inspector_7(add1 pos_50)))" +"(if(unsafe-fx< index_0 4)" +"(let-values()(values bulk-binding-registry_7(add1 pos_50)))" +"(if(unsafe-fx< index_0 5)" +"(let-values()" +"(let-values(((content_7 next-pos_2)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((context_2 next-pos_3)" +"(let-values(((i_115)(vector*-ref vec_45 next-pos_2)))" +"(if(exact-integer? i_115)" +"(values(vector*-ref shared_2 i_115)(add1 next-pos_2))" +"(decode" +" vec_45" +" next-pos_2" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((srcloc_3 next-pos_4)" +"(let-values(((i_116)(vector*-ref vec_45 next-pos_3)))" +"(if(exact-integer? i_116)" +"(values(vector*-ref shared_2 i_116)(add1 next-pos_3))" +"(decode" +" vec_45" +" next-pos_3" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))))" +"(values" +"(deserialize-syntax content_7 context_2 srcloc_3 #f #f inspector_7)" +" next-pos_4)))))" +"(let-values()" +"(let-values(((content_8 next-pos_5)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((context_3 next-pos_6)" +"(let-values(((i_117)(vector*-ref vec_45 next-pos_5)))" +"(if(exact-integer? i_117)" +"(values(vector*-ref shared_2 i_117)(add1 next-pos_5))" +"(decode" +" vec_45" +" next-pos_5" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((srcloc_4 next-pos_7)" +"(let-values(((i_118)(vector*-ref vec_45 next-pos_6)))" +"(if(exact-integer? i_118)" +"(values(vector*-ref shared_2 i_118)(add1 next-pos_6))" +"(decode" +" vec_45" +" next-pos_6" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))))" +"(values" +"(deserialize-datum->syntax content_8 context_3 srcloc_4 inspector_7)" +" next-pos_7)))))))))" +"(if(unsafe-fx< index_0 9)" +"(if(unsafe-fx< index_0 7)" +"(let-values()" +"(let-values(((content_9 next-pos_8)" +"(decode vec_45(add1 pos_50) mpis_9 inspector_7 bulk-binding-registry_7 shared_2)))" +"(let-values(((context_4 next-pos_9)" +"(let-values(((i_119)(vector*-ref vec_45 next-pos_8)))" +"(if(exact-integer? i_119)" +"(values(vector*-ref shared_2 i_119)(add1 next-pos_8))" +"(decode" +" vec_45" +" next-pos_8" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((srcloc_5 next-pos_10)" +"(let-values(((i_120)(vector*-ref vec_45 next-pos_9)))" +"(if(exact-integer? i_120)" +"(values(vector*-ref shared_2 i_120)(add1 next-pos_9))" +"(decode" +" vec_45" +" next-pos_9" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))))" +"(let-values(((props_1 next-pos_11)" +"(decode" +" vec_45" +" next-pos_10" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((tamper_2 next-pos_12)" +"(decode" +" vec_45" +" next-pos_11" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-syntax content_9 context_4 srcloc_5 props_1 tamper_2 inspector_7)" +" next-pos_12)))))))" +"(if(unsafe-fx< index_0 8)" +"(let-values()" +"(let-values(((source_0 next-pos_13)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((line_0 next-pos_14)" +"(decode" +" vec_45" +" next-pos_13" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((column_0 next-pos_15)" +"(decode" +" vec_45" +" next-pos_14" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((position_0 next-pos_16)" +"(decode" +" vec_45" +" next-pos_15" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((span_0 next-pos_17)" +"(decode" +" vec_45" +" next-pos_16" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(srcloc source_0 line_0 column_0 position_0 span_0) next-pos_17)))))))" +"(let-values()(values(vector*-ref vec_45(add1 pos_50))(+ pos_50 2)))))" +"(if(unsafe-fx< index_0 10)" +"(let-values()(values(vector*-ref mpis_9(vector*-ref vec_45(add1 pos_50)))(+ pos_50 2)))" +"(if(unsafe-fx< index_0 11)" +"(let-values()" +"(let-values(((v_149 next-pos_18)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(box-immutable v_149) next-pos_18)))" +"(if(unsafe-fx< index_0 12)" +"(let-values()" +"(let-values(((a_38 next-pos_19)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((d_24 next-pos_20)" +"(decode" +" vec_45" +" next-pos_19" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(cons a_38 d_24) next-pos_20))))" +"(let-values()" +"(let-values(((len_20)(vector*-ref vec_45(add1 pos_50))))" +"(let-values(((r_29)(make-vector len_20)))" +"(let-values(((next-pos_21)" +"(let-values(((start_27) 0)((end_19) len_20)((inc_13) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_27 end_19 inc_13)))" +"((letrec-values(((for-loop_137)" +"(lambda(pos_51 pos_52)" +"(begin" +" 'for-loop" +"(if(< pos_52 end_19)" +"(let-values(((i_121) pos_52))" +"(let-values(((pos_53)" +"(let-values(((pos_54) pos_51))" +"(let-values(((pos_55)" +"(let-values()" +"(let-values(((v_150" +" next-pos_22)" +"(let-values(((v_151" +" next-pos_23)" +"(decode" +" vec_45" +" pos_54" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +" v_151" +" next-pos_23))))" +"(begin" +"(vector-set!" +" r_29" +" i_121" +" v_150)" +" next-pos_22)))))" +"(values pos_55)))))" +"(if(not #f)" +"(for-loop_137 pos_53(+ pos_52 inc_13))" +" pos_53)))" +" pos_51)))))" +" for-loop_137)" +"(+ pos_50 2)" +" start_27)))))" +"(values" +"(if(eq?(vector*-ref vec_45 pos_50) '#:list)" +"(vector->list r_29)" +"(vector->immutable-vector r_29))" +" next-pos_21))))))))))" +"(if(unsafe-fx< index_0 20)" +"(if(unsafe-fx< index_0 16)" +"(if(unsafe-fx< index_0 14)" +"(let-values()" +"(let-values(((ht_88)" +"(let-values(((tmp_21)(vector*-ref vec_45 pos_50)))" +"(if(equal? tmp_21 '#:hash)" +"(let-values()(hash))" +"(if(equal? tmp_21 '#:hasheq)" +"(let-values()(hasheq))" +"(if(equal? tmp_21 '#:hasheqv)" +"(let-values()(hasheqv))" +"(let-values()(void))))))))" +"(let-values(((len_21)(vector*-ref vec_45(add1 pos_50))))" +"(let-values(((start_28) 0)((end_20) len_21)((inc_14) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_28 end_20 inc_14)))" +"((letrec-values(((for-loop_138)" +"(lambda(ht_89 pos_56 pos_57)" +"(begin" +" 'for-loop" +"(if(< pos_57 end_20)" +"(let-values()" +"(let-values(((ht_90 pos_58)" +"(let-values(((ht_91) ht_89)((pos_59) pos_56))" +"(let-values(((ht_92 pos_60)" +"(let-values()" +"(let-values(((k_26 next-pos_24)" +"(decode" +" vec_45" +" pos_59" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((v_152" +" next-pos_25)" +"(decode" +" vec_45" +" next-pos_24" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(hash-set ht_91 k_26 v_152)" +" next-pos_25))))))" +"(values ht_92 pos_60)))))" +"(if(not #f)" +"(for-loop_138 ht_90 pos_58(+ pos_57 inc_14))" +"(values ht_90 pos_58))))" +"(values ht_89 pos_56))))))" +" for-loop_138)" +" ht_88" +"(+ pos_50 2)" +" start_28))))))" +"(if(unsafe-fx< index_0 15)" +"(let-values()" +"(let-values(((s_137)" +"(let-values(((tmp_22)(vector*-ref vec_45 pos_50)))" +"(if(equal? tmp_22 '#:set)" +"(let-values()(set))" +"(if(equal? tmp_22 '#:seteq)" +"(let-values()(seteq))" +"(if(equal? tmp_22 '#:seteqv)" +"(let-values()(seteqv))" +"(let-values()(void))))))))" +"(let-values(((len_22)(vector*-ref vec_45(add1 pos_50))))" +"(let-values(((start_29) 0)((end_21) len_22)((inc_15) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_29 end_21 inc_15)))" +"((letrec-values(((for-loop_139)" +"(lambda(s_188 pos_61 pos_62)" +"(begin" +" 'for-loop" +"(if(< pos_62 end_21)" +"(let-values()" +"(let-values(((s_139 pos_63)" +"(let-values(((s_189) s_188)((pos_64) pos_61))" +"(let-values(((s_190 pos_65)" +"(let-values()" +"(let-values(((k_27" +" next-pos_26)" +"(decode" +" vec_45" +" pos_64" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(set-add s_189 k_27)" +" next-pos_26)))))" +"(values s_190 pos_65)))))" +"(if(not #f)" +"(for-loop_139 s_139 pos_63(+ pos_62 inc_15))" +"(values s_139 pos_63))))" +"(values s_188 pos_61))))))" +" for-loop_139)" +" s_137" +"(+ pos_50 2)" +" start_29))))))" +"(let-values()" +"(let-values(((key_47 next-pos_27)" +"(let-values(((k_28 next-pos_28)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values k_28 next-pos_28))))" +"(let-values(((len_23)(vector*-ref vec_45 next-pos_27)))" +"(let-values(((r_30 done-pos_1)" +"(let-values(((start_30) 0)((end_22) len_23)((inc_16) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_30 end_22 inc_16)))" +"((letrec-values(((for-loop_140)" +"(lambda(r_31 pos_66 pos_67)" +"(begin" +" 'for-loop" +"(if(< pos_67 end_22)" +"(let-values()" +"(let-values(((r_32 pos_68)" +"(let-values(((r_33) r_31)" +"((pos_69) pos_66))" +"(let-values(((r_34 pos_70)" +"(let-values()" +"(let-values(((v_153" +" next-pos_29)" +"(decode" +" vec_45" +" pos_69" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(cons" +" v_153" +" r_33)" +" next-pos_29)))))" +"(values r_34 pos_70)))))" +"(if(not #f)" +"(for-loop_140 r_32 pos_68(+ pos_67 inc_16))" +"(values r_32 pos_68))))" +"(values r_31 pos_66))))))" +" for-loop_140)" +" null" +"(add1 next-pos_27)" +" start_30)))))" +"(values(apply make-prefab-struct key_47(reverse$1 r_30)) done-pos_1)))))))" +"(if(unsafe-fx< index_0 17)" +"(let-values()(values(deserialize-scope)(add1 pos_50)))" +"(if(unsafe-fx< index_0 18)" +"(let-values()" +"(let-values(((kind_6 next-pos_30)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-scope kind_6) next-pos_30)))" +"(if(unsafe-fx< index_0 19)" +"(let-values()" +"(let-values(((name_37 next-pos_31)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((scopes_21 next-pos_32)" +"(decode" +" vec_45" +" next-pos_31" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-multi-scope name_37 scopes_21) next-pos_32))))" +"(let-values()" +"(let-values(((phase_45 next-pos_33)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((multi-scope_2 next-pos_34)" +"(decode" +" vec_45" +" next-pos_33" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-shifted-multi-scope phase_45 multi-scope_2) next-pos_34))))))))" +"(if(unsafe-fx< index_0 23)" +"(if(unsafe-fx< index_0 21)" +"(let-values()" +"(let-values(((syms_13 next-pos_35)" +"(decode vec_45(add1 pos_50) mpis_9 inspector_7 bulk-binding-registry_7 shared_2)))" +"(let-values(((bulk-bindings_4 next-pos_36)" +"(decode vec_45 next-pos_35 mpis_9 inspector_7 bulk-binding-registry_7 shared_2)))" +"(values(deserialize-table-with-bulk-bindings syms_13 bulk-bindings_4) next-pos_36))))" +"(if(unsafe-fx< index_0 22)" +"(let-values()" +"(let-values(((scopes_22 next-pos_37)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((bulk_5 next-pos_38)" +"(decode" +" vec_45" +" next-pos_37" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-bulk-binding-at scopes_22 bulk_5) next-pos_38))))" +"(let-values()" +"(let-values(((kind_7 next-pos_39)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase_46 next-pos_40)" +"(decode" +" vec_45" +" next-pos_39" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-representative-scope kind_7 phase_46) next-pos_40))))))" +"(if(unsafe-fx< index_0 25)" +"(if(unsafe-fx< index_0 24)" +"(let-values()" +"(let-values(((module_4 next-pos_41)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((sym_28 next-pos_42)" +"(decode" +" vec_45" +" next-pos_41" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase_47 next-pos_43)" +"(decode" +" vec_45" +" next-pos_42" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-module_4 next-pos_44)" +"(decode" +" vec_45" +" next-pos_43" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-phase_3 next-pos_45)" +"(decode" +" vec_45" +" next-pos_44" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-sym_3 next-pos_46)" +"(decode" +" vec_45" +" next-pos_45" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-require-phase_3 next-pos_47)" +"(decode" +" vec_45" +" next-pos_46" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((free=id_8 next-pos_48)" +"(decode" +" vec_45" +" next-pos_47" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((extra-inspector_3 next-pos_49)" +"(decode" +" vec_45" +" next-pos_48" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((extra-nominal-bindings_3 next-pos_50)" +"(decode" +" vec_45" +" next-pos_49" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-full-module-binding" +" module_4" +" sym_28" +" phase_47" +" nominal-module_4" +" nominal-phase_3" +" nominal-sym_3" +" nominal-require-phase_3" +" free=id_8" +" extra-inspector_3" +" extra-nominal-bindings_3)" +" next-pos_50))))))))))))" +"(let-values()" +"(let-values(((module_5 next-pos_51)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((sym_29 next-pos_52)" +"(decode" +" vec_45" +" next-pos_51" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase_48 next-pos_53)" +"(decode" +" vec_45" +" next-pos_52" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((nominal-module_5 next-pos_54)" +"(decode" +" vec_45" +" next-pos_53" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-simple-module-binding module_5 sym_29 phase_48 nominal-module_5)" +" next-pos_54)))))))" +"(if(unsafe-fx< index_0 26)" +"(let-values()" +"(let-values(((key_48 next-pos_55)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((free=id_9 next-pos_56)" +"(decode" +" vec_45" +" next-pos_55" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values(deserialize-full-local-binding key_48 free=id_9) next-pos_56))))" +"(if(unsafe-fx< index_0 27)" +"(let-values()" +"(let-values(((prefix_3 next-pos_57)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((excepts_3 next-pos_58)" +"(decode" +" vec_45" +" next-pos_57" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((mpi_26 next-pos_59)" +"(decode" +" vec_45" +" next-pos_58" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((provide-phase-level_2 next-pos_60)" +"(decode" +" vec_45" +" next-pos_59" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((phase-shift_3 next-pos_61)" +"(decode" +" vec_45" +" next-pos_60" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((bulk-binding-registry_8 next-pos_62)" +"(decode" +" vec_45" +" next-pos_61" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-bulk-binding" +" prefix_3" +" excepts_3" +" mpi_26" +" provide-phase-level_2" +" phase-shift_3" +" bulk-binding-registry_8)" +" next-pos_62))))))))" +"(let-values()" +"(let-values(((binding_11 next-pos_63)" +"(decode" +" vec_45" +"(add1 pos_50)" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((protected?_1 next-pos_64)" +"(decode" +" vec_45" +" next-pos_63" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(let-values(((syntax?_3 next-pos_65)" +"(decode" +" vec_45" +" next-pos_64" +" mpis_9" +" inspector_7" +" bulk-binding-registry_7" +" shared_2)))" +"(values" +"(deserialize-provided binding_11 protected?_1 syntax?_3)" +" next-pos_65)))))))))))))))))" +"(define-values" +"(decode-fill!)" +"(lambda(v_154 vec_46 pos_71 mpis_10 inspector_8 bulk-binding-registry_9 shared_3)" +"(begin" +"(let-values(((tmp_23)(vector*-ref vec_46 pos_71)))" +"(if(equal? tmp_23 #f)" +"(let-values()(add1 pos_71))" +"(if(equal? tmp_23 '#:set-box!)" +"(let-values()" +"(let-values(((c_21 next-pos_66)" +"(decode vec_46(add1 pos_71) mpis_10 inspector_8 bulk-binding-registry_9 shared_3)))" +"(begin(set-box! v_154 c_21) next-pos_66)))" +"(if(equal? tmp_23 '#:set-vector!)" +"(let-values()" +"(let-values(((len_24)(vector*-ref vec_46(add1 pos_71))))" +"(let-values(((start_31) 0)((end_23) len_24)((inc_17) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_31 end_23 inc_17)))" +"((letrec-values(((for-loop_141)" +"(lambda(pos_72 pos_73)" +"(begin" +" 'for-loop" +"(if(< pos_73 end_23)" +"(let-values(((i_122) pos_73))" +"(let-values(((pos_74)" +"(let-values(((pos_75) pos_72))" +"(let-values(((pos_76)" +"(let-values()" +"(let-values(((c_22 next-pos_67)" +"(decode" +" vec_46" +" pos_75" +" mpis_10" +" inspector_8" +" bulk-binding-registry_9" +" shared_3)))" +"(begin" +"(vector-set! v_154 i_122 c_22)" +" next-pos_67)))))" +"(values pos_76)))))" +"(if(not #f)(for-loop_141 pos_74(+ pos_73 inc_17)) pos_74)))" +" pos_72)))))" +" for-loop_141)" +"(+ pos_71 2)" +" start_31)))))" +"(if(equal? tmp_23 '#:set-hash!)" +"(let-values()" +"(let-values(((len_25)(vector*-ref vec_46(add1 pos_71))))" +"(let-values(((start_32) 0)((end_24) len_25)((inc_18) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_32 end_24 inc_18)))" +"((letrec-values(((for-loop_142)" +"(lambda(pos_77 pos_78)" +"(begin" +" 'for-loop" +"(if(< pos_78 end_24)" +"(let-values()" +"(let-values(((pos_79)" +"(let-values(((pos_80) pos_77))" +"(let-values(((pos_81)" +"(let-values()" +"(let-values(((key_49 next-pos_68)" +"(decode" +" vec_46" +" pos_80" +" mpis_10" +" inspector_8" +" bulk-binding-registry_9" +" shared_3)))" +"(let-values(((val_42 done-pos_2)" +"(decode" +" vec_46" +" next-pos_68" +" mpis_10" +" inspector_8" +" bulk-binding-registry_9" +" shared_3)))" +"(begin" +"(hash-set! v_154 key_49 val_42)" +" done-pos_2))))))" +"(values pos_81)))))" +"(if(not #f)(for-loop_142 pos_79(+ pos_78 inc_18)) pos_79)))" +" pos_77)))))" +" for-loop_142)" +"(+ pos_71 2)" +" start_32)))))" +"(if(equal? tmp_23 '#:scope-fill!)" +"(let-values()" +"(let-values(((c_23 next-pos_69)" +"(decode vec_46(add1 pos_71) mpis_10 inspector_8 bulk-binding-registry_9 shared_3)))" +"(begin(deserialize-scope-fill! v_154 c_23) next-pos_69)))" +"(if(equal? tmp_23 '#:representative-scope-fill!)" +"(let-values()" +"(let-values(((a_39 next-pos_70)" +"(decode vec_46(add1 pos_71) mpis_10 inspector_8 bulk-binding-registry_9 shared_3)))" +"(let-values(((d_25 done-pos_3)" +"(decode vec_46 next-pos_70 mpis_10 inspector_8 bulk-binding-registry_9 shared_3)))" +"(begin(deserialize-representative-scope-fill! v_154 a_39 d_25) done-pos_3))))" +" (let-values () (error 'deserialize \"bad fill encoding: ~v\" (vector*-ref vec_46 pos_71)))))))))))))" +"(define-values" +"(find-reachable-scopes)" +"(lambda(v_155)" +"(begin" +"(let-values(((seen_23)(make-hasheq)))" +"(let-values(((reachable-scopes_7)(seteq)))" +"(let-values(((scope-triggers_0)(make-hasheq)))" +"(begin" +"((letrec-values(((loop_81)" +"(lambda(v_156)" +"(begin" +" 'loop" +"(if(interned-literal? v_156)" +"(let-values()(void))" +"(if(hash-ref seen_23 v_156 #f)" +"(let-values()(void))" +"(let-values()" +"(begin" +"(hash-set! seen_23 v_156 #t)" +"(if(scope-with-bindings? v_156)" +"(let-values()" +"(let-values((()" +"(begin" +"(set! reachable-scopes_7" +"(set-add reachable-scopes_7 v_156))" +"(values))))" +"(let-values((()" +"(begin" +"((reach-scopes-ref v_156) v_156 loop_81)" +"(values))))" +"(let-values(((l_50)(hash-ref scope-triggers_0 v_156 null)))" +"(begin" +"(let-values(((lst_113) l_50))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_113)))" +"((letrec-values(((for-loop_143)" +"(lambda(lst_114)" +"(begin" +" 'for-loop" +"(if(pair? lst_114)" +"(let-values(((v_157)" +"(unsafe-car lst_114))" +"((rest_56)" +"(unsafe-cdr lst_114)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_81" +" v_157))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_143 rest_56)" +"(values))))" +"(values))))))" +" for-loop_143)" +" lst_113)))" +"(void)" +"((scope-with-bindings-ref v_156)" +" v_156" +" reachable-scopes_7" +" loop_81" +"(lambda(sc-unreachable_0 b_65)" +"(hash-update!" +" scope-triggers_0" +" sc-unreachable_0" +"(lambda(l_51)(cons b_65 l_51))" +" null))))))))" +"(if(reach-scopes? v_156)" +"(let-values()((reach-scopes-ref v_156) v_156 loop_81))" +"(if(pair? v_156)" +"(let-values()(begin(loop_81(car v_156))(loop_81(cdr v_156))))" +"(if(vector? v_156)" +"(let-values()" +"(begin" +"(let-values(((vec_47 len_26)" +"(let-values(((vec_48) v_156))" +"(begin" +"(check-vector vec_48)" +"(values" +" vec_48" +"(unsafe-vector-length vec_48))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_144)" +"(lambda(pos_82)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_82 len_26)" +"(let-values(((e_22)" +"(unsafe-vector-ref" +" vec_47" +" pos_82)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_81" +" e_22))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_144" +"(unsafe-fx+ 1 pos_82))" +"(values))))" +"(values))))))" +" for-loop_144)" +" 0)))" +"(void)))" +"(if(box? v_156)" +"(let-values()(loop_81(unbox v_156)))" +"(if(hash? v_156)" +"(let-values()" +"(begin" +"(let-values(((ht_93) v_156))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_93)))" +"((letrec-values(((for-loop_145)" +"(lambda(i_123)" +"(begin" +" 'for-loop" +"(if i_123" +"(let-values(((k_29 v_158)" +"(hash-iterate-key+value" +" ht_93" +" i_123)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(loop_81" +" k_29)" +"(loop_81" +" v_158)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_145" +"(hash-iterate-next" +" ht_93" +" i_123))" +"(values))))" +"(values))))))" +" for-loop_145)" +"(hash-iterate-first ht_93))))" +"(void)))" +"(if(prefab-struct-key v_156)" +"(let-values()" +"(begin" +"(let-values(((v*_5 start*_4 stop*_5 step*_4)" +"(normalise-inputs" +" 'in-vector" +" \"vector\"" +"(lambda(x_51)(vector? x_51))" +"(lambda(x_52)(unsafe-vector-length x_52))" +"(struct->vector v_156)" +" 1" +" #f" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_146)" +"(lambda(idx_4)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< idx_4 stop*_5)" +"(let-values(((e_23)" +"(unsafe-vector-ref" +" v*_5" +" idx_4)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_81" +" e_23))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_146" +"(unsafe-fx+ idx_4 1))" +"(values))))" +"(values))))))" +" for-loop_146)" +" start*_4)))" +"(void)))" +"(if(srcloc? v_156)" +"(let-values()(loop_81(srcloc-source v_156)))" +"(let-values()(void))))))))))))))))))" +" loop_81)" +" v_155)" +" reachable-scopes_7)))))))" +"(define-values" +"(deserialize-imports)" +" '(deserialize-module-path-indexes syntax-module-path-index-shift syntax-shift-phase-level module-use deserialize))" +"(define-values" +"(syntax-module-path-index-shift/no-keywords)" +"(let-values(((syntax-module-path-index-shift_0)" +"(let-values(((core27_0)" +"(lambda(s24_0 from-mpi25_0 to-mpi26_0 inspector22_0 inspector23_0)" +"(begin" +" 'core27" +"(let-values(((s_191) s24_0))" +"(let-values(((from-mpi_4) from-mpi25_0))" +"(let-values(((to-mpi_3) to-mpi26_0))" +"(let-values(((inspector_9)(if inspector23_0 inspector22_0 #f)))" +"(let-values()" +"(let-values(((s29_0) s_191)" +"((from-mpi30_0) from-mpi_4)" +"((to-mpi31_0) to-mpi_3)" +"((inspector32_0) inspector_9))" +"(syntax-module-path-index-shift15.1" +" #f" +" #f" +" s29_0" +" from-mpi30_0" +" to-mpi31_0" +" inspector32_0" +" #t)))))))))))" +"(case-lambda" +"((s_192 from-mpi_5 to-mpi_4)" +"(begin 'syntax-module-path-index-shift(core27_0 s_192 from-mpi_5 to-mpi_4 #f #f)))" +"((s_193 from-mpi_6 to-mpi_5 inspector22_1)(core27_0 s_193 from-mpi_6 to-mpi_5 inspector22_1 #t))))))" +" syntax-module-path-index-shift_0))" +"(define-values" +"(deserialize-instance)" +"(1/make-instance" +" 'deserialize" +" #f" +" 'constant" +" 'deserialize-module-path-indexes" +" deserialize-module-path-indexes" +" 'syntax-module-path-index-shift" +" syntax-module-path-index-shift/no-keywords" +" 'syntax-shift-phase-level" +" syntax-shift-phase-level$1" +" 'module-use" +" module-use1.1" +" 'deserialize" +" deserialize))" +"(define-values" +"(struct:parsed parsed1.1 parsed? parsed-s)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'parsed #f 1 0 #f(list(cons prop:authentic #t)) #f #f '(0) #f 'parsed)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 's))))" +"(define-values" +"(struct:parsed-id parsed-id2.1 parsed-id? parsed-id-binding parsed-id-inspector)" +"(let-values(((struct:_1 make-_1 ?_1 -ref_1 -set!_1)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-id" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-id)))))" +"(values" +" struct:_1" +" make-_1" +" ?_1" +"(make-struct-field-accessor -ref_1 0 'binding)" +"(make-struct-field-accessor -ref_1 1 'inspector))))" +"(define-values" +"(struct:parsed-primitive-id parsed-primitive-id3.1 parsed-primitive-id?)" +"(let-values(((struct:_41 make-_41 ?_41 -ref_41 -set!_41)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-primitive-id" +" struct:parsed-id" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-primitive-id)))))" +"(values struct:_41 make-_41 ?_41)))" +"(define-values" +"(struct:parsed-top-id parsed-top-id4.1 parsed-top-id?)" +"(let-values(((struct:_10 make-_10 ?_10 -ref_10 -set!_10)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-top-id" +" struct:parsed-id" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-top-id)))))" +"(values struct:_10 make-_10 ?_10)))" +"(define-values" +"(struct:parsed-lambda parsed-lambda5.1 parsed-lambda? parsed-lambda-keys parsed-lambda-body)" +"(let-values(((struct:_40 make-_40 ?_40 -ref_40 -set!_40)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-lambda" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-lambda)))))" +"(values" +" struct:_40" +" make-_40" +" ?_40" +"(make-struct-field-accessor -ref_40 0 'keys)" +"(make-struct-field-accessor -ref_40 1 'body))))" +"(define-values" +"(struct:parsed-case-lambda parsed-case-lambda6.1 parsed-case-lambda? parsed-case-lambda-clauses)" +"(let-values(((struct:_42 make-_42 ?_42 -ref_42 -set!_42)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-case-lambda" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-case-lambda)))))" +"(values struct:_42 make-_42 ?_42(make-struct-field-accessor -ref_42 0 'clauses))))" +"(define-values" +"(struct:parsed-app parsed-app7.1 parsed-app? parsed-app-rator parsed-app-rands)" +"(let-values(((struct:_43 make-_43 ?_43 -ref_43 -set!_43)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-app" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-app)))))" +"(values" +" struct:_43" +" make-_43" +" ?_43" +"(make-struct-field-accessor -ref_43 0 'rator)" +"(make-struct-field-accessor -ref_43 1 'rands))))" +"(define-values" +"(struct:parsed-if parsed-if8.1 parsed-if? parsed-if-tst parsed-if-thn parsed-if-els)" +"(let-values(((struct:_4 make-_4 ?_4 -ref_4 -set!_4)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-if" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-if)))))" +"(values" +" struct:_4" +" make-_4" +" ?_4" +"(make-struct-field-accessor -ref_4 0 'tst)" +"(make-struct-field-accessor -ref_4 1 'thn)" +"(make-struct-field-accessor -ref_4 2 'els))))" +"(define-values" +"(struct:parsed-set! parsed-set!9.1 parsed-set!? parsed-set!-id parsed-set!-rhs)" +"(let-values(((struct:_44 make-_44 ?_44 -ref_44 -set!_44)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-set!" +" struct:parsed" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'parsed-set!)))))" +"(values" +" struct:_44" +" make-_44" +" ?_44" +"(make-struct-field-accessor -ref_44 0 'id)" +"(make-struct-field-accessor -ref_44 1 'rhs))))" +"(define-values" +"(struct:parsed-with-continuation-mark" +" parsed-with-continuation-mark10.1" +" parsed-with-continuation-mark?" +" parsed-with-continuation-mark-key" +" parsed-with-continuation-mark-val" +" parsed-with-continuation-mark-body)" +"(let-values(((struct:_45 make-_45 ?_45 -ref_45 -set!_45)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-with-continuation-mark" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-with-continuation-mark)))))" +"(values" +" struct:_45" +" make-_45" +" ?_45" +"(make-struct-field-accessor -ref_45 0 'key)" +"(make-struct-field-accessor -ref_45 1 'val)" +"(make-struct-field-accessor -ref_45 2 'body))))" +"(define-values" +"(struct:parsed-#%variable-reference" +" parsed-#%variable-reference11.1" +" parsed-#%variable-reference?" +" parsed-#%variable-reference-id)" +"(let-values(((struct:_46 make-_46 ?_46 -ref_46 -set!_46)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-#%variable-reference" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-#%variable-reference)))))" +"(values struct:_46 make-_46 ?_46(make-struct-field-accessor -ref_46 0 'id))))" +"(define-values" +"(struct:parsed-begin parsed-begin12.1 parsed-begin? parsed-begin-body)" +"(let-values(((struct:_47 make-_47 ?_47 -ref_47 -set!_47)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-begin" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-begin)))))" +"(values struct:_47 make-_47 ?_47(make-struct-field-accessor -ref_47 0 'body))))" +"(define-values" +"(struct:parsed-begin0 parsed-begin013.1 parsed-begin0? parsed-begin0-body)" +"(let-values(((struct:_48 make-_48 ?_48 -ref_48 -set!_48)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-begin0" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-begin0)))))" +"(values struct:_48 make-_48 ?_48(make-struct-field-accessor -ref_48 0 'body))))" +"(define-values" +"(struct:parsed-quote parsed-quote14.1 parsed-quote? parsed-quote-datum)" +"(let-values(((struct:_49 make-_49 ?_49 -ref_49 -set!_49)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-quote" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-quote)))))" +"(values struct:_49 make-_49 ?_49(make-struct-field-accessor -ref_49 0 'datum))))" +"(define-values" +"(struct:parsed-quote-syntax parsed-quote-syntax15.1 parsed-quote-syntax? parsed-quote-syntax-datum)" +"(let-values(((struct:_50 make-_50 ?_50 -ref_50 -set!_50)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-quote-syntax" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-quote-syntax)))))" +"(values struct:_50 make-_50 ?_50(make-struct-field-accessor -ref_50 0 'datum))))" +"(define-values" +"(struct:parsed-let_-values" +" parsed-let_-values16.1" +" parsed-let_-values?" +" parsed-let_-values-idss" +" parsed-let_-values-clauses" +" parsed-let_-values-body)" +"(let-values(((struct:_51 make-_51 ?_51 -ref_51 -set!_51)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-let_-values" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-let_-values)))))" +"(values" +" struct:_51" +" make-_51" +" ?_51" +"(make-struct-field-accessor -ref_51 0 'idss)" +"(make-struct-field-accessor -ref_51 1 'clauses)" +"(make-struct-field-accessor -ref_51 2 'body))))" +"(define-values" +"(struct:parsed-let-values parsed-let-values17.1 parsed-let-values?)" +"(let-values(((struct:_52 make-_52 ?_52 -ref_52 -set!_52)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-let-values" +" struct:parsed-let_-values" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-let-values)))))" +"(values struct:_52 make-_52 ?_52)))" +"(define-values" +"(struct:parsed-letrec-values parsed-letrec-values18.1 parsed-letrec-values?)" +"(let-values(((struct:_53 make-_53 ?_53 -ref_53 -set!_53)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-letrec-values" +" struct:parsed-let_-values" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-letrec-values)))))" +"(values struct:_53 make-_53 ?_53)))" +"(define-values" +"(struct:parsed-define-values" +" parsed-define-values19.1" +" parsed-define-values?" +" parsed-define-values-ids" +" parsed-define-values-syms" +" parsed-define-values-rhs)" +"(let-values(((struct:_54 make-_54 ?_54 -ref_54 -set!_54)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-define-values" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-define-values)))))" +"(values" +" struct:_54" +" make-_54" +" ?_54" +"(make-struct-field-accessor -ref_54 0 'ids)" +"(make-struct-field-accessor -ref_54 1 'syms)" +"(make-struct-field-accessor -ref_54 2 'rhs))))" +"(define-values" +"(struct:parsed-define-syntaxes" +" parsed-define-syntaxes20.1" +" parsed-define-syntaxes?" +" parsed-define-syntaxes-ids" +" parsed-define-syntaxes-syms" +" parsed-define-syntaxes-rhs)" +"(let-values(((struct:_55 make-_55 ?_55 -ref_55 -set!_55)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-define-syntaxes" +" struct:parsed" +" 3" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'parsed-define-syntaxes)))))" +"(values" +" struct:_55" +" make-_55" +" ?_55" +"(make-struct-field-accessor -ref_55 0 'ids)" +"(make-struct-field-accessor -ref_55 1 'syms)" +"(make-struct-field-accessor -ref_55 2 'rhs))))" +"(define-values" +"(struct:parsed-begin-for-syntax parsed-begin-for-syntax21.1 parsed-begin-for-syntax? parsed-begin-for-syntax-body)" +"(let-values(((struct:_56 make-_56 ?_56 -ref_56 -set!_56)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-begin-for-syntax" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-begin-for-syntax)))))" +"(values struct:_56 make-_56 ?_56(make-struct-field-accessor -ref_56 0 'body))))" +"(define-values" +"(struct:parsed-#%declare parsed-#%declare22.1 parsed-#%declare?)" +"(let-values(((struct:_57 make-_57 ?_57 -ref_57 -set!_57)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-#%declare" +" struct:parsed" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-#%declare)))))" +"(values struct:_57 make-_57 ?_57)))" +"(define-values" +"(struct:parsed-require parsed-require23.1 parsed-require?)" +"(let-values(((struct:_58 make-_58 ?_58 -ref_58 -set!_58)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-require" +" struct:parsed" +" 0" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'parsed-require)))))" +"(values struct:_58 make-_58 ?_58)))" +"(define-values" +"(struct:parsed-#%module-begin parsed-#%module-begin24.1 parsed-#%module-begin? parsed-#%module-begin-body)" +"(let-values(((struct:_59 make-_59 ?_59 -ref_59 -set!_59)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-#%module-begin" +" struct:parsed" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'parsed-#%module-begin)))))" +"(values struct:_59 make-_59 ?_59(make-struct-field-accessor -ref_59 0 'body))))" +"(define-values" +"(struct:parsed-module" +" parsed-module25.1" +" parsed-module?" +" parsed-module-star?" +" parsed-module-name-id" +" parsed-module-self" +" parsed-module-requires" +" parsed-module-provides" +" parsed-module-root-ctx-simple?" +" parsed-module-encoded-root-ctx" +" parsed-module-body" +" parsed-module-compiled-module" +" parsed-module-compiled-submodules)" +"(let-values(((struct:_60 make-_60 ?_60 -ref_60 -set!_60)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'parsed-module" +" struct:parsed" +" 10" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9)" +" #f" +" 'parsed-module)))))" +"(values" +" struct:_60" +" make-_60" +" ?_60" +"(make-struct-field-accessor -ref_60 0 'star?)" +"(make-struct-field-accessor -ref_60 1 'name-id)" +"(make-struct-field-accessor -ref_60 2 'self)" +"(make-struct-field-accessor -ref_60 3 'requires)" +"(make-struct-field-accessor -ref_60 4 'provides)" +"(make-struct-field-accessor -ref_60 5 'root-ctx-simple?)" +"(make-struct-field-accessor -ref_60 6 'encoded-root-ctx)" +"(make-struct-field-accessor -ref_60 7 'body)" +"(make-struct-field-accessor -ref_60 8 'compiled-module)" +"(make-struct-field-accessor -ref_60 9 'compiled-submodules))))" +"(define-values" +"(module-path->mpi5.1)" +"(lambda(declared-submodule-names1_0 declared-submodule-names2_0 mod-path3_0 self4_2)" +"(begin" +" 'module-path->mpi5" +"(let-values(((mod-path_4) mod-path3_0))" +"(let-values(((self_6) self4_2))" +"(let-values(((declared-submodule-names_1)" +"(if declared-submodule-names2_0 declared-submodule-names1_0 '#hasheq())))" +"(let-values()" +"(if(if(list? mod-path_4)" +"(if(= 2(length mod-path_4))" +"(if(eq? 'quote(car mod-path_4))" +"(if(symbol?(cadr mod-path_4))(hash-ref declared-submodule-names_1(cadr mod-path_4) #f) #f)" +" #f)" +" #f)" +" #f)" +" (let-values () (1/module-path-index-join (list 'submod \".\" (cadr mod-path_4)) self_6))" +"(if(if(list? mod-path_4)" +"(if(eq? 'submod(car mod-path_4))" +"(let-values(((mod-path_5)(cadr mod-path_4)))" +"(if(list? mod-path_5)" +"(if(= 2(length mod-path_5))" +"(if(eq? 'quote(car mod-path_5))" +"(if(symbol?(cadr mod-path_5))" +"(hash-ref declared-submodule-names_1(cadr mod-path_5) #f)" +" #f)" +" #f)" +" #f)" +" #f))" +" #f)" +" #f)" +"(let-values()" +" (1/module-path-index-join (list* 'submod \".\" (cadr (cadr mod-path_4)) (cddr mod-path_4)) self_6))" +"(let-values()(1/module-path-index-join mod-path_4 self_6)))))))))))" +"(define-values" +"(module-path->mpi/context)" +"(lambda(mod-path_6 ctx_9)" +"(begin" +"(let-values(((temp9_0)(namespace-mpi(expand-context-namespace ctx_9)))" +"((temp10_2)(expand-context-declared-submodule-names ctx_9)))" +"(module-path->mpi5.1 temp10_2 #t mod-path_6 temp9_0)))))" +"(define-values" +"(syntax-mapped-names)" +"(lambda(s_0 phase_40)" +"(begin" +"(let-values(((s-scs_1)(syntax-scope-set s_0 phase_40)))" +"(let-values(((ht_94) s-scs_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_94)))" +"((letrec-values(((for-loop_106)" +"(lambda(syms_14 i_124)" +"(begin" +" 'for-loop" +"(if i_124" +"(let-values(((sc_25)(unsafe-immutable-hash-iterate-key ht_94 i_124)))" +"(let-values(((syms_15)" +"(let-values(((syms_16) syms_14))" +"(let-values(((syms_17)" +"(let-values()" +"(set-union" +" syms_16" +"(binding-table-symbols" +"(scope-binding-table sc_25)" +" s-scs_1" +" s_0" +" null)))))" +"(values syms_17)))))" +"(if(not #f)" +"(for-loop_106 syms_15(unsafe-immutable-hash-iterate-next ht_94 i_124))" +" syms_15)))" +" syms_14)))))" +" for-loop_106)" +"(seteq)" +"(unsafe-immutable-hash-iterate-first ht_94))))))))" +"(define-values" +"(struct:requires+provides" +" requires+provides1.1" +" requires+provides?" +" requires+provides-self" +" requires+provides-require-mpis" +" requires+provides-require-mpis-in-order" +" requires+provides-requires" +" requires+provides-provides" +" requires+provides-phase-to-defined-syms" +" requires+provides-can-cross-phase-persistent?" +" requires+provides-all-bindings-simple?" +" set-requires+provides-can-cross-phase-persistent?!" +" set-requires+provides-all-bindings-simple?!)" +"(let-values(((struct:_33 make-_33 ?_33 -ref_33 -set!_33)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'requires+provides" +" #f" +" 8" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5)" +" #f" +" 'requires+provides)))))" +"(values" +" struct:_33" +" make-_33" +" ?_33" +"(make-struct-field-accessor -ref_33 0 'self)" +"(make-struct-field-accessor -ref_33 1 'require-mpis)" +"(make-struct-field-accessor -ref_33 2 'require-mpis-in-order)" +"(make-struct-field-accessor -ref_33 3 'requires)" +"(make-struct-field-accessor -ref_33 4 'provides)" +"(make-struct-field-accessor -ref_33 5 'phase-to-defined-syms)" +"(make-struct-field-accessor -ref_33 6 'can-cross-phase-persistent?)" +"(make-struct-field-accessor -ref_33 7 'all-bindings-simple?)" +"(make-struct-field-mutator -set!_33 6 'can-cross-phase-persistent?)" +"(make-struct-field-mutator -set!_33 7 'all-bindings-simple?))))" +"(define-values" +"(struct:required required2.1 required? required-id required-phase required-can-be-shadowed? required-as-transformer?)" +"(let-values(((struct:_61 make-_61 ?_61 -ref_61 -set!_61)" +"(let-values()" +"(let-values()" +"(make-struct-type 'required #f 4 0 #f null(current-inspector) #f '(0 1 2 3) #f 'required)))))" +"(values" +" struct:_61" +" make-_61" +" ?_61" +"(make-struct-field-accessor -ref_61 0 'id)" +"(make-struct-field-accessor -ref_61 1 'phase)" +"(make-struct-field-accessor -ref_61 2 'can-be-shadowed?)" +"(make-struct-field-accessor -ref_61 3 'as-transformer?))))" +"(define-values" +"(struct:nominal nominal3.1 nominal? nominal-module nominal-provide-phase nominal-require-phase nominal-sym)" +"(let-values(((struct:_3 make-_3 ?_3 -ref_3 -set!_3)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'nominal" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +" #f" +" #f" +" '(0 1 2 3)" +" #f" +" 'nominal)))))" +"(values" +" struct:_3" +" make-_3" +" ?_3" +"(make-struct-field-accessor -ref_3 0 'module)" +"(make-struct-field-accessor -ref_3 1 'provide-phase)" +"(make-struct-field-accessor -ref_3 2 'require-phase)" +"(make-struct-field-accessor -ref_3 3 'sym))))" +"(define-values" +"(struct:bulk-required" +" bulk-required4.1" +" bulk-required?" +" bulk-required-provides" +" bulk-required-prefix-len" +" bulk-required-s" +" bulk-required-provide-phase-level" +" bulk-required-can-be-shadowed?)" +"(let-values(((struct:_5 make-_5 ?_5 -ref_5 -set!_5)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'bulk-required" +" #f" +" 5" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4)" +" #f" +" 'bulk-required)))))" +"(values" +" struct:_5" +" make-_5" +" ?_5" +"(make-struct-field-accessor -ref_5 0 'provides)" +"(make-struct-field-accessor -ref_5 1 'prefix-len)" +"(make-struct-field-accessor -ref_5 2 's)" +"(make-struct-field-accessor -ref_5 3 'provide-phase-level)" +"(make-struct-field-accessor -ref_5 4 'can-be-shadowed?))))" +"(define-values" +"(make-requires+provides8.1)" +"(lambda(copy-requires5_0 copy-requires6_0 self7_0)" +"(begin" +" 'make-requires+provides8" +"(let-values(((self_7) self7_0))" +"(let-values(((copy-r+p_0)(if copy-requires6_0 copy-requires5_0 #f)))" +"(let-values()" +"(requires+provides1.1" +" self_7" +"(if copy-r+p_0(requires+provides-require-mpis copy-r+p_0)(make-module-path-index-intern-table))" +"(if copy-r+p_0(hash-copy(requires+provides-require-mpis-in-order copy-r+p_0))(make-hasheqv))" +"(make-hasheq)" +"(make-hasheqv)" +"(make-hasheqv)" +" #t" +" #t)))))))" +"(define-values" +"(requires+provides-reset!)" +"(lambda(r+p_0)" +"(begin" +"(begin" +"(hash-clear!(requires+provides-requires r+p_0))" +"(hash-clear!(requires+provides-provides r+p_0))" +"(hash-clear!(requires+provides-phase-to-defined-syms r+p_0))))))" +"(define-values" +"(intern-mpi)" +"(lambda(r+p_1 mpi_27)(begin(intern-module-path-index!(requires+provides-require-mpis r+p_1) mpi_27))))" +"(define-values" +"(add-required-module!)" +"(lambda(r+p_2 mod-name_8 phase-shift_5 is-cross-phase-persistent?_0)" +"(begin" +"(let-values(((mpi_28)(intern-mpi r+p_2 mod-name_8)))" +"(begin" +"(if(hash-ref(hash-ref(requires+provides-requires r+p_2) mpi_28 '#hasheqv()) phase-shift_5 #f)" +"(void)" +"(let-values()" +"(begin" +"(hash-update!" +"(requires+provides-require-mpis-in-order r+p_2)" +" phase-shift_5" +"(lambda(l_52)(cons mpi_28 l_52))" +" null)" +"(hash-set!" +"(hash-ref!(requires+provides-requires r+p_2) mpi_28 make-hasheqv)" +" phase-shift_5" +"(make-hasheq)))))" +"(if is-cross-phase-persistent?_0" +"(void)" +"(let-values()(set-requires+provides-can-cross-phase-persistent?! r+p_2 #f)))" +" mpi_28)))))" +"(define-values" +"(add-defined-or-required-id!19.1)" +"(lambda(as-transformer?12_0 can-be-shadowed?11_0 can-be-shadowed?13_0 r+p15_0 id16_0 phase17_0 binding18_0)" +"(begin" +" 'add-defined-or-required-id!19" +"(let-values(((r+p_3) r+p15_0))" +"(let-values(((id_23) id16_0))" +"(let-values(((phase_49) phase17_0))" +"(let-values(((binding_12) binding18_0))" +"(let-values(((can-be-shadowed?_0)(if can-be-shadowed?13_0 can-be-shadowed?11_0 #f)))" +"(let-values(((as-transformer?_0) as-transformer?12_0))" +"(let-values()" +"(begin" +"(if(equal?" +" phase_49" +"(phase+" +"(module-binding-nominal-phase binding_12)" +"(module-binding-nominal-require-phase binding_12)))" +"(void)" +" (let-values () (error \"internal error: binding phase does not match nominal info\")))" +"(let-values(((temp117_0)(module-binding-nominal-module binding_12))" +"((temp118_0)(module-binding-nominal-require-phase binding_12))" +"((can-be-shadowed?119_0) can-be-shadowed?_0)" +"((as-transformer?120_0) as-transformer?_0))" +"(add-defined-or-required-id-at-nominal!33.1" +" as-transformer?120_0" +" can-be-shadowed?119_0" +" temp117_0" +" temp118_0" +" r+p_3" +" id_23" +" phase_49)))))))))))))" +"(define-values" +"(add-defined-or-required-id-at-nominal!33.1)" +"(lambda(as-transformer?25_0" +" can-be-shadowed?24_0" +" nominal-module22_0" +" nominal-require-phase23_0" +" r+p30_0" +" id31_0" +" phase32_1)" +"(begin" +" 'add-defined-or-required-id-at-nominal!33" +"(let-values(((r+p_4) r+p30_0))" +"(let-values(((id_24) id31_0))" +"(let-values(((phase_50) phase32_1))" +"(let-values(((nominal-module_6) nominal-module22_0))" +"(let-values(((nominal-require-phase_4) nominal-require-phase23_0))" +"(let-values(((can-be-shadowed?_1) can-be-shadowed?24_0))" +"(let-values(((as-transformer?_1) as-transformer?25_0))" +"(let-values()" +"(let-values(((at-mod_0)" +"(hash-ref!" +"(requires+provides-requires r+p_4)" +"(intern-mpi r+p_4 nominal-module_6)" +" make-hasheqv)))" +"(let-values(((sym-to-reqds_0)(hash-ref! at-mod_0 nominal-require-phase_4 make-hasheq)))" +"(let-values(((sym_30)(syntax-e$1 id_24)))" +"(hash-set!" +" sym-to-reqds_0" +" sym_30" +"(cons-ish" +"(required2.1 id_24 phase_50 can-be-shadowed?_1 as-transformer?_1)" +"(hash-ref sym-to-reqds_0 sym_30 null)))))))))))))))))" +"(define-values" +"(add-bulk-required-ids!59.1)" +"(lambda(accum-update-nominals42_0" +" can-be-shadowed?40_0" +" check-and-remove?41_0" +" excepts37_0" +" in39_0" +" prefix36_0" +" symbols-accum38_0" +" who43_0" +" r+p52_0" +" s53_0" +" self54_0" +" nominal-module55_0" +" phase-shift56_0" +" provides57_0" +" provide-phase-level58_0)" +"(begin" +" 'add-bulk-required-ids!59" +"(let-values(((r+p_5) r+p52_0))" +"(let-values(((s_194) s53_0))" +"(let-values(((self_8) self54_0))" +"(let-values(((nominal-module_7) nominal-module55_0))" +"(let-values(((phase-shift_6) phase-shift56_0))" +"(let-values(((provides_4) provides57_0))" +"(let-values(((provide-phase-level_3) provide-phase-level58_0))" +"(let-values(((bulk-prefix_0) prefix36_0))" +"(let-values(((bulk-excepts_0) excepts37_0))" +"(let-values(((symbols-accum_0) symbols-accum38_0))" +"(let-values(((orig-s_0) in39_0))" +"(let-values(((can-be-shadowed?_2) can-be-shadowed?40_0))" +"(let-values(((check-and-remove?_0) check-and-remove?41_0))" +"(let-values(((accum-update-nominals_0) accum-update-nominals42_0))" +"(let-values(((who_10) who43_0))" +"(let-values()" +"(let-values(((phase_51)(phase+ provide-phase-level_3 phase-shift_6)))" +"(let-values(((shortcut-table_0)" +"(if check-and-remove?_0" +"(if(>(hash-count provides_4) 64)" +"(syntax-mapped-names s_194 phase_51)" +" #f)" +" #f)))" +"(let-values(((mpi_29)(intern-mpi r+p_5 nominal-module_7)))" +"(let-values(((at-mod_1)" +"(hash-ref!" +"(requires+provides-requires r+p_5)" +" mpi_29" +" make-hasheqv)))" +"(let-values(((sym-to-reqds_1)" +"(hash-ref! at-mod_1 phase-shift_6 make-hasheq)))" +"(let-values(((prefix-len_0)" +"(if bulk-prefix_0" +"(string-length(symbol->string bulk-prefix_0))" +" 0)))" +"(let-values(((br_0)" +"(bulk-required4.1" +" provides_4" +" prefix-len_0" +" s_194" +" provide-phase-level_3" +" can-be-shadowed?_2)))" +"(begin" +"(let-values(((ht_95) provides_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_95)))" +"((letrec-values(((for-loop_147)" +"(lambda(i_125)" +"(begin" +" 'for-loop" +"(if i_125" +"(let-values(((out-sym_0 binding/p_2)" +"(hash-iterate-key+value" +" ht_95" +" i_125)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(if symbols-accum_0" +"(let-values()" +"(hash-set!" +" symbols-accum_0" +" out-sym_0" +" #t))" +"(void))" +"(if(hash-ref" +" bulk-excepts_0" +" out-sym_0" +" #f)" +"(void)" +"(let-values()" +"(let-values(((sym_31)" +"(if(not" +" bulk-prefix_0)" +"(let-values()" +" out-sym_0)" +"(let-values()" +"(string->symbol" +"(format" +" \"~a~a\"" +" bulk-prefix_0" +" out-sym_0))))))" +"(begin" +"(if(if check-and-remove?_0" +"(let-values(((or-part_177)" +"(not" +" shortcut-table_0)))" +"(if or-part_177" +" or-part_177" +"(hash-ref" +" shortcut-table_0" +" sym_31" +" #f)))" +" #f)" +"(let-values()" +"(let-values(((temp121_0)" +" #t)" +"((r+p122_0)" +" r+p_5)" +"((temp123_0)" +"(datum->syntax$1" +" s_194" +" sym_31" +" s_194))" +"((phase124_0)" +" phase_51)" +"((orig-s125_0)" +" orig-s_0)" +"((temp126_0)" +"(lambda()" +"(let-values(((self132_0)" +" self_8)" +"((mpi133_0)" +" mpi_29)" +"((provide-phase-level134_0)" +" provide-phase-level_3)" +"((phase-shift135_0)" +" phase-shift_6))" +"(provide-binding-to-require-binding11.1" +" mpi133_0" +" phase-shift135_0" +" provide-phase-level134_0" +" self132_0" +" binding/p_2" +" sym_31))))" +"((temp127_0)" +" #t)" +"((accum-update-nominals128_0)" +" accum-update-nominals_0)" +"((who129_0)" +" who_10))" +"(check-not-defined93.1" +" accum-update-nominals128_0" +" #t" +" temp121_0" +" #t" +" orig-s125_0" +" temp127_0" +" #t" +" temp126_0" +" #t" +" who129_0" +" r+p122_0" +" temp123_0" +" phase124_0)))" +"(void))" +"(hash-set!" +" sym-to-reqds_1" +" sym_31" +"(cons-ish" +" br_0" +"(hash-ref" +" sym-to-reqds_1" +" sym_31" +" null)))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_147" +"(hash-iterate-next" +" ht_95" +" i_125))" +"(values))))" +"(values))))))" +" for-loop_147)" +"(hash-iterate-first ht_95))))" +"(void))))))))))))))))))))))))))))" +"(define-values" +"(bulk-required->required)" +"(lambda(br_1 nominal-module_8 phase_52 sym_32)" +"(begin" +"(let-values(((prefix-len_1)(bulk-required-prefix-len br_1)))" +"(let-values(((out-sym_1)" +"(if(zero? prefix-len_1)" +" sym_32" +"(string->symbol(substring(symbol->string sym_32) prefix-len_1)))))" +"(let-values(((binding/p_3)(hash-ref(bulk-required-provides br_1) out-sym_1)))" +"(required2.1" +"(datum->syntax$1(bulk-required-s br_1) sym_32)" +"(phase+ phase_52(bulk-required-provide-phase-level br_1))" +"(bulk-required-can-be-shadowed? br_1)" +"(provided-as-transformer? binding/p_3))))))))" +"(define-values" +"(normalize-required)" +"(lambda(r_35 mod-name_9 phase_53 sym_33)" +"(begin(if(bulk-required? r_35)(bulk-required->required r_35 mod-name_9 phase_53 sym_33) r_35))))" +"(define-values" +"(add-enclosing-module-defined-and-required!67.1)" +"(lambda(enclosing-requires+provides62_0 r+p64_0 enclosing-mod65_0 phase-shift66_0)" +"(begin" +" 'add-enclosing-module-defined-and-required!67" +"(let-values(((r+p_6) r+p64_0))" +"(let-values(((enclosing-r+p_0) enclosing-requires+provides62_0))" +"(let-values(((enclosing-mod_0) enclosing-mod65_0))" +"(let-values(((phase-shift_7) phase-shift66_0))" +"(let-values()" +"(begin" +"(set-requires+provides-all-bindings-simple?! r+p_6 #f)" +"(let-values(((ht_96)(requires+provides-requires enclosing-r+p_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_96)))" +"((letrec-values(((for-loop_148)" +"(lambda(i_126)" +"(begin" +" 'for-loop" +"(if i_126" +"(let-values(((mod-name_10 at-mod_2)" +"(hash-iterate-key+value ht_96 i_126)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(let-values(((ht_4) at-mod_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_4)))" +"((letrec-values(((for-loop_134)" +"(lambda(i_127)" +"(begin" +" 'for-loop" +"(if i_127" +"(let-values(((phase_54" +" at-phase_8)" +"(hash-iterate-key+value" +" ht_4" +" i_127)))" +"(let-values((()" +"(let-values(((ht_6)" +" at-phase_8))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_6)))" +"((letrec-values(((for-loop_149)" +"(lambda(i_128)" +"(begin" +" 'for-loop" +"(if i_128" +"(let-values(((sym_34" +" reqds_0)" +"(hash-iterate-key+value" +" ht_6" +" i_128)))" +"(let-values((()" +"(let-values(((lst_115)" +" reqds_0))" +"(begin" +"(void)" +"((letrec-values(((for-loop_150)" +"(lambda(lst_116)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" lst_116))" +"(let-values(((reqd/maybe-bulk_0)" +"(if(pair?" +" lst_116)" +"(car" +" lst_116)" +" lst_116))" +"((rest_57)" +"(if(pair?" +" lst_116)" +"(cdr" +" lst_116)" +" null)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((reqd_0)" +"(normalize-required" +" reqd/maybe-bulk_0" +" mod-name_10" +" phase_54" +" sym_34)))" +"(let-values(((temp137_0)" +"(syntax-shift-phase-level$1" +"(let-values(((temp143_0)" +"(required-id" +" reqd_0))" +"((temp144_0)" +"(requires+provides-self" +" enclosing-r+p_0))" +"((enclosing-mod145_0)" +" enclosing-mod_0))" +"(syntax-module-path-index-shift15.1" +" #f" +" #f" +" temp143_0" +" temp144_0" +" enclosing-mod145_0" +" #f" +" #f))" +" phase-shift_7))" +"((temp138_0)" +"(phase+" +"(required-phase" +" reqd_0)" +" phase-shift_7))" +"((enclosing-mod139_0)" +" enclosing-mod_0)" +"((phase-shift140_1)" +" phase-shift_7)" +"((temp141_0)" +" #t)" +"((temp142_0)" +"(required-as-transformer?" +" reqd_0)))" +"(add-defined-or-required-id-at-nominal!33.1" +" temp142_0" +" temp141_0" +" enclosing-mod139_0" +" phase-shift140_1" +" r+p_6" +" temp137_0" +" temp138_0))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_150" +" rest_57)" +"(values))))" +"(values))))))" +" for-loop_150)" +" lst_115)))))" +"(if(not" +" #f)" +"(for-loop_149" +"(hash-iterate-next" +" ht_6" +" i_128))" +"(values))))" +"(values))))))" +" for-loop_149)" +"(hash-iterate-first" +" ht_6))))))" +"(if(not" +" #f)" +"(for-loop_134" +"(hash-iterate-next" +" ht_4" +" i_127))" +"(values))))" +"(values))))))" +" for-loop_134)" +"(hash-iterate-first ht_4))))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_148(hash-iterate-next ht_96 i_126))" +"(values))))" +"(values))))))" +" for-loop_148)" +"(hash-iterate-first ht_96))))" +"(void))))))))))" +"(define-values" +"(remove-required-id!75.1)" +"(lambda(unless-matches70_0 r+p72_0 id73_0 phase74_0)" +"(begin" +" 'remove-required-id!75" +"(let-values(((r+p_7) r+p72_0))" +"(let-values(((id_25) id73_0))" +"(let-values(((phase_55) phase74_0))" +"(let-values(((binding_13) unless-matches70_0))" +"(let-values()" +"(let-values(((b_66)" +"(let-values(((temp148_0) #t))" +"(resolve+shift30.1 #f #f temp148_0 #t #f #f #f #f #f #f id_25 phase_55))))" +"(if b_66" +"(let-values()" +"(let-values(((mpi_30)(intern-mpi r+p_7(module-binding-nominal-module b_66))))" +"(let-values(((at-mod_3)(hash-ref(requires+provides-requires r+p_7) mpi_30 #f)))" +"(if at-mod_3" +"(let-values()" +"(let-values(((nominal-phase_4)(module-binding-nominal-require-phase b_66)))" +"(let-values(((sym-to-reqds_2)(hash-ref at-mod_3 nominal-phase_4 #f)))" +"(if sym-to-reqds_2" +"(let-values()" +"(let-values(((sym_35)(syntax-e$1 id_25)))" +"(let-values(((l_53)(hash-ref sym-to-reqds_2 sym_35 null)))" +"(if(null? l_53)" +"(void)" +"(let-values()" +"(if(same-binding? b_66 binding_13)" +"(void)" +"(let-values()" +"(hash-set!" +" sym-to-reqds_2" +" sym_35" +"(remove-non-matching-requireds" +" l_53" +" id_25" +" phase_55" +" mpi_30" +" nominal-phase_4" +" sym_35)))))))))" +"(void)))))" +"(void)))))" +"(void)))))))))))" +"(define-values" +"(remove-non-matching-requireds)" +"(lambda(reqds_1 id_26 phase_56 mpi_31 nominal-phase_5 sym_36)" +"(begin" +"(reverse$1" +"(let-values(((lst_117) reqds_1))" +"(begin" +"(void)" +"((letrec-values(((for-loop_151)" +"(lambda(fold-var_96 lst_118)" +"(begin" +" 'for-loop" +"(if(not(null? lst_118))" +"(let-values(((r_36)(if(pair? lst_118)(car lst_118) lst_118))" +"((rest_58)(if(pair? lst_118)(cdr lst_118) null)))" +"(let-values(((fold-var_97)" +"(let-values(((r_37)" +"(normalize-required" +" r_36" +" mpi_31" +" nominal-phase_5" +" sym_36)))" +"(begin" +" #t" +"((letrec-values(((for-loop_152)" +"(lambda(fold-var_98)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_99)" +"(let-values(((fold-var_100)" +" fold-var_98))" +"(if(if(eqv?" +" phase_56" +"(required-phase" +" r_37))" +"(free-identifier=?$1" +"(required-id r_37)" +" id_26" +" phase_56" +" phase_56)" +" #f)" +" fold-var_100" +"(let-values(((fold-var_101)" +" fold-var_100))" +"(let-values(((fold-var_102)" +"(let-values()" +"(cons" +"(let-values()" +" r_37)" +" fold-var_101))))" +"(values" +" fold-var_102)))))))" +" fold-var_99))))))" +" for-loop_152)" +" fold-var_96)))))" +"(if(not #f)(for-loop_151 fold-var_97 rest_58) fold-var_97)))" +" fold-var_96)))))" +" for-loop_151)" +" null" +" lst_117)))))))" +"(define-values" +"(check-not-defined93.1)" +"(lambda(accum-update-nominals82_0" +" accum-update-nominals88_0" +" check-not-required?78_0" +" check-not-required?84_0" +" in79_0" +" remove-shadowed!?81_0" +" remove-shadowed!?87_0" +" unless-matches80_0" +" unless-matches86_0" +" who83_0" +" r+p90_0" +" id91_0" +" phase92_0)" +"(begin" +" 'check-not-defined93" +"(let-values(((check-not-required?_0)(if check-not-required?84_0 check-not-required?78_0 #f)))" +"(let-values(((r+p_8) r+p90_0))" +"(let-values(((id_27) id91_0))" +"(let-values(((phase_57) phase92_0))" +"(let-values(((orig-s_1) in79_0))" +"(let-values(((ok-binding/delayed_0)(if unless-matches86_0 unless-matches80_0 #f)))" +"(let-values(((remove-shadowed!?_0)(if remove-shadowed!?87_0 remove-shadowed!?81_0 #f)))" +"(let-values(((accum-update-nominals_1)" +"(if accum-update-nominals88_0 accum-update-nominals82_0 #f)))" +"(let-values(((who_11) who83_0))" +"(let-values()" +"(let-values(((b_67)" +"(let-values(((temp151_0) #t))" +"(resolve+shift30.1 #f #f temp151_0 #t #f #f #f #f #f #f id_27 phase_57))))" +"(if(not b_67)" +"(let-values()(void))" +"(if(not(module-binding? b_67))" +" (let-values () (raise-syntax-error$1 #f \"identifier out of context\" id_27))" +"(let-values()" +"(let-values(((defined?_0)" +"(if b_67" +"(eq?(requires+provides-self r+p_8)(module-binding-module b_67))" +" #f)))" +"(if(if(not defined?_0)(not check-not-required?_0) #f)" +"(let-values()(set-requires+provides-all-bindings-simple?! r+p_8 #f))" +"(if(if defined?_0" +"(not" +"(hash-ref" +"(hash-ref" +"(requires+provides-phase-to-defined-syms r+p_8)" +" phase_57" +" '#hasheq())" +"(module-binding-sym b_67)" +" #f))" +" #f)" +"(let-values()(void))" +"(let-values()" +"(let-values(((mpi_32)" +"(intern-mpi r+p_8(module-binding-nominal-module b_67))))" +"(let-values(((at-mod_4)" +"(hash-ref(requires+provides-requires r+p_8) mpi_32 #f)))" +"(let-values(((ok-binding_0)" +"(if(procedure? ok-binding/delayed_0)" +"(ok-binding/delayed_0)" +" ok-binding/delayed_0)))" +"(if(not at-mod_4)" +"(let-values()(void))" +"(if(if ok-binding_0(same-binding? b_67 ok-binding_0) #f)" +"(let-values()" +"(if(same-binding-nominals? b_67 ok-binding_0)" +"(void)" +"(let-values()" +"(let-values(((update!_0)" +"(lambda()" +"(begin" +" 'update!" +"(let-values(((temp152_0) #t)" +"((id153_0) id_27)" +"((temp154_0)" +"(let-values(((temp157_0)" +"(cons" +" ok-binding_0" +"(module-binding-extra-nominal-bindings" +" b_67))))" +"(module-binding-update48.1" +" #f" +" #f" +" temp157_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" b_67)))" +"((phase155_0) phase_57))" +"(add-binding!17.1" +" #f" +" #f" +" temp152_0" +" #t" +" id153_0" +" temp154_0" +" phase155_0))))))" +"(if accum-update-nominals_1" +"(let-values()" +"(set-box!" +" accum-update-nominals_1" +"(cons update!_0(unbox accum-update-nominals_1))))" +"(let-values()(update!_0)))))))" +"(let-values()" +"(let-values(((nominal-phase_6)" +"(module-binding-nominal-require-phase b_67)))" +"(let-values(((sym-to-reqds_3)" +"(hash-ref at-mod_4 nominal-phase_6 '#hasheq())))" +"(let-values(((reqds_2)" +"(hash-ref" +" sym-to-reqds_3" +"(syntax-e$1 id_27)" +" null)))" +"(begin" +"(let-values(((lst_119) reqds_2))" +"(begin" +"(void)" +"((letrec-values(((for-loop_62)" +"(lambda(lst_120)" +"(begin" +" 'for-loop" +"(if(not(null? lst_120))" +"(let-values(((r_38)" +"(if(pair?" +" lst_120)" +"(car lst_120)" +" lst_120))" +"((rest_59)" +"(if(pair?" +" lst_120)" +"(cdr lst_120)" +" null)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(if(bulk-required?" +" r_38)" +"(bulk-required-can-be-shadowed?" +" r_38)" +"(required-can-be-shadowed?" +" r_38))" +"(let-values()" +"(set-requires+provides-all-bindings-simple?!" +" r+p_8" +" #f))" +"(let-values()" +"(raise-syntax-error$1" +" who_11" +"(string-append" +" \"identifier already \"" +"(if defined?_0" +" \"defined\"" +" \"required\")" +"(if(zero-phase?" +" phase_57)" +"(let-values()" +" \"\")" +"(if(label-phase?" +" phase_57)" +"(let-values()" +" \" for label\")" +"(if(=" +" 1" +" phase_57)" +"(let-values()" +" \" for syntax\")" +"(let-values()" +"(format" +" \" for phase ~a\"" +" phase_57))))))" +" orig-s_1" +" id_27))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_62 rest_59)" +"(values))))" +"(values))))))" +" for-loop_62)" +" lst_119)))" +"(void)" +"(if(if remove-shadowed!?_0(not(null? reqds_2)) #f)" +"(let-values()" +"(hash-set!" +" sym-to-reqds_3" +"(syntax-e$1 id_27)" +"(remove-non-matching-requireds" +" reqds_2" +" id_27" +" phase_57" +" mpi_32" +" nominal-phase_6" +"(syntax-e$1 id_27))))" +"(void)))))))))))))))))))))))))))))))))" +"(define-values" +"(add-defined-syms!)" +"(lambda(r+p_9 syms_18 phase_58)" +"(begin" +"(let-values(((phase-to-defined-syms_0)(requires+provides-phase-to-defined-syms r+p_9)))" +"(let-values(((defined-syms_2)(hash-ref phase-to-defined-syms_0 phase_58 '#hasheq())))" +"(let-values(((new-defined-syms_0)" +"(let-values(((lst_121) syms_18))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_121)))" +"((letrec-values(((for-loop_153)" +"(lambda(defined-syms_3 lst_122)" +"(begin" +" 'for-loop" +"(if(pair? lst_122)" +"(let-values(((sym_37)(unsafe-car lst_122))" +"((rest_60)(unsafe-cdr lst_122)))" +"(let-values(((defined-syms_4)" +"(let-values(((defined-syms_5) defined-syms_3))" +"(let-values(((defined-syms_6)" +"(let-values()" +"(hash-set" +" defined-syms_5" +" sym_37" +" #t))))" +"(values defined-syms_6)))))" +"(if(not #f)" +"(for-loop_153 defined-syms_4 rest_60)" +" defined-syms_4)))" +" defined-syms_3)))))" +" for-loop_153)" +" defined-syms_2" +" lst_121)))))" +"(hash-set! phase-to-defined-syms_0 phase_58 new-defined-syms_0)))))))" +"(define-values" +"(extract-module-requires)" +"(lambda(r+p_10 mod-name_11 phase_59)" +"(begin" +"(let-values(((mpi_33)(intern-mpi r+p_10 mod-name_11)))" +"(let-values(((at-mod_5)(hash-ref(requires+provides-requires r+p_10) mpi_33 #f)))" +"(if at-mod_5" +"(reverse$1" +"(let-values(((ht_97)(hash-ref at-mod_5 phase_59 '#hasheq())))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_97)))" +"((letrec-values(((for-loop_154)" +"(lambda(fold-var_103 i_129)" +"(begin" +" 'for-loop" +"(if i_129" +"(let-values(((sym_38 reqds_3)(hash-iterate-key+value ht_97 i_129)))" +"(let-values(((fold-var_104)" +"(let-values(((lst_123) reqds_3))" +"(begin" +"(void)" +"((letrec-values(((for-loop_155)" +"(lambda(fold-var_105 lst_124)" +"(begin" +" 'for-loop" +"(if(not(null? lst_124))" +"(let-values(((reqd_1)" +"(if(pair? lst_124)" +"(car lst_124)" +" lst_124))" +"((rest_61)" +"(if(pair? lst_124)" +"(cdr lst_124)" +" null)))" +"(let-values(((fold-var_106)" +"(let-values(((fold-var_107)" +" fold-var_105))" +"(let-values(((fold-var_108)" +"(let-values()" +"(cons" +"(let-values()" +"(normalize-required" +" reqd_1" +" mpi_33" +" phase_59" +" sym_38))" +" fold-var_107))))" +"(values" +" fold-var_108)))))" +"(if(not #f)" +"(for-loop_155" +" fold-var_106" +" rest_61)" +" fold-var_106)))" +" fold-var_105)))))" +" for-loop_155)" +" fold-var_103" +" lst_123)))))" +"(if(not #f)" +"(for-loop_154 fold-var_104(hash-iterate-next ht_97 i_129))" +" fold-var_104)))" +" fold-var_103)))))" +" for-loop_154)" +" null" +"(hash-iterate-first ht_97)))))" +" #f))))))" +"(define-values" +"(extract-module-definitions)" +"(lambda(r+p_11)" +"(begin" +"(let-values(((or-part_178)(extract-module-requires r+p_11(requires+provides-self r+p_11) 0)))" +"(if or-part_178 or-part_178 null)))))" +"(define-values" +"(extract-all-module-requires)" +"(lambda(r+p_12 mod-name_12 phase_60)" +"(begin" +"(let-values(((self_9)(requires+provides-self r+p_12)))" +"(let-values(((requires_2)(requires+provides-requires r+p_12)))" +"(call/ec" +"(lambda(esc_0)" +"(reverse$1" +"(let-values(((lst_125)(if mod-name_12(list(intern-mpi r+p_12 mod-name_12))(hash-keys requires_2))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_125)))" +"((letrec-values(((for-loop_140)" +"(lambda(fold-var_109 lst_126)" +"(begin" +" 'for-loop" +"(if(pair? lst_126)" +"(let-values(((mod-name_13)(unsafe-car lst_126))" +"((rest_62)(unsafe-cdr lst_126)))" +"(let-values(((fold-var_110)" +"(let-values(((fold-var_111) fold-var_109))" +"(if(eq? mod-name_13 self_9)" +" fold-var_111" +"(let-values(((phase-to-requireds_0)" +"(hash-ref" +" requires_2" +" mod-name_13" +" '#hasheqv())))" +"(begin" +" #t" +"((letrec-values(((for-loop_156)" +"(lambda(fold-var_112)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_113)" +"(let-values(((lst_127)" +"(if(eq?" +" phase_60" +" 'all)" +"(hash-keys" +" phase-to-requireds_0)" +"(list" +" phase_60))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_127)))" +"((letrec-values(((for-loop_157)" +"(lambda(fold-var_114" +" lst_128)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_128)" +"(let-values(((phase_61)" +"(unsafe-car" +" lst_128))" +"((rest_63)" +"(unsafe-cdr" +" lst_128)))" +"(let-values(((fold-var_115)" +"(let-values(((ht_98)" +"(hash-ref" +" phase-to-requireds_0" +" phase_61" +"(lambda()" +"(esc_0" +" #f)))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_98)))" +"((letrec-values(((for-loop_158)" +"(lambda(fold-var_116" +" i_130)" +"(begin" +" 'for-loop" +"(if i_130" +"(let-values(((sym_39" +" reqds_4)" +"(hash-iterate-key+value" +" ht_98" +" i_130)))" +"(let-values(((fold-var_117)" +"(let-values(((lst_129)" +" reqds_4))" +"(begin" +"(void)" +"((letrec-values(((for-loop_159)" +"(lambda(fold-var_118" +" lst_130)" +"(begin" +" 'for-loop" +"(if(not" +"(null?" +" lst_130))" +"(let-values(((reqd_2)" +"(if(pair?" +" lst_130)" +"(car" +" lst_130)" +" lst_130))" +"((rest_64)" +"(if(pair?" +" lst_130)" +"(cdr" +" lst_130)" +" null)))" +"(let-values(((fold-var_119)" +"(let-values(((fold-var_120)" +" fold-var_118))" +"(let-values(((fold-var_121)" +"(let-values()" +"(cons" +"(let-values()" +"(normalize-required" +" reqd_2" +" mod-name_13" +" phase_61" +" sym_39))" +" fold-var_120))))" +"(values" +" fold-var_121)))))" +"(if(not" +" #f)" +"(for-loop_159" +" fold-var_119" +" rest_64)" +" fold-var_119)))" +" fold-var_118)))))" +" for-loop_159)" +" fold-var_116" +" lst_129)))))" +"(if(not" +" #f)" +"(for-loop_158" +" fold-var_117" +"(hash-iterate-next" +" ht_98" +" i_130))" +" fold-var_117)))" +" fold-var_116)))))" +" for-loop_158)" +" fold-var_114" +"(hash-iterate-first" +" ht_98))))))" +"(if(not" +" #f)" +"(for-loop_157" +" fold-var_115" +" rest_63)" +" fold-var_115)))" +" fold-var_114)))))" +" for-loop_157)" +" fold-var_112" +" lst_127)))))" +" fold-var_113))))))" +" for-loop_156)" +" fold-var_111)))))))" +"(if(not #f)(for-loop_140 fold-var_110 rest_62) fold-var_110)))" +" fold-var_109)))))" +" for-loop_140)" +" null" +" lst_125)))))))))))" +"(define-values" +"(add-provide!107.1)" +"(lambda(as-protected?96_0" +" as-transformer?97_0" +" r+p100_0" +" sym101_0" +" phase102_0" +" binding103_0" +" immed-binding104_0" +" id105_0" +" orig-s106_0)" +"(begin" +" 'add-provide!107" +"(let-values(((r+p_13) r+p100_0))" +"(let-values(((sym_40) sym101_0))" +"(let-values(((phase_62) phase102_0))" +"(let-values(((binding_14) binding103_0))" +"(let-values(((immed-binding_0) immed-binding104_0))" +"(let-values(((id_28) id105_0))" +"(let-values(((orig-s_2) orig-s106_0))" +"(let-values(((as-protected?_0) as-protected?96_0))" +"(let-values(((as-transformer?_2) as-transformer?97_0))" +"(let-values()" +"(begin" +"(if(if as-protected?_0" +"(not(eq?(module-binding-module immed-binding_0)(requires+provides-self r+p_13)))" +" #f)" +"(let-values()" +" (raise-syntax-error$1 #f \"cannot protect required identifier in re-provide\" sym_40))" +"(void))" +"(hash-update!" +"(requires+provides-provides r+p_13)" +" phase_62" +"(lambda(at-phase_9)" +"(let-values(((b/p_0)(hash-ref at-phase_9 sym_40 #f)))" +"(let-values(((b_68)(provided-as-binding b/p_0)))" +"(if(not b_68)" +"(let-values()" +"(let-values(((plain-binding_0)" +"(if(binding-free=id binding_14)" +"(let-values(((temp159_0) #f))" +"(module-binding-update48.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp159_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" binding_14))" +" binding_14)))" +"(hash-set" +" at-phase_9" +" sym_40" +"(if(let-values(((or-part_179) as-protected?_0))" +"(if or-part_179 or-part_179 as-transformer?_2))" +"(provided1.1 plain-binding_0 as-protected?_0 as-transformer?_2)" +" plain-binding_0))))" +"(if(same-binding? b_68 binding_14)" +"(let-values() at-phase_9)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"identifier already provided (as a different binding)\"" +" orig-s_2" +" id_28)))))))" +" '#hasheq())))))))))))))))" +"(define-values" +"(extract-requires-and-provides)" +"(lambda(r+p_14 old-self_0 new-self_1)" +"(begin" +"(let-values(((extract-requires_0)" +"(lambda()" +"(begin" +" 'extract-requires" +"(let-values(((phase-to-mpis-in-order_0)(requires+provides-require-mpis-in-order r+p_14)))" +"(let-values(((phases-in-order_1)" +"(let-values(((temp160_0)(hash-keys phase-to-mpis-in-order_0))" +"((phasesym-set" +" id147_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'prefix)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_8" +" prefix154_0" +" id:prefix155_0" +" spec156_0)" +"(let-values(((s_225)" +" req_0))" +"(let-values(((orig-s_10)" +" s_225))" +"(let-values(((prefix154_1" +" id:prefix155_1" +" spec156_1)" +"(let-values(((s_226)" +"(if(syntax?$1" +" s_225)" +"(syntax-e$1" +" s_225)" +" s_225)))" +"(if(pair?" +" s_226)" +"(let-values(((prefix157_0)" +"(let-values(((s_227)" +"(car" +" s_226)))" +" s_227))" +"((id:prefix158_0" +" spec159_0)" +"(let-values(((s_228)" +"(cdr" +" s_226)))" +"(let-values(((s_229)" +"(if(syntax?$1" +" s_228)" +"(syntax-e$1" +" s_228)" +" s_228)))" +"(if(pair?" +" s_229)" +"(let-values(((id:prefix160_0)" +"(let-values(((s_230)" +"(car" +" s_229)))" +"(if(let-values(((or-part_185)" +"(if(syntax?$1" +" s_230)" +"(symbol?" +"(syntax-e$1" +" s_230))" +" #f)))" +"(if or-part_185" +" or-part_185" +"(symbol?" +" s_230)))" +" s_230" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_10" +" s_230))))" +"((spec161_0)" +"(let-values(((s_231)" +"(cdr" +" s_229)))" +"(let-values(((s_232)" +"(if(syntax?$1" +" s_231)" +"(syntax-e$1" +" s_231)" +" s_231)))" +"(if(pair?" +" s_232)" +"(let-values(((spec162_0)" +"(let-values(((s_233)" +"(car" +" s_232)))" +" s_233))" +"(()" +"(let-values(((s_234)" +"(cdr" +" s_232)))" +"(let-values(((s_235)" +"(if(syntax?$1" +" s_234)" +"(syntax-e$1" +" s_234)" +" s_234)))" +"(if(null?" +" s_235)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10))))))" +"(values" +" spec162_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10))))))" +"(values" +" id:prefix160_0" +" spec161_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10))))))" +"(values" +" prefix157_0" +" id:prefix158_0" +" spec159_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_10)))))" +"(values" +" #t" +" prefix154_1" +" id:prefix155_1" +" spec156_1))))))" +"(loop_83" +"(list" +" spec156_0)" +"(let-values(((or-part_186)" +" top-req_0))" +"(if or-part_186" +" or-part_186" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-prefix2.1" +"(syntax-e$1" +" id:prefix155_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'all-except)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_9" +" all-except163_0" +" spec164_0" +" id165_0)" +"(let-values(((s_236)" +" req_0))" +"(let-values(((orig-s_11)" +" s_236))" +"(let-values(((all-except163_1" +" spec164_1" +" id165_1)" +"(let-values(((s_237)" +"(if(syntax?$1" +" s_236)" +"(syntax-e$1" +" s_236)" +" s_236)))" +"(if(pair?" +" s_237)" +"(let-values(((all-except166_0)" +"(let-values(((s_238)" +"(car" +" s_237)))" +" s_238))" +"((spec167_0" +" id168_0)" +"(let-values(((s_239)" +"(cdr" +" s_237)))" +"(let-values(((s_240)" +"(if(syntax?$1" +" s_239)" +"(syntax-e$1" +" s_239)" +" s_239)))" +"(if(pair?" +" s_240)" +"(let-values(((spec169_0)" +"(let-values(((s_241)" +"(car" +" s_240)))" +" s_241))" +"((id170_0)" +"(let-values(((s_242)" +"(cdr" +" s_240)))" +"(let-values(((s_243)" +"(if(syntax?$1" +" s_242)" +"(syntax-e$1" +" s_242)" +" s_242)))" +"(let-values(((flat-s_6)" +"(to-syntax-list.1" +" s_243)))" +"(if(not" +" flat-s_6)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_11))" +"(let-values()" +"(let-values(((id_34)" +"(let-values(((lst_137)" +" flat-s_6))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_137)))" +"((letrec-values(((for-loop_165)" +"(lambda(id_35" +" lst_138)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_138)" +"(let-values(((s_244)" +"(unsafe-car" +" lst_138))" +"((rest_69)" +"(unsafe-cdr" +" lst_138)))" +"(let-values(((id_36)" +"(let-values(((id_37)" +" id_35))" +"(let-values(((id_38)" +"(let-values()" +"(let-values(((id171_0)" +"(let-values()" +"(if(let-values(((or-part_187)" +"(if(syntax?$1" +" s_244)" +"(symbol?" +"(syntax-e$1" +" s_244))" +" #f)))" +"(if or-part_187" +" or-part_187" +"(symbol?" +" s_244)))" +" s_244" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_11" +" s_244)))))" +"(cons" +" id171_0" +" id_37)))))" +"(values" +" id_38)))))" +"(if(not" +" #f)" +"(for-loop_165" +" id_36" +" rest_69)" +" id_36)))" +" id_35)))))" +" for-loop_165)" +" null" +" lst_137)))))" +"(reverse$1" +" id_34)))))))))" +"(values" +" spec169_0" +" id170_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_11))))))" +"(values" +" all-except166_0" +" spec167_0" +" id168_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_11)))))" +"(values" +" #t" +" all-except163_1" +" spec164_1" +" id165_1))))))" +"(loop_83" +"(list" +" spec164_0)" +"(let-values(((or-part_188)" +" top-req_0))" +"(if or-part_188" +" or-part_188" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-all-except3.1" +" '||" +"(ids->sym-set" +" id165_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'prefix-all-except)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_10" +" prefix-all-except172_0" +" id:prefix173_0" +" spec174_0" +" id175_0)" +"(let-values(((s_245)" +" req_0))" +"(let-values(((orig-s_12)" +" s_245))" +"(let-values(((prefix-all-except172_1" +" id:prefix173_1" +" spec174_1" +" id175_1)" +"(let-values(((s_246)" +"(if(syntax?$1" +" s_245)" +"(syntax-e$1" +" s_245)" +" s_245)))" +"(if(pair?" +" s_246)" +"(let-values(((prefix-all-except176_0)" +"(let-values(((s_247)" +"(car" +" s_246)))" +" s_247))" +"((id:prefix177_0" +" spec178_0" +" id179_0)" +"(let-values(((s_248)" +"(cdr" +" s_246)))" +"(let-values(((s_249)" +"(if(syntax?$1" +" s_248)" +"(syntax-e$1" +" s_248)" +" s_248)))" +"(if(pair?" +" s_249)" +"(let-values(((id:prefix180_0)" +"(let-values(((s_250)" +"(car" +" s_249)))" +"(if(let-values(((or-part_189)" +"(if(syntax?$1" +" s_250)" +"(symbol?" +"(syntax-e$1" +" s_250))" +" #f)))" +"(if or-part_189" +" or-part_189" +"(symbol?" +" s_250)))" +" s_250" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_12" +" s_250))))" +"((spec181_0" +" id182_0)" +"(let-values(((s_251)" +"(cdr" +" s_249)))" +"(let-values(((s_252)" +"(if(syntax?$1" +" s_251)" +"(syntax-e$1" +" s_251)" +" s_251)))" +"(if(pair?" +" s_252)" +"(let-values(((spec183_0)" +"(let-values(((s_253)" +"(car" +" s_252)))" +" s_253))" +"((id184_0)" +"(let-values(((s_254)" +"(cdr" +" s_252)))" +"(let-values(((s_255)" +"(if(syntax?$1" +" s_254)" +"(syntax-e$1" +" s_254)" +" s_254)))" +"(let-values(((flat-s_7)" +"(to-syntax-list.1" +" s_255)))" +"(if(not" +" flat-s_7)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12))" +"(let-values()" +"(let-values(((id_39)" +"(let-values(((lst_139)" +" flat-s_7))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_139)))" +"((letrec-values(((for-loop_166)" +"(lambda(id_40" +" lst_140)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_140)" +"(let-values(((s_256)" +"(unsafe-car" +" lst_140))" +"((rest_70)" +"(unsafe-cdr" +" lst_140)))" +"(let-values(((id_41)" +"(let-values(((id_42)" +" id_40))" +"(let-values(((id_43)" +"(let-values()" +"(let-values(((id185_0)" +"(let-values()" +"(if(let-values(((or-part_190)" +"(if(syntax?$1" +" s_256)" +"(symbol?" +"(syntax-e$1" +" s_256))" +" #f)))" +"(if or-part_190" +" or-part_190" +"(symbol?" +" s_256)))" +" s_256" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_12" +" s_256)))))" +"(cons" +" id185_0" +" id_42)))))" +"(values" +" id_43)))))" +"(if(not" +" #f)" +"(for-loop_166" +" id_41" +" rest_70)" +" id_41)))" +" id_40)))))" +" for-loop_166)" +" null" +" lst_139)))))" +"(reverse$1" +" id_39)))))))))" +"(values" +" spec183_0" +" id184_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12))))))" +"(values" +" id:prefix180_0" +" spec181_0" +" id182_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12))))))" +"(values" +" prefix-all-except176_0" +" id:prefix177_0" +" spec178_0" +" id179_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_12)))))" +"(values" +" #t" +" prefix-all-except172_1" +" id:prefix173_1" +" spec174_1" +" id175_1))))))" +"(loop_83" +"(list" +" spec174_0)" +"(let-values(((or-part_191)" +" top-req_0))" +"(if or-part_191" +" or-part_191" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-all-except3.1" +"(syntax-e$1" +" id:prefix173_0)" +"(ids->sym-set" +" id175_0))" +" #f" +" #f" +" 'path))))" +"(if(equal?" +" tmp_24" +" 'rename)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_0" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_11" +" rename186_0" +" spec187_0" +" id:to188_0" +" id:from189_0)" +"(let-values(((s_257)" +" req_0))" +"(let-values(((orig-s_13)" +" s_257))" +"(let-values(((rename186_1" +" spec187_1" +" id:to188_1" +" id:from189_1)" +"(let-values(((s_258)" +"(if(syntax?$1" +" s_257)" +"(syntax-e$1" +" s_257)" +" s_257)))" +"(if(pair?" +" s_258)" +"(let-values(((rename190_0)" +"(let-values(((s_259)" +"(car" +" s_258)))" +" s_259))" +"((spec191_0" +" id:to192_0" +" id:from193_0)" +"(let-values(((s_260)" +"(cdr" +" s_258)))" +"(let-values(((s_261)" +"(if(syntax?$1" +" s_260)" +"(syntax-e$1" +" s_260)" +" s_260)))" +"(if(pair?" +" s_261)" +"(let-values(((spec194_0)" +"(let-values(((s_262)" +"(car" +" s_261)))" +" s_262))" +"((id:to195_0" +" id:from196_0)" +"(let-values(((s_263)" +"(cdr" +" s_261)))" +"(let-values(((s_264)" +"(if(syntax?$1" +" s_263)" +"(syntax-e$1" +" s_263)" +" s_263)))" +"(if(pair?" +" s_264)" +"(let-values(((id:to197_0)" +"(let-values(((s_265)" +"(car" +" s_264)))" +"(if(let-values(((or-part_192)" +"(if(syntax?$1" +" s_265)" +"(symbol?" +"(syntax-e$1" +" s_265))" +" #f)))" +"(if or-part_192" +" or-part_192" +"(symbol?" +" s_265)))" +" s_265" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_13" +" s_265))))" +"((id:from198_0)" +"(let-values(((s_266)" +"(cdr" +" s_264)))" +"(let-values(((s_267)" +"(if(syntax?$1" +" s_266)" +"(syntax-e$1" +" s_266)" +" s_266)))" +"(if(pair?" +" s_267)" +"(let-values(((id:from199_0)" +"(let-values(((s_268)" +"(car" +" s_267)))" +"(if(let-values(((or-part_193)" +"(if(syntax?$1" +" s_268)" +"(symbol?" +"(syntax-e$1" +" s_268))" +" #f)))" +"(if or-part_193" +" or-part_193" +"(symbol?" +" s_268)))" +" s_268" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_13" +" s_268))))" +"(()" +"(let-values(((s_269)" +"(cdr" +" s_267)))" +"(let-values(((s_270)" +"(if(syntax?$1" +" s_269)" +"(syntax-e$1" +" s_269)" +" s_269)))" +"(if(null?" +" s_270)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" id:from199_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" id:to197_0" +" id:from198_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" spec194_0" +" id:to195_0" +" id:from196_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13))))))" +"(values" +" rename190_0" +" spec191_0" +" id:to192_0" +" id:from193_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_13)))))" +"(values" +" #t" +" rename186_1" +" spec187_1" +" id:to188_1" +" id:from189_1))))))" +"(loop_83" +"(list" +" spec187_0)" +"(let-values(((or-part_194)" +" top-req_0))" +"(if or-part_194" +" or-part_194" +" req_0))" +" phase-shift_9" +" just-meta_0" +"(adjust-rename4.1" +" id:to188_0" +"(syntax-e$1" +" id:from189_0))" +" #f" +" #f" +" 'path))))" +"(let-values()" +"(let-values(((maybe-mp_0)" +"(syntax->datum$1" +" req_0)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_195)" +"(1/module-path?" +" maybe-mp_0)))" +"(if or-part_195" +" or-part_195" +"(1/resolved-module-path?" +" maybe-mp_0)))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad require spec\"" +" orig-s_3" +" req_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_196)" +" adjust_0))" +"(if or-part_196" +" or-part_196" +"(not" +"(eq?" +" just-meta_0" +" 'all))))" +"(let-values()" +"(set-requires+provides-all-bindings-simple?!" +" requires+provides_1" +" #f))" +"(void))" +"(values))))" +"(let-values(((mp_0)" +"(if(1/resolved-module-path?" +" maybe-mp_0)" +"(resolved-module-path->module-path" +" maybe-mp_0)" +" maybe-mp_0)))" +"(let-values(((mpi_35)" +"(let-values(((declared-submodule-names219_0)" +" declared-submodule-names_2))" +"(module-path->mpi5.1" +" declared-submodule-names219_0" +" #t" +" mp_0" +" self_10))))" +"(begin" +"(let-values(((temp203_0)" +"(let-values(((or-part_197)" +" req_0))" +"(if or-part_197" +" or-part_197" +" top-req_0)))" +"((m-ns204_0)" +" m-ns_8)" +"((phase-shift205_0)" +" phase-shift_9)" +"((run-phase206_0)" +" run-phase_5)" +"((just-meta207_0)" +" just-meta_0)" +"((adjust208_0)" +" adjust_0)" +"((requires+provides209_0)" +" requires+provides_1)" +"((run?210_0)" +" run?_1)" +"((visit?211_0)" +" visit?_1)" +"((copy-variable-phase-level212_0)" +" copy-variable-phase-level_0)" +"((copy-variable-as-constant?213_0)" +" copy-variable-as-constant?_0)" +"((skip-variable-phase-level214_0)" +" skip-variable-phase-level_0)" +"((initial-require?215_0)" +" initial-require?_0)" +"((who216_0)" +" who_12))" +"(perform-require!78.1" +" adjust208_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" copy-variable-as-constant?213_0" +" #t" +" copy-variable-phase-level212_0" +" #t" +" initial-require?215_0" +" #t" +" just-meta207_0" +" #t" +" phase-shift205_0" +" requires+provides209_0" +" #t" +" run-phase206_0" +" run?210_0" +" #t" +" skip-variable-phase-level214_0" +" #t" +" visit?211_0" +" #t" +" who216_0" +" mpi_35" +" req_0" +" self_10" +" temp203_0" +" m-ns204_0))" +"(set! initial-require?_0" +" #f)))))))))))))))))))))))))" +"(values" +" result_69)))))" +"(if(if(not" +"((lambda x_53" +"(not result_68))" +" req_0))" +"(not #f)" +" #f)" +"(for-loop_37" +" result_68" +" rest_67)" +" result_68)))" +" result_29)))))" +" for-loop_37)" +" #t" +" lst_135)))))))" +" loop_83)" +" reqs_0" +" #f" +" phase-shift_8" +" 'all" +" #f" +" #t" +" #t" +" 'raw))))))))))))))))))))" +"(define-values" +"(ids->sym-set)" +"(lambda(ids_3)" +"(begin" +"(let-values(((lst_141) ids_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_141)))" +"((letrec-values(((for-loop_167)" +"(lambda(table_128 lst_142)" +"(begin" +" 'for-loop" +"(if(pair? lst_142)" +"(let-values(((id_44)(unsafe-car lst_142))((rest_71)(unsafe-cdr lst_142)))" +"(let-values(((table_129)" +"(let-values(((table_130) table_128))" +"(let-values(((table_131)" +"(let-values()" +"(let-values(((key_52 val_45)" +"(let-values()" +"(values" +"(let-values()(syntax-e$1 id_44))" +" #t))))" +"(hash-set table_130 key_52 val_45)))))" +"(values table_131)))))" +"(if(not #f)(for-loop_167 table_129 rest_71) table_129)))" +" table_128)))))" +" for-loop_167)" +" '#hash()" +" lst_141))))))" +"(define-values" +"(perform-initial-require!42.1)" +"(lambda(bind?33_0 who34_0 mod-path37_0 self38_0 in-stx39_0 m-ns40_0 requires+provides41_0)" +"(begin" +" 'perform-initial-require!42" +"(let-values(((mod-path_7) mod-path37_0))" +"(let-values(((self_11) self38_0))" +"(let-values(((in-stx_0) in-stx39_0))" +"(let-values(((m-ns_9) m-ns40_0))" +"(let-values(((requires+provides_2) requires+provides41_0))" +"(let-values(((bind?_0) bind?33_0))" +"(let-values(((who_13) who34_0))" +"(let-values()" +"(let-values(((temp220_0)" +"(let-values(((mod-path232_0) mod-path_7)((self233_0) self_11))" +"(module-path->mpi5.1 #f #f mod-path232_0 self233_0)))" +"((temp221_0) #f)" +"((self222_0) self_11)" +"((in-stx223_0) in-stx_0)" +"((m-ns224_0) m-ns_9)" +"((temp225_0) 0)" +"((temp226_0) 0)" +"((requires+provides227_0) requires+provides_2)" +"((temp228_1) #t)" +"((temp229_0) #t)" +"((bind?230_0) bind?_0)" +"((who231_0) who_13))" +"(perform-require!78.1" +" #f" +" #f" +" bind?230_0" +" #t" +" temp228_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp229_0" +" #t" +" #f" +" #f" +" temp225_0" +" requires+provides227_0" +" #t" +" temp226_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" who231_0" +" temp220_0" +" temp221_0" +" self222_0" +" in-stx223_0" +" m-ns224_0)))))))))))))" +"(define-values" +"(perform-require!78.1)" +"(lambda(adjust48_0" +" adjust62_0" +" bind?57_0" +" bind?71_0" +" can-be-shadowed?52_0" +" can-be-shadowed?66_0" +" copy-variable-as-constant?55_0" +" copy-variable-as-constant?69_0" +" copy-variable-phase-level54_0" +" copy-variable-phase-level68_0" +" initial-require?53_0" +" initial-require?67_0" +" just-meta47_0" +" just-meta61_0" +" phase-shift45_0" +" requires+provides49_0" +" requires+provides63_0" +" run-phase46_0" +" run?51_0" +" run?65_0" +" skip-variable-phase-level56_0" +" skip-variable-phase-level70_0" +" visit?50_0" +" visit?64_0" +" who58_0" +" mpi73_0" +" orig-s74_0" +" self75_0" +" in-stx76_0" +" m-ns77_0)" +"(begin" +" 'perform-require!78" +"(let-values(((mpi_36) mpi73_0))" +"(let-values(((orig-s_14) orig-s74_0))" +"(let-values()" +"(let-values(((in-stx_1) in-stx76_0))" +"(let-values(((m-ns_10) m-ns77_0))" +"(let-values(((phase-shift_10) phase-shift45_0))" +"(let-values(((run-phase_6) run-phase46_0))" +"(let-values(((just-meta_1)(if just-meta61_0 just-meta47_0 'all)))" +"(let-values(((adjust_1)(if adjust62_0 adjust48_0 #f)))" +"(let-values(((requires+provides_3)(if requires+provides63_0 requires+provides49_0 #f)))" +"(let-values(((visit?_2)(if visit?64_0 visit?50_0 #t)))" +"(let-values(((run?_2)(if run?65_0 run?51_0 #f)))" +"(let-values(((can-be-shadowed?_3)(if can-be-shadowed?66_0 can-be-shadowed?52_0 #f)))" +"(let-values(((initial-require?_1)(if initial-require?67_0 initial-require?53_0 #f)))" +"(let-values(((copy-variable-phase-level_1)" +"(if copy-variable-phase-level68_0 copy-variable-phase-level54_0 #f)))" +"(let-values(((copy-variable-as-constant?_1)" +"(if copy-variable-as-constant?69_0" +" copy-variable-as-constant?55_0" +" #f)))" +"(let-values(((skip-variable-phase-level_1)" +"(if skip-variable-phase-level70_0" +" skip-variable-phase-level56_0" +" #f)))" +"(let-values(((bind?_1)(if bind?71_0 bind?57_0 #t)))" +"(let-values(((who_14) who58_0))" +"(let-values()" +"(let-values()" +"(let-values(((module-name_0)(1/module-path-index-resolve mpi_36 #t)))" +"(let-values(((bind-in-stx_0)" +"(if(adjust-rename? adjust_1)" +"(adjust-rename-to-id adjust_1)" +" in-stx_1)))" +"(let-values(((done-syms_0)(if adjust_1(make-hash) #f)))" +"(let-values(((m_13)(namespace->module m-ns_10 module-name_0)))" +"(let-values((()" +"(begin" +"(if m_13" +"(void)" +"(let-values()" +"(raise-unknown-module-error" +" 'require" +" module-name_0)))" +"(values))))" +"(let-values(((interned-mpi_0)" +"(if requires+provides_3" +"(add-required-module!" +" requires+provides_3" +" mpi_36" +" phase-shift_10" +"(module-cross-phase-persistent? m_13))" +" mpi_36)))" +"(let-values((()" +"(begin" +"(if visit?_2" +"(let-values()" +"(let-values(((run-phase252_0)" +" run-phase_6))" +"(namespace-module-visit!104.1" +" run-phase252_0" +" #t" +" m-ns_10" +" interned-mpi_0" +" phase-shift_10)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if run?_2" +"(let-values()" +"(let-values(((run-phase256_0)" +" run-phase_6))" +"(namespace-module-instantiate!96.1" +" #f" +" #f" +" run-phase256_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" m-ns_10" +" interned-mpi_0" +" phase-shift_10)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(not" +"(let-values(((or-part_198)" +" visit?_2))" +"(if or-part_198" +" or-part_198" +" run?_2)))" +"(let-values()" +"(let-values(((run-phase260_0)" +" run-phase_6))" +"(namespace-module-make-available!112.1" +" run-phase260_0" +" #t" +" m-ns_10" +" interned-mpi_0" +" phase-shift_10)))" +"(void))" +"(values))))" +"(let-values(((can-bulk-bind?_0)" +"(if(let-values(((or-part_199)" +"(not adjust_1)))" +"(if or-part_199" +" or-part_199" +"(let-values(((or-part_200)" +"(adjust-prefix?" +" adjust_1)))" +"(if or-part_200" +" or-part_200" +"(adjust-all-except?" +" adjust_1)))))" +"(not skip-variable-phase-level_1)" +" #f)))" +"(let-values(((bulk-prefix_1)" +"(if(adjust-prefix? adjust_1)" +"(let-values()" +"(adjust-prefix-sym adjust_1))" +"(if(adjust-all-except? adjust_1)" +"(let-values()" +"(adjust-all-except-prefix-sym" +" adjust_1))" +"(let-values() #f)))))" +"(let-values(((bulk-excepts_1)" +"(if(adjust-all-except? adjust_1)" +"(let-values()" +"(adjust-all-except-syms" +" adjust_1))" +"(let-values() '#hasheq()))))" +"(let-values(((update-nominals-box_0)" +"(if can-bulk-bind?_0" +"(box null)" +" #f)))" +"(let-values((()" +"(begin" +"(let-values(((orig-s240_0)" +" orig-s_14)" +"((temp241_0)" +"(if(adjust-only?" +" adjust_1)" +"(let-values()" +"(set->list" +"(adjust-only-syms" +" adjust_1)))" +"(if(adjust-rename?" +" adjust_1)" +"(let-values()" +"(list" +"(adjust-rename-from-sym" +" adjust_1)))" +"(let-values()" +" #f))))" +"((just-meta242_0)" +" just-meta_1)" +"((bind?243_0)" +" bind?_1)" +"((can-bulk-bind?244_0)" +" can-bulk-bind?_0)" +"((bulk-prefix245_0)" +" bulk-prefix_1)" +"((bulk-excepts246_0)" +" bulk-excepts_1)" +"((temp247_0)" +"(if requires+provides_3" +"(if can-bulk-bind?_0" +"(lambda(provides_6" +" provide-phase-level_4)" +"(begin" +" 'temp247" +"(let-values(((temp263_0)" +"(module-self" +" m_13))" +"((mpi264_0)" +" mpi_36)" +"((phase-shift265_0)" +" phase-shift_10)" +"((provides266_0)" +" provides_6)" +"((provide-phase-level267_0)" +" provide-phase-level_4)" +"((bulk-prefix268_0)" +" bulk-prefix_1)" +"((bulk-excepts269_0)" +" bulk-excepts_1)" +"((temp270_0)" +"(if(positive?" +"(hash-count" +" bulk-excepts_1))" +" done-syms_0" +" #f))" +"((can-be-shadowed?271_0)" +" can-be-shadowed?_3)" +"((temp272_0)" +"(not" +" initial-require?_1))" +"((orig-s273_0)" +" orig-s_14)" +"((update-nominals-box274_0)" +" update-nominals-box_0)" +"((who275_0)" +" who_14))" +"(add-bulk-required-ids!59.1" +" update-nominals-box274_0" +" can-be-shadowed?271_0" +" temp272_0" +" bulk-excepts269_0" +" orig-s273_0" +" bulk-prefix268_0" +" temp270_0" +" who275_0" +" requires+provides_3" +" bind-in-stx_0" +" temp263_0" +" mpi264_0" +" phase-shift265_0" +" provides266_0" +" provide-phase-level267_0))))" +" #f)" +" #f))" +"((temp248_0)" +"(if(let-values(((or-part_201)" +"(not" +" can-bulk-bind?_0)))" +"(if or-part_201" +" or-part_201" +" copy-variable-phase-level_1))" +"(lambda(binding_17" +" as-transformer?_3)" +"(begin" +" 'temp248" +"(let-values(((sym_42)" +"(module-binding-nominal-sym" +" binding_17)))" +"(let-values(((provide-phase_0)" +"(module-binding-nominal-phase" +" binding_17)))" +"(let-values(((adjusted-sym_0)" +"(if(if skip-variable-phase-level_1" +"(if(not" +" as-transformer?_3)" +"(equal?" +" provide-phase_0" +" skip-variable-phase-level_1)" +" #f)" +" #f)" +"(let-values()" +" #f)" +"(if(not" +" adjust_1)" +"(let-values()" +" sym_42)" +"(if(adjust-only?" +" adjust_1)" +"(let-values()" +"(if(set-member?" +"(adjust-only-syms" +" adjust_1)" +" sym_42)" +"(if(hash-set!" +" done-syms_0" +" sym_42" +" #t)" +" sym_42" +" #f)" +" #f))" +"(if(adjust-prefix?" +" adjust_1)" +"(let-values()" +"(string->symbol" +"(format" +" \"~a~a\"" +"(adjust-prefix-sym" +" adjust_1)" +" sym_42)))" +"(if(adjust-all-except?" +" adjust_1)" +"(let-values()" +"(if(not" +"(if(set-member?" +"(adjust-all-except-syms" +" adjust_1)" +" sym_42)" +"(hash-set!" +" done-syms_0" +" sym_42" +" #t)" +" #f))" +"(string->symbol" +"(format" +" \"~a~a\"" +"(adjust-all-except-prefix-sym" +" adjust_1)" +" sym_42))" +" #f))" +"(if(adjust-rename?" +" adjust_1)" +"(let-values()" +"(if(eq?" +" sym_42" +"(adjust-rename-from-sym" +" adjust_1))" +"(if(hash-set!" +" done-syms_0" +" sym_42" +" #t)" +"(adjust-rename-to-id" +" adjust_1)" +" #f)" +" #f))" +"(void)))))))))" +"(begin" +"(if(if adjusted-sym_0" +" requires+provides_3" +" #f)" +"(let-values()" +"(let-values(((s_271)" +"(datum->syntax$1" +" bind-in-stx_0" +" adjusted-sym_0)))" +"(let-values(((bind-phase_0)" +"(phase+" +" phase-shift_10" +" provide-phase_0)))" +"(begin" +"(if initial-require?_1" +"(void)" +"(let-values()" +"(let-values(((temp282_0)" +" #t)" +"((requires+provides283_0)" +" requires+provides_3)" +"((s284_0)" +" s_271)" +"((bind-phase285_0)" +" bind-phase_0)" +"((binding286_0)" +" binding_17)" +"((orig-s287_0)" +" orig-s_14)" +"((temp288_0)" +" #t)" +"((who289_0)" +" who_14))" +"(check-not-defined93.1" +" #f" +" #f" +" temp282_0" +" #t" +" orig-s287_0" +" temp288_0" +" #t" +" binding286_0" +" #t" +" who289_0" +" requires+provides283_0" +" s284_0" +" bind-phase285_0))))" +"(let-values(((can-be-shadowed?280_0)" +" can-be-shadowed?_3)" +"((as-transformer?281_0)" +" as-transformer?_3))" +"(add-defined-or-required-id!19.1" +" as-transformer?281_0" +" can-be-shadowed?280_0" +" #t" +" requires+provides_3" +" s_271" +" bind-phase_0" +" binding_17))))))" +"(void))" +"(if(if adjusted-sym_0" +"(if copy-variable-phase-level_1" +"(if(not" +" as-transformer?_3)" +"(equal?" +" provide-phase_0" +" copy-variable-phase-level_1)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(copy-namespace-value" +" m-ns_10" +" adjusted-sym_0" +" binding_17" +" copy-variable-phase-level_1" +" phase-shift_10" +" copy-variable-as-constant?_1))" +"(void))" +" adjusted-sym_0))))))" +" #f)))" +"(bind-all-provides!105.1" +" bind?243_0" +" temp247_0" +" bulk-excepts246_0" +" bulk-prefix245_0" +" can-bulk-bind?244_0" +" temp248_0" +" orig-s240_0" +" just-meta242_0" +" temp241_0" +" m_13" +" bind-in-stx_0" +" phase-shift_10" +" m-ns_10" +" interned-mpi_0" +" module-name_0))" +"(values))))" +"(let-values((()" +"(begin" +"(if update-nominals-box_0" +"(let-values()" +"(begin" +"(let-values(((lst_143)" +"(unbox" +" update-nominals-box_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_143)))" +"((letrec-values(((for-loop_168)" +"(lambda(lst_144)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_144)" +"(let-values(((update!_1)" +"(unsafe-car" +" lst_144))" +"((rest_72)" +"(unsafe-cdr" +" lst_144)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(update!_1))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_168" +" rest_72)" +"(values))))" +"(values))))))" +" for-loop_168)" +" lst_143)))" +"(void)))" +"(void))" +"(values))))" +"(let-values(((need-syms_0)" +"(if(adjust-only? adjust_1)" +"(let-values()" +"(adjust-only-syms" +" adjust_1))" +"(if(adjust-all-except?" +" adjust_1)" +"(let-values()" +"(adjust-all-except-syms" +" adjust_1))" +"(if(adjust-rename?" +" adjust_1)" +"(let-values()" +"(set" +"(adjust-rename-from-sym" +" adjust_1)))" +"(let-values()" +" #f))))))" +"(if(if need-syms_0" +"(not" +"(=" +"(set-count need-syms_0)" +"(hash-count done-syms_0)))" +" #f)" +"(let-values()" +"(begin" +"(let-values(((ht_93)" +" need-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-immutable-hash-keys" +" ht_93)))" +"((letrec-values(((for-loop_145)" +"(lambda(i_123)" +"(begin" +" 'for-loop" +"(if i_123" +"(let-values(((sym_43)" +"(unsafe-immutable-hash-iterate-key" +" ht_93" +" i_123)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(hash-ref" +" done-syms_0" +" sym_43" +" #f)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" who_14" +" \"not in nested spec\"" +" orig-s_14" +" sym_43))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_145" +"(unsafe-immutable-hash-iterate-next" +" ht_93" +" i_123))" +"(values))))" +"(values))))))" +" for-loop_145)" +"(unsafe-immutable-hash-iterate-first" +" ht_93))))" +"(void)))" +"(void))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(bind-all-provides!105.1)" +"(lambda(bind?84_0" +" bulk-callback89_0" +" bulk-excepts87_0" +" bulk-prefix86_0" +" can-bulk?85_0" +" filter88_0" +" in81_0" +" just-meta83_0" +" only82_0" +" m99_0" +" in-stx100_0" +" phase-shift101_0" +" ns102_0" +" mpi103_0" +" module-name104_0)" +"(begin" +" 'bind-all-provides!105" +"(let-values(((m_14) m99_0))" +"(let-values(((in-stx_2) in-stx100_0))" +"(let-values(((phase-shift_11) phase-shift101_0))" +"(let-values(((ns_48) ns102_0))" +"(let-values(((mpi_37) mpi103_0))" +"(let-values(((module-name_1) module-name104_0))" +"(let-values(((orig-s_15) in81_0))" +"(let-values(((only-syms_0) only82_0))" +"(let-values(((just-meta_2) just-meta83_0))" +"(let-values(((bind?_2) bind?84_0))" +"(let-values(((can-bulk?_0) can-bulk?85_0))" +"(let-values(((bulk-prefix_2) bulk-prefix86_0))" +"(let-values(((bulk-excepts_2) bulk-excepts87_0))" +"(let-values(((filter_0) filter88_0))" +"(let-values(((bulk-callback_0) bulk-callback89_0))" +"(let-values()" +"(let-values(((self_12)(module-self m_14)))" +"(begin" +"(let-values(((ht_101)(module-provides m_14)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_101)))" +"((letrec-values(((for-loop_169)" +"(lambda(i_133)" +"(begin" +" 'for-loop" +"(if i_133" +"(let-values(((provide-phase-level_5 provides_7)" +"(hash-iterate-key+value" +" ht_101" +" i_133)))" +"(let-values((()" +"(let-values()" +"(if(let-values(((or-part_202)" +"(eq?" +" just-meta_2" +" 'all)))" +"(if or-part_202" +" or-part_202" +"(eqv?" +" just-meta_2" +" provide-phase-level_5)))" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((phase_65)" +"(phase+" +" phase-shift_11" +" provide-phase-level_5)))" +"(begin" +"(if bulk-callback_0" +"(let-values()" +"(bulk-callback_0" +" provides_7" +" provide-phase-level_5))" +"(void))" +"(if bind?_2" +"(let-values()" +"(begin" +"(if filter_0" +"(let-values()" +"(begin" +"(let-values(((lst_145)" +"(let-values(((or-part_203)" +" only-syms_0))" +"(if or-part_203" +" or-part_203" +"(hash-keys" +" provides_7)))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_145)))" +"((letrec-values(((for-loop_170)" +"(lambda(lst_146)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_146)" +"(let-values(((sym_44)" +"(unsafe-car" +" lst_146))" +"((rest_73)" +"(unsafe-cdr" +" lst_146)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((binding/p_4)" +"(hash-ref" +" provides_7" +" sym_44" +" #f)))" +"(if binding/p_4" +"(let-values()" +"(let-values(((b_69)" +"(let-values(((self292_0)" +" self_12)" +"((mpi293_0)" +" mpi_37)" +"((provide-phase-level294_0)" +" provide-phase-level_5)" +"((phase-shift295_0)" +" phase-shift_11))" +"(provide-binding-to-require-binding11.1" +" mpi293_0" +" phase-shift295_0" +" provide-phase-level294_0" +" self292_0" +" binding/p_4" +" sym_44))))" +"(let-values(((sym_45)" +"(filter_0" +" b_69" +"(provided-as-transformer?" +" binding/p_4))))" +"(if(if sym_45" +"(not" +" can-bulk?_0)" +" #f)" +"(let-values()" +"(let-values(((temp296_0)" +"(datum->syntax$1" +" in-stx_2" +" sym_45))" +"((b297_0)" +" b_69)" +"((phase298_0)" +" phase_65))" +"(add-binding!17.1" +" #f" +" #f" +" #f" +" #f" +" temp296_0" +" b297_0" +" phase298_0)))" +"(void)))))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_170" +" rest_73)" +"(values))))" +"(values))))))" +" for-loop_170)" +" lst_145)))" +"(void)))" +"(void))" +"(if can-bulk?_0" +"(let-values()" +"(let-values(((bulk-binding-registry_10)" +"(namespace-bulk-binding-registry" +" ns_48)))" +"(let-values(((temp300_0)" +"(bulk-binding14.1" +"(let-values(((or-part_204)" +"(if(not" +" bulk-prefix_2)" +"(if(zero?" +"(hash-count" +" bulk-excepts_2))" +" provides_7" +" #f)" +" #f)))" +"(if or-part_204" +" or-part_204" +"(if(not" +"(registered-bulk-provide?" +" bulk-binding-registry_10" +" module-name_1))" +"(bulk-provides-add-prefix-remove-exceptions" +" provides_7" +" bulk-prefix_2" +" bulk-excepts_2)" +" #f)))" +" bulk-prefix_2" +" bulk-excepts_2" +" self_12" +" mpi_37" +" provide-phase-level_5" +" phase-shift_11" +" bulk-binding-registry_10))" +"((phase301_0)" +" phase_65)" +"((orig-s302_0)" +" orig-s_15))" +"(add-bulk-binding!25.1" +" orig-s302_0" +" #t" +" in-stx_2" +" temp300_0" +" phase301_0))))" +"(void))))" +"(void)))))" +"(values)))))" +"(values)))" +"(values)))))" +"(if(not #f)" +"(for-loop_169" +"(hash-iterate-next ht_101 i_133))" +"(values))))" +"(values))))))" +" for-loop_169)" +"(hash-iterate-first ht_101))))" +"(void))))))))))))))))))))))" +"(define-values" +"(require-spec-shift-for-syntax)" +"(lambda(req_1)" +"(begin" +"(let-values(((rebuild-req_0)" +"(lambda(req_2 new-req_0)(begin 'rebuild-req(datum->syntax$1 req_2 new-req_0 req_2 req_2)))))" +"(letrec-values(((loop_84)" +"(lambda(shifted?_0)" +"(begin" +" 'loop" +"(lambda(req_3)" +"(let-values(((fm_1)" +"(if(pair?(syntax-e$1 req_3))" +"(if(identifier?(car(syntax-e$1 req_3)))" +"(syntax-e$1(car(syntax-e$1 req_3)))" +" #f)" +" #f)))" +"(let-values(((tmp_25) fm_1))" +"(if(equal? tmp_25 'for-meta)" +"(let-values()" +"(let-values(((ok?_12 for-meta303_0 phase-level304_0 spec305_0)" +"(let-values(((s_272) req_3))" +"(let-values(((orig-s_16) s_272))" +"(let-values(((for-meta303_1 phase-level304_1 spec305_1)" +"(let-values(((s_273)" +"(if(syntax?$1 s_272)" +"(syntax-e$1 s_272)" +" s_272)))" +"(if(pair? s_273)" +"(let-values(((for-meta306_0)" +"(let-values(((s_274)" +"(car s_273)))" +" s_274))" +"((phase-level307_0 spec308_0)" +"(let-values(((s_275)" +"(cdr s_273)))" +"(let-values(((s_276)" +"(if(syntax?$1" +" s_275)" +"(syntax-e$1" +" s_275)" +" s_275)))" +"(if(pair? s_276)" +"(let-values(((phase-level309_0)" +"(let-values(((s_277)" +"(car" +" s_276)))" +" s_277))" +"((spec310_0)" +"(let-values(((s_278)" +"(cdr" +" s_276)))" +"(let-values(((s_279)" +"(if(syntax?$1" +" s_278)" +"(syntax-e$1" +" s_278)" +" s_278)))" +"(let-values(((flat-s_8)" +"(to-syntax-list.1" +" s_279)))" +"(if(not" +" flat-s_8)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_16))" +"(let-values()" +" flat-s_8)))))))" +"(values" +" phase-level309_0" +" spec310_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_16))))))" +"(values" +" for-meta306_0" +" phase-level307_0" +" spec308_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_16)))))" +"(values #t for-meta303_1 phase-level304_1 spec305_1))))))" +"(let-values(((p_33)(syntax-e$1 phase-level304_0)))" +"(begin" +"(if(phase? p_33)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"bad phase\" req_3)))" +"(rebuild-req_0" +" req_3" +"(list* for-meta303_0(phase+ p_33 1)(map2(loop_84 #t) spec305_0)))))))" +"(if(equal? tmp_25 'for-syntax)" +"(let-values()" +"(let-values(((ok?_13 for-syntax311_0 spec312_0)" +"(let-values(((s_280) req_3))" +"(let-values(((orig-s_17) s_280))" +"(let-values(((for-syntax311_1 spec312_1)" +"(let-values(((s_281)" +"(if(syntax?$1 s_280)" +"(syntax-e$1 s_280)" +" s_280)))" +"(if(pair? s_281)" +"(let-values(((for-syntax313_0)" +"(let-values(((s_282)" +"(car s_281)))" +" s_282))" +"((spec314_0)" +"(let-values(((s_283)" +"(cdr s_281)))" +"(let-values(((s_284)" +"(if(syntax?$1" +" s_283)" +"(syntax-e$1" +" s_283)" +" s_283)))" +"(let-values(((flat-s_9)" +"(to-syntax-list.1" +" s_284)))" +"(if(not flat-s_9)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_17))" +"(let-values()" +" flat-s_9)))))))" +"(values for-syntax313_0 spec314_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_17)))))" +"(values #t for-syntax311_1 spec312_1))))))" +"(rebuild-req_0 req_3(list* 'for-meta 2(map2(loop_84 #t) spec312_0)))))" +"(if(equal? tmp_25 'for-template)" +"(let-values()" +"(let-values(((ok?_14 for-template315_0 spec316_0)" +"(let-values(((s_285) req_3))" +"(let-values(((orig-s_18) s_285))" +"(let-values(((for-template315_1 spec316_1)" +"(let-values(((s_286)" +"(if(syntax?$1 s_285)" +"(syntax-e$1 s_285)" +" s_285)))" +"(if(pair? s_286)" +"(let-values(((for-template317_0)" +"(let-values(((s_287)" +"(car s_286)))" +" s_287))" +"((spec318_0)" +"(let-values(((s_288)" +"(cdr s_286)))" +"(let-values(((s_289)" +"(if(syntax?$1" +" s_288)" +"(syntax-e$1" +" s_288)" +" s_288)))" +"(let-values(((flat-s_10)" +"(to-syntax-list.1" +" s_289)))" +"(if(not flat-s_10)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_18))" +"(let-values()" +" flat-s_10)))))))" +"(values for-template317_0 spec318_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_18)))))" +"(values #t for-template315_1 spec316_1))))))" +"(rebuild-req_0 req_3(list* 'for-meta 0(map2(loop_84 #t) spec316_0)))))" +"(if(equal? tmp_25 'for-label)" +"(let-values()" +"(let-values(((ok?_15 for-label319_0 spec320_0)" +"(let-values(((s_290) req_3))" +"(let-values(((orig-s_19) s_290))" +"(let-values(((for-label319_1 spec320_1)" +"(let-values(((s_291)" +"(if(syntax?$1 s_290)" +"(syntax-e$1 s_290)" +" s_290)))" +"(if(pair? s_291)" +"(let-values(((for-label321_0)" +"(let-values(((s_292)" +"(car" +" s_291)))" +" s_292))" +"((spec322_0)" +"(let-values(((s_293)" +"(cdr" +" s_291)))" +"(let-values(((s_294)" +"(if(syntax?$1" +" s_293)" +"(syntax-e$1" +" s_293)" +" s_293)))" +"(let-values(((flat-s_11)" +"(to-syntax-list.1" +" s_294)))" +"(if(not flat-s_11)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_19))" +"(let-values()" +" flat-s_11)))))))" +"(values for-label321_0 spec322_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_19)))))" +"(values #t for-label319_1 spec320_1))))))" +"(rebuild-req_0" +" req_3" +"(list* for-label319_0(map2(loop_84 #t) spec320_0)))))" +"(if(equal? tmp_25 'just-meta)" +"(let-values()" +"(let-values(((ok?_16 just-meta323_0 phase-level324_0 spec325_0)" +"(let-values(((s_295) req_3))" +"(let-values(((orig-s_20) s_295))" +"(let-values(((just-meta323_1" +" phase-level324_1" +" spec325_1)" +"(let-values(((s_296)" +"(if(syntax?$1 s_295)" +"(syntax-e$1 s_295)" +" s_295)))" +"(if(pair? s_296)" +"(let-values(((just-meta326_0)" +"(let-values(((s_297)" +"(car" +" s_296)))" +" s_297))" +"((phase-level327_0" +" spec328_0)" +"(let-values(((s_298)" +"(cdr" +" s_296)))" +"(let-values(((s_299)" +"(if(syntax?$1" +" s_298)" +"(syntax-e$1" +" s_298)" +" s_298)))" +"(if(pair? s_299)" +"(let-values(((phase-level329_0)" +"(let-values(((s_300)" +"(car" +" s_299)))" +" s_300))" +"((spec330_0)" +"(let-values(((s_301)" +"(cdr" +" s_299)))" +"(let-values(((s_302)" +"(if(syntax?$1" +" s_301)" +"(syntax-e$1" +" s_301)" +" s_301)))" +"(let-values(((flat-s_12)" +"(to-syntax-list.1" +" s_302)))" +"(if(not" +" flat-s_12)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_20))" +"(let-values()" +" flat-s_12)))))))" +"(values" +" phase-level329_0" +" spec330_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_20))))))" +"(values" +" just-meta326_0" +" phase-level327_0" +" spec328_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_20)))))" +"(values" +" #t" +" just-meta323_1" +" phase-level324_1" +" spec325_1))))))" +"(rebuild-req_0" +" req_3" +"(list*" +" just-meta323_0" +" phase-level324_0" +"(map2(loop_84 #f) spec325_0)))))" +"(let-values()" +"(if shifted?_0" +" req_3" +"(datum->syntax$1 #f(list 'for-syntax req_3))))))))))))))))" +"((loop_84 #f) req_1))))))" +"(define-values" +"(copy-namespace-value)" +"(lambda(m-ns_11 adjusted-sym_1 binding_18 phase-level_15 phase-shift_12 as-constant?_1)" +"(begin" +"(let-values(((i-ns_0)" +"(let-values(((temp332_0)(1/module-path-index-resolve(module-binding-module binding_18)))" +"((temp333_0)(phase-(module-binding-phase binding_18) phase-level_15))" +"((temp334_0) #t))" +"(namespace->module-namespace82.1 #f #f temp334_0 #t #f #f m-ns_11 temp332_0 temp333_0))))" +"(let-values(((val_46)" +"(namespace-get-variable" +" i-ns_0" +"(module-binding-phase binding_18)" +"(module-binding-sym binding_18)" +"(lambda()" +"(error" +" 'namespace-require/copy" +"(format" +"(string-append" +" \"namespace mismatch;\\n\"" +" \" variable not found\\n\"" +" \" module: ~a\\n\"" +" \" variable name: ~s\\n\"" +" \" phase level: ~s\")" +"(module-binding-module binding_18)" +"(module-binding-sym binding_18)" +"(module-binding-phase binding_18)))))))" +"(namespace-set-variable!" +" m-ns_11" +"(phase+ phase-shift_12 phase-level_15)" +" adjusted-sym_1" +" val_46" +" as-constant?_1))))))" +"(define-values" +"(top-level-instance)" +"(1/make-instance" +" 'top-level" +" #f" +" 'constant" +" top-level-bind!-id" +"(lambda(id_22 mpi_38 orig-phase_0 phase-shift_13 ns_49 sym_46 trans?_0 trans-val_0)" +"(let-values(((phase_42)(phase+ orig-phase_0 phase-shift_13)))" +"(let-values(((b_70)" +"(let-values(((temp7_0)(root-expand-context-frame-id(namespace-get-root-expand-ctx ns_49))))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" temp7_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" mpi_38" +" phase_42" +" sym_46))))" +"(begin" +"(let-values(((id1_2) id_22)((b2_4) b_70)((phase3_1) phase_42))" +"(add-binding!17.1 #f #f #f #f id1_2 b2_4 phase3_1))" +"(if trans?_0" +"(let-values()(if trans-val_0(let-values()(maybe-install-free=id! trans-val_0 id_22 phase_42))(void)))" +"(let-values()(namespace-unset-transformer! ns_49 phase_42 sym_46)))))))" +" top-level-require!-id" +"(lambda(stx_11 ns_50)" +"(let-values(((reqs_2)(cdr(syntax->list$1 stx_11))))" +"(let-values(((temp8_1) #t)" +"((temp9_1) #f)" +"((reqs10_0) reqs_2)" +"((temp11_1) #f)" +"((ns12_0) ns_50)" +"((temp13_0)(namespace-phase ns_50))" +"((temp14_2)(let-values(((temp17_0) #f))(make-requires+provides8.1 #f #f temp17_0)))" +"((temp15_2) 'require)" +"((temp16_3) #t))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp16_3" +" #t" +" #f" +" #f" +" temp8_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp9_1" +" #t" +" temp15_2" +" reqs10_0" +" temp11_1" +" ns12_0" +" temp13_0" +" temp14_2))))))" +"(define-values" +"(struct:compiled-in-memory" +" compiled-in-memory1.1" +" compiled-in-memory?" +" compiled-in-memory-linklet-directory" +" compiled-in-memory-original-self" +" compiled-in-memory-requires" +" compiled-in-memory-provides" +" compiled-in-memory-phase-to-link-module-uses" +" compiled-in-memory-compile-time-inspector" +" compiled-in-memory-phase-to-link-extra-inspectorsss" +" compiled-in-memory-mpis" +" compiled-in-memory-syntax-literals" +" compiled-in-memory-pre-compiled-in-memorys" +" compiled-in-memory-post-compiled-in-memorys" +" compiled-in-memory-namespace-scopes" +" compiled-in-memory-purely-functional?)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'compiled-in-memory" +" #f" +" 13" +" 0" +" #f" +"(list" +"(cons" +" prop:custom-write" +"(lambda(cim_0 port_10 mode_11)(write(compiled-in-memory-linklet-directory cim_0) port_10))))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11 12)" +" #f" +" 'compiled-in-memory)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'linklet-directory)" +"(make-struct-field-accessor -ref_0 1 'original-self)" +"(make-struct-field-accessor -ref_0 2 'requires)" +"(make-struct-field-accessor -ref_0 3 'provides)" +"(make-struct-field-accessor -ref_0 4 'phase-to-link-module-uses)" +"(make-struct-field-accessor -ref_0 5 'compile-time-inspector)" +"(make-struct-field-accessor -ref_0 6 'phase-to-link-extra-inspectorsss)" +"(make-struct-field-accessor -ref_0 7 'mpis)" +"(make-struct-field-accessor -ref_0 8 'syntax-literals)" +"(make-struct-field-accessor -ref_0 9 'pre-compiled-in-memorys)" +"(make-struct-field-accessor -ref_0 10 'post-compiled-in-memorys)" +"(make-struct-field-accessor -ref_0 11 'namespace-scopes)" +"(make-struct-field-accessor -ref_0 12 'purely-functional?))))" +"(define-values" +"(struct:namespace-scopes namespace-scopes1.1 namespace-scopes? namespace-scopes-post namespace-scopes-other)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'namespace-scopes #f 2 0 #f null 'prefab #f '(0 1) #f 'namespace-scopes)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'post)" +"(make-struct-field-accessor -ref_0 1 'other))))" +"(define-values" +"(swap-top-level-scopes)" +"(lambda(s_303 original-scopes-s_0 new-ns_0)" +"(begin" +"(let-values(((old-scs-post_0 old-scs-other_0)" +"(if(namespace-scopes? original-scopes-s_0)" +"(values(namespace-scopes-post original-scopes-s_0)(namespace-scopes-other original-scopes-s_0))" +"(decode-namespace-scopes original-scopes-s_0))))" +"(let-values(((new-scs-post_0 new-scs-other_0)(extract-namespace-scopes/values new-ns_0)))" +"(syntax-swap-scopes" +"(syntax-swap-scopes s_303 old-scs-post_0 new-scs-post_0)" +" old-scs-other_0" +" new-scs-other_0))))))" +"(define-values" +"(extract-namespace-scopes/values)" +"(lambda(ns_44)" +"(begin" +"(let-values(((root-ctx_3)(namespace-get-root-expand-ctx ns_44)))" +"(let-values(((post-expansion-sc_0)(root-expand-context-post-expansion-scope root-ctx_3)))" +"(values" +"(seteq post-expansion-sc_0)" +"(set-remove(list->seteq(root-expand-context-module-scopes root-ctx_3)) post-expansion-sc_0)))))))" +"(define-values" +"(extract-namespace-scopes)" +"(lambda(ns_51)" +"(begin" +"(let-values(((scs-post_0 scs-other_0)(extract-namespace-scopes/values ns_51)))" +"(namespace-scopes1.1 scs-post_0 scs-other_0)))))" +"(define-values" +"(encode-namespace-scopes)" +"(lambda(ns_52)" +"(begin" +"(let-values(((post-expansion-scs_0 other-scs_0)(extract-namespace-scopes/values ns_52)))" +"(let-values(((post-expansion-s_0)(add-scopes(datum->syntax$1 #f 'post)(set->list post-expansion-scs_0))))" +"(let-values(((other-s_0)(add-scopes(datum->syntax$1 #f 'other)(set->list other-scs_0))))" +"(datum->syntax$1 #f(vector post-expansion-s_0 other-s_0))))))))" +"(define-values" +"(decode-namespace-scopes)" +"(lambda(stx_12)" +"(begin" +"(let-values(((vec_49)(syntax-e$1 stx_12)))" +"(values(syntax-scope-set(vector-ref vec_49 0) 0)(syntax-scope-set(vector-ref vec_49 1) 0))))))" +"(define-values" +"(namespace-scopes=?)" +"(lambda(nss1_0 nss2_0)" +"(begin" +"(if(set=?(namespace-scopes-post nss1_0)(namespace-scopes-post nss2_0))" +"(set=?(namespace-scopes-other nss1_0)(namespace-scopes-other nss2_0))" +" #f))))" +"(define-values" +"(struct:syntax-literals" +" syntax-literals1.1" +" syntax-literals?" +" syntax-literals-stxes" +" syntax-literals-count" +" set-syntax-literals-stxes!" +" set-syntax-literals-count!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'syntax-literals" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'syntax-literals)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'stxes)" +"(make-struct-field-accessor -ref_0 1 'count)" +"(make-struct-field-mutator -set!_0 0 'stxes)" +"(make-struct-field-mutator -set!_0 1 'count))))" +"(define-values" +"(struct:header" +" header2.1" +" header?" +" header-module-path-indexes" +" header-binding-sym-to-define-sym" +" header-binding-syms-in-order" +" header-require-var-to-import-sym" +" header-import-sym-to-extra-inspectors" +" header-require-vars-in-order" +" header-define-and-import-syms" +" header-syntax-literals" +" set-header-binding-syms-in-order!" +" set-header-require-vars-in-order!)" +"(let-values(((struct:_62 make-_62 ?_62 -ref_62 -set!_62)" +"(let-values()" +"(let-values()" +"(make-struct-type 'header #f 8 0 #f null(current-inspector) #f '(0 1 3 4 6 7) #f 'header)))))" +"(values" +" struct:_62" +" make-_62" +" ?_62" +"(make-struct-field-accessor -ref_62 0 'module-path-indexes)" +"(make-struct-field-accessor -ref_62 1 'binding-sym-to-define-sym)" +"(make-struct-field-accessor -ref_62 2 'binding-syms-in-order)" +"(make-struct-field-accessor -ref_62 3 'require-var-to-import-sym)" +"(make-struct-field-accessor -ref_62 4 'import-sym-to-extra-inspectors)" +"(make-struct-field-accessor -ref_62 5 'require-vars-in-order)" +"(make-struct-field-accessor -ref_62 6 'define-and-import-syms)" +"(make-struct-field-accessor -ref_62 7 'syntax-literals)" +"(make-struct-field-mutator -set!_62 2 'binding-syms-in-order)" +"(make-struct-field-mutator -set!_62 5 'require-vars-in-order))))" +"(define-values" +"(struct:variable-use variable-use3.1 variable-use? variable-use-module-use variable-use-sym)" +"(let-values(((struct:_63 make-_63 ?_63 -ref_63 -set!_63)" +"(let-values()" +"(let-values()(make-struct-type 'variable-use #f 2 0 #f null #f #f '(0 1) #f 'variable-use)))))" +"(values" +" struct:_63" +" make-_63" +" ?_63" +"(make-struct-field-accessor -ref_63 0 'module-use)" +"(make-struct-field-accessor -ref_63 1 'sym))))" +"(define-values(make-syntax-literals)(lambda()(begin(syntax-literals1.1 null 0))))" +"(define-values" +"(make-header)" +"(lambda(mpis_11 syntax-literals_0)" +"(begin" +"(header2.1 mpis_11(make-hasheq) null(make-variable-uses)(make-hasheq) null(make-hasheq) syntax-literals_0))))" +"(define-values(make-variable-uses)(lambda()(begin(make-hash))))" +"(define-values" +"(add-syntax-literal!)" +"(lambda(header-or-literals_0 q_0)" +"(begin" +"(let-values(((sl_0)" +"(if(header? header-or-literals_0)" +"(header-syntax-literals header-or-literals_0)" +" header-or-literals_0)))" +"(let-values(((pos_83)(syntax-literals-count sl_0)))" +"(begin" +"(set-syntax-literals-count! sl_0(add1 pos_83))" +"(set-syntax-literals-stxes! sl_0(cons q_0(syntax-literals-stxes sl_0)))" +" pos_83))))))" +"(define-values" +"(add-syntax-literals!)" +"(lambda(sl_1 vec_50)" +"(begin" +"(let-values(((pos_84)(syntax-literals-count sl_1)))" +"(begin" +"(let-values(((vec_51 len_27)" +"(let-values(((vec_52) vec_50))" +"(begin(check-vector vec_52)(values vec_52(unsafe-vector-length vec_52))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_171)" +"(lambda(pos_85)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_85 len_27)" +"(let-values(((e_12)(unsafe-vector-ref vec_51 pos_85)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(add-syntax-literal! sl_1 e_12))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_171(unsafe-fx+ 1 pos_85))(values))))" +"(values))))))" +" for-loop_171)" +" 0)))" +"(void)" +"(cons pos_84(vector-length vec_50)))))))" +"(define-values(syntax-literals-empty?)(lambda(sl_2)(begin(null?(syntax-literals-stxes sl_2)))))" +"(define-values" +"(generate-lazy-syntax-literals!9.1)" +"(lambda(skip-deserialize?4_0 skip-deserialize?5_0 sl6_0 mpis7_0 self8_0)" +"(begin" +" 'generate-lazy-syntax-literals!9" +"(let-values(((sl_3) sl6_0))" +"(let-values(((mpis_12) mpis7_0))" +"(let-values(((self_13) self8_0))" +"(let-values(((skip-deserialize?_0)(if skip-deserialize?5_0 skip-deserialize?4_0 #f)))" +"(let-values()" +"(list" +"(list 'define-values(list syntax-literals-id)(list* 'make-vector(syntax-literals-count sl_3) '(#f)))" +"(list" +" 'define-values" +"(list get-syntax-literal!-id)" +"(list" +" 'lambda" +" '(pos)" +"(list" +" 'let-values" +"(list(list '(ready-stx)(list* unsafe-vector-ref-id syntax-literals-id '(pos))))" +"(list" +" 'if" +" 'ready-stx" +" 'ready-stx" +"(list*" +" 'begin" +"(qq-append" +"(if skip-deserialize?_0" +" null" +"(list" +"(list" +" 'if" +"(list* unsafe-vector-ref-id deserialized-syntax-vector-id '(0))" +" '(void)" +"(list deserialize-syntax-id bulk-binding-registry-id))))" +"(list" +"(list" +" 'let-values" +"(list" +"(list" +" '(stx)" +"(list" +" 'syntax-module-path-index-shift" +"(list" +" 'syntax-shift-phase-level" +"(list* unsafe-vector-ref-id deserialized-syntax-vector-id '(pos))" +" phase-shift-id)" +"(add-module-path-index! mpis_12 self_13)" +" self-id" +" inspector-id)))" +"(list" +" 'begin" +"(list* 'vector-cas! syntax-literals-id '(pos #f stx))" +"(list* unsafe-vector-ref-id syntax-literals-id '(pos))))))))))))))))))))" +"(define-values" +"(generate-lazy-syntax-literals-data!)" +"(lambda(sl_4 mpis_4)" +"(begin" +"(if(syntax-literals-empty? sl_4)" +"(let-values()(list(list* 'define-values(list deserialize-syntax-id) '(#f))))" +"(let-values()" +"(list" +"(list" +" 'define-values" +"(list deserialize-syntax-id)" +"(list" +" 'lambda" +"(list bulk-binding-registry-id)" +"(list" +" 'begin" +"(list" +" 'vector-copy!" +" deserialized-syntax-vector-id" +" ''0" +"(list" +" 'let-values" +"(list(list*(list inspector-id) '(#f)))" +"(let-values(((temp25_1)" +"(vector->immutable-vector(list->vector(reverse$1(syntax-literals-stxes sl_4)))))" +"((mpis26_0) mpis_4))" +"(generate-deserialize6.1 #f #f temp25_1 mpis26_0))))" +"(list* 'set! deserialize-syntax-id '(#f)))))))))))" +"(define-values(generate-lazy-syntax-literal-lookup)(lambda(pos_86)(begin(list get-syntax-literal!-id pos_86))))" +"(define-values" +"(generate-eager-syntax-literals!)" +"(lambda(sl_5 mpis_13 base-phase_0 self_14 ns_53)" +"(begin" +"(if(syntax-literals-empty? sl_5)" +"(let-values() #f)" +"(let-values()" +"(list" +" 'let-values" +"(list" +"(list" +" '(ns+stxss)" +"(let-values(((temp27_2)(cons(encode-namespace-scopes ns_53)(reverse$1(syntax-literals-stxes sl_5))))" +"((mpis28_0) mpis_13))" +"(generate-deserialize6.1 #f #f temp27_2 mpis28_0))))" +"(list" +" 'let-values" +" '(((ns-scope-s)(car ns+stxss)))" +"(list" +" 'list->vector" +"(list*" +" 'map" +"(list" +" 'lambda" +" '(stx)" +"(list" +" 'swap-top-level-scopes" +"(list" +" 'syntax-module-path-index-shift" +"(list 'syntax-shift-phase-level 'stx(list '- base-phase_0 dest-phase-id))" +"(add-module-path-index! mpis_13 self_14)" +" self-id)" +" 'ns-scope-s" +" ns-id))" +" '((cdr ns+stxss)))))))))))" +"(define-values" +"(generate-eager-syntax-literal-lookup)" +"(lambda(pos_87)(begin(list unsafe-vector-ref-id syntax-literals-id pos_87))))" +"(define-values" +"(syntax-literals-as-vector)" +"(lambda(sl_6)(begin(list->vector(reverse$1(syntax-literals-stxes sl_6))))))" +"(define-values" +"(select-fresh)" +"(lambda(sym_4 header_0)" +"(begin" +"(if(symbol-conflicts? sym_4 header_0)" +"((letrec-values(((loop_85)" +"(lambda(pos_88)" +"(begin" +" 'loop" +" (let-values (((new-sym_0) (string->symbol (format \"~a/~a\" pos_88 sym_4))))" +"(if(symbol-conflicts? new-sym_0 header_0)(loop_85(add1 pos_88)) new-sym_0))))))" +" loop_85)" +" 1)" +" sym_4))))" +"(define-values" +"(symbol-conflicts?)" +"(lambda(sym_47 header_1)" +"(begin" +"(let-values(((or-part_46)(built-in-symbol? sym_47)))" +"(if or-part_46 or-part_46(hash-ref(header-define-and-import-syms header_1) sym_47 #f))))))" +"(define-values" +"(register-required-variable-use!19.1)" +"(lambda(defined?12_0 defined?13_0 header14_0 mpi15_0 phase16_1 sym17_0 extra-inspector18_0)" +"(begin" +" 'register-required-variable-use!19" +"(let-values(((header_2) header14_0))" +"(let-values(((mpi_39) mpi15_0))" +"(let-values(((phase_3) phase16_1))" +"(let-values(((sym_48) sym17_0))" +"(let-values(((extra-inspector_4) extra-inspector18_0))" +"(let-values(((defined?_1)(if defined?13_0 defined?12_0 #f)))" +"(let-values()" +"(let-values(((key_53)(variable-use3.1(module-use1.1 mpi_39 phase_3) sym_48)))" +"(let-values(((variable-uses_0)(header-require-var-to-import-sym header_2)))" +"(let-values(((prev-var-sym_0)(hash-ref variable-uses_0 key_53 #f)))" +"(let-values(((var-sym_0)" +"(let-values(((or-part_60) prev-var-sym_0))" +"(if or-part_60" +" or-part_60" +"(let-values(((sym_49)(select-fresh(variable-use-sym key_53) header_2)))" +"(begin" +"(hash-set! variable-uses_0 key_53 sym_49)" +"(set-header-require-vars-in-order!" +" header_2" +"(cons key_53(header-require-vars-in-order header_2)))" +"(hash-set!" +"(header-define-and-import-syms header_2)" +" sym_49" +"(if defined?_1 'defined 'required))" +" sym_49))))))" +"(begin" +"(if(if extra-inspector_4(not prev-var-sym_0) #f)" +"(let-values()" +"(let-values(((extra-inspectors_0)(header-import-sym-to-extra-inspectors header_2)))" +"(hash-update!" +" extra-inspectors_0" +" var-sym_0" +"(lambda(s_304)(set-add s_304 extra-inspector_4))" +" '#hasheq())))" +"(void))" +" var-sym_0)))))))))))))))" +"(define-values" +"(register-as-defined!)" +"(lambda(header_3 def-sym_0)(begin(hash-set!(header-define-and-import-syms header_3) def-sym_0 'defined))))" +"(define-values" +"(registered-as-required?)" +"(lambda(header_4 var-sym_1)" +"(begin(eq? 'required(hash-ref(header-define-and-import-syms header_4) var-sym_1 #f)))))" +"(define-values" +"(generate-links+imports)" +"(lambda(header_5 phase_66 cctx_0 cross-linklet-inlining?_0)" +"(begin" +"(let-values(((mod-use-ht_0)" +"(let-values(((lst_147)(header-require-vars-in-order header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_147)))" +"((letrec-values(((for-loop_172)" +"(lambda(ht_102 lst_148)" +"(begin" +" 'for-loop" +"(if(pair? lst_148)" +"(let-values(((vu_0)(unsafe-car lst_148))" +"((rest_74)(unsafe-cdr lst_148)))" +"(let-values(((ht_103)" +"(let-values(((ht_104) ht_102))" +"(let-values(((ht_105)" +"(let-values()" +"(let-values(((mu_2)" +"(variable-use-module-use" +" vu_0)))" +"(if(let-values(((or-part_205)" +"(hash-ref" +" ht_104" +" mu_2" +" #f)))" +"(if or-part_205" +" or-part_205" +"(let-values(((or-part_206)" +"(eq?" +"(module-use-module" +" mu_2)" +"(compile-context-self" +" cctx_0))))" +"(if or-part_206" +" or-part_206" +"(top-level-module-path-index?" +"(module-use-module" +" mu_2))))))" +" ht_104" +"(hash-set ht_104 mu_2 #t))))))" +"(values ht_105)))))" +"(if(not #f)(for-loop_172 ht_103 rest_74) ht_103)))" +" ht_102)))))" +" for-loop_172)" +" '#hash()" +" lst_147)))))" +"(let-values(((link-mod-uses_0)(hash-keys mod-use-ht_0)))" +"(values" +" link-mod-uses_0" +"(reverse$1" +"(let-values(((lst_102) link-mod-uses_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_102)))" +"((letrec-values(((for-loop_117)" +"(lambda(fold-var_25 lst_149)" +"(begin" +" 'for-loop" +"(if(pair? lst_149)" +"(let-values(((mu_3)(unsafe-car lst_149))((rest_75)(unsafe-cdr lst_149)))" +"(let-values(((fold-var_131)" +"(let-values(((fold-var_132) fold-var_25))" +"(let-values(((fold-var_133)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_50)" +"(header-require-vars-in-order" +" header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_50)))" +"((letrec-values(((for-loop_44)" +"(lambda(fold-var_134" +" lst_150)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_150)" +"(let-values(((vu_1)" +"(unsafe-car" +" lst_150))" +"((rest_76)" +"(unsafe-cdr" +" lst_150)))" +"(let-values(((fold-var_135)" +"(let-values(((fold-var_136)" +" fold-var_134))" +"(if(equal?" +" mu_3" +"(variable-use-module-use" +" vu_1))" +"(let-values(((fold-var_137)" +" fold-var_136))" +"(let-values(((fold-var_138)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((var-sym_2)" +"(hash-ref" +"(header-require-var-to-import-sym" +" header_5)" +" vu_1)))" +"(let-values(((ex-sym_0)" +"(variable-use-sym" +" vu_1)))" +"(if(eq?" +" var-sym_2" +" ex-sym_0)" +" var-sym_2" +"(list" +" ex-sym_0" +" var-sym_2)))))" +" fold-var_137))))" +"(values" +" fold-var_138)))" +" fold-var_136))))" +"(if(not" +" #f)" +"(for-loop_44" +" fold-var_135" +" rest_76)" +" fold-var_135)))" +" fold-var_134)))))" +" for-loop_44)" +" null" +" lst_50)))))" +" fold-var_132))))" +"(values fold-var_133)))))" +"(if(not #f)(for-loop_117 fold-var_131 rest_75) fold-var_131)))" +" fold-var_25)))))" +" for-loop_117)" +" null" +" lst_102))))" +"(reverse$1" +"(let-values(((lst_151) link-mod-uses_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_151)))" +"((letrec-values(((for-loop_173)" +"(lambda(fold-var_139 lst_104)" +"(begin" +" 'for-loop" +"(if(pair? lst_104)" +"(let-values(((mu_4)(unsafe-car lst_104))((rest_77)(unsafe-cdr lst_104)))" +"(let-values(((fold-var_140)" +"(let-values(((fold-var_141) fold-var_139))" +"(let-values(((fold-var_142)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((extra-inspectorss_0)" +"(let-values(((lst_152)" +"(header-require-vars-in-order" +" header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_152)))" +"((letrec-values(((for-loop_174)" +"(lambda(table_132" +" lst_153)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_153)" +"(let-values(((vu_2)" +"(unsafe-car" +" lst_153))" +"((rest_78)" +"(unsafe-cdr" +" lst_153)))" +"(let-values(((table_133)" +"(let-values(((table_134)" +" table_132))" +"(if(equal?" +" mu_4" +"(variable-use-module-use" +" vu_2))" +"(let-values(((var-sym_3)" +"(hash-ref" +"(header-require-var-to-import-sym" +" header_5)" +" vu_2)))" +"(begin" +" #t" +"((letrec-values(((for-loop_33)" +"(lambda(table_29)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_135)" +"(let-values(((extra-inspectors_1)" +"(hash-ref" +"(header-import-sym-to-extra-inspectors" +" header_5)" +" var-sym_3" +" #f)))" +"(begin" +" #t" +"((letrec-values(((for-loop_175)" +"(lambda(table_30)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_31)" +"(let-values(((table_32)" +" table_30))" +"(if(let-values(((or-part_207)" +" extra-inspectors_1))" +"(if or-part_207" +" or-part_207" +" cross-linklet-inlining?_0))" +"(let-values(((table_108)" +" table_32))" +"(let-values(((table_109)" +"(let-values()" +"(let-values(((key_54" +" val_47)" +"(let-values()" +"(values" +" var-sym_3" +" extra-inspectors_1))))" +"(hash-set" +" table_108" +" key_54" +" val_47)))))" +"(values" +" table_109)))" +" table_32))))" +" table_31))))))" +" for-loop_175)" +" table_29)))))" +" table_135))))))" +" for-loop_33)" +" table_134)))" +" table_134))))" +"(if(not" +" #f)" +"(for-loop_174" +" table_133" +" rest_78)" +" table_133)))" +" table_132)))))" +" for-loop_174)" +" '#hash()" +" lst_152)))))" +"(if(hash-count extra-inspectorss_0)" +" extra-inspectorss_0" +" #f)))" +" fold-var_141))))" +"(values fold-var_142)))))" +"(if(not #f)(for-loop_173 fold-var_140 rest_77) fold-var_140)))" +" fold-var_139)))))" +" for-loop_173)" +" null" +" lst_151))))" +"(reverse$1" +"(let-values(((lst_41)(header-require-vars-in-order header_5)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_41)))" +"((letrec-values(((for-loop_176)" +"(lambda(fold-var_143 lst_154)" +"(begin" +" 'for-loop" +"(if(pair? lst_154)" +"(let-values(((vu_3)(unsafe-car lst_154))((rest_79)(unsafe-cdr lst_154)))" +"(let-values(((fold-var_144)" +"(let-values(((fold-var_145) fold-var_143))" +"(if(let-values(((mod_2)" +"(module-use-module" +"(variable-use-module-use vu_3))))" +"(let-values(((or-part_208)" +"(eq?" +" mod_2" +"(compile-context-self cctx_0))))" +"(if or-part_208" +" or-part_208" +"(top-level-module-path-index? mod_2))))" +"(let-values(((fold-var_146) fold-var_145))" +"(let-values(((fold-var_147)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((var-sym_4)" +"(hash-ref" +"(header-require-var-to-import-sym" +" header_5)" +" vu_3)))" +"(let-values(((ex-sym_1)" +"(variable-use-sym" +" vu_3)))" +"(if(eq? var-sym_4 ex-sym_1)" +" var-sym_4" +"(list var-sym_4 ex-sym_1)))))" +" fold-var_146))))" +"(values fold-var_147)))" +" fold-var_145))))" +"(if(not #f)(for-loop_176 fold-var_144 rest_79) fold-var_144)))" +" fold-var_143)))))" +" for-loop_176)" +" null" +" lst_41))))))))))" +"(define-values" +"(instance-imports)" +"(list ns-id phase-shift-id self-id inspector-id bulk-binding-registry-id set-transformer!-id))" +"(define-values" +"(make-instance-instance13.1)" +"(lambda(bulk-binding-registry5_0 inspector4_0 namespace1_0 phase-shift2_0 self3_0 set-transformer!6_0)" +"(begin" +" 'make-instance-instance13" +"(let-values(((ns_54) namespace1_0))" +"(let-values(((phase-shift_14) phase-shift2_0))" +"(let-values(((self_15) self3_0))" +"(let-values(((inspector_10) inspector4_0))" +"(let-values(((bulk-binding-registry_11) bulk-binding-registry5_0))" +"(let-values(((set-transformer!_0) set-transformer!6_0))" +"(let-values()" +"(1/make-instance" +" 'instance" +" #f" +" 'constant" +" ns-id" +" ns_54" +" phase-shift-id" +" phase-shift_14" +" self-id" +" self_15" +" inspector-id" +" inspector_10" +" bulk-binding-registry-id" +" bulk-binding-registry_11" +" set-transformer!-id" +" set-transformer!_0)))))))))))" +"(define-values" +"(make-module-body-instance-instance18.1)" +"(lambda(set-transformer!16_0)" +"(begin" +" 'make-module-body-instance-instance18" +"(let-values(((set-transformer!_1) set-transformer!16_0))" +"(let-values()(1/make-instance 'body-instance #f 'constant set-transformer!-id set-transformer!_1))))))" +"(define-values" +"(empty-syntax-literals-instance)" +"(1/make-instance 'empty-stx #f 'constant get-syntax-literal!-id(lambda(pos_89) #f) 'get-encoded-root-expand-ctx #f))" +"(define-values" +"(empty-module-body-instance)" +"(let-values(((temp21_0)(lambda(name_38 val_48)(void))))(make-module-body-instance-instance18.1 temp21_0)))" +"(define-values" +"(empty-top-syntax-literal-instance)" +"(1/make-instance 'top-syntax-literal #f 'constant mpi-vector-id #f syntax-literals-id #f))" +"(define-values" +"(empty-syntax-literals-data-instance)" +"(1/make-instance 'empty-stx-data #f 'constant deserialized-syntax-vector-id(vector) deserialize-syntax-id void))" +"(define-values" +"(empty-instance-instance)" +"(let-values(((temp22_2) #f)((temp23_2) #f)((temp24_3) #f)((temp25_2) #f)((temp26_0) #f)((temp27_3) #f))" +"(make-instance-instance13.1 temp26_0 temp25_2 temp22_2 temp23_2 temp24_3 temp27_3)))" +"(define-values" +"(eager-instance-imports)" +"(list* ns-id dest-phase-id self-id bulk-binding-registry-id inspector-id '(swap-top-level-scopes)))" +"(define-values" +"(make-eager-instance-instance11.1)" +"(lambda(bulk-binding-registry4_0 dest-phase2_0 inspector5_0 namespace1_1 self3_1)" +"(begin" +" 'make-eager-instance-instance11" +"(let-values(((ns_55) namespace1_1))" +"(let-values(((dest-phase_0) dest-phase2_0))" +"(let-values(((self_16) self3_1))" +"(let-values(((bulk-binding-registry_12) bulk-binding-registry4_0))" +"(let-values(((inspector_11) inspector5_0))" +"(let-values()" +"(1/make-instance" +" 'instance" +" #f" +" 'constant" +" ns-id" +" ns_55" +" dest-phase-id" +" dest-phase_0" +" self-id" +" self_16" +" bulk-binding-registry-id" +" bulk-binding-registry_12" +" inspector-id" +" inspector_11" +" 'swap-top-level-scopes" +" swap-top-level-scopes))))))))))" +"(define-values" +"(empty-eager-instance-instance)" +"(let-values(((temp14_3) #f)((temp15_3) #f)((temp16_4) #f)((temp17_1) #f)((temp18_3) #f))" +"(make-eager-instance-instance11.1 temp17_1 temp15_3 temp18_3 temp14_3 temp16_4)))" +"(define-values" +"(self-quoting-in-linklet?)" +"(lambda(datum_0)" +"(begin" +"(let-values(((or-part_0)(number? datum_0)))" +"(if or-part_0" +" or-part_0" +"(let-values(((or-part_1)(boolean? datum_0)))" +"(if or-part_1" +" or-part_1" +"(let-values(((or-part_11)(string? datum_0)))(if or-part_11 or-part_11(bytes? datum_0))))))))))" +"(define-values(datum->syntax$3) datum->syntax)" +"(define-values(syntax-property$2) syntax-property)" +"(define-values(syntax-e$2) syntax-e)" +"(define-values(1/syntax?) syntax?)" +"(define-values(correlated?)(lambda(e_24)(begin(1/syntax? e_24))))" +"(define-values" +"(datum->correlated)" +"(let-values(((datum->correlated4_0)" +"(lambda(d3_0 srcloc1_0 srcloc2_0)" +"(begin" +" 'datum->correlated4" +"(let-values(((d_26) d3_0))" +"(let-values(((srcloc_6)(if srcloc2_0 srcloc1_0 #f)))" +"(let-values()(datum->syntax$3 #f d_26 srcloc_6))))))))" +"(case-lambda" +"((d_27)(begin(datum->correlated4_0 d_27 #f #f)))" +"((d_28 srcloc1_1)(datum->correlated4_0 d_28 srcloc1_1 #t)))))" +"(define-values(correlated-e)(lambda(e_25)(begin(if(1/syntax? e_25)(syntax-e$2 e_25) e_25))))" +"(define-values(correlated-cadr)(lambda(e_26)(begin(car(correlated-e(cdr(correlated-e e_26)))))))" +"(define-values" +"(correlated-length)" +"(lambda(e_27)(begin(let-values(((l_54)(correlated-e e_27)))(if(list? l_54)(length l_54) #f)))))" +"(define-values" +"(correlated->list)" +"(lambda(e_28)" +"(begin" +"((letrec-values(((loop_86)" +"(lambda(e_29)" +"(begin" +" 'loop" +"(if(list? e_29)" +"(let-values() e_29)" +"(if(pair? e_29)" +"(let-values()(cons(car e_29)(loop_86(cdr e_29))))" +"(if(null? e_29)" +"(let-values() null)" +"(if(1/syntax? e_29)" +"(let-values()(loop_86(syntax-e$2 e_29)))" +" (let-values () (error 'correlated->list \"not a list\"))))))))))" +" loop_86)" +" e_28))))" +"(define-values" +"(correlated-property)" +"(case-lambda" +"((e_30 k_30)(begin(syntax-property$2 e_30 k_30)))" +"((e_31 k_31 v_159)(syntax-property$2 e_31 k_31 v_159))))" +"(define-values" +"(to-syntax-list.1$1)" +"(lambda(s_115)" +"(begin" +" 'to-syntax-list" +"(if(list? s_115)" +"(let-values() s_115)" +"(if(pair? s_115)" +"(let-values()(let-values(((r_39)(to-syntax-list.1$1(cdr s_115))))(if r_39(cons(car s_115) r_39) #f)))" +"(if(1/syntax? s_115)(let-values()(to-syntax-list.1$1(syntax-e$2 s_115)))(let-values() #f)))))))" +"(define-values" +"(srcloc->vector)" +"(lambda(s_6)" +"(begin" +"(if s_6" +"(vector(srcloc-source s_6)(srcloc-line s_6)(srcloc-column s_6)(srcloc-position s_6)(srcloc-span s_6))" +" #f))))" +"(define-values" +"(correlate*)" +"(lambda(stx_13 s-exp_0)" +"(begin(if(syntax-srcloc stx_13)(datum->correlated s-exp_0(srcloc->vector(syntax-srcloc stx_13))) s-exp_0))))" +"(define-values(correlate~)(lambda(stx_14 s-exp_1)(begin s-exp_1)))" +"(define-values" +"(correlate/app)" +"(lambda(stx_15 s-exp_2)" +"(begin(if(eq?(system-type 'vm) 'chez-scheme)(correlate* stx_15 s-exp_2)(correlate~ stx_15 s-exp_2)))))" +"(define-values(->correlated)(lambda(s_2)(begin(datum->correlated s_2 #f))))" +"(define-values" +"(compile$2)" +"(let-values(((compile7_0)" +"(lambda(p5_0 cctx6_0 name1_0 result-used?2_0 name3_0 result-used?4_0)" +"(begin" +" 'compile7" +"(let-values(((p_34) p5_0))" +"(let-values(((cctx_1) cctx6_0))" +"(let-values(((name_39)(if name3_0 name1_0 #f)))" +"(let-values(((result-used?_0)(if result-used?4_0 result-used?2_0 #t)))" +"(let-values()" +"(let-values(((compile_0)" +"(lambda(p_35 name_40 result-used?_1)" +"(begin 'compile(compile$2 p_35 cctx_1 name_40 result-used?_1)))))" +"(let-values(((s_10)(parsed-s p_34)))" +"(if(parsed-id? p_34)" +"(let-values()" +"(let-values(((p27_1) p_34)((cctx28_0) cctx_1))" +"(compile-identifier24.1 #f #f #f #f p27_1 cctx28_0)))" +"(if(parsed-lambda? p_34)" +"(let-values()" +"(if result-used?_0" +"(let-values()" +"(add-lambda-properties" +"(correlate*" +" s_10" +"(list*" +" 'lambda" +"(compile-lambda" +"(parsed-lambda-keys p_34)" +"(parsed-lambda-body p_34)" +" cctx_1)))" +" name_39" +" s_10))" +"(let-values()(correlate~ s_10 ''unused-lambda))))" +"(if(parsed-case-lambda? p_34)" +"(let-values()" +"(if result-used?_0" +"(let-values()" +"(add-lambda-properties" +"(correlate*" +" s_10" +"(list*" +" 'case-lambda" +"(reverse$1" +"(let-values(((lst_155)(parsed-case-lambda-clauses p_34)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_155)))" +"((letrec-values(((for-loop_177)" +"(lambda(fold-var_31 lst_156)" +"(begin" +" 'for-loop" +"(if(pair? lst_156)" +"(let-values(((clause_0)" +"(unsafe-car lst_156))" +"((rest_80)" +"(unsafe-cdr lst_156)))" +"(let-values(((fold-var_63)" +"(let-values(((fold-var_148)" +" fold-var_31))" +"(let-values(((fold-var_149)" +"(let-values()" +"(cons" +"(let-values()" +"(compile-lambda" +"(car" +" clause_0)" +"(cadr" +" clause_0)" +" cctx_1))" +" fold-var_148))))" +"(values" +" fold-var_149)))))" +"(if(not #f)" +"(for-loop_177 fold-var_63 rest_80)" +" fold-var_63)))" +" fold-var_31)))))" +" for-loop_177)" +" null" +" lst_155))))))" +" name_39" +" s_10))" +"(let-values()(correlate~ s_10 ''unused-case-lambda))))" +"(if(parsed-app? p_34)" +"(let-values()" +"(let-values(((rands_0)(parsed-app-rands p_34)))" +"(correlate/app" +" s_10" +"(cons" +"(compile_0(parsed-app-rator p_34) #f #t)" +"(reverse$1" +"(let-values(((lst_39) rands_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_39)))" +"((letrec-values(((for-loop_178)" +"(lambda(fold-var_150 lst_157)" +"(begin" +" 'for-loop" +"(if(pair? lst_157)" +"(let-values(((r_40)(unsafe-car lst_157))" +"((rest_40)" +"(unsafe-cdr lst_157)))" +"(let-values(((fold-var_151)" +"(let-values(((fold-var_9)" +" fold-var_150))" +"(let-values(((fold-var_65)" +"(let-values()" +"(cons" +"(let-values()" +"(compile_0" +" r_40" +" #f" +" #t))" +" fold-var_9))))" +"(values" +" fold-var_65)))))" +"(if(not #f)" +"(for-loop_178 fold-var_151 rest_40)" +" fold-var_151)))" +" fold-var_150)))))" +" for-loop_178)" +" null" +" lst_39))))))))" +"(if(parsed-if? p_34)" +"(let-values()" +"(let-values(((tst-e_0)(compile_0(parsed-if-tst p_34) #f #f)))" +"(if(eq?(correlated-e tst-e_0) #t)" +"(let-values()" +"(compile_0(parsed-if-thn p_34) name_39 result-used?_0))" +"(if(eq?(correlated-e tst-e_0) #f)" +"(let-values()" +"(compile_0(parsed-if-els p_34) name_39 result-used?_0))" +"(let-values()" +"(correlate~" +" s_10" +"(list" +" 'if" +" tst-e_0" +"(compile_0(parsed-if-thn p_34) name_39 result-used?_0)" +"(compile_0(parsed-if-els p_34) name_39 result-used?_0))))))))" +"(if(parsed-with-continuation-mark? p_34)" +"(let-values()" +"(correlate~" +" s_10" +"(list" +" 'with-continuation-mark" +"(compile_0(parsed-with-continuation-mark-key p_34) #f #t)" +"(compile_0(parsed-with-continuation-mark-val p_34) #f #t)" +"(compile_0" +"(parsed-with-continuation-mark-body p_34)" +" name_39" +" result-used?_0))))" +"(if(parsed-begin0? p_34)" +"(let-values()" +"(correlate~" +" s_10" +"(list*" +" 'begin0" +"(compile_0(car(parsed-begin0-body p_34)) name_39 result-used?_0)" +"(reverse$1" +"(let-values(((lst_75)(cdr(parsed-begin0-body p_34))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_75)))" +"((letrec-values(((for-loop_101)" +"(lambda(fold-var_11 lst_85)" +"(begin" +" 'for-loop" +"(if(pair? lst_85)" +"(let-values(((e_32)" +"(unsafe-car lst_85))" +"((rest_41)" +"(unsafe-cdr lst_85)))" +"(let-values(((fold-var_152)" +"(let-values(((fold-var_153)" +" fold-var_11))" +"(let-values(((fold-var_154)" +"(let-values()" +"(cons" +"(let-values()" +"(compile_0" +" e_32" +" #f" +" #f))" +" fold-var_153))))" +"(values" +" fold-var_154)))))" +"(if(not #f)" +"(for-loop_101" +" fold-var_152" +" rest_41)" +" fold-var_152)))" +" fold-var_11)))))" +" for-loop_101)" +" null" +" lst_75)))))))" +"(if(parsed-begin? p_34)" +"(let-values()" +"(correlate~" +" s_10" +"(compile-begin" +"(parsed-begin-body p_34)" +" cctx_1" +" name_39" +" result-used?_0)))" +"(if(parsed-set!? p_34)" +"(let-values()" +"(correlate~" +" s_10" +"(let-values(((temp29_1)(parsed-set!-id p_34))" +"((cctx30_0) cctx_1)" +"((temp31_1) #t)" +"((temp32_1)" +"(compile_0" +"(parsed-set!-rhs p_34)" +"(parsed-s(parsed-set!-id p_34))" +" #t)))" +"(compile-identifier24.1" +" temp32_1" +" #t" +" temp31_1" +" #t" +" temp29_1" +" cctx30_0))))" +"(if(parsed-let-values? p_34)" +"(let-values()" +"(let-values(((temp36_0) #f)" +"((result-used?37_0) result-used?_0))" +"(compile-let15.1" +" temp36_0" +" p_34" +" cctx_1" +" name_39" +" result-used?37_0)))" +"(if(parsed-letrec-values? p_34)" +"(let-values()" +"(let-values(((temp41_0) #t)" +"((result-used?42_0) result-used?_0))" +"(compile-let15.1" +" temp41_0" +" p_34" +" cctx_1" +" name_39" +" result-used?42_0)))" +"(if(parsed-quote? p_34)" +"(let-values()" +"(let-values(((datum_1)(parsed-quote-datum p_34)))" +"(if(self-quoting-in-linklet? datum_1)" +"(let-values()(correlate~ s_10 datum_1))" +"(let-values()" +"(correlate~ s_10(list 'quote datum_1))))))" +"(if(parsed-quote-syntax? p_34)" +"(let-values()" +"(if result-used?_0" +"(compile-quote-syntax" +"(parsed-quote-syntax-datum p_34)" +" cctx_1)" +"(correlate~ s_10(list 'quote(syntax->datum$1 s_10)))))" +"(if(parsed-#%variable-reference? p_34)" +"(let-values()" +"(let-values(((id_45)" +"(parsed-#%variable-reference-id p_34)))" +"(correlate~" +" s_10" +"(if id_45" +"(list" +" '#%variable-reference" +"(let-values(((id43_0) id_45)((cctx44_0) cctx_1))" +"(compile-identifier24.1" +" #f" +" #f" +" #f" +" #f" +" id43_0" +" cctx44_0)))" +" '(#%variable-reference)))))" +"(let-values()" +"(error" +" \"unrecognized parsed form:\"" +" p_34)))))))))))))))))))))))))))" +"(case-lambda" +"((p_36 cctx_2)(begin 'compile(compile7_0 p_36 cctx_2 #f #f #f #f)))" +"((p_37 cctx_3 name_41 result-used?2_1)(compile7_0 p_37 cctx_3 name_41 result-used?2_1 #t #t))" +"((p_38 cctx_4 name1_1)(compile7_0 p_38 cctx_4 name1_1 #f #t #f)))))" +"(define-values" +"(compile-lambda)" +"(lambda(formals_0 bodys_0 cctx_5)(begin(list formals_0(compile-sequence bodys_0 cctx_5 #f #t)))))" +"(define-values" +"(compile-sequence)" +"(lambda(bodys_1 cctx_6 name_42 result-used?_2)" +"(begin" +"(if(null?(cdr bodys_1))" +"(compile$2(car bodys_1) cctx_6 name_42 result-used?_2)" +"(compile-begin bodys_1 cctx_6 name_42 result-used?_2)))))" +"(define-values" +"(compile-begin)" +"(lambda(es_0 cctx_7 name_43 result-used?_3)" +"(begin" +"(let-values(((used-pos_0)(sub1(length es_0))))" +"(list*" +" 'begin" +"(reverse$1" +"(let-values(((lst_158) es_0)((start_33) 0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_158)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_33)))" +"((letrec-values(((for-loop_179)" +"(lambda(fold-var_76 lst_159 pos_90)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_159) #t #f)" +"(let-values(((e_33)(unsafe-car lst_159))" +"((rest_81)(unsafe-cdr lst_159))" +"((i_134) pos_90))" +"(let-values(((fold-var_155)" +"(let-values(((fold-var_156) fold-var_76))" +"(let-values(((fold-var_157)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((used?_0)" +"(= i_134 used-pos_0)))" +"(compile$2" +" e_33" +" cctx_7" +"(if used?_0 name_43 #f)" +"(if used?_0 result-used?_3 #f))))" +" fold-var_156))))" +"(values fold-var_157)))))" +"(if(not #f)(for-loop_179 fold-var_155 rest_81(+ pos_90 1)) fold-var_155)))" +" fold-var_76)))))" +" for-loop_179)" +" null" +" lst_158" +" start_33)))))))))" +"(define-values" +"(add-lambda-properties)" +"(lambda(s_305 inferred-name_0 orig-s_21)" +"(begin" +"(letrec-values(((simplify-name_0)" +"(lambda(v_47)" +"(begin" +" 'simplify-name" +"(if(pair? v_47)" +"(let-values()" +"(let-values(((n1_0)(simplify-name_0(car v_47))))" +"(let-values(((n2_0)(simplify-name_0(cdr v_47))))(if(eq? n1_0 n2_0) n1_0 v_47))))" +"(let-values() v_47))))))" +"(let-values(((name_44)" +"(let-values(((or-part_209)" +"(let-values(((v_40)" +"(simplify-name_0(syntax-property$1 orig-s_21 'inferred-name))))" +"(if(let-values(((or-part_210)(symbol? v_40)))" +"(if or-part_210" +" or-part_210" +"(let-values(((or-part_211)(syntax?$1 v_40)))" +"(if or-part_211 or-part_211(void? v_40)))))" +" v_40" +" #f))))" +"(if or-part_209 or-part_209 inferred-name_0))))" +"(let-values(((named-s_0)" +"(if name_44" +"(correlated-property" +"(->correlated s_305)" +" 'inferred-name" +"(if(syntax?$1 name_44)(syntax-e$1 name_44) name_44))" +" s_305)))" +"(let-values(((as-method_0)(syntax-property$1 orig-s_21 'method-arity-error)))" +"(if as-method_0" +"(correlated-property(->correlated named-s_0) 'method-arity-error as-method_0)" +" named-s_0))))))))" +"(define-values" +"(compile-let15.1)" +"(lambda(rec?9_0 p11_0 cctx12_0 name13_0 result-used?14_0)" +"(begin" +" 'compile-let15" +"(let-values(((p_26) p11_0))" +"(let-values(((cctx_8) cctx12_0))" +"(let-values(((name_45) name13_0))" +"(let-values(((rec?_0) rec?9_0))" +"(let-values(((result-used?_4) result-used?14_0))" +"(let-values()" +"(let-values(((body_0)(parsed-let_-values-body p_26)))" +"(correlate~" +"(parsed-s p_26)" +"(list" +"(if rec?_0 'letrec-values 'let-values)" +"(reverse$1" +"(let-values(((lst_160)(parsed-let_-values-clauses p_26))" +"((lst_161)(parsed-let_-values-idss p_26)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_160)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_161)))" +"((letrec-values(((for-loop_34)" +"(lambda(fold-var_158 lst_162 lst_163)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_162)(pair? lst_163) #f)" +"(let-values(((clause_1)(unsafe-car lst_162))" +"((rest_82)(unsafe-cdr lst_162))" +"((ids_4)(unsafe-car lst_163))" +"((rest_83)(unsafe-cdr lst_163)))" +"(let-values(((fold-var_159)" +"(let-values(((fold-var_160) fold-var_158))" +"(let-values(((fold-var_161)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +"(if rec?_0" +"(reverse$1" +"(let-values(((lst_164)" +"(car" +" clause_1))" +"((lst_165)" +" ids_4))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_164)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_165)))" +"((letrec-values(((for-loop_180)" +"(lambda(fold-var_162" +" lst_166" +" lst_167)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_166)" +"(pair?" +" lst_167)" +" #f)" +"(let-values(((sym_50)" +"(unsafe-car" +" lst_166))" +"((rest_84)" +"(unsafe-cdr" +" lst_166))" +"((id_46)" +"(unsafe-car" +" lst_167))" +"((rest_85)" +"(unsafe-cdr" +" lst_167)))" +"(let-values(((fold-var_163)" +"(let-values(((fold-var_1)" +" fold-var_162))" +"(let-values(((fold-var_2)" +"(let-values()" +"(cons" +"(let-values()" +"(add-undefined-error-name-property" +" sym_50" +" id_46))" +" fold-var_1))))" +"(values" +" fold-var_2)))))" +"(if(not" +" #f)" +"(for-loop_180" +" fold-var_163" +" rest_84" +" rest_85)" +" fold-var_163)))" +" fold-var_162)))))" +" for-loop_180)" +" null" +" lst_164" +" lst_165))))" +"(car clause_1))" +"(compile$2" +"(cadr clause_1)" +" cctx_8" +"(if(= 1(length ids_4))" +"(car ids_4)" +" #f))))" +" fold-var_160))))" +"(values fold-var_161)))))" +"(if(not #f)" +"(for-loop_34 fold-var_159 rest_82 rest_83)" +" fold-var_159)))" +" fold-var_158)))))" +" for-loop_34)" +" null" +" lst_160" +" lst_161))))" +"(compile-sequence body_0 cctx_8 name_45 result-used?_4)))))))))))))" +"(define-values" +"(add-undefined-error-name-property)" +"(lambda(sym_19 orig-id_0)" +"(begin" +"(let-values(((id_47)(correlate~ orig-id_0 sym_19)))" +"(correlated-property" +"(->correlated id_47)" +" 'undefined-error-name" +"(let-values(((or-part_212)(syntax-property$1 orig-id_0 'undefined-error-name)))" +"(if or-part_212 or-part_212(syntax-e$1 orig-id_0))))))))" +"(define-values" +"(compile-identifier24.1)" +"(lambda(set-to19_0 set-to21_0 set-to?18_0 set-to?20_0 p22_0 cctx23_0)" +"(begin" +" 'compile-identifier24" +"(let-values(((p_39) p22_0))" +"(let-values(((cctx_9) cctx23_0))" +"(let-values(((set-to?_0)(if set-to?20_0 set-to?18_0 #f)))" +"(let-values(((rhs_0)(if set-to21_0 set-to19_0 #f)))" +"(let-values()" +"(let-values(((normal-b_0)(parsed-id-binding p_39)))" +"(let-values(((b_71)" +"(let-values(((or-part_213) normal-b_0))" +"(if or-part_213" +" or-part_213" +"(let-values(((temp45_0)(compile-context-self cctx_9))" +"((temp46_0)(compile-context-phase cctx_9))" +"((temp47_0)(syntax-e$1(parsed-s p_39))))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp45_0" +" temp46_0" +" temp47_0))))))" +"(let-values(((sym_51)" +"(if(local-binding? b_71)" +"(let-values()(local-binding-key b_71))" +"(if(module-binding? b_71)" +"(let-values()" +"(let-values(((mpi_40)" +"(if(parsed-top-id? p_39)" +"(compile-context-self cctx_9)" +"(module-binding-module b_71))))" +"(if(parsed-primitive-id? p_39)" +"(let-values()" +"(begin" +"(if(zero?(module-binding-phase b_71))" +"(void)" +"(let-values()" +" (error \"internal error: non-zero phase for a primitive\")))" +"(if set-to?_0" +"(let-values()" +"(error" +" \"internal error: cannot assign to a primitive:\"" +"(module-binding-sym b_71)))" +"(void))" +"(module-binding-sym b_71)))" +"(if(eq? mpi_40(compile-context-module-self cctx_9))" +"(let-values()" +"(let-values(((header_6)(compile-context-header cctx_9)))" +"(hash-ref" +"(header-binding-sym-to-define-sym header_6)" +"(module-binding-sym b_71))))" +"(let-values()" +"(let-values(((temp48_0)(compile-context-header cctx_9))" +"((mpi49_0) mpi_40)" +"((temp50_0)(module-binding-phase b_71))" +"((temp51_0)(module-binding-sym b_71))" +"((temp52_1)" +"(let-values(((or-part_96)" +"(module-binding-extra-inspector b_71)))" +"(if or-part_96" +" or-part_96" +"(let-values(((or-part_214)" +"(parsed-id-inspector p_39)))" +"(if or-part_214" +" or-part_214" +"(if(parsed-s p_39)" +"(syntax-inspector(parsed-s p_39))" +" #f)))))))" +"(register-required-variable-use!19.1" +" #f" +" #f" +" temp48_0" +" mpi49_0" +" temp50_0" +" temp51_0" +" temp52_1)))))))" +"(let-values()" +"(error" +" \"not a reference to a module or local binding:\"" +" b_71" +"(parsed-s p_39)))))))" +"(correlate~(parsed-s p_39)(if set-to?_0(list 'set! sym_51 rhs_0) sym_51)))))))))))))" +"(define-values" +"(compile-quote-syntax)" +"(lambda(q_1 cctx_10)" +"(begin" +"(let-values(((pos_22)(add-syntax-literal!(compile-context-header cctx_10) q_1)))" +"(if(compile-context-lazy-syntax-literals? cctx_10)" +"(let-values()(generate-lazy-syntax-literal-lookup pos_22))" +"(let-values()(generate-eager-syntax-literal-lookup pos_22)))))))" +"(define-values" +"(extra-inspectors-allow?)" +"(lambda(extra-inspectors_2 guard-insp_0)" +"(begin" +"(if(not extra-inspectors_2)" +"(let-values() #f)" +"(if(set? extra-inspectors_2)" +"(let-values()" +"(let-values(((ht_106) extra-inspectors_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_106)))" +"((letrec-values(((for-loop_90)" +"(lambda(result_70 i_135)" +"(begin" +" 'for-loop" +"(if i_135" +"(let-values(((extra-insp_0)(unsafe-immutable-hash-iterate-key ht_106 i_135)))" +"(let-values(((result_71)" +"(let-values()" +"(let-values(((result_72)" +"(let-values()" +"(let-values()" +"(inspector-superior?" +" extra-insp_0" +" guard-insp_0)))))" +"(values result_72)))))" +"(if(if(not((lambda x_54(not result_71)) extra-insp_0))(not #f) #f)" +"(for-loop_90 result_71(unsafe-immutable-hash-iterate-next ht_106 i_135))" +" result_71)))" +" result_70)))))" +" for-loop_90)" +" #t" +"(unsafe-immutable-hash-iterate-first ht_106)))))" +"(if(procedure? extra-inspectors_2)" +"(let-values()(extra-inspectors_2 guard-insp_0))" +"(let-values()" +"(error" +" 'extra-inspectors-allow?" +" \"unknown representation of extra inspectors: ~e\"" +" extra-inspectors_2))))))))" +"(define-values" +"(extra-inspectors-merge)" +"(lambda(extra-inspectors-1_0 extra-inspectors-2_0)" +"(begin" +"(if(let-values(((or-part_215)(not extra-inspectors-1_0)))" +"(if or-part_215 or-part_215(not extra-inspectors-2_0)))" +"(let-values() #f)" +"(if(if(set? extra-inspectors-1_0)(set? extra-inspectors-2_0) #f)" +"(let-values()(set-union extra-inspectors-1_0 extra-inspectors-2_0))" +"(let-values()" +"(lambda(guard-insp_1)" +"(if(extra-inspectors-allow? extra-inspectors-1_0 guard-insp_1)" +"(extra-inspectors-allow? extra-inspectors-2_0 guard-insp_1)" +" #f))))))))" +"(define-values" +"(struct:module-use*" +" module-use*1.1" +" module-use*?" +" module-use*-extra-inspectorss" +" module-use*-self-inspector" +" set-module-use*-extra-inspectorss!" +" set-module-use*-self-inspector!)" +"(let-values(((struct:_64 make-_64 ?_64 -ref_64 -set!_64)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-use*" +" struct:module-use" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'module-use*)))))" +"(values" +" struct:_64" +" make-_64" +" ?_64" +"(make-struct-field-accessor -ref_64 0 'extra-inspectorss)" +"(make-struct-field-accessor -ref_64 1 'self-inspector)" +"(make-struct-field-mutator -set!_64 0 'extra-inspectorss)" +"(make-struct-field-mutator -set!_64 1 'self-inspector))))" +"(define-values" +"(module-uses-add-extra-inspectorsss)" +"(lambda(mus_1 extra-inspectorsss_0)" +"(begin" +"(if extra-inspectorsss_0" +"(let-values()" +"(reverse$1" +"(let-values(((lst_168) mus_1)((lst_75) extra-inspectorsss_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_168)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_75)))" +"((letrec-values(((for-loop_101)" +"(lambda(fold-var_11 lst_85 lst_77)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_85)(pair? lst_77) #f)" +"(let-values(((mu_5)(unsafe-car lst_85))" +"((rest_86)(unsafe-cdr lst_85))" +"((extra-inspectorss_1)(unsafe-car lst_77))" +"((rest_87)(unsafe-cdr lst_77)))" +"(let-values(((fold-var_164)" +"(let-values(((fold-var_165) fold-var_11))" +"(let-values(((fold-var_166)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use*1.1" +"(module-use-module mu_5)" +"(module-use-phase mu_5)" +" extra-inspectorss_1" +" #f))" +" fold-var_165))))" +"(values fold-var_166)))))" +"(if(not #f)(for-loop_101 fold-var_164 rest_86 rest_87) fold-var_164)))" +" fold-var_11)))))" +" for-loop_101)" +" null" +" lst_168" +" lst_75)))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_86) mus_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_86)))" +"((letrec-values(((for-loop_93)" +"(lambda(fold-var_167 lst_169)" +"(begin" +" 'for-loop" +"(if(pair? lst_169)" +"(let-values(((mu_6)(unsafe-car lst_169))((rest_88)(unsafe-cdr lst_169)))" +"(let-values(((fold-var_67)" +"(let-values(((fold-var_168) fold-var_167))" +"(let-values(((fold-var_18)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use*1.1" +"(module-use-module mu_6)" +"(module-use-phase mu_6)" +" #f" +" #f))" +" fold-var_168))))" +"(values fold-var_18)))))" +"(if(not #f)(for-loop_93 fold-var_67 rest_88) fold-var_67)))" +" fold-var_167)))))" +" for-loop_93)" +" null" +" lst_86)))))))))" +"(define-values" +"(module-uses-strip-extra-inspectorsss)" +"(lambda(mu*s_0)" +"(begin" +"(reverse$1" +"(let-values(((lst_170) mu*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_170)))" +"((letrec-values(((for-loop_181)" +"(lambda(fold-var_69 lst_171)" +"(begin" +" 'for-loop" +"(if(pair? lst_171)" +"(let-values(((mu*_0)(unsafe-car lst_171))((rest_89)(unsafe-cdr lst_171)))" +"(let-values(((fold-var_169)" +"(let-values(((fold-var_70) fold-var_69))" +"(let-values(((fold-var_170)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use1.1" +"(module-use-module mu*_0)" +"(module-use-phase mu*_0)))" +" fold-var_70))))" +"(values fold-var_170)))))" +"(if(not #f)(for-loop_181 fold-var_169 rest_89) fold-var_169)))" +" fold-var_69)))))" +" for-loop_181)" +" null" +" lst_170)))))))" +"(define-values" +"(module-uses-extract-extra-inspectorsss)" +"(lambda(mu*s_1 linklet_0 check-inlined-reference?_0 skip-n_0)" +"(begin" +"(if(not check-inlined-reference?_0)" +"(let-values()" +"(reverse$1" +"(let-values(((lst_172) mu*s_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_172)))" +"((letrec-values(((for-loop_182)" +"(lambda(fold-var_73 lst_9)" +"(begin" +" 'for-loop" +"(if(pair? lst_9)" +"(let-values(((mu*_1)(unsafe-car lst_9))((rest_90)(unsafe-cdr lst_9)))" +"(let-values(((fold-var_171)" +"(let-values(((fold-var_4) fold-var_73))" +"(let-values(((fold-var_172)" +"(let-values()" +"(cons" +"(let-values()" +"(module-use*-extra-inspectorss mu*_1))" +" fold-var_4))))" +"(values fold-var_172)))))" +"(if(not #f)(for-loop_182 fold-var_171 rest_90) fold-var_171)))" +" fold-var_73)))))" +" for-loop_182)" +" null" +" lst_172)))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_173) mu*s_1)((lst_174)(list-tail(1/linklet-import-variables linklet_0) skip-n_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_173)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_174)))" +"((letrec-values(((for-loop_30)" +"(lambda(fold-var_6 lst_175 lst_176)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_175)(pair? lst_176) #f)" +"(let-values(((mu*_2)(unsafe-car lst_175))" +"((rest_91)(unsafe-cdr lst_175))" +"((imports_0)(unsafe-car lst_176))" +"((rest_92)(unsafe-cdr lst_176)))" +"(let-values(((fold-var_173)" +"(let-values(((fold-var_174) fold-var_6))" +"(let-values(((fold-var_175)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((extra-inspectorss_2)" +"(module-use*-extra-inspectorss" +" mu*_2)))" +"(let-values(((lst_91) imports_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_91)))" +"((letrec-values(((for-loop_19)" +"(lambda(extra-inspectorss_3" +" lst_177)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_177)" +"(let-values(((import_0)" +"(unsafe-car" +" lst_177))" +"((rest_93)" +"(unsafe-cdr" +" lst_177)))" +"(let-values(((extra-inspectorss_4)" +"(let-values(((extra-inspectorss_5)" +" extra-inspectorss_3))" +"(let-values(((extra-inspectorss_6)" +"(let-values()" +"(if(eq?" +"(hash-ref" +" extra-inspectorss_5" +" import_0" +" '#:not-recorded)" +" '#:not-recorded)" +"(let-values()" +"(hash-set" +" extra-inspectorss_5" +" import_0" +"(set" +"(module-use*-self-inspector" +" mu*_2))))" +"(let-values()" +" extra-inspectorss_5)))))" +"(values" +" extra-inspectorss_6)))))" +"(if(not" +" #f)" +"(for-loop_19" +" extra-inspectorss_4" +" rest_93)" +" extra-inspectorss_4)))" +" extra-inspectorss_3)))))" +" for-loop_19)" +" extra-inspectorss_2" +" lst_91)))))" +" fold-var_174))))" +"(values fold-var_175)))))" +"(if(not #f)(for-loop_30 fold-var_173 rest_91 rest_92) fold-var_173)))" +" fold-var_6)))))" +" for-loop_30)" +" null" +" lst_173" +" lst_174)))))))))" +"(define-values" +"(module-use*-declaration-inspector!)" +"(lambda(mu*_3 insp_9)(begin(set-module-use*-self-inspector! mu*_3 insp_9))))" +"(define-values" +"(module-use+extra-inspectors)" +"(lambda(mpi_41 phase_67 imports_1 inspector_12 extra-inspector_5 extra-inspectorss_7)" +"(begin" +"(let-values(((now-inspector_0)(current-code-inspector)))" +"(let-values(((add-insp?_0)(if inspector_12(inspector-superior? inspector_12 now-inspector_0) #f)))" +"(let-values(((add-extra-insp?_0)" +"(if extra-inspector_5(inspector-superior? extra-inspector_5 now-inspector_0) #f)))" +"(let-values(((new-extra-inspectorss_0)" +"(if(let-values(((or-part_216) add-insp?_0))(if or-part_216 or-part_216 add-extra-insp?_0))" +"(let-values()" +"(let-values(((lst_178) imports_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_178)))" +"((letrec-values(((for-loop_111)" +"(lambda(table_136 lst_179)" +"(begin" +" 'for-loop" +"(if(pair? lst_179)" +"(let-values(((import_1)(unsafe-car lst_179))" +"((rest_94)(unsafe-cdr lst_179)))" +"(let-values(((table_137)" +"(let-values(((table_138) table_136))" +"(let-values(((table_139)" +"(let-values()" +"(let-values(((key_55" +" val_49)" +"(let-values()" +"(values" +" import_1" +"(let-values(((extra-inspectors_3)" +"(if extra-inspectorss_7" +"(hash-ref" +" extra-inspectorss_7" +" import_1" +" #f)" +" #f)))" +"(lambda(guard-insp_2)" +"(let-values(((or-part_217)" +"(if add-insp?_0" +"(inspector-superior?" +" inspector_12" +" guard-insp_2)" +" #f)))" +"(if or-part_217" +" or-part_217" +"(let-values(((or-part_218)" +"(if add-extra-insp?_0" +"(inspector-superior?" +" extra-inspector_5" +" guard-insp_2)" +" #f)))" +"(if or-part_218" +" or-part_218" +"(extra-inspectors-allow?" +" extra-inspectors_3" +" guard-insp_2)))))))))))" +"(hash-set" +" table_138" +" key_55" +" val_49)))))" +"(values table_139)))))" +"(if(not #f)(for-loop_111 table_137 rest_94) table_137)))" +" table_136)))))" +" for-loop_111)" +" '#hash()" +" lst_178))))" +"(let-values()" +"(let-values(((lst_163) imports_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_163)))" +"((letrec-values(((for-loop_183)" +"(lambda(extra-inspectorss_8 lst_180)" +"(begin" +" 'for-loop" +"(if(pair? lst_180)" +"(let-values(((import_2)(unsafe-car lst_180))" +"((rest_95)(unsafe-cdr lst_180)))" +"(let-values(((extra-inspectorss_9)" +"(let-values(((extra-inspectorss_10)" +" extra-inspectorss_8))" +"(let-values(((extra-inspectorss_11)" +"(let-values()" +"(if(hash-ref" +" extra-inspectorss_10" +" import_2" +" #f)" +" extra-inspectorss_10" +"(hash-set" +" extra-inspectorss_10" +" import_2" +" #f)))))" +"(values extra-inspectorss_11)))))" +"(if(not #f)" +"(for-loop_183 extra-inspectorss_9 rest_95)" +" extra-inspectorss_9)))" +" extra-inspectorss_8)))))" +" for-loop_183)" +"(let-values(((or-part_219) extra-inspectorss_7))" +"(if or-part_219 or-part_219(seteq)))" +" lst_163)))))))" +"(module-use*1.1 mpi_41 phase_67 new-extra-inspectorss_0 #f))))))))" +"(define-values" +"(module-use-merge-extra-inspectorss!)" +"(lambda(existing-mu*_0 mu*_4)" +"(begin" +"(let-values(((extra-inspectorss_12)(module-use*-extra-inspectorss mu*_4)))" +"(let-values(((existing-extra-inspectorss_0)(module-use*-extra-inspectorss existing-mu*_0)))" +"(let-values(((new-extra-inspectorss_1)" +"(let-values(((ht_62) extra-inspectorss_12))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_62)))" +"((letrec-values(((for-loop_184)" +"(lambda(new-extra-inspectorss_2 i_136)" +"(begin" +" 'for-loop" +"(if i_136" +"(let-values(((sym_52 extra-inspectors_4)" +"(hash-iterate-key+value ht_62 i_136)))" +"(let-values(((new-extra-inspectorss_3)" +"(let-values(((new-extra-inspectorss_4)" +" new-extra-inspectorss_2))" +"(let-values(((new-extra-inspectorss_5)" +"(let-values()" +"(hash-set" +" new-extra-inspectorss_4" +" sym_52" +"(extra-inspectors-merge" +" extra-inspectors_4" +"(hash-ref" +" new-extra-inspectorss_4" +" sym_52" +"(seteq)))))))" +"(values new-extra-inspectorss_5)))))" +"(if(not #f)" +"(for-loop_184" +" new-extra-inspectorss_3" +"(hash-iterate-next ht_62 i_136))" +" new-extra-inspectorss_3)))" +" new-extra-inspectorss_2)))))" +" for-loop_184)" +" existing-extra-inspectorss_0" +"(hash-iterate-first ht_62))))))" +"(set-module-use*-extra-inspectorss! existing-mu*_0 new-extra-inspectorss_1)))))))" +"(define-values" +"(struct:link-info" +" link-info1.1" +" link-info?" +" link-info-link-module-uses" +" link-info-imports" +" link-info-extra-inspectorsss" +" link-info-def-decls)" +"(let-values(((struct:_39 make-_39 ?_39 -ref_39 -set!_39)" +"(let-values()" +"(let-values()" +"(make-struct-type 'link-info #f 4 0 #f null(current-inspector) #f '(0 1 2 3) #f 'link-info)))))" +"(values" +" struct:_39" +" make-_39" +" ?_39" +"(make-struct-field-accessor -ref_39 0 'link-module-uses)" +"(make-struct-field-accessor -ref_39 1 'imports)" +"(make-struct-field-accessor -ref_39 2 'extra-inspectorsss)" +"(make-struct-field-accessor -ref_39 3 'def-decls))))" +"(define-values" +"(compile-forms31.1)" +"(lambda(body-import-instances3_0" +" body-imports2_0" +" body-suffix-forms4_0" +" body-suffix-forms17_0" +" compiled-expression-callback8_0" +" compiled-expression-callback21_0" +" cross-linklet-inlining?14_0" +" cross-linklet-inlining?27_0" +" definition-callback9_0" +" definition-callback22_0" +" encoded-root-expand-ctx-box6_0" +" encoded-root-expand-ctx-box19_0" +" force-phases5_0" +" force-phases18_0" +" get-module-linklet-info11_0" +" get-module-linklet-info24_0" +" other-form-callback10_0" +" other-form-callback23_0" +" root-ctx-only-if-syntax?7_0" +" root-ctx-only-if-syntax?20_0" +" serializable?13_0" +" serializable?26_0" +" to-source?12_0" +" to-source?25_0" +" bodys28_0" +" cctx29_0" +" mpis30_0)" +"(begin" +" 'compile-forms31" +"(let-values(((bodys_2) bodys28_0))" +"(let-values(((cctx_11) cctx29_0))" +"(let-values(((mpis_14) mpis30_0))" +"(let-values(((body-imports_0) body-imports2_0))" +"(let-values(((body-import-instances_0) body-import-instances3_0))" +"(let-values(((body-suffix-forms_0)(if body-suffix-forms17_0 body-suffix-forms4_0 null)))" +"(let-values(((force-phases_0)(if force-phases18_0 force-phases5_0 null)))" +"(let-values(((encoded-root-expand-ctx-box_0)" +"(if encoded-root-expand-ctx-box19_0 encoded-root-expand-ctx-box6_0 #f)))" +"(let-values(((root-ctx-only-if-syntax?_0)" +"(if root-ctx-only-if-syntax?20_0 root-ctx-only-if-syntax?7_0 #f)))" +"(let-values(((compiled-expression-callback_0)" +"(if compiled-expression-callback21_0 compiled-expression-callback8_0 void)))" +"(let-values(((definition-callback_0)" +"(if definition-callback22_0 definition-callback9_0 void)))" +"(let-values(((other-form-callback_0)" +"(if other-form-callback23_0 other-form-callback10_0 void)))" +"(let-values(((get-module-linklet-info_0)" +"(if get-module-linklet-info24_0" +" get-module-linklet-info11_0" +"(lambda(mod-name_14 p_40)(begin 'get-module-linklet-info #f)))))" +"(let-values(((to-source?_0)(if to-source?25_0 to-source?12_0 #f)))" +"(let-values(((serializable?_0)(if serializable?26_0 serializable?13_0 #t)))" +"(let-values(((cross-linklet-inlining?_1)" +"(if cross-linklet-inlining?27_0 cross-linklet-inlining?14_0 #t)))" +"(let-values()" +"(let-values(((phase_68)(compile-context-phase cctx_11)))" +"(let-values(((self_17)(compile-context-self cctx_11)))" +"(let-values(((syntax-literals_1)(make-syntax-literals)))" +"(let-values(((phase-to-body_0)(make-hasheqv)))" +"(let-values(((add-body!_0)" +"(lambda(phase_67 body_1)" +"(begin" +" 'add-body!" +"(hash-update!" +" phase-to-body_0" +" phase_67" +"(lambda(l_55)(cons body_1 l_55))" +" null)))))" +"(let-values(((phase-to-header_0)(make-hasheqv)))" +"(let-values(((find-or-create-header!_0)" +"(lambda(phase_69)" +"(begin" +" 'find-or-create-header!" +"(let-values(((or-part_135)" +"(hash-ref" +" phase-to-header_0" +" phase_69" +" #f)))" +"(if or-part_135" +" or-part_135" +"(let-values(((header_7)" +"(make-header" +" mpis_14" +" syntax-literals_1)))" +"(begin" +"(hash-set!" +" phase-to-header_0" +" phase_69" +" header_7)" +" header_7))))))))" +"(let-values((()" +"(begin" +"(let-values(((lst_181) force-phases_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_181)))" +"((letrec-values(((for-loop_185)" +"(lambda(lst_182)" +"(begin" +" 'for-loop" +"(if(pair? lst_182)" +"(let-values(((phase_70)" +"(unsafe-car" +" lst_182))" +"((rest_96)" +"(unsafe-cdr" +" lst_182)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(find-or-create-header!_0" +" phase_70)" +"(add-body!_0" +" phase_70" +" '(void))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_185" +" rest_96)" +"(values))))" +"(values))))))" +" for-loop_185)" +" lst_181)))" +"(values))))" +"(let-values()" +"(let-values(((saw-define-syntaxes?_0) #f))" +"(let-values((()" +"(begin" +"(if(compile-context-module-self cctx_11)" +"(let-values()" +"((letrec-values(((loop!_0)" +"(lambda(bodys_3" +" phase_71" +" header_8)" +"(begin" +" 'loop!" +"(begin" +"(let-values(((lst_183)" +" bodys_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_183)))" +"((letrec-values(((for-loop_186)" +"(lambda(lst_184)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_184)" +"(let-values(((body_2)" +"(unsafe-car" +" lst_184))" +"((rest_97)" +"(unsafe-cdr" +" lst_184)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(parsed-define-values?" +" body_2)" +"(let-values()" +"(begin" +"(let-values(((lst_160)" +"(parsed-define-values-syms" +" body_2)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_160)))" +"((letrec-values(((for-loop_11)" +"(lambda(lst_185)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_185)" +"(let-values(((sym_53)" +"(unsafe-car" +" lst_185))" +"((rest_98)" +"(unsafe-cdr" +" lst_185)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((def-sym_1)" +"(select-fresh" +" sym_53" +" header_8)))" +"(begin" +"(hash-set!" +"(header-binding-sym-to-define-sym" +" header_8)" +" sym_53" +" def-sym_1)" +"(set-header-binding-syms-in-order!" +" header_8" +"(cons" +" sym_53" +"(header-binding-syms-in-order" +" header_8)))" +"(register-as-defined!" +" header_8" +" def-sym_1))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_11" +" rest_98)" +"(values))))" +"(values))))))" +" for-loop_11)" +" lst_160)))" +"(void)))" +"(if(parsed-begin-for-syntax?" +" body_2)" +"(let-values()" +"(loop!_0" +"(parsed-begin-for-syntax-body" +" body_2)" +"(add1" +" phase_71)" +"(find-or-create-header!_0" +"(add1" +" phase_71))))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_186" +" rest_97)" +"(values))))" +"(values))))))" +" for-loop_186)" +" lst_183)))" +"(void))))))" +" loop!_0)" +" bodys_2" +" phase_68" +"(find-or-create-header!_0 phase_68)))" +"(void))" +"(values))))" +"(let-values(((as-required?_0)" +"(lambda(header_9)" +"(begin" +" 'as-required?" +"(lambda(sym_54)" +"(registered-as-required?" +" header_9" +" sym_54))))))" +"(let-values(((last-i_0)(sub1(length bodys_2))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop!_1)" +"(lambda(bodys_4" +" phase_72" +" header_10)" +"(begin" +" 'loop!" +"(begin" +"(let-values(((lst_186)" +" bodys_4)" +"((start_34)" +" 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_186)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-naturals" +" start_34)))" +"((letrec-values(((for-loop_187)" +"(lambda(lst_187" +" pos_91)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_187)" +" #t" +" #f)" +"(let-values(((body_3)" +"(unsafe-car" +" lst_187))" +"((rest_99)" +"(unsafe-cdr" +" lst_187))" +"((i_137)" +" pos_91))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(parsed-define-values?" +" body_3)" +"(let-values()" +"(let-values(((ids_5)" +"(parsed-define-values-ids" +" body_3)))" +"(let-values(((binding-syms_0)" +"(parsed-define-values-syms" +" body_3)))" +"(let-values(((def-syms_0)" +"(if(compile-context-module-self" +" cctx_11)" +"(let-values()" +"(reverse$1" +"(let-values(((lst_188)" +" binding-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_188)))" +"((letrec-values(((for-loop_188)" +"(lambda(fold-var_3" +" lst_189)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_189)" +"(let-values(((binding-sym_0)" +"(unsafe-car" +" lst_189))" +"((rest_100)" +"(unsafe-cdr" +" lst_189)))" +"(let-values(((fold-var_176)" +"(let-values(((fold-var_177)" +" fold-var_3))" +"(let-values(((fold-var_178)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +"(header-binding-sym-to-define-sym" +" header_10)" +" binding-sym_0))" +" fold-var_177))))" +"(values" +" fold-var_178)))))" +"(if(not" +" #f)" +"(for-loop_188" +" fold-var_176" +" rest_100)" +" fold-var_176)))" +" fold-var_3)))))" +" for-loop_188)" +" null" +" lst_188)))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_48)" +" binding-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_48)))" +"((letrec-values(((for-loop_71)" +"(lambda(fold-var_35" +" lst_49)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_49)" +"(let-values(((binding-sym_1)" +"(unsafe-car" +" lst_49))" +"((rest_21)" +"(unsafe-cdr" +" lst_49)))" +"(let-values(((fold-var_36)" +"(let-values(((fold-var_37)" +" fold-var_35))" +"(let-values(((fold-var_38)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((temp36_1)" +"(compile-context-self" +" cctx_11))" +"((phase37_1)" +" phase_72)" +"((binding-sym38_0)" +" binding-sym_1)" +"((temp39_0)" +" #f)" +"((temp40_0)" +" #t))" +"(register-required-variable-use!19.1" +" temp40_0" +" #t" +" header_10" +" temp36_1" +" phase37_1" +" binding-sym38_0" +" temp39_0)))" +" fold-var_37))))" +"(values" +" fold-var_38)))))" +"(if(not" +" #f)" +"(for-loop_71" +" fold-var_36" +" rest_21)" +" fold-var_36)))" +" fold-var_35)))))" +" for-loop_71)" +" null" +" lst_48))))))))" +"(let-values(((rhs_1)" +"(compile$2" +"(parsed-define-values-rhs" +" body_3)" +"(let-values(((the-struct_50)" +" cctx_11))" +"(if(compile-context?" +" the-struct_50)" +"(let-values(((phase41_0)" +" phase_72)" +"((header42_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_50)" +" phase41_0" +"(compile-context-self" +" the-struct_50)" +"(compile-context-module-self" +" the-struct_50)" +"(compile-context-full-module-name" +" the-struct_50)" +"(compile-context-lazy-syntax-literals?" +" the-struct_50)" +" header42_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_50)))" +"(if(=" +"(length" +" ids_5)" +" 1)" +"(car" +" ids_5)" +" #f))))" +"(begin" +"(definition-callback_0)" +"(compiled-expression-callback_0" +" rhs_1" +"(length" +" def-syms_0)" +" phase_72" +"(as-required?_0" +" header_10))" +"(add-body!_0" +" phase_72" +"(propagate-inline-property" +"(correlate*" +"(parsed-s" +" body_3)" +"(list" +" 'define-values" +" def-syms_0" +" rhs_1))" +"(parsed-s" +" body_3)))" +"(if(let-values(((or-part_220)" +"(compile-context-module-self" +" cctx_11)))" +"(if or-part_220" +" or-part_220" +"(null?" +" ids_5)))" +"(void)" +"(let-values()" +"(begin" +"(add-body!_0" +" phase_72" +"(list*" +" 'if" +" #f" +"(list*" +" 'begin" +"(reverse$1" +"(let-values(((lst_190)" +" def-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_190)))" +"((letrec-values(((for-loop_189)" +"(lambda(fold-var_179" +" lst_191)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_191)" +"(let-values(((def-sym_2)" +"(unsafe-car" +" lst_191))" +"((rest_101)" +"(unsafe-cdr" +" lst_191)))" +"(let-values(((fold-var_180)" +"(let-values(((fold-var_181)" +" fold-var_179))" +"(let-values(((fold-var_182)" +"(let-values()" +"(cons" +"(let-values()" +"(list*" +" 'set!" +" def-sym_2" +" '(#f)))" +" fold-var_181))))" +"(values" +" fold-var_182)))))" +"(if(not" +" #f)" +"(for-loop_189" +" fold-var_180" +" rest_101)" +" fold-var_180)))" +" fold-var_179)))))" +" for-loop_189)" +" null" +" lst_190)))))" +" '((void))))" +"(add-body!_0" +" phase_72" +"(compile-top-level-bind" +" ids_5" +" binding-syms_0" +"(let-values(((the-struct_51)" +" cctx_11))" +"(if(compile-context?" +" the-struct_51)" +"(let-values(((phase43_0)" +" phase_72)" +"((header44_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_51)" +" phase43_0" +"(compile-context-self" +" the-struct_51)" +"(compile-context-module-self" +" the-struct_51)" +"(compile-context-full-module-name" +" the-struct_51)" +"(compile-context-lazy-syntax-literals?" +" the-struct_51)" +" header44_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_51)))" +" #f)))))))))))" +"(if(parsed-define-syntaxes?" +" body_3)" +"(let-values()" +"(let-values(((ids_6)" +"(parsed-define-syntaxes-ids" +" body_3)))" +"(let-values(((binding-syms_1)" +"(parsed-define-syntaxes-syms" +" body_3)))" +"(let-values(((next-header_0)" +"(find-or-create-header!_0" +"(add1" +" phase_72))))" +"(let-values(((gen-syms_0)" +"(reverse$1" +"(let-values(((lst_192)" +" binding-syms_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_192)))" +"((letrec-values(((for-loop_190)" +"(lambda(fold-var_183" +" lst_193)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_193)" +"(let-values(((binding-sym_2)" +"(unsafe-car" +" lst_193))" +"((rest_102)" +"(unsafe-cdr" +" lst_193)))" +"(let-values(((fold-var_184)" +"(let-values(((fold-var_185)" +" fold-var_183))" +"(let-values(((fold-var_186)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((gen-sym_0)" +"(select-fresh" +" binding-sym_2" +" next-header_0)))" +"(begin" +"(register-as-defined!" +" next-header_0" +" gen-sym_0)" +" gen-sym_0)))" +" fold-var_185))))" +"(values" +" fold-var_186)))))" +"(if(not" +" #f)" +"(for-loop_190" +" fold-var_184" +" rest_102)" +" fold-var_184)))" +" fold-var_183)))))" +" for-loop_190)" +" null" +" lst_192))))))" +"(let-values(((rhs_2)" +"(compile$2" +"(parsed-define-syntaxes-rhs" +" body_3)" +"(let-values(((the-struct_52)" +" cctx_11))" +"(if(compile-context?" +" the-struct_52)" +"(let-values(((phase45_0)" +"(add1" +" phase_72))" +"((header46_0)" +" next-header_0))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_52)" +" phase45_0" +"(compile-context-self" +" the-struct_52)" +"(compile-context-module-self" +" the-struct_52)" +"(compile-context-full-module-name" +" the-struct_52)" +"(compile-context-lazy-syntax-literals?" +" the-struct_52)" +" header46_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_52))))))" +"(let-values((()" +"(begin" +"(definition-callback_0)" +"(values))))" +"(let-values((()" +"(begin" +"(compiled-expression-callback_0" +" rhs_2" +"(length" +" gen-syms_0)" +"(add1" +" phase_72)" +"(as-required?_0" +" header_10))" +"(values))))" +"(let-values(((transformer-set!s_0)" +"(reverse$1" +"(let-values(((lst_194)" +" binding-syms_1)" +"((lst_195)" +" gen-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_194)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_195)))" +"((letrec-values(((for-loop_41)" +"(lambda(fold-var_187" +" lst_196" +" lst_197)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_196)" +"(pair?" +" lst_197)" +" #f)" +"(let-values(((binding-sym_3)" +"(unsafe-car" +" lst_196))" +"((rest_103)" +"(unsafe-cdr" +" lst_196))" +"((gen-sym_1)" +"(unsafe-car" +" lst_197))" +"((rest_104)" +"(unsafe-cdr" +" lst_197)))" +"(let-values(((fold-var_188)" +"(let-values(((fold-var_189)" +" fold-var_187))" +"(let-values(((fold-var_190)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +" set-transformer!-id" +"(list" +" 'quote" +" binding-sym_3)" +" gen-sym_1))" +" fold-var_189))))" +"(values" +" fold-var_190)))))" +"(if(not" +" #f)" +"(for-loop_41" +" fold-var_188" +" rest_103" +" rest_104)" +" fold-var_188)))" +" fold-var_187)))))" +" for-loop_41)" +" null" +" lst_194" +" lst_195))))))" +"(begin" +"(if(compile-context-module-self" +" cctx_11)" +"(let-values()" +"(add-body!_0" +"(add1" +" phase_72)" +"(list" +" 'let-values" +"(list" +"(list" +" gen-syms_0" +" rhs_2))" +"(list*" +" 'begin" +"(qq-append" +" transformer-set!s_0" +" '((void)))))))" +"(let-values()" +"(add-body!_0" +"(add1" +" phase_72)" +"(generate-top-level-define-syntaxes" +" gen-syms_0" +" rhs_2" +" transformer-set!s_0" +"(compile-top-level-bind" +" ids_6" +" binding-syms_1" +"(let-values(((the-struct_53)" +" cctx_11))" +"(if(compile-context?" +" the-struct_53)" +"(let-values(((phase47_0)" +" phase_72)" +"((header48_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_53)" +" phase47_0" +"(compile-context-self" +" the-struct_53)" +"(compile-context-module-self" +" the-struct_53)" +"(compile-context-full-module-name" +" the-struct_53)" +"(compile-context-lazy-syntax-literals?" +" the-struct_53)" +" header48_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_53)))" +" gen-syms_0)))))" +"(set! saw-define-syntaxes?_0" +" #t)))))))))))" +"(if(parsed-begin-for-syntax?" +" body_3)" +"(let-values()" +"(loop!_1" +"(parsed-begin-for-syntax-body" +" body_3)" +"(add1" +" phase_72)" +"(find-or-create-header!_0" +"(add1" +" phase_72))))" +"(if(let-values(((or-part_221)" +"(parsed-#%declare?" +" body_3)))" +"(if or-part_221" +" or-part_221" +"(let-values(((or-part_222)" +"(parsed-module?" +" body_3)))" +"(if or-part_222" +" or-part_222" +"(parsed-require?" +" body_3)))))" +"(let-values()" +"(let-values(((e_34)" +"(other-form-callback_0" +" body_3" +"(let-values(((the-struct_54)" +" cctx_11))" +"(if(compile-context?" +" the-struct_54)" +"(let-values(((phase49_0)" +" phase_72)" +"((header50_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_54)" +" phase49_0" +"(compile-context-self" +" the-struct_54)" +"(compile-context-module-self" +" the-struct_54)" +"(compile-context-full-module-name" +" the-struct_54)" +"(compile-context-lazy-syntax-literals?" +" the-struct_54)" +" header50_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_54))))))" +"(if e_34" +"(let-values()" +"(begin" +"(compiled-expression-callback_0" +" e_34" +" #f" +" phase_72" +"(as-required?_0" +" header_10))" +"(add-body!_0" +" phase_72" +" e_34)))" +"(void))))" +"(let-values()" +"(let-values(((e_19)" +"(compile$2" +" body_3" +"(let-values(((the-struct_55)" +" cctx_11))" +"(if(compile-context?" +" the-struct_55)" +"(let-values(((phase51_0)" +" phase_72)" +"((header52_0)" +" header_10))" +"(compile-context1.1" +"(compile-context-namespace" +" the-struct_55)" +" phase51_0" +"(compile-context-self" +" the-struct_55)" +"(compile-context-module-self" +" the-struct_55)" +"(compile-context-full-module-name" +" the-struct_55)" +"(compile-context-lazy-syntax-literals?" +" the-struct_55)" +" header52_0))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_55)))" +" #f" +"(=" +" i_137" +" last-i_0))))" +"(begin" +"(compiled-expression-callback_0" +" e_19" +" #f" +" phase_72" +"(as-required?_0" +" header_10))" +"(add-body!_0" +" phase_72" +" e_19)))))))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_187" +" rest_99" +"(+" +" pos_91" +" 1))" +"(values))))" +"(values))))))" +" for-loop_187)" +" lst_186" +" start_34)))" +"(void))))))" +" loop!_1)" +" bodys_2" +" phase_68" +"(find-or-create-header!_0 phase_68))" +"(values))))" +"(let-values(((encoded-root-expand-pos_0)" +"(if encoded-root-expand-ctx-box_0" +"(if(unbox" +" encoded-root-expand-ctx-box_0)" +"(if(not" +"(if root-ctx-only-if-syntax?_0" +"(if(not" +" saw-define-syntaxes?_0)" +"(syntax-literals-empty?" +" syntax-literals_1)" +" #f)" +" #f))" +"(add-syntax-literal!" +" syntax-literals_1" +"(unbox" +" encoded-root-expand-ctx-box_0))" +" #f)" +" #f)" +" #f)))" +"(let-values(((phases-in-order_2)" +"(let-values(((temp53_1)" +"(hash-keys" +" phase-to-body_0))" +"((<54_0) <))" +"(sort7.1" +" #f" +" #f" +" #f" +" #f" +" temp53_1" +" <54_0))))" +"(let-values(((min-phase_0)" +"(if(pair? phases-in-order_2)" +"(car phases-in-order_2)" +" phase_68)))" +"(let-values(((max-phase_0)" +"(if(pair? phases-in-order_2)" +"(car" +"(reverse$1" +" phases-in-order_2))" +" phase_68)))" +"(let-values(((phase-to-link-info_0)" +"(let-values(((lst_102)" +" phases-in-order_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_102)))" +"((letrec-values(((for-loop_117)" +"(lambda(table_140" +" lst_149)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_149)" +"(let-values(((phase_49)" +"(unsafe-car" +" lst_149))" +"((rest_75)" +"(unsafe-cdr" +" lst_149)))" +"(let-values(((table_141)" +"(let-values(((table_142)" +" table_140))" +"(let-values(((table_143)" +"(let-values()" +"(let-values(((key_56" +" val_50)" +"(let-values()" +"(let-values(((header_11)" +"(hash-ref" +" phase-to-header_0" +" phase_49" +" #f)))" +"(let-values(((link-module-uses_0" +" imports_2" +" extra-inspectorsss_1" +" def-decls_0)" +"(generate-links+imports" +" header_11" +" phase_49" +" cctx_11" +" cross-linklet-inlining?_1)))" +"(values" +" phase_49" +"(link-info1.1" +" link-module-uses_0" +" imports_2" +" extra-inspectorsss_1" +" def-decls_0)))))))" +"(hash-set" +" table_142" +" key_56" +" val_50)))))" +"(values" +" table_143)))))" +"(if(not" +" #f)" +"(for-loop_117" +" table_141" +" rest_75)" +" table_141)))" +" table_140)))))" +" for-loop_117)" +" '#hash()" +" lst_102)))))" +"(let-values(((body-linklets+module-use*s_0)" +"(let-values(((lst_198)" +" phases-in-order_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_198)))" +"((letrec-values(((for-loop_191)" +"(lambda(table_144" +" lst_199)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_199)" +"(let-values(((phase_73)" +"(unsafe-car" +" lst_199))" +"((rest_105)" +"(unsafe-cdr" +" lst_199)))" +"(let-values(((table_145)" +"(let-values(((table_146)" +" table_144))" +"(let-values(((table_147)" +"(let-values()" +"(let-values(((key_57" +" val_51)" +"(let-values()" +"(let-values(((bodys_5)" +"(hash-ref" +" phase-to-body_0" +" phase_73)))" +"(let-values(((li_0)" +"(hash-ref" +" phase-to-link-info_0" +" phase_73)))" +"(let-values(((binding-sym-to-define-sym_0)" +"(header-binding-sym-to-define-sym" +"(hash-ref" +" phase-to-header_0" +" phase_73))))" +"(let-values(((module-use*s_0)" +"(module-uses-add-extra-inspectorsss" +"(link-info-link-module-uses" +" li_0)" +"(link-info-extra-inspectorsss" +" li_0))))" +"(let-values(((linklet_1" +" new-module-use*s_0)" +"(let-values()" +"((if to-source?_0" +"(lambda(l_56" +" name_46" +" keys_0" +" getter_0)" +"(values" +" l_56" +" keys_0))" +"(lambda(l_57" +" name_47" +" keys_1" +" getter_1)" +"(1/compile-linklet" +" l_57" +" name_47" +" keys_1" +" getter_1" +" serializable?_0)))" +"(list*" +" 'linklet" +"(qq-append" +" body-imports_0" +"(link-info-imports" +" li_0))" +"(qq-append" +"(link-info-def-decls" +" li_0)" +"(reverse$1" +"(let-values(((lst_200)" +"(header-binding-syms-in-order" +"(hash-ref" +" phase-to-header_0" +" phase_73))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_200)))" +"((letrec-values(((for-loop_121)" +"(lambda(fold-var_191" +" lst_107)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_107)" +"(let-values(((binding-sym_4)" +"(unsafe-car" +" lst_107))" +"((rest_106)" +"(unsafe-cdr" +" lst_107)))" +"(let-values(((fold-var_192)" +"(let-values(((fold-var_193)" +" fold-var_191))" +"(let-values(((fold-var_194)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((def-sym_3)" +"(hash-ref" +" binding-sym-to-define-sym_0" +" binding-sym_4)))" +"(if(eq?" +" def-sym_3" +" binding-sym_4)" +" def-sym_3" +"(list" +" def-sym_3" +" binding-sym_4))))" +" fold-var_193))))" +"(values" +" fold-var_194)))))" +"(if(not" +" #f)" +"(for-loop_121" +" fold-var_192" +" rest_106)" +" fold-var_192)))" +" fold-var_191)))))" +" for-loop_121)" +" null" +" lst_200)))))" +"(qq-append" +"(reverse$1" +" bodys_5)" +" body-suffix-forms_0))" +" 'module" +"(list->vector" +"(append" +" body-import-instances_0" +" module-use*s_0))" +"(make-module-use-to-linklet" +" cross-linklet-inlining?_1" +"(compile-context-namespace" +" cctx_11)" +" get-module-linklet-info_0" +" module-use*s_0)))))" +"(values" +" phase_73" +"(cons" +" linklet_1" +"(list-tail" +"(vector->list" +" new-module-use*s_0)" +"(length" +" body-imports_0))))))))))))" +"(hash-set" +" table_146" +" key_57" +" val_51)))))" +"(values" +" table_147)))))" +"(if(not" +" #f)" +"(for-loop_191" +" table_145" +" rest_105)" +" table_145)))" +" table_144)))))" +" for-loop_191)" +" '#hasheq()" +" lst_198)))))" +"(let-values(((body-linklets_0)" +"(let-values(((ht_107)" +" body-linklets+module-use*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_107)))" +"((letrec-values(((for-loop_192)" +"(lambda(table_148" +" i_138)" +"(begin" +" 'for-loop" +"(if i_138" +"(let-values(((phase_74" +" l+mu*s_0)" +"(hash-iterate-key+value" +" ht_107" +" i_138)))" +"(let-values(((table_149)" +"(let-values(((table_150)" +" table_148))" +"(let-values(((table_151)" +"(let-values()" +"(let-values(((key_58" +" val_52)" +"(let-values()" +"(values" +" phase_74" +"(car" +" l+mu*s_0)))))" +"(hash-set" +" table_150" +" key_58" +" val_52)))))" +"(values" +" table_151)))))" +"(if(not" +" #f)" +"(for-loop_192" +" table_149" +"(hash-iterate-next" +" ht_107" +" i_138))" +" table_149)))" +" table_148)))))" +" for-loop_192)" +" '#hasheq()" +"(hash-iterate-first" +" ht_107))))))" +"(let-values(((phase-to-link-module-uses_1)" +"(let-values(((ht_108)" +" body-linklets+module-use*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_108)))" +"((letrec-values(((for-loop_193)" +"(lambda(table_152" +" i_139)" +"(begin" +" 'for-loop" +"(if i_139" +"(let-values(((phase_75" +" l+mu*s_1)" +"(hash-iterate-key+value" +" ht_108" +" i_139)))" +"(let-values(((table_153)" +"(let-values(((table_154)" +" table_152))" +"(let-values(((table_155)" +"(let-values()" +"(let-values(((key_59" +" val_53)" +"(let-values()" +"(values" +" phase_75" +"(module-uses-strip-extra-inspectorsss" +"(cdr" +" l+mu*s_1))))))" +"(hash-set" +" table_154" +" key_59" +" val_53)))))" +"(values" +" table_155)))))" +"(if(not" +" #f)" +"(for-loop_193" +" table_153" +"(hash-iterate-next" +" ht_108" +" i_139))" +" table_153)))" +" table_152)))))" +" for-loop_193)" +" '#hasheq()" +"(hash-iterate-first" +" ht_108))))))" +"(let-values(((phase-to-link-module-uses-expr_0)" +"(serialize-phase-to-link-module-uses" +" phase-to-link-module-uses_1" +" mpis_14)))" +"(let-values(((phase-to-link-extra-inspectorsss_0)" +"(let-values(((ht_109)" +" body-linklets+module-use*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_109)))" +"((letrec-values(((for-loop_194)" +"(lambda(table_156" +" i_140)" +"(begin" +" 'for-loop" +"(if i_140" +"(let-values(((phase_76" +" l+mu*s_2)" +"(hash-iterate-key+value" +" ht_109" +" i_140)))" +"(let-values(((table_157)" +"(let-values(((extra-inspectorsss_2)" +"(module-uses-extract-extra-inspectorsss" +"(cdr" +" l+mu*s_2)" +"(car" +" l+mu*s_2)" +" cross-linklet-inlining?_1" +"(length" +" body-imports_0))))" +"(begin" +" #t" +"((letrec-values(((for-loop_195)" +"(lambda(table_158)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_159)" +"(let-values(((table_160)" +" table_158))" +"(if extra-inspectorsss_2" +"(let-values(((table_161)" +" table_160))" +"(let-values(((table_162)" +"(let-values()" +"(let-values(((key_60" +" val_54)" +"(let-values()" +"(values" +" phase_76" +" extra-inspectorsss_2))))" +"(hash-set" +" table_161" +" key_60" +" val_54)))))" +"(values" +" table_162)))" +" table_160))))" +" table_159))))))" +" for-loop_195)" +" table_156)))))" +"(if(not" +" #f)" +"(for-loop_194" +" table_157" +"(hash-iterate-next" +" ht_109" +" i_140))" +" table_157)))" +" table_156)))))" +" for-loop_194)" +" '#hash()" +"(hash-iterate-first" +" ht_109))))))" +"(values" +" body-linklets_0" +" min-phase_0" +" max-phase_0" +" phase-to-link-module-uses_1" +" phase-to-link-module-uses-expr_0" +" phase-to-link-extra-inspectorsss_0" +" syntax-literals_1" +" encoded-root-expand-pos_0)))))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(compile-top-level-bind)" +"(lambda(ids_7 binding-syms_2 cctx_12 trans-exprs_0)" +"(begin" +"(let-values(((phase_77)(compile-context-phase cctx_12)))" +"(let-values(((self_18)(compile-context-self cctx_12)))" +"(let-values(((header_12)(compile-context-header cctx_12)))" +"(let-values(((mpis_15)(header-module-path-indexes header_12)))" +"(let-values(((top-level-bind-scope_2)" +"(root-expand-context-top-level-bind-scope" +"(namespace-get-root-expand-ctx(compile-context-namespace cctx_12)))))" +"(let-values(((self-expr_0)(add-module-path-index! mpis_15 self_18)))" +"(list*" +" 'begin" +"(reverse$1" +"(let-values(((lst_201) ids_7)" +"((lst_202) binding-syms_2)" +"((lst_203)" +"(let-values(((or-part_14) trans-exprs_0))" +"(if or-part_14" +" or-part_14" +"(reverse$1" +"(let-values(((lst_204) ids_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_204)))" +"((letrec-values(((for-loop_196)" +"(lambda(fold-var_195 lst_205)" +"(begin" +" 'for-loop" +"(if(pair? lst_205)" +"(let-values(((id_48)(unsafe-car lst_205))" +"((rest_107)(unsafe-cdr lst_205)))" +"(let-values(((fold-var_196)" +"(let-values(((fold-var_197)" +" fold-var_195))" +"(let-values(((fold-var_198)" +"(let-values()" +"(cons" +"(let-values()" +" ''#f)" +" fold-var_197))))" +"(values fold-var_198)))))" +"(if(not #f)" +"(for-loop_196 fold-var_196 rest_107)" +" fold-var_196)))" +" fold-var_195)))))" +" for-loop_196)" +" null" +" lst_204))))))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_201)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_202)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_203)))" +"((letrec-values(((for-loop_197)" +"(lambda(fold-var_199 lst_2 lst_206 lst_207)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_2)(if(pair? lst_206)(pair? lst_207) #f) #f)" +"(let-values(((id_49)(unsafe-car lst_2))" +"((rest_108)(unsafe-cdr lst_2))" +"((binding-sym_5)(unsafe-car lst_206))" +"((rest_109)(unsafe-cdr lst_206))" +"((trans-expr_0)(unsafe-car lst_207))" +"((rest_110)(unsafe-cdr lst_207)))" +"(let-values(((fold-var_200)" +"(let-values(((fold-var_201) fold-var_199))" +"(let-values(((fold-var_202)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((id-stx_0)" +"(compile-quote-syntax" +"(remove-scope" +" id_49" +" top-level-bind-scope_2)" +" cctx_12)))" +"(list" +" top-level-bind!-id" +" id-stx_0" +" self-expr_0" +" phase_77" +" phase-shift-id" +" ns-id" +"(list 'quote binding-sym_5)" +"(if trans-exprs_0 #t #f)" +" trans-expr_0)))" +" fold-var_201))))" +"(values fold-var_202)))))" +"(if(not #f)" +"(for-loop_197 fold-var_200 rest_108 rest_109 rest_110)" +" fold-var_200)))" +" fold-var_199)))))" +" for-loop_197)" +" null" +" lst_201" +" lst_202" +" lst_203))))))))))))))" +"(define-values" +"(generate-top-level-define-syntaxes)" +"(lambda(gen-syms_1 rhs_3 transformer-set!s_1 finish_1)" +"(begin" +"(list" +" 'call-with-values" +"(list 'lambda '() rhs_3)" +"(list" +" 'case-lambda" +"(list gen-syms_1(list* 'begin(qq-append transformer-set!s_1(list* finish_1 '((void))))))" +"(list" +" '()" +"(list" +" 'let-values" +"(list" +"(list" +" gen-syms_1" +"(list*" +" 'values" +"(reverse$1" +"(let-values(((lst_208) gen-syms_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_208)))" +"((letrec-values(((for-loop_198)" +"(lambda(fold-var_203 lst_209)" +"(begin" +" 'for-loop" +"(if(pair? lst_209)" +"(let-values(((s_236)(unsafe-car lst_209))((rest_111)(unsafe-cdr lst_209)))" +"(let-values(((fold-var_204)" +"(let-values(((fold-var_205) fold-var_203))" +"(let-values(((fold-var_206)" +"(let-values()" +"(cons(let-values() ''#f) fold-var_205))))" +"(values fold-var_206)))))" +"(if(not #f)(for-loop_198 fold-var_204 rest_111) fold-var_204)))" +" fold-var_203)))))" +" for-loop_198)" +" null" +" lst_208)))))))" +"(list* 'begin finish_1 '((void)))))" +"(list 'args(list* 'let-values(list(list* gen-syms_1 '((apply values args)))) '((void)))))))))" +"(define-values" +"(propagate-inline-property)" +"(lambda(e_35 orig-s_22)" +"(begin" +"(let-values(((v_160)(syntax-property$1 orig-s_22 'compiler-hint:cross-module-inline)))" +"(if v_160(correlated-property e_35 'compiler-hint:cross-module-inline v_160) e_35)))))" +"(define-values" +"(make-module-use-to-linklet)" +"(lambda(cross-linklet-inlining?_2 ns_56 get-module-linklet-info_1 init-mu*s_0)" +"(begin" +"(let-values(((mu*-intern-table_0)(make-hash)))" +"(let-values(((intern-module-use*_0)" +"(lambda(mu*_5)" +"(begin" +" 'intern-module-use*" +"(let-values(((mod-name_15)(1/module-path-index-resolve(module-use-module mu*_5))))" +"(let-values(((existing-mu*_1)" +"(hash-ref mu*-intern-table_0(cons mod-name_15(module-use-phase mu*_5)) #f)))" +"(if existing-mu*_1" +"(let-values()" +"(begin(module-use-merge-extra-inspectorss! existing-mu*_1 mu*_5) existing-mu*_1))" +"(let-values()" +"(begin" +"(hash-set! mu*-intern-table_0(cons mod-name_15(module-use-phase mu*_5)) mu*_5)" +" mu*_5)))))))))" +"(begin" +"(let-values(((lst_210) init-mu*s_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_210)))" +"((letrec-values(((for-loop_199)" +"(lambda(lst_137)" +"(begin" +" 'for-loop" +"(if(pair? lst_137)" +"(let-values(((mu*_6)(unsafe-car lst_137))((rest_112)(unsafe-cdr lst_137)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()(intern-module-use*_0 mu*_6))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_199 rest_112)(values))))" +"(values))))))" +" for-loop_199)" +" lst_210)))" +"(void)" +"(lambda(mu*-or-instance_0)" +"(if(1/instance? mu*-or-instance_0)" +"(let-values()(values mu*-or-instance_0 #f))" +"(if(not cross-linklet-inlining?_2)" +"(let-values()(values #f #f))" +"(if mu*-or-instance_0" +"(let-values()" +"(let-values(((mu*_7) mu*-or-instance_0))" +"(let-values(((mod-name_16)(1/module-path-index-resolve(module-use-module mu*_7))))" +"(let-values(((mli_0)" +"(let-values(((or-part_223)" +"(get-module-linklet-info_1 mod-name_16(module-use-phase mu*_7))))" +"(if or-part_223" +" or-part_223" +"(namespace->module-linklet-info" +" ns_56" +" mod-name_16" +"(module-use-phase mu*_7))))))" +"(begin" +"(if mli_0" +"(let-values()" +"(module-use*-declaration-inspector! mu*_7(module-linklet-info-inspector mli_0)))" +"(void))" +"(if mli_0" +"(values" +"(module-linklet-info-linklet-or-instance mli_0)" +"(if(module-linklet-info-module-uses mli_0)" +"(list->vector" +"(append" +" '(#f #f)" +"(let-values(((mus_2)(module-linklet-info-module-uses mli_0))" +"((extra-inspectorsss_3)" +"(module-linklet-info-extra-inspectorsss mli_0)))" +"(reverse$1" +"(let-values(((lst_211) mus_2)" +"((lst_212)" +"(1/linklet-import-variables" +"(module-linklet-info-linklet-or-instance mli_0)))" +"((lst_213)" +"(let-values(((or-part_224) extra-inspectorsss_3))" +"(if or-part_224 or-part_224 mus_2))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_211)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_212)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_213)))" +"((letrec-values(((for-loop_200)" +"(lambda(fold-var_207 lst_214 lst_215 lst_216)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_214)" +"(if(pair? lst_215)(pair? lst_216) #f)" +" #f)" +"(let-values(((sub-mu_0)(unsafe-car lst_214))" +"((rest_113)(unsafe-cdr lst_214))" +"((imports_3)(unsafe-car lst_215))" +"((rest_114)(unsafe-cdr lst_215))" +"((extra-inspectorss_13)" +"(unsafe-car lst_216))" +"((rest_115)(unsafe-cdr lst_216)))" +"(let-values(((fold-var_208)" +"(let-values(((fold-var_209)" +" fold-var_207))" +"(let-values(((fold-var_210)" +"(let-values()" +"(cons" +"(let-values()" +"(intern-module-use*_0" +"(module-use+extra-inspectors" +"(module-path-index-shift" +"(module-use-module" +" sub-mu_0)" +"(module-linklet-info-self" +" mli_0)" +"(module-use-module" +" mu*_7))" +"(module-use-phase" +" sub-mu_0)" +" imports_3" +"(module-linklet-info-inspector" +" mli_0)" +"(module-linklet-info-extra-inspector" +" mli_0)" +"(if extra-inspectorsss_3" +" extra-inspectorss_13" +" #f))))" +" fold-var_209))))" +"(values fold-var_210)))))" +"(if(not #f)" +"(for-loop_200" +" fold-var_208" +" rest_113" +" rest_114" +" rest_115)" +" fold-var_208)))" +" fold-var_207)))))" +" for-loop_200)" +" null" +" lst_211" +" lst_212" +" lst_213)))))))" +" #f))" +"(values #f #f)))))))" +"(let-values()(values #f #f))))))))))))" +"(define-values" +"(build-shared-data-linklet)" +"(lambda(cims_0 ns_41)" +"(begin" +"(let-values(((mpis_16)(make-module-path-index-table)))" +"(let-values(((mpi-trees_0)" +"(map-cim-tree" +" cims_0" +"(lambda(cim_1)" +"(let-values(((vec_53 i_141)" +"(let-values(((vec_54 len_28)" +"(let-values(((vec_55)(compiled-in-memory-mpis cim_1)))" +"(begin" +"(check-vector vec_55)" +"(values vec_55(unsafe-vector-length vec_55))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_91)" +"(lambda(vec_56 i_142 pos_92)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_92 len_28)" +"(let-values(((mpi_42)" +"(unsafe-vector-ref vec_54 pos_92)))" +"(let-values(((vec_57 i_143)" +"(let-values(((vec_58) vec_56)" +"((i_144) i_142))" +"(let-values(((vec_59 i_145)" +"(let-values()" +"(let-values(((new-vec_3)" +"(if(eq?" +" i_144" +"(unsafe-vector*-length" +" vec_58))" +"(grow-vector" +" vec_58)" +" vec_58)))" +"(begin" +"(unsafe-vector*-set!" +" new-vec_3" +" i_144" +"(let-values()" +"(add-module-path-index!/pos" +" mpis_16" +" mpi_42)))" +"(values" +" new-vec_3" +"(unsafe-fx+" +" i_144" +" 1)))))))" +"(values vec_59 i_145)))))" +"(if(not #f)" +"(for-loop_91" +" vec_57" +" i_143" +"(unsafe-fx+ 1 pos_92))" +"(values vec_57 i_143))))" +"(values vec_56 i_142))))))" +" for-loop_91)" +"(make-vector 16)" +" 0" +" 0)))))" +"(shrink-vector vec_53 i_141))))))" +"(let-values(((syntax-literals_2)(make-syntax-literals)))" +"(let-values(((syntax-literals-trees_0)" +"(map-cim-tree" +" cims_0" +"(lambda(cim_2)" +"(add-syntax-literals! syntax-literals_2(compiled-in-memory-syntax-literals cim_2))))))" +"(let-values(((module-uses-tables_0) null))" +"(let-values(((module-uses-tables-count_0) 0))" +"(let-values(((phase-to-link-module-uses-trees_0)" +"(map-cim-tree" +" cims_0" +"(lambda(cim_3)" +"(let-values(((pos_93) module-uses-tables-count_0))" +"(begin" +"(set! module-uses-tables_0" +"(cons" +"(compiled-in-memory-phase-to-link-module-uses cim_3)" +" module-uses-tables_0))" +"(set! module-uses-tables-count_0(add1 pos_93))" +" pos_93))))))" +"(let-values(((syntax-literals-expr_0)" +"(generate-eager-syntax-literals! syntax-literals_2 mpis_16 0 #f ns_41)))" +"(let-values(((phase-to-link-module-uses-expr_1)" +"(list*" +" 'vector" +"(reverse$1" +"(let-values(((lst_217)(reverse$1 module-uses-tables_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_217)))" +"((letrec-values(((for-loop_100)" +"(lambda(fold-var_64 lst_84)" +"(begin" +" 'for-loop" +"(if(pair? lst_84)" +"(let-values(((phase-to-link-module-uses_2)" +"(unsafe-car lst_84))" +"((rest_116)(unsafe-cdr lst_84)))" +"(let-values(((fold-var_29)" +"(let-values(((fold-var_151)" +" fold-var_64))" +"(let-values(((fold-var_9)" +"(let-values()" +"(cons" +"(let-values()" +"(serialize-phase-to-link-module-uses" +" phase-to-link-module-uses_2" +" mpis_16))" +" fold-var_151))))" +"(values fold-var_9)))))" +"(if(not #f)" +"(for-loop_100 fold-var_29 rest_116)" +" fold-var_29)))" +" fold-var_64)))))" +" for-loop_100)" +" null" +" lst_217)))))))" +"(1/compile-linklet" +"(list" +" 'linklet" +"(list deserialize-imports eager-instance-imports)" +"(list*" +" mpi-vector-id" +" '(mpi-vector-trees" +" phase-to-link-modules-vector" +" phase-to-link-modules-trees" +" syntax-literals" +" syntax-literals-trees))" +"(list 'define-values(list mpi-vector-id)(generate-module-path-index-deserialize mpis_16))" +"(list 'define-values '(mpi-vector-trees)(list 'quote mpi-trees_0))" +"(list 'define-values '(phase-to-link-modules-vector) phase-to-link-module-uses-expr_1)" +"(list" +" 'define-values" +" '(phase-to-link-modules-trees)" +"(list 'quote phase-to-link-module-uses-trees_0))" +"(list 'define-values '(syntax-literals) syntax-literals-expr_0)" +"(list" +" 'define-values" +" '(syntax-literals-trees)" +"(list 'quote syntax-literals-trees_0))))))))))))))))" +"(define-values" +"(map-cim-tree)" +"(lambda(cims_1 proc_7)" +"(begin" +"((letrec-values(((loop_38)" +"(lambda(cims_2)" +"(begin" +" 'loop" +"(reverse$1" +"(let-values(((lst_218) cims_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_218)))" +"((letrec-values(((for-loop_201)" +"(lambda(fold-var_211 lst_78)" +"(begin" +" 'for-loop" +"(if(pair? lst_78)" +"(let-values(((cim_4)(unsafe-car lst_78))" +"((rest_35)(unsafe-cdr lst_78)))" +"(let-values(((fold-var_154)" +"(let-values(((fold-var_164) fold-var_211))" +"(let-values(((fold-var_165)" +"(let-values()" +"(cons" +"(let-values()" +"(vector" +"(proc_7 cim_4)" +"(loop_38" +"(compiled-in-memory-pre-compiled-in-memorys" +" cim_4))" +"(loop_38" +"(compiled-in-memory-post-compiled-in-memorys" +" cim_4))))" +" fold-var_164))))" +"(values fold-var_165)))))" +"(if(not #f)" +"(for-loop_201 fold-var_154 rest_35)" +" fold-var_154)))" +" fold-var_211)))))" +" for-loop_201)" +" null" +" lst_218))))))))" +" loop_38)" +" cims_1))))" +"(define-values" +"(compiled-tops->compiled-top8.1)" +"(lambda(merge-serialization?2_0" +" merge-serialization?5_0" +" namespace3_0" +" namespace6_0" +" to-source?1_0" +" to-source?4_0" +" all-cims7_0)" +"(begin" +" 'compiled-tops->compiled-top8" +"(let-values(((all-cims_0) all-cims7_0))" +"(let-values(((to-source?_1)(if to-source?4_0 to-source?1_0 #f)))" +"(let-values(((merge-serialization?_0)(if merge-serialization?5_0 merge-serialization?2_0 #f)))" +"(let-values(((ns_57)(if namespace6_0 namespace3_0 #f)))" +"(let-values()" +"(let-values(((cims_3)(remove-nontail-purely-functional all-cims_0)))" +"(if(= 1(length cims_3))" +"(let-values()(car cims_3))" +"(let-values()" +"(let-values(((sequence-ht_0)" +"(let-values(((lst_219) cims_3)((start_35) 0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_219)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_35)))" +"((letrec-values(((for-loop_202)" +"(lambda(table_163 lst_94 pos_94)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_94) #t #f)" +"(let-values(((cim_5)(unsafe-car lst_94))" +"((rest_34)(unsafe-cdr lst_94))" +"((i_74) pos_94))" +"(let-values(((table_164)" +"(let-values(((table_165) table_163))" +"(let-values(((table_166)" +"(let-values()" +"(let-values(((key_61" +" val_55)" +"(let-values()" +"(values" +"(string->symbol" +"(number->string" +" i_74))" +"((if to-source?_1" +" values" +" compiled-in-memory-linklet-directory)" +" cim_5)))))" +"(hash-set" +" table_165" +" key_61" +" val_55)))))" +"(values table_166)))))" +"(if(not #f)" +"(for-loop_202 table_164 rest_34(+ pos_94 1))" +" table_164)))" +" table_163)))))" +" for-loop_202)" +" '#hasheq()" +" lst_219" +" start_35)))))" +"(let-values(((ht_110)" +"(if merge-serialization?_0" +"(hash-set" +" sequence-ht_0" +" 'data" +"(1/hash->linklet-directory" +"(hasheq" +" #f" +"(1/hash->linklet-bundle" +"(hasheq 0(build-shared-data-linklet cims_3 ns_57))))))" +" sequence-ht_0)))" +"(if to-source?_1" +"(let-values() ht_110)" +"(let-values()" +"(compiled-in-memory1.1" +"(1/hash->linklet-directory ht_110)" +" #f" +" #f" +" #f" +" '#hasheqv()" +" #f" +" '#hasheqv()" +" '#()" +" '#()" +" cims_3" +" null" +" #f" +" #f))))))))))))))))" +"(define-values" +"(compiled-top->compiled-tops)" +"(lambda(ld_0)" +"(begin" +"(let-values(((ht_73)(1/linklet-directory->hash ld_0)))" +"(reverse$1" +"(let-values(((start_36) 0)((end_25)(hash-count ht_73))((inc_19) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_36 end_25 inc_19)))" +"((letrec-values(((for-loop_27)" +"(lambda(fold-var_17 pos_95)" +"(begin" +" 'for-loop" +"(if(< pos_95 end_25)" +"(let-values(((i_146) pos_95))" +"(let-values(((fold-var_18)" +"(let-values(((top_0)" +"(hash-ref" +" ht_73" +"(string->symbol(number->string i_146))" +" #f)))" +"(begin" +" #t" +"((letrec-values(((for-loop_203)" +"(lambda(fold-var_68)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_69)" +"(let-values(((fold-var_212)" +" fold-var_68))" +"(if top_0" +"(let-values(((fold-var_213)" +" fold-var_212))" +"(let-values(((fold-var_214)" +"(let-values()" +"(cons" +"(let-values()" +" top_0)" +" fold-var_213))))" +"(values" +" fold-var_214)))" +" fold-var_212))))" +" fold-var_69))))))" +" for-loop_203)" +" fold-var_17)))))" +"(if(not #f)(for-loop_27 fold-var_18(+ pos_95 inc_19)) fold-var_18)))" +" fold-var_17)))))" +" for-loop_27)" +" null" +" start_36))))))))" +"(define-values" +"(remove-nontail-purely-functional)" +"(lambda(cims_4)" +"(begin" +"((letrec-values(((loop_87)" +"(lambda(cims_5)" +"(begin" +" 'loop" +"(if(null? cims_5)" +"(let-values() null)" +"(if(null?(cdr cims_5))" +"(let-values() cims_5)" +"(if(if(compiled-in-memory?(car cims_5))" +"(compiled-in-memory-purely-functional?(car cims_5))" +" #f)" +"(let-values()(loop_87(cdr cims_5)))" +"(let-values()(cons(car cims_5)(cdr cims_5))))))))))" +" loop_87)" +" cims_4))))" +"(define-values" +"(struct:known-defined/delay known-defined/delay2.1 known-defined/delay? known-defined/delay-thunk)" +"(let-values(((struct:_64 make-_64 ?_64 -ref_64 -set!_64)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-defined/delay #f 1 0 #f null 'prefab #f '(0) #f 'known-defined/delay)))))" +"(values struct:_64 make-_64 ?_64(make-struct-field-accessor -ref_64 0 'thunk))))" +"(define-values" +"(struct:known-property known-property3.1 known-property?)" +"(let-values(((struct:_33 make-_33 ?_33 -ref_33 -set!_33)" +"(let-values()" +"(let-values()(make-struct-type 'known-property #f 0 0 #f null 'prefab #f '() #f 'known-property)))))" +"(values struct:_33 make-_33 ?_33)))" +"(define-values" +"(struct:known-function known-function4.1 known-function? known-function-arity known-function-pure?)" +"(let-values(((struct:_65 make-_65 ?_65 -ref_65 -set!_65)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-function #f 2 0 #f null 'prefab #f '(0 1) #f 'known-function)))))" +"(values" +" struct:_65" +" make-_65" +" ?_65" +"(make-struct-field-accessor -ref_65 0 'arity)" +"(make-struct-field-accessor -ref_65 1 'pure?))))" +"(define-values" +"(struct:known-function-of-satisfying" +" known-function-of-satisfying5.1" +" known-function-of-satisfying?" +" known-function-of-satisfying-arg-predicate-keys)" +"(let-values(((struct:_40 make-_40 ?_40 -ref_40 -set!_40)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'known-function-of-satisfying" +" #f" +" 1" +" 0" +" #f" +" null" +" 'prefab" +" #f" +" '(0)" +" #f" +" 'known-function-of-satisfying)))))" +"(values struct:_40 make-_40 ?_40(make-struct-field-accessor -ref_40 0 'arg-predicate-keys))))" +"(define-values" +"(struct:known-predicate known-predicate6.1 known-predicate? known-predicate-key)" +"(let-values(((struct:_11 make-_11 ?_11 -ref_11 -set!_11)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-predicate #f 1 0 #f null 'prefab #f '(0) #f 'known-predicate)))))" +"(values struct:_11 make-_11 ?_11(make-struct-field-accessor -ref_11 0 'key))))" +"(define-values" +"(struct:known-satisfies known-satisfies7.1 known-satisfies? known-satisfies-predicate-key)" +"(let-values(((struct:_66 make-_66 ?_66 -ref_66 -set!_66)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-satisfies #f 1 0 #f null 'prefab #f '(0) #f 'known-satisfies)))))" +"(values struct:_66 make-_66 ?_66(make-struct-field-accessor -ref_66 0 'predicate-key))))" +"(define-values" +"(struct:known-struct-op known-struct-op8.1 known-struct-op? known-struct-op-type known-struct-op-field-count)" +"(let-values(((struct:_36 make-_36 ?_36 -ref_36 -set!_36)" +"(let-values()" +"(let-values()" +"(make-struct-type 'known-struct-op #f 2 0 #f null 'prefab #f '(0 1) #f 'known-struct-op)))))" +"(values" +" struct:_36" +" make-_36" +" ?_36" +"(make-struct-field-accessor -ref_36 0 'type)" +"(make-struct-field-accessor -ref_36 1 'field-count))))" +"(define-values" +"(lookup-defn)" +"(lambda(defns_0 sym_55)" +"(begin" +"(let-values(((d_29)(hash-ref defns_0 sym_55 #f)))" +"(if(known-defined/delay? d_29)" +"(let-values()(begin((known-defined/delay-thunk d_29))(lookup-defn defns_0 sym_55)))" +"(let-values() d_29))))))" +"(define-values" +"(any-side-effects?9.1)" +"(lambda(known-defns2_0" +" known-defns5_0" +" known-locals1_0" +" known-locals4_0" +" ready-variable?3_0" +" ready-variable?6_0" +" e7_0" +" expected-results8_0)" +"(begin" +" 'any-side-effects?9" +"(let-values(((e_36) e7_0))" +"(let-values(((expected-results_0) expected-results8_0))" +"(let-values(((locals_0)(if known-locals4_0 known-locals1_0 '#hasheq())))" +"(let-values(((defns_1)(if known-defns5_0 known-defns2_0 '#hasheq())))" +"(let-values(((ready-variable?_0)" +"(if ready-variable?6_0 ready-variable?3_0(lambda(id_2)(begin 'ready-variable? #f)))))" +"(let-values()" +"(let-values(((effects?_0)" +"(lambda(e_37 expected-results_1 locals_1)" +"(begin" +" 'effects?" +"(let-values(((locals14_0) locals_1)" +"((defns15_0) defns_1)" +"((ready-variable?16_0) ready-variable?_0))" +"(any-side-effects?9.1" +" defns15_0" +" #t" +" locals14_0" +" #t" +" ready-variable?16_0" +" #t" +" e_37" +" expected-results_1))))))" +"(let-values(((actual-results_0)" +"((letrec-values(((loop_88)" +"(lambda(e_38 locals_2)" +"(begin" +" 'loop" +"(let-values(((tmp_26)" +"(if(pair?(correlated-e e_38))" +"(correlated-e(car(correlated-e e_38)))" +" #f)))" +"(let-values(((index_1)" +"(if(symbol? tmp_26)" +"(hash-ref" +" '#hasheq((#%variable-reference . 1)" +"(begin . 5)" +"(begin0 . 6)" +"(case-lambda . 1)" +"(if . 11)" +"(lambda . 1)" +"(let-values . 2)" +"(letrec-values . 2)" +"(make-struct-field-accessor . 8)" +"(make-struct-field-mutator . 9)" +"(make-struct-type . 7)" +"(make-struct-type-property . 10)" +"(quote . 1)" +"(values . 3)" +"(void . 4))" +" tmp_26" +"(lambda() 0))" +" 0)))" +"(if(unsafe-fx< index_1 5)" +"(if(unsafe-fx< index_1 2)" +"(if(unsafe-fx< index_1 1)" +"(let-values()" +"(let-values(((v_31)(correlated-e e_38)))" +"(if(let-values(((or-part_164)(string? v_31)))" +"(if or-part_164" +" or-part_164" +"(let-values(((or-part_76)" +"(number? v_31)))" +"(if or-part_76" +" or-part_76" +"(let-values(((or-part_77)" +"(boolean? v_31)))" +"(if or-part_77" +" or-part_77" +"(char? v_31)))))))" +"(let-values() 1)" +"(let-values(((c1_24)" +"(if(pair? v_31)" +"(let-values(((rator_0)" +"(correlated-e" +"(car v_31))))" +"(let-values(((or-part_79)" +"(hash-ref" +" locals_2" +" rator_0" +" #f)))" +"(if or-part_79" +" or-part_79" +"(lookup-defn" +" defns_1" +" rator_0))))" +" #f)))" +"(if c1_24" +"((lambda(d_30)" +"(let-values(((ok?_17 _17_0 e18_0)" +"(let-values(((s_81) e_38))" +"(let-values(((orig-s_23)" +" s_81))" +"(let-values(((_17_1" +" e18_1)" +"(let-values(((s_306)" +"(if(1/syntax?" +" s_81)" +"(syntax-e$2" +" s_81)" +" s_81)))" +"(if(pair?" +" s_306)" +"(let-values(((_19_0)" +"(let-values(((s_307)" +"(car" +" s_306)))" +" s_307))" +"((e20_0)" +"(let-values(((s_35)" +"(cdr" +" s_306)))" +"(let-values(((s_178)" +"(if(1/syntax?" +" s_35)" +"(syntax-e$2" +" s_35)" +" s_35)))" +"(let-values(((flat-s_13)" +"(to-syntax-list.1$1" +" s_178)))" +"(if(not" +" flat-s_13)" +"(let-values()" +"((lambda(false_0" +" str_5" +" e_14)" +"(error" +" str_5))" +" #f" +" \"bad syntax\"" +" orig-s_23))" +"(let-values()" +" flat-s_13)))))))" +"(values" +" _19_0" +" e20_0))" +"((lambda(false_1" +" str_6" +" e_39)" +"(error" +" str_6))" +" #f" +" \"bad syntax\"" +" orig-s_23)))))" +"(values" +" #t" +" _17_1" +" e18_1))))))" +"(let-values(((n-args_0)" +"(length e18_0)))" +"(if(let-values(((or-part_170)" +"(if(let-values(((or-part_100)" +"(if(known-struct-op?" +" d_30)" +"(if(eq?" +" 'constructor" +"(known-struct-op-type" +" d_30))" +"(=" +"(known-struct-op-field-count" +" d_30)" +" n-args_0)" +" #f)" +" #f)))" +"(if or-part_100" +" or-part_100" +"(if(known-function?" +" d_30)" +"(if(known-function-pure?" +" d_30)" +"(arity-includes?" +"(known-function-arity" +" d_30)" +" n-args_0)" +" #f)" +" #f)))" +"(let-values(((lst_7)" +" e18_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_7)))" +"((letrec-values(((for-loop_0)" +"(lambda(result_73" +" lst_8)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_8)" +"(let-values(((e_2)" +"(unsafe-car" +" lst_8))" +"((rest_0)" +"(unsafe-cdr" +" lst_8)))" +"(let-values(((result_74)" +"(let-values()" +"(let-values(((result_75)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_2" +" 1" +" locals_2))))))" +"(values" +" result_75)))))" +"(if(if(not" +"((lambda x_55" +"(not" +" result_74))" +" e_2))" +"(not" +" #f)" +" #f)" +"(for-loop_0" +" result_74" +" rest_0)" +" result_74)))" +" result_73)))))" +" for-loop_0)" +" #t" +" lst_7)))" +" #f)))" +"(if or-part_170" +" or-part_170" +"(if(known-function-of-satisfying?" +" d_30)" +"(if(=" +" n-args_0" +"(length" +"(known-function-of-satisfying-arg-predicate-keys" +" d_30)))" +"(let-values(((lst_9)" +" e18_0)" +"((lst_220)" +"(known-function-of-satisfying-arg-predicate-keys" +" d_30)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_9)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_220)))" +"((letrec-values(((for-loop_204)" +"(lambda(result_76" +" lst_158" +" lst_22)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_158)" +"(pair?" +" lst_22)" +" #f)" +"(let-values(((e_40)" +"(unsafe-car" +" lst_158))" +"((rest_7)" +"(unsafe-cdr" +" lst_158))" +"((key_62)" +"(unsafe-car" +" lst_22))" +"((rest_117)" +"(unsafe-cdr" +" lst_22)))" +"(let-values(((result_39)" +"(let-values()" +"(let-values(((result_77)" +"(let-values()" +"(let-values()" +"(if(not" +"(effects?_0" +" e_40" +" 1" +" locals_2))" +"(satisfies?" +" e_40" +" key_62" +" defns_1" +" locals_2)" +" #f)))))" +"(values" +" result_77)))))" +"(if(if(not" +"((lambda x_56" +"(not" +" result_39))" +" e_40))" +"(if(not" +"((lambda x_57" +"(not" +" result_39))" +" key_62))" +"(not" +" #f)" +" #f)" +" #f)" +"(for-loop_204" +" result_39" +" rest_7" +" rest_117)" +" result_39)))" +" result_76)))))" +" for-loop_204)" +" #t" +" lst_9" +" lst_220)))" +" #f)" +" #f)))" +" 1" +" #f))))" +" c1_24)" +"(let-values()" +"(if(let-values(((or-part_225)" +"(self-quoting-in-linklet?" +" v_31)))" +"(if or-part_225" +" or-part_225" +"(if(symbol? v_31)" +"(let-values(((or-part_226)" +"(hash-ref" +" locals_2" +" v_31" +" #f)))" +"(if or-part_226" +" or-part_226" +"(let-values(((or-part_227)" +"(lookup-defn" +" defns_1" +" v_31)))" +"(if or-part_227" +" or-part_227" +"(let-values(((or-part_228)" +"(built-in-symbol?" +" v_31)))" +"(if or-part_228" +" or-part_228" +"(ready-variable?_0" +" v_31)))))))" +" #f)))" +" 1" +" #f)))))))" +"(let-values() 1))" +"(if(unsafe-fx< index_1 3)" +"(let-values()" +"(let-values(((ok?_18" +" _21_0" +" ids22_0" +" rhs23_0" +" body24_0)" +"(let-values(((s_44) e_38))" +"(let-values(((orig-s_24) s_44))" +"(let-values(((_21_1" +" ids22_1" +" rhs23_1" +" body24_1)" +"(let-values(((s_308)" +"(if(1/syntax?" +" s_44)" +"(syntax-e$2" +" s_44)" +" s_44)))" +"(if(pair? s_308)" +"(let-values(((_25_0)" +"(let-values(((s_309)" +"(car" +" s_308)))" +" s_309))" +"((ids26_0" +" rhs27_0" +" body28_0)" +"(let-values(((s_310)" +"(cdr" +" s_308)))" +"(let-values(((s_27)" +"(if(1/syntax?" +" s_310)" +"(syntax-e$2" +" s_310)" +" s_310)))" +"(if(pair?" +" s_27)" +"(let-values(((ids29_0" +" rhs30_0)" +"(let-values(((s_160)" +"(car" +" s_27)))" +"(let-values(((s_150)" +"(if(1/syntax?" +" s_160)" +"(syntax-e$2" +" s_160)" +" s_160)))" +"(let-values(((flat-s_14)" +"(to-syntax-list.1$1" +" s_150)))" +"(if(not" +" flat-s_14)" +"(let-values()" +"((lambda(false_2" +" str_7" +" e_41)" +"(error" +" str_7))" +" #f" +" \"bad syntax\"" +" orig-s_24))" +"(let-values()" +"(let-values(((ids_8" +" rhs_4)" +"(let-values(((lst_165)" +" flat-s_14))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_165)))" +"((letrec-values(((for-loop_180)" +"(lambda(ids_9" +" rhs_5" +" lst_167)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_167)" +"(let-values(((s_46)" +"(unsafe-car" +" lst_167))" +"((rest_84)" +"(unsafe-cdr" +" lst_167)))" +"(let-values(((ids_10" +" rhs_6)" +"(let-values(((ids_11)" +" ids_9)" +"((rhs_7)" +" rhs_5))" +"(let-values(((ids_12" +" rhs_8)" +"(let-values()" +"(let-values(((ids36_0" +" rhs37_0)" +"(let-values()" +"(let-values(((s_311)" +"(if(1/syntax?" +" s_46)" +"(syntax-e$2" +" s_46)" +" s_46)))" +"(if(pair?" +" s_311)" +"(let-values(((ids32_0)" +"(let-values(((s_312)" +"(car" +" s_311)))" +" s_312))" +"((rhs33_0)" +"(let-values(((s_313)" +"(cdr" +" s_311)))" +"(let-values(((s_314)" +"(if(1/syntax?" +" s_313)" +"(syntax-e$2" +" s_313)" +" s_313)))" +"(if(pair?" +" s_314)" +"(let-values(((rhs34_0)" +"(let-values(((s_315)" +"(car" +" s_314)))" +" s_315))" +"(()" +"(let-values(((s_316)" +"(cdr" +" s_314)))" +"(let-values(((s_52)" +"(if(1/syntax?" +" s_316)" +"(syntax-e$2" +" s_316)" +" s_316)))" +"(if(null?" +" s_52)" +"(values)" +"((lambda(false_3" +" str_8" +" e_42)" +"(error" +" str_8))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" rhs34_0))" +"((lambda(false_4" +" str_9" +" e_9)" +"(error" +" str_9))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" ids32_0" +" rhs33_0))" +"((lambda(false_5" +" str_10" +" e_43)" +"(error" +" str_10))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +"(cons" +" ids36_0" +" ids_11)" +"(cons" +" rhs37_0" +" rhs_7))))))" +"(values" +" ids_12" +" rhs_8)))))" +"(if(not" +" #f)" +"(for-loop_180" +" ids_10" +" rhs_6" +" rest_84)" +"(values" +" ids_10" +" rhs_6))))" +"(values" +" ids_9" +" rhs_5))))))" +" for-loop_180)" +" null" +" null" +" lst_165)))))" +"(values" +"(reverse$1" +" ids_8)" +"(reverse$1" +" rhs_4)))))))))" +"((body31_0)" +"(let-values(((s_317)" +"(cdr" +" s_27)))" +"(let-values(((s_33)" +"(if(1/syntax?" +" s_317)" +"(syntax-e$2" +" s_317)" +" s_317)))" +"(if(pair?" +" s_33)" +"(let-values(((body35_0)" +"(let-values(((s_318)" +"(car" +" s_33)))" +" s_318))" +"(()" +"(let-values(((s_159)" +"(cdr" +" s_33)))" +"(let-values(((s_319)" +"(if(1/syntax?" +" s_159)" +"(syntax-e$2" +" s_159)" +" s_159)))" +"(if(null?" +" s_319)" +"(values)" +"((lambda(false_6" +" str_11" +" e_44)" +"(error" +" str_11))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" body35_0))" +"((lambda(false_7" +" str_12" +" e_45)" +"(error" +" str_12))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" ids29_0" +" rhs30_0" +" body31_0))" +"((lambda(false_8" +" str_13" +" e_46)" +"(error" +" str_13))" +" #f" +" \"bad syntax\"" +" orig-s_24))))))" +"(values" +" _25_0" +" ids26_0" +" rhs27_0" +" body28_0))" +"((lambda(false_9" +" str_14" +" e_47)" +"(error" +" str_14))" +" #f" +" \"bad syntax\"" +" orig-s_24)))))" +"(values" +" #t" +" _21_1" +" ids22_1" +" rhs23_1" +" body24_1))))))" +"(if(not" +"(let-values(((lst_221) ids22_0)" +"((lst_222) rhs23_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_221)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_222)))" +"((letrec-values(((for-loop_205)" +"(lambda(result_78" +" lst_223" +" lst_224)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_223)" +"(pair?" +" lst_224)" +" #f)" +"(let-values(((ids_13)" +"(unsafe-car" +" lst_223))" +"((rest_118)" +"(unsafe-cdr" +" lst_223))" +"((rhs_9)" +"(unsafe-car" +" lst_224))" +"((rest_119)" +"(unsafe-cdr" +" lst_224)))" +"(let-values(((result_79)" +"(let-values()" +"(let-values(((result_80)" +"(let-values()" +"(let-values()" +"(effects?_0" +" rhs_9" +"(correlated-length" +" ids_13)" +" locals_2)))))" +"(values" +" result_80)))))" +"(if(if(not" +"((lambda x_58" +" result_79)" +" ids_13))" +"(if(not" +"((lambda x_59" +" result_79)" +" rhs_9))" +"(not" +" #f)" +" #f)" +" #f)" +"(for-loop_205" +" result_79" +" rest_118" +" rest_119)" +" result_79)))" +" result_78)))))" +" for-loop_205)" +" #f" +" lst_221" +" lst_222))))" +"(loop_88" +" body24_0" +"(add-binding-info locals_2 ids22_0 rhs23_0))" +" #f)))" +"(if(unsafe-fx< index_1 4)" +"(let-values()" +"(let-values(((ok?_19 _38_0 e39_0)" +"(let-values(((s_320) e_38))" +"(let-values(((orig-s_25) s_320))" +"(let-values(((_38_1 e39_1)" +"(let-values(((s_321)" +"(if(1/syntax?" +" s_320)" +"(syntax-e$2" +" s_320)" +" s_320)))" +"(if(pair?" +" s_321)" +"(let-values(((_40_0)" +"(let-values(((s_64)" +"(car" +" s_321)))" +" s_64))" +"((e41_0)" +"(let-values(((s_322)" +"(cdr" +" s_321)))" +"(let-values(((s_38)" +"(if(1/syntax?" +" s_322)" +"(syntax-e$2" +" s_322)" +" s_322)))" +"(let-values(((flat-s_15)" +"(to-syntax-list.1$1" +" s_38)))" +"(if(not" +" flat-s_15)" +"(let-values()" +"((lambda(false_10" +" str_15" +" e_48)" +"(error" +" str_15))" +" #f" +" \"bad syntax\"" +" orig-s_25))" +"(let-values()" +" flat-s_15)))))))" +"(values" +" _40_0" +" e41_0))" +"((lambda(false_11" +" str_16" +" e_49)" +"(error" +" str_16))" +" #f" +" \"bad syntax\"" +" orig-s_25)))))" +"(values #t _38_1 e39_1))))))" +"(if(let-values(((lst_225) e39_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_225)))" +"((letrec-values(((for-loop_206)" +"(lambda(result_81" +" lst_226)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_226)" +"(let-values(((e_50)" +"(unsafe-car" +" lst_226))" +"((rest_120)" +"(unsafe-cdr" +" lst_226)))" +"(let-values(((result_82)" +"(let-values()" +"(let-values(((result_83)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_50" +" 1" +" locals_2))))))" +"(values" +" result_83)))))" +"(if(if(not" +"((lambda x_60" +"(not" +" result_82))" +" e_50))" +"(not" +" #f)" +" #f)" +"(for-loop_206" +" result_82" +" rest_120)" +" result_82)))" +" result_81)))))" +" for-loop_206)" +" #t" +" lst_225)))" +"(length e39_0)" +" #f)))" +"(let-values()" +"(let-values(((ok?_20 _42_0 e43_0)" +"(let-values(((s_39) e_38))" +"(let-values(((orig-s_26) s_39))" +"(let-values(((_42_1 e43_1)" +"(let-values(((s_92)" +"(if(1/syntax?" +" s_39)" +"(syntax-e$2" +" s_39)" +" s_39)))" +"(if(pair? s_92)" +"(let-values(((_44_0)" +"(let-values(((s_323)" +"(car" +" s_92)))" +" s_323))" +"((e45_0)" +"(let-values(((s_94)" +"(cdr" +" s_92)))" +"(let-values(((s_324)" +"(if(1/syntax?" +" s_94)" +"(syntax-e$2" +" s_94)" +" s_94)))" +"(let-values(((flat-s_16)" +"(to-syntax-list.1$1" +" s_324)))" +"(if(not" +" flat-s_16)" +"(let-values()" +"((lambda(false_12" +" str_17" +" e_51)" +"(error" +" str_17))" +" #f" +" \"bad syntax\"" +" orig-s_26))" +"(let-values()" +" flat-s_16)))))))" +"(values" +" _44_0" +" e45_0))" +"((lambda(false_13" +" str_18" +" e_52)" +"(error" +" str_18))" +" #f" +" \"bad syntax\"" +" orig-s_26)))))" +"(values #t _42_1 e43_1))))))" +"(if(let-values(((lst_227) e43_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_227)))" +"((letrec-values(((for-loop_207)" +"(lambda(result_84" +" lst_40)" +"(begin" +" 'for-loop" +"(if(pair? lst_40)" +"(let-values(((e_53)" +"(unsafe-car" +" lst_40))" +"((rest_121)" +"(unsafe-cdr" +" lst_40)))" +"(let-values(((result_85)" +"(let-values()" +"(let-values(((result_86)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_53" +" 1" +" locals_2))))))" +"(values" +" result_86)))))" +"(if(if(not" +"((lambda x_61" +"(not" +" result_85))" +" e_53))" +"(not" +" #f)" +" #f)" +"(for-loop_207" +" result_85" +" rest_121)" +" result_85)))" +" result_84)))))" +" for-loop_207)" +" #t" +" lst_227)))" +" 1" +" #f))))))" +"(if(unsafe-fx< index_1 8)" +"(if(unsafe-fx< index_1 6)" +"(let-values()" +"(let-values(((ok?_21 _46_0 e47_0)" +"(let-values(((s_325) e_38))" +"(let-values(((orig-s_27) s_325))" +"(let-values(((_46_1 e47_1)" +"(let-values(((s_326)" +"(if(1/syntax?" +" s_325)" +"(syntax-e$2" +" s_325)" +" s_325)))" +"(if(pair? s_326)" +"(let-values(((_48_0)" +"(let-values(((s_327)" +"(car" +" s_326)))" +" s_327))" +"((e49_0)" +"(let-values(((s_155)" +"(cdr" +" s_326)))" +"(let-values(((s_156)" +"(if(1/syntax?" +" s_155)" +"(syntax-e$2" +" s_155)" +" s_155)))" +"(let-values(((flat-s_17)" +"(to-syntax-list.1$1" +" s_156)))" +"(if(not" +" flat-s_17)" +"(let-values()" +"((lambda(false_14" +" str_19" +" e_54)" +"(error" +" str_19))" +" #f" +" \"bad syntax\"" +" orig-s_27))" +"(let-values()" +" flat-s_17)))))))" +"(values" +" _48_0" +" e49_0))" +"((lambda(false_15" +" str_20" +" e_55)" +"(error" +" str_20))" +" #f" +" \"bad syntax\"" +" orig-s_27)))))" +"(values #t _46_1 e47_1))))))" +"((letrec-values(((bloop_0)" +"(lambda(es_1)" +"(begin" +" 'bloop" +"(if(null? es_1)" +"(let-values() #f)" +"(if(null?(cdr es_1))" +"(let-values()" +"(loop_88" +"(car es_1)" +" locals_2))" +"(let-values()" +"(if(not" +"(effects?_0" +"(car es_1)" +" #f" +" locals_2))" +"(bloop_0(cdr es_1))" +" #f))))))))" +" bloop_0)" +" e47_0)))" +"(if(unsafe-fx< index_1 7)" +"(let-values()" +"(let-values(((ok?_22 _50_0 e051_0 e52_0)" +"(let-values(((s_115) e_38))" +"(let-values(((orig-s_28) s_115))" +"(let-values(((_50_1" +" e051_1" +" e52_1)" +"(let-values(((s_328)" +"(if(1/syntax?" +" s_115)" +"(syntax-e$2" +" s_115)" +" s_115)))" +"(if(pair?" +" s_328)" +"(let-values(((_53_0)" +"(let-values(((s_117)" +"(car" +" s_328)))" +" s_117))" +"((e054_0" +" e55_0)" +"(let-values(((s_329)" +"(cdr" +" s_328)))" +"(let-values(((s_330)" +"(if(1/syntax?" +" s_329)" +"(syntax-e$2" +" s_329)" +" s_329)))" +"(if(pair?" +" s_330)" +"(let-values(((e056_0)" +"(let-values(((s_220)" +"(car" +" s_330)))" +" s_220))" +"((e57_0)" +"(let-values(((s_331)" +"(cdr" +" s_330)))" +"(let-values(((s_118)" +"(if(1/syntax?" +" s_331)" +"(syntax-e$2" +" s_331)" +" s_331)))" +"(let-values(((flat-s_18)" +"(to-syntax-list.1$1" +" s_118)))" +"(if(not" +" flat-s_18)" +"(let-values()" +"((lambda(false_16" +" str_21" +" e_56)" +"(error" +" str_21))" +" #f" +" \"bad syntax\"" +" orig-s_28))" +"(let-values()" +" flat-s_18)))))))" +"(values" +" e056_0" +" e57_0))" +"((lambda(false_17" +" str_22" +" e_57)" +"(error" +" str_22))" +" #f" +" \"bad syntax\"" +" orig-s_28))))))" +"(values" +" _53_0" +" e054_0" +" e55_0))" +"((lambda(false_18" +" str_23" +" e_58)" +"(error" +" str_23))" +" #f" +" \"bad syntax\"" +" orig-s_28)))))" +"(values" +" #t" +" _50_1" +" e051_1" +" e52_1))))))" +"(if(let-values(((lst_228) e52_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_228)))" +"((letrec-values(((for-loop_208)" +"(lambda(result_87" +" lst_229)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_229)" +"(let-values(((e_59)" +"(unsafe-car" +" lst_229))" +"((rest_122)" +"(unsafe-cdr" +" lst_229)))" +"(let-values(((result_88)" +"(let-values()" +"(let-values(((result_89)" +"(let-values()" +"(let-values()" +"(not" +"(effects?_0" +" e_59" +" #f" +" locals_2))))))" +"(values" +" result_89)))))" +"(if(if(not" +"((lambda x_62" +"(not" +" result_88))" +" e_59))" +"(not" +" #f)" +" #f)" +"(for-loop_208" +" result_88" +" rest_122)" +" result_88)))" +" result_87)))))" +" for-loop_208)" +" #t" +" lst_228)))" +"(loop_88 e051_0 locals_2)" +" #f)))" +"(let-values()" +"(if(ok-make-struct-type?" +" e_38" +" ready-variable?_0" +" defns_1)" +" 5" +" #f))))" +"(if(unsafe-fx< index_1 9)" +"(let-values()" +"(if(ok-make-struct-field-accessor/mutator?" +" e_38" +" locals_2" +" 'general-accessor" +" defns_1)" +" 1" +" #f))" +"(if(unsafe-fx< index_1 10)" +"(let-values()" +"(if(ok-make-struct-field-accessor/mutator?" +" e_38" +" locals_2" +" 'general-mutator" +" defns_1)" +" 1" +" #f))" +"(if(unsafe-fx< index_1 11)" +"(let-values()" +"(if(ok-make-struct-type-property? e_38 defns_1)" +" 3" +" #f))" +"(let-values()" +"(let-values(((ok?_23" +" _58_0" +" id:rator59_0" +" id:arg60_0" +" thn61_0" +" els62_0)" +"(let-values(((s_332) e_38))" +"(if(let-values(((s_333)" +"(if(1/syntax?" +" s_332)" +"(syntax-e$2" +" s_332)" +" s_332)))" +"(if(pair? s_333)" +"(if(let-values(((s_230)" +"(car" +" s_333)))" +" #t)" +"(let-values(((s_334)" +"(cdr" +" s_333)))" +"(let-values(((s_231)" +"(if(1/syntax?" +" s_334)" +"(syntax-e$2" +" s_334)" +" s_334)))" +"(if(pair? s_231)" +"(if(let-values(((s_232)" +"(car" +" s_231)))" +"(let-values(((s_335)" +"(if(1/syntax?" +" s_232)" +"(syntax-e$2" +" s_232)" +" s_232)))" +"(if(pair?" +" s_335)" +"(if(let-values(((s_233)" +"(car" +" s_335)))" +"(let-values(((or-part_229)" +"(if(1/syntax?" +" s_233)" +"(symbol?" +"(syntax-e$2" +" s_233))" +" #f)))" +"(if or-part_229" +" or-part_229" +"(symbol?" +" s_233))))" +"(let-values(((s_235)" +"(cdr" +" s_335)))" +"(let-values(((s_336)" +"(if(1/syntax?" +" s_235)" +"(syntax-e$2" +" s_235)" +" s_235)))" +"(if(pair?" +" s_336)" +"(if(let-values(((s_337)" +"(car" +" s_336)))" +"(let-values(((or-part_230)" +"(if(1/syntax?" +" s_337)" +"(symbol?" +"(syntax-e$2" +" s_337))" +" #f)))" +"(if or-part_230" +" or-part_230" +"(symbol?" +" s_337))))" +"(let-values(((s_338)" +"(cdr" +" s_336)))" +"(let-values(((s_339)" +"(if(1/syntax?" +" s_338)" +"(syntax-e$2" +" s_338)" +" s_338)))" +"(null?" +" s_339)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +"(let-values(((s_340)" +"(cdr" +" s_231)))" +"(let-values(((s_341)" +"(if(1/syntax?" +" s_340)" +"(syntax-e$2" +" s_340)" +" s_340)))" +"(if(pair?" +" s_341)" +"(if(let-values(((s_342)" +"(car" +" s_341)))" +" #t)" +"(let-values(((s_343)" +"(cdr" +" s_341)))" +"(let-values(((s_344)" +"(if(1/syntax?" +" s_343)" +"(syntax-e$2" +" s_343)" +" s_343)))" +"(if(pair?" +" s_344)" +"(if(let-values(((s_345)" +"(car" +" s_344)))" +" #t)" +"(let-values(((s_346)" +"(cdr" +" s_344)))" +"(let-values(((s_347)" +"(if(1/syntax?" +" s_346)" +"(syntax-e$2" +" s_346)" +" s_346)))" +"(null?" +" s_347)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((_58_1" +" id:rator59_1" +" id:arg60_1" +" thn61_1" +" els62_1)" +"(let-values(((s_348)" +"(if(1/syntax?" +" s_332)" +"(syntax-e$2" +" s_332)" +" s_332)))" +"(let-values(((_63_0)" +"(let-values(((s_349)" +"(car" +" s_348)))" +" s_349))" +"((id:rator64_0" +" id:arg65_0" +" thn66_0" +" els67_0)" +"(let-values(((s_238)" +"(cdr" +" s_348)))" +"(let-values(((s_239)" +"(if(1/syntax?" +" s_238)" +"(syntax-e$2" +" s_238)" +" s_238)))" +"(let-values(((id:rator68_0" +" id:arg69_0)" +"(let-values(((s_242)" +"(car" +" s_239)))" +"(let-values(((s_243)" +"(if(1/syntax?" +" s_242)" +"(syntax-e$2" +" s_242)" +" s_242)))" +"(let-values(((id:rator72_0)" +"(let-values(((s_350)" +"(car" +" s_243)))" +" s_350))" +"((id:arg73_0)" +"(let-values(((s_351)" +"(cdr" +" s_243)))" +"(let-values(((s_352)" +"(if(1/syntax?" +" s_351)" +"(syntax-e$2" +" s_351)" +" s_351)))" +"(let-values(((id:arg74_0)" +"(let-values(((s_244)" +"(car" +" s_352)))" +" s_244))" +"(()" +"(let-values(((s_353)" +"(cdr" +" s_352)))" +"(let-values(((s_354)" +"(if(1/syntax?" +" s_353)" +"(syntax-e$2" +" s_353)" +" s_353)))" +"(values)))))" +"(values" +" id:arg74_0))))))" +"(values" +" id:rator72_0" +" id:arg73_0)))))" +"((thn70_0" +" els71_0)" +"(let-values(((s_355)" +"(cdr" +" s_239)))" +"(let-values(((s_356)" +"(if(1/syntax?" +" s_355)" +"(syntax-e$2" +" s_355)" +" s_355)))" +"(let-values(((thn75_0)" +"(let-values(((s_357)" +"(car" +" s_356)))" +" s_357))" +"((els76_0)" +"(let-values(((s_358)" +"(cdr" +" s_356)))" +"(let-values(((s_359)" +"(if(1/syntax?" +" s_358)" +"(syntax-e$2" +" s_358)" +" s_358)))" +"(let-values(((els77_0)" +"(let-values(((s_360)" +"(car" +" s_359)))" +" s_360))" +"(()" +"(let-values(((s_361)" +"(cdr" +" s_359)))" +"(let-values(((s_362)" +"(if(1/syntax?" +" s_361)" +"(syntax-e$2" +" s_361)" +" s_361)))" +"(values)))))" +"(values" +" els77_0))))))" +"(values" +" thn75_0" +" els76_0))))))" +"(values" +" id:rator68_0" +" id:arg69_0" +" thn70_0" +" els71_0))))))" +"(values" +" _63_0" +" id:rator64_0" +" id:arg65_0" +" thn66_0" +" els67_0)))))" +"(values" +" #t" +" _58_1" +" id:rator59_1" +" id:arg60_1" +" thn61_1" +" els62_1)))" +"(values #f #f #f #f #f #f)))))" +"(if ok?_23" +"(let-values()" +"(let-values(((c2_2)" +"(let-values(((or-part_231)" +"(hash-ref" +" locals_2" +" id:rator59_0" +" #f)))" +"(if or-part_231" +" or-part_231" +"(lookup-defn" +" defns_1" +" id:rator59_0)))))" +"(if c2_2" +"((lambda(d_31)" +"(if(known-predicate? d_31)" +"(if(not" +"(effects?_0" +" thn61_0" +" expected-results_0" +"(hash-set" +" locals_2" +" id:arg60_0" +"(known-satisfies7.1" +"(known-predicate-key" +" d_31)))))" +"(loop_88 els62_0 locals_2)" +" #f)" +" #f))" +" c2_2)" +"(let-values() #f))))" +"(let-values()" +"(let-values(((ok?_24" +" _78_0" +" tst79_0" +" thn80_0" +" els81_0)" +"(let-values(((s_363) e_38))" +"(if(let-values(((s_364)" +"(if(1/syntax?" +" s_363)" +"(syntax-e$2" +" s_363)" +" s_363)))" +"(if(pair? s_364)" +"(if(let-values(((s_365)" +"(car" +" s_364)))" +" #t)" +"(let-values(((s_366)" +"(cdr" +" s_364)))" +"(let-values(((s_367)" +"(if(1/syntax?" +" s_366)" +"(syntax-e$2" +" s_366)" +" s_366)))" +"(if(pair?" +" s_367)" +"(if(let-values(((s_256)" +"(car" +" s_367)))" +" #t)" +"(let-values(((s_368)" +"(cdr" +" s_367)))" +"(let-values(((s_369)" +"(if(1/syntax?" +" s_368)" +"(syntax-e$2" +" s_368)" +" s_368)))" +"(if(pair?" +" s_369)" +"(if(let-values(((s_370)" +"(car" +" s_369)))" +" #t)" +"(let-values(((s_371)" +"(cdr" +" s_369)))" +"(let-values(((s_372)" +"(if(1/syntax?" +" s_371)" +"(syntax-e$2" +" s_371)" +" s_371)))" +"(if(pair?" +" s_372)" +"(if(let-values(((s_373)" +"(car" +" s_372)))" +" #t)" +"(let-values(((s_374)" +"(cdr" +" s_372)))" +"(let-values(((s_375)" +"(if(1/syntax?" +" s_374)" +"(syntax-e$2" +" s_374)" +" s_374)))" +"(null?" +" s_375)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((_78_1" +" tst79_1" +" thn80_1" +" els81_1)" +"(let-values(((s_376)" +"(if(1/syntax?" +" s_363)" +"(syntax-e$2" +" s_363)" +" s_363)))" +"(let-values(((_82_0)" +"(let-values(((s_377)" +"(car" +" s_376)))" +" s_377))" +"((tst83_0" +" thn84_0" +" els85_0)" +"(let-values(((s_378)" +"(cdr" +" s_376)))" +"(let-values(((s_379)" +"(if(1/syntax?" +" s_378)" +"(syntax-e$2" +" s_378)" +" s_378)))" +"(let-values(((tst86_0)" +"(let-values(((s_380)" +"(car" +" s_379)))" +" s_380))" +"((thn87_0" +" els88_0)" +"(let-values(((s_381)" +"(cdr" +" s_379)))" +"(let-values(((s_257)" +"(if(1/syntax?" +" s_381)" +"(syntax-e$2" +" s_381)" +" s_381)))" +"(let-values(((thn89_0)" +"(let-values(((s_382)" +"(car" +" s_257)))" +" s_382))" +"((els90_0)" +"(let-values(((s_383)" +"(cdr" +" s_257)))" +"(let-values(((s_384)" +"(if(1/syntax?" +" s_383)" +"(syntax-e$2" +" s_383)" +" s_383)))" +"(let-values(((els91_0)" +"(let-values(((s_385)" +"(car" +" s_384)))" +" s_385))" +"(()" +"(let-values(((s_386)" +"(cdr" +" s_384)))" +"(let-values(((s_387)" +"(if(1/syntax?" +" s_386)" +"(syntax-e$2" +" s_386)" +" s_386)))" +"(values)))))" +"(values" +" els91_0))))))" +"(values" +" thn89_0" +" els90_0))))))" +"(values" +" tst86_0" +" thn87_0" +" els88_0))))))" +"(values" +" _82_0" +" tst83_0" +" thn84_0" +" els85_0)))))" +"(values" +" #t" +" _78_1" +" tst79_1" +" thn80_1" +" els81_1)))" +"(values" +" #f" +" #f" +" #f" +" #f" +" #f)))))" +"(if ok?_24" +"(if(not" +"(effects?_0 tst79_0 1 locals_2))" +"(if(not" +"(effects?_0" +" thn80_0" +" expected-results_0" +" locals_2))" +"(loop_88 els81_0 locals_2)" +" #f)" +" #f)" +" #f)))))))))))))))))" +" loop_88)" +" e_36" +" locals_0)))" +"(not" +"(if actual-results_0" +"(let-values(((or-part_232)(not expected-results_0)))" +"(if or-part_232 or-part_232(= actual-results_0 expected-results_0)))" +" #f)))))))))))))" +"(define-values" +"(satisfies?)" +"(lambda(e_60 key_63 defns_2 locals_3)" +"(begin" +"(let-values(((d_32)" +"(let-values(((or-part_233)(hash-ref locals_3 e_60 #f)))" +"(if or-part_233 or-part_233(lookup-defn defns_2 e_60)))))" +"(if d_32(if(known-satisfies? d_32)(eq? key_63(known-satisfies-predicate-key d_32)) #f) #f)))))" +"(define-values" +"(add-binding-info)" +"(lambda(locals_4 idss_0 rhss_0)" +"(begin" +"(let-values(((lst_230) idss_0)((lst_231) rhss_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_230)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_231)))" +"((letrec-values(((for-loop_209)" +"(lambda(locals_5 lst_232 lst_233)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_232)(pair? lst_233) #f)" +"(let-values(((ids_14)(unsafe-car lst_232))" +"((rest_123)(unsafe-cdr lst_232))" +"((rhs_10)(unsafe-car lst_233))" +"((rest_124)(unsafe-cdr lst_233)))" +"(let-values(((locals_6)" +"(let-values(((locals_7) locals_5))" +"(let-values(((locals_8)" +"(let-values()" +"((letrec-values(((loop_89)" +"(lambda(rhs_11)" +"(begin" +" 'loop" +"(let-values(((tmp_27)" +"(if(pair?" +"(correlated-e" +" rhs_11))" +"(correlated-e" +"(car" +"(correlated-e" +" rhs_11)))" +" #f)))" +"(if(equal?" +" tmp_27" +" 'make-struct-type)" +"(let-values()" +"(let-values(((field-count_0)" +"(extract-struct-field-count-lower-bound" +" rhs_11)))" +"(let-values(((lst_234)" +"(correlated->list" +" ids_14))" +"((lst_235)" +" '(struct-type" +" constructor" +" predicate" +" general-accessor" +" general-mutator)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_234)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_235)))" +"((letrec-values(((for-loop_210)" +"(lambda(locals_9" +" lst_236" +" lst_237)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_236)" +"(pair?" +" lst_237)" +" #f)" +"(let-values(((id_50)" +"(unsafe-car" +" lst_236))" +"((rest_125)" +"(unsafe-cdr" +" lst_236))" +"((type_0)" +"(unsafe-car" +" lst_237))" +"((rest_126)" +"(unsafe-cdr" +" lst_237)))" +"(let-values(((locals_10)" +"(let-values(((locals_11)" +" locals_9))" +"(let-values(((locals_12)" +"(let-values()" +"(hash-set" +" locals_11" +"(correlated-e" +" id_50)" +"(known-struct-op8.1" +" type_0" +" field-count_0)))))" +"(values" +" locals_12)))))" +"(if(not" +" #f)" +"(for-loop_210" +" locals_10" +" rest_125" +" rest_126)" +" locals_10)))" +" locals_9)))))" +" for-loop_210)" +" locals_7" +" lst_234" +" lst_235)))))" +"(if(equal?" +" tmp_27" +" 'let-values)" +"(let-values()" +"(if(null?" +"(correlated-e" +"(correlated-cadr" +" rhs_11)))" +"(loop_89" +"(caddr" +"(correlated->list" +" rhs_11)))" +"(loop_89 #f)))" +"(let-values()" +"(let-values(((lst_238)" +"(correlated->list" +" ids_14)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_238)))" +"((letrec-values(((for-loop_211)" +"(lambda(locals_13" +" lst_239)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_239)" +"(let-values(((id_51)" +"(unsafe-car" +" lst_239))" +"((rest_127)" +"(unsafe-cdr" +" lst_239)))" +"(let-values(((locals_14)" +"(let-values(((locals_15)" +" locals_13))" +"(let-values(((locals_16)" +"(let-values()" +"(hash-set" +" locals_15" +"(correlated-e" +" id_51)" +" #t))))" +"(values" +" locals_16)))))" +"(if(not" +" #f)" +"(for-loop_211" +" locals_14" +" rest_127)" +" locals_14)))" +" locals_13)))))" +" for-loop_211)" +" locals_7" +" lst_238)))))))))))" +" loop_89)" +" rhs_10))))" +"(values locals_8)))))" +"(if(not #f)(for-loop_209 locals_6 rest_123 rest_124) locals_6)))" +" locals_5)))))" +" for-loop_209)" +" locals_4" +" lst_230" +" lst_231))))))" +"(define-values" +"(ok-make-struct-type-property?)" +"(lambda(e_61 defns_3)" +"(begin" +"(let-values(((l_58)(correlated->list e_61)))" +"(if(<= 2(length l_58) 5)" +"(let-values(((lst_240)(cdr l_58))" +"((lst_241)" +"(list" +"(lambda(v_161)(quoted? symbol? v_161))" +"(lambda(v_162)(is-lambda? v_162 2 defns_3))" +"(lambda(v_163)(ok-make-struct-type-property-super? v_163 defns_3))" +"(lambda(v_164)" +"(let-values(((temp93_1) 1)((defns94_0) defns_3))" +"(any-side-effects?9.1 defns94_0 #t #f #f #f #f v_164 temp93_1))))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_240)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_241)))" +"((letrec-values(((for-loop_138)" +"(lambda(result_90 lst_242 lst_243)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_242)(pair? lst_243) #f)" +"(let-values(((arg_0)(unsafe-car lst_242))" +"((rest_128)(unsafe-cdr lst_242))" +"((pred_1)(unsafe-car lst_243))" +"((rest_129)(unsafe-cdr lst_243)))" +"(let-values(((result_91)" +"(let-values()" +"(let-values(((result_92)" +"(let-values()(let-values()(pred_1 arg_0)))))" +"(values result_92)))))" +"(if(if(not((lambda x_63(not result_91)) arg_0))" +"(if(not((lambda x_64(not result_91)) pred_1))(not #f) #f)" +" #f)" +"(for-loop_138 result_91 rest_128 rest_129)" +" result_91)))" +" result_90)))))" +" for-loop_138)" +" #t" +" lst_240" +" lst_241)))" +" #f)))))" +"(define-values" +"(ok-make-struct-type-property-super?)" +"(lambda(v_152 defns_4)" +"(begin" +"(let-values(((or-part_234)(quoted? null? v_152)))" +"(if or-part_234" +" or-part_234" +"(let-values(((or-part_19)(eq? 'null(correlated-e v_152))))" +"(if or-part_19" +" or-part_19" +"(if(pair?(correlated-e v_152))" +"(if(eq?(correlated-e(car(correlated-e v_152))) 'list)" +"(if(let-values(((lst_244)(cdr(correlated->list v_152))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_244)))" +"((letrec-values(((for-loop_212)" +"(lambda(result_93 lst_245)" +"(begin" +" 'for-loop" +"(if(pair? lst_245)" +"(let-values(((prop+val_0)(unsafe-car lst_245))" +"((rest_130)(unsafe-cdr lst_245)))" +"(let-values(((result_94)" +"(let-values()" +"(let-values(((result_95)" +"(let-values()" +"(let-values()" +"(if(=" +"(correlated-length" +" prop+val_0)" +" 3)" +"(let-values(((prop+val_1)" +"(correlated->list" +" prop+val_0)))" +"(if(eq?" +" 'cons" +"(correlated-e" +"(car prop+val_1)))" +"(if(let-values(((or-part_235)" +"(memq" +"(correlated-e" +"(list-ref" +" prop+val_1" +" 1))" +" '(prop:procedure" +" prop:equal+hash" +" prop:custom-write))))" +"(if or-part_235" +" or-part_235" +"(known-property?" +"(lookup-defn" +" defns_4" +"(correlated-e" +"(list-ref" +" prop+val_1" +" 1))))))" +"(not" +"(let-values(((temp95_0)" +"(list-ref" +" prop+val_1" +" 2))" +"((temp96_1)" +" 1)" +"((defns97_0)" +" defns_4))" +"(any-side-effects?9.1" +" defns97_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp95_0" +" temp96_1)))" +" #f)" +" #f))" +" #f)))))" +"(values result_95)))))" +"(if(if(not((lambda x_65(not result_94)) prop+val_0))" +"(not #f)" +" #f)" +"(for-loop_212 result_94 rest_130)" +" result_94)))" +" result_93)))))" +" for-loop_212)" +" #t" +" lst_244)))" +"(=" +"(sub1(correlated-length v_152))" +"(set-count" +"(let-values(((lst_246)(cdr(correlated->list v_152))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_246)))" +"((letrec-values(((for-loop_64)" +"(lambda(table_167 lst_247)" +"(begin" +" 'for-loop" +"(if(pair? lst_247)" +"(let-values(((prop+val_2)(unsafe-car lst_247))" +"((rest_131)(unsafe-cdr lst_247)))" +"(let-values(((table_168)" +"(let-values(((table_169) table_167))" +"(let-values(((table_170)" +"(let-values()" +"(let-values(((key_64 val_56)" +"(let-values()" +"(values" +"(let-values()" +"(correlated-e" +"(list-ref" +"(correlated->list" +" prop+val_2)" +" 1)))" +" #t))))" +"(hash-set" +" table_169" +" key_64" +" val_56)))))" +"(values table_170)))))" +"(if(not #f)(for-loop_64 table_168 rest_131) table_168)))" +" table_167)))))" +" for-loop_64)" +" '#hash()" +" lst_246)))))" +" #f)" +" #f)" +" #f))))))))" +"(define-values" +"(ok-make-struct-type?)" +"(lambda(e_62 ready-variable?_1 defns_5)" +"(begin" +"(let-values(((l_59)(correlated->list e_62)))" +"(let-values(((init-field-count-expr_0)(if(>(length l_59) 3)(list-ref l_59 3) #f)))" +"(let-values(((auto-field-count-expr_0)(if(>(length l_59) 4)(list-ref l_59 4) #f)))" +"(let-values(((num-fields_0)" +"(maybe+" +"(field-count-expr-to-field-count init-field-count-expr_0)" +"(field-count-expr-to-field-count auto-field-count-expr_0))))" +"(let-values(((immutables-expr_0)" +"(let-values(((or-part_236)(if(>(length l_59) 9)(list-ref l_59 9) #f)))" +"(if or-part_236 or-part_236 'null))))" +"(let-values(((super-expr_0)(if(>(length l_59) 2)(list-ref l_59 2) #f)))" +"(if(>=(length l_59) 5)" +"(if(<=(length l_59) 12)" +"(let-values(((lst_248)(cdr l_59))" +"((lst_249)" +"(list" +"(lambda(v_153)(quoted? symbol? v_153))" +"(lambda(v_165)(super-ok? v_165 defns_5))" +"(lambda(v_166)(field-count-expr-to-field-count v_166))" +"(lambda(v_167)(field-count-expr-to-field-count v_167))" +"(lambda(v_168)" +"(not" +"(let-values(((temp99_0) 1)" +"((ready-variable?100_0) ready-variable?_1)" +"((defns101_0) defns_5))" +"(any-side-effects?9.1" +" defns101_0" +" #t" +" #f" +" #f" +" ready-variable?100_0" +" #t" +" v_168" +" temp99_0))))" +"(lambda(v_169)" +"(known-good-struct-properties? v_169 immutables-expr_0 super-expr_0 defns_5))" +"(lambda(v_170)(inspector-or-false? v_170))" +"(lambda(v_171)(procedure-spec? v_171 num-fields_0))" +"(lambda(v_172)(immutables-ok? v_172 init-field-count-expr_0)))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_248)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_249)))" +"((letrec-values(((for-loop_213)" +"(lambda(result_96 lst_129 lst_250)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_129)(pair? lst_250) #f)" +"(let-values(((arg_1)(unsafe-car lst_129))" +"((rest_132)(unsafe-cdr lst_129))" +"((pred_2)(unsafe-car lst_250))" +"((rest_64)(unsafe-cdr lst_250)))" +"(let-values(((result_97)" +"(let-values()" +"(let-values(((result_98)" +"(let-values()" +"(let-values()(pred_2 arg_1)))))" +"(values result_98)))))" +"(if(if(not((lambda x_66(not result_97)) arg_1))" +"(if(not((lambda x_67(not result_97)) pred_2))" +"(not #f)" +" #f)" +" #f)" +"(for-loop_213 result_97 rest_132 rest_64)" +" result_97)))" +" result_96)))))" +" for-loop_213)" +" #t" +" lst_248" +" lst_249)))" +" #f)" +" #f))))))))))" +"(define-values" +"(super-ok?)" +"(lambda(e_63 defns_6)" +"(begin" +"(let-values(((or-part_237)(quoted? false? e_63)))" +"(if or-part_237" +" or-part_237" +"(let-values(((o_0)(lookup-defn defns_6(correlated-e e_63))))" +"(if o_0(if(known-struct-op? o_0)(eq? 'struct-type(known-struct-op-type o_0)) #f) #f)))))))" +"(define-values" +"(extract-struct-field-count-lower-bound)" +"(lambda(e_64)" +"(begin" +"(let-values(((l_60)(correlated->list e_64)))" +"(+(field-count-expr-to-field-count(list-ref l_60 3))(field-count-expr-to-field-count(list-ref l_60 4)))))))" +"(define-values" +"(quoted?)" +"(lambda(val?_0 v_173)" +"(begin" +"(let-values(((or-part_238)" +"(if(pair?(correlated-e v_173))" +"(if(eq?(correlated-e(car(correlated-e v_173))) 'quote)" +"(val?_0(correlated-e(correlated-cadr v_173)))" +" #f)" +" #f)))" +"(if or-part_238 or-part_238(val?_0(correlated-e v_173)))))))" +"(define-values" +"(quoted-value)" +"(lambda(v_174)" +"(begin(if(pair?(correlated-e v_174))(correlated-e(correlated-cadr v_174))(correlated-e v_174)))))" +"(define-values(false?)(lambda(v_175)(begin(eq?(correlated-e v_175) #f))))" +"(define-values" +"(field-count-expr-to-field-count)" +"(lambda(v_176)(begin(if(quoted? exact-nonnegative-integer? v_176)(quoted-value v_176) #f))))" +"(define-values" +"(inspector-or-false?)" +"(lambda(v_177)" +"(begin" +"(let-values(((or-part_239)(quoted? false? v_177)))" +"(if or-part_239" +" or-part_239" +"(let-values(((or-part_240)(if(quoted? symbol? v_177)(eq? 'prefab(quoted-value v_177)) #f)))" +"(if or-part_240" +" or-part_240" +"(if(= 1(correlated-length v_177))" +"(eq? 'current-inspector(correlated-e(car(correlated-e v_177))))" +" #f))))))))" +"(define-values" +"(known-good-struct-properties?)" +"(lambda(v_178 immutables-expr_1 super-expr_1 defns_7)" +"(begin" +"(let-values(((or-part_241)(quoted? null? v_178)))" +"(if or-part_241" +" or-part_241" +"(let-values(((or-part_242)(eq? 'null(correlated-e v_178))))" +"(if or-part_242" +" or-part_242" +"(if(pair?(correlated-e v_178))" +"(if(eq?(correlated-e(car(correlated-e v_178))) 'list)" +"(if(let-values(((lst_251)(cdr(correlated->list v_178))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_251)))" +"((letrec-values(((for-loop_214)" +"(lambda(result_99 lst_252)" +"(begin" +" 'for-loop" +"(if(pair? lst_252)" +"(let-values(((prop+val_3)(unsafe-car lst_252))" +"((rest_133)(unsafe-cdr lst_252)))" +"(let-values(((result_100)" +"(let-values()" +"(let-values(((result_101)" +"(let-values()" +"(let-values()" +"(if(=" +"(correlated-length" +" prop+val_3)" +" 3)" +"(let-values(((prop+val_4)" +"(correlated->list" +" prop+val_3)))" +"(if(eq?" +" 'cons" +"(correlated-e" +"(car prop+val_4)))" +"(known-good-struct-property+value?" +"(list-ref prop+val_4 1)" +"(list-ref prop+val_4 2)" +" immutables-expr_1" +" super-expr_1" +" defns_7)" +" #f))" +" #f)))))" +"(values result_101)))))" +"(if(if(not((lambda x_68(not result_100)) prop+val_3))" +"(not #f)" +" #f)" +"(for-loop_214 result_100 rest_133)" +" result_100)))" +" result_99)))))" +" for-loop_214)" +" #t" +" lst_251)))" +"(=" +"(sub1(correlated-length v_178))" +"(set-count" +"(let-values(((lst_253)(cdr(correlated->list v_178))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_253)))" +"((letrec-values(((for-loop_215)" +"(lambda(table_171 lst_254)" +"(begin" +" 'for-loop" +"(if(pair? lst_254)" +"(let-values(((prop+val_5)(unsafe-car lst_254))" +"((rest_134)(unsafe-cdr lst_254)))" +"(let-values(((table_172)" +"(let-values(((table_173) table_171))" +"(let-values(((table_174)" +"(let-values()" +"(let-values(((key_65 val_57)" +"(let-values()" +"(values" +"(let-values()" +"(correlated-e" +"(list-ref" +"(correlated->list" +" prop+val_5)" +" 1)))" +" #t))))" +"(hash-set" +" table_173" +" key_65" +" val_57)))))" +"(values table_174)))))" +"(if(not #f)(for-loop_215 table_172 rest_134) table_172)))" +" table_171)))))" +" for-loop_215)" +" '#hash()" +" lst_253)))))" +" #f)" +" #f)" +" #f))))))))" +"(define-values" +"(known-good-struct-property+value?)" +"(lambda(prop-expr_0 val-expr_0 immutables-expr_2 super-expr_2 defns_8)" +"(begin" +"(let-values(((prop-name_0)(correlated-e prop-expr_0)))" +"(let-values(((tmp_28) prop-name_0))" +"(if(equal? tmp_28 'prop:evt)" +"(let-values()" +"(let-values(((or-part_243)(is-lambda? val-expr_0 1 defns_8)))" +"(if or-part_243 or-part_243(immutable-field? val-expr_0 immutables-expr_2))))" +"(if(equal? tmp_28 'prop:procedure)" +"(let-values()" +"(let-values(((or-part_244)(is-lambda? val-expr_0 1 defns_8)))" +"(if or-part_244 or-part_244(immutable-field? val-expr_0 immutables-expr_2))))" +"(if(equal? tmp_28 'prop:custom-write)" +"(let-values()(is-lambda? val-expr_0 3 defns_8))" +"(if(equal? tmp_28 'prop:equal+hash)" +"(let-values()" +"(let-values(((l_61)(correlated->list val-expr_0)))" +"(if(eq? 'list(car l_61))" +"(if(is-lambda?(list-ref l_61 1) 3 defns_8)" +"(if(is-lambda?(list-ref l_61 2) 2 defns_8)(is-lambda?(list-ref l_61 3) 2 defns_8) #f)" +" #f)" +" #f)))" +"(if(if(equal? tmp_28 'prop:method-arity-error) #t(equal? tmp_28 'prop:incomplete-arity))" +"(let-values()" +"(not" +"(let-values(((temp103_0) 1)((defns104_0) defns_8))" +"(any-side-effects?9.1 defns104_0 #t #f #f #f #f val-expr_0 temp103_0))))" +"(if(equal? tmp_28 'prop:impersonator-of)" +"(let-values()(is-lambda? val-expr_0 1 defns_8))" +"(if(equal? tmp_28 'prop:arity-string)" +"(let-values()(is-lambda? val-expr_0 1 defns_8))" +"(if(equal? tmp_28 'prop:checked-procedure)" +"(let-values()(if(quoted? false? super-expr_2)(immutable-field? 1 immutables-expr_2) #f))" +"(let-values()" +"(let-values(((o_1)(lookup-defn defns_8 prop-name_0)))" +"(if o_1" +"(if(known-property? o_1)" +"(not" +"(let-values(((temp106_0) 1)((defns107_0) defns_8))" +"(any-side-effects?9.1 defns107_0 #t #f #f #f #f val-expr_0 temp106_0)))" +" #f)" +" #f))))))))))))))))" +"(define-values" +"(is-lambda?)" +"(lambda(expr_9 arity_0 defns_9)" +"(begin" +"(let-values(((lookup_0)(lookup-defn defns_9 expr_9)))" +"(let-values(((or-part_245)" +"(if lookup_0" +"(if(known-function? lookup_0)" +"(let-values(((or-part_198)(not arity_0)))" +"(if or-part_198 or-part_198(arity-includes?(known-function-arity lookup_0) arity_0)))" +" #f)" +" #f)))" +"(if or-part_245" +" or-part_245" +"(let-values(((or-part_246)" +"(if(pair?(correlated-e expr_9))" +"(if(eq? 'case-lambda(car(correlated-e expr_9)))(not arity_0) #f)" +" #f)))" +"(if or-part_246" +" or-part_246" +"(if(pair?(correlated-e expr_9))" +"(if(eq? 'lambda(car(correlated-e expr_9)))" +"(let-values(((or-part_199)(not arity_0)))" +"(if or-part_199" +" or-part_199" +"((letrec-values(((loop_90)" +"(lambda(args_4 arity_1)" +"(begin" +" 'loop" +"(if(correlated? args_4)" +"(let-values()(loop_90(correlated-e args_4) arity_1))" +"(if(null? args_4)" +"(let-values()(zero? arity_1))" +"(if(pair? args_4)" +"(let-values()(loop_90(cdr args_4)(sub1 arity_1)))" +"(let-values()(not(negative? arity_1))))))))))" +" loop_90)" +"(cadr(correlated->list expr_9))" +" arity_0)))" +" #f)" +" #f)))))))))" +"(define-values" +"(arity-includes?)" +"(lambda(a_40 n_25)" +"(begin" +"(let-values(((or-part_247)(equal? a_40 n_25)))" +"(if or-part_247" +" or-part_247" +"(if(list? a_40)" +"(let-values(((lst_255) a_40))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_255)))" +"((letrec-values(((for-loop_216)" +"(lambda(result_102 lst_256)" +"(begin" +" 'for-loop" +"(if(pair? lst_256)" +"(let-values(((a_41)(unsafe-car lst_256))((rest_135)(unsafe-cdr lst_256)))" +"(let-values(((result_103)" +"(let-values()" +"(let-values(((result_104)" +"(let-values()" +"(let-values()(equal? a_41 n_25)))))" +"(values result_104)))))" +"(if(if(not((lambda x_69 result_103) a_41))(not #f) #f)" +"(for-loop_216 result_103 rest_135)" +" result_103)))" +" result_102)))))" +" for-loop_216)" +" #f" +" lst_255)))" +" #f))))))" +"(define-values" +"(immutable-field?)" +"(lambda(val-expr_1 immutables-expr_3)" +"(begin" +"(if(quoted? exact-nonnegative-integer? val-expr_1)" +"(memv(quoted-value val-expr_1)(immutables-expr-to-immutables immutables-expr_3 null))" +" #f))))" +"(define-values" +"(immutables-expr-to-immutables)" +"(lambda(e_65 fail-v_0)" +"(begin" +"(let-values(((tmp_29)(if(pair?(correlated-e e_65))(correlated-e(car(correlated-e e_65))) #f)))" +"(if(equal? tmp_29 'quote)" +"(let-values()" +"(let-values(((v_179)(correlated-cadr e_65)))" +"(let-values(((or-part_248)" +"(if(correlated-length v_179)" +"(let-values(((l_62)(map2 correlated-e(correlated->list v_179))))" +"(if(andmap2 exact-nonnegative-integer? l_62)" +"(if(=(length l_62)(set-count(list->set l_62))) l_62 #f)" +" #f))" +" #f)))" +"(if or-part_248 or-part_248 fail-v_0))))" +"(let-values() fail-v_0))))))" +"(define-values" +"(procedure-spec?)" +"(lambda(e_66 field-count_1)" +"(begin" +"(let-values(((or-part_249)(quoted? false? e_66)))" +"(if or-part_249" +" or-part_249" +"(let-values(((or-part_250)" +"(if(quoted? exact-nonnegative-integer? e_66)" +"(if field-count_1(<(quoted-value e_66) field-count_1) #f)" +" #f)))" +"(if or-part_250 or-part_250(is-lambda? e_66 #f '#hasheq()))))))))" +"(define-values" +"(immutables-ok?)" +"(lambda(e_67 init-field-count-expr_1)" +"(begin" +"(let-values(((l_63)(immutables-expr-to-immutables e_67 #f)))" +"(let-values(((c_24)(field-count-expr-to-field-count init-field-count-expr_1)))" +"(if l_63" +"(let-values(((lst_257) l_63))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_257)))" +"((letrec-values(((for-loop_217)" +"(lambda(result_105 lst_258)" +"(begin" +" 'for-loop" +"(if(pair? lst_258)" +"(let-values(((n_26)(unsafe-car lst_258))((rest_136)(unsafe-cdr lst_258)))" +"(let-values(((result_106)" +"(let-values()" +"(let-values(((result_107)" +"(let-values()(let-values()(< n_26 c_24)))))" +"(values result_107)))))" +"(if(if(not((lambda x_70(not result_106)) n_26))(not #f) #f)" +"(for-loop_217 result_106 rest_136)" +" result_106)))" +" result_105)))))" +" for-loop_217)" +" #t" +" lst_257)))" +" #f))))))" +"(define-values" +"(ok-make-struct-field-accessor/mutator?)" +"(lambda(e_68 locals_17 type_1 defns_10)" +"(begin" +"(let-values(((l_64)(correlated->list e_68)))" +"(let-values(((a_42)" +"(if(let-values(((or-part_251)(=(length l_64) 3)))" +"(if or-part_251 or-part_251(=(length l_64) 4)))" +"(let-values(((or-part_252)(hash-ref locals_17(correlated-e(list-ref l_64 1)) #f)))" +"(if or-part_252 or-part_252(lookup-defn defns_10(correlated-e(list-ref l_64 1)))))" +" #f)))" +"(if(known-struct-op? a_42)" +"(if(eq?(known-struct-op-type a_42) type_1)" +"(if(<(field-count-expr-to-field-count(list-ref l_64 2))(known-struct-op-field-count a_42))" +"(let-values(((or-part_253)(=(length l_64) 3)))" +"(if or-part_253 or-part_253(quoted? symbol?(list-ref l_64 3))))" +" #f)" +" #f)" +" #f))))))" +"(define-values(maybe+)(lambda(x_71 y_10)(begin(if x_71(if y_10(+ x_71 y_10) #f) #f))))" +"(define-values" +"(compile-single)" +"(lambda(p_41 cctx_13)" +"(begin(let-values(((temp14_4) #f)((temp15_4) #t))(compile-top9.1 temp14_4 #t temp15_4 #t #f #f p_41 cctx_13)))))" +"(define-values" +"(compile-top9.1)" +"(lambda(serializable?1_0" +" serializable?4_0" +" single-expression?2_0" +" single-expression?5_0" +" to-source?3_0" +" to-source?6_0" +" p7_0" +" cctx8_0)" +"(begin" +" 'compile-top9" +"(let-values(((p_34) p7_0))" +"(let-values(((cctx_1) cctx8_0))" +"(let-values(((serializable?_1)(if serializable?4_0 serializable?1_0 #t)))" +"(let-values(((single-expression?_0)(if single-expression?5_0 single-expression?2_0 #f)))" +"(let-values(((to-source?_2)(if to-source?6_0 to-source?3_0 #f)))" +"(let-values()" +"(let-values()" +"(let-values(((phase_78)(compile-context-phase cctx_1)))" +"(let-values(((mpis_17)(make-module-path-index-table)))" +"(let-values(((purely-functional?_0) #t))" +"(let-values(((body-linklets_1" +" min-phase_1" +" max-phase_1" +" phase-to-link-module-uses_3" +" phase-to-link-module-uses-expr_2" +" phase-to-link-extra-inspectorss_0" +" syntax-literals_3" +" no-root-context-pos_0)" +"(let-values(((temp16_5)(list p_34))" +"((cctx17_0) cctx_1)" +"((mpis18_0) mpis_17)" +"((temp19_0)" +"(if single-expression?_0" +"(list* '()(list syntax-literals-id) '(()))" +"(list" +"(list top-level-bind!-id top-level-require!-id)" +"(list mpi-vector-id syntax-literals-id)" +" instance-imports)))" +"((temp20_0)" +"(list" +" top-level-instance" +" empty-top-syntax-literal-instance" +" empty-instance-instance))" +"((to-source?21_0) to-source?_2)" +"((serializable?22_0) serializable?_1)" +"((temp23_3)(lambda()(set! purely-functional?_0 #f)))" +"((temp24_4)" +"(lambda(e_69 expected-results_2 phase_79 required-reference?_0)" +"(if(if purely-functional?_0" +"(let-values(((required-reference?29_0)" +" required-reference?_0))" +"(any-side-effects?9.1" +" #f" +" #f" +" #f" +" #f" +" required-reference?29_0" +" #t" +" e_69" +" expected-results_2))" +" #f)" +"(let-values()(set! purely-functional?_0 #f))" +"(void))))" +"((temp25_3)" +"(lambda(s_176 cctx_14)" +"(begin" +"(set! purely-functional?_0 #f)" +"(compile-top-level-require s_176 cctx_14))))" +"((temp26_1)(not single-expression?_0)))" +"(compile-forms31.1" +" temp20_0" +" temp19_0" +" #f" +" #f" +" temp24_4" +" #t" +" temp26_1" +" #t" +" temp23_3" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp25_3" +" #t" +" #f" +" #f" +" serializable?22_0" +" #t" +" to-source?21_0" +" #t" +" temp16_5" +" cctx17_0" +" mpis18_0))))" +"(let-values(((add-metadata_0)" +"(lambda(ht_111)" +"(begin" +" 'add-metadata" +"(let-values(((ht_112)(hash-set ht_111 'original-phase phase_78)))" +"(let-values(((ht_113)(hash-set ht_112 'max-phase max-phase_1)))" +" ht_113))))))" +"(let-values(((bundle_0)" +"((if to-source?_2 values 1/hash->linklet-bundle)" +"(add-metadata_0" +"(if serializable?_1" +"(let-values()" +"(let-values(((syntax-literals-expr_1)" +"(let-values()" +"(generate-eager-syntax-literals!" +" syntax-literals_3" +" mpis_17" +" phase_78" +"(compile-context-self cctx_1)" +"(compile-context-namespace cctx_1)))))" +"(let-values(((link-linklet_0)" +"((if to-source?_2" +" values" +"(lambda(s_306)" +"(let-values()" +"(let-values(((linklet_2 new-keys_0)" +"(1/compile-linklet" +" s_306" +" #f" +"(vector" +" deserialize-instance" +" empty-eager-instance-instance)" +"(lambda(inst_0)" +"(values inst_0 #f)))))" +" linklet_2))))" +"(list" +" 'linklet" +"(list deserialize-imports eager-instance-imports)" +"(list" +" mpi-vector-id" +" deserialized-syntax-vector-id" +" 'phase-to-link-modules" +" syntax-literals-id)" +"(list" +" 'define-values" +"(list mpi-vector-id)" +"(generate-module-path-index-deserialize mpis_17))" +"(list" +" 'define-values" +"(list deserialized-syntax-vector-id)" +"(list* 'make-vector(add1 phase_78) '(#f)))" +"(list" +" 'define-values" +" '(phase-to-link-modules)" +" phase-to-link-module-uses-expr_2)" +"(list" +" 'define-values" +"(list syntax-literals-id)" +" syntax-literals-expr_1)))))" +"(hash-set body-linklets_1 'link link-linklet_0))))" +"(let-values() body-linklets_1))))))" +"(if to-source?_2" +"(let-values()(hasheq #f bundle_0))" +"(let-values()" +"(compiled-in-memory1.1" +"(1/hash->linklet-directory(hasheq #f bundle_0))" +" #f" +" #f" +" #f" +" phase-to-link-module-uses_3" +"(current-code-inspector)" +" phase-to-link-extra-inspectorss_0" +"(mpis-as-vector mpis_17)" +"(syntax-literals-as-vector syntax-literals_3)" +" null" +" null" +"(extract-namespace-scopes(compile-context-namespace cctx_1))" +" purely-functional?_0)))))))))))))))))))" +"(define-values" +"(compile-top-level-require)" +"(lambda(p_42 cctx_15)" +"(begin" +"(let-values(((phase_80)(compile-context-phase cctx_15)))" +"(if(parsed-require? p_42)" +"(let-values()" +"(let-values(((form-stx_0)(compile-quote-syntax(syntax-disarm$1(parsed-s p_42)) cctx_15)))" +"(list top-level-require!-id form-stx_0 ns-id)))" +"(let-values() #f))))))" +"(define-values" +"(select-defined-syms-and-bind!16.1)" +"(lambda(as-transformer?5_0" +" as-transformer?10_0" +" frame-id1_0" +" in4_0" +" in9_0" +" requires+provides3_0" +" requires+provides8_0" +" top-level-bind-scope2_0" +" top-level-bind-scope7_0" +" ids11_0" +" defined-syms12_0" +" self13_0" +" phase14_0" +" all-scopes-stx15_0)" +"(begin" +" 'select-defined-syms-and-bind!16" +"(let-values(((ids_15) ids11_0))" +"(let-values(((defined-syms_7) defined-syms12_0))" +"(let-values(((self_19) self13_0))" +"(let-values(((phase_81) phase14_0))" +"(let-values(((all-scopes-stx_3) all-scopes-stx15_0))" +"(let-values(((frame-id_7) frame-id1_0))" +"(let-values(((top-level-bind-scope_3)(if top-level-bind-scope7_0 top-level-bind-scope2_0 #f)))" +"(let-values(((requires+provides_4)(if requires+provides8_0 requires+provides3_0 #f)))" +"(let-values(((orig-s_29)(if in9_0 in4_0 #f)))" +"(let-values(((as-transformer?_4)(if as-transformer?10_0 as-transformer?5_0 #f)))" +"(let-values()" +"(let-values(((defined-syms-at-phase_0)" +"(let-values(((or-part_254)(hash-ref defined-syms_7 phase_81 #f)))" +"(if or-part_254" +" or-part_254" +"(let-values(((ht_114)(make-hasheq)))" +"(begin(hash-set! defined-syms_7 phase_81 ht_114) ht_114))))))" +"(reverse$1" +"(let-values(((lst_76) ids_15))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_76)))" +"((letrec-values(((for-loop_92)" +"(lambda(fold-var_12 lst_77)" +"(begin" +" 'for-loop" +"(if(pair? lst_77)" +"(let-values(((id_52)(unsafe-car lst_77))" +"((rest_86)(unsafe-cdr lst_77)))" +"(let-values(((fold-var_153)" +"(let-values(((fold-var_154) fold-var_12))" +"(let-values(((fold-var_164)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((sym_9)" +"(syntax-e$1" +" id_52)))" +"(let-values(((defined-sym_0)" +"(if(if(not" +"(defined-as-other?" +"(hash-ref" +" defined-syms-at-phase_0" +" sym_9" +" #f)" +" id_52" +" phase_81" +" top-level-bind-scope_3))" +"(no-extra-scopes?" +" id_52" +" all-scopes-stx_3" +" top-level-bind-scope_3" +" phase_81)" +" #f)" +" sym_9" +"((letrec-values(((loop_91)" +"(lambda(pos_96)" +"(begin" +" 'loop" +"(let-values(((s_178)" +"(string->unreadable-symbol" +"(format" +" \"~a.~a\"" +" sym_9" +" pos_96))))" +"(if(defined-as-other?" +"(hash-ref" +" defined-syms-at-phase_0" +" s_178" +" #f)" +" id_52" +" phase_81" +" top-level-bind-scope_3)" +"(loop_91" +"(add1" +" pos_96))" +" s_178))))))" +" loop_91)" +" 1))))" +"(let-values((()" +"(begin" +"(hash-set!" +" defined-syms-at-phase_0" +" defined-sym_0" +" id_52)" +"(values))))" +"(let-values(((b_72)" +"(let-values(((frame-id26_0)" +" frame-id_7)" +"((sym27_1)" +" sym_9))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" frame-id26_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" sym27_1" +" #t" +" #f" +" #f" +" self_19" +" phase_81" +" defined-sym_0))))" +"(begin" +"(if requires+provides_4" +"(let-values()" +"(let-values(((b31_0)" +" b_72))" +"(remove-required-id!75.1" +" b31_0" +" requires+provides_4" +" id_52" +" phase_81)))" +"(void))" +"(let-values(((orig-s22_0)" +" orig-s_29))" +"(add-binding!17.1" +" orig-s22_0" +" #t" +" #f" +" #f" +" id_52" +" b_72" +" phase_81))" +"(if requires+provides_4" +"(let-values()" +"(let-values(((as-transformer?36_0)" +" as-transformer?_4))" +"(add-defined-or-required-id!19.1" +" as-transformer?36_0" +" #f" +" #f" +" requires+provides_4" +" id_52" +" phase_81" +" b_72)))" +"(void))" +" defined-sym_0))))))" +" fold-var_154))))" +"(values fold-var_164)))))" +"(if(not #f)" +"(for-loop_92 fold-var_153 rest_86)" +" fold-var_153)))" +" fold-var_12)))))" +" for-loop_92)" +" null" +" lst_76)))))))))))))))))))" +"(define-values" +"(no-extra-scopes?)" +"(lambda(id_53 all-scopes-stx_4 top-level-bind-scope_4 phase_82)" +"(begin" +"(let-values(((m-id_0)(datum->syntax$1 all-scopes-stx_4(syntax-e$1 id_53))))" +"(let-values(((or-part_74)(bound-identifier=?$1 id_53 m-id_0 phase_82)))" +"(if or-part_74" +" or-part_74" +"(if top-level-bind-scope_4" +"(bound-identifier=?$1 id_53(add-scope m-id_0 top-level-bind-scope_4) phase_82)" +" #f)))))))" +"(define-values" +"(defined-as-other?)" +"(lambda(prev-id_0 id_54 phase_83 top-level-bind-scope_5)" +"(begin" +"(if prev-id_0" +"(if(not(bound-identifier=?$1 prev-id_0 id_54 phase_83))" +"(let-values(((or-part_255)(not top-level-bind-scope_5)))" +"(if or-part_255" +" or-part_255" +"(not" +"(bound-identifier=?$1" +"(remove-scope prev-id_0 top-level-bind-scope_5)" +"(remove-scope id_54 top-level-bind-scope_5)" +" phase_83))))" +" #f)" +" #f))))" +"(define-values" +"(select-defined-syms-and-bind!/ctx)" +"(lambda(tl-ids_0 ctx_10)" +"(begin" +"(let-values(((temp38_0)(root-expand-context-defined-syms ctx_10))" +"((temp39_1)(namespace-mpi(expand-context-namespace ctx_10)))" +"((temp40_1)(expand-context-phase ctx_10))" +"((temp41_1)(root-expand-context-all-scopes-stx ctx_10))" +"((temp42_0)(root-expand-context-frame-id ctx_10))" +"((temp43_0)(root-expand-context-top-level-bind-scope ctx_10)))" +"(select-defined-syms-and-bind!16.1" +" #f" +" #f" +" temp42_0" +" #f" +" #f" +" #f" +" #f" +" temp43_0" +" #t" +" tl-ids_0" +" temp38_0" +" temp39_1" +" temp40_1" +" temp41_1)))))" +"(define-values" +"(add-defined-sym!)" +"(lambda(defined-syms_8 phase_84 sym_56 id_55)" +"(begin" +"(let-values(((defined-syms-at-phase_1)" +"(let-values(((or-part_256)(hash-ref defined-syms_8 phase_84 #f)))" +"(if or-part_256" +" or-part_256" +"(let-values(((ht_31)(make-hasheq)))" +"(begin(hash-set! defined-syms_8 phase_84 ht_31) ht_31))))))" +"(hash-set! defined-syms-at-phase_1 sym_56 id_55)))))" +"(define-values" +"(make-create-root-expand-context-from-module)" +"(lambda(requires_3 evaled-ld-h_0)" +"(begin" +"(lambda(ns_58 phase-shift_13 original-self_0 self_6)" +"(let-values(((root-ctx_4)(let-values()(make-root-expand-context11.1 #f #f #f #f #f #f #f #f))))" +"(let-values(((s_3)(add-scopes empty-syntax(root-expand-context-module-scopes root-ctx_4))))" +"(let-values((()" +"(begin" +"(let-values(((lst_80) requires_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_80)))" +"((letrec-values(((for-loop_218)" +"(lambda(lst_259)" +"(begin" +" 'for-loop" +"(if(pair? lst_259)" +"(let-values(((phase+reqs_0)(unsafe-car lst_259))" +"((rest_137)(unsafe-cdr lst_259)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((phase_15)" +"(car" +" phase+reqs_0)))" +"(begin" +"(let-values(((lst_260)" +"(cdr" +" phase+reqs_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_260)))" +"((letrec-values(((for-loop_202)" +"(lambda(lst_261)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_261)" +"(let-values(((req_4)" +"(unsafe-car" +" lst_261))" +"((rest_138)" +"(unsafe-cdr" +" lst_261)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((mpi_12)" +"(module-path-index-shift" +" req_4" +" original-self_0" +" self_6)))" +"(let-values(((temp6_0)" +"(phase+" +" phase_15" +" phase-shift_13))" +"((phase-shift7_0)" +" phase-shift_13)" +"((temp8_2)" +" 'module))" +"(perform-require!78.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp6_0" +" #f" +" #f" +" phase-shift7_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp8_2" +" mpi_12" +" s_3" +" self_6" +" s_3" +" ns_58))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_202" +" rest_138)" +"(values))))" +"(values))))))" +" for-loop_202)" +" lst_260)))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_218 rest_137)(values))))" +"(values))))))" +" for-loop_218)" +" lst_80)))" +"(values))))" +"(let-values()" +"(let-values(((defined-syms_9)(root-expand-context-defined-syms root-ctx_4)))" +"(begin" +"(let-values(((ht_115) evaled-ld-h_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_115)))" +"((letrec-values(((for-loop_219)" +"(lambda(i_85)" +"(begin" +" 'for-loop" +"(if i_85" +"(let-values(((phase_85 linklet_3)" +"(hash-iterate-key+value ht_115 i_85)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(let-values(((lst_262)" +"(1/linklet-export-variables" +" linklet_3)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_262)))" +"((letrec-values(((for-loop_77)" +"(lambda(lst_83)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_83)" +"(let-values(((sym_57)" +"(unsafe-car" +" lst_83))" +"((rest_139)" +"(unsafe-cdr" +" lst_83)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((id_5)" +"(datum->syntax$1" +" s_3" +" sym_57)))" +"(begin" +"(let-values(((id9_0)" +" id_5)" +"((temp10_0)" +"(let-values(((self12_0)" +" self_6)" +"((phase13_0)" +" phase_85)" +"((sym14_0)" +" sym_57))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" self12_0" +" phase13_0" +" sym14_0)))" +"((phase11_0)" +" phase_85))" +"(add-binding!17.1" +" #f" +" #f" +" #f" +" #f" +" id9_0" +" temp10_0" +" phase11_0))" +"(add-defined-sym!" +" defined-syms_9" +" phase_85" +" sym_57" +" id_5))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_77" +" rest_139)" +"(values))))" +"(values))))))" +" for-loop_77)" +" lst_262)))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_219(hash-iterate-next ht_115 i_85))" +"(values))))" +"(values))))))" +" for-loop_219)" +"(hash-iterate-first ht_115))))" +"(void)" +" root-ctx_4))))))))))" +"(define-values" +"(check-require-access9.1)" +"(lambda(skip-imports1_0" +" linklet3_0" +" import-module-uses4_0" +" import-module-instances5_0" +" insp6_0" +" extra-inspector7_0" +" extra-inspectorsss8_0)" +"(begin" +" 'check-require-access9" +"(let-values(((linklet_4) linklet3_0))" +"(let-values(((skip-num-imports_0) skip-imports1_0))" +"(let-values(((import-module-uses_0) import-module-uses4_0))" +"(let-values(((import-module-instances_0) import-module-instances5_0))" +"(let-values(((insp_10) insp6_0))" +"(let-values(((extra-inspector_0) extra-inspector7_0))" +"(let-values(((extra-inspectorsss_4) extra-inspectorsss8_0))" +"(let-values()" +"(begin" +"(let-values(((lst_39)(list-tail(1/linklet-import-variables linklet_4) skip-num-imports_0))" +"((lst_263) import-module-uses_0)" +"((lst_84) import-module-instances_0)" +"((lst_157)" +"(let-values(((or-part_71) extra-inspectorsss_4))" +"(if or-part_71 or-part_71 import-module-uses_0))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_39)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_263)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_84)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_157)))" +"((letrec-values(((for-loop_220)" +"(lambda(lst_264 lst_265 lst_24 lst_168)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_264)" +"(if(pair? lst_265)(if(pair? lst_24)(pair? lst_168) #f) #f)" +" #f)" +"(let-values(((import-syms_0)(unsafe-car lst_264))" +"((rest_140)(unsafe-cdr lst_264))" +"((mu_7)(unsafe-car lst_265))" +"((rest_141)(unsafe-cdr lst_265))" +"((mi_16)(unsafe-car lst_24))" +"((rest_41)(unsafe-cdr lst_24))" +"((extra-inspectorss_14)(unsafe-car lst_168))" +"((rest_35)(unsafe-cdr lst_168)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((m_15)" +"(module-instance-module" +" mi_16)))" +"(if(module-no-protected?" +" m_15)" +"(void)" +"(let-values()" +"(let-values(((access_2)" +"(let-values(((or-part_8)" +"(module-access" +" m_15)))" +"(if or-part_8" +" or-part_8" +"(module-compute-access!" +" m_15)))))" +"(begin" +"(let-values(((lst_55)" +" import-syms_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_55)))" +"((letrec-values(((for-loop_221)" +"(lambda(lst_25)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_25)" +"(let-values(((import-sym_0)" +"(unsafe-car" +" lst_25))" +"((rest_9)" +"(unsafe-cdr" +" lst_25)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((a_43)" +"(hash-ref" +"(hash-ref" +" access_2" +"(module-use-phase" +" mu_7)" +" '#hasheq())" +" import-sym_0" +" 'unexported)))" +"(if(let-values(((or-part_167)" +"(eq?" +" a_43" +" 'unexported)))" +"(if or-part_167" +" or-part_167" +"(eq?" +" a_43" +" 'protected)))" +"(let-values()" +"(let-values(((guard-insp_3)" +"(namespace-inspector" +"(module-instance-namespace" +" mi_16))))" +"(if(let-values(((or-part_169)" +"(inspector-superior?" +" insp_10" +" guard-insp_3)))" +"(if or-part_169" +" or-part_169" +"(let-values(((or-part_33)" +"(if extra-inspector_0" +"(inspector-superior?" +" extra-inspector_0" +" guard-insp_3)" +" #f)))" +"(if or-part_33" +" or-part_33" +"(if extra-inspectorsss_4" +"(if extra-inspectorss_14" +"(extra-inspectors-allow?" +"(hash-ref" +" extra-inspectorss_14" +" import-sym_0" +" #f)" +" guard-insp_3)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(error" +" 'link" +"(string-append" +" \"access disallowed by code inspector to ~a variable\\n\"" +" \" variable: ~s\\n\"" +" \" from module: ~a\")" +" a_43" +" import-sym_0" +"(1/module-path-index-resolve" +"(namespace-mpi" +"(module-instance-namespace" +" mi_16))))))))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_221" +" rest_9)" +"(values))))" +"(values))))))" +" for-loop_221)" +" lst_55)))" +"(void)))))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_220 rest_140 rest_141 rest_41 rest_35)" +"(values))))" +"(values))))))" +" for-loop_220)" +" lst_39" +" lst_263" +" lst_84" +" lst_157)))" +"(void)))))))))))))" +"(define-values" +"(check-single-require-access)" +"(lambda(mi_17 phase_86 sym_58 insp_11)" +"(begin" +"(let-values(((m_16)(module-instance-module mi_17)))" +"(if(module-no-protected? m_16)" +"(let-values() #t)" +"(let-values()" +"(let-values(((access_3)" +"(let-values(((or-part_68)(module-access m_16)))" +"(if or-part_68 or-part_68(module-compute-access! m_16)))))" +"(let-values(((a_44)(hash-ref(hash-ref access_3 phase_86 '#hasheq()) sym_58 'unexported)))" +"(if(let-values(((or-part_36)(eq? a_44 'unexported)))" +"(if or-part_36 or-part_36(eq? a_44 'protected)))" +"(let-values()" +"(let-values(((guard-insp_4)(namespace-inspector(module-instance-namespace mi_17))))" +"(let-values(((or-part_257)(if insp_11(inspector-superior? insp_11 guard-insp_4) #f)))" +"(if or-part_257 or-part_257(inspector-superior?(current-code-inspector) guard-insp_4)))))" +"(let-values() #t))))))))))" +"(define-values(module-cache)(make-weak-hash))" +"(define-values" +"(make-module-cache-key)" +"(lambda(hash-code_4)(begin(if hash-code_4(list hash-code_4(current-load-relative-directory)) #f))))" +"(define-values" +"(module-cache-set!)" +"(lambda(key_11 proc_8)(begin(hash-set! module-cache key_11(make-ephemeron key_11 proc_8)))))" +"(define-values" +"(module-cache-ref)" +"(lambda(key_66)" +"(begin(let-values(((e_70)(hash-ref module-cache key_66 #f)))(if e_70(ephemeron-value e_70) #f)))))" +"(define-values(current-module-declare-as-predefined)(make-parameter #f))" +"(define-values" +"(eval-module8.1)" +"(lambda(namespace1_2" +" namespace4_0" +" supermodule-name3_0" +" supermodule-name6_0" +" with-submodules?2_0" +" with-submodules?5_0" +" c7_0)" +"(begin" +" 'eval-module8" +"(let-values(((c_18) c7_0))" +"(let-values(((ns_59)(if namespace4_0 namespace1_2(1/current-namespace))))" +"(let-values(((with-submodules?_1)(if with-submodules?5_0 with-submodules?2_0 #t)))" +"(let-values(((supermodule-name_1)(if supermodule-name6_0 supermodule-name3_0 #f)))" +"(let-values()" +"(let-values()" +"(let-values(((dh_0 h_1 data-instance_0 declaration-instance_0)" +"(compiled-module->dh+h+data-instance+declaration-instance c_18)))" +"(let-values(((syntax-literals-data-instance_0)" +"(if(compiled-in-memory? c_18)" +"(make-syntax-literal-data-instance-from-compiled-in-memory c_18)" +"(let-values(((l_11)(hash-ref h_1 'stx-data #f)))" +"(if l_11" +"(let-values()" +"(1/instantiate-linklet" +"(1/eval-linklet l_11)" +"(list deserialize-instance data-instance_0)))" +"(if(eq?(hash-ref h_1 'module->namespace #f) 'empty)" +"(let-values() empty-syntax-literals-instance/empty-namespace)" +"(let-values() empty-syntax-literals-data-instance)))))))" +"(let-values(((decl_0)" +"(lambda(key_67)" +"(begin 'decl(1/instance-variable-value declaration-instance_0 key_67)))))" +"(let-values(((pre-submodule-names_0)(hash-ref h_1 'pre null)))" +"(let-values(((post-submodule-names_0)(hash-ref h_1 'post null)))" +"(let-values(((default-name_1)(hash-ref h_1 'name 'module)))" +"(let-values(((cache-key_0)" +"(make-module-cache-key" +"(if(null? pre-submodule-names_0)" +"(if(null? post-submodule-names_0)(hash-ref h_1 'hash-code #f) #f)" +" #f))))" +"(let-values(((cross-phase-persistent?_1)(hash-ref h_1 'cross-phase-persistent? #f)))" +"(let-values(((min-phase_2)(hash-ref h_1 'min-phase 0)))" +"(let-values(((max-phase_2)(hash-ref h_1 'max-phase 0)))" +"(let-values(((language-info_1)(hash-ref h_1 'language-info #f)))" +"(let-values(((phases-h_0)" +"(let-values(((start_37) min-phase_2)" +"((end_26)(add1 max-phase_2))" +"((inc_20) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_37 end_26 inc_20)))" +"((letrec-values(((for-loop_107)" +"(lambda(table_103 pos_97)" +"(begin" +" 'for-loop" +"(if(< pos_97 end_26)" +"(let-values(((phase-level_16)" +" pos_97))" +"(let-values(((table_175)" +"(let-values(((v_180)" +"(hash-ref" +" h_1" +" phase-level_16" +" #f)))" +"(begin" +" #t" +"((letrec-values(((for-loop_222)" +"(lambda(table_105)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_176)" +"(let-values(((table_177)" +" table_105))" +"(if v_180" +"(let-values(((table_178)" +" table_177))" +"(let-values(((table_179)" +"(let-values()" +"(let-values(((key_68" +" val_58)" +"(let-values()" +"(values" +" phase-level_16" +"(1/eval-linklet" +" v_180)))))" +"(hash-set" +" table_178" +" key_68" +" val_58)))))" +"(values" +" table_179)))" +" table_177))))" +" table_176))))))" +" for-loop_222)" +" table_103)))))" +"(if(not #f)" +"(for-loop_107" +" table_175" +"(+ pos_97 inc_20))" +" table_175)))" +" table_103)))))" +" for-loop_107)" +" '#hash()" +" start_37)))))" +"(let-values(((syntax-literals-linklet_0)" +"(let-values(((l_15)(hash-ref h_1 'stx #f)))" +"(if l_15(1/eval-linklet l_15) #f))))" +"(let-values(((extra-inspector_6)" +"(if(compiled-in-memory? c_18)" +"(compiled-in-memory-compile-time-inspector c_18)" +" #f)))" +"(let-values(((phase-to-link-extra-inspectorsss_1)" +"(if(compiled-in-memory? c_18)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss c_18)" +" '#hasheqv())))" +"(let-values(((requires_4)(decl_0 'requires)))" +"(let-values(((provides_8)(decl_0 'provides)))" +"(let-values(((original-self_1)(decl_0 'self-mpi)))" +"(let-values(((phase-to-link-modules_0)" +"(decl_0 'phase-to-link-modules)))" +"(let-values(((create-root-expand-context-from-module_0)" +"(make-create-root-expand-context-from-module" +" requires_4" +" phases-h_0)))" +"(let-values(((declare-submodules_0)" +"(if dh_0" +"(lambda(ns_60 names_0 declare-name_0 pre?_0)" +"(begin" +" 'declare-submodules" +"(if(compiled-in-memory? c_18)" +"(begin" +"(let-values(((lst_20)" +"(if pre?_0" +"(compiled-in-memory-pre-compiled-in-memorys" +" c_18)" +"(compiled-in-memory-post-compiled-in-memorys" +" c_18))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_20)))" +"((letrec-values(((for-loop_223)" +"(lambda(lst_87)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_87)" +"(let-values(((c_25)" +"(unsafe-car" +" lst_87))" +"((rest_42)" +"(unsafe-cdr" +" lst_87)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((ns13_0)" +" ns_60)" +"((declare-name14_0)" +" declare-name_0))" +"(eval-module8.1" +" ns13_0" +" #t" +" declare-name14_0" +" #t" +" #f" +" #f" +" c_25)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_223" +" rest_42)" +"(values))))" +"(values))))))" +" for-loop_223)" +" lst_20)))" +"(void))" +"(begin" +"(let-values(((lst_266) names_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_266)))" +"((letrec-values(((for-loop_224)" +"(lambda(lst_88)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_88)" +"(let-values(((name_48)" +"(unsafe-car" +" lst_88))" +"((rest_142)" +"(unsafe-cdr" +" lst_88)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((sm-cd_0)" +"(hash-ref" +" dh_0" +" name_48" +" #f)))" +"(begin" +"(if sm-cd_0" +"(void)" +"(let-values()" +"(error" +" \"missing submodule declaration:\"" +" name_48)))" +"(let-values(((ns16_0)" +" ns_60)" +"((declare-name17_0)" +" declare-name_0))" +"(eval-module8.1" +" ns16_0" +" #t" +" declare-name17_0" +" #t" +" #f" +" #f" +" sm-cd_0)))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_224" +" rest_142)" +"(values))))" +"(values))))))" +" for-loop_224)" +" lst_266)))" +"(void)))))" +" void)))" +"(let-values(((declare-this-module_0)" +"(lambda(ns_61)" +"(begin" +" 'declare-this-module" +"(let-values(((m_17)" +"(let-values(((temp22_3)" +"(1/current-module-declare-source))" +"((original-self23_0)" +" original-self_1)" +"((requires24_0)" +" requires_4)" +"((provides25_0)" +" provides_8)" +"((language-info26_0)" +" language-info_1)" +"((min-phase27_0)" +" min-phase_2)" +"((max-phase28_0)" +" max-phase_2)" +"((cross-phase-persistent?29_0)" +" cross-phase-persistent?_1)" +"((temp30_1)" +"(current-module-declare-as-predefined))" +"((temp31_2)" +"(append" +" pre-submodule-names_0" +" post-submodule-names_0))" +"((supermodule-name32_0)" +" supermodule-name_1)" +"((temp33_0)" +"(lambda()" +"(get-all-variables" +" phases-h_0)))" +"((temp34_0)" +"(lambda(phase-level_17" +" ns_62" +" insp_12)" +"(module-linklet-info2.1" +"(hash-ref" +" phases-h_0" +" phase-level_17" +" #f)" +"(hash-ref" +" phase-to-link-modules_0" +" phase-level_17" +" #f)" +" original-self_1" +" insp_12" +" extra-inspector_6" +"(hash-ref" +" phase-to-link-extra-inspectorsss_1" +" phase-level_17" +" #f))))" +"((temp35_0)" +"(lambda(bulk-binding-registry_13)" +"(force-syntax-deserialize" +" syntax-literals-data-instance_0" +" bulk-binding-registry_13)))" +"((temp36_2)" +"(lambda(data-box_2" +" ns_63" +" phase-shift_15" +" self_20" +" bulk-binding-registry_14" +" insp_13)" +"(if(unbox" +" data-box_2)" +"(void)" +"(let-values()" +"(init-instance-data!" +" data-box_2" +" cache-key_0" +" ns_63" +" syntax-literals-linklet_0" +" data-instance_0" +" syntax-literals-data-instance_0" +" phase-shift_15" +" original-self_1" +" self_20" +" bulk-binding-registry_14" +" insp_13" +" create-root-expand-context-from-module_0)))))" +"((temp37_0)" +"(lambda(data-box_3" +" ns_64" +" phase-shift_16" +" phase-level_18" +" self_21" +" bulk-binding-registry_15" +" insp_14)" +"(let-values()" +"(let-values(((syntax-literals-instance_0)" +"(instance-data-syntax-literals-instance" +"(unbox" +" data-box_3))))" +"(let-values(((phase-linklet_0)" +"(hash-ref" +" phases-h_0" +" phase-level_18" +" #f)))" +"(if phase-linklet_0" +"(let-values()" +"(let-values(((module-uses_0)" +"(hash-ref" +" phase-to-link-modules_0" +" phase-level_18)))" +"(let-values(((import-module-instances_1" +" import-instances_0)" +"(let-values(((mis_1" +" is_0)" +"(let-values(((lst_267)" +" module-uses_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_267)))" +"((letrec-values(((for-loop_225)" +"(lambda(mis_2" +" is_1" +" lst_268)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_268)" +"(let-values(((mu_8)" +"(unsafe-car" +" lst_268))" +"((rest_143)" +"(unsafe-cdr" +" lst_268)))" +"(let-values(((mis_3" +" is_2)" +"(let-values(((mis_4)" +" mis_2)" +"((is_3)" +" is_1))" +"(let-values(((mis_5" +" is_4)" +"(let-values()" +"(let-values(((mis45_0" +" is46_0)" +"(let-values()" +"(let-values(((original-self49_0)" +" original-self_1)" +"((self50_0)" +" self_21)" +"((temp51_1)" +"(phase+" +"(phase-" +" phase-level_18" +"(module-use-phase" +" mu_8))" +" phase-shift_16)))" +"(namespace-module-use->module+linklet-instances146.1" +" temp51_1" +" original-self49_0" +" #t" +" self50_0" +" #t" +" ns_64" +" mu_8)))))" +"(values" +"(cons" +" mis45_0" +" mis_4)" +"(cons" +" is46_0" +" is_3))))))" +"(values" +" mis_5" +" is_4)))))" +"(if(not" +" #f)" +"(for-loop_225" +" mis_3" +" is_2" +" rest_143)" +"(values" +" mis_3" +" is_2))))" +"(values" +" mis_2" +" is_1))))))" +" for-loop_225)" +" null" +" null" +" lst_267)))))" +"(values" +"(reverse$1" +" mis_1)" +"(reverse$1" +" is_0)))))" +"(let-values((()" +"(begin" +"(let-values(((temp39_2)" +" 2)" +"((module-uses40_0)" +" module-uses_0)" +"((import-module-instances41_0)" +" import-module-instances_1)" +"((insp42_0)" +" insp_14)" +"((extra-inspector43_0)" +" extra-inspector_6)" +"((temp44_0)" +"(hash-ref" +" phase-to-link-extra-inspectorsss_1" +" phase-level_18" +" #f)))" +"(check-require-access9.1" +" temp39_2" +" phase-linklet_0" +" module-uses40_0" +" import-module-instances41_0" +" insp42_0" +" extra-inspector43_0" +" temp44_0))" +"(values))))" +"(let-values(((module-body-instance-instance_0)" +"(let-values(((temp52_2)" +"(lambda(name_49" +" val_59)" +"(namespace-set-transformer!" +" ns_64" +"(sub1" +" phase-level_18)" +" name_49" +" val_59))))" +"(make-module-body-instance-instance18.1" +" temp52_2))))" +"(let-values(((instantiate-body_0)" +"(lambda()" +"(begin" +" 'instantiate-body" +"(1/instantiate-linklet" +" phase-linklet_0" +"(list*" +" syntax-literals-instance_0" +" module-body-instance-instance_0" +" import-instances_0)" +"(namespace->instance" +" ns_64" +" phase-level_18))))))" +"(if(zero-phase?" +" phase-level_18)" +"(let-values()" +"(if(zero-phase?" +" phase-shift_16)" +"(let-values()" +"(instantiate-body_0))" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" ns_64)" +"(let-values()" +"(instantiate-body_0))))))" +"(let-values()" +"(let-values(((ns-1_0)" +"(namespace->namespace-at-phase" +" ns_64" +"(phase+" +" phase-shift_16" +"(sub1" +" phase-level_18)))))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-expand-context" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:214:76" +"(let-values(((ns-153_0)" +" ns-1_0))" +"(make-expand-context10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns-153_0)))))" +" 1/current-namespace" +" ns_64" +" current-module-code-inspector" +" insp_14)" +"(let-values()" +"(instantiate-body_0))))))))))))" +"(void))))))))" +"(make-module39.1" +" cross-phase-persistent?29_0" +" #t" +" temp35_0" +" #t" +" temp33_0" +" #t" +" temp37_0" +" language-info26_0" +" #t" +" max-phase28_0" +" #t" +" min-phase27_0" +" #t" +" #f" +" #f" +" temp34_0" +" #t" +" temp30_1" +" #t" +" temp36_2" +" #t" +" #f" +" #f" +" provides25_0" +" requires24_0" +" #t" +" original-self23_0" +" temp22_3" +" #t" +" temp31_2" +" #t" +" supermodule-name32_0" +" #t))))" +"(let-values(((declare-name_1)" +"(substitute-module-declare-name" +" default-name_1)))" +"(begin" +"(if with-submodules?_1" +"(let-values()" +"(declare-submodules_0" +" ns_61" +" pre-submodule-names_0" +" declare-name_1" +" #t))" +"(void))" +"(let-values(((with-submodules?21_0)" +" with-submodules?_1))" +"(declare-module!58.1" +" with-submodules?21_0" +" #t" +" ns_61" +" m_17" +" declare-name_1))" +"(if with-submodules?_1" +"(let-values()" +"(declare-submodules_0" +" ns_61" +" post-submodule-names_0" +" declare-name_1" +" #f))" +"(void)))))))))" +"(begin" +"(if cache-key_0" +"(let-values()" +"(module-cache-set!" +" cache-key_0" +" declare-this-module_0))" +"(void))" +"(declare-this-module_0" +" ns_59)))))))))))))))))))))))))))))))))" +"(define-values" +"(struct:instance-data instance-data11.1 instance-data? instance-data-syntax-literals-instance instance-data-cache-key)" +"(let-values(((struct:_67 make-_67 ?_67 -ref_67 -set!_67)" +"(let-values()" +"(let-values()" +"(make-struct-type 'instance-data #f 2 0 #f null(current-inspector) #f '(0 1) #f 'instance-data)))))" +"(values" +" struct:_67" +" make-_67" +" ?_67" +"(make-struct-field-accessor -ref_67 0 'syntax-literals-instance)" +"(make-struct-field-accessor -ref_67 1 'cache-key))))" +"(define-values" +"(init-instance-data!)" +"(lambda(data-box_4" +" cache-key_1" +" ns_65" +" syntax-literals-linklet_1" +" data-instance_1" +" syntax-literals-data-instance_1" +" phase-shift_17" +" original-self_2" +" self_22" +" bulk-binding-registry_16" +" insp_15" +" create-root-expand-context-from-module_1)" +"(begin" +"(let-values((()" +"(begin" +"(if(if(not(load-on-demand-enabled))" +"(if(not(eq? syntax-literals-data-instance_1 empty-syntax-literals-data-instance))" +"(not(eq? syntax-literals-data-instance_1 empty-syntax-literals-instance/empty-namespace))" +" #f)" +" #f)" +"(let-values()" +"(force-syntax-deserialize syntax-literals-data-instance_1 bulk-binding-registry_16))" +"(void))" +"(values))))" +"(let-values(((inst_1)" +"(let-values(((ns55_1) ns_65)" +"((phase-shift56_1) phase-shift_17)" +"((self57_0) self_22)" +"((insp58_0) insp_15)" +"((bulk-binding-registry59_0) bulk-binding-registry_16)" +"((temp60_1)" +" (lambda (name_50 val_60) (error \"shouldn't get here for the root-ctx linklet\"))))" +"(make-instance-instance13.1" +" bulk-binding-registry59_0" +" insp58_0" +" ns55_1" +" phase-shift56_1" +" self57_0" +" temp60_1))))" +"(let-values(((syntax-literals-instance_1)" +"(if syntax-literals-linklet_1" +"(1/instantiate-linklet" +" syntax-literals-linklet_1" +"(list deserialize-instance data-instance_1 syntax-literals-data-instance_1 inst_1))" +" empty-syntax-literals-instance)))" +"(let-values((()" +"(begin" +"(set-box! data-box_4(instance-data11.1 syntax-literals-instance_1 cache-key_1))" +"(values))))" +"(let-values(((get-encoded-root-expand-ctx_0)" +"(1/instance-variable-value syntax-literals-instance_1 'get-encoded-root-expand-ctx)))" +"(if(eq? get-encoded-root-expand-ctx_0 'empty)" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" ns_65" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:281:39" +"(let-values()(make-root-expand-context11.1 #f #f #f #f #f #f #f #f)))))))" +"(if(procedure? get-encoded-root-expand-ctx_0)" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" ns_65" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:284:39" +"(root-expand-context-decode-for-module(get-encoded-root-expand-ctx_0)))))))" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" ns_65" +"(delay" +"(lambda()" +"(begin" +" '...nder/eval/module.rkt:289:39" +"(create-root-expand-context-from-module_1" +" ns_65" +" phase-shift_17" +" original-self_2" +" self_22))))))))))))))))" +"(define-values" +"(force-syntax-deserialize)" +"(lambda(syntax-literals-data-instance_2 bulk-binding-registry_17)" +"(begin" +"(let-values(((deserialize-syntax_0)" +"(1/instance-variable-value syntax-literals-data-instance_2 deserialize-syntax-id)))" +"(if deserialize-syntax_0(let-values()(deserialize-syntax_0 bulk-binding-registry_17))(void))))))" +"(define-values" +"(compiled-module->dh+h)" +"(lambda(c_26)" +"(begin" +"(let-values(((ld/h_0)(if(compiled-in-memory? c_26)(compiled-in-memory-linklet-directory c_26) c_26)))" +"(let-values(((dh_1)" +"(if(1/linklet-directory? ld/h_0)" +"(let-values()(1/linklet-directory->hash ld/h_0))" +"(let-values() #f))))" +"(let-values(((h_2)(1/linklet-bundle->hash(if dh_1(hash-ref dh_1 #f) ld/h_0))))(values dh_1 h_2)))))))" +"(define-values" +"(compiled-module->h)" +"(lambda(c_27)(begin(let-values(((dh_2 h_3)(compiled-module->dh+h c_27))) h_3))))" +"(define-values" +"(compiled-module->dh+h+data-instance+declaration-instance)" +"(lambda(c_28)" +"(begin" +"(let-values(((dh_3 h_4)(compiled-module->dh+h c_28)))" +"(let-values(((data-instance_2)" +"(if(compiled-in-memory? c_28)" +"(make-data-instance-from-compiled-in-memory c_28)" +"(1/instantiate-linklet(1/eval-linklet(hash-ref h_4 'data))(list deserialize-instance)))))" +"(let-values(((declaration-instance_1)" +"(if(if(compiled-in-memory? c_28)(compiled-in-memory-original-self c_28) #f)" +"(make-declaration-instance-from-compiled-in-memory c_28)" +"(1/instantiate-linklet" +"(1/eval-linklet(hash-ref h_4 'decl))" +"(list deserialize-instance data-instance_2)))))" +"(values dh_3 h_4 data-instance_2 declaration-instance_1)))))))" +"(define-values" +"(compiled-module->declaration-instance)" +"(lambda(c_29)" +"(begin" +"(let-values(((dh_4 h_5 data-instance_3 declaration-instance_2)" +"(compiled-module->dh+h+data-instance+declaration-instance c_29)))" +" declaration-instance_2))))" +"(define-values" +"(compiled-module->h+declaration-instance)" +"(lambda(c_30)" +"(begin" +"(let-values(((dh_5 h_6 data-instance_4 declaration-instance_3)" +"(compiled-module->dh+h+data-instance+declaration-instance c_30)))" +"(values h_6 declaration-instance_3)))))" +"(define-values" +"(make-data-instance-from-compiled-in-memory)" +"(lambda(cim_6)(begin(1/make-instance 'data #f 'constant mpi-vector-id(compiled-in-memory-mpis cim_6)))))" +"(define-values" +"(make-declaration-instance-from-compiled-in-memory)" +"(lambda(cim_7)" +"(begin" +"(1/make-instance" +" 'decl" +" #f" +" 'constant" +" 'self-mpi" +"(compiled-in-memory-original-self cim_7)" +" 'requires" +"(compiled-in-memory-requires cim_7)" +" 'provides" +"(compiled-in-memory-provides cim_7)" +" 'phase-to-link-modules" +"(compiled-in-memory-phase-to-link-module-uses cim_7)))))" +"(define-values" +"(make-syntax-literal-data-instance-from-compiled-in-memory)" +"(lambda(cim_8)" +"(begin" +"(1/make-instance" +" 'syntax-literal-data" +" #f" +" #f" +" deserialize-syntax-id" +" void" +" deserialized-syntax-vector-id" +"(compiled-in-memory-syntax-literals cim_8)))))" +"(define-values" +"(empty-syntax-literals-instance/empty-namespace)" +"(1/make-instance" +" 'empty-stx/empty-ns" +" #f" +" 'constant" +" get-syntax-literal!-id" +"(lambda(pos_98) #f)" +" 'get-encoded-root-expand-ctx" +" 'empty))" +"(define-values" +"(get-all-variables)" +"(lambda(phases-h_1)" +"(begin" +"(let-values(((ht_116) phases-h_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_116)))" +"((letrec-values(((for-loop_226)" +"(lambda(table_180 i_147)" +"(begin" +" 'for-loop" +"(if i_147" +"(let-values(((phase_87 linklet_5)(hash-iterate-key+value ht_116 i_147)))" +"(let-values(((table_181)" +"(let-values(((table_144) table_180))" +"(let-values(((table_182)" +"(let-values()" +"(let-values(((key_69 val_61)" +"(let-values()" +"(values" +" phase_87" +"(1/linklet-export-variables" +" linklet_5)))))" +"(hash-set table_144 key_69 val_61)))))" +"(values table_182)))))" +"(if(not #f)" +"(for-loop_226 table_181(hash-iterate-next ht_116 i_147))" +" table_181)))" +" table_180)))))" +" for-loop_226)" +" '#hash()" +"(hash-iterate-first ht_116)))))))" +"(define-values" +"(provides->api-provides)" +"(lambda(provides_9 self_23)" +"(begin" +"(let-values(((extract_0)" +"(lambda(ok?_25)" +"(begin" +" 'extract" +"(let-values(((result-l_0)" +"(reverse$1" +"(let-values(((ht_117) provides_9))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_117)))" +"((letrec-values(((for-loop_95)" +"(lambda(fold-var_58 i_148)" +"(begin" +" 'for-loop" +"(if i_148" +"(let-values(((phase_88 at-phase_11)" +"(hash-iterate-key+value ht_117 i_148)))" +"(let-values(((fold-var_59)" +"(let-values(((l_65)" +"(reverse$1" +"(let-values(((ht_110)" +" at-phase_11))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_110)))" +"((letrec-values(((for-loop_227)" +"(lambda(fold-var_215" +" i_149)" +"(begin" +" 'for-loop" +"(if i_149" +"(let-values(((sym_59" +" b/p_1)" +"(hash-iterate-key+value" +" ht_110" +" i_149)))" +"(let-values(((fold-var_216)" +"(let-values(((fold-var_217)" +" fold-var_215))" +"(if(ok?_25" +" b/p_1)" +"(let-values(((fold-var_30)" +" fold-var_217))" +"(let-values(((fold-var_218)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((b_73)" +"(provided-as-binding" +" b/p_1)))" +"(list" +" sym_59" +"(if(eq?" +" self_23" +"(module-binding-module" +" b_73))" +"(let-values()" +" null)" +"(let-values()" +"(reverse$1" +"(let-values(((lst_82)" +"(cons" +" b_73" +"(module-binding-extra-nominal-bindings" +" b_73))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_82)))" +"((letrec-values(((for-loop_219)" +"(lambda(fold-var_32" +" lst_269)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_269)" +"(let-values(((b_74)" +"(unsafe-car" +" lst_269))" +"((rest_144)" +"(unsafe-cdr" +" lst_269)))" +"(let-values(((fold-var_148)" +"(let-values(((fold-var_149)" +" fold-var_32))" +"(let-values(((fold-var_26)" +"(let-values()" +"(cons" +"(let-values()" +"(if(if(eqv?" +"(module-binding-nominal-phase" +" b_74)" +" phase_88)" +"(eq?" +"(module-binding-nominal-sym" +" b_74)" +" sym_59)" +" #f)" +"(let-values()" +"(module-binding-nominal-module" +" b_74))" +"(let-values()" +"(list" +"(module-binding-nominal-module" +" b_74)" +"(module-binding-phase" +" b_74)" +"(module-binding-nominal-sym" +" b_74)" +"(module-binding-nominal-phase" +" b_74)))))" +" fold-var_149))))" +"(values" +" fold-var_26)))))" +"(if(not" +" #f)" +"(for-loop_219" +" fold-var_148" +" rest_144)" +" fold-var_148)))" +" fold-var_32)))))" +" for-loop_219)" +" null" +" lst_82)))))))))" +" fold-var_30))))" +"(values" +" fold-var_218)))" +" fold-var_217))))" +"(if(not" +" #f)" +"(for-loop_227" +" fold-var_216" +"(hash-iterate-next" +" ht_110" +" i_149))" +" fold-var_216)))" +" fold-var_215)))))" +" for-loop_227)" +" null" +"(hash-iterate-first" +" ht_110)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_100)" +"(lambda(fold-var_64)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_150)" +"(let-values(((fold-var_27)" +" fold-var_64))" +"(if(null?" +" l_65)" +" fold-var_27" +"(let-values(((fold-var_28)" +" fold-var_27))" +"(let-values(((fold-var_29)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" phase_88" +"(let-values(((car6_0)" +" car))" +"(sort7.1" +" #f" +" #f" +" car6_0" +" #t" +" l_65" +" symbolapi-nonprovides)" +"(lambda(provides_10 all-vars_0)" +"(begin" +"(let-values(((result-l_1)" +"(reverse$1" +"(let-values(((ht_118) all-vars_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_118)))" +"((letrec-values(((for-loop_201)" +"(lambda(fold-var_211 i_40)" +"(begin" +" 'for-loop" +"(if i_40" +"(let-values(((phase_89 vars_0)(hash-iterate-key+value ht_118 i_40)))" +"(let-values(((fold-var_154)" +"(let-values(((fold-var_164) fold-var_211))" +"(let-values(((l_14)" +"(let-values(((syms_19)" +"(hash-ref" +" provides_10" +" phase_89" +" '#hasheq())))" +"(reverse$1" +"(let-values(((lst_86) vars_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_86)))" +"((letrec-values(((for-loop_93)" +"(lambda(fold-var_167" +" lst_169)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_169)" +"(let-values(((var-sym_5)" +"(unsafe-car" +" lst_169))" +"((rest_88)" +"(unsafe-cdr" +" lst_169)))" +"(let-values(((fold-var_67)" +"(let-values(((fold-var_168)" +" fold-var_167))" +"(if(hash-ref" +" syms_19" +" var-sym_5" +" #f)" +" fold-var_168" +"(let-values(((fold-var_18)" +" fold-var_168))" +"(let-values(((fold-var_19)" +"(let-values()" +"(cons" +"(let-values()" +" var-sym_5)" +" fold-var_18))))" +"(values" +" fold-var_19)))))))" +"(if(not" +" #f)" +"(for-loop_93" +" fold-var_67" +" rest_88)" +" fold-var_67)))" +" fold-var_167)))))" +" for-loop_93)" +" null" +" lst_86)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_203)" +"(lambda(fold-var_68)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((fold-var_69)" +"(let-values(((fold-var_212)" +" fold-var_68))" +"(if(null?" +" l_14)" +" fold-var_212" +"(let-values(((fold-var_213)" +" fold-var_212))" +"(let-values(((fold-var_214)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" phase_89" +"(let-values(((l10_0)" +" l_14)" +"((symbollinklet-directory-or-bundle)" +"(lambda(c_31)(begin(if(compiled-in-memory? c_31)(compiled-in-memory-linklet-directory c_31) c_31))))" +"(define-values" +"(module-compiled-current-name)" +"(lambda(c_32)" +"(begin" +"(let-values(((ld_1)(compiled->linklet-directory-or-bundle c_32)))" +"(let-values(((b_15)(if(1/linklet-bundle? ld_1) ld_1(hash-ref(1/linklet-directory->hash ld_1) #f))))" +"(hash-ref(1/linklet-bundle->hash b_15) 'name))))))" +"(define-values" +"(module-compiled-immediate-name)" +"(lambda(c_33)" +"(begin(let-values(((n_27)(module-compiled-current-name c_33)))(if(pair? n_27)(car(reverse$1 n_27)) n_27)))))" +"(define-values" +"(change-module-name)" +"(lambda(c_34 name_3 prefix_4)" +"(begin" +"(let-values(((full-name_0)(if(null? prefix_4) name_3(append prefix_4(list name_3)))))" +"(let-values(((next-prefix_0)(if(null? prefix_4)(list name_3) full-name_0)))" +"(let-values(((recur_0)" +"(lambda(sub-c_0 name_51)" +"(begin" +" 'recur" +"(if(equal?(module-compiled-current-name sub-c_0)(append next-prefix_0(list name_51)))" +" sub-c_0" +"(change-module-name sub-c_0 name_51 next-prefix_0))))))" +"(if(compiled-in-memory? c_34)" +"(let-values()" +"(let-values(((change-submodule-name_0)" +"(lambda(sub-c_1)" +"(begin" +" 'change-submodule-name" +"(recur_0 sub-c_1(module-compiled-immediate-name sub-c_1))))))" +"(let-values(((pre-compiled-in-memorys_0)" +"(map2 change-submodule-name_0(compiled-in-memory-pre-compiled-in-memorys c_34))))" +"(let-values(((post-compiled-in-memorys_0)" +"(map2 change-submodule-name_0(compiled-in-memory-post-compiled-in-memorys c_34))))" +"(let-values(((the-struct_3) c_34))" +"(if(compiled-in-memory? the-struct_3)" +"(let-values(((pre-compiled-in-memorys8_0) pre-compiled-in-memorys_0)" +"((post-compiled-in-memorys9_0) post-compiled-in-memorys_0)" +"((linklet-directory10_0)" +"(let-values(((temp11_2)" +"(update-one-name" +"(let-values(((ld_2)" +"(compiled->linklet-directory-or-bundle c_34)))" +"(if(1/linklet-bundle? ld_2)" +" ld_2" +"(hash-ref(1/linklet-directory->hash ld_2) #f)))" +" full-name_0))" +"((temp12_1)(symbol? full-name_0))" +"((temp13_1)" +"(append pre-compiled-in-memorys_0 post-compiled-in-memorys_0)))" +"(rebuild-linklet-directory5.1 temp12_1 #t temp11_2 temp13_1))))" +"(compiled-in-memory1.1" +" linklet-directory10_0" +"(compiled-in-memory-original-self the-struct_3)" +"(compiled-in-memory-requires the-struct_3)" +"(compiled-in-memory-provides the-struct_3)" +"(compiled-in-memory-phase-to-link-module-uses the-struct_3)" +"(compiled-in-memory-compile-time-inspector the-struct_3)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_3)" +"(compiled-in-memory-mpis the-struct_3)" +"(compiled-in-memory-syntax-literals the-struct_3)" +" pre-compiled-in-memorys8_0" +" post-compiled-in-memorys9_0" +"(compiled-in-memory-namespace-scopes the-struct_3)" +"(compiled-in-memory-purely-functional? the-struct_3)))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_3)))))))" +"(if(1/linklet-directory? c_34)" +"(let-values()" +"(1/hash->linklet-directory" +"(let-values(((ht_119)(1/linklet-directory->hash c_34)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_119)))" +"((letrec-values(((for-loop_228)" +"(lambda(table_183 i_150)" +"(begin" +" 'for-loop" +"(if i_150" +"(let-values(((key_30 val_62)(hash-iterate-key+value ht_119 i_150)))" +"(let-values(((table_184)" +"(let-values(((table_185) table_183))" +"(let-values(((table_102)" +"(let-values()" +"(let-values(((key_70 val_63)" +"(let-values()" +"(values" +" key_30" +"(if(not key_30)" +"(update-one-name" +" val_62" +" full-name_0)" +"(recur_0" +" val_62" +" key_30))))))" +"(hash-set" +" table_185" +" key_70" +" val_63)))))" +"(values table_102)))))" +"(if(not #f)" +"(for-loop_228 table_184(hash-iterate-next ht_119 i_150))" +" table_184)))" +" table_183)))))" +" for-loop_228)" +" '#hasheq()" +"(hash-iterate-first ht_119))))))" +"(let-values()(update-one-name c_34 full-name_0))))))))))" +"(define-values" +"(update-one-name)" +"(lambda(lb_0 name_52)(begin(1/hash->linklet-bundle(hash-set(1/linklet-bundle->hash lb_0) 'name name_52)))))" +"(define-values" +"(rebuild-linklet-directory5.1)" +"(lambda(bundle-ok?1_0 bundle-ok?2_0 main3_0 submods4_0)" +"(begin" +" 'rebuild-linklet-directory5" +"(let-values(((main_0) main3_0))" +"(let-values(((submods_0) submods4_0))" +"(let-values(((bundle-ok?_0)(if bundle-ok?2_0 bundle-ok?1_0 #f)))" +"(let-values()" +"(if(if(null? submods_0) bundle-ok?_0 #f)" +" main_0" +"(1/hash->linklet-directory" +"(hash-set" +"(let-values(((lst_85) submods_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_85)))" +"((letrec-values(((for-loop_222)" +"(lambda(ht_111 lst_270)" +"(begin" +" 'for-loop" +"(if(pair? lst_270)" +"(let-values(((submod_1)(unsafe-car lst_270))" +"((rest_87)(unsafe-cdr lst_270)))" +"(let-values(((ht_120)" +"(let-values(((ht_121) ht_111))" +"(let-values(((ht_122)" +"(let-values()" +"(let-values(((name_53)" +"(module-compiled-immediate-name" +" submod_1)))" +"(if(hash-ref ht_121 name_53 #f)" +"(let-values()" +"(raise-arguments-error" +" 'module-compiled-submodules" +" \"change would result in duplicate submodule name\"" +" \"name\"" +" name_53))" +"(let-values()" +"(hash-set" +" ht_121" +" name_53" +"(compiled->linklet-directory-or-bundle" +" submod_1))))))))" +"(values ht_122)))))" +"(if(not #f)(for-loop_222 ht_120 rest_87) ht_120)))" +" ht_111)))))" +" for-loop_222)" +" '#hasheq()" +" lst_85)))" +" #f" +" main_0))))))))))" +"(define-values" +"(1/compiled-expression?)" +"(lambda(c_31)" +"(begin" +" 'compiled-expression?" +"(let-values(((or-part_0)(compiled-in-memory? c_31)))" +"(if or-part_0" +" or-part_0" +"(let-values(((or-part_1)(1/linklet-directory? c_31)))" +"(if or-part_1 or-part_1(1/linklet-bundle? c_31))))))))" +"(define-values" +"(1/compiled-module-expression?)" +"(lambda(c_35)" +"(begin" +" 'compiled-module-expression?" +"(let-values(((ld_3)(compiled->linklet-directory-or-bundle c_35)))" +"(let-values(((or-part_26)" +"(if(1/linklet-directory? ld_3)" +"(if(let-values(((b_75)(hash-ref(1/linklet-directory->hash ld_3) #f #f)))" +"(if b_75(hash-ref(1/linklet-bundle->hash b_75) 'decl #f) #f))" +" #t" +" #f)" +" #f)))" +"(if or-part_26" +" or-part_26" +"(if(1/linklet-bundle? ld_3)(if(hash-ref(1/linklet-bundle->hash ld_3) 'decl #f) #t #f) #f)))))))" +"(define-values" +"(1/module-compiled-name)" +"(case-lambda" +"((c_18)" +"(begin" +" 'module-compiled-name" +"(begin" +"(if(1/compiled-module-expression? c_18)" +"(void)" +" (let-values () (raise-argument-error 'module-compiled-name \"compiled-module-expression?\" c_18)))" +"(module-compiled-current-name c_18))))" +"((c_36 name_54)" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_36)" +"(void)" +" (let-values () (raise-argument-error 'module-compiled-name \"compiled-module-expression?\" c_36)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_13)(symbol? name_54)))" +"(if or-part_13" +" or-part_13" +"(if(pair? name_54)(if(list? name_54)(andmap2 symbol? name_54) #f) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-compiled-name" +" \"(or/c symbol? (cons/c symbol? (non-empty-listof symbol?)))\"" +" name_54)))" +"(values))))" +"(let-values(((i-name_0 prefix_5)" +"(if(symbol? name_54)" +"(values name_54 null)" +"(let-values(((r_41)(reverse$1 name_54)))(values(car r_41)(reverse$1(cdr r_41)))))))" +"(change-module-name c_36 i-name_0 prefix_5)))))))" +"(define-values" +"(1/module-compiled-submodules)" +"(case-lambda" +"((c_37 non-star?_0)" +"(begin" +" 'module-compiled-submodules" +"(begin" +"(if(1/compiled-module-expression? c_37)" +"(void)" +" (let-values () (raise-argument-error 'module-compiled-submodules \"compiled-module-expression?\" c_37)))" +"(if(compiled-in-memory? c_37)" +"(let-values()" +"(if non-star?_0" +"(compiled-in-memory-pre-compiled-in-memorys c_37)" +"(compiled-in-memory-post-compiled-in-memorys c_37)))" +"(let-values()" +"(if(1/linklet-directory? c_37)" +"(let-values()" +"(let-values(((ht_123)(1/linklet-directory->hash c_37)))" +"(let-values(((bh_0)(1/linklet-bundle->hash(hash-ref ht_123 #f))))" +"(let-values(((names_1)(hash-ref bh_0(if non-star?_0 'pre 'post) null)))" +"(reverse$1" +"(let-values(((lst_74) names_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_74)))" +"((letrec-values(((for-loop_70)" +"(lambda(fold-var_30 lst_271)" +"(begin" +" 'for-loop" +"(if(pair? lst_271)" +"(let-values(((name_55)(unsafe-car lst_271))" +"((rest_145)(unsafe-cdr lst_271)))" +"(let-values(((fold-var_31)" +"(let-values(((fold-var_32) fold-var_30))" +"(let-values(((fold-var_33)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref ht_123 name_55))" +" fold-var_32))))" +"(values fold-var_33)))))" +"(if(not #f)(for-loop_70 fold-var_31 rest_145) fold-var_31)))" +" fold-var_30)))))" +" for-loop_70)" +" null" +" lst_74))))))))" +"(let-values() null)))))))" +"((c_38 non-star?_1 submods_1)" +"(begin" +"(if(1/compiled-module-expression? c_38)" +"(void)" +" (let-values () (raise-argument-error 'module-compiled-submodules \"compiled-module-expression?\" c_38)))" +"(if(if(list? submods_1)(andmap2 1/compiled-module-expression? submods_1) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-submodules \"(listof compiled-module-expression?)\" submods_1)))" +"(if(if(null? submods_1)" +"(let-values(((or-part_29)(1/linklet-bundle?(compiled->linklet-directory-or-bundle c_38))))" +"(if or-part_29" +" or-part_29" +"(if(compiled-in-memory? c_38)" +"(null?" +"(if non-star?_1" +"(compiled-in-memory-pre-compiled-in-memorys c_38)" +"(compiled-in-memory-post-compiled-in-memorys c_38)))" +" #f)))" +" #f)" +"(let-values() c_38)" +"(if(if(compiled-in-memory? c_38)(andmap2 compiled-in-memory? submods_1) #f)" +"(let-values()" +"(let-values(((pre-compiled-in-memorys_1)" +"(if non-star?_1 submods_1(compiled-in-memory-pre-compiled-in-memorys c_38))))" +"(let-values(((post-compiled-in-memorys_1)" +"(if non-star?_1(compiled-in-memory-post-compiled-in-memorys c_38) submods_1)))" +"(let-values(((n-c_0)(normalize-to-linklet-directory c_38)))" +"(fixup-submodule-names" +"(let-values(((the-struct_56) n-c_0))" +"(if(compiled-in-memory? the-struct_56)" +"(let-values(((pre-compiled-in-memorys1_0) pre-compiled-in-memorys_1)" +"((post-compiled-in-memorys2_0) post-compiled-in-memorys_1)" +"((linklet-directory3_0)" +"(let-values(((temp4_1)" +"(reset-submodule-names" +"(hash-ref" +"(1/linklet-directory->hash" +"(compiled->linklet-directory-or-bundle n-c_0))" +" #f)" +" non-star?_1" +" submods_1))" +"((temp5_3)(symbol?(module-compiled-current-name c_38)))" +"((temp6_1)" +"(append pre-compiled-in-memorys_1 post-compiled-in-memorys_1)))" +"(rebuild-linklet-directory5.1 temp5_3 #t temp4_1 temp6_1))))" +"(compiled-in-memory1.1" +" linklet-directory3_0" +"(compiled-in-memory-original-self the-struct_56)" +"(compiled-in-memory-requires the-struct_56)" +"(compiled-in-memory-provides the-struct_56)" +"(compiled-in-memory-phase-to-link-module-uses the-struct_56)" +"(compiled-in-memory-compile-time-inspector the-struct_56)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_56)" +"(compiled-in-memory-mpis the-struct_56)" +"(compiled-in-memory-syntax-literals the-struct_56)" +" pre-compiled-in-memorys1_0" +" post-compiled-in-memorys2_0" +"(compiled-in-memory-namespace-scopes the-struct_56)" +"(compiled-in-memory-purely-functional? the-struct_56)))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_56))))))))" +"(let-values()" +"(let-values(((n-c_1)(normalize-to-linklet-directory c_38)))" +"(fixup-submodule-names" +"(let-values(((temp7_1)" +"(reset-submodule-names" +"(hash-ref(1/linklet-directory->hash(compiled->linklet-directory-or-bundle n-c_1)) #f)" +" non-star?_1" +" submods_1))" +"((temp8_3)" +"(map2" +" compiled->linklet-directory-or-bundle" +"(append" +"(if non-star?_1 submods_1(1/module-compiled-submodules c_38 #t))" +"(if non-star?_1(1/module-compiled-submodules c_38 #f) submods_1)))))" +"(rebuild-linklet-directory5.1 #f #f temp7_1 temp8_3)))))))))))" +"(define-values" +"(1/module-compiled-language-info)" +"(lambda(c_39)" +"(begin" +" 'module-compiled-language-info" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_39)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-language-info \"compiled-module-expression?\" c_39)))" +"(values))))" +"(let-values(((h_7)(compiled-module->h c_39)))(hash-ref h_7 'language-info #f))))))" +"(define-values" +"(1/module-compiled-imports)" +"(lambda(c_40)" +"(begin" +" 'module-compiled-imports" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_40)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-imports \"compiled-module-expression?\" c_40)))" +"(values))))" +"(let-values(((inst_2)(compiled-module->declaration-instance c_40)))" +"(1/instance-variable-value inst_2 'requires))))))" +"(define-values" +"(1/module-compiled-exports)" +"(lambda(c_41)" +"(begin" +" 'module-compiled-exports" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_41)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-imports \"compiled-module-expression?\" c_41)))" +"(values))))" +"(let-values(((inst_3)(compiled-module->declaration-instance c_41)))" +"(provides->api-provides" +"(1/instance-variable-value inst_3 'provides)" +"(1/instance-variable-value inst_3 'self-mpi)))))))" +"(define-values" +"(1/module-compiled-indirect-exports)" +"(lambda(c_42)" +"(begin" +" 'module-compiled-indirect-exports" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_42)" +"(void)" +"(let-values()" +" (raise-argument-error 'module-compiled-indirect-imports \"compiled-module-expression?\" c_42)))" +"(values))))" +"(let-values(((h_8 inst_4)(compiled-module->h+declaration-instance c_42)))" +"(let-values(((min-phase_3)(hash-ref h_8 'min-phase 0)))" +"(let-values(((max-phase_3)(hash-ref h_8 'max-phase 0)))" +"(variables->api-nonprovides" +"(1/instance-variable-value inst_4 'provides)" +"(let-values(((start_36) min-phase_3)((end_25)(add1 max-phase_3))((inc_19) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_36 end_25 inc_19)))" +"((letrec-values(((for-loop_27)" +"(lambda(table_99 pos_95)" +"(begin" +" 'for-loop" +"(if(< pos_95 end_25)" +"(let-values(((phase-level_19) pos_95))" +"(let-values(((table_186)" +"(let-values(((table_106) table_99))" +"(let-values(((table_54)" +"(let-values()" +"(let-values(((key_71 val_48)" +"(let-values()" +"(let-values(((linklet_6)" +"(hash-ref" +" h_8" +" phase-level_19" +" #f)))" +"(values" +" phase-level_19" +"(if linklet_6" +"(1/linklet-export-variables" +" linklet_6)" +" null))))))" +"(hash-set table_106 key_71 val_48)))))" +"(values table_54)))))" +"(if(not #f)(for-loop_27 table_186(+ pos_95 inc_19)) table_186)))" +" table_99)))))" +" for-loop_27)" +" '#hash()" +" start_36)))))))))))" +"(define-values" +"(1/module-compiled-cross-phase-persistent?)" +"(lambda(c_43)" +"(begin" +" 'module-compiled-cross-phase-persistent?" +"(let-values((()" +"(begin" +"(if(1/compiled-module-expression? c_43)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'module-compiled-cross-phase-persistent?" +" \"compiled-module-expression?\"" +" c_43)))" +"(values))))" +"(let-values(((h_9)(compiled-module->h c_43)))(hash-ref h_9 'cross-phase-persistent? #f))))))" +"(define-values" +"(normalize-to-linklet-directory)" +"(lambda(c_44)" +"(begin" +"(if(1/linklet-directory?(compiled->linklet-directory-or-bundle c_44))" +"(let-values() c_44)" +"(if(1/linklet-bundle? c_44)" +"(let-values()(1/hash->linklet-directory(hasheq #f c_44)))" +"(let-values()" +"(let-values(((the-struct_57) c_44))" +"(if(compiled-in-memory? the-struct_57)" +"(let-values(((linklet-directory9_0)" +"(normalize-to-linklet-directory(compiled-in-memory-linklet-directory c_44))))" +"(compiled-in-memory1.1" +" linklet-directory9_0" +"(compiled-in-memory-original-self the-struct_57)" +"(compiled-in-memory-requires the-struct_57)" +"(compiled-in-memory-provides the-struct_57)" +"(compiled-in-memory-phase-to-link-module-uses the-struct_57)" +"(compiled-in-memory-compile-time-inspector the-struct_57)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss the-struct_57)" +"(compiled-in-memory-mpis the-struct_57)" +"(compiled-in-memory-syntax-literals the-struct_57)" +"(compiled-in-memory-pre-compiled-in-memorys the-struct_57)" +"(compiled-in-memory-post-compiled-in-memorys the-struct_57)" +"(compiled-in-memory-namespace-scopes the-struct_57)" +"(compiled-in-memory-purely-functional? the-struct_57)))" +" (raise-argument-error 'struct-copy \"compiled-in-memory?\" the-struct_57)))))))))" +"(define-values" +"(fixup-submodule-names)" +"(lambda(c_45)(begin(1/module-compiled-name c_45(1/module-compiled-name c_45)))))" +"(define-values" +"(reset-submodule-names)" +"(lambda(b_76 pre?_1 submods_2)" +"(begin" +"(1/hash->linklet-bundle" +"(hash-set" +"(1/linklet-bundle->hash b_76)" +"(if pre?_1 'pre 'post)" +"(map2 module-compiled-immediate-name submods_2))))))" +"(define-values" +"(compile-module13.1)" +"(lambda(force-linklet-directory?1_0" +" force-linklet-directory?6_0" +" modules-being-compiled4_0" +" modules-being-compiled9_0" +" need-compiled-submodule-rename?5_0" +" need-compiled-submodule-rename?10_0" +" serializable?2_0" +" serializable?7_0" +" to-source?3_1" +" to-source?8_0" +" p11_1" +" cctx12_1)" +"(begin" +" 'compile-module13" +"(let-values(((p_35) p11_1))" +"(let-values(((cctx_16) cctx12_1))" +"(let-values(((force-linklet-directory?_0)(if force-linklet-directory?6_0 force-linklet-directory?1_0 #f)))" +"(let-values(((serializable?_2)(if serializable?7_0 serializable?2_0 #f)))" +"(let-values(((to-source?_3)(if to-source?8_0 to-source?3_1 #f)))" +"(let-values(((modules-being-compiled_0)" +"(if modules-being-compiled9_0 modules-being-compiled4_0(make-hasheq))))" +"(let-values(((need-compiled-submodule-rename?_0)" +"(if need-compiled-submodule-rename?10_0 need-compiled-submodule-rename?5_0 #t)))" +"(let-values()" +"(let-values(((full-module-name_1)" +"(let-values(((parent-full-name_0)(compile-context-full-module-name cctx_16))" +"((name_56)(syntax-e$1(parsed-module-name-id p_35))))" +"(if parent-full-name_0" +"(append" +"(if(list? parent-full-name_0) parent-full-name_0(list parent-full-name_0))" +"(list name_56))" +" name_56))))" +"(let-values(((compiled-submodules_0)(parsed-module-compiled-submodules p_35)))" +"(let-values(((get-submodules_0)" +"(lambda(star?_0)" +"(begin" +" 'get-submodules" +"(reverse$1" +"(let-values(((ht_124) compiled-submodules_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_124)))" +"((letrec-values(((for-loop_100)" +"(lambda(fold-var_64 i_151)" +"(begin" +" 'for-loop" +"(if i_151" +"(let-values(((name_57 star?+compiled_0)" +"(hash-iterate-key+value" +" ht_124" +" i_151)))" +"(let-values(((fold-var_29)" +"(let-values(((fold-var_151)" +" fold-var_64))" +"(if(eq?" +" star?_0" +"(car star?+compiled_0))" +"(let-values(((fold-var_9)" +" fold-var_151))" +"(let-values(((fold-var_65)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" name_57" +"(if(if need-compiled-submodule-rename?_0" +"(not" +"(parsed-module-compiled-module" +" p_35))" +" #f)" +"(update-submodule-names" +"(cdr" +" star?+compiled_0)" +" name_57" +" full-module-name_1)" +"(cdr" +" star?+compiled_0))))" +" fold-var_9))))" +"(values fold-var_65)))" +" fold-var_151))))" +"(if(not #f)" +"(for-loop_100" +" fold-var_29" +"(hash-iterate-next ht_124 i_151))" +" fold-var_29)))" +" fold-var_64)))))" +" for-loop_100)" +" null" +"(hash-iterate-first ht_124)))))))))" +"(let-values(((pre-submodules_0)(get-submodules_0 #f)))" +"(let-values(((post-submodules_0)(get-submodules_0 #t)))" +"(let-values(((c1_25)(parsed-module-compiled-module p_35)))" +"(if c1_25" +"((lambda(c_46)" +"(let-values(((name_58 prefix_6)" +"(if(symbol? full-module-name_1)" +"(values full-module-name_1 null)" +"(let-values(((r_10)(reverse$1 full-module-name_1)))" +"(values(car r_10)(reverse$1(cdr r_10)))))))" +"(let-values(((m_18)(change-module-name c_46 name_58 prefix_6)))" +"(1/module-compiled-submodules" +"(1/module-compiled-submodules m_18 #t(map2 cdr pre-submodules_0))" +" #f" +"(map2 cdr post-submodules_0)))))" +" c1_25)" +"(let-values()" +"(let-values(((full-module-name39_0) full-module-name_1)" +"((force-linklet-directory?40_0) force-linklet-directory?_0)" +"((serializable?41_0) serializable?_2)" +"((to-source?42_0) to-source?_3)" +"((modules-being-compiled43_0) modules-being-compiled_0)" +"((pre-submodules44_0) pre-submodules_0)" +"((post-submodules45_0) post-submodules_0)" +"((need-compiled-submodule-rename?46_0)" +" need-compiled-submodule-rename?_0))" +"(compile-module-from-parsed34.1" +" force-linklet-directory?40_0" +" full-module-name39_0" +" modules-being-compiled43_0" +" need-compiled-submodule-rename?46_0" +" post-submodules45_0" +" pre-submodules44_0" +" serializable?41_0" +" to-source?42_0" +" p_35" +" cctx_16)))))))))))))))))))))" +"(define-values" +"(compile-module-from-parsed34.1)" +"(lambda(force-linklet-directory?17_0" +" full-module-name16_0" +" modules-being-compiled20_0" +" need-compiled-submodule-rename?23_0" +" post-submodules22_0" +" pre-submodules21_0" +" serializable?18_0" +" to-source?19_0" +" p32_0" +" cctx33_0)" +"(begin" +" 'compile-module-from-parsed34" +"(let-values(((p_25) p32_0))" +"(let-values(((cctx_17) cctx33_0))" +"(let-values(((full-module-name_2) full-module-name16_0))" +"(let-values(((force-linklet-directory?_1) force-linklet-directory?17_0))" +"(let-values(((serializable?_3) serializable?18_0))" +"(let-values(((to-source?_4) to-source?19_0))" +"(let-values(((modules-being-compiled_1) modules-being-compiled20_0))" +"(let-values(((pre-submodules_1) pre-submodules21_0))" +"(let-values(((post-submodules_1) post-submodules22_0))" +"(let-values(((need-compiled-submodule-rename?_1) need-compiled-submodule-rename?23_0))" +"(let-values()" +"(let-values()" +"(let-values(((enclosing-self_0)(compile-context-module-self cctx_17)))" +"(let-values(((self_24)(parsed-module-self p_25)))" +"(let-values(((requires_5)(parsed-module-requires p_25)))" +"(let-values(((provides_11)(parsed-module-provides p_25)))" +"(let-values(((encoded-root-expand-ctx-box_1)" +"(box(parsed-module-encoded-root-ctx p_25))))" +"(let-values(((body-context-simple?_0)(parsed-module-root-ctx-simple? p_25)))" +"(let-values(((language-info_2)" +"(filter-language-info" +"(syntax-property$1(parsed-s p_25) 'module-language))))" +"(let-values(((bodys_6)(parsed-module-body p_25)))" +"(let-values(((empty-result-for-module->namespace?_0) #f))" +"(let-values(((mpis_3)(make-module-path-index-table)))" +"(let-values(((body-cctx_0)" +"(let-values(((the-struct_58) cctx_17))" +"(if(compile-context? the-struct_58)" +"(let-values(((phase47_1) 0)" +"((self48_0) self_24)" +"((module-self49_0) self_24)" +"((full-module-name50_0)" +" full-module-name_2)" +"((lazy-syntax-literals?51_0) #t))" +"(compile-context1.1" +"(compile-context-namespace the-struct_58)" +" phase47_1" +" self48_0" +" module-self49_0" +" full-module-name50_0" +" lazy-syntax-literals?51_0" +"(compile-context-header the-struct_58)))" +"(raise-argument-error" +" 'struct-copy" +" \"compile-context?\"" +" the-struct_58)))))" +"(let-values(((cross-phase-persistent?_2) #f))" +"(let-values(((side-effects_0)(make-hasheqv)))" +"(let-values(((check-side-effects!_0)" +"(lambda(e_71" +" expected-results_3" +" phase_90" +" required-reference?_1)" +"(begin" +" 'check-side-effects!" +"(if(hash-ref side-effects_0 phase_90 #f)" +"(void)" +"(let-values()" +"(if(let-values(((required-reference?54_0)" +" required-reference?_1))" +"(any-side-effects?9.1" +" #f" +" #f" +" #f" +" #f" +" required-reference?54_0" +" #t" +" e_71" +" expected-results_3))" +"(let-values()" +"(hash-set!" +" side-effects_0" +" phase_90" +" #t))" +"(void))))))))" +"(let-values((()" +"(begin" +"(if(if need-compiled-submodule-rename?_1" +" modules-being-compiled_1" +" #f)" +"(let-values()" +"(begin" +"(if(null? post-submodules_1)" +"(void)" +"(let-values()" +"(error" +" \"internal error: have post submodules, but not already compiled\")))" +"(register-compiled-submodules" +" modules-being-compiled_1" +" pre-submodules_1" +" self_24)))" +"(void))" +"(values))))" +"(let-values(((body-linklets_2" +" min-phase_4" +" max-phase_4" +" phase-to-link-module-uses_4" +" phase-to-link-module-uses-expr_3" +" phase-to-link-extra-inspectorsss_2" +" syntax-literals_4" +" root-ctx-pos_0)" +"(let-values(((temp58_2)" +"(list" +"(list get-syntax-literal!-id)" +"(list set-transformer!-id)))" +"((temp59_2)" +"(list" +" empty-syntax-literals-instance" +" empty-module-body-instance))" +"((temp60_2) '((void)))" +"((temp61_0) '(0))" +"((encoded-root-expand-ctx-box62_0)" +" encoded-root-expand-ctx-box_1)" +"((body-context-simple?63_0)" +" body-context-simple?_0)" +"((check-side-effects!64_0)" +" check-side-effects!_0)" +"((temp65_0)" +"(lambda(body_4 cctx_18)" +"(if(parsed-#%declare? body_4)" +"(let-values()" +"(let-values(((ok?_26" +" _69_0" +" kw70_0)" +"(let-values(((s_388)" +"(parsed-s" +" body_4)))" +"(let-values(((orig-s_30)" +" s_388))" +"(let-values(((_69_1" +" kw70_1)" +"(let-values(((s_389)" +"(if(syntax?$1" +" s_388)" +"(syntax-e$1" +" s_388)" +" s_388)))" +"(if(pair?" +" s_389)" +"(let-values(((_71_0)" +"(let-values(((s_390)" +"(car" +" s_389)))" +" s_390))" +"((kw72_0)" +"(let-values(((s_34)" +"(cdr" +" s_389)))" +"(let-values(((s_391)" +"(if(syntax?$1" +" s_34)" +"(syntax-e$1" +" s_34)" +" s_34)))" +"(let-values(((flat-s_19)" +"(to-syntax-list.1" +" s_391)))" +"(if(not" +" flat-s_19)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_30))" +"(let-values()" +" flat-s_19)))))))" +"(values" +" _71_0" +" kw72_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_30)))))" +"(values" +" #t" +" _69_1" +" kw70_1))))))" +"(begin" +"(let-values(((lst_221)" +" kw70_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_221)))" +"((letrec-values(((for-loop_229)" +"(lambda(lst_272)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_272)" +"(let-values(((kw_0)" +"(unsafe-car" +" lst_272))" +"((rest_146)" +"(unsafe-cdr" +" lst_272)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(if(eq?" +"(syntax-e$1" +" kw_0)" +" '#:cross-phase-persistent)" +"(let-values()" +"(set! cross-phase-persistent?_2" +" #t))" +"(void))" +"(if(eq?" +"(syntax-e$1" +" kw_0)" +" '#:empty-namespace)" +"(let-values()" +"(begin" +"(set! empty-result-for-module->namespace?_0" +" #t)" +"(set-box!" +" encoded-root-expand-ctx-box_1" +" #f)))" +"(void))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_229" +" rest_146)" +"(values))))" +"(values))))))" +" for-loop_229)" +" lst_221)))" +"(void)" +" #f)))" +"(let-values() #f))))" +"((temp66_1)" +"(lambda(mod-name_17 phase_91)" +"(let-values(((ht_125)" +"(if modules-being-compiled_1" +"(hash-ref" +" modules-being-compiled_1" +" mod-name_17" +" #f)" +" #f)))" +"(if ht_125" +"(hash-ref" +" ht_125" +" phase_91" +" #f)" +" #f))))" +"((to-source?67_0) to-source?_4)" +"((serializable?68_0)" +" serializable?_3))" +"(compile-forms31.1" +" temp59_2" +" temp58_2" +" temp60_2" +" #t" +" check-side-effects!64_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" encoded-root-expand-ctx-box62_0" +" #t" +" temp61_0" +" #t" +" temp66_1" +" #t" +" temp65_0" +" #t" +" body-context-simple?63_0" +" #t" +" serializable?68_0" +" #t" +" to-source?67_0" +" #t" +" bodys_6" +" body-cctx_0" +" mpis_3))))" +"(let-values((()" +"(begin" +"(if modules-being-compiled_1" +"(let-values()" +"(hash-set!" +" modules-being-compiled_1" +"(1/module-path-index-resolve self_24)" +"(let-values(((ht_126)" +" body-linklets_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_126)))" +"((letrec-values(((for-loop_230)" +"(lambda(table_187" +" i_152)" +"(begin" +" 'for-loop" +"(if i_152" +"(let-values(((phase_92" +" linklet_7)" +"(hash-iterate-key+value" +" ht_126" +" i_152)))" +"(let-values(((table_188)" +"(let-values(((table_43)" +" table_187))" +"(let-values(((table_189)" +"(let-values()" +"(let-values(((key_72" +" val_64)" +"(let-values()" +"(values" +" phase_92" +"(module-linklet-info2.1" +" linklet_7" +"(hash-ref" +" phase-to-link-module-uses_4" +" phase_92" +" #f)" +" self_24" +" #f" +" #f" +"(if phase-to-link-extra-inspectorsss_2" +"(hash-ref" +" phase-to-link-extra-inspectorsss_2" +" phase_92" +" #f)" +" #f))))))" +"(hash-set" +" table_43" +" key_72" +" val_64)))))" +"(values" +" table_189)))))" +"(if(not" +" #f)" +"(for-loop_230" +" table_188" +"(hash-iterate-next" +" ht_126" +" i_152))" +" table_188)))" +" table_187)))))" +" for-loop_230)" +" '#hasheq()" +"(hash-iterate-first ht_126))))))" +"(void))" +"(values))))" +"(let-values(((declaration-linklet_0)" +"(if serializable?_3" +"((if to-source?_4" +" values" +"(lambda(s_198)" +"(let-values()" +"(1/compile-linklet" +" s_198" +" 'decl))))" +"(list" +" 'linklet" +"(list" +" deserialize-imports" +"(list mpi-vector-id))" +" '(self-mpi" +" requires" +" provides" +" phase-to-link-modules)" +"(list" +" 'define-values" +" '(self-mpi)" +"(add-module-path-index!" +" mpis_3" +" self_24))" +"(list" +" 'define-values" +" '(requires)" +"(let-values(((temp75_0) #f))" +"(generate-deserialize6.1" +" temp75_0" +" #t" +" requires_5" +" mpis_3)))" +"(list" +" 'define-values" +" '(provides)" +"(let-values(((temp78_1) #f))" +"(generate-deserialize6.1" +" temp78_1" +" #t" +" provides_11" +" mpis_3)))" +"(list" +" 'define-values" +" '(phase-to-link-modules)" +" phase-to-link-module-uses-expr_3)))" +" #f)))" +"(let-values(((syntax-literals-linklet_2)" +"(if(not" +"(syntax-literals-empty?" +" syntax-literals_4))" +"((if to-source?_4" +" values" +"(lambda(s_392)" +"(let-values()" +"(let-values(((linklet_8" +" new-keys_1)" +"(1/compile-linklet" +" s_392" +" 'syntax-literals" +"(vector" +" deserialize-instance" +" empty-top-syntax-literal-instance" +" empty-syntax-literals-data-instance" +" empty-instance-instance)" +"(lambda(inst_5)" +"(values" +" inst_5" +" #f))" +" serializable?_3)))" +" linklet_8))))" +"(list*" +" 'linklet" +"(list" +" deserialize-imports" +"(list mpi-vector-id)" +"(list*" +" deserialized-syntax-vector-id" +"(if serializable?_3" +"(list deserialize-syntax-id)" +" '()))" +" instance-imports)" +"(list*" +" get-syntax-literal!-id" +" '(get-encoded-root-expand-ctx))" +"(qq-append" +"(let-values(((temp82_0)" +"(not" +" serializable?_3)))" +"(generate-lazy-syntax-literals!9.1" +" temp82_0" +" #t" +" syntax-literals_4" +" mpis_3" +" self_24))" +"(list" +"(list" +" 'define-values" +" '(get-encoded-root-expand-ctx)" +"(if root-ctx-pos_0" +"(let-values()" +"(list" +" 'lambda" +" '()" +"(generate-lazy-syntax-literal-lookup" +" root-ctx-pos_0)))" +"(if empty-result-for-module->namespace?_0" +"(let-values() ''empty)" +"(let-values() ''#f))))))))" +" #f)))" +"(let-values(((syntax-literals-data-linklet_0)" +"(if serializable?_3" +"(if(not" +"(syntax-literals-empty?" +" syntax-literals_4))" +"((if to-source?_4" +" values" +"(lambda(s_86)" +"(let-values()" +"(1/compile-linklet" +" s_86" +" 'syntax-literals-data))))" +"(list*" +" 'linklet" +"(list" +" deserialize-imports" +"(list mpi-vector-id))" +"(list" +" deserialized-syntax-vector-id" +" deserialize-syntax-id)" +"(list" +" 'define-values" +"(list" +" deserialized-syntax-vector-id)" +"(list*" +" 'make-vector" +"(syntax-literals-count" +" syntax-literals_4)" +" '(#f)))" +"(let-values()" +"(generate-lazy-syntax-literals-data!" +" syntax-literals_4" +" mpis_3))))" +" #f)" +" #f)))" +"(let-values(((data-linklet_0)" +"(if serializable?_3" +"((if to-source?_4" +" values" +"(lambda(s_320)" +"(let-values()" +"(1/compile-linklet" +" s_320" +" 'data))))" +"(list" +" 'linklet" +"(list deserialize-imports)" +"(list mpi-vector-id)" +"(list*" +" 'define-values" +"(list inspector-id)" +" '((current-code-inspector)))" +"(list" +" 'define-values" +"(list mpi-vector-id)" +"(generate-module-path-index-deserialize" +" mpis_3))))" +" #f)))" +"(let-values(((bundle_1)" +"(let-values(((bundle_2)" +"(hash-set" +" body-linklets_2" +" 'name" +" full-module-name_2)))" +"(let-values(((bundle_3)" +"(hash-set" +" bundle_2" +" 'decl" +"(let-values(((or-part_258)" +" declaration-linklet_0))" +"(if or-part_258" +" or-part_258" +" 'in-memory)))))" +"(let-values(((bundle_4)" +"(if data-linklet_0" +"(hash-set" +" bundle_3" +" 'data" +" data-linklet_0)" +" bundle_3)))" +"(let-values(((bundle_5)" +"(if syntax-literals-linklet_2" +"(hash-set" +" bundle_4" +" 'stx" +" syntax-literals-linklet_2)" +" bundle_4)))" +"(let-values(((bundle_6)" +"(if syntax-literals-data-linklet_0" +"(hash-set" +" bundle_5" +" 'stx-data" +" syntax-literals-data-linklet_0)" +" bundle_5)))" +"(let-values(((bundle_7)" +"(if(null?" +" pre-submodules_1)" +" bundle_6" +"(hash-set" +" bundle_6" +" 'pre" +"(map2" +" car" +" pre-submodules_1)))))" +"(let-values(((bundle_8)" +"(if(null?" +" post-submodules_1)" +" bundle_7" +"(hash-set" +" bundle_7" +" 'post" +"(map2" +" car" +" post-submodules_1)))))" +"(let-values(((bundle_9)" +"(if cross-phase-persistent?_2" +"(hash-set" +" bundle_8" +" 'cross-phase-persistent?" +" #t)" +" bundle_8)))" +"(let-values(((bundle_10)" +"(if language-info_2" +"(hash-set" +" bundle_9" +" 'language-info" +" language-info_2)" +" bundle_9)))" +"(let-values(((bundle_11)" +"(if(zero?" +" min-phase_4)" +" bundle_10" +"(hash-set" +" bundle_10" +" 'min-phase" +" min-phase_4))))" +"(let-values(((bundle_12)" +"(if(zero?" +" max-phase_4)" +" bundle_11" +"(hash-set" +" bundle_11" +" 'max-phase" +" max-phase_4))))" +"(let-values(((bundle_13)" +"(if(hash-count" +" side-effects_0)" +"(hash-set" +" bundle_12" +" 'side-effects" +"(let-values(((temp83_0)" +"(hash-keys" +" side-effects_0))" +"((<84_0)" +" <))" +"(sort7.1" +" #f" +" #f" +" #f" +" #f" +" temp83_0" +" <84_0)))" +" bundle_12)))" +"(let-values(((bundle_14)" +"(if empty-result-for-module->namespace?_0" +"(hash-set" +" bundle_13" +" 'module->namespace" +" 'empty)" +" bundle_13)))" +"(1/hash->linklet-bundle" +" bundle_14))))))))))))))))" +"(let-values(((ld_4)" +"(if(if(null? pre-submodules_1)" +"(if(null?" +" post-submodules_1)" +"(not" +" force-linklet-directory?_1)" +" #f)" +" #f)" +"(let-values() bundle_1)" +"(let-values()" +"((if to-source?_4" +" values" +" 1/hash->linklet-directory)" +"(let-values(((lst_273)" +"(append" +" pre-submodules_1" +" post-submodules_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_273)))" +"((letrec-values(((for-loop_231)" +"(lambda(ht_127" +" lst_225)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_225)" +"(let-values(((sm_0)" +"(unsafe-car" +" lst_225))" +"((rest_147)" +"(unsafe-cdr" +" lst_225)))" +"(let-values(((ht_128)" +"(let-values(((ht_129)" +" ht_127))" +"(let-values(((ht_42)" +"(let-values()" +"(hash-set" +" ht_129" +"(car" +" sm_0)" +"((if to-source?_4" +" values" +" compiled-in-memory-linklet-directory)" +"(cdr" +" sm_0))))))" +"(values" +" ht_42)))))" +"(if(not" +" #f)" +"(for-loop_231" +" ht_128" +" rest_147)" +" ht_128)))" +" ht_127)))))" +" for-loop_231)" +"(hasheq #f bundle_1)" +" lst_273))))))))" +"(if to-source?_4" +"(let-values() ld_4)" +"(let-values()" +"(compiled-in-memory1.1" +" ld_4" +" self_24" +" requires_5" +" provides_11" +" phase-to-link-module-uses_4" +"(current-code-inspector)" +" phase-to-link-extra-inspectorsss_2" +"(mpis-as-vector mpis_3)" +"(syntax-literals-as-vector" +" syntax-literals_4)" +"(map2 cdr pre-submodules_1)" +"(map2 cdr post-submodules_1)" +" #f" +" #f)))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(update-submodule-names)" +"(lambda(cim_9 name_59 full-module-name_3)" +"(begin" +"(change-module-name" +" cim_9" +" name_59" +"(if(symbol? full-module-name_3)(list full-module-name_3)(reverse$1(cdr(reverse$1 full-module-name_3))))))))" +"(define-values" +"(register-compiled-submodules)" +"(lambda(modules-being-compiled_2 pre-submodules_2 self_25)" +"(begin" +"(begin" +"(let-values(((lst_154) pre-submodules_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_154)))" +"((letrec-values(((for-loop_232)" +"(lambda(lst_274)" +"(begin" +" 'for-loop" +"(if(pair? lst_274)" +"(let-values(((s_101)(unsafe-car lst_274))((rest_148)(unsafe-cdr lst_274)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((name_60)(car s_101)))" +"(let-values(((cim_10)(cdr s_101)))" +"(let-values(((phase-to-link-module-uses_5)" +"(compiled-in-memory-phase-to-link-module-uses" +" cim_10)))" +"(let-values(((ld_5)" +"(compiled-in-memory-linklet-directory" +" cim_10)))" +"(let-values(((sm-self_0)" +"(1/module-path-index-join" +"(list" +" 'submod" +" \".\"" +" name_60)" +" self_25)))" +"(let-values(((phase-to-extra-inspectorsss_0)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss" +" cim_10)))" +"(hash-set!" +" modules-being-compiled_2" +"(1/module-path-index-resolve" +" sm-self_0)" +"(let-values(((ht_130)" +"(1/linklet-bundle->hash" +"(if(1/linklet-directory?" +" ld_5)" +"(hash-ref" +"(1/linklet-directory->hash" +" ld_5)" +" #f)" +" ld_5))))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash ht_130)))" +"((letrec-values(((for-loop_233)" +"(lambda(table_154" +" i_153)" +"(begin" +" 'for-loop" +"(if i_153" +"(let-values(((phase_93" +" linklet_9)" +"(hash-iterate-key+value" +" ht_130" +" i_153)))" +"(let-values(((table_190)" +"(let-values(((table_191)" +" table_154))" +"(if(number?" +" phase_93)" +"(let-values(((table_156)" +" table_191))" +"(let-values(((table_192)" +"(let-values()" +"(let-values(((key_73" +" val_65)" +"(let-values()" +"(values" +" phase_93" +"(module-linklet-info2.1" +" linklet_9" +"(hash-ref" +" phase-to-link-module-uses_5" +" phase_93" +" #f)" +" self_25" +" #f" +"(compiled-in-memory-compile-time-inspector" +" cim_10)" +"(if phase-to-extra-inspectorsss_0" +"(hash-ref" +" phase-to-extra-inspectorsss_0" +" phase_93" +" #f)" +" #f))))))" +"(hash-set" +" table_156" +" key_73" +" val_65)))))" +"(values" +" table_192)))" +" table_191))))" +"(if(not" +" #f)" +"(for-loop_233" +" table_190" +"(hash-iterate-next" +" ht_130" +" i_153))" +" table_190)))" +" table_154)))))" +" for-loop_233)" +" '#hasheq()" +"(hash-iterate-first" +" ht_130))))))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_232 rest_148)(values))))" +"(values))))))" +" for-loop_232)" +" lst_154)))" +"(void)))))" +"(define-values" +"(filter-language-info)" +"(lambda(li_1)" +"(begin" +"(if(vector? li_1)" +"(if(= 3(vector-length li_1))" +"(if(1/module-path?(vector-ref li_1 0))(if(symbol?(vector-ref li_1 1)) li_1 #f) #f)" +" #f)" +" #f))))" +"(define-values" +"(1/compiled-expression-recompile)" +"(lambda(c_31)" +"(begin" +" 'compiled-expression-recompile" +"(begin" +"(if(1/compiled-expression? c_31)" +"(void)" +" (let-values () (raise-argument-error 'compiled-expression-recompile \"compiled-expression?\" c_31)))" +"(if(1/linklet-bundle? c_31)" +"(let-values()" +"(1/hash->linklet-bundle" +"(let-values(((ht_131)(1/linklet-bundle->hash c_31)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_131)))" +"((letrec-values(((for-loop_234)" +"(lambda(table_193 i_154)" +"(begin" +" 'for-loop" +"(if i_154" +"(let-values(((k_32 v_68)(hash-iterate-key+value ht_131 i_154)))" +"(let-values(((table_194)" +"(let-values(((table_195) table_193))" +"(let-values(((table_196)" +"(let-values()" +"(let-values(((key_28 val_18)" +"(let-values()" +"(if(1/linklet? v_68)" +"(let-values()" +"(values" +" k_32" +"(1/recompile-linklet" +" v_68)))" +"(let-values()" +"(values k_32 v_68))))))" +"(hash-set table_195 key_28 val_18)))))" +"(values table_196)))))" +"(if(not #f)" +"(for-loop_234 table_194(hash-iterate-next ht_131 i_154))" +" table_194)))" +" table_193)))))" +" for-loop_234)" +" '#hasheq()" +"(hash-iterate-first ht_131))))))" +"(if(1/linklet-directory? c_31)" +"(let-values()" +"(1/hash->linklet-directory" +"(let-values(((ht_132)(1/linklet-directory->hash c_31)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_132)))" +"((letrec-values(((for-loop_235)" +"(lambda(table_197 i_155)" +"(begin" +" 'for-loop" +"(if i_155" +"(let-values(((k_33 v_1)(hash-iterate-key+value ht_132 i_155)))" +"(let-values(((table_198)" +"(let-values(((table_199) table_197))" +"(let-values(((table_200)" +"(let-values()" +"(let-values(((key_74 val_66)" +"(let-values()" +"(if(1/compiled-expression?" +" v_1)" +"(let-values()" +"(values" +" k_33" +"(1/compiled-expression-recompile" +" v_1)))" +"(let-values()" +"(values k_33 v_1))))))" +"(hash-set table_199 key_74 val_66)))))" +"(values table_200)))))" +"(if(not #f)" +"(for-loop_235 table_198(hash-iterate-next ht_132 i_155))" +" table_198)))" +" table_197)))))" +" for-loop_235)" +" '#hasheq()" +"(hash-iterate-first ht_132))))))" +"(let-values() c_31)))))))" +"(define-values" +"(create-compiled-in-memorys-using-shared-data)" +"(lambda(tops_0 data-linklet_1 ns_58)" +"(begin" +"(let-values(((data-instance_5)" +"(1/instantiate-linklet" +" data-linklet_1" +"(list" +" deserialize-instance" +"(let-values(((ns1_0) ns_58)" +"((temp2_3)(namespace-phase ns_58))" +"((temp3_3)(namespace-mpi ns_58))" +"((temp4_2)(namespace-bulk-binding-registry ns_58))" +"((temp5_4)(current-code-inspector)))" +"(make-eager-instance-instance11.1 temp4_2 temp2_3 temp5_4 ns1_0 temp3_3))))))" +"(let-values(((data_0)(lambda(key_75)(begin 'data(1/instance-variable-value data-instance_5 key_75)))))" +"(let-values(((mpi-vector_0)(data_0 mpi-vector-id)))" +"(let-values(((mpi-vector-trees_0)(data_0 'mpi-vector-trees)))" +"(let-values(((phase-to-link-modules-vector_0)(data_0 'phase-to-link-modules-vector)))" +"(let-values(((phase-to-link-modules-trees_0)(data_0 'phase-to-link-modules-trees)))" +"(let-values(((syntax-literals_5)(data_0 'syntax-literals)))" +"(let-values(((syntax-literals-trees_1)(data_0 'syntax-literals-trees)))" +"(let-values(((namespace-scopes_0)(extract-namespace-scopes ns_58)))" +"(letrec-values(((construct-compiled-in-memory_0)" +"(lambda(ld_6" +" mpi-vector-tree_0" +" phase-to-link-modules-tree_0" +" syntax-literals-tree_0)" +"(begin" +" 'construct-compiled-in-memory" +"(let-values(((is-module?_0)" +"(let-values(((or-part_76)(1/linklet-bundle? ld_6)))" +"(if or-part_76" +" or-part_76" +"(let-values(((b_77)" +"(hash-ref" +"(1/linklet-directory->hash ld_6)" +" #f" +" #f)))" +"(if b_77" +"(hash-ref(1/linklet-bundle->hash b_77) 'decl #f)" +" #f))))))" +"(let-values(((mpi-pos-vec_0)(vector-ref mpi-vector-tree_0 0)))" +"(let-values(((syntax-literals-spec_0)" +"(vector-ref syntax-literals-tree_0 0)))" +"(let-values(((pres_0)" +"(if is-module?_0" +"(extract-submodules ld_6 'pre)" +"(compiled-top->compiled-tops ld_6))))" +"(let-values(((posts_0)" +"(if is-module?_0" +"(extract-submodules ld_6 'post)" +" null)))" +"(let-values(((map-construct-compiled-in-memory_0)" +"(lambda(l_66 vec-pos_0)" +"(begin" +" 'map-construct-compiled-in-memory" +"(reverse$1" +"(let-values(((lst_39) l_66)" +"((lst_263)" +"(vector-ref" +" mpi-vector-tree_0" +" vec-pos_0))" +"((lst_84)" +"(vector-ref" +" phase-to-link-modules-tree_0" +" vec-pos_0))" +"((lst_157)" +"(vector-ref" +" syntax-literals-tree_0" +" vec-pos_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_39)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_263)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_84)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_157)))" +"((letrec-values(((for-loop_236)" +"(lambda(fold-var_29" +" lst_264" +" lst_265" +" lst_24" +" lst_168)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_264)" +"(if(pair?" +" lst_265)" +"(if(pair?" +" lst_24)" +"(pair?" +" lst_168)" +" #f)" +" #f)" +" #f)" +"(let-values(((sub-ld_0)" +"(unsafe-car" +" lst_264))" +"((rest_140)" +"(unsafe-cdr" +" lst_264))" +"((mpi-vector-tree_1)" +"(unsafe-car" +" lst_265))" +"((rest_141)" +"(unsafe-cdr" +" lst_265))" +"((phase-to-link-modules-tree_1)" +"(unsafe-car" +" lst_24))" +"((rest_41)" +"(unsafe-cdr" +" lst_24))" +"((syntax-literals-tree_1)" +"(unsafe-car" +" lst_168))" +"((rest_35)" +"(unsafe-cdr" +" lst_168)))" +"(let-values(((fold-var_154)" +"(let-values(((fold-var_164)" +" fold-var_29))" +"(let-values(((fold-var_165)" +"(let-values()" +"(cons" +"(let-values()" +"(construct-compiled-in-memory_0" +" sub-ld_0" +" mpi-vector-tree_1" +" phase-to-link-modules-tree_1" +" syntax-literals-tree_1))" +" fold-var_164))))" +"(values" +" fold-var_165)))))" +"(if(not #f)" +"(for-loop_236" +" fold-var_154" +" rest_140" +" rest_141" +" rest_41" +" rest_35)" +" fold-var_154)))" +" fold-var_29)))))" +" for-loop_236)" +" null" +" lst_39" +" lst_263" +" lst_84" +" lst_157))))))))" +"(compiled-in-memory1.1" +" ld_6" +" #f" +" #f" +" #f" +"(vector-ref" +" phase-to-link-modules-vector_0" +"(vector-ref phase-to-link-modules-tree_0 0))" +" #f" +" '#hasheqv()" +"(let-values(((len_29)(vector-length mpi-pos-vec_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_29)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/vector" +" \"exact-nonnegative-integer?\"" +" len_29)))" +"(let-values(((v_181)(make-vector len_29 0)))" +"(begin" +"(if(zero? len_29)" +"(void)" +"(let-values()" +"(let-values(((vec_60 len_30)" +"(let-values(((vec_61)" +" mpi-pos-vec_0))" +"(begin" +"(check-vector vec_61)" +"(values" +" vec_61" +"(unsafe-vector-length" +" vec_61))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_27)" +"(lambda(i_156 pos_95)" +"(begin" +" 'for-loop" +"(if(unsafe-fx<" +" pos_95" +" len_30)" +"(let-values(((pos_99)" +"(unsafe-vector-ref" +" vec_60" +" pos_95)))" +"(let-values(((i_157)" +"(let-values(((i_158)" +" i_156))" +"(let-values(((i_90)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_181" +" i_158" +"(let-values()" +"(vector-ref" +" mpi-vector_0" +" pos_99)))" +"(unsafe-fx+" +" 1" +" i_158)))))" +"(values" +" i_90)))))" +"(if(if(not" +"((lambda x_72" +"(unsafe-fx=" +" i_157" +" len_29))" +" pos_99))" +"(not #f)" +" #f)" +"(for-loop_27" +" i_157" +"(unsafe-fx+" +" 1" +" pos_95))" +" i_157)))" +" i_156)))))" +" for-loop_27)" +" 0" +" 0)))))" +" v_181))))" +"(let-values(((len_31)(cdr syntax-literals-spec_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_31)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/vector" +" \"exact-nonnegative-integer?\"" +" len_31)))" +"(let-values(((v_182)(make-vector len_31 0)))" +"(begin" +"(if(zero? len_31)" +"(void)" +"(let-values()" +"(let-values(((start_38) 0)" +"((end_27)" +"(cdr syntax-literals-spec_0))" +"((inc_21) 1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range start_38 end_27 inc_21)))" +"((letrec-values(((for-loop_0)" +"(lambda(i_159 pos_12)" +"(begin" +" 'for-loop" +"(if(< pos_12 end_27)" +"(let-values(((i_160)" +" pos_12))" +"(let-values(((i_20)" +"(let-values(((i_161)" +" i_159))" +"(let-values(((i_34)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_182" +" i_161" +"(let-values()" +"(if syntax-literals_5" +"(vector-ref" +" syntax-literals_5" +"(+" +"(car" +" syntax-literals-spec_0)" +" i_160))" +" #f)))" +"(unsafe-fx+" +" 1" +" i_161)))))" +"(values" +" i_34)))))" +"(if(if(not" +"((lambda x_73" +"(unsafe-fx=" +" i_20" +" len_31))" +" i_160))" +"(not #f)" +" #f)" +"(for-loop_0" +" i_20" +"(+" +" pos_12" +" inc_21))" +" i_20)))" +" i_159)))))" +" for-loop_0)" +" 0" +" start_38)))))" +" v_182))))" +"(map-construct-compiled-in-memory_0 pres_0 1)" +"(map-construct-compiled-in-memory_0 posts_0 2)" +" namespace-scopes_0" +" #f)))))))))))" +"(map2" +" construct-compiled-in-memory_0" +" tops_0" +" mpi-vector-trees_0" +" phase-to-link-modules-trees_0" +" syntax-literals-trees_1))))))))))))))" +"(define-values" +"(extract-submodules)" +"(lambda(ld_7 names-key_0)" +"(begin" +"(if(1/linklet-bundle? ld_7)" +"(let-values() null)" +"(let-values()" +"(let-values(((h_10)(1/linklet-directory->hash ld_7)))" +"(let-values(((mod_3)(hash-ref h_10 #f #f)))" +" (let-values ((() (begin (if mod_3 (void) (let-values () (error \"missing main module\"))) (values))))" +"(let-values(((mh_0)(1/linklet-bundle->hash mod_3)))" +"(let-values(((names_2)(hash-ref mh_0 names-key_0 null)))" +"(reverse$1" +"(let-values(((lst_22) names_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_22)))" +"((letrec-values(((for-loop_179)" +"(lambda(fold-var_76 lst_159)" +"(begin" +" 'for-loop" +"(if(pair? lst_159)" +"(let-values(((name_61)(unsafe-car lst_159))" +"((rest_149)(unsafe-cdr lst_159)))" +"(let-values(((fold-var_8)" +"(let-values(((fold-var_219) fold-var_76))" +"(let-values(((fold-var_155)" +"(let-values()" +"(cons" +"(let-values()" +"(hash-ref" +" h_10" +" name_61" +"(lambda()" +"(error" +" \"missing submodule declaration:\"" +" name_61))))" +" fold-var_219))))" +"(values fold-var_155)))))" +"(if(not #f)(for-loop_179 fold-var_8 rest_149) fold-var_8)))" +" fold-var_76)))))" +" for-loop_179)" +" null" +" lst_22))))))))))))))" +"(define-values" +"(eval-single-top)" +"(lambda(c_31 ns_41)(begin(let-values(((temp20_1) #t))(eval-one-top15.1 temp20_1 #t c_31 ns_41 #f #f)))))" +"(define-values" +"(compiled-multiple-top?)" +"(lambda(c_35)" +"(begin" +"(let-values(((ld_3)(if(compiled-in-memory? c_35)(compiled-in-memory-linklet-directory c_35) c_35)))" +"(if(1/linklet-directory? ld_3)(not(hash-ref(1/linklet-directory->hash ld_3) #f #f)) #f)))))" +"(define-values" +"(eval-top)" +"(let-values(((eval-top7_0)" +"(lambda(c5_0 ns6_0 eval-compiled1_0 as-tail?2_0 eval-compiled3_0 as-tail?4_0)" +"(begin" +" 'eval-top7" +"(let-values(((c_47) c5_0))" +"(let-values(((ns_66) ns6_0))" +"(let-values(((eval-compiled_0)(if eval-compiled3_0 eval-compiled1_0 eval-top)))" +"(let-values(((as-tail?_0)(if as-tail?4_0 as-tail?2_0 #t)))" +"(let-values()" +"(if(compiled-multiple-top? c_47)" +"(eval-multiple-tops c_47 ns_66 eval-compiled_0 as-tail?_0)" +"(let-values(((c21_0) c_47)((ns22_0) ns_66)((as-tail?23_0) as-tail?_0))" +"(eval-one-top15.1 #f #f c21_0 ns22_0 as-tail?23_0 #t))))))))))))" +"(case-lambda" +"((c_48 ns_67)(begin(eval-top7_0 c_48 ns_67 #f #f #f #f)))" +"((c_49 ns_68 eval-compiled_1 as-tail?2_1)(eval-top7_0 c_49 ns_68 eval-compiled_1 as-tail?2_1 #t #t))" +"((c_50 ns_69 eval-compiled1_1)(eval-top7_0 c_50 ns_69 eval-compiled1_1 #f #t #f)))))" +"(define-values" +"(eval-multiple-tops)" +"(lambda(c_38 ns_70 eval-compiled_2 as-tail?_1)" +"(begin" +"(let-values(((eval-compiled-parts_0)" +"(lambda(l_67)" +"(begin" +" 'eval-compiled-parts" +"((letrec-values(((loop_92)" +"(lambda(l_68)" +"(begin" +" 'loop" +"(if(null? l_68)" +"(let-values() void)" +"(if(null?(cdr l_68))" +"(let-values()(eval-compiled_2(car l_68) ns_70 as-tail?_1))" +"(let-values()" +"(begin" +"(eval-compiled_2(car l_68) ns_70 #f)" +"(loop_92(cdr l_68))))))))))" +" loop_92)" +" l_67)))))" +"(if(compiled-in-memory? c_38)" +"(let-values()(eval-compiled-parts_0(compiled-in-memory-pre-compiled-in-memorys c_38)))" +"(let-values(((c1_26)(hash-ref(1/linklet-directory->hash c_38) 'data #f)))" +"(if c1_26" +"((lambda(data-ld_0)" +"(eval-compiled-parts_0" +"(create-compiled-in-memorys-using-shared-data" +"(compiled-top->compiled-tops c_38)" +"(hash-ref(1/linklet-bundle->hash(hash-ref(1/linklet-directory->hash data-ld_0) #f)) 0)" +" ns_70)))" +" c1_26)" +"(let-values()(eval-compiled-parts_0(compiled-top->compiled-tops c_38))))))))))" +"(define-values" +"(eval-one-top15.1)" +"(lambda(single-expression?9_0 single-expression?10_0 c13_0 ns14_1 as-tail?11_0 as-tail?12_0)" +"(begin" +" 'eval-one-top15" +"(let-values(((c_51) c13_0))" +"(let-values(((ns_71) ns14_1))" +"(let-values(((as-tail?_2)(if as-tail?12_0 as-tail?11_0 #t)))" +"(let-values(((single-expression?_1)(if single-expression?10_0 single-expression?9_0 #f)))" +"(let-values()" +"(let-values()" +"(let-values(((ld_8)" +"(if(compiled-in-memory? c_51)(compiled-in-memory-linklet-directory c_51) c_51)))" +"(let-values(((h_11)(1/linklet-bundle->hash(hash-ref(1/linklet-directory->hash ld_8) #f))))" +"(let-values(((link-instance_0)" +"(if(compiled-in-memory? c_51)" +"(link-instance-from-compiled-in-memory" +" c_51" +"(if(not single-expression?_1) ns_71 #f))" +"(1/instantiate-linklet" +"(hash-ref h_11 'link)" +"(list" +" deserialize-instance" +"(let-values(((ns24_0) ns_71)" +"((temp25_4)(namespace-phase ns_71))" +"((temp26_2)(namespace-mpi ns_71))" +"((temp27_4)(namespace-bulk-binding-registry ns_71))" +"((temp28_2)(current-code-inspector)))" +"(make-eager-instance-instance11.1" +" temp27_4" +" temp25_4" +" temp28_2" +" ns24_0" +" temp26_2)))))))" +"(let-values(((orig-phase_1)(hash-ref h_11 'original-phase)))" +"(let-values(((max-phase_5)(hash-ref h_11 'max-phase)))" +"(let-values(((phase-shift_18)(phase-(namespace-phase ns_71) orig-phase_1)))" +"(let-values(((extra-inspector_7)" +"(if(compiled-in-memory? c_51)" +"(compiled-in-memory-compile-time-inspector c_51)" +" #f)))" +"(let-values(((phase-to-link-extra-inspectorsss_3)" +"(if(compiled-in-memory? c_51)" +"(compiled-in-memory-phase-to-link-extra-inspectorsss c_51)" +" '#hasheqv())))" +"(let-values(((phase-to-link-modules_1)" +"(if(compiled-in-memory? c_51)" +"(compiled-in-memory-phase-to-link-module-uses c_51)" +"(1/instance-variable-value link-instance_0 'phase-to-link-modules))))" +"(let-values(((thunk_3)" +"(let-values(((start_39) max-phase_5)" +"((end_28)(sub1 orig-phase_1))" +"((inc_22) -1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_39 end_28 inc_22)))" +"((letrec-values(((for-loop_181)" +"(lambda(prev-thunk_0 pos_100)" +"(begin" +" 'for-loop" +"(if(> pos_100 end_28)" +"(let-values(((phase_94) pos_100))" +"(let-values(((prev-thunk_1)" +"(let-values(((prev-thunk_2)" +" prev-thunk_0))" +"(let-values(((prev-thunk_3)" +"(let-values()" +"(let-values((()" +"(begin" +"(prev-thunk_2" +" #f)" +"(values))))" +"(let-values(((module-uses_1)" +"(hash-ref" +" phase-to-link-modules_1" +" phase_94" +" null)))" +"(let-values(((import-module-instances_2" +" import-instances_1)" +"(let-values(((mis_6" +" is_5)" +"(let-values(((lst_9)" +" module-uses_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_9)))" +"((letrec-values(((for-loop_1)" +"(lambda(mis_7" +" is_6" +" lst_158)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_158)" +"(let-values(((mu_9)" +"(unsafe-car" +" lst_158))" +"((rest_150)" +"(unsafe-cdr" +" lst_158)))" +"(let-values(((mis_8" +" is_7)" +"(let-values(((mis_9)" +" mis_7)" +"((is_8)" +" is_6))" +"(let-values(((mis_10" +" is_9)" +"(let-values()" +"(let-values(((mis29_0" +" is30_0)" +"(let-values()" +"(let-values(((temp33_1)" +"(phase-" +"(phase+" +" phase_94" +" phase-shift_18)" +"(module-use-phase" +" mu_9))))" +"(namespace-module-use->module+linklet-instances146.1" +" temp33_1" +" #f" +" #f" +" #f" +" #f" +" ns_71" +" mu_9)))))" +"(values" +"(cons" +" mis29_0" +" mis_9)" +"(cons" +" is30_0" +" is_8))))))" +"(values" +" mis_10" +" is_9)))))" +"(if(not" +" #f)" +"(for-loop_1" +" mis_8" +" is_7" +" rest_150)" +"(values" +" mis_8" +" is_7))))" +"(values" +" mis_7" +" is_6))))))" +" for-loop_1)" +" null" +" null" +" lst_9)))))" +"(values" +"(reverse$1" +" mis_6)" +"(reverse$1" +" is_5)))))" +"(let-values(((phase-ns_0)" +"(namespace->namespace-at-phase" +" ns_71" +"(phase+" +" phase_94" +" phase-shift_18))))" +"(let-values(((inst_6)" +"(if single-expression?_1" +" link-instance_0" +"(let-values(((phase-ns34_0)" +" phase-ns_0)" +"((phase-shift35_0)" +" phase-shift_18)" +"((temp36_3)" +"(namespace-mpi" +" ns_71))" +"((temp37_1)" +"(namespace-inspector" +" ns_71))" +"((temp38_1)" +"(namespace-bulk-binding-registry" +" ns_71))" +"((temp39_3)" +"(lambda(name_62" +" val_67)" +"(namespace-set-transformer!" +" ns_71" +"(phase+" +"(sub1" +" phase_94)" +" phase-shift_18)" +" name_62" +" val_67))))" +"(make-instance-instance13.1" +" temp38_1" +" temp37_1" +" phase-ns34_0" +" phase-shift35_0" +" temp36_3" +" temp39_3)))))" +"(let-values(((linklet_10)" +"(hash-ref" +" h_11" +" phase_94" +" #f)))" +"(if linklet_10" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((temp41_2)" +" 3)" +"((module-uses42_0)" +" module-uses_1)" +"((import-module-instances43_0)" +" import-module-instances_2)" +"((temp44_1)" +"(current-code-inspector))" +"((extra-inspector45_1)" +" extra-inspector_7)" +"((temp46_1)" +"(hash-ref" +" phase-to-link-extra-inspectorsss_3" +" phase_94" +" #f)))" +"(check-require-access9.1" +" temp41_2" +" linklet_10" +" module-uses42_0" +" import-module-instances43_0" +" temp44_1" +" extra-inspector45_1" +" temp46_1))" +"(values))))" +"(let-values(((instantiate_0)" +"(lambda(tail?_49)" +"(begin" +" 'instantiate" +"(1/instantiate-linklet" +" linklet_10" +"(list*" +" top-level-instance" +" link-instance_0" +" inst_6" +" import-instances_1)" +"(namespace->instance" +" ns_71" +"(phase-" +"(phase+" +" phase_94" +" phase-shift_18)" +"(namespace-0-phase" +" ns_71)))" +"(not" +" tail?_49))))))" +"(if(zero-phase?" +" phase_94)" +"(let-values()" +" instantiate_0)" +"(if single-expression?_1" +"(let-values()" +"(lambda(tail?_50)" +"(begin" +" 'prev-thunk" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" phase-ns_0)" +"(let-values()" +"(instantiate_0" +" tail?_50))))))" +"(let-values()" +"(let-values(((ns-1_1)" +"(namespace->namespace-at-phase" +" phase-ns_0" +"(sub1" +" phase_94))))" +"(lambda(tail?_51)" +"(begin" +" 'prev-thunk" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-expand-context" +"(let-values(((ns-147_0)" +" ns-1_1))" +"(make-expand-context10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns-147_0))" +" 1/current-namespace" +" phase-ns_0)" +"(let-values()" +"(instantiate_0" +" tail?_51))))))))))))" +"(let-values()" +" void)))))))))))" +"(values" +" prev-thunk_3)))))" +"(if(not #f)" +"(for-loop_181" +" prev-thunk_1" +"(+ pos_100 inc_22))" +" prev-thunk_1)))" +" prev-thunk_0)))))" +" for-loop_181)" +" void" +" start_39)))))" +"(thunk_3 as-tail?_2))))))))))))))))))))" +"(define-values" +"(link-instance-from-compiled-in-memory)" +"(lambda(cim_11 to-ns_0)" +"(begin" +"(let-values(((orig-syntax-literals_0)(compiled-in-memory-syntax-literals cim_11)))" +"(let-values(((syntax-literals_6)" +"(if(not to-ns_0)" +"(let-values() orig-syntax-literals_0)" +"(if(namespace-scopes=?" +"(compiled-in-memory-namespace-scopes cim_11)" +"(extract-namespace-scopes to-ns_0))" +"(let-values() orig-syntax-literals_0)" +"(let-values()" +"(let-values(((len_32)(vector-length orig-syntax-literals_0)))" +"(begin" +"(if(exact-nonnegative-integer? len_32)" +"(void)" +"(let-values()" +" (raise-argument-error 'for/vector \"exact-nonnegative-integer?\" len_32)))" +"(let-values(((v_183)(make-vector len_32 0)))" +"(begin" +"(if(zero? len_32)" +"(void)" +"(let-values()" +"(let-values(((vec_62 len_33)" +"(let-values(((vec_63) orig-syntax-literals_0))" +"(begin" +"(check-vector vec_63)" +"(values vec_63(unsafe-vector-length vec_63))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_6)" +"(lambda(i_30 pos_101)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_101 len_33)" +"(let-values(((s_393)" +"(unsafe-vector-ref vec_62 pos_101)))" +"(let-values(((i_162)" +"(let-values(((i_163) i_30))" +"(let-values(((i_164)" +"(let-values()" +"(begin" +"(unsafe-vector*-set!" +" v_183" +" i_163" +"(let-values()" +"(swap-top-level-scopes" +" s_393" +"(compiled-in-memory-namespace-scopes" +" cim_11)" +" to-ns_0)))" +"(unsafe-fx+" +" 1" +" i_163)))))" +"(values i_164)))))" +"(if(if(not" +"((lambda x_74" +"(unsafe-fx= i_162 len_32))" +" s_393))" +"(not #f)" +" #f)" +"(for-loop_6 i_162(unsafe-fx+ 1 pos_101))" +" i_162)))" +" i_30)))))" +" for-loop_6)" +" 0" +" 0)))))" +" v_183)))))))))" +"(1/make-instance" +" 'link" +" #f" +" 'constant" +" mpi-vector-id" +"(compiled-in-memory-mpis cim_11)" +" syntax-literals-id" +" syntax-literals_6))))))" +"(define-values(not-available)(gensym 'not-available))" +"(define-values(get-not-available)(lambda()(begin not-available)))" +"(define-values" +"(can-direct-eval?)" +"(lambda(p_41 ns_41)" +"(begin" +"(if(parsed-app? p_41)" +"(let-values()" +"(if(can-direct-eval?(parsed-app-rator p_41) ns_41)" +"(let-values(((lst_71)(parsed-app-rands p_41)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_71)))" +"((letrec-values(((for-loop_90)" +"(lambda(result_70 lst_72)" +"(begin" +" 'for-loop" +"(if(pair? lst_72)" +"(let-values(((r_42)(unsafe-car lst_72))((rest_33)(unsafe-cdr lst_72)))" +"(let-values(((result_62)" +"(let-values()" +"(let-values(((result_108)" +"(let-values()" +"(let-values()" +"(can-direct-eval? r_42 ns_41)))))" +"(values result_108)))))" +"(if(if(not((lambda x_75(not result_62)) r_42))(not #f) #f)" +"(for-loop_90 result_62 rest_33)" +" result_62)))" +" result_70)))))" +" for-loop_90)" +" #t" +" lst_71)))" +" #f))" +"(if(parsed-id? p_41)" +"(let-values()(not(eq?(get-id-value p_41 ns_41) not-available)))" +"(if(parsed-quote? p_41)" +"(let-values() #t)" +"(if(parsed-quote-syntax? p_41)(let-values() #t)(let-values() #f))))))))" +"(define-values" +"(direct-eval)" +"(lambda(p_34 ns_66)" +"(begin" +"(if(parsed-app? p_34)" +"(let-values()" +"(apply" +"(direct-eval(parsed-app-rator p_34) ns_66)" +"(reverse$1" +"(let-values(((lst_219)(parsed-app-rands p_34)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_219)))" +"((letrec-values(((for-loop_237)" +"(lambda(fold-var_220 lst_261)" +"(begin" +" 'for-loop" +"(if(pair? lst_261)" +"(let-values(((r_43)(unsafe-car lst_261))((rest_138)(unsafe-cdr lst_261)))" +"(let-values(((fold-var_217)" +"(let-values(((fold-var_30) fold-var_220))" +"(let-values(((fold-var_218)" +"(let-values()" +"(cons" +"(let-values()(direct-eval r_43 ns_66))" +" fold-var_30))))" +"(values fold-var_218)))))" +"(if(not #f)(for-loop_237 fold-var_217 rest_138) fold-var_217)))" +" fold-var_220)))))" +" for-loop_237)" +" null" +" lst_219))))))" +"(if(parsed-id? p_34)" +"(let-values()(get-id-value p_34 ns_66))" +"(if(parsed-quote? p_34)" +"(let-values()(parsed-quote-datum p_34))" +"(if(parsed-quote-syntax? p_34)(let-values()(parsed-quote-syntax-datum p_34))(let-values() #f))))))))" +"(define-values" +"(get-id-value)" +"(lambda(p_43 ns_72)" +"(begin" +"(let-values(((b_26)(parsed-id-binding p_43)))" +"(if(parsed-primitive-id? p_43)" +"(let-values()(hash-ref(1/primitive-table '#%kernel)(module-binding-sym b_26) get-not-available))" +"(if(let-values(((or-part_259)(parsed-top-id? p_43)))" +"(if or-part_259" +" or-part_259" +"(let-values(((or-part_160)(not b_26)))" +"(if or-part_160 or-part_160(eq?(namespace-mpi ns_72)(module-binding-module b_26))))))" +"(let-values()" +"(namespace-get-variable" +" ns_72" +"(if b_26(module-binding-phase b_26)(namespace-phase ns_72))" +"(if b_26(module-binding-sym b_26)(syntax-e$1(parsed-s p_43)))" +" get-not-available))" +"(let-values()" +"(let-values(((mi_18)" +"(let-values(((ns1_1) ns_72)" +"((temp2_4)(1/module-path-index-resolve(module-binding-module b_26)))" +"((temp3_4)(phase-(namespace-phase ns_72)(module-binding-phase b_26))))" +"(namespace->module-instance70.1 #f #f #f #f #f #f ns1_1 temp2_4 temp3_4))))" +"(if(not mi_18)" +"(let-values() not-available)" +"(if(check-single-require-access" +" mi_18" +"(module-binding-phase b_26)" +"(module-binding-sym b_26)" +"(module-binding-extra-inspector b_26))" +"(let-values()" +"(namespace-get-variable" +"(module-instance-namespace mi_18)" +"(module-binding-phase b_26)" +"(module-binding-sym b_26)" +" get-not-available))" +"(let-values() not-available)))))))))))" +"(define-values(runtime-scope)(new-multi-scope))" +"(define-values(runtime-stx)(add-scope empty-syntax runtime-scope))" +"(define-values(runtime-module-name)(1/make-resolved-module-path '#%runtime))" +"(define-values(runtime-mpi)(1/module-path-index-join ''#%runtime #f))" +"(define-values" +"(add-runtime-primitive!)" +"(lambda(sym_60)" +"(begin" +"(let-values(((temp1_3)(syntax-scope-set runtime-stx 0))" +"((sym2_0) sym_60)" +"((temp3_5)" +"(let-values(((runtime-mpi4_0) runtime-mpi)((temp5_5) 0)((sym6_1) sym_60))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" runtime-mpi4_0" +" temp5_5" +" sym6_1))))" +"(add-binding-in-scopes!20.1 #f #f temp1_3 sym2_0 temp3_5)))))" +"(void" +"(begin" +"(add-runtime-primitive! 'values)" +"(add-runtime-primitive! 'cons)" +"(add-runtime-primitive! 'list)" +"(add-runtime-primitive! 'make-struct-type)" +"(add-runtime-primitive! 'make-struct-type-property)" +"(add-runtime-primitive! 'gensym)" +"(add-runtime-primitive! 'string->uninterned-symbol)))" +"(define-values" +"(runtime-instances)" +" '(#%kernel #%paramz #%foreign #%unsafe #%flfxnum #%extfl #%network #%place #%futures))" +"(define-values(box-cons!)(lambda(b_16 v_68)(begin(set-box! b_16(cons v_68(unbox b_16))))))" +"(define-values(box-clear!)(lambda(b_17)(begin(begin0(reverse$1(unbox b_17))(set-box! b_17 null)))))" +"(define-values" +"(struct:lift-context lift-context1.1 lift-context? lift-context-convert lift-context-lifts lift-context-module*-ok?)" +"(let-values(((struct:_68 make-_68 ?_68 -ref_68 -set!_68)" +"(let-values()" +"(let-values()" +"(make-struct-type 'lift-context #f 3 0 #f null(current-inspector) #f '(0 1 2) #f 'lift-context)))))" +"(values" +" struct:_68" +" make-_68" +" ?_68" +"(make-struct-field-accessor -ref_68 0 'convert)" +"(make-struct-field-accessor -ref_68 1 'lifts)" +"(make-struct-field-accessor -ref_68 2 'module*-ok?))))" +"(define-values" +"(struct:lifted-bind lifted-bind2.1 lifted-bind? lifted-bind-ids lifted-bind-keys lifted-bind-rhs)" +"(let-values(((struct:_69 make-_69 ?_69 -ref_69 -set!_69)" +"(let-values()" +"(let-values()" +"(make-struct-type 'lifted-bind #f 3 0 #f null(current-inspector) #f '(0 1 2) #f 'lifted-bind)))))" +"(values" +" struct:_69" +" make-_69" +" ?_69" +"(make-struct-field-accessor -ref_69 0 'ids)" +"(make-struct-field-accessor -ref_69 1 'keys)" +"(make-struct-field-accessor -ref_69 2 'rhs))))" +"(define-values" +"(make-lift-context6.1)" +"(lambda(module*-ok?3_0 module*-ok?4_0 convert5_0)" +"(begin" +" 'make-lift-context6" +"(let-values(((convert_0) convert5_0))" +"(let-values(((module*-ok?_0)(if module*-ok?4_0 module*-ok?3_0 #f)))" +"(let-values()(lift-context1.1 convert_0(box null) module*-ok?_0)))))))" +"(define-values" +"(add-lifted!)" +"(lambda(lifts_1 ids_16 rhs_12 phase_95)" +"(begin" +"(let-values(((lifted-ids_0 lifted_0)((lift-context-convert lifts_1) ids_16 rhs_12 phase_95)))" +"(begin(box-cons!(lift-context-lifts lifts_1) lifted_0) lifted-ids_0)))))" +"(define-values(get-and-clear-lifts!)(lambda(lifts_2)(begin(box-clear!(lift-context-lifts lifts_2)))))" +"(define-values" +"(make-local-lift)" +"(lambda(lift-env_1 counter_3)" +"(begin" +"(lambda(ids_17 rhs_13 phase_96)" +"(let-values(((keys_2)" +"(reverse$1" +"(let-values(((lst_275) ids_17))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_275)))" +"((letrec-values(((for-loop_238)" +"(lambda(fold-var_221 lst_276)" +"(begin" +" 'for-loop" +"(if(pair? lst_276)" +"(let-values(((id_54)(unsafe-car lst_276))" +"((rest_151)(unsafe-cdr lst_276)))" +"(let-values(((fold-var_80)" +"(let-values(((fold-var_81) fold-var_221))" +"(let-values(((fold-var_222)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((key_76)" +"(let-values(((id32_1)" +" id_54)" +"((phase33_1)" +" phase_96)" +"((counter34_1)" +" counter_3))" +"(add-local-binding!35.1" +" #f" +" #f" +" #f" +" #f" +" id32_1" +" phase33_1" +" counter34_1))))" +"(begin" +"(set-box!" +" lift-env_1" +"(hash-set" +"(unbox lift-env_1)" +" key_76" +" variable))" +" key_76)))" +" fold-var_81))))" +"(values fold-var_222)))))" +"(if(not #f)(for-loop_238 fold-var_80 rest_151) fold-var_80)))" +" fold-var_221)))))" +" for-loop_238)" +" null" +" lst_275))))))" +"(values ids_17(lifted-bind2.1 ids_17 keys_2 rhs_13)))))))" +"(define-values" +"(make-top-level-lift)" +"(lambda(ctx_11)" +"(begin" +"(lambda(ids_18 rhs_14 phase_69)" +"(let-values(((post-scope_0)" +"(root-expand-context-post-expansion-scope" +"(namespace-get-root-expand-ctx(expand-context-namespace ctx_11)))))" +"(let-values(((tl-ids_1)" +"(reverse$1" +"(let-values(((lst_267) ids_18))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_267)))" +"((letrec-values(((for-loop_225)" +"(lambda(fold-var_223 lst_178)" +"(begin" +" 'for-loop" +"(if(pair? lst_178)" +"(let-values(((id_56)(unsafe-car lst_178))" +"((rest_152)(unsafe-cdr lst_178)))" +"(let-values(((fold-var_224)" +"(let-values(((fold-var_225) fold-var_223))" +"(let-values(((fold-var_226)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_56" +" post-scope_0))" +" fold-var_225))))" +"(values fold-var_226)))))" +"(if(not #f)" +"(for-loop_225 fold-var_224 rest_152)" +" fold-var_224)))" +" fold-var_223)))))" +" for-loop_225)" +" null" +" lst_267))))))" +"(let-values(((syms_20)(select-defined-syms-and-bind!/ctx tl-ids_1 ctx_11)))" +"(values tl-ids_1(lifted-bind2.1 tl-ids_1 syms_20 rhs_14)))))))))" +"(define-values" +"(wrap-lifts-as-let)" +"(lambda(lifts_3 body_5 phase_97)" +"(begin" +"(datum->syntax$1" +" #f" +"(let-values(((lst_277)(reverse$1 lifts_3)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_277)))" +"((letrec-values(((for-loop_239)" +"(lambda(body_6 lst_185)" +"(begin" +" 'for-loop" +"(if(pair? lst_185)" +"(let-values(((lift_0)(unsafe-car lst_185))((rest_98)(unsafe-cdr lst_185)))" +"(let-values(((body_7)" +"(let-values(((body_8) body_6))" +"(let-values(((body_9)" +"(let-values()" +"(begin" +"(if(lifted-bind? lift_0)" +"(void)" +"(let-values()" +" (error \"non-bindings in `lift-context`\")))" +"(list" +"(datum->syntax$1" +"(syntax-shift-phase-level$1 core-stx phase_97)" +" 'let-values)" +"(list" +"(list" +"(lifted-bind-ids lift_0)" +"(lifted-bind-rhs lift_0)))" +" body_8)))))" +"(values body_9)))))" +"(if(not #f)(for-loop_239 body_7 rest_98) body_7)))" +" body_6)))))" +" for-loop_239)" +" body_5" +" lst_277)))))))" +"(define-values" +"(wrap-lifts-as-begin16.1)" +"(lambda(adjust-body10_0 adjust-body12_0 adjust-form9_0 adjust-form11_0 lifts13_0 body14_0 phase15_0)" +"(begin" +" 'wrap-lifts-as-begin16" +"(let-values(((lifts_4) lifts13_0))" +"(let-values(((body_10) body14_0))" +"(let-values(((phase_98) phase15_0))" +"(let-values(((adjust-form_0)(if adjust-form11_0 adjust-form9_0 values)))" +"(let-values(((adjust-body_0)(if adjust-body12_0 adjust-body10_0 values)))" +"(let-values()" +"(datum->syntax$1" +" #f" +"(cons" +"(datum->syntax$1(syntax-shift-phase-level$1 core-stx phase_98) 'begin)" +"(append" +"(reverse$1" +"(let-values(((lst_278) lifts_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_278)))" +"((letrec-values(((for-loop_184)" +"(lambda(fold-var_227 lst_279)" +"(begin" +" 'for-loop" +"(if(pair? lst_279)" +"(let-values(((lift_1)(unsafe-car lst_279))" +"((rest_153)(unsafe-cdr lst_279)))" +"(let-values(((fold-var_3)" +"(let-values(((fold-var_88) fold-var_227))" +"(let-values(((fold-var_228)" +"(let-values()" +"(cons" +"(let-values()" +"(adjust-form_0" +"(if(lifted-bind? lift_1)" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list" +"(datum->syntax$1" +"(syntax-shift-phase-level$1" +" core-stx" +" phase_98)" +" 'define-values)" +"(lifted-bind-ids lift_1)" +"(lifted-bind-rhs" +" lift_1))))" +"(let-values() lift_1))))" +" fold-var_88))))" +"(values fold-var_228)))))" +"(if(not #f)(for-loop_184 fold-var_3 rest_153) fold-var_3)))" +" fold-var_227)))))" +" for-loop_184)" +" null" +" lst_278))))" +"(list(adjust-body_0 body_10))))))))))))))" +"(define-values" +"(get-lifts-as-lists)" +"(lambda(lifts_5)" +"(begin" +"(reverse$1" +"(let-values(((lst_280) lifts_5))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_280)))" +"((letrec-values(((for-loop_240)" +"(lambda(fold-var_181 lst_281)" +"(begin" +" 'for-loop" +"(if(pair? lst_281)" +"(let-values(((lift_2)(unsafe-car lst_281))((rest_154)(unsafe-cdr lst_281)))" +"(let-values(((fold-var_229)" +"(let-values(((fold-var_230) fold-var_181))" +"(let-values(((fold-var_231)" +"(let-values()" +"(cons" +"(let-values()" +"(list" +"(lifted-bind-ids lift_2)" +"(lifted-bind-keys lift_2)" +"(lifted-bind-rhs lift_2)))" +" fold-var_230))))" +"(values fold-var_231)))))" +"(if(not #f)(for-loop_240 fold-var_229 rest_154) fold-var_229)))" +" fold-var_181)))))" +" for-loop_240)" +" null" +" lst_280)))))))" +"(define-values" +"(struct:module-lift-context" +" module-lift-context19.1" +" module-lift-context?" +" module-lift-context-wrt-phase" +" module-lift-context-lifts" +" module-lift-context-module*-ok?)" +"(let-values(((struct:_70 make-_70 ?_70 -ref_70 -set!_70)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'module-lift-context" +" #f" +" 3" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'module-lift-context)))))" +"(values" +" struct:_70" +" make-_70" +" ?_70" +"(make-struct-field-accessor -ref_70 0 'wrt-phase)" +"(make-struct-field-accessor -ref_70 1 'lifts)" +"(make-struct-field-accessor -ref_70 2 'module*-ok?))))" +"(define-values" +"(make-module-lift-context)" +"(lambda(phase_99 module*-ok?_1)(begin(module-lift-context19.1 phase_99(box null) module*-ok?_1))))" +"(define-values" +"(get-and-clear-module-lifts!)" +"(lambda(module-lifts_1)(begin(box-clear!(module-lift-context-lifts module-lifts_1)))))" +"(define-values" +"(add-lifted-module!)" +"(lambda(module-lifts_2 s_394 phase_100)" +"(begin" +"(begin" +"(if(let-values(((or-part_260)" +"(if(module-lift-context? module-lifts_2)" +"(module-lift-context-module*-ok? module-lifts_2)" +" #f)))" +"(if or-part_260" +" or-part_260" +"(if(lift-context? module-lifts_2)(lift-context-module*-ok? module-lifts_2) #f)))" +"(void)" +"(let-values()" +"(let-values(((tmp_30)(core-form-sym s_394 phase_100)))" +"(if(equal? tmp_30 'module)" +"(let-values()(void))" +"(if(equal? tmp_30 'module*)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-lift-module" +" \"cannot lift `module*' to a top-level context\"" +" \"syntax\"" +" s_394))" +"(let-values()" +" (raise-arguments-error 'syntax-local-lift-module \"not a `module' declaration\" \"syntax\" s_394)))))))" +"(if(module-lift-context? module-lifts_2)" +"(let-values()(box-cons!(module-lift-context-lifts module-lifts_2) s_394))" +"(if(lift-context? module-lifts_2)" +"(let-values()(box-cons!(lift-context-lifts module-lifts_2) s_394))" +" (let-values () (error \"internal error: unrecognized lift-context type for module lift\"))))))))" +"(define-values" +"(struct:require-lift-context" +" require-lift-context20.1" +" require-lift-context?" +" require-lift-context-do-require" +" require-lift-context-wrt-phase" +" require-lift-context-requires)" +"(let-values(((struct:_71 make-_71 ?_71 -ref_71 -set!_71)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'require-lift-context" +" #f" +" 3" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1 2)" +" #f" +" 'require-lift-context)))))" +"(values" +" struct:_71" +" make-_71" +" ?_71" +"(make-struct-field-accessor -ref_71 0 'do-require)" +"(make-struct-field-accessor -ref_71 1 'wrt-phase)" +"(make-struct-field-accessor -ref_71 2 'requires))))" +"(define-values" +"(make-require-lift-context)" +"(lambda(wrt-phase_0 do-require_0)(begin(require-lift-context20.1 do-require_0 wrt-phase_0(box null)))))" +"(define-values" +"(get-and-clear-require-lifts!)" +"(lambda(require-lifts_1)(begin(box-clear!(require-lift-context-requires require-lifts_1)))))" +"(define-values" +"(add-lifted-require!)" +"(lambda(require-lifts_2 s_39 phase_101)" +"(begin" +"(begin" +"((require-lift-context-do-require require-lifts_2) s_39 phase_101)" +"(box-cons!(require-lift-context-requires require-lifts_2) s_39)))))" +"(define-values" +"(struct:to-module-lift-context" +" to-module-lift-context21.1" +" to-module-lift-context?" +" to-module-lift-context-wrt-phase" +" to-module-lift-context-provides" +" to-module-lift-context-end-as-expressions?" +" to-module-lift-context-ends)" +"(let-values(((struct:_72 make-_72 ?_72 -ref_72 -set!_72)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'to-module-lift-context" +" #f" +" 4" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'to-module-lift-context)))))" +"(values" +" struct:_72" +" make-_72" +" ?_72" +"(make-struct-field-accessor -ref_72 0 'wrt-phase)" +"(make-struct-field-accessor -ref_72 1 'provides)" +"(make-struct-field-accessor -ref_72 2 'end-as-expressions?)" +"(make-struct-field-accessor -ref_72 3 'ends))))" +"(define-values" +"(make-to-module-lift-context27.1)" +"(lambda(end-as-expressions?23_0 shared-module-ends22_0 phase26_1)" +"(begin" +" 'make-to-module-lift-context27" +"(let-values(((phase_93) phase26_1))" +"(let-values(((ends_0) shared-module-ends22_0))" +"(let-values(((end-as-expressions?_0) end-as-expressions?23_0))" +"(let-values()(to-module-lift-context21.1 phase_93(box null) end-as-expressions?_0 ends_0))))))))" +"(define-values(make-shared-module-ends)(lambda()(begin(box null))))" +"(define-values" +"(get-and-clear-end-lifts!)" +"(lambda(to-module-lifts_1)(begin(box-clear!(to-module-lift-context-ends to-module-lifts_1)))))" +"(define-values" +"(get-and-clear-provide-lifts!)" +"(lambda(to-module-lifts_2)(begin(box-clear!(to-module-lift-context-provides to-module-lifts_2)))))" +"(define-values" +"(add-lifted-to-module-provide!)" +"(lambda(to-module-lifts_3 s_214 phase_102)" +"(begin(box-cons!(to-module-lift-context-provides to-module-lifts_3) s_214))))" +"(define-values" +"(add-lifted-to-module-end!)" +"(lambda(to-module-lifts_4 s_395 phase_103)" +"(begin(box-cons!(to-module-lift-context-ends to-module-lifts_4) s_395))))" +"(define-values" +"(struct:already-expanded already-expanded1.1 already-expanded? already-expanded-s already-expanded-binding-layer)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expanded-syntax" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'already-expanded)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 's)" +"(make-struct-field-accessor -ref_0 1 'binding-layer))))" +"(define-values" +"(1/prop:liberal-define-context has-liberal-define-context-property? liberal-define-context-value)" +"(make-struct-type-property 'liberal-define-context))" +"(define-values" +"(struct:liberal-define-context make-liberal-define-context 1/liberal-define-context?)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'liberal-define-context" +" #f" +" 0" +" 0" +" #f" +"(list(cons 1/prop:liberal-define-context #t))" +" #f" +" #f" +" '()" +" #f" +" 'make-liberal-define-context)))))" +"(values struct:_0 make-_0 ?_0)))" +"(define-values" +"(1/prop:expansion-contexts expansion-contexts? expansion-contexts-ref)" +"(make-struct-type-property" +" 'expansion-contexts" +"(lambda(v_26 info_1)" +"(begin" +"(if(if(list? v_26)" +"(let-values(((lst_71) v_26))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_71)))" +"((letrec-values(((for-loop_90)" +"(lambda(result_70 lst_72)" +"(begin" +" 'for-loop" +"(if(pair? lst_72)" +"(let-values(((s_2)(unsafe-car lst_72))((rest_33)(unsafe-cdr lst_72)))" +"(let-values(((result_62)" +"(let-values()" +"(let-values(((result_108)" +"(let-values()" +"(let-values()" +"(memq" +" s_2" +" '(expression" +" top-level" +" module" +" module-begin" +" definition-context))))))" +"(values result_108)))))" +"(if(if(not((lambda x_75(not result_62)) s_2))(not #f) #f)" +"(for-loop_90 result_62 rest_33)" +" result_62)))" +" result_70)))))" +" for-loop_90)" +" #t" +" lst_71)))" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'guard-for-prop:expansion-contexts" +" \"(listof (or/c 'expression 'top-level 'module 'module-begin 'definition-context))\"" +" v_26)))" +" v_26))))" +"(define-values" +"(not-in-this-expand-context?)" +"(lambda(t_42 ctx_12)" +"(begin" +"(if(expansion-contexts? t_42)" +"(not(memq(context->symbol(expand-context-context ctx_12))(expansion-contexts-ref t_42)))" +" #f))))" +"(define-values(context->symbol)(lambda(context_5)(begin(if(symbol? context_5) context_5 'definition-context))))" +"(define-values" +"(avoid-current-expand-context)" +"(lambda(s_171 t_43 ctx_13)" +"(begin" +"(let-values(((wrap_1)" +"(lambda(sym_61)" +"(begin" +" 'wrap" +"(datum->syntax$1" +" #f" +"(list" +"(syntax-shift-phase-level$1(datum->syntax$1 core-stx sym_61)(expand-context-phase ctx_13))" +" s_171))))))" +"(let-values(((fail_0)" +"(lambda()" +"(begin" +" 'fail" +"(raise-syntax-error$1" +" #f" +"(format" +" \"not allowed in context\\n expansion context: ~a\"" +"(context->symbol(expand-context-context ctx_13)))" +" s_171)))))" +"(let-values(((tmp_31)(context->symbol(expand-context-context ctx_13))))" +"(if(equal? tmp_31 'module-begin)" +"(let-values()(wrap_1 'begin))" +"(if(if(equal? tmp_31 'module) #t(if(equal? tmp_31 'top-level) #t(equal? tmp_31 'definition-context)))" +"(let-values()(if(memq 'expression(expansion-contexts-ref t_43))(wrap_1 '#%expression)(fail_0)))" +"(let-values()(fail_0))))))))))" +"(define-values" +"(struct:reference-record" +" reference-record1.1" +" reference-record?" +" reference-record-already-bound" +" reference-record-reference-before-bound" +" reference-record-all-referenced?" +" set-reference-record-already-bound!" +" set-reference-record-reference-before-bound!" +" set-reference-record-all-referenced?!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()(make-struct-type 'reference-record #f 3 0 #f null #f #f '() #f 'reference-record)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'already-bound)" +"(make-struct-field-accessor -ref_0 1 'reference-before-bound)" +"(make-struct-field-accessor -ref_0 2 'all-referenced?)" +"(make-struct-field-mutator -set!_0 0 'already-bound)" +"(make-struct-field-mutator -set!_0 1 'reference-before-bound)" +"(make-struct-field-mutator -set!_0 2 'all-referenced?))))" +"(define-values(make-reference-record)(lambda()(begin(reference-record1.1(seteq)(seteq) #f))))" +"(define-values" +"(reference-record-used!)" +"(lambda(rr_0 key_77)" +"(begin" +"(if(set-member?(reference-record-already-bound rr_0) key_77)" +"(void)" +"(let-values()" +"(set-reference-record-reference-before-bound!" +" rr_0" +"(set-add(reference-record-reference-before-bound rr_0) key_77)))))))" +"(define-values" +"(reference-records-all-used!)" +"(lambda(rrs_0)" +"(begin" +"(begin" +"(let-values(((lst_39) rrs_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_39)))" +"((letrec-values(((for-loop_178)" +"(lambda(lst_84)" +"(begin" +" 'for-loop" +"(if(pair? lst_84)" +"(let-values(((rr_1)(unsafe-car lst_84))((rest_116)(unsafe-cdr lst_84)))" +"(let-values(((post-guard-var_0)(lambda()(begin 'post-guard-var #t))))" +"(let-values()" +"(if(reference-record-all-referenced? rr_1)" +"(values)" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(set-reference-record-all-referenced?! rr_1 #t))" +"(values)))))" +"(if(post-guard-var_0)(for-loop_178 rest_116)(values))))))))" +"(values))))))" +" for-loop_178)" +" lst_39)))" +"(void)))))" +"(define-values" +"(reference-record-bound!)" +"(lambda(rr_2 keys_3)" +"(begin" +"(begin" +"(set-reference-record-already-bound!" +" rr_2" +"(let-values(((lst_24) keys_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_24)))" +"((letrec-values(((for-loop_241)" +"(lambda(ab_3 lst_76)" +"(begin" +" 'for-loop" +"(if(pair? lst_76)" +"(let-values(((key_78)(unsafe-car lst_76))((rest_141)(unsafe-cdr lst_76)))" +"(let-values(((ab_4)" +"(let-values(((ab_5) ab_3))" +"(let-values(((ab_6)(let-values()(set-add ab_5 key_78))))" +"(values ab_6)))))" +"(if(not #f)(for-loop_241 ab_4 rest_141) ab_4)))" +" ab_3)))))" +" for-loop_241)" +"(reference-record-already-bound rr_2)" +" lst_24))))" +"(set-reference-record-reference-before-bound!" +" rr_2" +"(let-values(((lst_17) keys_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_17)))" +"((letrec-values(((for-loop_10)" +"(lambda(rbb_0 lst_18)" +"(begin" +" 'for-loop" +"(if(pair? lst_18)" +"(let-values(((key_79)(unsafe-car lst_18))((rest_5)(unsafe-cdr lst_18)))" +"(let-values(((rbb_1)" +"(let-values(((rbb_2) rbb_0))" +"(let-values(((rbb_3)(let-values()(set-remove rbb_2 key_79))))" +"(values rbb_3)))))" +"(if(not #f)(for-loop_10 rbb_1 rest_5) rbb_1)))" +" rbb_0)))))" +" for-loop_10)" +"(reference-record-reference-before-bound rr_2)" +" lst_17))))))))" +"(define-values" +"(reference-record-forward-references?)" +"(lambda(rr_3)" +"(begin" +"(let-values(((or-part_167)(reference-record-all-referenced? rr_3)))" +"(if or-part_167 or-part_167(positive?(set-count(reference-record-reference-before-bound rr_3))))))))" +"(define-values" +"(reference-record-clear!)" +"(lambda(rr_4)" +"(begin" +"(begin(set-reference-record-already-bound! rr_4 #f)(set-reference-record-reference-before-bound! rr_4 #f)))))" +"(define-values" +"(call-expand-observe)" +"(lambda(obs_0 key_80 . args_5)" +"(begin" +"(obs_0" +"(hash-ref key->number key_80)" +"(if(null? args_5)(let-values() #f)(let-values()(apply list* args_5)))))))" +"(define-values" +"(log-expand-start)" +"(lambda()" +"(begin" +"(let-values(((obs_1)(current-expand-observe)))" +"(if obs_1(let-values()(call-expand-observe obs_1 'start-expand))(void))))))" +"(define-values" +"(key->number)" +" '#hash((block->letrec . 14)" +"(block->list . 12)" +"(block-renames . 24)" +"(case-lambda-renames . 18)" +"(enter-bind . 144)" +"(enter-block . 10)" +"(enter-check . 126)" +"(enter-list . 4)" +"(enter-local . 130)" +"(enter-local-expr . 139)" +"(enter-macro . 8)" +"(enter-prim . 6)" +"(exit-bind . 145)" +"(exit-check . 127)" +"(exit-list . 5)" +"(exit-local . 131)" +"(exit-local-bind . 160)" +"(exit-local-expr . 140)" +"(exit-macro . 9)" +"(exit-prim . 7)" +"(lambda-renames . 17)" +"(let-renames . 16)" +"(letlift-loop . 136)" +"(letrec-syntaxes-renames . 19)" +"(lift-loop . 128)" +"(lift-provide . 151)" +"(lift-require . 150)" +"(lift-statement . 134)" +"(local-bind . 143)" +"(local-lift . 129)" +"(local-post . 133)" +"(local-pre . 132)" +"(local-value . 153)" +"(local-value-result . 154)" +"(macro-post-x . 22)" +"(macro-pre-x . 21)" +"(module-body . 23)" +"(module-lift-end-loop . 135)" +"(module-lift-loop . 137)" +"(next . 3)" +"(next-group . 13)" +"(opaque-expr . 146)" +"(phase-up . 20)" +"(prepare-env . 157)" +"(prim-#%app . 109)" +"(prim-#%datum . 115)" +"(prim-#%expression . 138)" +"(prim-#%stratified . 155)" +"(prim-#%top . 116)" +"(prim-#%variable-reference . 149)" +"(prim-begin . 107)" +"(prim-begin-for-syntax . 156)" +"(prim-begin0 . 108)" +"(prim-case-lambda . 111)" +"(prim-define-syntaxes . 103)" +"(prim-define-values . 104)" +"(prim-if . 105)" +"(prim-lambda . 110)" +"(prim-let-values . 112)" +"(prim-letrec-syntaxes+values . 114)" +"(prim-letrec-values . 113)" +"(prim-module . 101)" +"(prim-module-begin . 102)" +"(prim-provide . 122)" +"(prim-quote . 117)" +"(prim-quote-syntax . 118)" +"(prim-require . 119)" +"(prim-set! . 123)" +"(prim-stop . 100)" +"(prim-submodule . 158)" +"(prim-submodule* . 159)" +"(prim-with-continuation-mark . 106)" +"(rename-list . 147)" +"(rename-one . 148)" +"(resolve . 1)" +"(return . 2)" +"(splice . 11)" +"(start-expand . 141)" +"(tag . 142)" +"(track-origin . 152)" +"(variable . 125)" +"(visit . 0)))" +"(define-values" +"(rebuild5.1)" +"(lambda(track?1_0 track?2_0 orig-s3_0 new4_0)" +"(begin" +" 'rebuild5" +"(let-values(((orig-s_31) orig-s3_0))" +"(let-values(((new_1) new4_0))" +"(let-values(((track?_0)(if track?2_0 track?1_0 #t)))" +"(let-values()" +"(syntax-rearm$1" +"(datum->syntax$1(syntax-disarm$1 orig-s_31) new_1 orig-s_31(if track?_0 orig-s_31 #f))" +" orig-s_31))))))))" +"(define-values" +"(struct:expanded+parsed expanded+parsed1.1 expanded+parsed? expanded+parsed-s expanded+parsed-parsed)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'expanded+parsed" +" #f" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'expanded+parsed)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 's)" +"(make-struct-field-accessor -ref_0 1 'parsed))))" +"(define-values" +"(struct:semi-parsed-define-values" +" semi-parsed-define-values2.1" +" semi-parsed-define-values?" +" semi-parsed-define-values-s" +" semi-parsed-define-values-syms" +" semi-parsed-define-values-ids" +" semi-parsed-define-values-rhs)" +"(let-values(((struct:_62 make-_62 ?_62 -ref_62 -set!_62)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'semi-parsed-define-values" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'semi-parsed-define-values)))))" +"(values" +" struct:_62" +" make-_62" +" ?_62" +"(make-struct-field-accessor -ref_62 0 's)" +"(make-struct-field-accessor -ref_62 1 'syms)" +"(make-struct-field-accessor -ref_62 2 'ids)" +"(make-struct-field-accessor -ref_62 3 'rhs))))" +"(define-values" +"(struct:semi-parsed-begin-for-syntax" +" semi-parsed-begin-for-syntax3.1" +" semi-parsed-begin-for-syntax?" +" semi-parsed-begin-for-syntax-s" +" semi-parsed-begin-for-syntax-body)" +"(let-values(((struct:_10 make-_10 ?_10 -ref_10 -set!_10)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'semi-parsed-begin-for-syntax" +" #f" +" 2" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'semi-parsed-begin-for-syntax)))))" +"(values" +" struct:_10" +" make-_10" +" ?_10" +"(make-struct-field-accessor -ref_10 0 's)" +"(make-struct-field-accessor -ref_10 1 'body))))" +"(define-values(extract-syntax)(lambda(s_186)(begin(if(expanded+parsed? s_186)(expanded+parsed-s s_186) s_186))))" +"(define-values" +"(parsed-only)" +"(lambda(l_69)" +"(begin" +"(reverse$1" +"(let-values(((lst_173) l_69))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_173)))" +"((letrec-values(((for-loop_242)" +"(lambda(fold-var_5 lst_282)" +"(begin" +" 'for-loop" +"(if(pair? lst_282)" +"(let-values(((i_27)(unsafe-car lst_282))((rest_81)(unsafe-cdr lst_282)))" +"(let-values(((fold-var_219)" +"(let-values(((fold-var_155) fold-var_5))" +"(if(let-values(((or-part_69)(parsed? i_27)))" +"(if or-part_69" +" or-part_69" +"(let-values(((or-part_225)(expanded+parsed? i_27)))" +"(if or-part_225" +" or-part_225" +"(semi-parsed-begin-for-syntax? i_27)))))" +"(let-values(((fold-var_173) fold-var_155))" +"(let-values(((fold-var_174)" +"(let-values()" +"(cons" +"(let-values()" +"(if(expanded+parsed? i_27)" +"(let-values()" +"(expanded+parsed-parsed i_27))" +"(if(semi-parsed-begin-for-syntax? i_27)" +"(let-values()" +"(parsed-begin-for-syntax21.1" +"(semi-parsed-begin-for-syntax-s i_27)" +"(parsed-only" +"(semi-parsed-begin-for-syntax-body" +" i_27))))" +"(let-values() i_27))))" +" fold-var_173))))" +"(values fold-var_174)))" +" fold-var_155))))" +"(if(not #f)(for-loop_242 fold-var_219 rest_81) fold-var_219)))" +" fold-var_5)))))" +" for-loop_242)" +" null" +" lst_173)))))))" +"(define-values" +"(syntax-only)" +"(lambda(l_70)" +"(begin" +"(reverse$1" +"(let-values(((lst_275) l_70))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_275)))" +"((letrec-values(((for-loop_238)" +"(lambda(fold-var_221 lst_276)" +"(begin" +" 'for-loop" +"(if(pair? lst_276)" +"(let-values(((i_35)(unsafe-car lst_276))((rest_151)(unsafe-cdr lst_276)))" +"(let-values(((fold-var_80)" +"(let-values(((fold-var_81) fold-var_221))" +"(if(let-values(((or-part_209)(syntax?$1 i_35)))" +"(if or-part_209" +" or-part_209" +"(let-values(((or-part_261)(expanded+parsed? i_35)))" +"(if or-part_261" +" or-part_261" +"(semi-parsed-begin-for-syntax? i_35)))))" +"(let-values(((fold-var_82) fold-var_81))" +"(let-values(((fold-var_232)" +"(let-values()" +"(cons" +"(let-values()" +"(if(expanded+parsed? i_35)" +"(let-values()(expanded+parsed-s i_35))" +"(if(semi-parsed-begin-for-syntax? i_35)" +"(let-values()" +"(let-values(((s_396)" +"(semi-parsed-begin-for-syntax-s" +" i_35)))" +"(let-values(((nested-bodys_0)" +"(semi-parsed-begin-for-syntax-body" +" i_35)))" +"(let-values(((disarmed-s_0)" +"(syntax-disarm$1" +" s_396)))" +"(let-values(((ok?_27" +" begin-for-syntax7_0" +" _8_0)" +"(let-values(((s_397)" +" disarmed-s_0))" +"(let-values(((orig-s_32)" +" s_397))" +"(let-values(((begin-for-syntax7_1" +" _8_1)" +"(let-values(((s_27)" +"(if(syntax?$1" +" s_397)" +"(syntax-e$1" +" s_397)" +" s_397)))" +"(if(pair?" +" s_27)" +"(let-values(((begin-for-syntax9_0)" +"(let-values(((s_30)" +"(car" +" s_27)))" +" s_30))" +"((_10_0)" +"(let-values(((s_160)" +"(cdr" +" s_27)))" +"(let-values(((s_150)" +"(if(syntax?$1" +" s_160)" +"(syntax-e$1" +" s_160)" +" s_160)))" +"(let-values(((flat-s_14)" +"(to-syntax-list.1" +" s_150)))" +"(if(not" +" flat-s_14)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_32))" +"(let-values()" +" flat-s_14)))))))" +"(values" +" begin-for-syntax9_0" +" _10_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_32)))))" +"(values" +" #t" +" begin-for-syntax7_1" +" _8_1))))))" +"(let-values(((s11_0) s_396)" +"((temp12_2)" +"(list*" +" begin-for-syntax7_0" +"(syntax-only" +" nested-bodys_0))))" +"(rebuild5.1" +" #f" +" #f" +" s11_0" +" temp12_2)))))))" +"(let-values() i_35))))" +" fold-var_82))))" +"(values fold-var_232)))" +" fold-var_81))))" +"(if(not #f)(for-loop_238 fold-var_80 rest_151) fold-var_80)))" +" fold-var_221)))))" +" for-loop_238)" +" null" +" lst_275)))))))" +"(define-values" +"(expand7.1)" +"(lambda(alternate-id1_0 alternate-id3_0 skip-log?2_0 skip-log?4_0 s5_0 ctx6_0)" +"(begin" +" 'expand7" +"(let-values(((s_398) s5_0))" +"(let-values(((ctx_14) ctx6_0))" +"(let-values(((alternate-id_0)(if alternate-id3_0 alternate-id1_0 #f)))" +"(let-values(((skip-log?_0)(if skip-log?4_0 skip-log?2_0 #f)))" +"(let-values()" +"(begin" +"(let-values(((obs_2)(expand-context-observer ctx_14)))" +"(if obs_2" +"(let-values()" +"(if(not skip-log?_0)" +"(let-values()" +"(call-expand-observe" +" obs_2" +"(if(expand-context-only-immediate? ctx_14) 'enter-check 'visit)" +" s_398))" +"(void)))" +"(void)))" +"(if(identifier? s_398)" +"(let-values()(expand-identifier s_398 ctx_14 alternate-id_0))" +"(if(if(pair?(syntax-content s_398))(identifier?(car(syntax-content s_398))) #f)" +"(let-values()(expand-id-application-form s_398 ctx_14 alternate-id_0))" +"(if(let-values(((or-part_29)(pair?(syntax-content s_398))))" +"(if or-part_29 or-part_29(null?(syntax-content s_398))))" +"(let-values()(expand-implicit '#%app s_398 ctx_14 #f))" +"(if(already-expanded?(syntax-content s_398))" +"(let-values()(expand-already-expanded s_398 ctx_14))" +"(let-values()(expand-implicit '#%datum s_398 ctx_14 #f)))))))))))))))" +"(define-values" +"(expand-identifier)" +"(lambda(s_43 ctx_15 alternate-id_1)" +"(begin" +"(let-values(((id_57)(let-values(((or-part_166) alternate-id_1))(if or-part_166 or-part_166 s_43))))" +"(if(free-id-set-member?(expand-context-stops ctx_15)(expand-context-phase ctx_15) id_57)" +"(let-values()" +"(begin" +"(let-values(((obs_3)(expand-context-observer ctx_15)))" +"(if obs_3" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_15))" +"(let-values()" +"(begin" +"(call-expand-observe obs_3 'resolve id_57)" +"(call-expand-observe obs_3 'enter-prim s_43)" +"(call-expand-observe obs_3 'prim-stop)" +"(call-expand-observe obs_3 'exit-prim s_43)" +"(call-expand-observe obs_3 'return s_43)))" +"(void)))" +"(void)))" +" s_43))" +"(let-values()" +"(let-values(((binding_19)" +"(let-values(((temp78_2)(expand-context-phase ctx_15))" +"((temp79_0) 'ambiguous)" +"((temp80_1) #t))" +"(resolve+shift30.1 temp79_0 #t #f #f #f #f temp80_1 #t #f #f id_57 temp78_2))))" +"(begin" +"(let-values(((obs_4)(expand-context-observer ctx_15)))" +"(if obs_4" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_15))" +"(let-values()(call-expand-observe obs_4 'resolve id_57))" +"(void)))" +"(void)))" +"(if(eq? binding_19 'ambiguous)" +"(let-values()(raise-ambiguous-error id_57 ctx_15))" +"(if(not binding_19)" +"(let-values()(expand-implicit '#%top(substitute-alternate-id s_43 alternate-id_1) ctx_15 s_43))" +"(let-values()" +"(let-values(((t_44 primitive?_2 insp-of-t_0)" +"(let-values(((temp84_0)(if alternate-id_1 s_43 #f))" +"((temp85_0)(expand-context-in-local-expand? ctx_15)))" +"(lookup17.1 temp84_0 #t temp85_0 #t binding_19 ctx_15 id_57))))" +"(dispatch t_44 insp-of-t_0 s_43 id_57 ctx_15 binding_19 primitive?_2)))))))))))))" +"(define-values" +"(expand-id-application-form)" +"(lambda(s_399 ctx_16 alternate-id_2)" +"(begin" +"(let-values(((id_58)" +"(let-values(((or-part_262) alternate-id_2))" +"(if or-part_262 or-part_262(car(syntax-e/no-taint s_399))))))" +"(if(free-id-set-member?(expand-context-stops ctx_16)(expand-context-phase ctx_16) id_58)" +"(let-values()" +"(begin" +"(let-values(((obs_5)(expand-context-observer ctx_16)))" +"(if obs_5" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_16))" +"(let-values()" +"(begin" +"(call-expand-observe obs_5 'resolve id_58)" +"(call-expand-observe obs_5 'enter-prim s_399)" +"(call-expand-observe obs_5 'prim-stop)" +"(call-expand-observe obs_5 'exit-prim s_399)" +"(call-expand-observe obs_5 'return s_399)))" +"(void)))" +"(void)))" +" s_399))" +"(let-values()" +"(let-values(((binding_20)" +"(let-values(((temp87_1)(expand-context-phase ctx_16))" +"((temp88_1) 'ambiguous)" +"((temp89_1) #t))" +"(resolve+shift30.1 temp88_1 #t #f #f #f #f temp89_1 #t #f #f id_58 temp87_1))))" +"(begin" +"(let-values(((obs_6)(expand-context-observer ctx_16)))" +"(if obs_6" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_16))" +"(let-values()(call-expand-observe obs_6 'resolve id_58))" +"(void)))" +"(void)))" +"(if(eq? binding_20 'ambiguous)" +"(let-values()(raise-ambiguous-error id_58 ctx_16))" +"(if(not binding_20)" +"(let-values()(expand-implicit '#%app(substitute-alternate-id s_399 alternate-id_2) ctx_16 id_58))" +"(let-values()" +"(let-values(((t_45 primitive?_3 insp-of-t_1)" +"(let-values(((temp93_2)(if alternate-id_2(car(syntax-e/no-taint s_399)) #f))" +"((temp94_1)(expand-context-in-local-expand? ctx_16)))" +"(lookup17.1 temp93_2 #t temp94_1 #t binding_20 ctx_16 id_58))))" +"(if(variable? t_45)" +"(let-values()" +"(expand-implicit '#%app(substitute-alternate-id s_399 alternate-id_2) ctx_16 id_58))" +"(let-values()" +"(dispatch t_45 insp-of-t_1 s_399 id_58 ctx_16 binding_20 primitive?_3)))))))))))))))" +"(define-values" +"(expand-implicit)" +"(lambda(sym_25 s_17 ctx_17 trigger-id_1)" +"(begin" +"(if(expand-context-only-immediate? ctx_17)" +"(let-values()" +"(begin" +"(let-values(((obs_7)(expand-context-observer ctx_17)))" +"(if obs_7(let-values()(let-values()(call-expand-observe obs_7 'exit-check s_17)))(void)))" +" s_17))" +"(let-values()" +"(let-values(((disarmed-s_1)(syntax-disarm$1 s_17)))" +"(let-values(((id_15)(datum->syntax$1 disarmed-s_1 sym_25)))" +"(if(free-id-set-member?(expand-context-stops ctx_17)(expand-context-phase ctx_17) id_15)" +"(let-values()" +"(begin" +"(let-values(((obs_8)(expand-context-observer ctx_17)))" +"(if obs_8" +"(let-values()" +"(if(not(expand-context-only-immediate? ctx_17))" +"(let-values()" +"(begin" +"(call-expand-observe obs_8 'resolve id_15)" +"(call-expand-observe obs_8 'enter-prim s_17)" +"(call-expand-observe obs_8 'prim-stop)" +"(call-expand-observe obs_8 'exit-prim s_17)" +"(call-expand-observe obs_8 'return s_17)))" +"(void)))" +"(void)))" +" s_17))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_9)(expand-context-observer ctx_17)))" +"(if obs_9" +"(let-values()(let-values()(call-expand-observe obs_9 'resolve id_15)))" +"(void)))" +"(values))))" +"(let-values(((b_78)" +"(let-values(((temp96_2)(expand-context-phase ctx_17))" +"((temp97_1) 'ambiguous)" +"((temp98_1) #t))" +"(resolve+shift30.1 temp97_1 #t #f #f #f #f temp98_1 #t #f #f id_15 temp96_2))))" +"(if(eq? b_78 'ambiguous)" +"(let-values()(raise-ambiguous-error id_15 ctx_17))" +"(let-values()" +"(let-values(((t_46 primitive?_4 insp-of-t_2)" +"(if b_78" +"(let-values(((b99_0) b_78)((ctx100_0) ctx_17)((id101_0) id_15))" +"(lookup17.1 #f #f #f #f b99_0 ctx100_0 id101_0))" +"(values #f #f #f))))" +"(if(transformer? t_46)" +"(let-values()" +"(dispatch-transformer" +" t_46" +" insp-of-t_2" +"(make-explicit ctx_17 sym_25 s_17 disarmed-s_1)" +" id_15" +" ctx_17" +" b_78))" +"(if(core-form? t_46)" +"(let-values()" +"(if(if(eq? sym_25 '#%top)" +"(if(eq?(core-form-name t_46) '#%top)" +"(expand-context-in-local-expand? ctx_17)" +" #f)" +" #f)" +"(let-values()(dispatch-implicit-#%top-core-form t_46 s_17 ctx_17))" +"(let-values()" +"(dispatch-core-form" +" t_46" +"(make-explicit ctx_17 sym_25 s_17 disarmed-s_1)" +" ctx_17))))" +"(let-values()" +"(let-values(((tl-id_0)" +"(if(eq? sym_25 '#%top)" +"(if(root-expand-context-top-level-bind-scope ctx_17)" +"(add-scope s_17(root-expand-context-top-level-bind-scope ctx_17))" +" #f)" +" #f)))" +"(let-values(((tl-b_0)" +"(if tl-id_0" +"(let-values(((tl-id102_0) tl-id_0)" +"((temp103_1)(expand-context-phase ctx_17)))" +"(resolve33.1 #f #f #f #f #f #f #f #f tl-id102_0 temp103_1))" +" #f)))" +"(if tl-b_0" +"(let-values()" +"(if(if(expand-context-to-parsed? ctx_17)" +"(free-id-set-empty?(expand-context-stops ctx_17))" +" #f)" +"(parsed-id2.1 tl-id_0 tl-b_0 #f)" +" tl-id_0))" +"(let-values()" +"(raise-syntax-implicit-error" +" s_17" +" sym_25" +" trigger-id_1" +" ctx_17))))))))))))))))))))))" +"(define-values" +"(expand-already-expanded)" +"(lambda(s_164 ctx_18)" +"(begin" +"(let-values(((ae_0)(syntax-e$1 s_164)))" +"(let-values(((exp-s_0)(already-expanded-s ae_0)))" +"(begin" +"(if(let-values(((or-part_263)(syntax-any-macro-scopes? s_164)))" +"(if or-part_263" +" or-part_263" +"(let-values(((or-part_264)" +"(not" +"(eq?(expand-context-binding-layer ctx_18)(already-expanded-binding-layer ae_0)))))" +"(if or-part_264" +" or-part_264" +"(if(parsed? exp-s_0)" +"(not" +"(if(expand-context-to-parsed? ctx_18)" +"(free-id-set-empty?(expand-context-stops ctx_18))" +" #f))" +" #f)))))" +"(let-values()" +"(raise-syntax-error$1" +" #f" +"(string-append" +" \"expanded syntax not in its original lexical context;\\n\"" +" \" extra bindings or scopes in the current context\")" +"(if(not(parsed? exp-s_0)) exp-s_0 #f)))" +"(void))" +"(if(parsed? exp-s_0)" +"(let-values() exp-s_0)" +"(let-values()" +"(let-values(((result-s_1)(syntax-track-origin$1 exp-s_0 s_164)))" +"(begin" +"(let-values(((obs_10)(expand-context-observer ctx_18)))" +"(if obs_10" +"(let-values()(let-values()(call-expand-observe obs_10 'opaque-expr result-s_1)))" +"(void)))" +"(if(if(expand-context-to-parsed? ctx_18)(free-id-set-empty?(expand-context-stops ctx_18)) #f)" +"(let-values(((result-s104_0) result-s_1)((ctx105_0) ctx_18))" +"(expand7.1 #f #f #f #f result-s104_0 ctx105_0))" +" result-s_1)))))))))))" +"(define-values" +"(make-explicit)" +"(lambda(ctx_19 sym_62 s_77 disarmed-s_2)" +"(begin" +"(let-values(((new-s_0)" +"(syntax-rearm$1(datum->syntax$1 disarmed-s_2(cons sym_62 disarmed-s_2) s_77 s_77) s_77)))" +"(begin" +"(let-values(((obs_11)(expand-context-observer ctx_19)))" +"(if obs_11(let-values()(let-values()(call-expand-observe obs_11 'tag new-s_0)))(void)))" +" new-s_0)))))" +"(define-values" +"(dispatch)" +"(lambda(t_31 insp-of-t_3 s_397 id_59 ctx_20 binding_21 primitive?_5)" +"(begin" +"(if(core-form? t_31)" +"(let-values()(dispatch-core-form t_31 s_397 ctx_20))" +"(if(transformer? t_31)" +"(let-values()(dispatch-transformer t_31 insp-of-t_3 s_397 id_59 ctx_20 binding_21))" +"(if(variable? t_31)" +"(let-values()(dispatch-variable t_31 s_397 id_59 ctx_20 binding_21 primitive?_5))" +" (let-values () (raise-syntax-error$1 #f \"illegal use of syntax\" s_397))))))))" +"(define-values" +"(dispatch-core-form)" +"(lambda(t_47 s_29 ctx_21)" +"(begin" +"(if(expand-context-only-immediate? ctx_21)" +"(let-values()" +"(begin" +"(let-values(((obs_12)(expand-context-observer ctx_21)))" +"(if obs_12(let-values()(let-values()(call-expand-observe obs_12 'exit-check s_29)))(void)))" +" s_29))" +"(if(expand-context-observer ctx_21)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_13)(expand-context-observer ctx_21)))" +"(if obs_13" +"(let-values()(let-values()(call-expand-observe obs_13 'enter-prim s_29)))" +"(void)))" +"(values))))" +"(let-values(((result-s_2)((core-form-expander t_47) s_29 ctx_21)))" +"(begin" +"(let-values(((obs_14)(expand-context-observer ctx_21)))" +"(if obs_14" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_14 'exit-prim(extract-syntax result-s_2))" +"(call-expand-observe obs_14 'return(extract-syntax result-s_2)))))" +"(void)))" +" result-s_2))))" +"(let-values()((core-form-expander t_47) s_29 ctx_21)))))))" +"(define-values" +"(dispatch-implicit-#%top-core-form)" +"(lambda(t_48 s_400 ctx_0)" +"(begin" +"(let-values((()" +"(begin" +"(let-values(((obs_15)(expand-context-observer ctx_0)))" +"(if obs_15" +"(let-values()(let-values()(call-expand-observe obs_15 'enter-prim s_400)))" +"(void)))" +"(values))))" +"(let-values(((result-s_3)((core-form-expander t_48) s_400 ctx_0 #t)))" +"(begin" +"(let-values(((obs_16)(expand-context-observer ctx_0)))" +"(if obs_16" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_16 'exit-prim result-s_3)" +"(call-expand-observe obs_16 'return result-s_3))))" +"(void)))" +" result-s_3))))))" +"(define-values" +"(dispatch-transformer)" +"(lambda(t_49 insp-of-t_4 s_401 id_60 ctx_22 binding_22)" +"(begin" +"(if(not-in-this-expand-context? t_49 ctx_22)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_17)(expand-context-observer ctx_22)))" +"(if obs_17" +"(let-values()(let-values()(call-expand-observe obs_17 'enter-macro s_401)))" +"(void)))" +"(values))))" +"(let-values(((adj-s_0)(avoid-current-expand-context(substitute-alternate-id s_401 id_60) t_49 ctx_22)))" +"(begin" +"(let-values(((obs_18)(expand-context-observer ctx_22)))" +"(if obs_18(let-values()(let-values()(call-expand-observe obs_18 'exit-macro s_401)))(void)))" +"(let-values(((adj-s106_0) adj-s_0)((ctx107_0) ctx_22))" +"(expand7.1 #f #f #f #f adj-s106_0 ctx107_0))))))" +"(if(expand-context-should-not-encounter-macros? ctx_22)" +"(let-values()" +" (raise-syntax-error$1 #f \"encountered a macro binding in form that should be fully expanded\" s_401))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_19)(expand-context-observer ctx_22)))" +"(if obs_19" +"(let-values()" +"(if(if(expand-context-only-immediate? ctx_22)(not(1/rename-transformer? t_49)) #f)" +"(let-values()" +"(begin" +"(call-expand-observe obs_19 'visit s_401)" +"(call-expand-observe obs_19 'resolve id_60)))" +"(void)))" +"(void)))" +"(values))))" +"(let-values(((exp-s_1 re-ctx_0)" +"(if(1/rename-transformer? t_49)" +"(values s_401 ctx_22)" +"(apply-transformer t_49 insp-of-t_4 s_401 id_60 ctx_22 binding_22))))" +"(begin" +"(let-values(((obs_20)(expand-context-observer ctx_22)))" +"(if obs_20" +"(let-values()" +"(if(if(expand-context-only-immediate? ctx_22)(not(1/rename-transformer? t_49)) #f)" +"(let-values()(call-expand-observe obs_20 'return exp-s_1))" +"(void)))" +"(void)))" +"(if(expand-context-just-once? ctx_22)" +"(let-values() exp-s_1)" +"(let-values()" +"(let-values(((temp110_0)" +"(if(1/rename-transformer? t_49)" +"(syntax-track-origin$1" +"(rename-transformer-target-in-context t_49 ctx_22)" +" id_60" +" id_60)" +" #f))" +"((temp111_0)" +"(let-values(((or-part_171)(expand-context-only-immediate? ctx_22)))" +"(if or-part_171 or-part_171(1/rename-transformer? t_49)))))" +"(expand7.1 temp110_0 #t temp111_0 #t exp-s_1 re-ctx_0)))))))))))))" +"(define-values" +"(dispatch-variable)" +"(lambda(t_50 s_312 id_61 ctx_23 binding_23 primitive?_6)" +"(begin" +"(if(expand-context-only-immediate? ctx_23)" +"(let-values()" +"(begin" +"(let-values(((obs_21)(expand-context-observer ctx_23)))" +"(if obs_21(let-values()(let-values()(call-expand-observe obs_21 'exit-check s_312)))(void)))" +" id_61))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_22)(expand-context-observer ctx_23)))" +"(if obs_22" +"(let-values()(let-values()(call-expand-observe obs_22 'variable s_312 id_61)))" +"(void)))" +"(values))))" +"(let-values((()(begin(register-variable-referenced-if-local! binding_23)(values))))" +"(let-values(((result-s_4)" +"(let-values(((temp114_0)" +"(free-id-set-empty-or-just-module*?(expand-context-stops ctx_23))))" +"(substitute-variable6.1 temp114_0 id_61 t_50))))" +"(if(if(expand-context-to-parsed? ctx_23)(free-id-set-empty?(expand-context-stops ctx_23)) #f)" +"(let-values()" +"(let-values(((prop-s_0)(keep-properties-only~ result-s_4)))" +"(let-values(((insp_16)(syntax-inspector result-s_4)))" +"(if primitive?_6" +"(parsed-primitive-id3.1 prop-s_0 binding_23 insp_16)" +"(parsed-id2.1 prop-s_0 binding_23 insp_16)))))" +"(let-values()" +"(begin" +"(let-values(((obs_23)(expand-context-observer ctx_23)))" +"(if obs_23" +"(let-values()(let-values()(call-expand-observe obs_23 'return result-s_4)))" +"(void)))" +" result-s_4)))))))))))" +"(define-values" +"(apply-transformer)" +"(lambda(t_51 insp-of-t_5 s_54 id_62 ctx_24 binding_24)" +"(begin" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_24)(expand-context-observer ctx_24)))" +"(if obs_24" +"(let-values()(let-values()(call-expand-observe obs_24 'enter-macro s_54)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_3)(syntax-disarm$1 s_54)))" +"(let-values(((intro-scope_0)(new-scope 'macro)))" +"(let-values(((intro-s_0)(flip-scope disarmed-s_3 intro-scope_0)))" +"(let-values(((use-s_0 use-scopes_0)(maybe-add-use-site-scope intro-s_0 ctx_24 binding_24)))" +"(let-values(((cleaned-s_0)(syntax-remove-taint-dispatch-properties use-s_0)))" +"(let-values(((def-ctx-scopes_1)(box null)))" +"(let-values(((transformed-s_0)" +"(apply-transformer-in-context" +" t_51" +" cleaned-s_0" +" ctx_24" +" insp-of-t_5" +" intro-scope_0" +" use-scopes_0" +" def-ctx-scopes_1" +" id_62)))" +"(let-values(((result-s_5)(flip-scope transformed-s_0 intro-scope_0)))" +"(let-values(((post-s_0)(maybe-add-post-expansion-scope result-s_5 ctx_24)))" +"(let-values(((tracked-s_0)(syntax-track-origin$1 post-s_0 cleaned-s_0 id_62)))" +"(let-values(((rearmed-s_0)" +"(taint-dispatch" +" tracked-s_0" +"(lambda(t-s_0)(syntax-rearm$1 t-s_0 s_54))" +"(expand-context-phase ctx_24))))" +"(begin" +"(let-values(((obs_25)(expand-context-observer ctx_24)))" +"(if obs_25" +"(let-values()" +"(let-values()(call-expand-observe obs_25 'exit-macro rearmed-s_0)))" +"(void)))" +"(values" +" rearmed-s_0" +"(accumulate-def-ctx-scopes ctx_24 def-ctx-scopes_1)))))))))))))))))))" +"(define-values" +"(apply-transformer-in-context)" +"(lambda(t_52 cleaned-s_1 ctx_25 insp-of-t_6 intro-scope_1 use-scopes_1 def-ctx-scopes_2 id_63)" +"(begin" +"(let-values((()" +"(begin" +"(let-values(((obs_26)(expand-context-observer ctx_25)))" +"(if obs_26" +"(let-values()(let-values()(call-expand-observe obs_26 'macro-pre-x cleaned-s_1)))" +"(void)))" +"(values))))" +"(let-values(((confine-def-ctx-scopes?_0)" +"(not" +"(let-values(((or-part_265)(expand-context-only-immediate? ctx_25)))" +"(if or-part_265" +" or-part_265" +"(not(free-id-set-empty-or-just-module*?(expand-context-stops ctx_25))))))))" +"(let-values(((accum-ctx_0)" +"(if(if confine-def-ctx-scopes?_0" +"(if(expand-context-def-ctx-scopes ctx_25)" +"(not(null?(unbox(expand-context-def-ctx-scopes ctx_25))))" +" #f)" +" #f)" +"(accumulate-def-ctx-scopes ctx_25(expand-context-def-ctx-scopes ctx_25))" +" ctx_25)))" +"(let-values(((m-ctx_0)" +"(let-values(((v_184) accum-ctx_0))" +"(let-values(((the-struct_59) v_184))" +"(if(expand-context/outer? the-struct_59)" +"(let-values(((current-introduction-scopes115_0)(cons intro-scope_1 use-scopes_1))" +"((def-ctx-scopes116_0)" +"(if confine-def-ctx-scopes?_0" +" def-ctx-scopes_2" +"(expand-context-def-ctx-scopes ctx_25)))" +"((inner117_0)(root-expand-context/outer-inner v_184)))" +"(expand-context/outer1.1" +" inner117_0" +"(root-expand-context/outer-post-expansion-scope the-struct_59)" +"(root-expand-context/outer-use-site-scopes the-struct_59)" +"(root-expand-context/outer-frame-id the-struct_59)" +"(expand-context/outer-context the-struct_59)" +"(expand-context/outer-env the-struct_59)" +"(expand-context/outer-post-expansion-scope-action the-struct_59)" +"(expand-context/outer-scopes the-struct_59)" +" def-ctx-scopes116_0" +"(expand-context/outer-binding-layer the-struct_59)" +"(expand-context/outer-reference-records the-struct_59)" +"(expand-context/outer-only-immediate? the-struct_59)" +"(expand-context/outer-need-eventually-defined the-struct_59)" +" current-introduction-scopes115_0" +"(expand-context/outer-name the-struct_59)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_59))))))" +"(let-values(((transformed-s_1)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-expand-context" +" m-ctx_0" +" 1/current-namespace" +"(namespace->namespace-at-phase" +"(expand-context-namespace ctx_25)" +"(add1(expand-context-phase ctx_25)))" +" current-module-code-inspector" +"(let-values(((or-part_266) insp-of-t_6))" +"(if or-part_266 or-part_266(current-module-code-inspector))))" +"(let-values()" +"(call-with-continuation-barrier" +"(lambda()((transformer->procedure t_52) cleaned-s_1)))))))" +"(begin" +"(let-values(((obs_27)(expand-context-observer ctx_25)))" +"(if obs_27" +"(let-values()" +"(let-values()(call-expand-observe obs_27 'macro-post-x transformed-s_1 cleaned-s_1)))" +"(void)))" +"(if(syntax?$1 transformed-s_1)" +"(void)" +"(let-values()" +"(raise-arguments-error" +"(syntax-e$1 id_63)" +" \"received value from syntax expander was not syntax\"" +" \"received\"" +" transformed-s_1)))" +" transformed-s_1)))))))))" +"(define-values" +"(maybe-add-use-site-scope)" +"(lambda(s_61 ctx_26 binding_1)" +"(begin" +"(if(if(root-expand-context-use-site-scopes ctx_26)" +"(matching-frame?(root-expand-context-frame-id ctx_26)(binding-frame-id binding_1))" +" #f)" +"(let-values()" +"(let-values(((sc_26)(new-scope 'use-site)))" +"(let-values(((b_79)(root-expand-context-use-site-scopes ctx_26)))" +"(begin(set-box! b_79(cons sc_26(unbox b_79)))(values(add-scope s_61 sc_26)(list sc_26))))))" +"(let-values()(values s_61 null))))))" +"(define-values" +"(matching-frame?)" +"(lambda(current-frame-id_0 bind-frame-id_0)" +"(begin" +"(if current-frame-id_0" +"(let-values(((or-part_93)(eq? current-frame-id_0 bind-frame-id_0)))" +"(if or-part_93 or-part_93(eq? current-frame-id_0 'all)))" +" #f))))" +"(define-values" +"(maybe-add-post-expansion-scope)" +"(lambda(s_320 ctx_27)" +"(begin" +"(if(root-expand-context-post-expansion-scope ctx_27)" +"(let-values()" +"((expand-context-post-expansion-scope-action ctx_27) s_320(root-expand-context-post-expansion-scope ctx_27)))" +"(let-values() s_320)))))" +"(define-values" +"(accumulate-def-ctx-scopes)" +"(lambda(ctx_28 def-ctx-scopes_3)" +"(begin" +"(if(null?(unbox def-ctx-scopes_3))" +" ctx_28" +"(let-values(((v_107) ctx_28))" +"(let-values(((the-struct_60) v_107))" +"(if(expand-context/outer? the-struct_60)" +"(let-values(((scopes118_0)(append(unbox def-ctx-scopes_3)(expand-context-scopes ctx_28)))" +"((inner119_0)(root-expand-context/outer-inner v_107)))" +"(expand-context/outer1.1" +" inner119_0" +"(root-expand-context/outer-post-expansion-scope the-struct_60)" +"(root-expand-context/outer-use-site-scopes the-struct_60)" +"(root-expand-context/outer-frame-id the-struct_60)" +"(expand-context/outer-context the-struct_60)" +"(expand-context/outer-env the-struct_60)" +"(expand-context/outer-post-expansion-scope-action the-struct_60)" +" scopes118_0" +"(expand-context/outer-def-ctx-scopes the-struct_60)" +"(expand-context/outer-binding-layer the-struct_60)" +"(expand-context/outer-reference-records the-struct_60)" +"(expand-context/outer-only-immediate? the-struct_60)" +"(expand-context/outer-need-eventually-defined the-struct_60)" +"(expand-context/outer-current-introduction-scopes the-struct_60)" +"(expand-context/outer-name the-struct_60)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_60))))))))" +"(define-values" +"(lookup17.1)" +"(lambda(in10_1 in12_1 out-of-context-as-variable?11_0 out-of-context-as-variable?13_0 b14_0 ctx15_0 id16_1)" +"(begin" +" 'lookup17" +"(let-values(((b_80) b14_0))" +"(let-values(((ctx_29) ctx15_0))" +"(let-values(((id_64) id16_1))" +"(let-values(((in-s_7)(if in12_1 in10_1 #f)))" +"(let-values(((out-of-context-as-variable?_1)" +"(if out-of-context-as-variable?13_0 out-of-context-as-variable?11_0 #f)))" +"(let-values()" +"(let-values(((temp121_1)(expand-context-env ctx_29))" +"((temp122_0)(expand-context-lift-envs ctx_29))" +"((temp123_1)(expand-context-namespace ctx_29))" +"((temp124_0)(expand-context-phase ctx_29))" +"((id125_0) id_64)" +"((in-s126_0) in-s_7)" +"((out-of-context-as-variable?127_0) out-of-context-as-variable?_1))" +"(binding-lookup48.1" +" in-s126_0" +" #t" +" out-of-context-as-variable?127_0" +" #t" +" b_80" +" temp121_1" +" temp122_0" +" temp123_1" +" temp124_0" +" id125_0)))))))))))" +"(define-values" +"(substitute-alternate-id)" +"(lambda(s_95 alternate-id_3)" +"(begin" +"(if(not alternate-id_3)" +"(let-values() s_95)" +"(if(identifier? s_95)" +"(let-values()(syntax-rearm$1(syntax-track-origin$1 alternate-id_3 s_95) s_95))" +"(let-values()" +"(let-values(((disarmed-s_4)(syntax-disarm$1 s_95)))" +"(syntax-rearm$1" +"(syntax-track-origin$1" +"(datum->syntax$1 disarmed-s_4(cons alternate-id_3(cdr(syntax-e$1 disarmed-s_4))) s_95)" +" s_95)" +" s_95))))))))" +"(define-values" +"(register-variable-referenced-if-local!)" +"(lambda(binding_25)" +"(begin" +"(if(if(local-binding? binding_25)(reference-record?(binding-frame-id binding_25)) #f)" +"(let-values()(reference-record-used!(binding-frame-id binding_25)(local-binding-key binding_25)))" +"(void)))))" +"(define-values" +"(expand/capture-lifts30.1)" +"(lambda(always-wrap?23_0" +" always-wrap?27_0" +" begin-form?21_0" +" begin-form?25_0" +" expand-lifts?20_0" +" expand-lifts?24_0" +" lift-key22_0" +" lift-key26_0" +" s28_1" +" ctx29_0)" +"(begin" +" 'expand/capture-lifts30" +"(let-values(((s_210) s28_1))" +"(let-values(((ctx_30) ctx29_0))" +"(let-values(((expand-lifts?_0)(if expand-lifts?24_0 expand-lifts?20_0 #f)))" +"(let-values(((begin-form?_0)(if begin-form?25_0 begin-form?21_0 #f)))" +"(let-values(((lift-key_2)(if lift-key26_0 lift-key22_0(generate-lift-key))))" +"(let-values(((always-wrap?_0)(if always-wrap?27_0 always-wrap?23_0 #f)))" +"(let-values()" +"(let-values(((context_6)(expand-context-context ctx_30)))" +"(let-values(((phase_104)(expand-context-phase ctx_30)))" +"(let-values(((local?_0)(not begin-form?_0)))" +"((letrec-values(((loop_93)" +"(lambda(s_102 always-wrap?_1 ctx_31)" +"(begin" +" 'loop" +"(let-values(((lift-env_2)(if local?_0(box empty-env) #f)))" +"(let-values(((lift-ctx_0)" +"(let-values(((temp128_0)" +"(if local?_0" +"(make-local-lift" +" lift-env_2" +"(root-expand-context-counter ctx_31))" +"(make-top-level-lift ctx_31)))" +"((temp129_0)" +"(if(not local?_0)" +"(eq? context_6 'module)" +" #f)))" +"(make-lift-context6.1 temp129_0 #t temp128_0))))" +"(let-values(((capture-ctx_0)" +"(let-values(((v_185) ctx_31))" +"(let-values(((the-struct_61) v_185))" +"(if(expand-context/outer? the-struct_61)" +"(let-values(((inner130_0)" +"(let-values(((the-struct_62)" +"(root-expand-context/outer-inner" +" v_185)))" +"(if(expand-context/inner?" +" the-struct_62)" +"(let-values(((lift-key131_0)" +" lift-key_2)" +"((lifts132_0)" +" lift-ctx_0)" +"((lift-envs133_0)" +"(if local?_0" +"(cons" +" lift-env_2" +"(expand-context-lift-envs" +" ctx_31))" +"(expand-context-lift-envs" +" ctx_31)))" +"((module-lifts134_0)" +"(if(let-values(((or-part_267)" +" local?_0))" +"(if or-part_267" +" or-part_267" +"(not" +"(memq" +" context_6" +" '(top-level" +" module)))))" +"(expand-context-module-lifts" +" ctx_31)" +" lift-ctx_0)))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_62)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_62)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_62)" +"(root-expand-context/inner-defined-syms" +" the-struct_62)" +"(root-expand-context/inner-counter" +" the-struct_62)" +" lift-key131_0" +"(expand-context/inner-to-parsed?" +" the-struct_62)" +"(expand-context/inner-phase" +" the-struct_62)" +"(expand-context/inner-namespace" +" the-struct_62)" +"(expand-context/inner-just-once?" +" the-struct_62)" +"(expand-context/inner-module-begin-k" +" the-struct_62)" +"(expand-context/inner-allow-unbound?" +" the-struct_62)" +"(expand-context/inner-in-local-expand?" +" the-struct_62)" +"(expand-context/inner-stops" +" the-struct_62)" +"(expand-context/inner-declared-submodule-names" +" the-struct_62)" +" lifts132_0" +" lift-envs133_0" +" module-lifts134_0" +"(expand-context/inner-require-lifts" +" the-struct_62)" +"(expand-context/inner-to-module-lifts" +" the-struct_62)" +"(expand-context/inner-requires+provides" +" the-struct_62)" +"(expand-context/inner-observer" +" the-struct_62)" +"(expand-context/inner-for-serializable?" +" the-struct_62)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_62)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_62)))))" +"(expand-context/outer1.1" +" inner130_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_61)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_61)" +"(root-expand-context/outer-frame-id" +" the-struct_61)" +"(expand-context/outer-context the-struct_61)" +"(expand-context/outer-env the-struct_61)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_61)" +"(expand-context/outer-scopes the-struct_61)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_61)" +"(expand-context/outer-binding-layer" +" the-struct_61)" +"(expand-context/outer-reference-records" +" the-struct_61)" +"(expand-context/outer-only-immediate?" +" the-struct_61)" +"(expand-context/outer-need-eventually-defined" +" the-struct_61)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_61)" +"(expand-context/outer-name the-struct_61)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_61))))))" +"(let-values(((rebuild-s_0)(keep-properties-only s_102)))" +"(let-values(((exp-s_2)" +"(let-values(((s135_0) s_102)" +"((capture-ctx136_0) capture-ctx_0))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" s135_0" +" capture-ctx136_0))))" +"(let-values(((lifts_6)" +"(get-and-clear-lifts!" +"(expand-context-lifts capture-ctx_0))))" +"(let-values(((with-lifts-s_0)" +"(if(let-values(((or-part_163)" +"(pair? lifts_6)))" +"(if or-part_163" +" or-part_163" +" always-wrap?_1))" +"(let-values()" +"(if(expand-context-to-parsed? ctx_31)" +"(let-values()" +"(begin" +"(if expand-lifts?_0" +"(void)" +"(let-values()" +"(error" +" \"internal error: to-parsed mode without expanding lifts\")))" +"(wrap-lifts-as-parsed-let" +" lifts_6" +" exp-s_2" +" rebuild-s_0" +" ctx_31" +"(lambda(rhs_15 rhs-ctx_0)" +"(loop_93 rhs_15 #f rhs-ctx_0)))))" +"(let-values()" +"(if begin-form?_0" +"(let-values(((lifts137_0) lifts_6)" +"((exp-s138_0) exp-s_2)" +"((phase139_0)" +" phase_104))" +"(wrap-lifts-as-begin16.1" +" #f" +" #f" +" #f" +" #f" +" lifts137_0" +" exp-s138_0" +" phase139_0))" +"(wrap-lifts-as-let" +" lifts_6" +" exp-s_2" +" phase_104)))))" +"(let-values() exp-s_2))))" +"(if(let-values(((or-part_268)(not expand-lifts?_0)))" +"(if or-part_268" +" or-part_268" +"(let-values(((or-part_269)(null? lifts_6)))" +"(if or-part_269" +" or-part_269" +"(expand-context-to-parsed? ctx_31)))))" +"(let-values() with-lifts-s_0)" +"(let-values()" +"(begin" +"(let-values(((obs_28)" +"(expand-context-observer ctx_31)))" +"(if obs_28" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_28" +" 'letlift-loop" +" with-lifts-s_0)))" +"(void)))" +"(loop_93 with-lifts-s_0 #f ctx_31)))))))))))))))" +" loop_93)" +" s_210" +" always-wrap?_0" +" ctx_30))))))))))))))" +"(define-values" +"(expand-transformer47.1)" +"(lambda(always-wrap?37_0" +" always-wrap?43_0" +" begin-form?34_0" +" begin-form?40_0" +" context33_0" +" context39_1" +" expand-lifts?35_0" +" expand-lifts?41_0" +" keep-stops?38_0" +" keep-stops?44_0" +" lift-key36_0" +" lift-key42_0" +" s45_0" +" ctx46_0)" +"(begin" +" 'expand-transformer47" +"(let-values(((s_122) s45_0))" +"(let-values(((ctx_32) ctx46_0))" +"(let-values(((context_7)(if context39_1 context33_0 'expression)))" +"(let-values(((begin-form?_1)(if begin-form?40_0 begin-form?34_0 #f)))" +"(let-values(((expand-lifts?_1)(if expand-lifts?41_0 expand-lifts?35_0 #t)))" +"(let-values(((lift-key_3)(if lift-key42_0 lift-key36_0(generate-lift-key))))" +"(let-values(((always-wrap?_2)(if always-wrap?43_0 always-wrap?37_0 #f)))" +"(let-values(((keep-stops?_0)(if keep-stops?44_0 keep-stops?38_0 #f)))" +"(let-values()" +"(let-values()" +"(let-values(((trans-ctx_0)" +"(let-values(((keep-stops?148_0) keep-stops?_0))" +"(context->transformer-context55.1 keep-stops?148_0 #t ctx_32 context_7 #t))))" +"(let-values(((expand-lifts?142_0) expand-lifts?_1)" +"((begin-form?143_0) begin-form?_1)" +"((lift-key144_0) lift-key_3)" +"((always-wrap?145_0) always-wrap?_2))" +"(expand/capture-lifts30.1" +" always-wrap?145_0" +" #t" +" begin-form?143_0" +" #t" +" expand-lifts?142_0" +" #t" +" lift-key144_0" +" #t" +" s_122" +" trans-ctx_0))))))))))))))))" +"(define-values" +"(context->transformer-context55.1)" +"(lambda(keep-stops?50_0 keep-stops?51_0 ctx54_0 context52_0 context53_0)" +"(begin" +" 'context->transformer-context55" +"(let-values(((ctx_33) ctx54_0))" +"(let-values(((context_8)(if context53_0 context52_0 'expression)))" +"(let-values(((keep-stops?_1)(if keep-stops?51_0 keep-stops?50_0 #f)))" +"(let-values()" +"(let-values(((phase_105)(add1(expand-context-phase ctx_33))))" +"(let-values(((ns_73)(namespace->namespace-at-phase(expand-context-namespace ctx_33) phase_105)))" +"(begin" +"(namespace-visit-available-modules! ns_73 phase_105)" +"(let-values(((v_186) ctx_33))" +"(let-values(((the-struct_63) v_186))" +"(if(expand-context/outer? the-struct_63)" +"(let-values(((context149_0) context_8)" +"((scopes150_0) null)" +"((env151_0) empty-env)" +"((only-immediate?152_0)" +"(if keep-stops?_1(expand-context-only-immediate? ctx_33) #f))" +"((def-ctx-scopes153_0) #f)" +"((post-expansion-scope154_0) #f)" +"((inner155_0)" +"(let-values(((the-struct_64)(root-expand-context/outer-inner v_186)))" +"(if(expand-context/inner? the-struct_64)" +"(let-values(((phase156_0) phase_105)" +"((namespace157_0) ns_73)" +"((stops158_0)" +"(if keep-stops?_1" +"(expand-context-stops ctx_33)" +" empty-free-id-set)))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes the-struct_64)" +"(root-expand-context/inner-top-level-bind-scope the-struct_64)" +"(root-expand-context/inner-all-scopes-stx the-struct_64)" +"(root-expand-context/inner-defined-syms the-struct_64)" +"(root-expand-context/inner-counter the-struct_64)" +"(root-expand-context/inner-lift-key the-struct_64)" +"(expand-context/inner-to-parsed? the-struct_64)" +" phase156_0" +" namespace157_0" +"(expand-context/inner-just-once? the-struct_64)" +"(expand-context/inner-module-begin-k the-struct_64)" +"(expand-context/inner-allow-unbound? the-struct_64)" +"(expand-context/inner-in-local-expand? the-struct_64)" +" stops158_0" +"(expand-context/inner-declared-submodule-names the-struct_64)" +"(expand-context/inner-lifts the-struct_64)" +"(expand-context/inner-lift-envs the-struct_64)" +"(expand-context/inner-module-lifts the-struct_64)" +"(expand-context/inner-require-lifts the-struct_64)" +"(expand-context/inner-to-module-lifts the-struct_64)" +"(expand-context/inner-requires+provides the-struct_64)" +"(expand-context/inner-observer the-struct_64)" +"(expand-context/inner-for-serializable? the-struct_64)" +"(expand-context/inner-should-not-encounter-macros? the-struct_64)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_64)))))" +"(expand-context/outer1.1" +" inner155_0" +" post-expansion-scope154_0" +"(root-expand-context/outer-use-site-scopes the-struct_63)" +"(root-expand-context/outer-frame-id the-struct_63)" +" context149_0" +" env151_0" +"(expand-context/outer-post-expansion-scope-action the-struct_63)" +" scopes150_0" +" def-ctx-scopes153_0" +"(expand-context/outer-binding-layer the-struct_63)" +"(expand-context/outer-reference-records the-struct_63)" +" only-immediate?152_0" +"(expand-context/outer-need-eventually-defined the-struct_63)" +"(expand-context/outer-current-introduction-scopes the-struct_63)" +"(expand-context/outer-name the-struct_63)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_63))))))))))))))" +"(define-values" +"(expand+eval-for-syntaxes-binding63.1)" +"(lambda(log-next?58_0 log-next?59_0 rhs60_0 ids61_0 ctx62_0)" +"(begin" +" 'expand+eval-for-syntaxes-binding63" +"(let-values(((rhs_16) rhs60_0))" +"(let-values(((ids_19) ids61_0))" +"(let-values(((ctx_34) ctx62_0))" +"(let-values(((log-next?_0)(if log-next?59_0 log-next?58_0 #t)))" +"(let-values()" +"(let-values(((exp-rhs_0)" +"(let-values(((rhs159_0) rhs_16)((temp160_1)(as-named-context ctx_34 ids_19)))" +"(expand-transformer47.1 #f #f #f #f #f #f #f #f #f #f #f #f rhs159_0 temp160_1))))" +"(let-values(((phase_106)(add1(expand-context-phase ctx_34))))" +"(let-values(((parsed-rhs_0)" +"(if(expand-context-to-parsed? ctx_34)" +" exp-rhs_0" +"(let-values(((exp-rhs161_0) exp-rhs_0)" +"((temp162_1)" +"(let-values(((temp163_0)(as-to-parsed-context ctx_34)))" +"(context->transformer-context55.1 #f #f temp163_0 #f #f))))" +"(expand7.1 #f #f #f #f exp-rhs161_0 temp162_1)))))" +"(begin" +"(if log-next?_0" +"(let-values()" +"(let-values(((obs_29)(expand-context-observer ctx_34)))" +"(if obs_29(let-values()(let-values()(call-expand-observe obs_29 'next)))(void))))" +"(void))" +"(values" +" exp-rhs_0" +" parsed-rhs_0" +"(eval-for-bindings" +" ids_19" +" parsed-rhs_0" +" phase_106" +"(namespace->namespace-at-phase(expand-context-namespace ctx_34) phase_106)" +" ctx_34))))))))))))))" +"(define-values" +"(eval-for-syntaxes-binding)" +"(lambda(rhs_17 ids_20 ctx_35)" +"(begin" +"(let-values(((exp-rhs_1 parsed-rhs_1 vals_3)" +"(let-values(((rhs164_0) rhs_17)((ids165_0) ids_20)((ctx166_0) ctx_35))" +"(expand+eval-for-syntaxes-binding63.1 #f #f rhs164_0 ids165_0 ctx166_0))))" +" vals_3))))" +"(define-values" +"(eval-for-bindings)" +"(lambda(ids_21 p_44 phase_107 ns_74 ctx_36)" +"(begin" +"(let-values(((compiled_0)" +"(if(can-direct-eval? p_44 ns_74)" +" #f" +"(compile-single" +" p_44" +"(let-values(((ns167_0) ns_74)((phase168_1) phase_107))" +"(make-compile-context14.1 #f #f #f #f #f #f ns167_0 #t phase168_1 #t #f #f))))))" +"(let-values(((vals_4)" +"(call-with-values" +"(lambda()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-expand-context" +" ctx_36" +" 1/current-namespace" +" ns_74" +" eval-jit-enabled" +" #f)" +"(let-values()(if compiled_0(eval-single-top compiled_0 ns_74)(direct-eval p_44 ns_74)))))" +" list)))" +"(begin" +"(if(=(length vals_4)(length ids_21))" +"(void)" +" (let-values () (error \"wrong number of results (\" (length vals_4) \"vs.\" (length ids_21) \")\" \"from\" p_44)))" +" vals_4))))))" +"(define-values(keep-properties-only)(lambda(s_380)(begin(datum->syntax$1 #f 'props s_380 s_380))))" +"(define-values(keep-properties-only~)(lambda(s_381)(begin #f)))" +"(define-values" +"(keep-as-needed74.1)" +"(lambda(for-track?66_0" +" for-track?69_0" +" keep-for-error?68_0" +" keep-for-error?71_0" +" keep-for-parsed?67_0" +" keep-for-parsed?70_0" +" ctx72_0" +" s73_0)" +"(begin" +" 'keep-as-needed74" +"(let-values(((ctx_37) ctx72_0))" +"(let-values(((s_387) s73_0))" +"(let-values()" +"(let-values(((keep-for-parsed?_0)(if keep-for-parsed?70_0 keep-for-parsed?67_0 #f)))" +"(let-values(((keep-for-error?_0)(if keep-for-error?71_0 keep-for-error?68_0 #f)))" +"(let-values()" +"(let-values(((d_33)(syntax-e$1 s_387)))" +"(let-values(((keep-e_0)" +"(if(symbol? d_33)" +"(let-values() d_33)" +"(if(if(pair? d_33)(identifier?(car d_33)) #f)" +"(let-values()(syntax-e$1(car d_33)))" +"(let-values() #f)))))" +"(if(expand-context-to-parsed? ctx_37)" +"(let-values()" +"(if(let-values(((or-part_270) keep-for-parsed?_0))" +"(if or-part_270 or-part_270 keep-for-error?_0))" +"(datum->syntax$1 #f keep-e_0 s_387 s_387)" +" #f))" +"(let-values()" +"(syntax-rearm$1" +"(datum->syntax$1(syntax-disarm$1 s_387) keep-e_0 s_387 s_387)" +" s_387))))))))))))))" +"(define-values" +"(attach-disappeared-transformer-bindings)" +"(lambda(s_402 trans-idss_0)" +"(begin" +"(if(null? trans-idss_0)" +"(let-values() s_402)" +"(let-values()" +"(syntax-property$1" +" s_402" +" 'disappeared-binding" +"(append" +"(apply append trans-idss_0)" +"(let-values(((or-part_271)(syntax-property$1 s_402 'disappeared-binding)))" +"(if or-part_271 or-part_271 null)))))))))" +"(define-values" +"(increment-binding-layer)" +"(lambda(ids_22 ctx_38 layer-val_0)" +"(begin" +"(if((letrec-values(((loop_94)" +"(lambda(ids_23)" +"(begin" +" 'loop" +"(let-values(((or-part_272)(identifier? ids_23)))" +"(if or-part_272" +" or-part_272" +"(if(pair? ids_23)" +"(let-values(((or-part_273)(loop_94(car ids_23))))" +"(if or-part_273 or-part_273(loop_94(cdr ids_23))))" +" #f)))))))" +" loop_94)" +" ids_22)" +" layer-val_0" +"(expand-context-binding-layer ctx_38)))))" +"(define-values" +"(wrap-lifts-as-parsed-let)" +"(lambda(lifts_7 exp-s_3 rebuild-s_1 ctx_39 parse-rhs_0)" +"(begin" +"(let-values(((idss+keyss+rhss_0)(get-lifts-as-lists lifts_7)))" +"((letrec-values(((lets-loop_0)" +"(lambda(idss+keyss+rhss_1 rhs-ctx_1)" +"(begin" +" 'lets-loop" +"(if(null? idss+keyss+rhss_1)" +"(let-values() exp-s_3)" +"(let-values()" +"(let-values(((ids_24)(caar idss+keyss+rhss_1)))" +"(let-values(((keys_4)(cadar idss+keyss+rhss_1)))" +"(let-values(((rhs_18)(caddar idss+keyss+rhss_1)))" +"(let-values(((exp-rhs_2)(parse-rhs_0 rhs_18 rhs-ctx_1)))" +"(parsed-let-values17.1" +" rebuild-s_1" +"(list ids_24)" +"(list(list keys_4 exp-rhs_2))" +"(list" +"(lets-loop_0" +"(cdr idss+keyss+rhss_1)" +"(let-values(((v_187) rhs-ctx_1))" +"(let-values(((the-struct_65) v_187))" +"(if(expand-context/outer? the-struct_65)" +"(let-values(((env169_0)" +"(let-values(((lst_283) ids_24)((lst_119) keys_4))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_283)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_119)))" +"((letrec-values(((for-loop_62)" +"(lambda(env_3 lst_284 lst_285)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_284)" +"(pair? lst_285)" +" #f)" +"(let-values(((id_65)" +"(unsafe-car" +" lst_284))" +"((rest_155)" +"(unsafe-cdr" +" lst_284))" +"((key_81)" +"(unsafe-car" +" lst_285))" +"((rest_156)" +"(unsafe-cdr" +" lst_285)))" +"(let-values(((env_4)" +"(let-values(((env_5)" +" env_3))" +"(let-values(((env_6)" +"(let-values()" +"(env-extend" +" env_5" +" key_81" +"(local-variable1.1" +" id_65)))))" +"(values" +" env_6)))))" +"(if(not #f)" +"(for-loop_62" +" env_4" +" rest_155" +" rest_156)" +" env_4)))" +" env_3)))))" +" for-loop_62)" +"(expand-context-env rhs-ctx_1)" +" lst_283" +" lst_119))))" +"((inner170_0)(root-expand-context/outer-inner v_187)))" +"(expand-context/outer1.1" +" inner170_0" +"(root-expand-context/outer-post-expansion-scope the-struct_65)" +"(root-expand-context/outer-use-site-scopes the-struct_65)" +"(root-expand-context/outer-frame-id the-struct_65)" +"(expand-context/outer-context the-struct_65)" +" env169_0" +"(expand-context/outer-post-expansion-scope-action the-struct_65)" +"(expand-context/outer-scopes the-struct_65)" +"(expand-context/outer-def-ctx-scopes the-struct_65)" +"(expand-context/outer-binding-layer the-struct_65)" +"(expand-context/outer-reference-records the-struct_65)" +"(expand-context/outer-only-immediate? the-struct_65)" +"(expand-context/outer-need-eventually-defined the-struct_65)" +"(expand-context/outer-current-introduction-scopes the-struct_65)" +"(expand-context/outer-name the-struct_65)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_65)))))))))))))))))" +" lets-loop_0)" +" idss+keyss+rhss_0" +" ctx_39)))))" +"(define-values" +"(rename-transformer-target-in-context)" +"(lambda(t_53 ctx_40)" +"(begin" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_40)" +"(let-values()(1/rename-transformer-target t_53))))))" +"(define-values" +"(maybe-install-free=id-in-context!)" +"(lambda(val_68 id_66 phase_108 ctx_41)" +"(begin" +"(if(1/rename-transformer? val_68)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_41)" +"(let-values()(maybe-install-free=id! val_68 id_66 phase_108))))" +"(void)))))" +"(define-values" +"(stop-ids->all-stop-ids)" +"(lambda(stop-ids_0 phase_40)" +"(begin" +"(if(null? stop-ids_0)" +"(let-values() stop-ids_0)" +"(let-values()" +"(let-values(((p-core-stx_0)(syntax-shift-phase-level$1 core-stx phase_40)))" +"(if(if(= 1(length stop-ids_0))" +"(free-identifier=?$1(car stop-ids_0)(datum->syntax$1 p-core-stx_0 'module*) phase_40 phase_40)" +" #f)" +"(let-values() stop-ids_0)" +"(let-values()" +"(append" +" stop-ids_0" +"(reverse$1" +"(let-values(((lst_95) auto-stop-syms))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_95)))" +"((letrec-values(((for-loop_106)" +"(lambda(fold-var_85 lst_6)" +"(begin" +" 'for-loop" +"(if(pair? lst_6)" +"(let-values(((sym_63)(unsafe-car lst_6))((rest_46)(unsafe-cdr lst_6)))" +"(let-values(((fold-var_86)" +"(let-values(((fold-var_87) fold-var_85))" +"(let-values(((fold-var_59)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" p-core-stx_0" +" sym_63))" +" fold-var_87))))" +"(values fold-var_59)))))" +"(if(not #f)(for-loop_106 fold-var_86 rest_46) fold-var_86)))" +" fold-var_85)))))" +" for-loop_106)" +" null" +" lst_95)))))))))))))" +"(define-values" +"(auto-stop-syms)" +" '(begin" +" quote" +" set!" +" lambda" +" case-lambda" +" let-values" +" letrec-values" +" if" +" begin0" +" with-continuation-mark" +" letrec-syntaxes+values" +" #%app" +" #%expression" +" #%top" +" #%variable-reference))" +"(define-values" +"(module-expand-stop-ids)" +"(lambda(phase_109)" +"(begin" +"(let-values(((p-core-stx_1)(syntax-shift-phase-level$1 core-stx phase_109)))" +"(reverse$1" +"(let-values(((lst_219) module-stop-syms))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_219)))" +"((letrec-values(((for-loop_237)" +"(lambda(fold-var_220 lst_261)" +"(begin" +" 'for-loop" +"(if(pair? lst_261)" +"(let-values(((sym_17)(unsafe-car lst_261))((rest_138)(unsafe-cdr lst_261)))" +"(let-values(((fold-var_217)" +"(let-values(((fold-var_30) fold-var_220))" +"(let-values(((fold-var_218)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1 p-core-stx_1 sym_17))" +" fold-var_30))))" +"(values fold-var_218)))))" +"(if(not #f)(for-loop_237 fold-var_217 rest_138) fold-var_217)))" +" fold-var_220)))))" +" for-loop_237)" +" null" +" lst_219))))))))" +"(define-values" +"(module-stop-syms)" +"(append" +" auto-stop-syms" +" '(define-values define-syntaxes begin-for-syntax #%require #%provide module module* #%declare #%stratified-body)))" +"(define-values" +"(struct:internal-definition-context" +" internal-definition-context1.1" +" 1/internal-definition-context?" +" internal-definition-context-frame-id" +" internal-definition-context-scope" +" internal-definition-context-add-scope?" +" internal-definition-context-env-mixins)" +"(let-values(((struct:_64 make-_64 ?_64 -ref_64 -set!_64)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'internal-definition-context" +" #f" +" 4" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'internal-definition-context)))))" +"(values" +" struct:_64" +" make-_64" +" ?_64" +"(make-struct-field-accessor -ref_64 0 'frame-id)" +"(make-struct-field-accessor -ref_64 1 'scope)" +"(make-struct-field-accessor -ref_64 2 'add-scope?)" +"(make-struct-field-accessor -ref_64 3 'env-mixins))))" +"(define-values" +"(struct:env-mixin env-mixin2.1 env-mixin? env-mixin-id env-mixin-sym env-mixin-value env-mixin-cache)" +"(let-values(((struct:_65 make-_65 ?_65 -ref_65 -set!_65)" +"(let-values()" +"(let-values()" +"(make-struct-type 'env-mixin #f 4 0 #f null(current-inspector) #f '(0 1 2 3) #f 'env-mixin)))))" +"(values" +" struct:_65" +" make-_65" +" ?_65" +"(make-struct-field-accessor -ref_65 0 'id)" +"(make-struct-field-accessor -ref_65 1 'sym)" +"(make-struct-field-accessor -ref_65 2 'value)" +"(make-struct-field-accessor -ref_65 3 'cache))))" +"(define-values" +"(1/syntax-local-make-definition-context)" +"(let-values(((syntax-local-make-definition-context7_0)" +"(lambda(parent-ctx3_0 add-scope?4_0 parent-ctx5_0 add-scope?6_0)" +"(begin" +" 'syntax-local-make-definition-context7" +"(let-values(((parent-ctx_0)(if parent-ctx5_0 parent-ctx3_0 #f)))" +"(let-values(((add-scope?_0)(if add-scope?6_0 add-scope?4_0 #t)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_225)(not parent-ctx_0)))" +"(if or-part_225" +" or-part_225" +"(1/internal-definition-context? parent-ctx_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-make-definition-context" +" \"(or/c #f internal-definition-context?)\"" +" parent-ctx_0)))" +"(values))))" +"(let-values(((ctx_42)" +"(let-values(((temp42_1) 'syntax-local-make-definition-context))" +"(get-current-expand-context17.1 #f #f temp42_1 #t))))" +"(let-values(((frame-id_8)" +"(let-values(((or-part_227)(root-expand-context-frame-id ctx_42)))" +"(if or-part_227" +" or-part_227" +"(let-values(((or-part_228)" +"(if parent-ctx_0" +"(internal-definition-context-frame-id parent-ctx_0)" +" #f)))" +"(if or-part_228 or-part_228(gensym)))))))" +"(let-values(((sc_27)(new-scope 'intdef)))" +"(let-values(((def-ctx-scopes_4)(expand-context-def-ctx-scopes ctx_42)))" +"(begin" +"(if def-ctx-scopes_4" +"(void)" +"(let-values()" +" (error \"internal error: no box to accumulate definition-context scopes\")))" +"(set-box! def-ctx-scopes_4(cons sc_27(unbox def-ctx-scopes_4)))" +"(internal-definition-context1.1" +" frame-id_8" +" sc_27" +" add-scope?_0" +"(box null)))))))))))))))" +"(case-lambda" +"(()(begin 'syntax-local-make-definition-context(syntax-local-make-definition-context7_0 #f #f #f #f)))" +"((parent-ctx_1 add-scope?4_1)(syntax-local-make-definition-context7_0 parent-ctx_1 add-scope?4_1 #t #t))" +"((parent-ctx3_1)(syntax-local-make-definition-context7_0 parent-ctx3_1 #f #t #f)))))" +"(define-values" +"(1/syntax-local-bind-syntaxes)" +"(lambda(ids_25 s_403 intdef_0)" +"(begin" +" 'syntax-local-bind-syntaxes" +"(let-values((()" +"(begin" +"(if(if(list? ids_25)(andmap2 identifier? ids_25) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'syntax-local-bind-syntaxes \"(listof identifier?)\" ids_25)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_274)(not s_403)))(if or-part_274 or-part_274(syntax?$1 s_403)))" +"(void)" +" (let-values () (raise-argument-error 'syntax-local-bind-syntaxes \"(or/c syntax? #f)\" s_403)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/internal-definition-context? intdef_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-bind-syntaxes" +" \"internal-definition-context?\"" +" intdef_0)))" +"(values))))" +"(let-values(((ctx_43)" +"(let-values(((temp43_1) 'local-expand))(get-current-expand-context17.1 #f #f temp43_1 #t))))" +"(let-values((()" +"(begin" +"(let-values(((obs_30)(expand-context-observer ctx_43)))" +"(if obs_30" +"(let-values()(let-values()(call-expand-observe obs_30 'local-bind ids_25)))" +"(void)))" +"(values))))" +"(let-values(((phase_110)(expand-context-phase ctx_43)))" +"(let-values(((intdef-env_0)(add-intdef-bindings(expand-context-env ctx_43) intdef_0)))" +"(let-values(((intdef-ids_0)" +"(reverse$1" +"(let-values(((lst_286) ids_25))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_286)))" +"((letrec-values(((for-loop_171)" +"(lambda(fold-var_16 lst_181)" +"(begin" +" 'for-loop" +"(if(pair? lst_181)" +"(let-values(((id_67)(unsafe-car lst_181))" +"((rest_157)(unsafe-cdr lst_181)))" +"(let-values(((fold-var_223)" +"(let-values(((fold-var_233)" +" fold-var_16))" +"(let-values(((fold-var_234)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((pre-id_0)" +"(remove-use-site-scopes" +"(flip-introduction-scopes" +" id_67" +" ctx_43)" +" ctx_43)))" +"(let-values(((temp46_2)" +" #t))" +"(add-intdef-scopes21.1" +" #f" +" #f" +" temp46_2" +" #t" +" pre-id_0" +" intdef_0))))" +" fold-var_233))))" +"(values fold-var_234)))))" +"(if(not #f)" +"(for-loop_171 fold-var_223 rest_157)" +" fold-var_223)))" +" fold-var_16)))))" +" for-loop_171)" +" null" +" lst_286))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_31)(expand-context-observer ctx_43)))" +"(if obs_31" +"(let-values()" +"(let-values()(call-expand-observe obs_31 'rename-list intdef-ids_0)))" +"(void)))" +"(values))))" +"(let-values(((syms_21)" +"(reverse$1" +"(let-values(((lst_183) intdef-ids_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_183)))" +"((letrec-values(((for-loop_186)" +"(lambda(fold-var_235 lst_287)" +"(begin" +" 'for-loop" +"(if(pair? lst_287)" +"(let-values(((intdef-id_0)(unsafe-car lst_287))" +"((rest_158)(unsafe-cdr lst_287)))" +"(let-values(((fold-var_236)" +"(let-values(((fold-var_237)" +" fold-var_235))" +"(let-values(((fold-var_158)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((temp49_1)" +"(root-expand-context-counter" +" ctx_43))" +"((temp50_1)" +"(internal-definition-context-frame-id" +" intdef_0)))" +"(add-local-binding!35.1" +" temp50_1" +" #t" +" #f" +" #f" +" intdef-id_0" +" phase_110" +" temp49_1)))" +" fold-var_237))))" +"(values fold-var_158)))))" +"(if(not #f)" +"(for-loop_186 fold-var_236 rest_158)" +" fold-var_236)))" +" fold-var_235)))))" +" for-loop_186)" +" null" +" lst_183))))))" +"(let-values(((vals_5)" +"(if s_403" +"(let-values()" +"(let-values(((input-s_0)" +"(flip-introduction-scopes" +"(let-values(((temp53_2) #t))" +"(add-intdef-scopes21.1 #f #f temp53_2 #t s_403 intdef_0))" +" ctx_43)))" +"(let-values(((tmp-env_0)" +"(let-values(((lst_288) syms_21))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_288)))" +"((letrec-values(((for-loop_35)" +"(lambda(env_7 lst_164)" +"(begin" +" 'for-loop" +"(if(pair? lst_164)" +"(let-values(((sym_2)" +"(unsafe-car" +" lst_164))" +"((rest_159)" +"(unsafe-cdr" +" lst_164)))" +"(let-values(((env_8)" +"(let-values(((env_9)" +" env_7))" +"(let-values(((env_10)" +"(let-values()" +"(hash-set" +" env_9" +" sym_2" +" variable))))" +"(values" +" env_10)))))" +"(if(not #f)" +"(for-loop_35" +" env_8" +" rest_159)" +" env_8)))" +" env_7)))))" +" for-loop_35)" +" intdef-env_0" +" lst_288)))))" +"(let-values((()" +"(begin" +"(let-values(((obs_32)" +"(expand-context-observer ctx_43)))" +"(if obs_32" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_32 'enter-bind)))" +"(void)))" +"(values))))" +"(let-values(((vals_6)" +"(eval-for-syntaxes-binding" +" input-s_0" +" ids_25" +"(let-values(((temp54_1)" +"(let-values(((v_92) ctx_43))" +"(let-values(((the-struct_66) v_92))" +"(if(expand-context/outer?" +" the-struct_66)" +"(let-values(((env57_0) tmp-env_0)" +"((inner58_0)" +"(root-expand-context/outer-inner" +" v_92)))" +"(expand-context/outer1.1" +" inner58_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_66)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_66)" +"(root-expand-context/outer-frame-id" +" the-struct_66)" +"(expand-context/outer-context" +" the-struct_66)" +" env57_0" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_66)" +"(expand-context/outer-scopes" +" the-struct_66)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_66)" +"(expand-context/outer-binding-layer" +" the-struct_66)" +"(expand-context/outer-reference-records" +" the-struct_66)" +"(expand-context/outer-only-immediate?" +" the-struct_66)" +"(expand-context/outer-need-eventually-defined" +" the-struct_66)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_66)" +"(expand-context/outer-name" +" the-struct_66)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_66)))))" +"((temp55_1) 'expression)" +"((intdef56_0) intdef_0))" +"(make-local-expand-context37.1" +" temp55_1" +" intdef56_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp54_1)))))" +"(begin" +"(let-values(((obs_20)(expand-context-observer ctx_43)))" +"(if obs_20" +"(let-values()" +"(let-values()(call-expand-observe obs_20 'exit-bind)))" +"(void)))" +" vals_6))))))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_11) ids_25))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_11)))" +"((letrec-values(((for-loop_7)" +"(lambda(fold-var_176 lst_12)" +"(begin" +" 'for-loop" +"(if(pair? lst_12)" +"(let-values(((id_68)(unsafe-car lst_12))" +"((rest_2)(unsafe-cdr lst_12)))" +"(let-values(((fold-var_238)" +"(let-values(((fold-var_35)" +" fold-var_176))" +"(let-values(((fold-var_239)" +"(let-values()" +"(cons" +"(let-values()" +" variable)" +" fold-var_35))))" +"(values fold-var_239)))))" +"(if(not #f)" +"(for-loop_7 fold-var_238 rest_2)" +" fold-var_238)))" +" fold-var_176)))))" +" for-loop_7)" +" null" +" lst_11))))))))" +"(let-values(((env-mixins_0)(internal-definition-context-env-mixins intdef_0)))" +"(begin" +"(set-box!" +" env-mixins_0" +"(append" +"(reverse$1" +"(let-values(((lst_135) intdef-ids_0)((lst_289) syms_21)((lst_98) vals_5))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_135)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_289)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_98)))" +"((letrec-values(((for-loop_113)" +"(lambda(fold-var_38 lst_99 lst_14 lst_290)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_99)" +"(if(pair? lst_14)(pair? lst_290) #f)" +" #f)" +"(let-values(((intdef-id_1)(unsafe-car lst_99))" +"((rest_160)(unsafe-cdr lst_99))" +"((sym_64)(unsafe-car lst_14))" +"((rest_161)(unsafe-cdr lst_14))" +"((val_9)(unsafe-car lst_290))" +"((rest_162)(unsafe-cdr lst_290)))" +"(let-values(((fold-var_240)" +"(let-values(((fold-var_241)" +" fold-var_38))" +"(let-values(((fold-var_179)" +"(let-values()" +"(cons" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_9" +" intdef-id_1" +" phase_110" +" ctx_43)" +"(env-mixin2.1" +" intdef-id_1" +" sym_64" +" val_9" +"(make-weak-hasheq))))" +" fold-var_241))))" +"(values fold-var_179)))))" +"(if(not #f)" +"(for-loop_113" +" fold-var_240" +" rest_160" +" rest_161" +" rest_162)" +" fold-var_240)))" +" fold-var_38)))))" +" for-loop_113)" +" null" +" lst_135" +" lst_289" +" lst_98))))" +"(unbox env-mixins_0)))" +"(let-values(((obs_33)(expand-context-observer ctx_43)))" +"(if obs_33" +"(let-values()(let-values()(call-expand-observe obs_33 'exit-local-bind)))" +"(void)))))))))))))))))))" +"(define-values" +"(1/internal-definition-context-binding-identifiers)" +"(lambda(intdef_1)" +"(begin" +" 'internal-definition-context-binding-identifiers" +"(begin" +"(if(1/internal-definition-context? intdef_1)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'internal-definition-context-binding-identifiers" +" \"internal-definition-context?\"" +" intdef_1)))" +"(reverse$1" +"(let-values(((lst_280)(unbox(internal-definition-context-env-mixins intdef_1))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_280)))" +"((letrec-values(((for-loop_240)" +"(lambda(fold-var_181 lst_281)" +"(begin" +" 'for-loop" +"(if(pair? lst_281)" +"(let-values(((env-mixin_0)(unsafe-car lst_281))" +"((rest_154)(unsafe-cdr lst_281)))" +"(let-values(((fold-var_229)" +"(let-values(((fold-var_230) fold-var_181))" +"(let-values(((fold-var_231)" +"(let-values()" +"(cons" +"(let-values()(env-mixin-id env-mixin_0))" +" fold-var_230))))" +"(values fold-var_231)))))" +"(if(not #f)(for-loop_240 fold-var_229 rest_154) fold-var_229)))" +" fold-var_181)))))" +" for-loop_240)" +" null" +" lst_280))))))))" +"(define-values" +"(1/internal-definition-context-introduce)" +"(let-values(((internal-definition-context-introduce13_0)" +"(lambda(intdef11_0 s12_1 mode9_0 mode10_0)" +"(begin" +" 'internal-definition-context-introduce13" +"(let-values(((intdef_2) intdef11_0))" +"(let-values(((s_404) s12_1))" +"(let-values(((mode_12)(if mode10_0 mode9_0 'flip)))" +"(let-values()" +"(begin" +"(if(1/internal-definition-context? intdef_2)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'internal-definition-context-introduce" +" \"internal-definition-context?\"" +" intdef_2)))" +"(if(syntax?$1 s_404)" +"(void)" +"(let-values()" +" (raise-argument-error 'internal-definition-context-introduce \"syntax?\" s_404)))" +"(let-values(((temp61_1)" +"(let-values(((tmp_32) mode_12))" +"(if(equal? tmp_32 'add)" +"(let-values() add-scope)" +"(if(equal? tmp_32 'remove)" +"(let-values() remove-scope)" +"(if(equal? tmp_32 'flip)" +"(let-values() flip-scope)" +"(let-values()" +"(raise-argument-error" +" 1/internal-definition-context-introduce" +" \"(or/c 'add 'remove 'flip)\"" +" mode_12))))))))" +"(add-intdef-scopes21.1 temp61_1 #t #f #f s_404 intdef_2)))))))))))" +"(case-lambda" +"((intdef_3 s_405)" +"(begin 'internal-definition-context-introduce(internal-definition-context-introduce13_0 intdef_3 s_405 #f #f)))" +"((intdef_4 s_59 mode9_1)(internal-definition-context-introduce13_0 intdef_4 s_59 mode9_1 #t)))))" +"(define-values" +"(1/internal-definition-context-seal)" +"(lambda(intdef_5)" +"(begin" +" 'internal-definition-context-seal" +"(begin" +"(if(1/internal-definition-context? intdef_5)" +"(void)" +"(let-values()" +" (raise-argument-error 'internal-definition-context-seal \"internal-definition-context?\" intdef_5)))" +"(void)))))" +"(define-values" +"(1/identifier-remove-from-definition-context)" +"(lambda(id_69 intdef_6)" +"(begin" +" 'identifier-remove-from-definition-context" +"(begin" +"(if(identifier? id_69)" +"(void)" +" (let-values () (raise-argument-error 'identifier-remove-from-definition-context \"identifier?\" id_69)))" +"(if(let-values(((or-part_275)(1/internal-definition-context? intdef_6)))" +"(if or-part_275 or-part_275(if(list? intdef_6)(andmap2 1/internal-definition-context? intdef_6) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'identifier-remove-from-definition-context" +" \"(or/c internal-definition-context? (listof internal-definition-context?))\"" +" intdef_6)))" +"(let-values(((x_76)" +"(let-values(((a_45) intdef_6))" +"(if(list? a_45)" +"(let-values()(reverse$1 a_45))" +"(if(not a_45)(let-values() null)(let-values()(list a_45)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_243)" +"(lambda(id_70 a_46)" +"(begin" +" 'for-loop" +"(if(pair? a_46)" +"(let-values(((intdef_7)(car a_46)))" +"(let-values(((id_71)" +"(let-values(((id_72) id_70))" +"(let-values(((id_73)" +"(let-values()" +"(1/internal-definition-context-introduce" +" intdef_7" +" id_72" +" 'remove))))" +"(values id_73)))))" +"(if(not #f)(for-loop_243 id_71(cdr a_46)) id_71)))" +" id_70)))))" +" for-loop_243)" +" id_69" +" x_76)))))))" +"(define-values" +"(add-intdef-bindings)" +"(lambda(env_11 intdefs_0)" +"(begin" +"(let-values(((x_77)" +"(let-values(((a_47) intdefs_0))" +"(if(list? a_47)" +"(let-values()(reverse$1 a_47))" +"(if(not a_47)(let-values() null)(let-values()(list a_47)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_89)" +"(lambda(env_12 a_48)" +"(begin" +" 'for-loop" +"(if(pair? a_48)" +"(let-values(((intdef_8)(car a_48)))" +"(let-values(((env_13)" +"(let-values(((env_14) env_12))" +"(let-values(((env_15)" +"(let-values()" +"(let-values(((env-mixins_1)" +"(unbox" +"(internal-definition-context-env-mixins" +" intdef_8))))" +"((letrec-values(((loop_95)" +"(lambda(env_16 env-mixins_2)" +"(begin" +" 'loop" +"(if(null? env-mixins_2)" +"(let-values() env_16)" +"(let-values()" +"(let-values(((env-mixin_1)" +"(car" +" env-mixins_2)))" +"(let-values(((or-part_206)" +"(hash-ref" +"(env-mixin-cache" +" env-mixin_1)" +" env_16" +" #f)))" +"(if or-part_206" +" or-part_206" +"(let-values(((new-env_0)" +"(env-extend" +"(loop_95" +" env_16" +"(cdr" +" env-mixins_2))" +"(env-mixin-sym" +" env-mixin_1)" +"(env-mixin-value" +" env-mixin_1))))" +"(begin" +"(hash-set!" +"(env-mixin-cache" +" env-mixin_1)" +" env_16" +" new-env_0)" +" new-env_0)))))))))))" +" loop_95)" +" env_14" +" env-mixins_1)))))" +"(values env_15)))))" +"(if(not #f)(for-loop_89 env_13(cdr a_48)) env_13)))" +" env_12)))))" +" for-loop_89)" +" env_11" +" x_77))))))" +"(define-values" +"(add-intdef-scopes21.1)" +"(lambda(action16_0 action18_0 always?15_0 always?17_0 s19_0 intdefs20_0)" +"(begin" +" 'add-intdef-scopes21" +"(let-values(((s_406) s19_0))" +"(let-values(((intdefs_1) intdefs20_0))" +"(let-values(((always?_0)(if always?17_0 always?15_0 #f)))" +"(let-values(((action_0)(if action18_0 action16_0 add-scope)))" +"(let-values()" +"(let-values(((x_78)" +"(let-values(((a_49) intdefs_1))" +"(if(list? a_49)" +"(let-values()(reverse$1 a_49))" +"(if(not a_49)(let-values() null)(let-values()(list a_49)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_244)" +"(lambda(s_407 a_50)" +"(begin" +" 'for-loop" +"(if(pair? a_50)" +"(let-values(((intdef_9)(car a_50)))" +"(let-values(((s_408)" +"(let-values(((s_152) s_407))" +"(if(let-values(((or-part_276) always?_0))" +"(if or-part_276" +" or-part_276" +"(internal-definition-context-add-scope?" +" intdef_9)))" +"(let-values(((s_90) s_152))" +"(let-values(((s_409)" +"(let-values()" +"(action_0" +" s_90" +"(internal-definition-context-scope" +" intdef_9)))))" +"(values s_409)))" +" s_152))))" +"(if(not #f)(for-loop_244 s_408(cdr a_50)) s_408)))" +" s_407)))))" +" for-loop_244)" +" s_406" +" x_78)))))))))))" +"(define-values" +"(make-local-expand-context37.1)" +"(lambda(context24_0" +" intdefs26_0" +" phase25_0" +" phase31_0" +" stop-ids27_0" +" stop-ids33_0" +" to-parsed-ok?28_0" +" to-parsed-ok?34_0" +" track-to-be-defined?29_0" +" track-to-be-defined?35_0" +" ctx36_0)" +"(begin" +" 'make-local-expand-context37" +"(let-values(((ctx_44) ctx36_0))" +"(let-values(((context_9) context24_0))" +"(let-values(((phase_111)(if phase31_0 phase25_0(expand-context-phase ctx_44))))" +"(let-values(((intdefs_2) intdefs26_0))" +"(let-values(((stop-ids_1)(if stop-ids33_0 stop-ids27_0 #f)))" +"(let-values(((to-parsed-ok?_0)(if to-parsed-ok?34_0 to-parsed-ok?28_0 #f)))" +"(let-values(((track-to-be-defined?_0)(if track-to-be-defined?35_0 track-to-be-defined?29_0 #f)))" +"(let-values()" +"(let-values(((same-kind?_0)" +"(let-values(((or-part_277)(eq? context_9(expand-context-context ctx_44))))" +"(if or-part_277" +" or-part_277" +"(if(list? context_9)(list?(expand-context-context ctx_44)) #f)))))" +"(let-values(((all-stop-ids_0)" +"(if stop-ids_1(stop-ids->all-stop-ids stop-ids_1 phase_111) #f)))" +"(let-values(((def-ctx-scopes_5)" +"(if(expand-context-def-ctx-scopes ctx_44)" +"(unbox(expand-context-def-ctx-scopes ctx_44))" +" null)))" +"(let-values(((v_188) ctx_44))" +"(let-values(((the-struct_67) v_188))" +"(if(expand-context/outer? the-struct_67)" +"(let-values(((context62_0) context_9)" +"((env63_0)(add-intdef-bindings(expand-context-env ctx_44) intdefs_2))" +"((use-site-scopes64_0)" +"(if(let-values(((or-part_163)(eq? context_9 'module)))" +"(if or-part_163" +" or-part_163" +"(let-values(((or-part_278)(eq? context_9 'module-begin)))" +"(if or-part_278 or-part_278(list? context_9)))))" +"(let-values(((or-part_279)" +"(root-expand-context-use-site-scopes ctx_44)))" +"(if or-part_279 or-part_279(box null)))" +" #f))" +"((frame-id65_0)" +"(let-values(((x_3)" +"(let-values(((a_51) intdefs_2))" +"(if(list? a_51)" +"(let-values()(reverse$1 a_51))" +"(if(not a_51)" +"(let-values() null)" +"(let-values()(list a_51)))))))" +"(begin" +" #t" +"((letrec-values(((for-loop_245)" +"(lambda(frame-id_9 a_52)" +"(begin" +" 'for-loop" +"(if(pair? a_52)" +"(let-values(((intdef_10)(car a_52)))" +"(let-values(((frame-id_10)" +"(let-values(((frame-id_11)" +" frame-id_9))" +"(let-values(((frame-id_12)" +"(let-values()" +"(let-values(((i-frame-id_0)" +"(internal-definition-context-frame-id" +" intdef_10)))" +"(if(if frame-id_11" +"(if i-frame-id_0" +"(not" +"(eq?" +" frame-id_11" +" i-frame-id_0))" +" #f)" +" #f)" +"(let-values()" +" 'all)" +"(let-values()" +"(let-values(((or-part_280)" +" frame-id_11))" +"(if or-part_280" +" or-part_280" +" i-frame-id_0))))))))" +"(values frame-id_12)))))" +"(if(not #f)" +"(for-loop_245 frame-id_10(cdr a_52))" +" frame-id_10)))" +" frame-id_9)))))" +" for-loop_245)" +"(root-expand-context-frame-id ctx_44)" +" x_3))))" +"((post-expansion-scope66_0)" +"(if intdefs_2" +"(new-scope 'macro)" +"(if same-kind?_0" +"(if(memq context_9 '(module module-begin top-level))" +"(root-expand-context-post-expansion-scope ctx_44)" +" #f)" +" #f)))" +"((post-expansion-scope-action67_0)" +"(if intdefs_2" +"(lambda(s_111 placeholder-sc_0)" +"(begin" +" 'post-expansion-scope-action67" +"(let-values(((s73_1) s_111)((intdefs74_0) intdefs_2))" +"(add-intdef-scopes21.1 #f #f #f #f s73_1 intdefs74_0))))" +"(expand-context-post-expansion-scope-action ctx_44)))" +"((scopes68_0)(append def-ctx-scopes_5(expand-context-scopes ctx_44)))" +"((only-immediate?69_0)(not stop-ids_1))" +"((current-introduction-scopes70_0) null)" +"((need-eventually-defined71_0)" +"(let-values(((ht_133)(expand-context-need-eventually-defined ctx_44)))" +"(if track-to-be-defined?_0" +"(let-values() ht_133)" +"(if ht_133(let-values()(make-hasheqv))(let-values() #f)))))" +"((inner72_0)" +"(let-values(((the-struct_68)(root-expand-context/outer-inner v_188)))" +"(if(expand-context/inner? the-struct_68)" +"(let-values(((to-parsed?75_0)" +"(if to-parsed-ok?_0" +"(expand-context-to-parsed? ctx_44)" +" #f))" +"((just-once?76_0) #f)" +"((in-local-expand?77_0) #t)" +"((stops78_0)" +"(free-id-set" +" phase_111" +"(let-values(((or-part_281) all-stop-ids_0))" +"(if or-part_281 or-part_281 null)))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes the-struct_68)" +"(root-expand-context/inner-top-level-bind-scope the-struct_68)" +"(root-expand-context/inner-all-scopes-stx the-struct_68)" +"(root-expand-context/inner-defined-syms the-struct_68)" +"(root-expand-context/inner-counter the-struct_68)" +"(root-expand-context/inner-lift-key the-struct_68)" +" to-parsed?75_0" +"(expand-context/inner-phase the-struct_68)" +"(expand-context/inner-namespace the-struct_68)" +" just-once?76_0" +"(expand-context/inner-module-begin-k the-struct_68)" +"(expand-context/inner-allow-unbound? the-struct_68)" +" in-local-expand?77_0" +" stops78_0" +"(expand-context/inner-declared-submodule-names the-struct_68)" +"(expand-context/inner-lifts the-struct_68)" +"(expand-context/inner-lift-envs the-struct_68)" +"(expand-context/inner-module-lifts the-struct_68)" +"(expand-context/inner-require-lifts the-struct_68)" +"(expand-context/inner-to-module-lifts the-struct_68)" +"(expand-context/inner-requires+provides the-struct_68)" +"(expand-context/inner-observer the-struct_68)" +"(expand-context/inner-for-serializable? the-struct_68)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_68)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_68)))))" +"(expand-context/outer1.1" +" inner72_0" +" post-expansion-scope66_0" +" use-site-scopes64_0" +" frame-id65_0" +" context62_0" +" env63_0" +" post-expansion-scope-action67_0" +" scopes68_0" +"(expand-context/outer-def-ctx-scopes the-struct_67)" +"(expand-context/outer-binding-layer the-struct_67)" +"(expand-context/outer-reference-records the-struct_67)" +" only-immediate?69_0" +" need-eventually-defined71_0" +" current-introduction-scopes70_0" +"(expand-context/outer-name the-struct_67)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_67))))))))))))))))))" +"(define-values" +"(flip-introduction-scopes)" +"(lambda(s_410 ctx_45)(begin(flip-scopes s_410(expand-context-current-introduction-scopes ctx_45)))))" +"(define-values" +"(1/syntax-transforming?)" +"(lambda()" +"(begin" +" 'syntax-transforming?" +"(if(let-values(((temp62_0) #t))(get-current-expand-context17.1 temp62_0 #t #f #f)) #t #f))))" +"(define-values" +"(1/syntax-transforming-with-lifts?)" +"(lambda()" +"(begin" +" 'syntax-transforming-with-lifts?" +"(let-values(((ctx_46)(let-values(((temp63_1) #t))(get-current-expand-context17.1 temp63_1 #t #f #f))))" +"(if ctx_46(if(expand-context-lifts ctx_46) #t #f) #f)))))" +"(define-values" +"(1/syntax-transforming-module-expression?)" +"(lambda()" +"(begin" +" 'syntax-transforming-module-expression?" +"(let-values(((ctx_12)(let-values(((temp64_1) #t))(get-current-expand-context17.1 temp64_1 #t #f #f))))" +"(if ctx_12(if(expand-context-to-module-lifts ctx_12) #t #f) #f)))))" +"(define-values" +"(1/syntax-local-transforming-module-provides?)" +"(lambda()" +"(begin" +" 'syntax-local-transforming-module-provides?" +"(let-values(((ctx_47)(let-values(((temp65_1) #t))(get-current-expand-context17.1 temp65_1 #t #f #f))))" +"(if ctx_47(if(expand-context-requires+provides ctx_47) #t #f) #f)))))" +"(define-values" +"(1/syntax-local-context)" +"(lambda()" +"(begin" +" 'syntax-local-context" +"(let-values(((ctx_13)" +"(let-values(((temp66_2) 'syntax-local-context))" +"(get-current-expand-context17.1 #f #f temp66_2 #t))))" +"(expand-context-context ctx_13)))))" +"(define-values" +"(1/syntax-local-introduce)" +"(lambda(s_411)" +"(begin" +" 'syntax-local-introduce" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_411)" +"(void)" +" (let-values () (raise-argument-error 'syntax-local-introduce \"syntax?\" s_411)))" +"(values))))" +"(let-values(((ctx_48)" +"(let-values(((temp67_0) 'syntax-local-introduce))" +"(get-current-expand-context17.1 #f #f temp67_0 #t))))" +"(flip-introduction-scopes s_411 ctx_48))))))" +"(define-values" +"(1/syntax-local-identifier-as-binding)" +"(lambda(id_3)" +"(begin" +" 'syntax-local-identifier-as-binding" +"(let-values((()" +"(begin" +"(if(identifier? id_3)" +"(void)" +" (let-values () (raise-argument-error 1/syntax-local-identifier-as-binding \"identifier?\" id_3)))" +"(values))))" +"(let-values(((ctx_49)" +"(let-values(((temp68_0) 'syntax-local-identifier-as-binding))" +"(get-current-expand-context17.1 #f #f temp68_0 #t))))" +"(remove-use-site-scopes id_3 ctx_49))))))" +"(define-values" +"(1/syntax-local-phase-level)" +"(lambda()" +"(begin" +" 'syntax-local-phase-level" +"(let-values(((ctx_50)(let-values(((temp69_0) #t))(get-current-expand-context17.1 temp69_0 #t #f #f))))" +"(if ctx_50(expand-context-phase ctx_50) 0)))))" +"(define-values" +"(1/syntax-local-name)" +"(lambda()" +"(begin" +" 'syntax-local-name" +"(let-values(((ctx_14)" +"(let-values(((temp70_0) 'syntax-local-name))(get-current-expand-context17.1 #f #f temp70_0 #t))))" +"(let-values(((id_4)(expand-context-name ctx_14)))" +"(if id_4(datum->syntax$1 #f(syntax-e$1 id_4) id_4) #f))))))" +"(define-values" +"(1/make-syntax-introducer)" +"(let-values(((make-syntax-introducer3_0)" +"(lambda(as-use-site?1_0 as-use-site?2_0)" +"(begin" +" 'make-syntax-introducer3" +"(let-values(((as-use-site?_0)(if as-use-site?2_0 as-use-site?1_0 #f)))" +"(let-values()" +"(let-values(((sc_28)(new-scope(if as-use-site?_0 'use-site 'macro))))" +"(let-values(((core74_0)" +"(lambda(s73_2 mode71_0 mode72_0)" +"(begin" +" 'core74" +"(let-values(((s_175) s73_2))" +"(let-values(((mode_13)(if mode72_0 mode71_0 'flip)))" +"(let-values()" +"(begin" +"(if(syntax?$1 s_175)" +"(void)" +"(let-values()" +" (raise-argument-error 'syntax-introducer \"syntax?\" s_175)))" +"(let-values(((tmp_33) mode_13))" +"(if(equal? tmp_33 'add)" +"(let-values()(add-scope s_175 sc_28))" +"(if(equal? tmp_33 'remove)" +"(let-values()(remove-scope s_175 sc_28))" +"(if(equal? tmp_33 'flip)" +"(let-values()(flip-scope s_175 sc_28))" +"(let-values()" +"(raise-argument-error" +" 'syntax-introducer" +" \"(or/c 'add 'remove 'flip)\"" +" mode_13))))))))))))))" +"(case-lambda" +"((s_6)(core74_0 s_6 #f #f))" +"((s_75 mode71_1)(core74_0 s_75 mode71_1 #t)))))))))))" +"(case-lambda" +"(()(begin 'make-syntax-introducer(make-syntax-introducer3_0 #f #f)))" +"((as-use-site?1_1)(make-syntax-introducer3_0 as-use-site?1_1 #t)))))" +"(define-values" +"(1/make-syntax-delta-introducer)" +"(let-values(((make-syntax-delta-introducer9_0)" +"(lambda(ext-s7_0 base-s8_0 phase5_0 phase6_1)" +"(begin" +" 'make-syntax-delta-introducer9" +"(let-values(((ext-s_0) ext-s7_0))" +"(let-values(((base-s_0) base-s8_0))" +"(let-values(((phase_112)(if phase6_1 phase5_0(1/syntax-local-phase-level))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 ext-s_0)" +"(void)" +"(let-values()" +" (raise-argument-error 'make-syntax-delta-introducer \"syntax?\" ext-s_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_166)(syntax?$1 base-s_0)))" +"(if or-part_166 or-part_166(not base-s_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-syntax-delta-introducer" +" \"(or/c syntax? #f)\"" +" base-s_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(phase? phase_112)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-syntax-delta-introducer" +" phase?-string" +" phase_112)))" +"(values))))" +"(let-values(((ext-scs_0)(syntax-scope-set ext-s_0 phase_112)))" +"(let-values(((base-scs_0)" +"(syntax-scope-set" +"(let-values(((or-part_167) base-s_0))" +"(if or-part_167 or-part_167 empty-syntax))" +" phase_112)))" +"(let-values(((use-base-scs_0)" +"(if(subset? base-scs_0 ext-scs_0)" +" base-scs_0" +"(let-values(((or-part_168)" +"(if(identifier? base-s_0)" +"(let-values(((temp78_2) #t))" +"(resolve33.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp78_2" +" #t" +" base-s_0" +" phase_112))" +" #f)))" +"(if or-part_168 or-part_168(seteq))))))" +"(let-values(((delta-scs_0)" +"(set->list(set-subtract ext-scs_0 use-base-scs_0))))" +"(let-values(((maybe-taint_0)" +"(if(syntax-clean? ext-s_0) values syntax-taint$1)))" +"(let-values(((core82_0)" +"(lambda(s81_0 mode79_0 mode80_0)" +"(begin" +" 'core82" +"(let-values(((s_412) s81_0))" +"(let-values(((mode_14)(if mode80_0 mode79_0 'add)))" +"(let-values()" +"(maybe-taint_0" +"(let-values(((tmp_34) mode_14))" +"(if(equal? tmp_34 'add)" +"(let-values()(add-scopes s_412 delta-scs_0))" +"(if(equal? tmp_34 'remove)" +"(let-values()" +"(remove-scopes s_412 delta-scs_0))" +"(if(equal? tmp_34 'flip)" +"(let-values()" +"(flip-scopes s_412 delta-scs_0))" +"(let-values()" +"(raise-argument-error" +" 'syntax-introducer" +" \"(or/c 'add 'remove 'flip)\"" +" mode_14))))))))))))))" +"(case-lambda" +"((s_181)(core82_0 s_181 #f #f))" +"((s_399 mode79_1)(core82_0 s_399 mode79_1 #t))))))))))))))))))))" +"(case-lambda" +"((ext-s_1 base-s_1)(begin 'make-syntax-delta-introducer(make-syntax-delta-introducer9_0 ext-s_1 base-s_1 #f #f)))" +"((ext-s_2 base-s_2 phase5_1)(make-syntax-delta-introducer9_0 ext-s_2 base-s_2 phase5_1 #t)))))" +"(define-values" +"(do-syntax-local-value17.1)" +"(lambda(immediate?11_0 who13_0 id14_0 intdef15_0 failure-thunk16_0)" +"(begin" +" 'do-syntax-local-value17" +"(let-values(((who_15) who13_0))" +"(let-values(((id_74) id14_0))" +"(let-values(((intdef_11) intdef15_0))" +"(let-values(((failure-thunk_0) failure-thunk16_0))" +"(let-values(((immediate?_1) immediate?11_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(identifier? id_74)" +"(void)" +" (let-values () (raise-argument-error who_15 \"identifier?\" id_74)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_73)(not failure-thunk_0)))" +"(if or-part_73" +" or-part_73" +"(if(procedure? failure-thunk_0)" +"(procedure-arity-includes? failure-thunk_0 0)" +" #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_15" +" \"(or #f (procedure-arity-includes/c 0))\"" +" failure-thunk_0)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_74)(not intdef_11)))" +"(if or-part_74 or-part_74(1/internal-definition-context? intdef_11)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_15" +" \"(or #f internal-definition-context?)\"" +" failure-thunk_0)))" +"(values))))" +"(let-values(((current-ctx_0)" +"(let-values(((who84_0) who_15))" +"(get-current-expand-context17.1 #f #f who84_0 #t))))" +"(let-values(((ctx_51)" +"(if intdef_11" +"(let-values(((v_189) current-ctx_0))" +"(let-values(((the-struct_8) v_189))" +"(if(expand-context/outer? the-struct_8)" +"(let-values(((env85_0)" +"(add-intdef-bindings" +"(expand-context-env current-ctx_0)" +" intdef_11))" +"((inner86_0)(root-expand-context/outer-inner v_189)))" +"(expand-context/outer1.1" +" inner86_0" +"(root-expand-context/outer-post-expansion-scope the-struct_8)" +"(root-expand-context/outer-use-site-scopes the-struct_8)" +"(root-expand-context/outer-frame-id the-struct_8)" +"(expand-context/outer-context the-struct_8)" +" env85_0" +"(expand-context/outer-post-expansion-scope-action the-struct_8)" +"(expand-context/outer-scopes the-struct_8)" +"(expand-context/outer-def-ctx-scopes the-struct_8)" +"(expand-context/outer-binding-layer the-struct_8)" +"(expand-context/outer-reference-records the-struct_8)" +"(expand-context/outer-only-immediate? the-struct_8)" +"(expand-context/outer-need-eventually-defined the-struct_8)" +"(expand-context/outer-current-introduction-scopes the-struct_8)" +"(expand-context/outer-name the-struct_8)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_8))))" +" current-ctx_0)))" +"(let-values((()" +"(begin" +"(let-values(((obs_34)(expand-context-observer ctx_51)))" +"(if obs_34" +"(let-values()" +"(let-values()(call-expand-observe obs_34 'local-value id_74)))" +"(void)))" +"(values))))" +"(let-values(((phase_82)(expand-context-phase ctx_51)))" +"((letrec-values(((loop_96)" +"(lambda(id_75)" +"(begin" +" 'loop" +"(let-values(((b_20)" +"(if immediate?_1" +"(let-values(((temp89_2) #t))" +"(resolve+shift30.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp89_2" +" #t" +" #f" +" #f" +" id_75" +" phase_82))" +"(resolve+shift/extra-inspector" +" id_75" +" phase_82" +"(expand-context-namespace ctx_51)))))" +"(begin" +"(let-values(((obs_35)(expand-context-observer ctx_51)))" +"(if obs_35" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_35 'resolve id_75)))" +"(void)))" +"(if(not b_20)" +"(let-values()" +"(begin" +"(let-values(((obs_36)" +"(expand-context-observer ctx_51)))" +"(if obs_36" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_36" +" 'local-value-result" +" #f)))" +"(void)))" +"(if failure-thunk_0" +"(failure-thunk_0)" +"(error" +" 'syntax-local-value" +" \"unbound identifier: ~v\"" +" id_75))))" +"(let-values()" +"(let-values(((v_190 primitive?_7 insp_17)" +"(let-values(((temp93_3) #t))" +"(lookup17.1" +" #f" +" #f" +" temp93_3" +" #t" +" b_20" +" ctx_51" +" id_75))))" +"(if(let-values(((or-part_282)(variable? v_190)))" +"(if or-part_282 or-part_282(core-form? v_190)))" +"(let-values()" +"(begin" +"(let-values(((obs_37)" +"(expand-context-observer ctx_51)))" +"(if obs_37" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_37" +" 'local-value-result" +" #f)))" +"(void)))" +"(if failure-thunk_0" +"(failure-thunk_0)" +"(error" +" 'syntax-local-value" +" \"identifier is not bound to syntax: ~v\"" +" id_75))))" +"(let-values()" +"(begin" +"(let-values(((obs_38)" +"(expand-context-observer ctx_51)))" +"(if obs_38" +"(let-values()" +"(if(not" +"(if(1/rename-transformer? v_190)" +"(not immediate?_1)" +" #f))" +"(let-values()" +"(call-expand-observe" +" obs_38" +" 'local-value-result" +" #t))" +"(void)))" +"(void)))" +"(if(1/rename-transformer? v_190)" +"(let-values()" +"(if immediate?_1" +"(values" +" v_190" +"(1/rename-transformer-target v_190))" +"(loop_96" +"(1/rename-transformer-target v_190))))" +"(if immediate?_1" +"(let-values()(values v_190 #f))" +"(let-values() v_190)))))))))))))))" +" loop_96)" +"(flip-introduction-scopes id_74 ctx_51))))))))))))))))))" +"(define-values" +"(1/syntax-local-value)" +"(let-values(((syntax-local-value25_0)" +"(lambda(id24_0 failure-thunk20_0 intdef21_0 failure-thunk22_0 intdef23_0)" +"(begin" +" 'syntax-local-value25" +"(let-values(((id_76) id24_0))" +"(let-values(((failure-thunk_1)(if failure-thunk22_0 failure-thunk20_0 #f)))" +"(let-values(((intdef_12)(if intdef23_0 intdef21_0 #f)))" +"(let-values()" +"(let-values(((temp94_2) 'syntax-local-value)" +"((temp95_1) #f)" +"((id96_0) id_76)" +"((intdef97_0) intdef_12)" +"((failure-thunk98_0) failure-thunk_1))" +"(do-syntax-local-value17.1 temp95_1 temp94_2 id96_0 intdef97_0 failure-thunk98_0))))))))))" +"(case-lambda" +"((id_77)(begin 'syntax-local-value(syntax-local-value25_0 id_77 #f #f #f #f)))" +"((id_78 failure-thunk_2 intdef21_1)(syntax-local-value25_0 id_78 failure-thunk_2 intdef21_1 #t #t))" +"((id_79 failure-thunk20_1)(syntax-local-value25_0 id_79 failure-thunk20_1 #f #t #f)))))" +"(define-values" +"(1/syntax-local-value/immediate)" +"(let-values(((syntax-local-value/immediate32_0)" +"(lambda(id31_1 failure-thunk27_0 intdef28_0 failure-thunk29_0 intdef30_0)" +"(begin" +" 'syntax-local-value/immediate32" +"(let-values(((id_16) id31_1))" +"(let-values(((failure-thunk_3)(if failure-thunk29_0 failure-thunk27_0 #f)))" +"(let-values(((intdef_13)(if intdef30_0 intdef28_0 #f)))" +"(let-values()" +"(let-values(((temp99_1) 'syntax-local-value/immediate)" +"((temp100_0) #t)" +"((id101_1) id_16)" +"((intdef102_0) intdef_13)" +"((failure-thunk103_0) failure-thunk_3))" +"(do-syntax-local-value17.1" +" temp100_0" +" temp99_1" +" id101_1" +" intdef102_0" +" failure-thunk103_0))))))))))" +"(case-lambda" +"((id_80)(begin 'syntax-local-value/immediate(syntax-local-value/immediate32_0 id_80 #f #f #f #f)))" +"((id_81 failure-thunk_4 intdef28_1)(syntax-local-value/immediate32_0 id_81 failure-thunk_4 intdef28_1 #t #t))" +"((id_7 failure-thunk27_1)(syntax-local-value/immediate32_0 id_7 failure-thunk27_1 #f #t #f)))))" +"(define-values" +"(do-lift-values-expression)" +"(lambda(who_16 n_28 s_413)" +"(begin" +"(let-values((()" +"(begin" +" (if (syntax?$1 s_413) (void) (let-values () (raise-argument-error who_16 \"syntax?\" s_413)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(exact-nonnegative-integer? n_28)" +"(void)" +" (let-values () (raise-argument-error who_16 \"exact-nonnegative-integer?\" n_28)))" +"(values))))" +"(let-values(((ctx_24)(let-values(((who104_0) who_16))(get-current-expand-context17.1 #f #f who104_0 #t))))" +"(let-values(((lifts_8)(expand-context-lifts ctx_24)))" +"(let-values((()" +"(begin" +" (if lifts_8 (void) (let-values () (raise-arguments-error who_16 \"no lift target\")))" +"(values))))" +"(let-values(((counter_4)(root-expand-context-counter ctx_24)))" +"(let-values(((ids_26)" +"(reverse$1" +"(let-values(((start_40) 0)((end_29) n_28)((inc_23) 1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-range start_40 end_29 inc_23)))" +"((letrec-values(((for-loop_246)" +"(lambda(fold-var_180 pos_102)" +"(begin" +" 'for-loop" +"(if(< pos_102 end_29)" +"(let-values()" +"(let-values(((fold-var_242)" +"(let-values(((fold-var_243) fold-var_180))" +"(let-values(((fold-var_229)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(set-box!" +" counter_4" +"(add1" +"(unbox" +" counter_4)))" +"(values))))" +"(let-values(((name_63)" +"(string->unreadable-symbol" +"(format" +" \"lifted/~a\"" +"(unbox" +" counter_4)))))" +"(add-scope" +"(datum->syntax$1" +" #f" +" name_63)" +"(new-scope" +" 'macro)))))" +" fold-var_243))))" +"(values fold-var_229)))))" +"(if(not #f)" +"(for-loop_246 fold-var_242(+ pos_102 inc_23))" +" fold-var_242)))" +" fold-var_180)))))" +" for-loop_246)" +" null" +" start_40))))))" +"(begin" +"(let-values(((obs_25)(expand-context-observer ctx_24)))" +"(if obs_25" +"(let-values()(let-values()(call-expand-observe obs_25 'local-lift ids_26 s_413)))" +"(void)))" +"(map2" +"(lambda(id_82)(flip-introduction-scopes id_82 ctx_24))" +"(add-lifted!" +" lifts_8" +" ids_26" +"(flip-introduction-scopes s_413 ctx_24)" +"(expand-context-phase ctx_24))))))))))))))" +"(define-values" +"(1/syntax-local-lift-expression)" +"(lambda(s_57)" +"(begin 'syntax-local-lift-expression(car(do-lift-values-expression 'syntax-local-lift-expression 1 s_57)))))" +"(define-values" +"(1/syntax-local-lift-values-expression)" +"(lambda(n_29 s_414)" +"(begin" +" 'syntax-local-lift-values-expression" +"(do-lift-values-expression 'syntax-local-lift-values-expression n_29 s_414))))" +"(define-values" +"(1/syntax-local-lift-context)" +"(lambda()" +"(begin" +" 'syntax-local-lift-context" +"(let-values(((ctx_52)" +"(let-values(((temp105_0) 'syntax-local-lift-context))" +"(get-current-expand-context17.1 #f #f temp105_0 #t))))" +"(root-expand-context-lift-key ctx_52)))))" +"(define-values" +"(1/syntax-local-lift-module)" +"(lambda(s_404)" +"(begin" +" 'syntax-local-lift-module" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_404)" +"(void)" +" (let-values () (raise-argument-error 'syntax-local-lift-module \"syntax?\" s_404)))" +"(values))))" +"(let-values(((ctx_53)" +"(let-values(((temp106_1) 'syntax-local-lift-module))" +"(get-current-expand-context17.1 #f #f temp106_1 #t))))" +"(let-values(((phase_113)(expand-context-phase ctx_53)))" +"(begin" +"(let-values(((tmp_35)(core-form-sym s_404 phase_113)))" +"(if(if(equal? tmp_35 'module) #t(equal? tmp_35 'module*))" +"(let-values()" +"(let-values(((lifts_0)(expand-context-module-lifts ctx_53)))" +"(begin" +"(if lifts_0" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-lift-module" +" \"not currently transforming within a module declaration or top level\"" +" \"form to lift\"" +" s_404)))" +"(add-lifted-module! lifts_0(flip-introduction-scopes s_404 ctx_53) phase_113))))" +"(let-values()" +" (raise-arguments-error 'syntax-local-lift-module \"not a module form\" \"given form\" s_404))))" +"(let-values(((obs_26)(expand-context-observer ctx_53)))" +"(if obs_26" +"(let-values()(let-values()(call-expand-observe obs_26 'lift-statement s_404)))" +"(void))))))))))" +"(define-values" +"(do-local-lift-to-module54.1)" +"(lambda(add-lifted!38_0" +" get-lift-ctx37_0" +" get-wrt-phase39_0" +" intro?35_0" +" intro?44_0" +" more-checks36_0" +" more-checks45_0" +" no-target-msg34_0" +" post-wrap42_0" +" post-wrap51_0" +" pre-wrap40_0" +" pre-wrap49_0" +" shift-wrap41_0" +" shift-wrap50_0" +" who52_0" +" s53_1)" +"(begin" +" 'do-local-lift-to-module54" +"(let-values(((who_17) who52_0))" +"(let-values(((s_64) s53_1))" +"(let-values(((no-target-msg_0) no-target-msg34_0))" +"(let-values(((intro?_0)(if intro?44_0 intro?35_0 #t)))" +"(let-values(((more-checks_0)(if more-checks45_0 more-checks36_0 void)))" +"(let-values(((get-lift-ctx_0) get-lift-ctx37_0))" +"(let-values(((add-lifted!_0) add-lifted!38_0))" +"(let-values(((get-wrt-phase_0) get-wrt-phase39_0))" +"(let-values(((pre-wrap_0)" +"(if pre-wrap49_0" +" pre-wrap40_0" +"(lambda(s_66 phase_114 lift-ctx_1)(begin 'pre-wrap s_66)))))" +"(let-values(((shift-wrap_0)" +"(if shift-wrap50_0" +" shift-wrap41_0" +"(lambda(s_415 phase_49 lift-ctx_2)(begin 'shift-wrap s_415)))))" +"(let-values(((post-wrap_0)" +"(if post-wrap51_0" +" post-wrap42_0" +"(lambda(s_406 phase_115 lift-ctx_3)(begin 'post-wrap s_406)))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_64)" +"(void)" +" (let-values () (raise-argument-error who_17 \"syntax?\" s_64)))" +"(values))))" +"(let-values((()(begin(more-checks_0)(values))))" +"(let-values(((ctx_54)" +"(let-values(((who107_0) who_17))" +"(get-current-expand-context17.1 #f #f who107_0 #t))))" +"(let-values(((lift-ctx_4)(get-lift-ctx_0 ctx_54)))" +"(let-values((()" +"(begin" +"(if lift-ctx_4" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_17" +" no-target-msg_0" +" \"form to lift\"" +" s_64)))" +"(values))))" +"(let-values(((phase_116)(expand-context-phase ctx_54)))" +"(let-values(((wrt-phase_1)(get-wrt-phase_0 lift-ctx_4)))" +"(let-values(((added-s_0)" +"(if intro?_0(flip-introduction-scopes s_64 ctx_54) s_64)))" +"(let-values(((pre-s_0)(pre-wrap_0 added-s_0 phase_116 lift-ctx_4)))" +"(let-values(((shift-s_0)" +"(let-values(((start_41) phase_116)" +"((end_30) wrt-phase_1)" +"((inc_24) -1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-range start_41 end_30 inc_24)))" +"((letrec-values(((for-loop_173)" +"(lambda(s_416 pos_103)" +"(begin" +" 'for-loop" +"(if(> pos_103 end_30)" +"(let-values(((phase_117)" +" pos_103))" +"(let-values(((s_206)" +"(let-values(((s_39)" +" s_416))" +"(let-values(((s_417)" +"(let-values()" +"(shift-wrap_0" +" s_39" +"(sub1" +" phase_117)" +" lift-ctx_4))))" +"(values" +" s_417)))))" +"(if(not #f)" +"(for-loop_173" +" s_206" +"(+ pos_103 inc_24))" +" s_206)))" +" s_416)))))" +" for-loop_173)" +" pre-s_0" +" start_41)))))" +"(let-values(((post-s_1)" +"(post-wrap_0 shift-s_0 wrt-phase_1 lift-ctx_4)))" +"(begin" +"(add-lifted!_0 lift-ctx_4 post-s_1 wrt-phase_1)" +"(values ctx_54 post-s_1))))))))))))))))))))))))))))" +"(define-values" +"(1/syntax-local-lift-require)" +"(lambda(s_418 use-s_1)" +"(begin" +" 'syntax-local-lift-require" +"(let-values(((sc_29)(new-scope 'macro)))" +"(let-values(((ctx_55 added-s_1)" +"(let-values(((temp108_0) 'syntax-local-lift-require)" +"((temp109_0)(datum->syntax$1 #f s_418))" +" ((temp110_1) \"could not find target context\")" +"((temp111_1) #f)" +"((temp112_0)" +"(lambda()" +"(if(syntax?$1 use-s_1)" +"(void)" +"(let-values()" +" (raise-argument-error 'syntax-local-lift-require \"syntax?\" use-s_1)))))" +"((expand-context-require-lifts113_0) expand-context-require-lifts)" +"((require-lift-context-wrt-phase114_0) require-lift-context-wrt-phase)" +"((add-lifted-require!115_0) add-lifted-require!)" +"((temp116_0)" +"(lambda(s_109 phase_118 require-lift-ctx_0)(require-spec-shift-for-syntax s_109)))" +"((temp117_1)" +"(lambda(s_419 phase_119 require-lift-ctx_1)" +"(wrap-form '#%require(add-scope s_419 sc_29) phase_119))))" +"(do-local-lift-to-module54.1" +" add-lifted-require!115_0" +" expand-context-require-lifts113_0" +" require-lift-context-wrt-phase114_0" +" temp111_1" +" #t" +" temp112_0" +" #t" +" temp110_1" +" temp117_1" +" #t" +" #f" +" #f" +" temp116_0" +" #t" +" temp108_0" +" temp109_0))))" +"(let-values((()" +"(begin" +"(namespace-visit-available-modules!" +"(expand-context-namespace ctx_55)" +"(expand-context-phase ctx_55))" +"(values))))" +"(let-values(((result-s_6)(add-scope use-s_1 sc_29)))" +"(begin" +"(let-values(((obs_39)(expand-context-observer ctx_55)))" +"(if obs_39" +"(let-values()" +"(let-values()(call-expand-observe obs_39 'lift-require added-s_1 use-s_1 result-s_6)))" +"(void)))" +" result-s_6))))))))" +"(define-values" +"(1/syntax-local-lift-provide)" +"(lambda(s_215)" +"(begin" +" 'syntax-local-lift-provide" +"(let-values(((ctx_56 result-s_7)" +"(let-values(((temp118_1) 'syntax-local-lift-provide)" +"((s119_0) s_215)" +" ((temp120_0) \"not expanding in a module run-time body\")" +"((expand-context-to-module-lifts121_0) expand-context-to-module-lifts)" +"((to-module-lift-context-wrt-phase122_0) to-module-lift-context-wrt-phase)" +"((add-lifted-to-module-provide!123_0) add-lifted-to-module-provide!)" +"((temp124_1)" +"(lambda(s_420 phase_120 to-module-lift-ctx_0)(wrap-form 'for-syntax s_420 #f)))" +"((temp125_0)" +"(lambda(s_113 phase_121 to-module-lift-ctx_1)" +"(wrap-form '#%provide s_113 phase_121))))" +"(do-local-lift-to-module54.1" +" add-lifted-to-module-provide!123_0" +" expand-context-to-module-lifts121_0" +" to-module-lift-context-wrt-phase122_0" +" #f" +" #f" +" #f" +" #f" +" temp120_0" +" temp125_0" +" #t" +" #f" +" #f" +" temp124_1" +" #t" +" temp118_1" +" s119_0))))" +"(let-values(((obs_40)(expand-context-observer ctx_56)))" +"(if obs_40(let-values()(let-values()(call-expand-observe obs_40 'lift-provide result-s_7)))(void)))))))" +"(define-values" +"(1/syntax-local-lift-module-end-declaration)" +"(lambda(s_421)" +"(begin" +" 'syntax-local-lift-module-end-declaration" +"(let-values(((ctx_57 also-s_0)" +"(let-values(((temp126_1) 'syntax-local-lift-module-end-declaration)" +"((s127_0) s_421)" +" ((temp128_1) \"not currently transforming an expression within a module declaration\")" +"((expand-context-to-module-lifts129_0) expand-context-to-module-lifts)" +"((temp130_0)(lambda(lift-ctx_5) 0))" +"((add-lifted-to-module-end!131_0) add-lifted-to-module-end!)" +"((temp132_0)" +"(lambda(orig-s_33 phase_122 to-module-lift-ctx_2)" +"(if(to-module-lift-context-end-as-expressions? to-module-lift-ctx_2)" +"(wrap-form '#%expression orig-s_33 phase_122)" +" orig-s_33)))" +"((temp133_0)" +"(lambda(s_221 phase_123 to-module-lift-ctx_3)" +"(wrap-form 'begin-for-syntax s_221 phase_123))))" +"(do-local-lift-to-module54.1" +" add-lifted-to-module-end!131_0" +" expand-context-to-module-lifts129_0" +" temp130_0" +" #f" +" #f" +" #f" +" #f" +" temp128_1" +" #f" +" #f" +" temp132_0" +" #t" +" temp133_0" +" #t" +" temp126_1" +" s127_0))))" +"(let-values(((obs_41)(expand-context-observer ctx_57)))" +"(if obs_41(let-values()(let-values()(call-expand-observe obs_41 'lift-statement s_421)))(void)))))))" +"(define-values" +"(wrap-form)" +"(lambda(sym_65 s_119 phase_124)" +"(begin" +"(datum->syntax$1" +" #f" +"(list(datum->syntax$1(if phase_124(syntax-shift-phase-level$1 core-stx phase_124) #f) sym_65) s_119)))))" +"(define-values" +"(1/syntax-local-module-defined-identifiers)" +"(lambda()" +"(begin" +" 'syntax-local-module-defined-identifiers" +"(let-values((()" +"(begin" +"(if(1/syntax-local-transforming-module-provides?)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-module-defined-identifiers" +" \"not currently transforming module provides\")))" +"(values))))" +"(let-values(((ctx_58)" +"(let-values(((temp134_0) 'syntax-local-module-defined-identifiers))" +"(get-current-expand-context17.1 #f #f temp134_0 #t))))" +"(requireds->phase-ht(extract-module-definitions(expand-context-requires+provides ctx_58))))))))" +"(define-values" +"(1/syntax-local-module-required-identifiers)" +"(lambda(mod-path_8 phase-level_20)" +"(begin" +" 'syntax-local-module-required-identifiers" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_184)(not mod-path_8)))" +"(if or-part_184 or-part_184(1/module-path? mod-path_8)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-module-required-identifiers" +" \"(or/c module-path? #f)\"" +" mod-path_8)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_177)(eq? phase-level_20 #t)))" +"(if or-part_177 or-part_177(phase? phase-level_20)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-module-required-identifiers" +" (format \"(or/c ~a #t)\" phase?-string)" +" phase-level_20)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/syntax-local-transforming-module-provides?)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'syntax-local-module-required-identifiers" +" \"not currently transforming module provides\")))" +"(values))))" +"(let-values(((ctx_59)" +"(let-values(((temp135_0) 'syntax-local-module-required-identifiers))" +"(get-current-expand-context17.1 #f #f temp135_0 #t))))" +"(let-values(((requires+provides_5)(expand-context-requires+provides ctx_59)))" +"(let-values(((mpi_43)(if mod-path_8(module-path->mpi/context mod-path_8 ctx_59) #f)))" +"(let-values(((requireds_0)" +"(extract-all-module-requires" +" requires+provides_5" +" mpi_43" +"(if(eq? phase-level_20 #t) 'all phase-level_20))))" +"(if requireds_0" +"(reverse$1" +"(let-values(((ht_134)(requireds->phase-ht requireds_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_134)))" +"((letrec-values(((for-loop_247)" +"(lambda(fold-var_244 i_165)" +"(begin" +" 'for-loop" +"(if i_165" +"(let-values(((phase_125 ids_27)" +"(hash-iterate-key+value ht_134 i_165)))" +"(let-values(((fold-var_245)" +"(let-values(((fold-var_246) fold-var_244))" +"(let-values(((fold-var_247)" +"(let-values()" +"(cons" +"(let-values()" +"(cons phase_125 ids_27))" +" fold-var_246))))" +"(values fold-var_247)))))" +"(if(not #f)" +"(for-loop_247 fold-var_245(hash-iterate-next ht_134 i_165))" +" fold-var_245)))" +" fold-var_244)))))" +" for-loop_247)" +" null" +"(hash-iterate-first ht_134)))))" +" #f)))))))))))" +"(define-values" +"(requireds->phase-ht)" +"(lambda(requireds_1)" +"(begin" +"(let-values(((lst_291) requireds_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_291)))" +"((letrec-values(((for-loop_248)" +"(lambda(ht_135 lst_292)" +"(begin" +" 'for-loop" +"(if(pair? lst_292)" +"(let-values(((r_44)(unsafe-car lst_292))((rest_163)(unsafe-cdr lst_292)))" +"(let-values(((ht_136)" +"(let-values(((ht_137) ht_135))" +"(let-values(((ht_138)" +"(let-values()" +"(hash-update" +" ht_137" +"(required-phase r_44)" +"(lambda(l_71)(cons(required-id r_44) l_71))" +" null))))" +"(values ht_138)))))" +"(if(not #f)(for-loop_248 ht_136 rest_163) ht_136)))" +" ht_135)))))" +" for-loop_248)" +"(hasheqv)" +" lst_291))))))" +"(define-values" +"(1/syntax-local-module-exports)" +"(lambda(mod-path_9)" +"(begin" +" 'syntax-local-module-exports" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_283)(1/module-path? mod-path_9)))" +"(if or-part_283" +" or-part_283" +"(if(syntax?$1 mod-path_9)(1/module-path?(syntax->datum$1 mod-path_9)) #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-local-module-exports" +"(string-append" +" \"(or/c module-path?\\n\"" +" \" (and/c syntax?\\n\"" +" \" (lambda (stx)\\n\"" +" \" (module-path? (syntax->datum stx)))))\")" +" mod-path_9)))" +"(values))))" +"(let-values(((ctx_60)" +"(let-values(((temp136_0) 'syntax-local-module-exports))" +"(get-current-expand-context17.1 #f #f temp136_0 #t))))" +"(let-values(((ns_75)(expand-context-namespace ctx_60)))" +"(let-values(((mod-name_18)" +"(1/module-path-index-resolve" +"(module-path->mpi/context" +"(if(syntax?$1 mod-path_9)(syntax->datum$1 mod-path_9) mod-path_9)" +" ctx_60)" +" #t)))" +"(let-values(((m_19)(namespace->module ns_75 mod-name_18)))" +"(begin" +"(if m_19(void)(let-values()(raise-unknown-module-error 'syntax-local-module-exports mod-name_18)))" +"(reverse$1" +"(let-values(((ht_139)(module-provides m_19)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_139)))" +"((letrec-values(((for-loop_130)" +"(lambda(fold-var_248 i_8)" +"(begin" +" 'for-loop" +"(if i_8" +"(let-values(((phase_126 syms_22)(hash-iterate-key+value ht_139 i_8)))" +"(let-values(((fold-var_249)" +"(let-values(((fold-var_250) fold-var_248))" +"(let-values(((fold-var_251)" +"(let-values()" +"(cons" +"(let-values()" +"(cons" +" phase_126" +"(reverse$1" +"(let-values(((ht_140) syms_22))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash-keys" +" ht_140)))" +"((letrec-values(((for-loop_249)" +"(lambda(fold-var_252" +" i_166)" +"(begin" +" 'for-loop" +"(if i_166" +"(let-values(((sym_66)" +"(hash-iterate-key" +" ht_140" +" i_166)))" +"(let-values(((fold-var_201)" +"(let-values(((fold-var_202)" +" fold-var_252))" +"(let-values(((fold-var_253)" +"(let-values()" +"(cons" +"(let-values()" +" sym_66)" +" fold-var_202))))" +"(values" +" fold-var_253)))))" +"(if(not" +" #f)" +"(for-loop_249" +" fold-var_201" +"(hash-iterate-next" +" ht_140" +" i_166))" +" fold-var_201)))" +" fold-var_252)))))" +" for-loop_249)" +" null" +"(hash-iterate-first" +" ht_140)))))))" +" fold-var_250))))" +"(values fold-var_251)))))" +"(if(not #f)" +"(for-loop_130 fold-var_249(hash-iterate-next ht_139 i_8))" +" fold-var_249)))" +" fold-var_248)))))" +" for-loop_130)" +" null" +"(hash-iterate-first ht_139))))))))))))))" +"(define-values" +"(1/syntax-local-submodules)" +"(lambda()" +"(begin" +" 'syntax-local-submodules" +"(let-values(((ctx_61)" +"(let-values(((temp137_1) 'syntax-local-submodules))" +"(get-current-expand-context17.1 #f #f temp137_1 #t))))" +"(let-values(((submods_3)(expand-context-declared-submodule-names ctx_61)))" +"(reverse$1" +"(let-values(((ht_141) submods_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_141)))" +"((letrec-values(((for-loop_250)" +"(lambda(fold-var_254 i_167)" +"(begin" +" 'for-loop" +"(if i_167" +"(let-values(((name_64 kind_8)(hash-iterate-key+value ht_141 i_167)))" +"(let-values(((fold-var_255)" +"(let-values(((fold-var_256) fold-var_254))" +"(if(eq? kind_8 'module)" +"(let-values(((fold-var_257) fold-var_256))" +"(let-values(((fold-var_204)" +"(let-values()" +"(cons" +"(let-values() name_64)" +" fold-var_257))))" +"(values fold-var_204)))" +" fold-var_256))))" +"(if(not #f)" +"(for-loop_250 fold-var_255(hash-iterate-next ht_141 i_167))" +" fold-var_255)))" +" fold-var_254)))))" +" for-loop_250)" +" null" +"(hash-iterate-first ht_141))))))))))" +"(define-values" +"(1/syntax-local-get-shadower)" +"(let-values(((syntax-local-get-shadower60_0)" +"(lambda(id59_0 only-generated?57_0 only-generated?58_0)" +"(begin" +" 'syntax-local-get-shadower60" +"(let-values(((id_83) id59_0))" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(if(identifier? id_83)" +"(void)" +"(let-values()" +" (raise-argument-error 'syntax-local-get-shadower \"identifier?\" id_83)))" +"(values))))" +"(let-values(((ctx_62)" +"(let-values(((temp138_1) 'syntax-local-get-shadower))" +"(get-current-expand-context17.1 #f #f temp138_1 #t))))" +"(let-values(((new-id_0)(add-scopes id_83(expand-context-scopes ctx_62))))" +"(if(syntax-clean? id_83) new-id_0(syntax-taint$1 new-id_0))))))))))))" +"(case-lambda" +"((id_84)(begin 'syntax-local-get-shadower(syntax-local-get-shadower60_0 id_84 #f #f)))" +"((id_85 only-generated?57_1)(syntax-local-get-shadower60_0 id_85 only-generated?57_1 #t)))))" +"(define-values" +"(syntax-source-accessor)" +"(lambda(who_0 srcloc-accessor_0)" +"(begin" +"(lambda(s_158)" +"(let-values((()" +"(begin" +" (if (syntax?$1 s_158) (void) (let-values () (raise-argument-error who_0 \"syntax?\" s_158)))" +"(values))))" +"(let-values(((srcloc_7)(syntax-srcloc s_158)))(if srcloc_7(srcloc-accessor_0 srcloc_7) #f)))))))" +"(define-values(1/syntax-source)(syntax-source-accessor 'syntax-source srcloc-source))" +"(define-values(1/syntax-line)(syntax-source-accessor 'syntax-line srcloc-line))" +"(define-values(1/syntax-column)(syntax-source-accessor 'syntax-column srcloc-column))" +"(define-values(1/syntax-position)(syntax-source-accessor 'syntax-position srcloc-position))" +"(define-values(1/syntax-span)(syntax-source-accessor 'syntax-span srcloc-span))" +"(define-values" +"(encoded-srcloc?)" +"(lambda(v_66)" +"(begin" +"(let-values(((or-part_26)(if(list? v_66)(if(=(length v_66) 5)(srcloc-vector?(list->vector v_66)) #f) #f)))" +"(if or-part_26 or-part_26(if(vector? v_66)(if(=(vector-length v_66) 5)(srcloc-vector? v_66) #f) #f))))))" +"(define-values" +"(srcloc-vector?)" +"(lambda(v_68)" +"(begin" +"(if(let-values(((or-part_284)(not(vector-ref v_68 1))))" +"(if or-part_284 or-part_284(exact-positive-integer?(vector-ref v_68 1))))" +"(if(let-values(((or-part_27)(not(vector-ref v_68 2))))" +"(if or-part_27 or-part_27(exact-nonnegative-integer?(vector-ref v_68 2))))" +"(if(let-values(((or-part_10)(not(vector-ref v_68 3))))" +"(if or-part_10 or-part_10(exact-positive-integer?(vector-ref v_68 3))))" +"(let-values(((or-part_159)(not(vector-ref v_68 4))))" +"(if or-part_159 or-part_159(exact-nonnegative-integer?(vector-ref v_68 4))))" +" #f)" +" #f)" +" #f))))" +"(define-values" +"(to-srcloc-stx)" +"(lambda(v_191)" +"(begin" +"(if(srcloc? v_191)" +"(let-values()" +"(let-values(((the-struct_69) empty-syntax))" +"(if(syntax?$1 the-struct_69)" +"(let-values(((srcloc1_2) v_191))" +"(syntax1.1" +"(syntax-content the-struct_69)" +"(syntax-scopes the-struct_69)" +"(syntax-shifted-multi-scopes the-struct_69)" +"(syntax-scope-propagations+tamper the-struct_69)" +"(syntax-mpi-shifts the-struct_69)" +" srcloc1_2" +"(syntax-props the-struct_69)" +"(syntax-inspector the-struct_69)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_69))))" +"(if(pair? v_191)" +"(let-values()(to-srcloc-stx(list->vector v_191)))" +"(if(vector? v_191)" +"(let-values()" +"(let-values(((the-struct_29) empty-syntax))" +"(if(syntax?$1 the-struct_29)" +"(let-values(((srcloc2_1)" +"(srcloc" +"(vector-ref v_191 0)" +"(vector-ref v_191 1)" +"(vector-ref v_191 2)" +"(vector-ref v_191 3)" +"(vector-ref v_191 4))))" +"(syntax1.1" +"(syntax-content the-struct_29)" +"(syntax-scopes the-struct_29)" +"(syntax-shifted-multi-scopes the-struct_29)" +"(syntax-scope-propagations+tamper the-struct_29)" +"(syntax-mpi-shifts the-struct_29)" +" srcloc2_1" +"(syntax-props the-struct_29)" +"(syntax-inspector the-struct_29)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_29))))" +"(let-values() v_191)))))))" +"(define-values" +"(1/syntax-e)" +"(lambda(s_0)" +"(begin" +" 'syntax-e" +"(begin" +" (if (syntax?$1 s_0) (void) (let-values () (raise-argument-error 'syntax-e \"syntax?\" s_0)))" +"(syntax-e$1 s_0)))))" +"(define-values" +"(1/syntax->datum)" +"(lambda(s_157)" +"(begin" +" 'syntax->datum" +"(begin" +" (if (syntax?$1 s_157) (void) (let-values () (raise-argument-error 'syntax->datum \"syntax?\" s_157)))" +"(syntax->datum$1 s_157)))))" +"(define-values(maybe-syntax->datum)(lambda(s_158)(begin(if(syntax?$1 s_158)(syntax->datum$1 s_158) s_158))))" +"(define-values" +"(1/datum->syntax)" +"(let-values(((datum->syntax9_0)" +"(lambda(stx-c7_0 s8_0 stx-l1_0 stx-p2_0 ignored3_0 stx-l4_1 stx-p5_1 ignored6_0)" +"(begin" +" 'datum->syntax9" +"(let-values(((stx-c_4) stx-c7_0))" +"(let-values(((s_422) s8_0))" +"(let-values(((stx-l_2)(if stx-l4_1 stx-l1_0 #f)))" +"(let-values(((stx-p_1)(if stx-p5_1 stx-p2_0 #f)))" +"(let-values()" +"(let-values()" +"(begin" +"(if(let-values(((or-part_6)(not stx-c_4)))" +"(if or-part_6 or-part_6(syntax?$1 stx-c_4)))" +"(void)" +" (let-values () (raise-argument-error 'datum->syntax \"(or #f syntax?)\" stx-c_4)))" +"(if(let-values(((or-part_285)(not stx-l_2)))" +"(if or-part_285" +" or-part_285" +"(let-values(((or-part_28)(syntax?$1 stx-l_2)))" +"(if or-part_28 or-part_28(encoded-srcloc? stx-l_2)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'datum->syntax" +"(string-append" +" \"(or #f syntax?\\n\"" +" \" (list/c any/c\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f)\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f))\\n\"" +" \" (vector/c any/c\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f)\\n\"" +" \" (or/c exact-positive-integer? #f)\\n\"" +" \" (or/c exact-nonnegative-integer? #f)))\")" +" stx-l_2)))" +"(if(let-values(((or-part_286)(not stx-p_1)))" +"(if or-part_286 or-part_286(syntax?$1 stx-p_1)))" +"(void)" +" (let-values () (raise-argument-error 'datum->syntax \"(or #f syntax?)\" stx-p_1)))" +"(datum->syntax$1 stx-c_4 s_422(to-srcloc-stx stx-l_2) stx-p_1))))))))))))" +"(case-lambda" +"((stx-c_5 s_71)(begin 'datum->syntax(datum->syntax9_0 stx-c_5 s_71 #f #f #f #f #f #f)))" +"((stx-c_6 s_4 stx-l_3 stx-p_2 ignored3_1)(datum->syntax9_0 stx-c_6 s_4 stx-l_3 stx-p_2 ignored3_1 #t #t #t))" +"((stx-c_7 s_72 stx-l_4 stx-p2_1)(datum->syntax9_0 stx-c_7 s_72 stx-l_4 stx-p2_1 #f #t #t #f))" +"((stx-c_8 s_41 stx-l1_1)(datum->syntax9_0 stx-c_8 s_41 stx-l1_1 #f #f #t #f #f)))))" +"(define-values" +"(1/syntax->list)" +"(lambda(s_423)" +"(begin" +" 'syntax->list" +"(begin" +" (if (syntax?$1 s_423) (void) (let-values () (raise-argument-error 'syntax->list \"syntax?\" s_423)))" +"(syntax->list$1 s_423)))))" +"(define-values" +"(1/syntax-original?)" +"(lambda(s_424)" +"(begin" +" 'syntax-original?" +"(begin" +" (if (syntax?$1 s_424) (void) (let-values () (raise-argument-error 'syntax-original? \"syntax?\" s_424)))" +"(if(syntax-property$1 s_424 original-property-sym)(not(syntax-any-macro-scopes? s_424)) #f)))))" +"(define-values" +"(1/bound-identifier=?)" +"(let-values(((bound-identifier=?15_0)" +"(lambda(a13_0 b14_1 phase11_1 phase12_0)" +"(begin" +" 'bound-identifier=?15" +"(let-values(((a_53) a13_0))" +"(let-values(((b_48) b14_1))" +"(let-values(((phase_127)(if phase12_0 phase11_1(1/syntax-local-phase-level))))" +"(let-values()" +"(begin" +"(if(identifier? a_53)" +"(void)" +" (let-values () (raise-argument-error 'bound-identifier=? \"identifier?\" a_53)))" +"(if(identifier? b_48)" +"(void)" +" (let-values () (raise-argument-error 'bound-identifier=? \"identifier?\" b_48)))" +"(if(phase? phase_127)" +"(void)" +"(let-values()(raise-argument-error 'bound-identifier=? phase?-string phase_127)))" +"(bound-identifier=?$1 a_53 b_48 phase_127))))))))))" +"(case-lambda" +"((a_54 b_81)(begin 'bound-identifier=?(bound-identifier=?15_0 a_54 b_81 #f #f)))" +"((a_55 b_82 phase11_2)(bound-identifier=?15_0 a_55 b_82 phase11_2 #t)))))" +"(define-values" +"(1/free-identifier=?)" +"(let-values(((free-identifier=?23_0)" +"(lambda(a21_0 b22_0 a-phase17_0 b-phase18_0 a-phase19_0 b-phase20_0)" +"(begin" +" 'free-identifier=?23" +"(let-values(((a_56) a21_0))" +"(let-values(((b_83) b22_0))" +"(let-values(((a-phase_1)(if a-phase19_0 a-phase17_0(1/syntax-local-phase-level))))" +"(let-values(((b-phase_1)(if b-phase20_0 b-phase18_0 a-phase_1)))" +"(let-values()" +"(begin" +"(if(identifier? a_56)" +"(void)" +" (let-values () (raise-argument-error 'free-identifier=? \"identifier?\" a_56)))" +"(if(identifier? b_83)" +"(void)" +" (let-values () (raise-argument-error 'free-identifier=? \"identifier?\" b_83)))" +"(if(phase? a-phase_1)" +"(void)" +"(let-values()(raise-argument-error 'free-identifier=? phase?-string a-phase_1)))" +"(if(phase? b-phase_1)" +"(void)" +"(let-values()(raise-argument-error 'free-identifier=? phase?-string b-phase_1)))" +"(free-identifier=?$1 a_56 b_83 a-phase_1 b-phase_1)))))))))))" +"(case-lambda" +"((a_57 b_43)(begin 'free-identifier=?(free-identifier=?23_0 a_57 b_43 #f #f #f #f)))" +"((a_58 b_84 a-phase_2 b-phase18_1)(free-identifier=?23_0 a_58 b_84 a-phase_2 b-phase18_1 #t #t))" +"((a_59 b_85 a-phase17_1)(free-identifier=?23_0 a_59 b_85 a-phase17_1 #f #t #f)))))" +"(define-values" +"(1/free-transformer-identifier=?)" +"(lambda(a_60 b_86)" +"(begin" +" 'free-transformer-identifier=?" +"(let-values((()" +"(begin" +"(if(identifier? a_60)" +"(void)" +" (let-values () (raise-argument-error 'free-transformer-identifier=? \"identifier?\" a_60)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(identifier? b_86)" +"(void)" +" (let-values () (raise-argument-error 'free-transformer-identifier=? \"identifier?\" b_86)))" +"(values))))" +"(let-values(((phase_128)(add1(1/syntax-local-phase-level))))" +"(free-identifier=?$1 a_60 b_86 phase_128 phase_128)))))))" +"(define-values" +"(1/free-template-identifier=?)" +"(lambda(a_61 b_87)" +"(begin" +" 'free-template-identifier=?" +"(let-values((()" +"(begin" +"(if(identifier? a_61)" +"(void)" +" (let-values () (raise-argument-error 'free-template-identifier=? \"identifier?\" a_61)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(identifier? b_87)" +"(void)" +" (let-values () (raise-argument-error 'free-template-identifier=? \"identifier?\" b_87)))" +"(values))))" +"(let-values(((phase_129)(sub1(1/syntax-local-phase-level))))" +"(free-identifier=?$1 a_61 b_87 phase_129 phase_129)))))))" +"(define-values" +"(1/free-label-identifier=?)" +"(lambda(a_62 b_88)" +"(begin" +" 'free-label-identifier=?" +"(begin" +"(if(identifier? a_62)" +"(void)" +" (let-values () (raise-argument-error 'free-label-identifier=? \"identifier?\" a_62)))" +"(if(identifier? b_88)" +"(void)" +" (let-values () (raise-argument-error 'free-label-identifier=? \"identifier?\" b_88)))" +"(free-identifier=?$1 a_62 b_88 #f #f)))))" +"(define-values" +"(1/identifier-binding)" +"(let-values(((identifier-binding30_0)" +"(lambda(id29_0 phase25_1 top-level-symbol?26_0 phase27_0 top-level-symbol?28_0)" +"(begin" +" 'identifier-binding30" +"(let-values(((id_86) id29_0))" +"(let-values(((phase_86)(if phase27_0 phase25_1(1/syntax-local-phase-level))))" +"(let-values(((top-level-symbol?_1)(if top-level-symbol?28_0 top-level-symbol?26_0 #f)))" +"(let-values()" +"(begin" +"(if(identifier? id_86)" +"(void)" +" (let-values () (raise-argument-error 'identifier-binding \"identifier?\" id_86)))" +"(if(phase? phase_86)" +"(void)" +"(let-values()(raise-argument-error 'identifier-binding phase?-string phase_86)))" +"(identifier-binding$1 id_86 phase_86 top-level-symbol?_1))))))))))" +"(case-lambda" +"((id_87)(begin 'identifier-binding(identifier-binding30_0 id_87 #f #f #f #f)))" +"((id_88 phase_130 top-level-symbol?26_1)(identifier-binding30_0 id_88 phase_130 top-level-symbol?26_1 #t #t))" +"((id_89 phase25_2)(identifier-binding30_0 id_89 phase25_2 #f #t #f)))))" +"(define-values" +"(1/identifier-transformer-binding)" +"(let-values(((identifier-transformer-binding35_0)" +"(lambda(id34_0 phase32_2 phase33_2)" +"(begin" +" 'identifier-transformer-binding35" +"(let-values(((id_53) id34_0))" +"(let-values(((phase_96)(if phase33_2 phase32_2(1/syntax-local-phase-level))))" +"(let-values()" +"(begin" +"(if(identifier? id_53)" +"(void)" +"(let-values()" +" (raise-argument-error 'identifier-transformer-binding \"identifier?\" id_53)))" +"(identifier-binding$1 id_53(if phase_96(add1 phase_96) #f))))))))))" +"(case-lambda" +"((id_90)(begin 'identifier-transformer-binding(identifier-transformer-binding35_0 id_90 #f #f)))" +"((id_91 phase32_3)(identifier-transformer-binding35_0 id_91 phase32_3 #t)))))" +"(define-values" +"(1/identifier-template-binding)" +"(lambda(id_92)" +"(begin" +" 'identifier-template-binding" +"(begin" +"(if(identifier? id_92)" +"(void)" +" (let-values () (raise-argument-error 'identifier-template-binding \"identifier?\" id_92)))" +"(identifier-binding$1 id_92(sub1(1/syntax-local-phase-level)))))))" +"(define-values" +"(1/identifier-label-binding)" +"(lambda(id_93)" +"(begin" +" 'identifier-label-binding" +"(begin" +"(if(identifier? id_93)" +"(void)" +" (let-values () (raise-argument-error 'identifier-label-binding \"identifier?\" id_93)))" +"(identifier-binding$1 id_93 #f)))))" +"(define-values" +"(1/identifier-binding-symbol)" +"(let-values(((identifier-binding-symbol40_0)" +"(lambda(id39_0 phase37_2 phase38_0)" +"(begin" +" 'identifier-binding-symbol40" +"(let-values(((id_94) id39_0))" +"(let-values(((phase_131)(if phase38_0 phase37_2(1/syntax-local-phase-level))))" +"(let-values()" +"(begin" +"(if(identifier? id_94)" +"(void)" +" (let-values () (raise-argument-error 'identifier-binding-symbol \"identifier?\" id_94)))" +"(if(phase? phase_131)" +"(void)" +"(let-values()(raise-argument-error 'identifier-binding-symbol phase?-string phase_131)))" +"(identifier-binding-symbol$1 id_94 phase_131)))))))))" +"(case-lambda" +"((id_75)(begin 'identifier-binding-symbol(identifier-binding-symbol40_0 id_75 #f #f)))" +"((id_95 phase37_3)(identifier-binding-symbol40_0 id_95 phase37_3 #t)))))" +"(define-values" +"(1/identifier-prune-lexical-context)" +"(let-values(((identifier-prune-lexical-context45_0)" +"(lambda(id44_0 syms42_0 syms43_0)" +"(begin" +" 'identifier-prune-lexical-context45" +"(let-values(((id_96) id44_0))" +"(let-values(((syms_23)(if syms43_0 syms42_0 null)))" +"(let-values()" +"(begin" +"(if(identifier? id_96)" +"(void)" +"(let-values()" +" (raise-argument-error 'identifier-prune-lexical-context \"identifier?\" id_96)))" +"(if(if(list? syms_23)(andmap2 symbol? syms_23) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'identifier-prune-lexical-context \"(listof symbol?)\" syms_23)))" +" id_96))))))))" +"(case-lambda" +"((id_55)(begin 'identifier-prune-lexical-context(identifier-prune-lexical-context45_0 id_55 #f #f)))" +"((id_67 syms42_1)(identifier-prune-lexical-context45_0 id_67 syms42_1 #t)))))" +"(define-values" +"(1/syntax-debug-info)" +"(let-values(((syntax-debug-info52_0)" +"(lambda(s51_0 phase47_2 all-bindings?48_0 phase49_1 all-bindings?50_0)" +"(begin" +" 'syntax-debug-info52" +"(let-values(((s_397) s51_0))" +"(let-values(((phase_12)(if phase49_1 phase47_2(1/syntax-local-phase-level))))" +"(let-values(((all-bindings?_1)(if all-bindings?50_0 all-bindings?48_0 #f)))" +"(let-values()" +"(begin" +"(if(syntax?$1 s_397)" +"(void)" +" (let-values () (raise-argument-error 'syntax-debug-info \"syntax?\" s_397)))" +"(if(phase? phase_12)" +"(void)" +"(let-values()(raise-argument-error 'syntax-debug-info phase?-string phase_12)))" +"(syntax-debug-info$1 s_397 phase_12 all-bindings?_1))))))))))" +"(case-lambda" +"((s_310)(begin 'syntax-debug-info(syntax-debug-info52_0 s_310 #f #f #f #f)))" +"((s_27 phase_132 all-bindings?48_1)(syntax-debug-info52_0 s_27 phase_132 all-bindings?48_1 #t #t))" +"((s_30 phase47_3)(syntax-debug-info52_0 s_30 phase47_3 #f #t #f)))))" +"(define-values" +"(1/syntax-shift-phase-level)" +"(lambda(s_150 phase_20)" +"(begin" +" 'syntax-shift-phase-level" +"(begin" +" (if (syntax?$1 s_150) (void) (let-values () (raise-argument-error 'syntax-shift-phase-level \"syntax?\" s_150)))" +"(if(phase? phase_20)" +"(void)" +"(let-values()(raise-argument-error 'syntax-shift-phase-level phase?-string phase_20)))" +"(syntax-shift-phase-level$1 s_150 phase_20)))))" +"(define-values" +"(1/syntax-track-origin)" +"(lambda(new-stx_8 old-stx_4 id_97)" +"(begin" +" 'syntax-track-origin" +"(let-values((()" +"(begin" +"(if(syntax?$1 new-stx_8)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"syntax?\" new-stx_8)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(syntax?$1 old-stx_4)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"syntax?\" old-stx_4)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(identifier? id_97)" +"(void)" +" (let-values () (raise-argument-error 'syntax-track-origin \"identifier?\" id_97)))" +"(values))))" +"(let-values(((s_425)(syntax-track-origin$1 new-stx_8 old-stx_4 id_97)))" +"(let-values(((ctx_63)(let-values(((temp54_2) #t))(get-current-expand-context17.1 temp54_2 #t #f #f))))" +"(begin" +"(if ctx_63" +"(let-values()" +"(let-values(((obs_16)(expand-context-observer ctx_63)))" +"(if obs_16" +"(let-values()(let-values()(call-expand-observe obs_16 'track-origin new-stx_8 s_425)))" +"(void))))" +"(void))" +" s_425)))))))))" +"(define-values" +"(1/namespace-attach-module)" +"(let-values(((namespace-attach-module5_0)" +"(lambda(src-namespace3_0 mod-path4_0 dest-namespace1_0 dest-namespace2_0)" +"(begin" +" 'namespace-attach-module5" +"(let-values(((src-namespace_0) src-namespace3_0))" +"(let-values(((mod-path_10) mod-path4_0))" +"(let-values(((dest-namespace_0)" +"(if dest-namespace2_0 dest-namespace1_0(1/current-namespace))))" +"(let-values()" +"(let-values(((temp22_4) 'namespace-attach-module)" +"((src-namespace23_0) src-namespace_0)" +"((mod-path24_0) mod-path_10)" +"((dest-namespace25_0) dest-namespace_0)" +"((temp26_3) #t))" +"(do-attach-module19.1" +" temp26_3" +" #t" +" temp22_4" +" src-namespace23_0" +" mod-path24_0" +" dest-namespace25_0))))))))))" +"(case-lambda" +"((src-namespace_1 mod-path_11)" +"(begin 'namespace-attach-module(namespace-attach-module5_0 src-namespace_1 mod-path_11 #f #f)))" +"((src-namespace_2 mod-path_12 dest-namespace1_1)" +"(namespace-attach-module5_0 src-namespace_2 mod-path_12 dest-namespace1_1 #t)))))" +"(define-values" +"(1/namespace-attach-module-declaration)" +"(let-values(((namespace-attach-module-declaration11_0)" +"(lambda(src-namespace9_0 mod-path10_1 dest-namespace7_0 dest-namespace8_0)" +"(begin" +" 'namespace-attach-module-declaration11" +"(let-values(((src-namespace_3) src-namespace9_0))" +"(let-values(((mod-path_13) mod-path10_1))" +"(let-values(((dest-namespace_1)" +"(if dest-namespace8_0 dest-namespace7_0(1/current-namespace))))" +"(let-values()" +"(let-values(((temp27_5) 'namespace-attach-module-declaration)" +"((src-namespace28_0) src-namespace_3)" +"((mod-path29_0) mod-path_13)" +"((dest-namespace30_0) dest-namespace_1)" +"((temp31_3) #f))" +"(do-attach-module19.1" +" temp31_3" +" #t" +" temp27_5" +" src-namespace28_0" +" mod-path29_0" +" dest-namespace30_0))))))))))" +"(case-lambda" +"((src-namespace_4 mod-path_14)" +"(begin" +" 'namespace-attach-module-declaration" +"(namespace-attach-module-declaration11_0 src-namespace_4 mod-path_14 #f #f)))" +"((src-namespace_5 mod-path_15 dest-namespace7_1)" +"(namespace-attach-module-declaration11_0 src-namespace_5 mod-path_15 dest-namespace7_1 #t)))))" +"(define-values" +"(do-attach-module19.1)" +"(lambda(attach-instances?13_0 attach-instances?14_0 who15_1 src-namespace16_0 mod-path17_0 dest-namespace18_0)" +"(begin" +" 'do-attach-module19" +"(let-values(((who_18) who15_1))" +"(let-values(((src-namespace_6) src-namespace16_0))" +"(let-values(((mod-path_16) mod-path17_0))" +"(let-values(((dest-namespace_2) dest-namespace18_0))" +"(let-values(((attach-instances?_0)(if attach-instances?14_0 attach-instances?13_0 #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/namespace? src-namespace_6)" +"(void)" +" (let-values () (raise-argument-error who_18 \"namespace?\" src-namespace_6)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_56)(1/module-path? mod-path_16)))" +"(if or-part_56 or-part_56(1/resolved-module-path? mod-path_16)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_18" +" \"(or/c module-path? resolved-module-path?)\"" +" mod-path_16)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? dest-namespace_2)" +"(void)" +" (let-values () (raise-argument-error who_18 \"namespace?\" dest-namespace_2)))" +"(values))))" +"(let-values(((phase_133)(namespace-phase src-namespace_6)))" +"(let-values((()" +"(begin" +"(if(eqv? phase_133(namespace-phase dest-namespace_2))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_18" +" \"source and destination namespace phases do not match\"" +" \"source phase\"" +" phase_133" +" \"destination phase\"" +"(namespace-phase dest-namespace_2))))" +"(values))))" +"(let-values(((todo_0)(make-hasheq)))" +"(let-values(((missing_0)(gensym 'missing)))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_77)" +"(lambda(mpi_44" +" phase_0" +" attach-instances?_1" +" attach-phase_0)" +"(begin" +" 'loop" +"(let-values(((mod-name_19)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" src-namespace_6)" +"(let-values()" +"(1/module-path-index-resolve" +" mpi_44)))))" +"(let-values(((attach-this-instance?_0)" +"(if attach-instances?_1" +"(eqv? phase_0 attach-phase_0)" +" #f)))" +"(let-values(((m-ns_12)" +"(hash-ref" +"(hash-ref" +" todo_0" +" mod-name_19" +" '#hasheqv())" +" phase_0" +" missing_0)))" +"(if(let-values(((or-part_167)" +"(eq? missing_0 m-ns_12)))" +"(if or-part_167" +" or-part_167" +"(if attach-this-instance?_0" +"(not m-ns_12)" +" #f)))" +"(let-values()" +"(let-values(((m_20)" +"(namespace->module" +" src-namespace_6" +" mod-name_19)))" +"(begin" +"(if m_20" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_18" +" \"module not declared (in the source namespace)\"" +" \"module name\"" +" mod-name_19)))" +"(if(if(module-cross-phase-persistent?" +" m_20)" +"(if(not" +"(label-phase? phase_0))" +"(not(zero-phase? phase_0))" +" #f)" +" #f)" +"(let-values()" +"(loop_77" +" mpi_44" +" 0" +" attach-instances?_1" +" 0))" +"(let-values()" +"(let-values(((already-m_0)" +"(namespace->module" +" dest-namespace_2" +" mod-name_19)))" +"(let-values((()" +"(begin" +"(if(if already-m_0" +"(not" +"(eq?" +" already-m_0" +" m_20))" +" #f)" +"(let-values()" +"(raise-arguments-error" +" who_18" +" \"a different declaration is already in the destination namespace\"" +" \"module name\"" +" mod-name_19))" +"(void))" +"(values))))" +"(let-values(((m-ns_13" +" already?_0)" +"(if attach-this-instance?_0" +"(let-values()" +"(let-values(((m-ns_14)" +"(let-values(((src-namespace32_0)" +" src-namespace_6)" +"((mod-name33_0)" +" mod-name_19)" +"((phase34_0)" +" phase_0))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" src-namespace32_0" +" mod-name33_0" +" phase34_0))))" +"(let-values((()" +"(begin" +"(if m-ns_14" +"(void)" +"(let-values()" +"(raise-arguments-error" +" who_18" +" \"module not instantiated (in the source namespace)\"" +" \"module name\"" +" mod-name_19)))" +"(values))))" +"(let-values(((already-m-ns_0)" +"(if already-m_0" +"(let-values(((dest-namespace35_0)" +" dest-namespace_2)" +"((mod-name36_0)" +" mod-name_19)" +"((phase37_4)" +" phase_0))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" dest-namespace35_0" +" mod-name36_0" +" phase37_4))" +" #f)))" +"(begin" +"(if(if already-m-ns_0" +"(if(not" +"(eq?" +" m-ns_14" +" already-m-ns_0))" +"(not" +"(namespace-same-instance?" +" m-ns_14" +" already-m-ns_0))" +" #f)" +" #f)" +"(let-values()" +"(raise-arguments-error" +" who_18" +" \"a different instance is already in the destination namespace\"" +" \"module name\"" +" mod-name_19))" +"(void))" +"(values" +" m-ns_14" +"(if already-m-ns_0" +" #t" +" #f)))))))" +"(let-values()" +"(begin" +"(if(if(label-phase?" +" phase_0)" +"(not" +"(let-values(((src-namespace38_0)" +" src-namespace_6)" +"((mod-name39_0)" +" mod-name_19)" +"((phase40_0)" +" phase_0))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" src-namespace38_0" +" mod-name39_0" +" phase40_0)))" +" #f)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" src-namespace_6)" +"(let-values()" +"(let-values(((src-namespace41_0)" +" src-namespace_6)" +"((mpi42_0)" +" mpi_44)" +"((phase43_1)" +" phase_0))" +"(namespace-module-instantiate!96.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" src-namespace41_0" +" mpi42_0" +" phase43_1)))))" +"(void))" +"(values" +" #f" +"(if already-m_0" +" #t" +" #f)))))))" +"(begin" +"(hash-update!" +" todo_0" +" mod-name_19" +"(lambda(ht_142)" +"(hash-set" +" ht_142" +" phase_0" +" m-ns_13))" +" '#hasheqv())" +"(if already?_0" +"(void)" +"(let-values()" +"(begin" +"(let-values(((lst_293)" +"(module-requires" +" m_20)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_293)))" +"((letrec-values(((for-loop_251)" +"(lambda(lst_220)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_220)" +"(let-values(((phase+reqs_1)" +"(unsafe-car" +" lst_220))" +"((rest_164)" +"(unsafe-cdr" +" lst_220)))" +"(let-values((()" +"(let-values(((lst_158)" +"(cdr" +" phase+reqs_1)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_158)))" +"((letrec-values(((for-loop_252)" +"(lambda(lst_173)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_173)" +"(let-values(((req_5)" +"(unsafe-car" +" lst_173))" +"((rest_165)" +"(unsafe-cdr" +" lst_173)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_77" +"(module-path-index-shift" +" req_5" +"(module-self" +" m_20)" +" mpi_44)" +"(phase+" +" phase_0" +"(car" +" phase+reqs_1))" +" attach-instances?_1" +" attach-phase_0))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_252" +" rest_165)" +"(values))))" +"(values))))))" +" for-loop_252)" +" lst_158)))))" +"(if(not" +" #f)" +"(for-loop_251" +" rest_164)" +"(values))))" +"(values))))))" +" for-loop_251)" +" lst_293)))" +"(void)" +"(let-values(((lst_282)" +"(module-submodule-names" +" m_20)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_282)))" +"((letrec-values(((for-loop_253)" +"(lambda(lst_176)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_176)" +"(let-values(((submod-name_0)" +"(unsafe-car" +" lst_176))" +"((rest_91)" +"(unsafe-cdr" +" lst_176)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(loop_77" +"(1/module-path-index-join" +"(list" +" 'submod" +" \".\"" +" submod-name_0)" +" mpi_44)" +" #f" +" #f" +" attach-phase_0))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_253" +" rest_91)" +"(values))))" +"(values))))))" +" for-loop_253)" +" lst_282)))" +"(void)" +"(if(module-supermodule-name" +" m_20)" +"(let-values()" +"(loop_77" +"(1/module-path-index-join" +" '(submod" +" \"..\")" +" mpi_44)" +" #f" +" #f" +" attach-phase_0))" +"(void))))))))))))))" +"(void)))))))))" +" loop_77)" +"(1/module-path-index-join" +"(if(1/resolved-module-path? mod-path_16)" +"(resolved-module-path->module-path mod-path_16)" +" mod-path_16)" +" #f)" +" phase_133" +" attach-instances?_0" +" phase_133)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((ht_143) todo_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_143)))" +"((letrec-values(((for-loop_254)" +"(lambda(i_95)" +"(begin" +" 'for-loop" +"(if i_95" +"(let-values(((mod-name_20 phases_0)" +"(hash-iterate-key+value" +" ht_143" +" i_95)))" +"(let-values((()" +"(let-values(((ht_144)" +" phases_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_144)))" +"((letrec-values(((for-loop_238)" +"(lambda(i_168)" +"(begin" +" 'for-loop" +"(if i_168" +"(let-values(((phase_134" +" m-ns_15)" +"(hash-iterate-key+value" +" ht_144" +" i_168)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((m_21)" +"(namespace->module" +" src-namespace_6" +" mod-name_20)))" +"(begin" +"(module-force-bulk-binding!" +" m_21" +" src-namespace_6)" +"(let-values(((dest-namespace44_0)" +" dest-namespace_2)" +"((m45_0)" +" m_21)" +"((mod-name46_0)" +" mod-name_20))" +"(declare-module!58.1" +" #f" +" #f" +" dest-namespace44_0" +" m45_0" +" mod-name46_0))" +"(if m-ns_15" +"(let-values()" +"(begin" +"(namespace-record-module-instance-attached!" +" src-namespace_6" +" mod-name_20" +" phase_134)" +"(let-values(((or-part_261)" +"(let-values(((dest-namespace47_0)" +" dest-namespace_2)" +"((mod-name48_0)" +" mod-name_20)" +"((phase49_2)" +" phase_134))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" dest-namespace47_0" +" mod-name48_0" +" phase49_2))))" +"(if or-part_261" +" or-part_261" +"(namespace-install-module-namespace!" +" dest-namespace_2" +" mod-name_20" +" phase_134" +" m_21" +" m-ns_15)))))" +"(void)))))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_238" +"(hash-iterate-next" +" ht_144" +" i_168))" +"(values))))" +"(values))))))" +" for-loop_238)" +"(hash-iterate-first" +" ht_144))))))" +"(if(not #f)" +"(for-loop_254" +"(hash-iterate-next ht_143 i_95))" +"(values))))" +"(values))))))" +" for-loop_254)" +"(hash-iterate-first ht_143))))" +"(values))))" +"(let-values()" +"(let-values(((mnr_0)(1/current-module-name-resolver)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" dest-namespace_2)" +"(let-values()" +"(begin" +"(let-values(((ht_145) todo_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_145)))" +"((letrec-values(((for-loop_110)" +"(lambda(i_169)" +"(begin" +" 'for-loop" +"(if i_169" +"(let-values(((mod-name_21)" +"(hash-iterate-key ht_145 i_169)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(mnr_0" +" mod-name_21" +" src-namespace_6))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_110" +"(hash-iterate-next ht_145 i_169))" +"(values))))" +"(values))))))" +" for-loop_110)" +"(hash-iterate-first ht_145))))" +"(void))))))))))))))))))))))))" +"(define-values" +"(1/make-empty-namespace)" +"(lambda()" +"(begin" +" 'make-empty-namespace" +"(let-values(((current-ns_0)(1/current-namespace)))" +"(let-values(((phase_40)(namespace-phase current-ns_0)))" +"(let-values(((ns_58)(namespace->namespace-at-phase(make-namespace) phase_40)))" +"(begin" +"(1/namespace-attach-module current-ns_0 ''#%kernel ns_58)" +"(namespace-primitive-module-visit! ns_58 '#%kernel)" +" ns_58)))))))" +"(define-values" +"(1/namespace-syntax-introduce)" +"(let-values(((namespace-syntax-introduce4_0)" +"(lambda(s3_1 ns1_2 ns2_0)" +"(begin" +" 'namespace-syntax-introduce4" +"(let-values(((s_3) s3_1))" +"(let-values(((ns_59)(if ns2_0 ns1_2(1/current-namespace))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_3)" +"(void)" +"(let-values()" +" (raise-argument-error 'namespace-syntax-introduce \"syntax?\" s_3)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_59)" +"(void)" +"(let-values()" +" (raise-argument-error 'namespace-syntax-introduce \"namespace?\" ns_59)))" +"(values))))" +"(let-values(((root-ctx_5)(namespace-get-root-expand-ctx ns_59)))" +"(let-values(((post-scope_1)(root-expand-context-post-expansion-scope root-ctx_5)))" +"(let-values(((other-namespace-scopes_0)" +"(reverse$1" +"(let-values(((ht_79)" +"(syntax-scope-set" +"(root-expand-context-all-scopes-stx root-ctx_5)" +"(namespace-phase ns_59))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-immutable-hash-keys ht_79)))" +"((letrec-values(((for-loop_237)" +"(lambda(fold-var_220 i_170)" +"(begin" +" 'for-loop" +"(if i_170" +"(let-values(((sc_30)" +"(unsafe-immutable-hash-iterate-key" +" ht_79" +" i_170)))" +"(let-values(((fold-var_216)" +"(let-values(((fold-var_217)" +" fold-var_220))" +"(if(equal?" +" sc_30" +" post-scope_1)" +" fold-var_217" +"(let-values(((fold-var_30)" +" fold-var_217))" +"(let-values(((fold-var_218)" +"(let-values()" +"(cons" +"(let-values()" +" sc_30)" +" fold-var_30))))" +"(values" +" fold-var_218)))))))" +"(if(not #f)" +"(for-loop_237" +" fold-var_216" +"(unsafe-immutable-hash-iterate-next" +" ht_79" +" i_170))" +" fold-var_216)))" +" fold-var_220)))))" +" for-loop_237)" +" null" +"(unsafe-immutable-hash-iterate-first ht_79)))))))" +"(let-values(((add-ns-scopes_0)" +"(lambda(s_172)" +"(begin" +" 'add-ns-scopes" +"(let-values(((temp78_3)" +"(add-scopes" +"(push-scope s_172 post-scope_1)" +" other-namespace-scopes_0))" +"((temp79_1)" +"(root-expand-context-all-scopes-stx root-ctx_5))" +"((temp80_2)" +"(let-values(((or-part_164)" +"(namespace-declaration-inspector" +" ns_59)))" +"(if or-part_164" +" or-part_164" +"(current-code-inspector))))" +"((temp81_0) #t))" +"(syntax-transfer-shifts39.1" +" temp81_0" +" #t" +" temp78_3" +" temp79_1" +" temp80_2" +" #t))))))" +"(let-values(((maybe-module-id_0)" +"(if(pair?(1/syntax-e s_3))" +"(if(identifier?(car(1/syntax-e s_3)))" +"(add-ns-scopes_0(car(1/syntax-e s_3)))" +" #f)" +" #f)))" +"(if(if maybe-module-id_0" +"(1/free-identifier=?" +" maybe-module-id_0" +"(1/namespace-module-identifier ns_59)" +"(namespace-phase ns_59))" +" #f)" +"(let-values()" +"(1/datum->syntax" +" s_3" +"(cons maybe-module-id_0(cdr(1/syntax-e s_3)))" +" s_3" +" s_3))" +"(let-values()(add-ns-scopes_0 s_3)))))))))))))))))" +"(case-lambda" +"((s_72)(begin 'namespace-syntax-introduce(namespace-syntax-introduce4_0 s_72 #f #f)))" +"((s_426 ns1_3)(namespace-syntax-introduce4_0 s_426 ns1_3 #t)))))" +"(define-values" +"(1/namespace-module-identifier)" +"(let-values(((namespace-module-identifier8_0)" +"(lambda(where6_0 where7_0)" +"(begin" +" 'namespace-module-identifier8" +"(let-values(((where_0)(if where7_0 where6_0(1/current-namespace))))" +"(let-values()" +"(begin" +"(if(let-values(((or-part_70)(1/namespace? where_0)))" +"(if or-part_70 or-part_70(phase? where_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-module-identifier" +" (string-append \"(or/c namespace? \" phase?-string \")\")" +" where_0)))" +"(1/datum->syntax" +"(1/syntax-shift-phase-level" +" core-stx" +"(if(1/namespace? where_0)(namespace-phase where_0) where_0))" +" 'module))))))))" +"(case-lambda" +"(()(begin 'namespace-module-identifier(namespace-module-identifier8_0 #f #f)))" +"((where6_1)(namespace-module-identifier8_0 where6_1 #t)))))" +"(define-values" +"(1/namespace-symbol->identifier)" +"(lambda(sym_67)" +"(begin" +" 'namespace-symbol->identifier" +"(begin" +"(if(symbol? sym_67)" +"(void)" +" (let-values () (raise-argument-error 'namespace-symbol->identifier \"symbol?\" sym_67)))" +"(1/namespace-syntax-introduce(1/datum->syntax #f sym_67))))))" +"(define-values" +"(do-namespace-require23.1)" +"(lambda(copy-variable-as-constant?13_0" +" copy-variable-as-constant?18_0" +" copy-variable-phase-level12_0" +" copy-variable-phase-level17_0" +" run?10_0" +" run?15_0" +" skip-variable-phase-level14_0" +" skip-variable-phase-level19_0" +" visit?11_0" +" visit?16_0" +" who20_0" +" req21_0" +" ns22_1)" +"(begin" +" 'do-namespace-require23" +"(let-values(((run?_3)(if run?15_0 run?10_0 #t)))" +"(let-values(((visit?_3)(if visit?16_0 visit?11_0 #f)))" +"(let-values(((who_19) who20_0))" +"(let-values(((req_6) req21_0))" +"(let-values(((ns_60) ns22_1))" +"(let-values(((copy-variable-phase-level_2)" +"(if copy-variable-phase-level17_0 copy-variable-phase-level12_0 #f)))" +"(let-values(((copy-variable-as-constant?_2)" +"(if copy-variable-as-constant?18_0 copy-variable-as-constant?13_0 #f)))" +"(let-values(((skip-variable-phase-level_2)" +"(if skip-variable-phase-level19_0 skip-variable-phase-level14_0 #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_60)" +"(void)" +" (let-values () (raise-argument-error who_19 \"namespace?\" ns_60)))" +"(values))))" +"(let-values(((ctx-stx_0)" +"(add-scopes" +" empty-syntax" +"(root-expand-context-module-scopes(namespace-get-root-expand-ctx ns_60)))))" +"(if(let-values(((or-part_168)(1/module-path-index? req_6)))" +"(if or-part_168 or-part_168(1/module-path? req_6)))" +"(let-values()" +"(let-values(((temp82_1)" +"(if(1/module-path-index? req_6)" +" req_6" +"(1/module-path-index-join req_6 #f)))" +"((temp83_1) #f)" +"((temp84_1) #f)" +"((ctx-stx85_0) ctx-stx_0)" +"((ns86_0) ns_60)" +"((run?87_0) run?_3)" +"((visit?88_0) visit?_3)" +"((temp89_3)(namespace-phase ns_60))" +"((temp90_0)(namespace-phase ns_60))" +"((copy-variable-phase-level91_0) copy-variable-phase-level_2)" +"((copy-variable-as-constant?92_0) copy-variable-as-constant?_2)" +"((skip-variable-phase-level93_0) skip-variable-phase-level_2)" +"((who94_0) who_19))" +"(perform-require!78.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" copy-variable-as-constant?92_0" +" #t" +" copy-variable-phase-level91_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp89_3" +" #f" +" #f" +" temp90_0" +" run?87_0" +" #t" +" skip-variable-phase-level93_0" +" #t" +" visit?88_0" +" #t" +" who94_0" +" temp82_1" +" temp83_1" +" temp84_1" +" ctx-stx85_0" +" ns86_0)))" +"(let-values()" +"(let-values(((run?95_0) run?_3)" +"((visit?96_0) visit?_3)" +"((temp97_2)(list(1/datum->syntax ctx-stx_0 req_6)))" +"((temp98_2) #f)" +"((ns99_0) ns_60)" +"((temp100_1)(namespace-phase ns_60))" +"((temp101_0)" +"(let-values(((temp104_0) #f))" +"(make-requires+provides8.1 #f #f temp104_0)))" +"((skip-variable-phase-level102_0) skip-variable-phase-level_2)" +"((who103_0) who_19))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" run?95_0" +" #t" +" #f" +" #f" +" skip-variable-phase-level102_0" +" #t" +" visit?96_0" +" #t" +" who103_0" +" temp97_2" +" temp98_2" +" ns99_0" +" temp100_1" +" temp101_0))))))))))))))))))" +"(define-values" +"(1/namespace-require)" +"(let-values(((namespace-require29_0)" +"(lambda(req28_0 ns26_0 ns27_0)" +"(begin" +" 'namespace-require29" +"(let-values(((req_7) req28_0))" +"(let-values(((ns_76)(if ns27_0 ns26_0(1/current-namespace))))" +"(let-values()" +"(let-values(((temp105_1) 'namespace-require)((req106_0) req_7)((ns107_0) ns_76))" +"(do-namespace-require23.1 #f #f #f #f #f #f #f #f #f #f temp105_1 req106_0 ns107_0)))))))))" +"(case-lambda" +"((req_8)(begin 'namespace-require(namespace-require29_0 req_8 #f #f)))" +"((req_9 ns26_1)(namespace-require29_0 req_9 ns26_1 #t)))))" +"(define-values" +"(1/namespace-require/expansion-time)" +"(let-values(((namespace-require/expansion-time34_0)" +"(lambda(req33_0 ns31_0 ns32_0)" +"(begin" +" 'namespace-require/expansion-time34" +"(let-values(((req_10) req33_0))" +"(let-values(((ns_77)(if ns32_0 ns31_0(1/current-namespace))))" +"(let-values()" +"(let-values(((temp108_1) #f)" +"((temp109_1) #t)" +"((temp110_2) 'namespace-require/expansion-time)" +"((req111_0) req_10)" +"((ns112_0) ns_77))" +"(do-namespace-require23.1" +" #f" +" #f" +" #f" +" #f" +" temp108_1" +" #t" +" #f" +" #f" +" temp109_1" +" #t" +" temp110_2" +" req111_0" +" ns112_0)))))))))" +"(case-lambda" +"((req_11)(begin 'namespace-require/expansion-time(namespace-require/expansion-time34_0 req_11 #f #f)))" +"((req_12 ns31_1)(namespace-require/expansion-time34_0 req_12 ns31_1 #t)))))" +"(define-values" +"(1/namespace-require/constant)" +"(let-values(((namespace-require/constant39_0)" +"(lambda(req38_0 ns36_0 ns37_0)" +"(begin" +" 'namespace-require/constant39" +"(let-values(((req_13) req38_0))" +"(let-values(((ns_4)(if ns37_0 ns36_0(1/current-namespace))))" +"(let-values()" +"(let-values(((temp113_0) 'namespace-require/constant)" +"((req114_0) req_13)" +"((ns115_0) ns_4)" +"((temp116_1) 0)" +"((temp117_2) #t))" +"(do-namespace-require23.1" +" temp117_2" +" #t" +" temp116_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp113_0" +" req114_0" +" ns115_0)))))))))" +"(case-lambda" +"((req_14)(begin 'namespace-require/constant(namespace-require/constant39_0 req_14 #f #f)))" +"((req_15 ns36_1)(namespace-require/constant39_0 req_15 ns36_1 #t)))))" +"(define-values" +"(1/namespace-require/copy)" +"(let-values(((namespace-require/copy44_0)" +"(lambda(req43_0 ns41_0 ns42_0)" +"(begin" +" 'namespace-require/copy44" +"(let-values(((req_16) req43_0))" +"(let-values(((ns_78)(if ns42_0 ns41_0(1/current-namespace))))" +"(let-values()" +"(let-values(((temp118_2) 'namespace-require/copy)" +"((req119_0) req_16)" +"((ns120_0) ns_78)" +"((temp121_2) 0)" +"((temp122_1) 0))" +"(do-namespace-require23.1" +" #f" +" #f" +" temp121_2" +" #t" +" #f" +" #f" +" temp122_1" +" #t" +" #f" +" #f" +" temp118_2" +" req119_0" +" ns120_0)))))))))" +"(case-lambda" +"((req_17)(begin 'namespace-require/copy(namespace-require/copy44_0 req_17 #f #f)))" +"((req_18 ns41_1)(namespace-require/copy44_0 req_18 ns41_1 #t)))))" +"(define-values" +"(1/namespace-variable-value)" +"(let-values(((namespace-variable-value53_0)" +"(lambda(sym52_0 use-mapping?46_0 failure-thunk47_0 ns48_0 use-mapping?49_0 failure-thunk50_0 ns51_0)" +"(begin" +" 'namespace-variable-value53" +"(let-values(((sym_51) sym52_0))" +"(let-values(((use-mapping?_0)(if use-mapping?49_0 use-mapping?46_0 #f)))" +"(let-values(((failure-thunk_5)(if failure-thunk50_0 failure-thunk47_0 #f)))" +"(let-values(((ns_79)(if ns51_0 ns48_0(1/current-namespace))))" +"(let-values()" +"(begin" +"(if(symbol? sym_51)" +"(void)" +" (let-values () (raise-argument-error 'namespace-variable-value \"symbol?\" sym_51)))" +"(if(let-values(((or-part_103)(not failure-thunk_5)))" +"(if or-part_103" +" or-part_103" +"(if(procedure? failure-thunk_5)" +"(procedure-arity-includes? failure-thunk_5 0)" +" #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-variable-value" +" \"(or/c #f (procedure-arity-includes/c 0))\"" +" failure-thunk_5)))" +"(if(1/namespace? ns_79)" +"(void)" +" (let-values () (raise-argument-error 'namespace-variable-value \"namespace?\" ns_79)))" +"((call/ec" +"(lambda(escape_0)" +"(let-values(((var-ns_0 var-phase-level_0 var-sym_6)" +"(if use-mapping?_0" +"(let-values()" +"(let-values(((id_98)(1/datum->syntax #f sym_51)))" +"(let-values(((b_89)" +"(resolve+shift/extra-inspector" +"(1/namespace-syntax-introduce id_98 ns_79)" +"(namespace-phase ns_79)" +" ns_79)))" +"(let-values((()" +"(begin" +"(if b_89" +"(let-values()" +"(namespace-visit-available-modules!" +" ns_79))" +"(void))" +"(values))))" +"(let-values(((v_192 primitive?_8 extra-inspector_8)" +"(if b_89" +"(let-values(((b123_0) b_89)" +"((empty-env124_0) empty-env)" +"((null125_0) null)" +"((ns126_0) ns_79)" +"((temp127_1)" +"(namespace-phase ns_79))" +"((id128_0) id_98))" +"(binding-lookup48.1" +" #f" +" #f" +" #f" +" #f" +" b123_0" +" empty-env124_0" +" null125_0" +" ns126_0" +" temp127_1" +" id128_0))" +"(values variable #f #f))))" +"(begin" +"(if(variable? v_192)" +"(void)" +"(let-values()" +"(escape_0" +"(let-values(((or-part_287) failure-thunk_5))" +"(if or-part_287" +" or-part_287" +"(lambda()" +"(raise" +"(make-exn:fail:syntax$1" +"(format" +"(string-append" +" \"namespace-variable-value: bound to syntax\\n\"" +" \" in: ~s\")" +" sym_51)" +"(current-continuation-marks)" +" null))))))))" +"(if(module-binding? b_89)" +"(values" +"(if(top-level-module-path-index?" +"(module-binding-module b_89))" +" ns_79" +"(module-instance-namespace" +"(binding->module-instance" +" b_89" +" ns_79" +"(namespace-phase ns_79)" +" id_98)))" +"(module-binding-phase b_89)" +"(module-binding-sym b_89))" +"(values ns_79(namespace-phase ns_79) sym_51))))))))" +"(let-values()(values ns_79(namespace-phase ns_79) sym_51)))))" +"(let-values(((val_10)" +"(namespace-get-variable" +" var-ns_0" +" var-phase-level_0" +" var-sym_6" +"(lambda()" +"(escape_0" +"(let-values(((or-part_288) failure-thunk_5))" +"(if or-part_288" +" or-part_288" +"(raise" +"(exn:fail:contract:variable" +"(format" +"(string-append" +" \"namespace-variable-value: given name is not defined\\n\"" +" \" name: ~s\")" +" sym_51)" +"(current-continuation-marks)" +" sym_51)))))))))" +"(lambda() val_10))))))))))))))))" +"(case-lambda" +"((sym_68)(begin 'namespace-variable-value(namespace-variable-value53_0 sym_68 #f #f #f #f #f #f)))" +"((sym_69 use-mapping?_1 failure-thunk_6 ns48_1)" +"(namespace-variable-value53_0 sym_69 use-mapping?_1 failure-thunk_6 ns48_1 #t #t #t))" +"((sym_70 use-mapping?_2 failure-thunk47_1)" +"(namespace-variable-value53_0 sym_70 use-mapping?_2 failure-thunk47_1 #f #t #t #f))" +"((sym_71 use-mapping?46_1)(namespace-variable-value53_0 sym_71 use-mapping?46_1 #f #f #t #f #f)))))" +"(define-values" +"(1/namespace-set-variable-value!)" +"(let-values(((namespace-set-variable-value!63_0)" +"(lambda(sym61_0 val62_0 map?55_0 ns56_0 as-constant?57_0 map?58_0 ns59_0 as-constant?60_0)" +"(begin" +" 'namespace-set-variable-value!63" +"(let-values(((sym_72) sym61_0))" +"(let-values(((val_69) val62_0))" +"(let-values(((map?_0)(if map?58_0 map?55_0 #f)))" +"(let-values(((ns_80)(if ns59_0 ns56_0(1/current-namespace))))" +"(let-values(((as-constant?_2)(if as-constant?60_0 as-constant?57_0 #f)))" +"(let-values()" +"(begin" +"(if(symbol? sym_72)" +"(void)" +" (let-values () (raise-argument-error 'namespace-variable-value \"symbol?\" sym_72)))" +"(if(1/namespace? ns_80)" +"(void)" +" (let-values () (raise-argument-error 'namespace-variable-value \"namespace?\" ns_80)))" +"(namespace-set-variable! ns_80(namespace-phase ns_80) sym_72 val_69 as-constant?_2)" +"(if map?_0" +"(let-values()" +"(let-values((()" +"(begin" +"(namespace-unset-transformer!" +" ns_80" +"(namespace-phase ns_80)" +" sym_72)" +"(values))))" +"(let-values(((id_99)(1/datum->syntax #f sym_72)))" +"(let-values(((temp129_1)(1/namespace-syntax-introduce id_99 ns_80))" +"((temp130_1)" +"(let-values(((temp132_1)(namespace-mpi ns_80))" +"((temp133_1)(namespace-phase ns_80))" +"((sym134_0) sym_72))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp132_1" +" temp133_1" +" sym134_0)))" +"((temp131_0)(namespace-phase ns_80)))" +"(add-binding!17.1 #f #f #f #f temp129_1 temp130_1 temp131_0)))))" +"(void)))))))))))))" +"(case-lambda" +"((sym_73 val_70)" +"(begin 'namespace-set-variable-value!(namespace-set-variable-value!63_0 sym_73 val_70 #f #f #f #f #f #f)))" +"((sym_74 val_71 map?_1 ns_81 as-constant?57_1)" +"(namespace-set-variable-value!63_0 sym_74 val_71 map?_1 ns_81 as-constant?57_1 #t #t #t))" +"((sym_75 val_50 map?_2 ns56_1)(namespace-set-variable-value!63_0 sym_75 val_50 map?_2 ns56_1 #f #t #t #f))" +"((sym_76 val_72 map?55_1)(namespace-set-variable-value!63_0 sym_76 val_72 map?55_1 #f #f #t #f #f)))))" +"(define-values" +"(1/namespace-undefine-variable!)" +"(let-values(((namespace-undefine-variable!68_0)" +"(lambda(sym67_0 ns65_0 ns66_0)" +"(begin" +" 'namespace-undefine-variable!68" +"(let-values(((sym_77) sym67_0))" +"(let-values(((ns_82)(if ns66_0 ns65_0(1/current-namespace))))" +"(let-values()" +"(begin" +"(if(symbol? sym_77)" +"(void)" +" (let-values () (raise-argument-error 'namespace-variable-value \"symbol?\" sym_77)))" +"(if(1/namespace? ns_82)" +"(void)" +" (let-values () (raise-argument-error 'namespace-variable-value \"namespace?\" ns_82)))" +"(namespace-unset-variable! ns_82(namespace-phase ns_82) sym_77)))))))))" +"(case-lambda" +"((sym_78)(begin 'namespace-undefine-variable!(namespace-undefine-variable!68_0 sym_78 #f #f)))" +"((sym_79 ns65_1)(namespace-undefine-variable!68_0 sym_79 ns65_1 #t)))))" +"(define-values" +"(1/namespace-mapped-symbols)" +"(let-values(((namespace-mapped-symbols72_0)" +"(lambda(ns70_0 ns71_0)" +"(begin" +" 'namespace-mapped-symbols72" +"(let-values(((ns_83)(if ns71_0 ns70_0(1/current-namespace))))" +"(let-values()" +"(begin" +"(if(1/namespace? ns_83)" +"(void)" +" (let-values () (raise-argument-error 'namespace-mapped-symbols \"namespace?\" ns_83)))" +"(set->list" +"(set-union" +"(syntax-mapped-names" +"(root-expand-context-all-scopes-stx(namespace-get-root-expand-ctx ns_83))" +"(namespace-phase ns_83))" +"(list->set(1/instance-variable-names(namespace->instance ns_83 0))))))))))))" +"(case-lambda" +"(()(begin 'namespace-mapped-symbols(namespace-mapped-symbols72_0 #f #f)))" +"((ns70_1)(namespace-mapped-symbols72_0 ns70_1 #t)))))" +"(define-values" +"(1/namespace-base-phase)" +"(let-values(((namespace-base-phase76_0)" +"(lambda(ns74_0 ns75_0)" +"(begin" +" 'namespace-base-phase76" +"(let-values(((ns_84)(if ns75_0 ns74_0(1/current-namespace))))" +"(let-values()" +"(begin" +"(if(1/namespace? ns_84)" +"(void)" +" (let-values () (raise-argument-error 'namespace-base-phase \"namespace?\" ns_84)))" +"(namespace-phase ns_84))))))))" +"(case-lambda" +"(()(begin 'namespace-base-phase(namespace-base-phase76_0 #f #f)))" +"((ns74_1)(namespace-base-phase76_0 ns74_1 #t)))))" +"(define-values" +"(1/eval)" +"(let-values(((eval6_0)" +"(lambda(s5_1 ns1_4 compile2_0 ns3_0 compile4_0)" +"(begin" +" 'eval6" +"(let-values(((s_146) s5_1))" +"(let-values(((ns_42)(if ns3_0 ns1_4(1/current-namespace))))" +"(let-values(((compile_1)" +"(if compile4_0" +" compile2_0" +"(lambda(s_411 ns_67)(begin 'compile(1/compile s_411 ns_67 #f))))))" +"(let-values()" +"(if(let-values(((or-part_289)(compiled-in-memory? s_146)))" +"(if or-part_289" +" or-part_289" +"(let-values(((or-part_290)(1/linklet-directory? s_146)))" +"(if or-part_290 or-part_290(1/linklet-bundle? s_146)))))" +"(let-values()(eval-compiled s_146 ns_42))" +"(if(if(syntax?$1 s_146)" +"(let-values(((or-part_291)(compiled-in-memory?(1/syntax-e s_146))))" +"(if or-part_291" +" or-part_291" +"(let-values(((or-part_292)(1/linklet-directory?(1/syntax-e s_146))))" +"(if or-part_292 or-part_292(1/linklet-bundle?(1/syntax-e s_146))))))" +" #f)" +"(let-values()(eval-compiled(1/syntax->datum s_146) ns_42))" +"(let-values()" +"(let-values(((temp82_2)" +"(lambda(s_173 ns_85 tail?_52)" +"(eval-compiled(compile_1 s_173 ns_85) ns_85 tail?_52)))" +"((temp83_2) #f))" +"(per-top-level68.1" +" #f" +" #f" +" #f" +" #f" +" temp83_2" +" #f" +" #f" +" #f" +" #f" +" temp82_2" +" #f" +" #f" +" s_146" +" ns_42)))))))))))))" +"(case-lambda" +"((s_426)(begin 'eval(eval6_0 s_426 #f #f #f #f)))" +"((s_427 ns_44 compile2_1)(eval6_0 s_427 ns_44 compile2_1 #t #t))" +"((s_174 ns1_5)(eval6_0 s_174 ns1_5 #f #t #f)))))" +"(define-values" +"(eval-compiled)" +"(let-values(((eval-compiled12_0)" +"(lambda(c10_0 ns11_0 as-tail?8_0 as-tail?9_0)" +"(begin" +" 'eval-compiled12" +"(let-values(((c_52) c10_0))" +"(let-values(((ns_86) ns11_0))" +"(let-values(((as-tail?_3)(if as-tail?9_0 as-tail?8_0 #t)))" +"(let-values()" +"(if(1/compiled-module-expression? c_52)" +"(let-values()" +"(let-values(((ns85_0) ns_86))(eval-module8.1 ns85_0 #t #f #f #f #f c_52)))" +"(let-values()(eval-top c_52 ns_86 eval-compiled as-tail?_3)))))))))))" +"(case-lambda" +"((c_39 ns_87)(begin(eval-compiled12_0 c_39 ns_87 #f #f)))" +"((c_40 ns_88 as-tail?8_1)(eval-compiled12_0 c_40 ns_88 as-tail?8_1 #t)))))" +"(define-values" +"(1/compile)" +"(let-values(((compile23_0)" +"(lambda(s22_1" +" ns14_2" +" serializable?15_0" +" expand16_0" +" to-source?17_0" +" ns18_0" +" serializable?19_0" +" expand20_0" +" to-source?21_1)" +"(begin" +" 'compile23" +"(let-values(((s_162) s22_1))" +"(let-values(((ns_89)(if ns18_0 ns14_2(1/current-namespace))))" +"(let-values(((serializable?_4)(if serializable?19_0 serializable?15_0 #t)))" +"(let-values(((expand_0)(if expand20_0 expand16_0 expand$1)))" +"(let-values(((to-source?_5)(if to-source?21_1 to-source?17_0 #f)))" +"(let-values()" +"(let-values(((cs_0)" +"(if(1/compiled-expression? s_162)" +"(let-values()(list s_162))" +"(if(if(syntax?$1 s_162)" +"(1/compiled-expression?(1/syntax-e s_162))" +" #f)" +"(let-values()(list(1/syntax-e s_162)))" +"(let-values()" +"(let-values(((temp88_2)" +"(lambda(s_428 ns_45 as-tail?_4)" +"(list" +"(compile-single$1" +" s_428" +" ns_45" +" expand_0" +" serializable?_4" +" to-source?_5))))" +"((append89_0) append)" +"((temp90_1) #f))" +"(per-top-level68.1" +" append89_0" +" #t" +" #f" +" #f" +" temp90_1" +" #f" +" #f" +" #f" +" #f" +" temp88_2" +" #f" +" #f" +" s_162" +" ns_89)))))))" +"(if(if(= 1(length cs_0))(not(compiled-multiple-top?(car cs_0))) #f)" +"(car cs_0)" +"(let-values(((to-source?92_0) to-source?_5)" +"((serializable?93_0) serializable?_4)" +"((ns94_0) ns_89))" +"(compiled-tops->compiled-top8.1" +" serializable?93_0" +" #t" +" ns94_0" +" #t" +" to-source?92_0" +" #t" +" cs_0))))))))))))))" +"(case-lambda" +"((s_429)(begin 'compile(compile23_0 s_429 #f #f #f #f #f #f #f #f)))" +"((s_430 ns_47 serializable?_5 expand_1 to-source?17_1)" +"(compile23_0 s_430 ns_47 serializable?_5 expand_1 to-source?17_1 #t #t #t #t))" +"((s_149 ns_90 serializable?_6 expand16_1)(compile23_0 s_149 ns_90 serializable?_6 expand16_1 #f #t #t #t #f))" +"((s_186 ns_91 serializable?15_1)(compile23_0 s_186 ns_91 serializable?15_1 #f #f #t #t #f #f))" +"((s_17 ns14_3)(compile23_0 s_17 ns14_3 #f #f #f #t #f #f #f)))))" +"(define-values" +"(compile-to-linklets)" +"(let-values(((compile-to-linklets28_0)" +"(lambda(s27_0 ns25_0 ns26_2)" +"(begin" +" 'compile-to-linklets28" +"(let-values(((s_22) s27_0))" +"(let-values(((ns_62)(if ns26_2 ns25_0(1/current-namespace))))" +"(let-values()(1/compile s_22 ns_62 #t expand$1 #t))))))))" +"(case-lambda" +"((s_431)(begin(compile-to-linklets28_0 s_431 #f #f)))" +"((s_24 ns25_1)(compile-to-linklets28_0 s_24 ns25_1 #t)))))" +"(define-values" +"(struct:lifted-parsed-begin" +" lifted-parsed-begin30.1" +" lifted-parsed-begin?" +" lifted-parsed-begin-seq" +" lifted-parsed-begin-last)" +"(let-values(((struct:_73 make-_73 ?_73 -ref_73 -set!_73)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'lifted-parsed-begin" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '(0 1)" +" #f" +" 'lifted-parsed-begin)))))" +"(values" +" struct:_73" +" make-_73" +" ?_73" +"(make-struct-field-accessor -ref_73 0 'seq)" +"(make-struct-field-accessor -ref_73 1 'last))))" +"(define-values" +"(compile-single$1)" +"(lambda(s_432 ns_92 expand_2 serializable?_7 to-source?_6)" +"(begin" +" 'compile-single" +"(let-values(((exp-s_4)(expand_2 s_432 ns_92 #f #t serializable?_7)))" +"((letrec-values(((loop_97)" +"(lambda(exp-s_5)" +"(begin" +" 'loop" +"(if(parsed-module? exp-s_5)" +"(let-values()" +"(let-values(((temp97_3)" +"(let-values(((ns100_0) ns_92))" +"(make-compile-context14.1 #f #f #f #f #f #f ns100_0 #t #f #f #f #f)))" +"((serializable?98_0) serializable?_7)" +"((to-source?99_0) to-source?_6))" +"(compile-module13.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" serializable?98_0" +" #t" +" to-source?99_0" +" #t" +" exp-s_5" +" temp97_3)))" +"(if(lifted-parsed-begin? exp-s_5)" +"(let-values()" +"(let-values(((temp101_1)" +"(reverse$1" +"(let-values(((lst_163)" +"(append" +"(lifted-parsed-begin-seq exp-s_5)" +"(list(lifted-parsed-begin-last exp-s_5)))))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_163)))" +"((letrec-values(((for-loop_183)" +"(lambda(fold-var_258 lst_180)" +"(begin" +" 'for-loop" +"(if(pair? lst_180)" +"(let-values(((e_72)" +"(unsafe-car lst_180))" +"((rest_95)" +"(unsafe-cdr lst_180)))" +"(let-values(((fold-var_160)" +"(let-values(((fold-var_161)" +" fold-var_258))" +"(let-values(((fold-var_259)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_97" +" e_72))" +" fold-var_161))))" +"(values" +" fold-var_259)))))" +"(if(not #f)" +"(for-loop_183 fold-var_160 rest_95)" +" fold-var_160)))" +" fold-var_258)))))" +" for-loop_183)" +" null" +" lst_163)))))" +"((to-source?102_0) to-source?_6))" +"(compiled-tops->compiled-top8.1 #f #f #f #f to-source?102_0 #t temp101_1)))" +"(let-values()" +"(let-values(((temp104_1)" +"(let-values(((ns107_1) ns_92))" +"(make-compile-context14.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns107_1" +" #t" +" #f" +" #f" +" #f" +" #f)))" +"((serializable?105_0) serializable?_7)" +"((to-source?106_0) to-source?_6))" +"(compile-top9.1" +" serializable?105_0" +" #t" +" #f" +" #f" +" to-source?106_0" +" #t" +" exp-s_5" +" temp104_1)))))))))" +" loop_97)" +" exp-s_4)))))" +"(define-values" +"(expand$1)" +"(let-values(((expand40_0)" +"(lambda(s39_0" +" ns31_2" +" observable?32_0" +" to-parsed?33_0" +" serializable?34_0" +" ns35_0" +" observable?36_0" +" to-parsed?37_0" +" serializable?38_0)" +"(begin" +" 'expand40" +"(let-values(((s_50) s39_0))" +"(let-values(((ns_93)(if ns35_0 ns31_2(1/current-namespace))))" +"(let-values(((observable?_1)(if observable?36_0 observable?32_0 #f)))" +"(let-values(((to-parsed?_2)(if to-parsed?37_0 to-parsed?33_0 #f)))" +"(let-values(((serializable?_8)(if serializable?38_0 serializable?34_0 #f)))" +"(let-values()" +"(begin" +"(if observable?_1(let-values()(log-expand-start))(void))" +"(let-values(((temp110_3)" +"(lambda(s_316 ns_94 as-tail?_5)" +"(expand-single" +" s_316" +" ns_94" +" observable?_1" +" to-parsed?_2" +" serializable?_8)))" +"((cons111_0) cons)" +"((re-pair112_0) re-pair)" +"((observable?113_0) observable?_1))" +"(per-top-level68.1" +" cons111_0" +" #t" +" #f" +" #f" +" observable?113_0" +" #f" +" #f" +" #f" +" #f" +" temp110_3" +" re-pair112_0" +" #t" +" s_50" +" ns_93)))))))))))))" +"(case-lambda" +"((s_433)(begin 'expand(expand40_0 s_433 #f #f #f #f #f #f #f #f)))" +"((s_434 ns_95 observable?_2 to-parsed?_3 serializable?34_1)" +"(expand40_0 s_434 ns_95 observable?_2 to-parsed?_3 serializable?34_1 #t #t #t #t))" +"((s_54 ns_96 observable?_3 to-parsed?33_1)(expand40_0 s_54 ns_96 observable?_3 to-parsed?33_1 #f #t #t #t #f))" +"((s_55 ns_97 observable?32_1)(expand40_0 s_55 ns_97 observable?32_1 #f #f #t #t #f #f))" +"((s_319 ns31_3)(expand40_0 s_319 ns31_3 #f #f #f #t #f #f #f)))))" +"(define-values" +"(expand-single)" +"(lambda(s_388 ns_98 observable?_4 to-parsed?_4 serializable?_9)" +"(begin" +"(let-values(((rebuild-s_2)(keep-properties-only s_388)))" +"(let-values(((ctx_64)" +"(let-values(((to-parsed?115_0) to-parsed?_4)" +"((serializable?116_0) serializable?_9)" +"((observable?117_0) observable?_4))" +"(make-expand-context10.1 serializable?116_0 #t observable?117_0 #t to-parsed?115_0 #t ns_98))))" +"(let-values(((require-lifts_3 lifts_9 exp-s_6)(expand-capturing-lifts s_388 ctx_64)))" +"(if(if(null? require-lifts_3)(null? lifts_9) #f)" +"(let-values() exp-s_6)" +"(if to-parsed?_4" +"(let-values()" +"(let-values(((temp122_2)" +"(lambda(form_0)" +"(expand-single form_0 ns_98 observable?_4 to-parsed?_4 serializable?_9))))" +"(wrap-lifts-as-lifted-parsed-begin77.1 temp122_2 require-lifts_3 lifts_9 exp-s_6 rebuild-s_2)))" +"(let-values()" +"(let-values((()" +"(begin" +"(log-top-lift-begin-before ctx_64 require-lifts_3 lifts_9 exp-s_6 ns_98)" +"(values))))" +"(let-values(((new-s_1)" +"(let-values(((temp123_2)(append require-lifts_3 lifts_9))" +"((temp124_2)" +"(lambda(form_1)" +"(begin" +"(let-values(((obs_26)(expand-context-observer ctx_64)))" +"(if obs_26" +"(let-values()" +"(let-values()(call-expand-observe obs_26 'next)))" +"(void)))" +"(expand-single" +" form_1" +" ns_98" +" observable?_4" +" to-parsed?_4" +" serializable?_9))))" +"((temp125_1)" +"(lambda(form_2)" +"(if to-parsed?_4" +"(let-values() form_2)" +"(let-values()" +"(begin" +"(let-values(((obs_42)(expand-context-observer ctx_64)))" +"(if obs_42" +"(let-values()" +"(let-values()(call-expand-observe obs_42 'next)))" +"(void)))" +"(expand-single" +" form_2" +" ns_98" +" observable?_4" +" to-parsed?_4" +" serializable?_9))))))" +"((exp-s126_0) exp-s_6)" +"((temp127_2)(namespace-phase ns_98)))" +"(wrap-lifts-as-begin16.1" +" temp125_1" +" #t" +" temp124_2" +" #t" +" temp123_2" +" exp-s126_0" +" temp127_2))))" +"(begin(log-top-begin-after ctx_64 new-s_1) new-s_1))))))))))))" +"(define-values" +"(expand-once$1)" +"(let-values(((expand-once45_0)" +"(lambda(s44_1 ns42_1 ns43_0)" +"(begin" +" 'expand-once45" +"(let-values(((s_197) s44_1))" +"(let-values(((ns_99)(if ns43_0 ns42_1(1/current-namespace))))" +"(let-values()" +"(let-values(((temp130_2)" +"(lambda(s_200 ns_100 as-tail?_6)(expand-single-once s_200 ns_100)))" +"((cons131_0) cons)" +"((re-pair132_0) re-pair)" +"((temp133_2) #t)" +"((temp134_1) #t))" +"(per-top-level68.1" +" cons131_0" +" #t" +" temp133_2" +" #t" +" temp134_1" +" #f" +" #f" +" #f" +" #f" +" temp130_2" +" re-pair132_0" +" #t" +" s_197" +" ns_99)))))))))" +"(case-lambda" +"((s_320)(begin 'expand-once(expand-once45_0 s_320 #f #f)))" +"((s_435 ns42_2)(expand-once45_0 s_435 ns42_2 #t)))))" +"(define-values" +"(expand-single-once)" +"(lambda(s_63 ns_101)" +"(begin" +"(let-values(((require-lifts_4 lifts_10 exp-s_7)" +"(expand-capturing-lifts" +" s_63" +"(let-values(((v_111)" +"(let-values(((temp136_1) #t))" +"(make-expand-context10.1 #f #f temp136_1 #t #f #f ns_101))))" +"(let-values(((the-struct_70) v_111))" +"(if(expand-context/outer? the-struct_70)" +"(let-values(((inner137_0)" +"(let-values(((the-struct_71)(root-expand-context/outer-inner v_111)))" +"(if(expand-context/inner? the-struct_71)" +"(let-values(((just-once?138_0) #t))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes the-struct_71)" +"(root-expand-context/inner-top-level-bind-scope the-struct_71)" +"(root-expand-context/inner-all-scopes-stx the-struct_71)" +"(root-expand-context/inner-defined-syms the-struct_71)" +"(root-expand-context/inner-counter the-struct_71)" +"(root-expand-context/inner-lift-key the-struct_71)" +"(expand-context/inner-to-parsed? the-struct_71)" +"(expand-context/inner-phase the-struct_71)" +"(expand-context/inner-namespace the-struct_71)" +" just-once?138_0" +"(expand-context/inner-module-begin-k the-struct_71)" +"(expand-context/inner-allow-unbound? the-struct_71)" +"(expand-context/inner-in-local-expand? the-struct_71)" +"(expand-context/inner-stops the-struct_71)" +"(expand-context/inner-declared-submodule-names the-struct_71)" +"(expand-context/inner-lifts the-struct_71)" +"(expand-context/inner-lift-envs the-struct_71)" +"(expand-context/inner-module-lifts the-struct_71)" +"(expand-context/inner-require-lifts the-struct_71)" +"(expand-context/inner-to-module-lifts the-struct_71)" +"(expand-context/inner-requires+provides the-struct_71)" +"(expand-context/inner-observer the-struct_71)" +"(expand-context/inner-for-serializable? the-struct_71)" +"(expand-context/inner-should-not-encounter-macros? the-struct_71)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_71)))))" +"(expand-context/outer1.1" +" inner137_0" +"(root-expand-context/outer-post-expansion-scope the-struct_70)" +"(root-expand-context/outer-use-site-scopes the-struct_70)" +"(root-expand-context/outer-frame-id the-struct_70)" +"(expand-context/outer-context the-struct_70)" +"(expand-context/outer-env the-struct_70)" +"(expand-context/outer-post-expansion-scope-action the-struct_70)" +"(expand-context/outer-scopes the-struct_70)" +"(expand-context/outer-def-ctx-scopes the-struct_70)" +"(expand-context/outer-binding-layer the-struct_70)" +"(expand-context/outer-reference-records the-struct_70)" +"(expand-context/outer-only-immediate? the-struct_70)" +"(expand-context/outer-need-eventually-defined the-struct_70)" +"(expand-context/outer-current-introduction-scopes the-struct_70)" +"(expand-context/outer-name the-struct_70)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_70)))))))" +"(if(if(null? require-lifts_4)(null? lifts_10) #f)" +"(let-values() exp-s_7)" +"(let-values()" +"(let-values(((temp139_0)(append require-lifts_4 lifts_10))" +"((exp-s140_0) exp-s_7)" +"((temp141_1)(namespace-phase ns_101)))" +"(wrap-lifts-as-begin16.1 #f #f #f #f temp139_0 exp-s140_0 temp141_1))))))))" +"(define-values" +"(expand-to-top-form$1)" +"(let-values(((expand-to-top-form50_0)" +"(lambda(s49_0 ns47_0 ns48_2)" +"(begin" +" 'expand-to-top-form50" +"(let-values(((s_203) s49_0))" +"(let-values(((ns_102)(if ns48_2 ns47_0(1/current-namespace))))" +"(let-values()" +"(begin" +"(log-expand-start)" +"(let-values(((temp144_1) #f)((temp145_0) #f)((temp146_0) #t))" +"(per-top-level68.1" +" #f" +" #f" +" #f" +" #f" +" temp146_0" +" temp145_0" +" #t" +" #f" +" #f" +" temp144_1" +" #f" +" #f" +" s_203" +" ns_102))))))))))" +"(case-lambda" +"((s_436)(begin 'expand-to-top-form(expand-to-top-form50_0 s_436 #f #f)))" +"((s_437 ns47_1)(expand-to-top-form50_0 s_437 ns47_1 #t)))))" +"(define-values" +"(per-top-level68.1)" +"(lambda(combine53_0" +" combine60_0" +" just-once?55_0" +" just-once?62_0" +" observable?58_0" +" quick-immediate?56_0" +" quick-immediate?63_0" +" serializable?57_0" +" serializable?64_0" +" single52_0" +" wrap54_0" +" wrap61_0" +" given-s66_0" +" ns67_1)" +"(begin" +" 'per-top-level68" +"(let-values(((given-s_0) given-s66_0))" +"(let-values(((ns_103) ns67_1))" +"(let-values(((single_0) single52_0))" +"(let-values(((combine_0)(if combine60_0 combine53_0 #f)))" +"(let-values(((wrap_2)(if wrap61_0 wrap54_0 #f)))" +"(let-values(((just-once?_1)(if just-once?62_0 just-once?55_0 #f)))" +"(let-values(((quick-immediate?_0)(if quick-immediate?63_0 quick-immediate?56_0 #t)))" +"(let-values(((serializable?_10)(if serializable?64_0 serializable?57_0 #f)))" +"(let-values(((observable?_5) observable?58_0))" +"(let-values()" +"(let-values(((s_438)(maybe-intro given-s_0 ns_103)))" +"(let-values(((ctx_1)" +"(let-values(((observable?148_0) observable?_5))" +"(make-expand-context10.1 #f #f observable?148_0 #t #f #f ns_103))))" +"(let-values(((phase_135)(namespace-phase ns_103)))" +"((letrec-values(((loop_98)" +"(lambda(s_209 phase_50 ns_104 as-tail?_7)" +"(begin" +" 'loop" +"(let-values(((tl-ctx_0)" +"(let-values(((v_193) ctx_1))" +"(let-values(((the-struct_72) v_193))" +"(if(expand-context/outer? the-struct_72)" +"(let-values(((inner149_0)" +"(let-values(((the-struct_73)" +"(root-expand-context/outer-inner" +" v_193)))" +"(if(expand-context/inner?" +" the-struct_73)" +"(let-values(((phase150_0)" +" phase_50)" +"((namespace151_0)" +" ns_104)" +"((just-once?152_0)" +" just-once?_1)" +"((for-serializable?153_0)" +" serializable?_10))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_73)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_73)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_73)" +"(root-expand-context/inner-defined-syms" +" the-struct_73)" +"(root-expand-context/inner-counter" +" the-struct_73)" +"(root-expand-context/inner-lift-key" +" the-struct_73)" +"(expand-context/inner-to-parsed?" +" the-struct_73)" +" phase150_0" +" namespace151_0" +" just-once?152_0" +"(expand-context/inner-module-begin-k" +" the-struct_73)" +"(expand-context/inner-allow-unbound?" +" the-struct_73)" +"(expand-context/inner-in-local-expand?" +" the-struct_73)" +"(expand-context/inner-stops" +" the-struct_73)" +"(expand-context/inner-declared-submodule-names" +" the-struct_73)" +"(expand-context/inner-lifts" +" the-struct_73)" +"(expand-context/inner-lift-envs" +" the-struct_73)" +"(expand-context/inner-module-lifts" +" the-struct_73)" +"(expand-context/inner-require-lifts" +" the-struct_73)" +"(expand-context/inner-to-module-lifts" +" the-struct_73)" +"(expand-context/inner-requires+provides" +" the-struct_73)" +"(expand-context/inner-observer" +" the-struct_73)" +" for-serializable?153_0" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_73)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_73)))))" +"(expand-context/outer1.1" +" inner149_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_72)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_72)" +"(root-expand-context/outer-frame-id" +" the-struct_72)" +"(expand-context/outer-context" +" the-struct_72)" +"(expand-context/outer-env the-struct_72)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_72)" +"(expand-context/outer-scopes the-struct_72)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_72)" +"(expand-context/outer-binding-layer" +" the-struct_72)" +"(expand-context/outer-reference-records" +" the-struct_72)" +"(expand-context/outer-only-immediate?" +" the-struct_72)" +"(expand-context/outer-need-eventually-defined" +" the-struct_72)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_72)" +"(expand-context/outer-name the-struct_72)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_72))))))" +"(let-values(((wb-s_0)(if just-once?_1 s_209 #f)))" +"(let-values(((require-lifts_5 lifts_11 exp-s_8)" +"(if(if quick-immediate?_0" +"(core-form-sym s_209 phase_50)" +" #f)" +"(values null null s_209)" +"(expand-capturing-lifts" +" s_209" +"(let-values(((v_194) tl-ctx_0))" +"(let-values(((the-struct_74) v_194))" +"(if(expand-context/outer? the-struct_74)" +"(let-values(((only-immediate?154_0)" +" #t)" +"((def-ctx-scopes155_0)" +"(box null))" +"((inner156_0)" +"(let-values(((the-struct_75)" +"(root-expand-context/outer-inner" +" v_194)))" +"(if(expand-context/inner?" +" the-struct_75)" +"(let-values(((phase157_0)" +" phase_50)" +"((namespace158_0)" +" ns_104))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_75)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_75)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_75)" +"(root-expand-context/inner-defined-syms" +" the-struct_75)" +"(root-expand-context/inner-counter" +" the-struct_75)" +"(root-expand-context/inner-lift-key" +" the-struct_75)" +"(expand-context/inner-to-parsed?" +" the-struct_75)" +" phase157_0" +" namespace158_0" +"(expand-context/inner-just-once?" +" the-struct_75)" +"(expand-context/inner-module-begin-k" +" the-struct_75)" +"(expand-context/inner-allow-unbound?" +" the-struct_75)" +"(expand-context/inner-in-local-expand?" +" the-struct_75)" +"(expand-context/inner-stops" +" the-struct_75)" +"(expand-context/inner-declared-submodule-names" +" the-struct_75)" +"(expand-context/inner-lifts" +" the-struct_75)" +"(expand-context/inner-lift-envs" +" the-struct_75)" +"(expand-context/inner-module-lifts" +" the-struct_75)" +"(expand-context/inner-require-lifts" +" the-struct_75)" +"(expand-context/inner-to-module-lifts" +" the-struct_75)" +"(expand-context/inner-requires+provides" +" the-struct_75)" +"(expand-context/inner-observer" +" the-struct_75)" +"(expand-context/inner-for-serializable?" +" the-struct_75)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_75)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_75)))))" +"(expand-context/outer1.1" +" inner156_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_74)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_74)" +"(root-expand-context/outer-frame-id" +" the-struct_74)" +"(expand-context/outer-context" +" the-struct_74)" +"(expand-context/outer-env" +" the-struct_74)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_74)" +"(expand-context/outer-scopes" +" the-struct_74)" +" def-ctx-scopes155_0" +"(expand-context/outer-binding-layer" +" the-struct_74)" +"(expand-context/outer-reference-records" +" the-struct_74)" +" only-immediate?154_0" +"(expand-context/outer-need-eventually-defined" +" the-struct_74)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_74)" +"(expand-context/outer-name" +" the-struct_74)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_74))))))))" +"(let-values(((disarmed-exp-s_0)(syntax-disarm$1 exp-s_8)))" +"(if(let-values(((or-part_293)(pair? require-lifts_5)))" +"(if or-part_293 or-part_293(pair? lifts_11)))" +"(let-values()" +"(let-values(((new-s_2)" +"(let-values(((temp159_1)" +"(append" +" require-lifts_5" +" lifts_11))" +"((exp-s160_0) exp-s_8)" +"((phase161_0) phase_50))" +"(wrap-lifts-as-begin16.1" +" #f" +" #f" +" #f" +" #f" +" temp159_1" +" exp-s160_0" +" phase161_0))))" +"(begin" +"(let-values(((obs_43)" +"(expand-context-observer tl-ctx_0)))" +"(if obs_43" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_43" +" 'lift-loop" +" new-s_2)))" +"(void)))" +"(if just-once?_1" +" new-s_2" +"(loop_98 new-s_2 phase_50 ns_104 as-tail?_7)))))" +"(if(not single_0)" +"(let-values() exp-s_8)" +"(if(if just-once?_1(not(eq? exp-s_8 wb-s_0)) #f)" +"(let-values() exp-s_8)" +"(let-values()" +"(let-values(((tmp_36)" +"(core-form-sym" +" disarmed-exp-s_0" +" phase_50)))" +"(if(equal? tmp_36 'begin)" +"(let-values()" +"(let-values((()" +"(begin" +"(log-top-begin-before" +" ctx_1" +" exp-s_8)" +"(values))))" +"(let-values(((ok?_28 begin162_0 e163_0)" +"(let-values(((s_395)" +" disarmed-exp-s_0))" +"(let-values(((orig-s_34)" +" s_395))" +"(let-values(((begin162_1" +" e163_1)" +"(let-values(((s_111)" +"(if(syntax?$1" +" s_395)" +"(syntax-e$1" +" s_395)" +" s_395)))" +"(if(pair?" +" s_111)" +"(let-values(((begin164_0)" +"(let-values(((s_439)" +"(car" +" s_111)))" +" s_439))" +"((e165_0)" +"(let-values(((s_112)" +"(cdr" +" s_111)))" +"(let-values(((s_420)" +"(if(syntax?$1" +" s_112)" +"(syntax-e$1" +" s_112)" +" s_112)))" +"(let-values(((flat-s_20)" +"(to-syntax-list.1" +" s_420)))" +"(if(not" +" flat-s_20)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_34))" +"(let-values()" +" flat-s_20)))))))" +"(values" +" begin164_0" +" e165_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_34)))))" +"(values" +" #t" +" begin162_1" +" e163_1))))))" +"(letrec-values(((begin-loop_0)" +"(lambda(es_2)" +"(begin" +" 'begin-loop" +"(if(null? es_2)" +"(let-values()" +"(if combine_0" +" null" +"(void)))" +"(if(if(not" +" combine_0)" +"(null?" +"(cdr" +" es_2))" +" #f)" +"(let-values()" +"(loop_98" +"(car es_2)" +" phase_50" +" ns_104" +" as-tail?_7))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_44)" +"(expand-context-observer" +" tl-ctx_0)))" +"(if obs_44" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_44" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((a_63)" +"(if combine_0" +"(loop_98" +"(car" +" es_2)" +" phase_50" +" ns_104" +" #f)" +"(begin" +"(loop_98" +"(car" +" es_2)" +" phase_50" +" ns_104" +" #f)" +"(void)))))" +"(if combine_0" +"(combine_0" +" a_63" +"(begin-loop_0" +"(cdr" +" es_2)))" +"(begin-loop_0" +"(cdr" +" es_2))))))))))))" +"(if wrap_2" +"(let-values()" +"(let-values(((new-s_3)" +"(wrap_2" +" begin162_0" +" exp-s_8" +"(begin-loop_0" +" e163_0))))" +"(begin" +"(log-top-begin-after" +" tl-ctx_0" +" new-s_3)" +" new-s_3)))" +"(let-values()" +"(begin-loop_0 e163_0)))))))" +"(if(equal? tmp_36 'begin-for-syntax)" +"(let-values()" +"(let-values(((ok?_29" +" begin-for-syntax166_0" +" e167_0)" +"(let-values(((s_221)" +" disarmed-exp-s_0))" +"(let-values(((orig-s_35)" +" s_221))" +"(let-values(((begin-for-syntax166_1" +" e167_1)" +"(let-values(((s_440)" +"(if(syntax?$1" +" s_221)" +"(syntax-e$1" +" s_221)" +" s_221)))" +"(if(pair?" +" s_440)" +"(let-values(((begin-for-syntax168_0)" +"(let-values(((s_441)" +"(car" +" s_440)))" +" s_441))" +"((e169_0)" +"(let-values(((s_442)" +"(cdr" +" s_440)))" +"(let-values(((s_224)" +"(if(syntax?$1" +" s_442)" +"(syntax-e$1" +" s_442)" +" s_442)))" +"(let-values(((flat-s_21)" +"(to-syntax-list.1" +" s_224)))" +"(if(not" +" flat-s_21)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_35))" +"(let-values()" +" flat-s_21)))))))" +"(values" +" begin-for-syntax168_0" +" e169_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_35)))))" +"(values" +" #t" +" begin-for-syntax166_1" +" e167_1))))))" +"(let-values(((next-phase_0)" +"(add1 phase_50)))" +"(let-values(((next-ns_0)" +"(namespace->namespace-at-phase" +" ns_104" +" next-phase_0)))" +"(let-values((()" +"(begin" +"(if quick-immediate?_0" +"(let-values()" +"(namespace-visit-available-modules!" +" ns_104))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(namespace-visit-available-modules!" +" next-ns_0)" +"(values))))" +"(let-values(((l_72)" +"(reverse$1" +"(let-values(((lst_294)" +" e167_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_294)))" +"((letrec-values(((for-loop_255)" +"(lambda(fold-var_260" +" lst_295)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_295)" +"(let-values(((s_443)" +"(unsafe-car" +" lst_295))" +"((rest_166)" +"(unsafe-cdr" +" lst_295)))" +"(let-values(((fold-var_261)" +"(let-values(((fold-var_262)" +" fold-var_260))" +"(let-values(((fold-var_263)" +"(let-values()" +"(cons" +"(let-values()" +"(loop_98" +" s_443" +" next-phase_0" +" next-ns_0" +" #f))" +" fold-var_262))))" +"(values" +" fold-var_263)))))" +"(if(not" +" #f)" +"(for-loop_255" +" fold-var_261" +" rest_166)" +" fold-var_261)))" +" fold-var_260)))))" +" for-loop_255)" +" null" +" lst_294))))))" +"(if wrap_2" +"(let-values()" +"(wrap_2" +" begin-for-syntax166_0" +" exp-s_8" +" l_72))" +"(if combine_0" +"(let-values() l_72)" +"(let-values()" +"(void)))))))))))" +"(let-values()" +"(single_0" +" exp-s_8" +" ns_104" +" as-tail?_7)))))))))))))))))" +" loop_98)" +" s_438" +" phase_135" +" ns_103" +" #t)))))))))))))))))" +"(define-values" +"(maybe-intro)" +"(lambda(s_235 ns_105)" +"(begin(if(syntax?$1 s_235) s_235(1/namespace-syntax-introduce(1/datum->syntax #f s_235) ns_105)))))" +"(define-values" +"(re-pair)" +"(lambda(form-id_0 s_444 r_45)" +"(begin(syntax-rearm$1(1/datum->syntax(syntax-disarm$1 s_444)(cons form-id_0 r_45) s_444 s_444) s_444))))" +"(define-values" +"(expand-capturing-lifts)" +"(lambda(s_339 ctx_65)" +"(begin" +"(let-values()" +"(let-values(((ns_106)(expand-context-namespace ctx_65)))" +"(let-values((()(begin(namespace-visit-available-modules! ns_106)(values))))" +"(let-values(((lift-ctx_6)" +"(let-values(((temp170_1)(make-top-level-lift ctx_65)))" +"(make-lift-context6.1 #f #f temp170_1))))" +"(let-values(((require-lift-ctx_2)" +"(make-require-lift-context" +"(namespace-phase ns_106)" +"(make-parse-top-lifted-require ns_106))))" +"(let-values(((exp-s_9)" +"(let-values(((s171_0) s_339)" +"((temp172_0)" +"(let-values(((v_195) ctx_65))" +"(let-values(((the-struct_76) v_195))" +"(if(expand-context/outer? the-struct_76)" +"(let-values(((inner173_0)" +"(let-values(((the-struct_77)" +"(root-expand-context/outer-inner v_195)))" +"(if(expand-context/inner? the-struct_77)" +"(let-values(((lifts174_0) lift-ctx_6)" +"((module-lifts175_0) lift-ctx_6)" +"((require-lifts176_0)" +" require-lift-ctx_2))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_77)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_77)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_77)" +"(root-expand-context/inner-defined-syms" +" the-struct_77)" +"(root-expand-context/inner-counter the-struct_77)" +"(root-expand-context/inner-lift-key" +" the-struct_77)" +"(expand-context/inner-to-parsed? the-struct_77)" +"(expand-context/inner-phase the-struct_77)" +"(expand-context/inner-namespace the-struct_77)" +"(expand-context/inner-just-once? the-struct_77)" +"(expand-context/inner-module-begin-k" +" the-struct_77)" +"(expand-context/inner-allow-unbound?" +" the-struct_77)" +"(expand-context/inner-in-local-expand?" +" the-struct_77)" +"(expand-context/inner-stops the-struct_77)" +"(expand-context/inner-declared-submodule-names" +" the-struct_77)" +" lifts174_0" +"(expand-context/inner-lift-envs the-struct_77)" +" module-lifts175_0" +" require-lifts176_0" +"(expand-context/inner-to-module-lifts" +" the-struct_77)" +"(expand-context/inner-requires+provides" +" the-struct_77)" +"(expand-context/inner-observer the-struct_77)" +"(expand-context/inner-for-serializable?" +" the-struct_77)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_77)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_77)))))" +"(expand-context/outer1.1" +" inner173_0" +"(root-expand-context/outer-post-expansion-scope the-struct_76)" +"(root-expand-context/outer-use-site-scopes the-struct_76)" +"(root-expand-context/outer-frame-id the-struct_76)" +"(expand-context/outer-context the-struct_76)" +"(expand-context/outer-env the-struct_76)" +"(expand-context/outer-post-expansion-scope-action the-struct_76)" +"(expand-context/outer-scopes the-struct_76)" +"(expand-context/outer-def-ctx-scopes the-struct_76)" +"(expand-context/outer-binding-layer the-struct_76)" +"(expand-context/outer-reference-records the-struct_76)" +"(expand-context/outer-only-immediate? the-struct_76)" +"(expand-context/outer-need-eventually-defined the-struct_76)" +"(expand-context/outer-current-introduction-scopes the-struct_76)" +"(expand-context/outer-name the-struct_76)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_76))))))" +"(expand7.1 #f #f #f #f s171_0 temp172_0))))" +"(values" +"(get-and-clear-require-lifts! require-lift-ctx_2)" +"(get-and-clear-lifts! lift-ctx_6)" +" exp-s_9))))))))))" +"(define-values" +"(make-parse-top-lifted-require)" +"(lambda(ns_107)" +"(begin" +"(lambda(s_445 phase_136)" +"(let-values(((ok?_30 #%require177_0 req178_0)" +"(let-values(((s_350)(syntax-disarm$1 s_445)))" +"(let-values(((orig-s_36) s_350))" +"(let-values(((#%require177_1 req178_1)" +"(let-values(((s_244)(if(syntax?$1 s_350)(syntax-e$1 s_350) s_350)))" +"(if(pair? s_244)" +"(let-values(((#%require179_0)(let-values(((s_446)(car s_244))) s_446))" +"((req180_0)" +"(let-values(((s_447)(cdr s_244)))" +"(let-values(((s_448)" +"(if(syntax?$1 s_447)" +"(syntax-e$1 s_447)" +" s_447)))" +"(if(pair? s_448)" +"(let-values(((req181_0)" +"(let-values(((s_449)(car s_448)))" +" s_449))" +"(()" +"(let-values(((s_450)(cdr s_448)))" +"(let-values(((s_355)" +"(if(syntax?$1 s_450)" +"(syntax-e$1 s_450)" +" s_450)))" +"(if(null? s_355)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_36))))))" +"(values req181_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_36))))))" +"(values #%require179_0 req180_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_36)))))" +"(values #t #%require177_1 req178_1))))))" +"(let-values(((temp182_0)(list req178_0))" +"((s183_0) s_445)" +"((ns184_0) ns_107)" +"((phase185_0) phase_136)" +"((phase186_0) phase_136)" +"((temp187_0)(let-values(((temp189_0) #f))(make-requires+provides8.1 #f #f temp189_0)))" +"((temp188_0) 'require))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" phase186_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp188_0" +" temp182_0" +" s183_0" +" ns184_0" +" phase185_0" +" temp187_0)))))))" +"(define-values" +"(wrap-lifts-as-lifted-parsed-begin77.1)" +"(lambda(adjust-form71_0 require-lifts73_0 lifts74_0 exp-s75_0 rebuild-s76_0)" +"(begin" +" 'wrap-lifts-as-lifted-parsed-begin77" +"(let-values(((require-lifts_6) require-lifts73_0))" +"(let-values(((lifts_12) lifts74_0))" +"(let-values(((exp-s_10) exp-s75_0))" +"(let-values(((rebuild-s_3) rebuild-s76_0))" +"(let-values(((adjust-form_1) adjust-form71_0))" +"(let-values()" +"(lifted-parsed-begin30.1" +"(append" +"(reverse$1" +"(let-values(((lst_296) require-lifts_6))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_296)))" +"((letrec-values(((for-loop_256)" +"(lambda(fold-var_264 lst_297)" +"(begin" +" 'for-loop" +"(if(pair? lst_297)" +"(let-values(((req_19)(unsafe-car lst_297))" +"((rest_167)(unsafe-cdr lst_297)))" +"(let-values(((fold-var_265)" +"(let-values(((fold-var_266) fold-var_264))" +"(let-values(((fold-var_267)" +"(let-values()" +"(cons" +"(let-values()" +"(parsed-require23.1 req_19))" +" fold-var_266))))" +"(values fold-var_267)))))" +"(if(not #f)(for-loop_256 fold-var_265 rest_167) fold-var_265)))" +" fold-var_264)))))" +" for-loop_256)" +" null" +" lst_296))))" +"(reverse$1" +"(let-values(((lst_298)(get-lifts-as-lists lifts_12)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_298)))" +"((letrec-values(((for-loop_257)" +"(lambda(fold-var_268 lst_299)" +"(begin" +" 'for-loop" +"(if(pair? lst_299)" +"(let-values(((ids+syms+rhs_0)(unsafe-car lst_299))" +"((rest_168)(unsafe-cdr lst_299)))" +"(let-values(((fold-var_269)" +"(let-values(((fold-var_270) fold-var_268))" +"(let-values(((fold-var_271)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((exp-rhs_3)" +"(adjust-form_1" +"(caddr" +" ids+syms+rhs_0))))" +"(let-values(((just-rhs_0)" +"(if(lifted-parsed-begin?" +" exp-rhs_3)" +"(lifted-parsed-begin-last" +" exp-rhs_3)" +" exp-rhs_3)))" +"(let-values(((dv_0)" +"(parsed-define-values19.1" +" rebuild-s_3" +"(car" +" ids+syms+rhs_0)" +"(cadr" +" ids+syms+rhs_0)" +" just-rhs_0)))" +"(if(lifted-parsed-begin?" +" exp-rhs_3)" +"(let-values(((the-struct_78)" +" exp-rhs_3))" +"(if(lifted-parsed-begin?" +" the-struct_78)" +"(let-values(((last190_0)" +" dv_0))" +"(lifted-parsed-begin30.1" +"(lifted-parsed-begin-seq" +" the-struct_78)" +" last190_0))" +"(raise-argument-error" +" 'struct-copy" +" \"lifted-parsed-begin?\"" +" the-struct_78)))" +" dv_0)))))" +" fold-var_270))))" +"(values fold-var_271)))))" +"(if(not #f)(for-loop_257 fold-var_269 rest_168) fold-var_269)))" +" fold-var_268)))))" +" for-loop_257)" +" null" +" lst_298)))))" +" exp-s_10))))))))))" +"(define-values" +"(log-top-lift-begin-before)" +"(lambda(ctx_66 require-lifts_7 lifts_13 exp-s_11 ns_108)" +"(begin" +"(let-values(((obs_45)(expand-context-observer ctx_66)))" +"(if obs_45" +"(let-values()" +"(let-values(((new-s_4)" +"(let-values(((temp191_0)(append require-lifts_7 lifts_13))" +"((exp-s192_0) exp-s_11)" +"((temp193_0)(namespace-phase ns_108)))" +"(wrap-lifts-as-begin16.1 #f #f #f #f temp191_0 exp-s192_0 temp193_0))))" +"(begin(call-expand-observe obs_45 'lift-loop new-s_4)(log-top-begin-before ctx_66 new-s_4))))" +"(void))))))" +"(define-values" +"(log-top-begin-before)" +"(lambda(ctx_67 new-s_5)" +"(begin" +"(let-values(((obs_46)(expand-context-observer ctx_67)))" +"(if obs_46" +"(let-values()" +"(let-values(((ok?_31 begin194_0 e195_0)" +"(let-values(((s_262) new-s_5))" +"(let-values(((orig-s_37) s_262))" +"(let-values(((begin194_1 e195_1)" +"(let-values(((s_451)(if(syntax?$1 s_262)(syntax-e$1 s_262) s_262)))" +"(if(pair? s_451)" +"(let-values(((begin196_0)(let-values(((s_266)(car s_451))) s_266))" +"((e197_0)" +"(let-values(((s_267)(cdr s_451)))" +"(let-values(((s_452)" +"(if(syntax?$1 s_267)" +"(syntax-e$1 s_267)" +" s_267)))" +"(let-values(((flat-s_22)(to-syntax-list.1 s_452)))" +"(if(not flat-s_22)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_37))" +"(let-values() flat-s_22)))))))" +"(values begin196_0 e197_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_37)))))" +"(values #t begin194_1 e195_1))))))" +"(begin" +"(call-expand-observe obs_46 'visit new-s_5)" +"(call-expand-observe obs_46 'resolve begin194_0)" +"(call-expand-observe obs_46 'enter-prim new-s_5)" +"(call-expand-observe obs_46 'prim-begin)" +"(call-expand-observe obs_46 'enter-list(1/datum->syntax #f e195_0 new-s_5)))))" +"(void))))))" +"(define-values" +"(log-top-begin-after)" +"(lambda(ctx_68 new-s_6)" +"(begin" +"(let-values(((obs_47)(expand-context-observer ctx_68)))" +"(if obs_47" +"(let-values()" +"(let-values(((ok?_32 begin198_0 e199_0)" +"(let-values(((s_453) new-s_6))" +"(let-values(((orig-s_38) s_453))" +"(let-values(((begin198_1 e199_1)" +"(let-values(((s_454)(if(syntax?$1 s_453)(syntax-e$1 s_453) s_453)))" +"(if(pair? s_454)" +"(let-values(((begin200_0)(let-values(((s_455)(car s_454))) s_455))" +"((e201_0)" +"(let-values(((s_456)(cdr s_454)))" +"(let-values(((s_457)" +"(if(syntax?$1 s_456)" +"(syntax-e$1 s_456)" +" s_456)))" +"(let-values(((flat-s_23)(to-syntax-list.1 s_457)))" +"(if(not flat-s_23)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_38))" +"(let-values() flat-s_23)))))))" +"(values begin200_0 e201_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_38)))))" +"(values #t begin198_1 e199_1))))))" +"(let-values(((obs_48)(expand-context-observer ctx_68)))" +"(if obs_48" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_48 'exit-list(1/datum->syntax #f e199_0 new-s_6))" +"(call-expand-observe obs_48 'exit-prim new-s_6)" +"(call-expand-observe obs_48 'return new-s_6))))" +"(void)))))" +"(void))))))" +"(define-values" +"(do-dynamic-require)" +"(let-values(((do-dynamic-require6_0)" +"(lambda(who3_0 mod-path4_0 sym5_0 fail-k1_0 fail-k2_0)" +"(begin" +" 'do-dynamic-require6" +"(let-values(((who_20) who3_0))" +"(let-values(((mod-path_5) mod-path4_0))" +"(let-values(((sym_80) sym5_0))" +"(let-values(((fail-k_2)(if fail-k2_0 fail-k1_0 default-dynamic-require-fail-thunk)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_3)(1/module-path? mod-path_5)))" +"(if or-part_3" +" or-part_3" +"(let-values(((or-part_4)(1/module-path-index? mod-path_5)))" +"(if or-part_4 or-part_4(1/resolved-module-path? mod-path_5)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_20" +" \"(or/c module-path? module-path-index? resolved-module-path?)\"" +" mod-path_5)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_5)(symbol? sym_80)))" +"(if or-part_5" +" or-part_5" +"(let-values(((or-part_6)(not sym_80)))" +"(if or-part_6" +" or-part_6" +"(let-values(((or-part_285)(equal? sym_80 0)))" +"(if or-part_285 or-part_285(void? sym_80)))))))" +"(void)" +"(let-values()" +" (raise-argument-error who_20 \"(or/c symbol? #f 0 void?)\" sym_80)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(if(procedure? fail-k_2)" +"(procedure-arity-includes? fail-k_2 0)" +" #f)" +"(void)" +" (let-values () (raise-argument-error who_20 \"(-> any)\" fail-k_2)))" +"(values))))" +"(let-values(((ns_57)(1/current-namespace)))" +"(let-values(((mpi_45)" +"(if(1/module-path? mod-path_5)" +"(let-values()(1/module-path-index-join mod-path_5 #f))" +"(if(1/module-path-index? mod-path_5)" +"(let-values() mod-path_5)" +"(let-values()" +"(1/module-path-index-join" +"(resolved-module-path->module-path mod-path_5)" +" #f))))))" +"(let-values(((mod-name_22)(1/module-path-index-resolve mpi_45 #t)))" +"(let-values(((phase_137)(namespace-phase ns_57)))" +"(if(not sym_80)" +"(let-values()" +"(let-values(((phase23_0) phase_137)((temp24_5) #f))" +"(namespace-module-instantiate!96.1" +" temp24_5" +" #t" +" phase23_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" ns_57" +" mpi_45" +" phase_137)))" +"(if(equal? sym_80 0)" +"(let-values()" +"(let-values(((phase28_1) phase_137))" +"(namespace-module-instantiate!96.1" +" #f" +" #f" +" phase28_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" ns_57" +" mpi_45" +" phase_137)))" +"(if(void? sym_80)" +"(let-values()" +"(let-values(((phase32_4) phase_137))" +"(namespace-module-visit!104.1" +" phase32_4" +" #t" +" ns_57" +" mpi_45" +" phase_137)))" +"(let-values()" +"(let-values(((m_22)(namespace->module ns_57 mod-name_22)))" +"(let-values((()" +"(begin" +"(if m_22" +"(void)" +"(let-values()" +"(raise-unknown-module-error" +" 'dynamic-require" +" mod-name_22)))" +"(values))))" +"(let-values(((binding/p_5)" +"(hash-ref" +"(hash-ref(module-provides m_22) 0 '#hasheq())" +" sym_80" +" #f)))" +"(if(not binding/p_5)" +"(let-values()" +"(if(eq? fail-k_2 default-dynamic-require-fail-thunk)" +"(raise-arguments-error" +" 'dynamic-require" +" \"name is not provided\"" +" \"name\"" +" sym_80" +" \"module\"" +" mod-name_22)" +"(fail-k_2)))" +"(let-values()" +"(let-values(((binding_26)" +"(provided-as-binding binding/p_5)))" +"(let-values(((ex-sym_2)" +"(module-binding-sym binding_26)))" +"(let-values(((ex-phase_0)" +"(module-binding-phase binding_26)))" +"(let-values((()" +"(begin" +"(let-values(((phase36_0)" +" phase_137))" +"(namespace-module-instantiate!96.1" +" #f" +" #f" +" phase36_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" ns_57" +" mpi_45" +" phase_137))" +"(values))))" +"(let-values(((ex-mod-name_0)" +"(1/module-path-index-resolve" +"(module-path-index-shift" +"(module-binding-module binding_26)" +"(module-self m_22)" +" mpi_45))))" +"(let-values(((m-ns_16)" +"(let-values(((temp39_4)" +"(phase-" +" phase_137" +" ex-phase_0))" +"((temp40_2) #t))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" temp40_2" +" #t" +" #f" +" #f" +" ns_57" +" ex-mod-name_0" +" temp39_4))))" +"(let-values(((ex-m_0)" +"(namespace->module" +" ns_57" +" ex-mod-name_0)))" +"(let-values(((access_4)" +"(let-values(((or-part_70)" +"(module-access" +" ex-m_0)))" +"(if or-part_70" +" or-part_70" +"(module-compute-access!" +" ex-m_0)))))" +"(let-values((()" +"(begin" +"(if(if(not" +"(eq?" +" 'provided" +"(hash-ref" +"(hash-ref" +" access_4" +" ex-phase_0" +" '#hasheq())" +" ex-sym_2" +" #f)))" +"(if(not" +"(inspector-superior?" +"(current-code-inspector)" +"(namespace-inspector" +" m-ns_16)))" +"(not" +"(if(module-binding-extra-inspector" +" binding_26)" +"(inspector-superior?" +"(module-binding-extra-inspector" +" binding_26)" +"(namespace-inspector" +" m-ns_16))" +" #f))" +" #f)" +" #f)" +"(let-values()" +"(raise-arguments-error" +" 'dynamic-require" +" \"name is protected\"" +" \"name\"" +" sym_80" +" \"module\"" +" mod-name_22))" +"(void))" +"(values))))" +"(let-values(((fail_1)" +"(lambda()" +"(begin" +" 'fail" +"(if(eq?" +" fail-k_2" +" default-dynamic-require-fail-thunk)" +"(raise-arguments-error" +" 'dynamic-require" +" \"name's binding is missing\"" +" \"name\"" +" sym_80" +" \"module\"" +" mod-name_22)" +"(fail-k_2))))))" +"(if(not" +"(provided-as-transformer?" +" binding/p_5))" +"(let-values()" +"(namespace-get-variable" +" m-ns_16" +" ex-phase_0" +" ex-sym_2" +" fail_1))" +"(let-values()" +"(let-values(((missing_1)" +"(gensym 'missing)))" +"(let-values((()" +"(begin" +"(let-values(((phase44_0)" +" phase_137))" +"(namespace-module-visit!104.1" +" phase44_0" +" #t" +" ns_57" +" mpi_45" +" phase_137))" +"(values))))" +"(let-values(((t_54)" +"(namespace-get-transformer" +" m-ns_16" +" ex-phase_0" +" ex-sym_2" +" missing_1)))" +"(if(eq? t_54 missing_1)" +"(let-values()(fail_1))" +"(let-values()" +"(let-values(((tmp-ns_0)" +"(let-values(((ns45_1)" +" ns_57))" +"(new-namespace9.1" +" #f" +" #f" +" #f" +" #f" +" ns45_1" +" #t))))" +"(let-values(((mod-path_17)" +"(resolved-module-path->module-path" +" mod-name_22)))" +"(begin" +"(1/namespace-require" +" mod-path_17" +" tmp-ns_0)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-namespace" +" tmp-ns_0)" +"(let-values()" +"(1/eval" +" sym_80" +" tmp-ns_0))))))))))))))))))))))))))))))))))))))))))))))))" +"(case-lambda" +"((who_21 mod-path_16 sym_81)(begin(do-dynamic-require6_0 who_21 mod-path_16 sym_81 #f #f)))" +"((who_22 mod-path_18 sym_82 fail-k1_1)(do-dynamic-require6_0 who_22 mod-path_18 sym_82 fail-k1_1 #t)))))" +" (define-values (default-dynamic-require-fail-thunk) (lambda () (begin (error \"failed\"))))" +"(define-values" +"(1/dynamic-require)" +"(let-values(((dynamic-require12_0)" +"(lambda(mod-path10_2 sym11_0 fail-k8_0 fail-k9_0)" +"(begin" +" 'dynamic-require12" +"(let-values(((mod-path_19) mod-path10_2))" +"(let-values(((sym_83) sym11_0))" +"(let-values(((fail-k_3)(if fail-k9_0 fail-k8_0 default-dynamic-require-fail-thunk)))" +"(let-values()(do-dynamic-require 'dynamic-require mod-path_19 sym_83 fail-k_3)))))))))" +"(case-lambda" +"((mod-path_20 sym_10)(begin 'dynamic-require(dynamic-require12_0 mod-path_20 sym_10 #f #f)))" +"((mod-path_21 sym_84 fail-k8_1)(dynamic-require12_0 mod-path_21 sym_84 fail-k8_1 #t)))))" +"(define-values" +"(1/dynamic-require-for-syntax)" +"(let-values(((dynamic-require-for-syntax18_0)" +"(lambda(mod-path16_0 sym17_1 fail-k14_0 fail-k15_0)" +"(begin" +" 'dynamic-require-for-syntax18" +"(let-values(((mod-path_22) mod-path16_0))" +"(let-values(((sym_85) sym17_1))" +"(let-values(((fail-k_4)(if fail-k15_0 fail-k14_0 default-dynamic-require-fail-thunk)))" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +"(let-values(((ns_109)(1/current-namespace)))" +"(namespace->namespace-at-phase ns_109(add1(namespace-phase ns_109)))))" +"(let-values()" +"(do-dynamic-require 'dynamic-require-for-syntax mod-path_22 sym_85 fail-k_4)))))))))))" +"(case-lambda" +"((mod-path_23 sym_86)" +"(begin 'dynamic-require-for-syntax(dynamic-require-for-syntax18_0 mod-path_23 sym_86 #f #f)))" +"((mod-path_24 sym_87 fail-k14_1)(dynamic-require-for-syntax18_0 mod-path_24 sym_87 fail-k14_1 #t)))))" +" (define-values (replace-me) (lambda (who_0) (begin (lambda args_6 (error who_0 \"this stub must be replaced\")))))" +"(define-values" +"(1/current-eval)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-eval)" +"(lambda(p_45)" +"(begin" +"(if((lambda(p_46)(if(procedure? p_46)(procedure-arity-includes? p_46 1) #f)) p_45)" +"(void)" +" (let-values () (raise-argument-error 'current-eval \"(procedure-arity-includes/c 1)\" p_45)))" +" p_45))))))" +"(define-values" +"(1/current-compile)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-compile)" +"(lambda(p_30)" +"(begin" +"(if((lambda(p_47)(if(procedure? p_47)(procedure-arity-includes? p_47 2) #f)) p_30)" +"(void)" +" (let-values () (raise-argument-error 'current-compile \"(procedure-arity-includes/c 2)\" p_30)))" +" p_30))))))" +"(define-values" +"(1/current-load)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-load)" +"(lambda(p_48)" +"(begin" +"(if((lambda(p_49)(if(procedure? p_49)(procedure-arity-includes? p_49 2) #f)) p_48)" +"(void)" +" (let-values () (raise-argument-error 'current-load \"(procedure-arity-includes/c 2)\" p_48)))" +" p_48))))))" +"(define-values" +"(1/current-load/use-compiled)" +"(let-values()" +"(let-values()" +"(make-parameter" +"(replace-me 'current-load/use-compiled)" +"(lambda(p_34)" +"(begin" +"(if((lambda(p_50)(if(procedure? p_50)(procedure-arity-includes? p_50 2) #f)) p_34)" +"(void)" +" (let-values () (raise-argument-error 'current-load/use-compiled \"(procedure-arity-includes/c 2)\" p_34)))" +" p_34))))))" +"(define-values" +"(1/current-library-collection-paths)" +"(let-values()" +"(let-values()" +"(make-parameter" +" null" +"(lambda(l_7)" +"(begin" +"(if((lambda(l_73)(if(list? l_73)(andmap2 complete-path-string? l_73) #f)) l_7)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-library-collection-paths" +" \"(listof (and/c path-string? complete-path?))\"" +" l_7)))" +"(map2 to-path l_7)))))))" +"(define-values" +"(1/current-library-collection-links)" +"(let-values()" +"(let-values()" +"(make-parameter" +" null" +"(lambda(l_74)" +"(begin" +"(if((lambda(l_8)" +"(if(list? l_8)" +"(andmap2" +"(lambda(p_51)" +"(let-values(((or-part_289)(not p_51)))" +"(if or-part_289" +" or-part_289" +"(let-values(((or-part_290)(complete-path-string? p_51)))" +"(if or-part_290" +" or-part_290" +"(if(hash? p_51)" +"(let-values(((ht_146) p_51))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_146)))" +"((letrec-values(((for-loop_177)" +"(lambda(result_109 i_85)" +"(begin" +" 'for-loop" +"(if i_85" +"(let-values(((k_34 v_3)" +"(hash-iterate-key+value ht_146 i_85)))" +"(let-values(((result_110)" +"(let-values()" +"(let-values(((result_111)" +"(let-values()" +"(let-values()" +"(if(let-values(((or-part_78)" +"(not" +" k_34)))" +"(if or-part_78" +" or-part_78" +"(if(symbol?" +" k_34)" +"(1/module-path?" +" k_34)" +" #f)))" +"(if(list? v_3)" +"(andmap2" +" complete-path-string?" +" v_3)" +" #f)" +" #f)))))" +"(values result_111)))))" +"(if(if(not((lambda x_79(not result_110)) k_34 v_3))" +"(not #f)" +" #f)" +"(for-loop_177" +" result_110" +"(hash-iterate-next ht_146 i_85))" +" result_110)))" +" result_109)))))" +" for-loop_177)" +" #t" +"(hash-iterate-first ht_146))))" +" #f))))))" +" l_8)" +" #f))" +" l_74)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-library-collection-links" +"(string-append" +" \"(listof (or/c #f\\n\"" +" \" (and/c path-string? complete-path?)\\n\"" +" \" (hash/c (or/c (and/c symbol? module-path?) #f)\\n\"" +" \" (listof (and/c path-string? complete-path?)))))\")" +" l_74)))" +"(map2" +"(lambda(p_3)" +"(if(not p_3)" +"(let-values() #f)" +"(if(path? p_3)" +"(let-values() p_3)" +"(if(string? p_3)" +"(let-values()(string->path p_3))" +"(let-values()" +"(let-values(((ht_147) p_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_147)))" +"((letrec-values(((for-loop_258)" +"(lambda(table_201 i_86)" +"(begin" +" 'for-loop" +"(if i_86" +"(let-values(((k_35 v_196)(hash-iterate-key+value ht_147 i_86)))" +"(let-values(((table_202)" +"(let-values(((table_103) table_201))" +"(let-values(((table_203)" +"(let-values()" +"(let-values(((key_82 val_73)" +"(let-values()" +"(values" +" k_35" +"(to-path v_196)))))" +"(hash-set" +" table_103" +" key_82" +" val_73)))))" +"(values table_203)))))" +"(if(not #f)" +"(for-loop_258 table_202(hash-iterate-next ht_147 i_86))" +" table_202)))" +" table_201)))))" +" for-loop_258)" +" '#hash()" +"(hash-iterate-first ht_147)))))))))" +" l_74)))))))" +"(define-values" +"(1/use-compiled-file-paths)" +"(let-values()" +"(let-values()" +"(make-parameter" +" (list (string->path \"compiled\"))" +"(lambda(l_48)" +"(begin" +"(if((lambda(l_75)(if(list? l_75)(andmap2 relative-path-string?$1 l_75) #f)) l_48)" +"(void)" +"(let-values()" +" (raise-argument-error 'use-compiled-file-paths \"(listof (and/c path-string? relative-path?))\" l_48)))" +"(map2 to-path l_48)))))))" +"(define-values" +"(1/current-compiled-file-roots)" +"(let-values()" +"(let-values()" +"(make-parameter" +" '(same)" +"(lambda(l_76)" +"(begin" +"(if((lambda(l_77)" +"(if(list? l_77)" +"(andmap2" +"(lambda(p_52)" +"(let-values(((or-part_8)(path-string? p_52)))(if or-part_8 or-part_8(eq? p_52 'same))))" +" l_77)" +" #f))" +" l_76)" +"(void)" +"(let-values()" +" (raise-argument-error 'current-compiled-file-roots \"(listof (or/c path-string? 'same))\" l_76)))" +"(map2 to-path l_76)))))))" +"(define-values" +"(1/use-compiled-file-check)" +"(let-values()" +"(let-values()" +"(make-parameter" +" 'modify-seconds" +"(lambda(v_181)" +"(begin" +"(if((lambda(v_64)" +"(let-values(((or-part_21)(eq? v_64 'modify-seconds)))" +"(if or-part_21 or-part_21(eq? v_64 'exists))))" +" v_181)" +"(void)" +" (let-values () (raise-argument-error 'use-compiled-file-check \"(or/c 'modify-seconds 'exists)\" v_181)))" +" v_181))))))" +"(define-values(1/use-collection-link-paths)(make-parameter #t(lambda(v_76)(if v_76 #t #f))))" +"(define-values(1/use-user-specific-search-paths)(make-parameter #t(lambda(v_197)(if v_197 #t #f))))" +"(define-values(complete-path-string?)(lambda(p_20)(begin(if(path-string? p_20)(complete-path? p_20) #f))))" +"(define-values" +"(relative-path-string?$1)" +"(lambda(p_53)(begin 'relative-path-string?(if(path-string? p_53)(relative-path? p_53) #f))))" +"(define-values(to-path)(lambda(p_54)(begin(if(string? p_54)(string->path p_54) p_54))))" +"(define-values" +"(1/load)" +"(lambda(s_0)" +"(begin" +" 'load" +"(let-values()" +"(let-values()" +"(begin" +" (if (path-string? s_0) (void) (let-values () (raise-argument-error 'load \"path-string?\" s_0)))" +"(call-with-current-load-relative-directory s_0(lambda()((1/current-load) s_0 #f)))))))))" +"(define-values" +"(1/load-extension)" +"(lambda(s_158)" +"(begin" +" 'load-extension" +"(let-values()" +"(let-values()" +"(begin" +" (if (path-string? s_158) (void) (let-values () (raise-argument-error 'load-extension \"path-string?\" s_158)))" +"(call-with-current-load-relative-directory s_158(lambda()((current-load-extension) s_158 #f)))))))))" +"(define-values" +"(call-with-current-load-relative-directory)" +"(lambda(p_46 thunk_4)" +"(begin" +"(let-values(((base_2 name_3 dir?_2)(split-path p_46)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-load-relative-directory" +"(if(eq? base_2 'relative)(current-directory)(path->complete-path base_2)))" +"(let-values()(thunk_4)))))))" +"(define-values" +"(1/load/use-compiled)" +"(lambda(f_35)" +"(begin" +" 'load/use-compiled" +"(let-values()" +"(let-values()" +"(begin" +"(if(path-string? f_35)" +"(void)" +" (let-values () (raise-argument-error 'load/use-compiled \"path-string?\" f_35)))" +"((1/current-load/use-compiled) f_35 #f)))))))" +"(define-values" +"(embedded-load)" +"(lambda(start_42 end_31 str_24 as-predefined?_0)" +"(begin" +"(let-values(((s_171)" +"(if str_24" +" str_24" +"(let-values(((sp_0)(find-system-path 'exec-file)))" +"(let-values(((exe_0)(find-executable-path sp_0 #f)))" +"(let-values(((start_43)" +"(let-values(((or-part_28)(1/string->number start_42)))" +"(if or-part_28 or-part_28 0))))" +"(let-values(((end_32)" +"(let-values(((or-part_289)(1/string->number end_31)))" +"(if or-part_289 or-part_289 0))))" +"(let-values(((exe4_0) exe_0)" +"((temp5_6)" +"(lambda()" +"(begin" +" 'temp5" +"(begin" +"(file-position(current-input-port) start_43)" +"(read-bytes(max 0(- end_32 start_43))))))))" +"(with-input-from-file45.1 #f #f exe4_0 temp5_6)))))))))" +"(let-values(((p_55)(open-input-bytes s_171)))" +"((letrec-values(((loop_2)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((e_73)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/read-accept-compiled" +" #t" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #t" +" read-on-demand-source" +" #t)" +"(let-values()(1/read p_55)))))" +"(if(eof-object? e_73)" +"(void)" +"(let-values()" +"(begin" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-module-declare-as-predefined" +" as-predefined?_0)" +"(let-values()((1/current-eval) e_73)))" +"(loop_2)))))))))" +" loop_2)))))))" +"(define-values" +"(find-main-collects)" +"(lambda()" +"(begin(cache-configuration 0(lambda()(exe-relative-path->complete-path(find-system-path 'collects-dir)))))))" +"(define-values" +"(find-main-config)" +"(lambda()" +"(begin(cache-configuration 1(lambda()(exe-relative-path->complete-path(find-system-path 'config-dir)))))))" +"(define-values" +"(exe-relative-path->complete-path)" +"(lambda(collects-path_0)" +"(begin" +"(if(complete-path? collects-path_0)" +"(let-values()(simplify-path collects-path_0))" +"(if(absolute-path? collects-path_0)" +"(let-values()" +"(let-values(((exec_0)" +"(path->complete-path" +"(find-executable-path(find-system-path 'exec-file))" +"(find-system-path 'orig-dir))))" +"(let-values(((base_18 name_65 dir?_3)(split-path exec_0)))" +"(simplify-path(path->complete-path collects-path_0 base_18)))))" +"(let-values()" +"(let-values(((p_56)(find-executable-path(find-system-path 'exec-file) collects-path_0 #t)))" +"(if p_56(simplify-path p_56) #f))))))))" +"(define-values(relative-path-string?)(lambda(s_0)(begin(if(path-string? s_0)(relative-path? s_0) #f))))" +"(define-values" +"(check-collection)" +"(lambda(who_23 s_158 l_4)" +"(begin" +"(begin" +"(if(relative-path-string? s_158)" +"(void)" +" (let-values () (raise-argument-error who_23 \"(and/c path-string? relative-path?)\" s_158)))" +"(if((lambda(l_2)(if(list? l_2)(andmap2 relative-path-string? l_2) #f)) l_4)" +"(void)" +" (let-values () (raise-argument-error who_23 \"(listof (and/c path-string? relative-path?))\" l_4)))))))" +"(define-values" +"(check-fail)" +"(lambda(who_24 fail_2)" +"(begin" +"(if((lambda(p_47)(if(procedure? p_47)(procedure-arity-includes? p_47 1) #f)) fail_2)" +"(void)" +" (let-values () (raise-argument-error who_24 \"(procedure-arity-includes/c 1)\" fail_2))))))" +"(define-values" +"(1/collection-path)" +"(lambda(fail_3 collection_0 collection-path_0)" +"(begin" +" 'collection-path" +"(let-values()" +"(let-values()" +"(begin" +"(check-collection 'collection-path collection_0 collection-path_0)" +"(check-fail 'collection-path fail_3)" +"(find-col-file fail_3 collection_0 collection-path_0 #f #f)))))))" +"(define-values" +"(1/collection-file-path)" +"(lambda(fail_4 check-compiled?_0 file-name_0 collection_1 collection-path_1)" +"(begin" +" 'collection-file-path" +"(let-values()" +"(let-values()" +"(begin" +"(if(relative-path-string? file-name_0)" +"(void)" +"(let-values()" +" (raise-argument-error 'collection-file-path \"(and/c path-string? relative-path?)\" file-name_0)))" +"(check-collection 'collection-file-path collection_1 collection-path_1)" +"(check-fail 'collection-file-path fail_4)" +"(find-col-file fail_4 collection_1 collection-path_1 file-name_0 check-compiled?_0)))))))" +"(define-values" +"(get-config-table)" +"(lambda(d_34)" +"(begin" +" (let-values (((p_57) (if d_34 (build-path d_34 \"config.rktd\") #f)))" +"(let-values(((or-part_286)" +"(if p_57" +"(if(file-exists? p_57)" +"(let-values(((p9_0) p_57)" +"((temp10_3)" +"(lambda()" +"(begin" +" 'temp10" +"(let-values(((v_2)(call-with-default-reading-parameterization 1/read)))" +"(if(hash? v_2) v_2 #f))))))" +"(with-input-from-file45.1 #f #f p9_0 temp10_3))" +" #f)" +" #f)))" +"(if or-part_286 or-part_286 '#hash()))))))" +"(define-values" +"(get-installation-name)" +"(lambda(config-table_0)(begin(hash-ref config-table_0 'installation-name(version)))))" +"(define-values" +"(coerce-to-path)" +"(lambda(p_1)" +"(begin" +"(if(string? p_1)" +"(let-values()(collects-relative-path->complete-path(string->path p_1)))" +"(if(bytes? p_1)" +"(let-values()(collects-relative-path->complete-path(bytes->path p_1)))" +"(if(path? p_1)(let-values()(collects-relative-path->complete-path p_1))(let-values() p_1)))))))" +"(define-values" +"(collects-relative-path->complete-path)" +"(lambda(p_58)" +"(begin" +"(if(complete-path? p_58)" +"(let-values() p_58)" +"(let-values()" +"(path->complete-path" +" p_58" +"(let-values(((or-part_160)(find-main-collects)))(if or-part_160 or-part_160(current-directory)))))))))" +"(define-values" +"(add-config-search)" +"(lambda(ht_148 key_83 orig-l_9)" +"(begin" +"(let-values(((l_66)(hash-ref ht_148 key_83 #f)))" +"(if l_66" +"((letrec-values(((loop_99)" +"(lambda(l_67)" +"(begin" +" 'loop" +"(if(null? l_67)" +"(let-values() null)" +"(if(not(car l_67))" +"(let-values()(append orig-l_9(loop_99(cdr l_67))))" +"(let-values()(cons(coerce-to-path(car l_67))(loop_99(cdr l_67))))))))))" +" loop_99)" +" l_66)" +" orig-l_9)))))" +"(define-values" +"(1/find-library-collection-links)" +"(lambda()" +"(begin" +" 'find-library-collection-links" +"(let-values(((ht_149)(get-config-table(find-main-config))))" +"(let-values(((lf_0)" +"(coerce-to-path" +"(let-values(((or-part_70)(hash-ref ht_149 'links-file #f)))" +"(if or-part_70" +" or-part_70" +"(build-path" +"(let-values(((or-part_71)(hash-ref ht_149 'share-dir #f)))" +" (if or-part_71 or-part_71 (build-path 'up \"share\")))" +" \"links.rktd\"))))))" +"(append" +"(list #f)" +"(if(if(1/use-user-specific-search-paths)(1/use-collection-link-paths) #f)" +" (list (build-path (find-system-path 'addon-dir) (get-installation-name ht_149) \"links.rktd\"))" +" null)" +"(if(1/use-collection-link-paths)(add-config-search ht_149 'links-search-files(list lf_0)) null)))))))" +"(define-values(links-cache)(make-weak-hash))" +"(define-values(stamp-prompt-tag)(make-continuation-prompt-tag 'stamp))" +"(define-values" +"(file->stamp)" +"(lambda(path_7 old-stamp_0)" +"(begin" +"(if(if old-stamp_0(if(cdr old-stamp_0)(not(sync/timeout 0(cdr old-stamp_0))) #f) #f)" +"(let-values() old-stamp_0)" +"(let-values()" +"(call-with-continuation-prompt" +"(lambda()" +"(call-with-exception-handler" +"(lambda(exn_0)" +"(abort-current-continuation" +" stamp-prompt-tag" +"(if(exn:fail:filesystem? exn_0)(lambda() #f)(lambda()(raise exn_0)))))" +"(lambda()" +"(let-values(((dir-evt_0)" +"(if(vector-ref(system-type 'fs-change) 2)" +"((letrec-values(((loop_62)" +"(lambda(path_8)" +"(begin" +" 'loop" +"(let-values(((base_19 name_66 dir?_4)(split-path path_8)))" +"(if(path? base_19)" +"(if(directory-exists? base_19)" +"(filesystem-change-evt base_19(lambda() #f))" +"(loop_62 base_19))" +" #f))))))" +" loop_62)" +" path_7)" +" #f)))" +"(if(not(file-exists? path_7))" +"(let-values()(cons #f dir-evt_0))" +"(let-values()" +"(let-values(((evt_0)" +"(if(vector-ref(system-type 'fs-change) 2)" +"(filesystem-change-evt path_7(lambda() #f))" +" #f)))" +"(begin" +"(if dir-evt_0(let-values()(filesystem-change-evt-cancel dir-evt_0))(void))" +"(cons(file->bytes path_7) evt_0)))))))))" +" stamp-prompt-tag))))))" +"(define-values" +"(file->bytes)" +"(lambda(path_9)" +"(begin" +"(let-values(((path11_0) path_9)" +"((temp12_3)" +"(lambda(p_59)" +"(begin" +" 'temp12" +"(let-values(((bstr_1)(read-bytes 8192 p_59)))" +"(if(if(bytes? bstr_1)(>=(bytes-length bstr_1) 8192) #f)" "(apply" " bytes-append" "(cons" -" bstr" -"(let loop()" -"(let((bstr(read-bytes 8192 p)))" -"(if(eof-object? bstr)" -" null" -"(cons bstr(loop)))))))" -" bstr)))" -"(lambda()(close-input-port p))))" -" evt))))))" -" stamp-prompt-tag)))))" -"(define-values(no-file-stamp?)" -"(lambda(a)" -"(or(not a)" -"(not(car a)))))" -"(define-values(get-linked-collections)" -"(lambda(links-path)" -"(call-with-escape-continuation" -"(lambda(esc)" -"(define-values(make-handler)" -"(lambda(ts)" -"(lambda(exn)" -"(if(exn:fail? exn)" -"(let((l(current-logger)))" -"(when(log-level? l 'error)" -"(log-message l 'error" +" bstr_1" +"((letrec-values(((loop_100)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((bstr_2)(read-bytes 8192 p_59)))" +"(if(eof-object? bstr_2) null(cons bstr_2(loop_100))))))))" +" loop_100))))" +" bstr_1))))))" +"(call-with-input-file*61.1 #f #f path11_0 temp12_3)))))" +"(define-values" +"(no-file-stamp?)" +"(lambda(a_64)(begin(let-values(((or-part_53)(not a_64)))(if or-part_53 or-part_53(not(car a_64)))))))" +"(define-values" +"(get-linked-collections)" +"(lambda(links-path_0)" +"(begin" +"(call/ec" +"(lambda(esc_1)" +"(let-values(((make-handler_0)" +"(lambda(ts_0)" +"(begin" +" 'make-handler" +"(lambda(exn_1)" +"(begin" +"(if(exn:fail? exn_1)" +"(let-values(((l_78)(current-logger)))" +"(if(log-level? l_78 'error)" +"(let-values()" +"(log-message" +" l_78" +" 'error" "(format" -" \"error reading collection links file ~s: ~a\"" -" links-path" -"(exn-message exn))" -"(current-continuation-marks))))" +" \"error reading collection links file ~s: ~a\"" +" links-path_0" +"(exn-message exn_1))" +"(current-continuation-marks)))" +"(void)))" "(void))" -"(when ts" -"(hash-set! links-cache links-path(cons ts #hasheq())))" -"(if(exn:fail? exn)" -"(esc(make-hasheq))" -" exn))))" -"(with-continuation-mark" -" exception-handler-key" -"(make-handler #f)" -"(let*((links-stamp+cache(hash-ref links-cache links-path '(#f . #hasheq())))" -"(a-links-stamp(car links-stamp+cache))" -"(ts(file->stamp links-path a-links-stamp)))" -"(if(not(equal? ts a-links-stamp))" -"(with-continuation-mark" -" exception-handler-key" -"(make-handler ts)" +"(if ts_0" +"(let-values()(hash-set! links-cache links-path_0(cons ts_0 '#hasheq())))" +"(void))" +"(if(exn:fail? exn_1)(esc_1(make-hasheq)) exn_1)))))))" +"(call-with-exception-handler" +"(make-handler_0 #f)" +"(lambda()" +"(let-values(((links-stamp+cache_0)(hash-ref links-cache links-path_0 '(#f . #hasheq()))))" +"(let-values(((a-links-stamp_0)(car links-stamp+cache_0)))" +"(let-values(((ts_1)(file->stamp links-path_0 a-links-stamp_0)))" +"(if(equal? ts_1 a-links-stamp_0)" +"(let-values()(cdr links-stamp+cache_0))" +"(let-values()" +"(call-with-exception-handler" +"(make-handler_0 ts_1)" +"(lambda()" "(call-with-default-reading-parameterization" "(lambda()" -"(let((v(if(no-file-stamp? ts)" +"(let-values(((v_131)" +"(if(no-file-stamp? ts_1)" " null" -"(let((p(open-input-file links-path 'binary)))" -"(dynamic-wind" -" void" -"(lambda() " +"(let-values(((links-path13_0) links-path_0)" +"((temp14_5)" +"(lambda(p_60)" +"(begin" +" 'temp14" "(begin0" -"(read p)" -"(unless(eof-object?(read p))" -" (error \"expected a single S-expression\"))))" -"(lambda()(close-input-port p)))))))" -"(unless(and(list? v)" -"(andmap(lambda(p)" -"(and(list? p)" -"(or(= 2(length p))" -"(= 3(length p)))" -"(or(string?(car p))" -"(eq? 'root(car p))" -"(eq? 'static-root(car p)))" -"(path-string?(cadr p))" -"(or(null?(cddr p))" -"(regexp?(caddr p)))))" -" v))" -" (error \"ill-formed content\"))" -"(let((ht(make-hasheq))" -"(dir(let-values(((base name dir?)(split-path links-path)))" -" base)))" -"(for-each" -"(lambda(p)" -"(when(or(null?(cddr p))" -"(regexp-match?(caddr p)(version)))" -"(let((dir(simplify-path" -"(path->complete-path(cadr p) dir))))" -"(cond" -"((eq?(car p) 'static-root)" -"(for-each" -"(lambda(sub)" -"(when(directory-exists?(build-path dir sub))" -"(let((k(string->symbol(path->string sub))))" -"(hash-set! ht k(cons dir(hash-ref ht k null))))))" -"(directory-list dir)))" -"((eq?(car p) 'root)" -"(unless(hash-ref ht #f #f)" -"(hash-set! ht #f null))" +"(1/read p_60)" +"(if(eof-object?(1/read p_60))" +"(void)" +"(let-values()" +" (error \"expected a single S-expression\"))))))))" +"(call-with-input-file*61.1 #f #f links-path13_0 temp14_5)))))" +"(let-values((()" +"(begin" +"(if(if(list? v_131)" +"(andmap2" +"(lambda(p_61)" +"(if(list? p_61)" +"(if(let-values(((or-part_64)(= 2(length p_61))))" +"(if or-part_64 or-part_64(= 3(length p_61))))" +"(if(let-values(((or-part_294)(string?(car p_61))))" +"(if or-part_294" +" or-part_294" +"(let-values(((or-part_262)" +"(eq? 'root(car p_61))))" +"(if or-part_262" +" or-part_262" +"(eq? 'static-root(car p_61))))))" +"(if(path-string?(cadr p_61))" +"(let-values(((or-part_65)(null?(cddr p_61))))" +"(if or-part_65 or-part_65(regexp?(caddr p_61))))" +" #f)" +" #f)" +" #f)" +" #f))" +" v_131)" +" #f)" +"(void)" +" (let-values () (error \"ill-formed content\")))" +"(values))))" +"(let-values(((ht_150)(make-hasheq)))" +"(let-values(((dir_0)" +"(let-values(((base_20 name_42 dir?_5)(split-path links-path_0)))" +" base_20)))" +"(begin" +"(for-each2" +"(lambda(p_62)" +"(if(let-values(((or-part_66)(null?(cddr p_62))))" +"(if or-part_66 or-part_66(regexp-match?(caddr p_62)(version))))" +"(let-values()" +"(let-values(((dir_1)" +"(simplify-path(path->complete-path(cadr p_62) dir_0))))" +"(if(eq?(car p_62) 'static-root)" +"(let-values()" +"(for-each2" +"(lambda(sub_1)" +"(if(directory-exists?(build-path dir_1 sub_1))" +"(let-values()" +"(let-values(((k_36)(string->symbol(path->string sub_1))))" +"(hash-set!" +" ht_150" +" k_36" +"(cons dir_1(hash-ref ht_150 k_36 null)))))" +"(void)))" +"(directory-list dir_1)))" +"(if(eq?(car p_62) 'root)" +"(let-values()" +"(begin" +"(if(hash-ref ht_150 #f #f)" +"(void)" +"(let-values()(hash-set! ht_150 #f null)))" "(hash-for-each" -" ht" -"(lambda(k v)" -"(hash-set! ht k(cons dir v)))))" -"(else" -"(let((s(string->symbol(car p))))" -"(hash-set! ht s(cons(box dir)" -"(hash-ref ht s null)))))))))" -" v)" +" ht_150" +"(lambda(k_37 v_198)" +"(hash-set! ht_150 k_37(cons dir_1 v_198))))))" +"(let-values()" +"(let-values(((s_16)(string->symbol(car p_62))))" +"(hash-set!" +" ht_150" +" s_16" +"(cons(box dir_1)(hash-ref ht_150 s_16 null)))))))))" +"(void)))" +" v_131)" "(hash-for-each" -" ht" -"(lambda(k v)(hash-set! ht k(reverse v))))" -"(hash-set! links-cache links-path(cons ts ht))" -" ht)))))" -"(cdr links-stamp+cache))))))))" -"(define-values(normalize-collection-reference)" -"(lambda(collection collection-path)" -"(cond" -"((string? collection)" -" (let ((m (regexp-match-positions #rx\"/+\" collection)))" -"(if m" -"(cond" -"((=(caar m)(sub1(string-length collection)))" -"(values(substring collection 0(caar m)) collection-path))" -"(else" -"(values(substring collection 0(caar m))" -"(cons(substring collection(cdar m))" -" collection-path))))" -"(values collection collection-path))))" -"(else" -"(let-values(((base name dir?)(split-path collection)))" -"(if(eq? base 'relative)" -"(values name collection-path)" -"(normalize-collection-reference base(cons name collection-path))))))))" -"(define-values(find-col-file)" -"(lambda(fail collection collection-path file-name check-compiled?)" -"(let-values(((collection collection-path)" -"(normalize-collection-reference collection collection-path)))" -"(let((all-paths(let((sym(string->symbol " -"(if(path? collection)" -"(path->string collection)" -" collection))))" -"(let loop((l(current-library-collection-links)))" -"(cond" -"((null? l) null)" -"((not(car l))" -"(append " -"(current-library-collection-paths)" -"(loop(cdr l))))" -"((hash?(car l))" -"(append" -"(map box(hash-ref(car l) sym null))" -"(hash-ref(car l) #f null)" -"(loop(cdr l))))" -"(else" -"(let((ht(get-linked-collections(car l))))" -"(append " -"(hash-ref ht sym null)" -"(hash-ref ht #f null)" -"(loop(cdr l))))))))))" -"(define-values(done)" -"(lambda(p)" -"(if file-name(build-path p file-name) p)))" -"(define-values(*build-path-rep)" -"(lambda(p c)" -"(if(path? p)" -"(build-path p c)" -"(unbox p))))" -"(define-values(*directory-exists?)" -"(lambda(orig p)" -"(if(path? orig)" -"(directory-exists? p)" -" #t)))" -"(define-values(to-string)(lambda(p)(if(path? p)(path->string p) p)))" -"(let cloop((paths all-paths)(found-col #f))" -"(if(null? paths)" -"(if found-col" -"(done found-col)" -"(let((rest-coll" -"(if(null? collection-path)" -" \"\"" -"(apply" -" string-append" -"(let loop((cp collection-path))" -"(if(null?(cdr cp))" -"(list(to-string(car cp)))" -" (list* (to-string (car cp)) \"/\" (loop (cdr cp)))))))))" -"(define-values(filter)" -"(lambda(f l)" -"(if(null? l)" -" null" -"(if(f(car l))" -"(cons(car l)(filter f(cdr l)))" -"(filter f(cdr l))))))" -"(fail" -" (format \"collection not found\\n collection: ~s\\n in collection directories:~a~a\" " -"(if(null? collection-path)" -"(to-string collection)" -" (string-append (to-string collection) \"/\" rest-coll))" -"(apply" -" string-append" -"(map(lambda(p)" -" (format \"\\n ~a ~a\" \" \" p))" -"(let((len(length all-paths))" -"(clen(length(current-library-collection-paths))))" -"(if((- len clen) . < . 5)" -" all-paths" -"(append(current-library-collection-paths)" -" (list (format \"... [~a additional linked and package directories]\"" -"(- len clen))))))))" -"(if(ormap box? all-paths)" -" (format \"\\n sub-collection: ~s\\n in parent directories:~a\"" -" rest-coll " -"(apply" -" string-append" -"(map(lambda(p)" -" (format \"\\n ~a\" (unbox p)))" -"(filter box? all-paths))))" -" \"\")))))" -"(let((dir(*build-path-rep(car paths) collection)))" -"(if(*directory-exists?(car paths) dir)" -"(let((cpath(apply build-path dir collection-path)))" -"(if(if(null? collection-path)" -" #t" -"(directory-exists? cpath))" -"(if file-name" -"(if(or(file-exists?/maybe-compiled cpath file-name" -" check-compiled?)" -"(let((alt-file-name" -"(let*((file-name(if(path? file-name)" -"(path->string file-name)" -" file-name))" -"(len(string-length file-name)))" -"(and(len . >= . 4)" -" (string=? \".rkt\" (substring file-name (- len 4)))" -" (string-append (substring file-name 0 (- len 4)) \".ss\")))))" -"(and alt-file-name" -"(file-exists?/maybe-compiled cpath alt-file-name" -" check-compiled?))))" -"(done cpath)" -"(cloop(cdr paths)(or found-col cpath)))" -"(done cpath))" -"(cloop(cdr paths) found-col)))" -"(cloop(cdr paths) found-col)))))))))" -"(define-values(file-exists?/maybe-compiled)" -"(lambda(dir path check-compiled?)" -"(or(file-exists?(build-path dir path))" -"(and check-compiled?" -" (let ((try-path (path-add-extension path #\".zo\"))" -"(modes(use-compiled-file-paths))" -"(roots(current-compiled-file-roots)))" -"(ormap(lambda(d)" -"(ormap(lambda(mode)" -"(file-exists?" -"(let((p(build-path dir mode try-path)))" -"(cond" -"((eq? d 'same) p)" -"((relative-path? d)(build-path p d))" -"(else(reroot-path p d))))))" -" modes))" -" roots))))))" -"(define-values(check-extension-call)" -"(lambda(s sfx who)" -"(unless(or(path-for-some-system? s)" -"(path-string? s))" -" (raise-argument-error who \"(or/c path-for-some-system? path-string?)\" 0 s sfx))" -"(unless(or(string? sfx)(bytes? sfx))" -" (raise-argument-error who \"(or/c string? bytes?)\" 1 s sfx))" -"(let-values(((base name dir?)(split-path s)))" -"(when(not base)" -" (raise-mismatch-error who \"cannot add an extension to a root path: \" s))" -"(values base name))))" -"(define-values(path-adjust-extension)" -"(lambda(name sep rest-bytes s sfx)" -"(let-values(((base name)(check-extension-call s sfx name)))" -"(define bs(path-element->bytes name))" -"(define finish" -"(lambda(i sep i2)" -"(bytes->path-element" -"(bytes-append" -"(subbytes bs 0 i)" -" sep" -"(rest-bytes bs i2)" -"(if(string? sfx)" -"(string->bytes/locale sfx(char->integer #\\?))" -" sfx))" -"(if(path-for-some-system? s)" -"(path-convention-type s)" -"(system-path-convention-type)))))" -"(let((new-name(letrec-values(((loop)" -"(lambda(i)" -"(if(zero? i)" -" (finish (bytes-length bs) #\"\" (bytes-length bs))" -"(let-values(((i)(sub1 i)))" -"(if(and(not(zero? i))" -"(eq?(char->integer #\\.)(bytes-ref bs i)))" -"(finish i sep(add1 i))" -"(loop i)))))))" -"(loop(bytes-length bs)))))" -"(if(path-for-some-system? base)" -"(build-path base new-name)" -" new-name)))))" -"(define-values(path-replace-extension)" -"(lambda(s sfx)" -" (path-adjust-extension 'path-replace-extension #\"\" (lambda (bs i) #\"\") s sfx)))" -"(define-values(path-add-extension)" -"(lambda(s sfx)" -" (path-adjust-extension 'path-add-extension #\"_\" subbytes s sfx)))" -"(define-values(load/use-compiled)" -"(lambda(f)((current-load/use-compiled) f #f)))" -"(define-values(find-library-collection-paths)" -"(case-lambda" -"(()(find-library-collection-paths null null))" -"((extra-collects-dirs)(find-library-collection-paths extra-collects-dirs null))" -"((extra-collects-dirs post-collects-dirs)" -"(let((user-too?(use-user-specific-search-paths))" -"(cons-if(lambda(f r)(if f(cons f r) r)))" -"(config-table(get-config-table(find-main-config))))" -"(path-list-string->path-list" -"(if user-too?" -"(let((c(environment-variables-ref(current-environment-variables)" -" #\"PLTCOLLECTS\")))" -"(if c" -"(bytes->string/locale c #\\?)" -" \"\"))" -" \"\")" -"(add-config-search" -" config-table" -" 'collects-search-dirs" -"(cons-if" -"(and user-too?" -"(build-path(find-system-path 'addon-dir)" -"(get-installation-name config-table)" -" \"collects\"))" -"(let loop((l(append" -" extra-collects-dirs" -"(list(find-system-path 'collects-dir))" -" post-collects-dirs)))" -"(if(null? l)" -" null" -"(let*((collects-path(car l))" -"(v(exe-relative-path->complete-path collects-path)))" -"(if v" -"(cons(simplify-path(path->complete-path v(current-directory)))" -"(loop(cdr l)))" -"(loop(cdr l)))))))))))))" -"(define(embedded-load start end str)" -"(let*((s(if str" -" str" -"(let*((sp(find-system-path 'exec-file)) " -"(exe(find-executable-path sp #f))" -"(start(or(string->number start) 0))" -"(end(or(string->number end) 0)))" -"(with-input-from-file exe " -"(lambda()" -"(file-position(current-input-port) start)" -"(read-bytes(max 0(- end start))))))))" -"(p(open-input-bytes s)))" -"(let loop()" -"(let((e(parameterize((read-accept-compiled #t)" -"(read-accept-reader #t)" -"(read-accept-lang #t)" -"(read-on-demand-source #t))" -"(read p))))" -"(unless(eof-object? e)" -"(eval e)" -"(loop)))))))" -); - EVAL_ONE_STR( -"(module #%place-struct '#%kernel" -"(define-values(struct:TH-place-channel TH-place-channel TH-place-channel? " -" TH-place-channel-ref TH-place-channel-set!)" -"(make-struct-type 'TH-place-channel #f 2 0 #f(list(cons prop:evt(lambda(x)(TH-place-channel-ref x 0))))))" -"(define-values(TH-place-channel-in TH-place-channel-out) " +" ht_150" +"(lambda(k_38 v_199)(hash-set! ht_150 k_38(reverse$1 v_199))))" +"(hash-set! links-cache links-path_0(cons ts_1 ht_150))" +" ht_150))))))))))))))))))))))" +"(define-values" +"(normalize-collection-reference)" +"(lambda(collection_2 collection-path_2)" +"(begin" +"(if(string? collection_2)" +"(let-values()" +" (let-values (((m_23) (regexp-match-positions '#rx\"/+\" collection_2)))" +"(if m_23" +"(if(=(caar m_23)(sub1(string-length collection_2)))" +"(let-values()(values(substring collection_2 0(caar m_23)) collection-path_2))" +"(let-values()" "(values" -"(lambda(x)(TH-place-channel-ref x 0))" -"(lambda(x)(TH-place-channel-ref x 1))))" -"(#%provide " -" struct:TH-place-channel" -" TH-place-channel " -" TH-place-channel? " -" TH-place-channel-in" -" TH-place-channel-out))" -); - EVAL_ONE_STR( -"(module #%boot '#%kernel" -"(#%require '#%min-stx '#%utils '#%paramz)" -"(#%provide boot seal orig-paramz)" -"(define-values(dll-suffix)" -"(system-type 'so-suffix))" -"(define-values(default-load/use-compiled)" -"(let*((resolve(lambda(s)" -"(if(complete-path? s)" -" s" -"(let((d(current-load-relative-directory)))" -"(if d(path->complete-path s d) s)))))" -"(use-seconds?(eq?(use-compiled-file-check) 'modify-seconds))" -"(date-of-1(lambda(a)" -"(let((v(file-or-directory-modify-seconds a #f(lambda() #f))))" -"(and v(cons a(if use-seconds? v 0))))))" -"(date-of(lambda(a modes roots)" -"(ormap(lambda(root-dir)" -"(ormap" -"(lambda(compiled-dir)" -"(let((a(a root-dir compiled-dir)))" -"(date-of-1 a)))" -" modes))" -" roots)))" -"(date>=?" -"(lambda(modes roots a bm)" -"(and a" -"(let((am(date-of a modes roots)))" -"(or(and(not bm) am) " -"(and am bm(>=(cdr am)(cdr bm)) am))))))" -"(with-dir*(lambda(base t) " -"(parameterize((current-load-relative-directory " -"(if(path? base) " -" base " -"(current-directory))))" -"(t)))))" -"(lambda(path expect-module)" -"(unless(path-string? path)" -" (raise-argument-error 'load/use-compiled \"path-string?\" path))" -"(unless(or(not expect-module)" -"(symbol? expect-module)" -"(and(list? expect-module)" -"((length expect-module) . > . 1)" -"(or(symbol?(car expect-module))" -"(not(car expect-module)))" -"(andmap symbol?(cdr expect-module))))" -" (raise-argument-error 'load/use-compiled \"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))\" path))" -"(define name(and expect-module(current-module-declare-name)))" -"(define ns-hts(and name" -"(hash-ref -module-hash-table-table" -"(namespace-module-registry(current-namespace))" +"(substring collection_2 0(caar m_23))" +"(cons(substring collection_2(cdar m_23)) collection-path_2))))" +"(values collection_2 collection-path_2))))" +"(let-values()" +"(let-values(((base_21 name_67 dir?_6)(split-path collection_2)))" +"(if(eq? base_21 'relative)" +"(values name_67 collection-path_2)" +"(normalize-collection-reference base_21(cons name_67 collection-path_2)))))))))" +"(define-values" +"(find-col-file)" +"(lambda(fail_5 collection-in_0 collection-path-in_0 file-name_1 check-compiled?_1)" +"(begin" +"(let-values(((collection_3 collection-path_3)" +"(normalize-collection-reference collection-in_0 collection-path-in_0)))" +"(let-values(((all-paths_0)" +"(let-values(((sym_88)" +"(string->symbol" +"(if(path? collection_3)(path->string collection_3) collection_3))))" +"((letrec-values(((loop_96)" +"(lambda(l_79)" +"(begin" +" 'loop" +"(if(null? l_79)" +"(let-values() null)" +"(if(not(car l_79))" +"(let-values()" +"(append(1/current-library-collection-paths)(loop_96(cdr l_79))))" +"(if(hash?(car l_79))" +"(let-values()" +"(append" +"(map2 box(hash-ref(car l_79) sym_88 null))" +"(hash-ref(car l_79) #f null)" +"(loop_96(cdr l_79))))" +"(let-values()" +"(let-values(((ht_151)(get-linked-collections(car l_79))))" +"(append" +"(hash-ref ht_151 sym_88 null)" +"(hash-ref ht_151 #f null)" +"(loop_96(cdr l_79))))))))))))" +" loop_96)" +"(1/current-library-collection-links)))))" +"(let-values(((done_1)(lambda(p_11)(begin 'done(if file-name_1(build-path p_11 file-name_1) p_11)))))" +"(let-values(((*build-path-rep_0)" +"(lambda(p_25 c_53)" +"(begin '*build-path-rep(if(path? p_25)(build-path p_25 c_53)(unbox p_25))))))" +"(let-values(((*directory-exists?_0)" +"(lambda(orig_0 p_63)" +"(begin '*directory-exists?(if(path? orig_0)(directory-exists? p_63) #t)))))" +"(let-values(((to-string_0)" +"(lambda(p_64)(begin 'to-string(if(path? p_64)(path->string p_64) p_64)))))" +"((letrec-values(((cloop_0)" +"(lambda(paths_1 found-col_0)" +"(begin" +" 'cloop" +"(if(null? paths_1)" +"(if found-col_0" +"(done_1 found-col_0)" +"(let-values(((rest-coll_0)" +"(if(null? collection-path_3)" +" \"\"" +"(apply" +" string-append" +"((letrec-values(((loop_48)" +"(lambda(cp_0)" +"(begin" +" 'loop" +"(if(null?(cdr cp_0))" +"(list(to-string_0(car cp_0)))" +"(list*" +"(to-string_0(car cp_0))" +" \"/\"" +"(loop_48(cdr cp_0))))))))" +" loop_48)" +" collection-path_3)))))" +"(letrec-values(((filter_1)" +"(lambda(f_37 l_28)" +"(begin" +" 'filter" +"(if(null? l_28)" +" null" +"(if(f_37(car l_28))" +"(cons(car l_28)(filter_1 f_37(cdr l_28)))" +"(filter_1 f_37(cdr l_28))))))))" +"(fail_5" +"(format" +" \"collection not found\\n collection: ~s\\n in collection directories:~a~a\"" +"(if(null? collection-path_3)" +"(to-string_0 collection_3)" +" (string-append (to-string_0 collection_3) \"/\" rest-coll_0))" +"(apply" +" string-append" +"(map2" +" (lambda (p_26) (format \"\\n ~a ~a\" \" \" p_26))" +"(let-values(((len_34)(length all-paths_0))" +"((clen_0)" +"(length(1/current-library-collection-paths))))" +"(if(<(- len_34 clen_0) 5)" +" all-paths_0" +"(append" +"(1/current-library-collection-paths)" +"(list" +"(format" +" \"... [~a additional linked and package directories]\"" +"(- len_34 clen_0))))))))" +"(if(ormap2 box? all-paths_0)" +"(format" +" \"\\n sub-collection: ~s\\n in parent directories:~a\"" +" rest-coll_0" +"(apply" +" string-append" +"(map2" +" (lambda (p_65) (format \"\\n ~a\" (unbox p_65)))" +"(filter_1 box? all-paths_0))))" +" \"\"))))))" +"(let-values(((dir_2)(*build-path-rep_0(car paths_1) collection_3)))" +"(if(*directory-exists?_0(car paths_1) dir_2)" +"(let-values(((cpath_0)(apply build-path dir_2 collection-path_3)))" +"(if(if(null? collection-path_3) #t(directory-exists? cpath_0))" +"(if file-name_1" +"(if(let-values(((or-part_146)" +"(file-exists?/maybe-compiled" +" cpath_0" +" file-name_1" +" check-compiled?_1)))" +"(if or-part_146" +" or-part_146" +"(let-values(((alt-file-name_0)" +"(let-values(((file-name_2)" +"(if(path? file-name_1)" +"(path->string file-name_1)" +" file-name_1)))" +"(let-values(((len_35)" +"(string-length file-name_2)))" +"(if(>= len_35 4)" +"(if(string=?" +" \".rkt\"" +"(substring" +" file-name_2" +"(- len_35 4)))" +"(string-append" +"(substring" +" file-name_2" +" 0" +"(- len_35 4))" +" \".ss\")" +" #f)" +" #f)))))" +"(if alt-file-name_0" +"(file-exists?/maybe-compiled" +" cpath_0" +" alt-file-name_0" +" check-compiled?_1)" +" #f))))" +"(done_1 cpath_0)" +"(cloop_0" +"(cdr paths_1)" +"(let-values(((or-part_218) found-col_0))" +"(if or-part_218 or-part_218 cpath_0))))" +"(done_1 cpath_0))" +"(cloop_0(cdr paths_1) found-col_0)))" +"(cloop_0(cdr paths_1) found-col_0))))))))" +" cloop_0)" +" all-paths_0" +" #f))))))))))" +"(define-values" +"(file-exists?/maybe-compiled)" +"(lambda(dir_3 path_10 check-compiled?_2)" +"(begin" +"(let-values(((or-part_98)(file-exists?(build-path dir_3 path_10))))" +"(if or-part_98" +" or-part_98" +"(if check-compiled?_2" +" (let-values (((try-path_0) (path-add-extension path_10 #\".zo\"))" +"((modes_0)(1/use-compiled-file-paths))" +"((roots_0)(1/current-compiled-file-roots)))" +"(ormap2" +"(lambda(d_35)" +"(ormap2" +"(lambda(mode_15)" +"(file-exists?" +"(let-values(((p_66)(build-path dir_3 mode_15 try-path_0)))" +"(if(eq? d_35 'same)" +"(let-values() p_66)" +"(if(relative-path? d_35)" +"(let-values()(build-path p_66 d_35))" +"(let-values()(reroot-path p_66 d_35)))))))" +" modes_0))" +" roots_0))" +" #f))))))" +"(define-values" +"(1/find-library-collection-paths)" +"(let-values(((find-library-collection-paths5_0)" +"(lambda(extra-collects-dirs1_0 post-collects-dirs2_0 extra-collects-dirs3_0 post-collects-dirs4_0)" +"(begin" +" 'find-library-collection-paths5" +"(let-values(((extra-collects-dirs_0)(if extra-collects-dirs3_0 extra-collects-dirs1_0 null)))" +"(let-values(((post-collects-dirs_0)(if post-collects-dirs4_0 post-collects-dirs2_0 null)))" +"(let-values()" +"(let-values(((user-too?_0)(1/use-user-specific-search-paths))" +"((cons-if_0)" +"(lambda(f_38 r_46)(begin 'cons-if(if f_38(cons f_38 r_46) r_46))))" +"((config-table_1)(get-config-table(find-main-config))))" +"(path-list-string->path-list" +"(if user-too?_0" +"(let-values(((c_11)" +"(environment-variables-ref" +"(current-environment-variables)" +" #\"PLTCOLLECTS\")))" +" (if c_11 (bytes->string/locale c_11 '#\\?) \"\"))" +" \"\")" +"(add-config-search" +" config-table_1" +" 'collects-search-dirs" +"(cons-if_0" +"(if user-too?_0" +"(build-path" +"(find-system-path 'addon-dir)" +"(get-installation-name config-table_1)" +" \"collects\")" +" #f)" +"((letrec-values(((loop_83)" +"(lambda(l_80)" +"(begin" +" 'loop" +"(if(null? l_80)" +" null" +"(let-values(((collects-path_1)(car l_80)))" +"(let-values(((v_200)" +"(exe-relative-path->complete-path" +" collects-path_1)))" +"(if v_200" +"(cons" +"(simplify-path" +"(path->complete-path v_200(current-directory)))" +"(loop_83(cdr l_80)))" +"(loop_83(cdr l_80))))))))))" +" loop_83)" +"(append" +" extra-collects-dirs_0" +"(list(find-system-path 'collects-dir))" +" post-collects-dirs_0)))))))))))))" +"(case-lambda" +"(()(begin 'find-library-collection-paths(find-library-collection-paths5_0 #f #f #f #f)))" +"((extra-collects-dirs_1 post-collects-dirs2_1)" +"(find-library-collection-paths5_0 extra-collects-dirs_1 post-collects-dirs2_1 #t #t))" +"((extra-collects-dirs1_1)(find-library-collection-paths5_0 extra-collects-dirs1_1 #f #t #f)))))" +"(define-values(prop:readtable prop:readtable? prop:readtable-ref)(make-struct-type-property 'readtable))" +"(define-values" +"(1/current-readtable)" +"(make-parameter" +" #f" +"(lambda(v_26)" +"(begin" +"(if(let-values(((or-part_0)(not v_26)))(if or-part_0 or-part_0(prop:readtable? v_26)))" +"(void)" +" (let-values () (raise-argument-error 'current-readtable \"(or/c readtable? #f)\" v_26)))" +" v_26))))" +"(define-values" +"(struct:read-config/outer" +" read-config/outer1.1" +" read-config/outer?" +" read-config/outer-inner" +" read-config/outer-wrap" +" read-config/outer-line" +" read-config/outer-col" +" read-config/outer-pos" +" read-config/outer-indentations" +" read-config/outer-keep-comment?)" +"(let-values(((struct:_39 make-_39 ?_39 -ref_39 -set!_39)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'read-config" +" #f" +" 7" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6)" +" #f" +" 'read-config/outer)))))" +"(values" +" struct:_39" +" make-_39" +" ?_39" +"(make-struct-field-accessor -ref_39 0 'inner)" +"(make-struct-field-accessor -ref_39 1 'wrap)" +"(make-struct-field-accessor -ref_39 2 'line)" +"(make-struct-field-accessor -ref_39 3 'col)" +"(make-struct-field-accessor -ref_39 4 'pos)" +"(make-struct-field-accessor -ref_39 5 'indentations)" +"(make-struct-field-accessor -ref_39 6 'keep-comment?))))" +"(define-values" +"(struct:read-config/inner" +" read-config/inner2.1" +" read-config/inner?" +" read-config/inner-readtable" +" read-config/inner-next-readtable" +" read-config/inner-for-syntax?" +" read-config/inner-source" +" read-config/inner-read-compiled" +" read-config/inner-dynamic-require" +" read-config/inner-module-declared?" +" read-config/inner-coerce" +" read-config/inner-coerce-key" +" read-config/inner-parameter-override" +" read-config/inner-parameter-cache" +" read-config/inner-st)" +"(let-values(((struct:_74 make-_74 ?_74 -ref_74 -set!_74)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'read-config/inner" +" #f" +" 12" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3 4 5 6 7 8 9 10 11)" +" #f" +" 'read-config/inner)))))" +"(values" +" struct:_74" +" make-_74" +" ?_74" +"(make-struct-field-accessor -ref_74 0 'readtable)" +"(make-struct-field-accessor -ref_74 1 'next-readtable)" +"(make-struct-field-accessor -ref_74 2 'for-syntax?)" +"(make-struct-field-accessor -ref_74 3 'source)" +"(make-struct-field-accessor -ref_74 4 'read-compiled)" +"(make-struct-field-accessor -ref_74 5 'dynamic-require)" +"(make-struct-field-accessor -ref_74 6 'module-declared?)" +"(make-struct-field-accessor -ref_74 7 'coerce)" +"(make-struct-field-accessor -ref_74 8 'coerce-key)" +"(make-struct-field-accessor -ref_74 9 'parameter-override)" +"(make-struct-field-accessor -ref_74 10 'parameter-cache)" +"(make-struct-field-accessor -ref_74 11 'st))))" +"(define-values" +"(read-config/make)" +"(lambda(readtable_0" +" next-readtable_0" +" for-syntax?_0" +" source_1" +" wrap_3" +" read-compiled_0" +" dynamic-require_0" +" module-declared?_0" +" coerce_0" +" coerce-key_0" +" line_1" +" col_0" +" pos_104" +" indentations_0" +" keep-comment?_0" +" parameter-override_0" +" parameter-cache_0" +" st_0)" +"(begin" +"(read-config/outer1.1" +"(read-config/inner2.1" +" readtable_0" +" next-readtable_0" +" for-syntax?_0" +" source_1" +" read-compiled_0" +" dynamic-require_0" +" module-declared?_0" +" coerce_0" +" coerce-key_0" +" parameter-override_0" +" parameter-cache_0" +" st_0)" +" wrap_3" +" line_1" +" col_0" +" pos_104" +" indentations_0" +" keep-comment?_0))))" +"(define-values(read-config-wrap)(lambda(v_183)(begin(read-config/outer-wrap v_183))))" +"(define-values(read-config-line)(lambda(v_201)(begin(read-config/outer-line v_201))))" +"(define-values(read-config-col)(lambda(v_202)(begin(read-config/outer-col v_202))))" +"(define-values(read-config-pos)(lambda(v_203)(begin(read-config/outer-pos v_203))))" +"(define-values(read-config-indentations)(lambda(v_204)(begin(read-config/outer-indentations v_204))))" +"(define-values(read-config-keep-comment?)(lambda(v_205)(begin(read-config/outer-keep-comment? v_205))))" +"(define-values" +"(read-config-readtable)" +"(lambda(v_206)(begin(read-config/inner-readtable(read-config/outer-inner v_206)))))" +"(define-values" +"(read-config-next-readtable)" +"(lambda(v_92)(begin(read-config/inner-next-readtable(read-config/outer-inner v_92)))))" +"(define-values" +"(read-config-for-syntax?)" +"(lambda(v_207)(begin(read-config/inner-for-syntax?(read-config/outer-inner v_207)))))" +"(define-values(read-config-source)(lambda(v_71)(begin(read-config/inner-source(read-config/outer-inner v_71)))))" +"(define-values" +"(read-config-read-compiled)" +"(lambda(v_208)(begin(read-config/inner-read-compiled(read-config/outer-inner v_208)))))" +"(define-values" +"(read-config-dynamic-require)" +"(lambda(v_209)(begin(read-config/inner-dynamic-require(read-config/outer-inner v_209)))))" +"(define-values" +"(read-config-module-declared?)" +"(lambda(v_38)(begin(read-config/inner-module-declared?(read-config/outer-inner v_38)))))" +"(define-values" +"(read-config-coerce)" +"(lambda(v_210)(begin(read-config/inner-coerce(read-config/outer-inner v_210)))))" +"(define-values" +"(read-config-coerce-key)" +"(lambda(v_211)(begin(read-config/inner-coerce-key(read-config/outer-inner v_211)))))" +"(define-values" +"(read-config-parameter-override)" +"(lambda(v_200)(begin(read-config/inner-parameter-override(read-config/outer-inner v_200)))))" +"(define-values" +"(read-config-parameter-cache)" +"(lambda(v_212)(begin(read-config/inner-parameter-cache(read-config/outer-inner v_212)))))" +"(define-values(read-config-st)(lambda(v_213)(begin(read-config/inner-st(read-config/outer-inner v_213)))))" +"(define-values" +"(struct:read-config-state" +" read-config-state3.1" +" read-config-state?" +" read-config-state-accum-str" +" read-config-state-graph" +" set-read-config-state-accum-str!" +" set-read-config-state-graph!)" +"(let-values(((struct:_75 make-_75 ?_75 -ref_75 -set!_75)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'read-config-state" +" #f" +" 2" +" 0" +" #f" +" null" +"(current-inspector)" +" #f" +" '()" +" #f" +" 'read-config-state)))))" +"(values" +" struct:_75" +" make-_75" +" ?_75" +"(make-struct-field-accessor -ref_75 0 'accum-str)" +"(make-struct-field-accessor -ref_75 1 'graph)" +"(make-struct-field-mutator -set!_75 0 'accum-str)" +"(make-struct-field-mutator -set!_75 1 'graph))))" +"(define-values(current-read-config)(make-parameter #f))" +"(define-values" +"(make-read-config26.1)" +"(lambda(coerce12_0" +" coerce23_0" +" coerce-key13_0" +" coerce-key24_0" +" dynamic-require10_0" +" dynamic-require21_0" +" for-syntax?5_0" +" for-syntax?16_0" +" keep-comment?14_0" +" keep-comment?25_0" +" module-declared?11_0" +" module-declared?22_0" +" next-readtable7_0" +" next-readtable18_0" +" read-compiled9_0" +" read-compiled20_0" +" readtable6_0" +" readtable17_0" +" source4_0" +" source15_0" +" wrap8_0" +" wrap19_0)" +"(begin" +" 'make-read-config26" +"(let-values(((source_2)(if source15_0 source4_0 #f)))" +"(let-values(((for-syntax?_1)(if for-syntax?16_0 for-syntax?5_0 #f)))" +"(let-values(((readtable_1)(if readtable17_0 readtable6_0(1/current-readtable))))" +"(let-values(((next-readtable_1)(if next-readtable18_0 next-readtable7_0 readtable_1)))" +"(let-values(((wrap_4)(if wrap19_0 wrap8_0 #f)))" +"(let-values(((read-compiled_1)(if read-compiled20_0 read-compiled9_0 #f)))" +"(let-values(((dynamic-require_1)(if dynamic-require21_0 dynamic-require10_0 #f)))" +"(let-values(((module-declared?_1)(if module-declared?22_0 module-declared?11_0 #f)))" +"(let-values(((coerce_1)(if coerce23_0 coerce12_0 #f)))" +"(let-values(((coerce-key_1)(if coerce-key24_0 coerce-key13_0 #f)))" +"(let-values(((keep-comment?_1)(if keep-comment?25_0 keep-comment?14_0 #f)))" +"(let-values()" +"(read-config/make" +" readtable_1" +" next-readtable_1" +" for-syntax?_1" +" source_2" +" wrap_4" +"(let-values(((or-part_92) read-compiled_1))" +" (if or-part_92 or-part_92 (lambda (in_0) (error 'read \"no `read-compiled` provided\"))))" +"(let-values(((or-part_94) dynamic-require_1))" +"(if or-part_94" +" or-part_94" +"(lambda(mod-path_25 sym_89 failure-k_0)" +" (error 'read \"no `dynamic-require` provided\"))))" +"(let-values(((or-part_221) module-declared?_1))" +"(if or-part_221" +" or-part_221" +" (lambda (mod-path_26) (error 'read \"no `module-declare?` provided\"))))" +"(let-values(((or-part_295) coerce_1))" +"(if or-part_295 or-part_295(lambda(for-syntax?_2 v_111 srcloc_8) v_111)))" +"(let-values(((or-part_296) coerce-key_1))" +"(if or-part_296 or-part_296(lambda(for-syntax?_3 v_115) v_115)))" +" #f" +" #f" +" #f" +" null" +" keep-comment?_1" +" '#hasheq()" +"(make-hasheq)" +"(read-config-state3.1 #f #f)))))))))))))))))" +"(define-values" +"(read-config-update42.1)" +"(lambda(for-syntax?29_0" +" keep-comment?34_0" +" next-readtable32_0" +" next-readtable38_0" +" readtable31_0" +" reset-graph?33_0" +" wrap30_0" +" config41_0)" +"(begin" +" 'read-config-update42" +"(let-values(((config_0) config41_0))" +"(let-values(((for-syntax?_4) for-syntax?29_0))" +"(let-values(((wrap_5) wrap30_0))" +"(let-values(((readtable_2) readtable31_0))" +"(let-values(((next-readtable_2)" +"(if next-readtable38_0 next-readtable32_0(read-config-readtable config_0))))" +"(let-values(((local-graph?_0) reset-graph?33_0))" +"(let-values(((keep-comment?_2) keep-comment?34_0))" +"(let-values()" +"(let-values(((v_214) config_0))" +"(let-values(((the-struct_79) v_214))" +"(if(read-config/outer? the-struct_79)" +"(let-values(((wrap48_0) wrap_5)" +"((keep-comment?49_0) keep-comment?_2)" +"((inner50_0)" +"(let-values(((the-struct_80)(read-config/outer-inner v_214)))" +"(if(read-config/inner? the-struct_80)" +"(let-values(((for-syntax?51_0) for-syntax?_4)" +"((readtable52_0) readtable_2)" +"((next-readtable53_0) next-readtable_2)" +"((st54_0)" +"(if local-graph?_0" +"(read-config-state3.1 #f #f)" +"(read-config-st config_0))))" +"(read-config/inner2.1" +" readtable52_0" +" next-readtable53_0" +" for-syntax?51_0" +"(read-config/inner-source the-struct_80)" +"(read-config/inner-read-compiled the-struct_80)" +"(read-config/inner-dynamic-require the-struct_80)" +"(read-config/inner-module-declared? the-struct_80)" +"(read-config/inner-coerce the-struct_80)" +"(read-config/inner-coerce-key the-struct_80)" +"(read-config/inner-parameter-override the-struct_80)" +"(read-config/inner-parameter-cache the-struct_80)" +" st54_0))" +" (raise-argument-error 'struct-copy \"read-config/inner?\" the-struct_80)))))" +"(read-config/outer1.1" +" inner50_0" +" wrap48_0" +"(read-config/outer-line the-struct_79)" +"(read-config/outer-col the-struct_79)" +"(read-config/outer-pos the-struct_79)" +"(read-config/outer-indentations the-struct_79)" +" keep-comment?49_0))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_79)))))))))))))))" +"(define-values" +"(port+config->srcloc)" +"(lambda(in_1 config_1)" +"(begin" +"(let-values(((end-line_0 end-col_0 end-pos_0)(port-next-location in_1)))" +"(srcloc" +"(read-config-source config_1)" +"(read-config-line config_1)" +"(read-config-col config_1)" +"(read-config-pos config_1)" +"(if(read-config-pos config_1)(if end-pos_0(- end-pos_0(read-config-pos config_1)) #f) #f))))))" +"(define-values" +"(reading-at)" +"(lambda(config_2 line_2 col_1 pos_105)" +"(begin" +"(let-values(((v_215) config_2))" +"(let-values(((the-struct_81) v_215))" +"(if(read-config/outer? the-struct_81)" +"(let-values(((line55_0) line_2)" +"((col56_0) col_1)" +"((pos57_0) pos_105)" +"((inner58_1)(read-config/outer-inner v_215)))" +"(read-config/outer1.1" +" inner58_1" +"(read-config/outer-wrap the-struct_81)" +" line55_0" +" col56_0" +" pos57_0" +"(read-config/outer-indentations the-struct_81)" +"(read-config/outer-keep-comment? the-struct_81)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_81)))))))" +"(define-values" +"(disable-wrapping)" +"(lambda(config_3)" +"(begin" +"(let-values(((v_216) config_3))" +"(let-values(((the-struct_82) v_216))" +"(if(read-config/outer? the-struct_82)" +"(let-values(((wrap59_0) #f)((inner60_0)(read-config/outer-inner v_216)))" +"(read-config/outer1.1" +" inner60_0" +" wrap59_0" +"(read-config/outer-line the-struct_82)" +"(read-config/outer-col the-struct_82)" +"(read-config/outer-pos the-struct_82)" +"(read-config/outer-indentations the-struct_82)" +"(read-config/outer-keep-comment? the-struct_82)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_82)))))))" +"(define-values" +"(keep-comment)" +"(lambda(config_4)" +"(begin" +"(let-values(((v_144) config_4))" +"(let-values(((the-struct_83) v_144))" +"(if(read-config/outer? the-struct_83)" +"(let-values(((keep-comment?61_0) #t)((inner62_0)(read-config/outer-inner v_144)))" +"(read-config/outer1.1" +" inner62_0" +"(read-config/outer-wrap the-struct_83)" +"(read-config/outer-line the-struct_83)" +"(read-config/outer-col the-struct_83)" +"(read-config/outer-pos the-struct_83)" +"(read-config/outer-indentations the-struct_83)" +" keep-comment?61_0))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_83)))))))" +"(define-values" +"(discard-comment)" +"(lambda(config_5)" +"(begin" +"(if(not(read-config-keep-comment? config_5))" +"(let-values() config_5)" +"(let-values()" +"(let-values(((v_217) config_5))" +"(let-values(((the-struct_84) v_217))" +"(if(read-config/outer? the-struct_84)" +"(let-values(((keep-comment?63_0) #f)((inner64_0)(read-config/outer-inner v_217)))" +"(read-config/outer1.1" +" inner64_0" +"(read-config/outer-wrap the-struct_84)" +"(read-config/outer-line the-struct_84)" +"(read-config/outer-col the-struct_84)" +"(read-config/outer-pos the-struct_84)" +"(read-config/outer-indentations the-struct_84)" +" keep-comment?63_0))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_84)))))))))" +"(define-values" +"(next-readtable)" +"(lambda(config_6)" +"(begin" +"(if(eq?(read-config-readtable config_6)(read-config-next-readtable config_6))" +"(let-values() config_6)" +"(let-values()" +"(let-values(((v_218) config_6))" +"(let-values(((the-struct_85) v_218))" +"(if(read-config/outer? the-struct_85)" +"(let-values(((inner65_0)" +"(let-values(((the-struct_86)(read-config/outer-inner v_218)))" +"(if(read-config/inner? the-struct_86)" +"(let-values(((readtable66_0)(read-config-next-readtable config_6)))" +"(read-config/inner2.1" +" readtable66_0" +"(read-config/inner-next-readtable the-struct_86)" +"(read-config/inner-for-syntax? the-struct_86)" +"(read-config/inner-source the-struct_86)" +"(read-config/inner-read-compiled the-struct_86)" +"(read-config/inner-dynamic-require the-struct_86)" +"(read-config/inner-module-declared? the-struct_86)" +"(read-config/inner-coerce the-struct_86)" +"(read-config/inner-coerce-key the-struct_86)" +"(read-config/inner-parameter-override the-struct_86)" +"(read-config/inner-parameter-cache the-struct_86)" +"(read-config/inner-st the-struct_86)))" +" (raise-argument-error 'struct-copy \"read-config/inner?\" the-struct_86)))))" +"(read-config/outer1.1" +" inner65_0" +"(read-config/outer-wrap the-struct_85)" +"(read-config/outer-line the-struct_85)" +"(read-config/outer-col the-struct_85)" +"(read-config/outer-pos the-struct_85)" +"(read-config/outer-indentations the-struct_85)" +"(read-config/outer-keep-comment? the-struct_85)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_85)))))))))" +"(define-values" +"(coerce)" +"(lambda(val_74 in_2 config_7)" +"(begin" +"(let-values(((for-syntax?_5)(read-config-for-syntax? config_7)))" +"((read-config-coerce config_7)" +" for-syntax?_5" +" val_74" +"(if for-syntax?_5(port+config->srcloc in_2 config_7) #f))))))" +"(define-values(default-reader-guard$1)(lambda(v_219)(begin 'default-reader-guard v_219)))" +"(define-values" +"(1/current-reader-guard)" +"(make-parameter" +" default-reader-guard$1" +"(lambda(v_220)" +"(begin" +"(if(if(procedure? v_220)(procedure-arity-includes? v_220 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'current-reader-guard \"(procedure-arity-includes/c 1)\" v_220)))" +" v_220))))" +"(define-values(1/read-square-bracket-as-paren)(make-parameter #t(lambda(v_1)(if v_1 #t #f))))" +"(define-values(1/read-curly-brace-as-paren)(make-parameter #t(lambda(v_221)(if v_221 #t #f))))" +"(define-values(1/read-square-bracket-with-tag)(make-parameter #f(lambda(v_222)(if v_222 #t #f))))" +"(define-values(1/read-curly-brace-with-tag)(make-parameter #f(lambda(v_62)(if v_62 #t #f))))" +"(define-values(1/read-cdot)(make-parameter #f(lambda(v_29)(if v_29 #t #f))))" +"(define-values(1/read-accept-graph)(make-parameter #t(lambda(v_63)(if v_63 #t #f))))" +"(define-values(1/read-accept-compiled)(make-parameter #f(lambda(v_2)(if v_2 #t #f))))" +"(define-values(1/read-accept-box)(make-parameter #t(lambda(v_82)(if v_82 #t #f))))" +"(define-values(1/read-decimal-as-inexact)(make-parameter #t(lambda(v_30)(if v_30 #t #f))))" +"(define-values(1/read-accept-dot)(make-parameter #t(lambda(v_75)(if v_75 #t #f))))" +"(define-values(1/read-accept-infix-dot)(make-parameter #t(lambda(v_31)(if v_31 #t #f))))" +"(define-values(1/read-accept-quasiquote)(make-parameter #t(lambda(v_3)(if v_3 #t #f))))" +"(define-values(1/read-accept-reader)(make-parameter #f(lambda(v_32)(if v_32 #t #f))))" +"(define-values(1/read-accept-lang)(make-parameter #t(lambda(v_4)(if v_4 #t #f))))" +"(define-values(unknown)(gensym 'unknown))" +"(define-values" +"(check-parameter)" +"(lambda(param_0 config_8)" +"(begin" +"(let-values(((cache_4)(read-config-parameter-cache config_8)))" +"(let-values(((v_65)" +"(hash-ref(read-config-parameter-override config_8) param_0(hash-ref cache_4 param_0 unknown))))" +"(if(eq? v_65 unknown)" +"(let-values()(let-values(((v_66)(param_0)))(begin(hash-set! cache_4 param_0 v_66) v_66)))" +"(let-values() v_65)))))))" +"(define-values" +"(override-parameter)" +"(lambda(param_1 config_9 v_28)" +"(begin" +"(let-values(((v_93) config_9))" +"(let-values(((the-struct_87) v_93))" +"(if(read-config/outer? the-struct_87)" +"(let-values(((inner1_0)" +"(let-values(((the-struct_88)(read-config/outer-inner v_93)))" +"(if(read-config/inner? the-struct_88)" +"(let-values(((parameter-override2_0)" +"(hash-set(read-config-parameter-override config_9) param_1 v_28)))" +"(read-config/inner2.1" +"(read-config/inner-readtable the-struct_88)" +"(read-config/inner-next-readtable the-struct_88)" +"(read-config/inner-for-syntax? the-struct_88)" +"(read-config/inner-source the-struct_88)" +"(read-config/inner-read-compiled the-struct_88)" +"(read-config/inner-dynamic-require the-struct_88)" +"(read-config/inner-module-declared? the-struct_88)" +"(read-config/inner-coerce the-struct_88)" +"(read-config/inner-coerce-key the-struct_88)" +" parameter-override2_0" +"(read-config/inner-parameter-cache the-struct_88)" +"(read-config/inner-st the-struct_88)))" +" (raise-argument-error 'struct-copy \"read-config/inner?\" the-struct_88)))))" +"(read-config/outer1.1" +" inner1_0" +"(read-config/outer-wrap the-struct_87)" +"(read-config/outer-line the-struct_87)" +"(read-config/outer-col the-struct_87)" +"(read-config/outer-pos the-struct_87)" +"(read-config/outer-indentations the-struct_87)" +"(read-config/outer-keep-comment? the-struct_87)))" +" (raise-argument-error 'struct-copy \"read-config/outer?\" the-struct_87)))))))" +"(define-values" +"(force-parameters!)" +"(lambda(config_10)" +"(begin" +"(let-values(((cache_5)(read-config-parameter-cache config_10)))" +"(if(hash-ref cache_5 'all-forced #f)" +"(void)" +"(let-values()" +"(begin" +"(hash-set! cache_5 'all-forced #t)" +"(check-parameter read-case-sensitive config_10)" +"(check-parameter 1/read-square-bracket-as-paren config_10)" +"(check-parameter 1/read-curly-brace-as-paren config_10)" +"(check-parameter 1/read-square-bracket-with-tag config_10)" +"(check-parameter 1/read-curly-brace-with-tag config_10)" +"(check-parameter 1/read-cdot config_10)" +"(check-parameter 1/read-accept-graph config_10)" +"(check-parameter 1/read-accept-compiled config_10)" +"(check-parameter 1/read-accept-box config_10)" +"(check-parameter read-accept-bar-quote config_10)" +"(check-parameter 1/read-decimal-as-inexact config_10)" +"(check-parameter 1/read-accept-dot config_10)" +"(check-parameter 1/read-accept-infix-dot config_10)" +"(check-parameter 1/read-accept-quasiquote config_10)" +"(check-parameter 1/read-accept-reader config_10)" +"(check-parameter 1/read-accept-lang config_10))))))))" +"(define-values" +"(struct:special-comment 1/make-special-comment 1/special-comment? 1/special-comment-value)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'special-comment" +" #f" +" 1" +" 0" +" #f" +"(list(cons prop:authentic #t))" +"(current-inspector)" +" #f" +" '(0)" +" #f" +" 'make-special-comment)))))" +"(values struct:_0 make-_0 ?_0(make-struct-field-accessor -ref_0 0 'value))))" +"(define-values" +"(struct:readtable" +" readtable1.1" +" 1/readtable?" +" readtable-symbol-parser" +" readtable-char-ht" +" readtable-dispatch-ht" +" readtable-delimiter-ht)" +"(let-values(((struct:_19 make-_19 ?_19 -ref_19 -set!_19)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'readtable" +" #f" +" 4" +" 0" +" #f" +"(list(cons prop:readtable #t))" +"(current-inspector)" +" #f" +" '(0 1 2 3)" +" #f" +" 'readtable)))))" +"(values" +" struct:_19" +" make-_19" +" ?_19" +"(make-struct-field-accessor -ref_19 0 'symbol-parser)" +"(make-struct-field-accessor -ref_19 1 'char-ht)" +"(make-struct-field-accessor -ref_19 2 'dispatch-ht)" +"(make-struct-field-accessor -ref_19 3 'delimiter-ht))))" +"(define-values" +"(1/make-readtable)" +"(lambda(rt_0 . args_7)" +"(begin" +" 'make-readtable" +"(begin" +"(if(let-values(((or-part_55)(not rt_0)))(if or-part_55 or-part_55(1/readtable? rt_0)))" +"(void)" +" (let-values () (raise-argument-error 'make-readtable \"(or/c readtable? #f)\" rt_0)))" +"((letrec-values(((loop_101)" +"(lambda(args_8 symbol-parser_0 char-ht_0 dispatch-ht_0 delimiter-ht_0)" +"(begin" +" 'loop" +"(if(null? args_8)" +"(let-values()(readtable1.1 symbol-parser_0 char-ht_0 dispatch-ht_0 delimiter-ht_0))" +"(let-values()" +"(let-values(((key_84)(car args_8)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_168)(not key_84)))" +"(if or-part_168 or-part_168(char? key_84)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(or/c char? #f)\"" +" key_84)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(null? args_8)" +"(let-values()" +"(if key_84" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +"(string-append" +" \"expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro,\"" +" \" or character argument after character argument\")" +" \"character\"" +" key_84))" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +" \"expected 'non-terminating-macro after #f\"))))" +"(void))" +"(values))))" +"(let-values(((mode_16)(cadr args_8)))" +"(let-values((()" +"(begin" +"(if key_84" +"(let-values()" +"(if(let-values(((or-part_169)" +"(eq? mode_16 'terminating-macro)))" +"(if or-part_169" +" or-part_169" +"(let-values(((or-part_33)" +"(eq?" +" mode_16" +" 'non-terminating-macro)))" +"(if or-part_33" +" or-part_33" +"(let-values(((or-part_297)" +"(eq? mode_16 'dispatch-macro)))" +"(if or-part_297" +" or-part_297" +"(char? mode_16)))))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(or/c 'terminating-macro 'non-terminating-macro 'dispatch-macro char?)\"" +" mode_16))))" +"(let-values()" +"(if(eq? mode_16 'non-terminating-macro)" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +" \"expected 'non-terminating-macro after #f\")))))" +"(values))))" +"(let-values((()" +"(begin" +"(if(null?(cddr args_8))" +"(let-values()" +"(raise-arguments-error" +" 'make-readtable" +"(if key_84" +" \"expected readtable or #f argument after character argument\"" +" \"expected procedure argument after symbol argument\")" +" \"given\"" +" mode_16))" +"(void))" +"(values))))" +"(let-values(((target_0)(caddr args_8)))" +"(let-values(((rest-args_0)(cdddr args_8)))" +"(if(not key_84)" +"(let-values()" +"(begin" +"(if(if(procedure? target_0)" +"(procedure-arity-includes? target_0 6)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(procedure-arity-includes/c 6)\"" +" target_0)))" +"(loop_101" +" rest-args_0" +" target_0" +" char-ht_0" +" dispatch-ht_0" +" delimiter-ht_0)))" +"(if(eq? mode_16 'dispatch-macro)" +"(let-values()" +"(begin" +"(if(if(procedure? target_0)" +"(procedure-arity-includes? target_0 6)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(procedure-arity-includes/c 6)\"" +" target_0)))" +"(loop_101" +" rest-args_0" +" symbol-parser_0" +" char-ht_0" +"(hash-set dispatch-ht_0 key_84 target_0)" +" delimiter-ht_0)))" +"(if(char? mode_16)" +"(let-values()" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_99)" +"(not target_0)))" +"(if or-part_99" +" or-part_99" +"(1/readtable? target_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(or/c readtable? #f)\"" +" target_0)))" +"(values))))" +"(let-values(((actual-target_0)" +"(let-values(((or-part_170)" +"(if target_0" +"(hash-ref" +"(readtable-char-ht target_0)" +" mode_16" +" #f)" " #f)))" -"(define use-path/src(and ns-hts(hash-ref(cdr ns-hts) name #f)))" -"(if use-path/src" -"(parameterize((current-module-declare-source(cadr use-path/src)))" -"(with-dir*(caddr use-path/src)" -"(lambda()((current-load)(car use-path/src) expect-module))))" -"(let*-values(((orig-path)(resolve path))" -"((base orig-file dir?)(split-path path))" -"((file alt-file)(if expect-module" -"(let*((b(path->bytes orig-file))" -"(len(bytes-length b)))" -"(cond" -"((and(len . >= . 4)" -" (bytes=? #\".rkt\" (subbytes b (- len 4))))" -"(values orig-file" -" (bytes->path (bytes-append (subbytes b 0 (- len 4)) #\".ss\"))))" -"(else" -"(values orig-file #f))))" -"(values orig-file #f)))" -"((path)(if(eq? file orig-file)" -" orig-path" -"(build-path base file)))" -"((alt-path)(and alt-file" -"(if(eq? alt-file orig-file)" -" orig-path" -"(build-path base alt-file))))" -"((base)(if(eq? base 'relative) 'same base))" -"((modes)(use-compiled-file-paths))" -"((roots)(current-compiled-file-roots))" -"((reroot)(lambda(p d)" -"(cond" -"((eq? d 'same) p)" -"((relative-path? d)(build-path p d))" -"(else(reroot-path p d))))))" -"(let*((main-path-d(date-of-1 path))" -"(alt-path-d(and alt-path " -"(not main-path-d)" -"(date-of-1 alt-path)))" -"(path-d(or main-path-d alt-path-d))" -"(get-so(lambda(file rep-sfx?)" -"(lambda(root-dir compiled-dir)" -"(build-path(reroot base root-dir)" -" compiled-dir" -" \"native\"" +"(if or-part_170 or-part_170 mode_16))))" +"(let-values(((new-char-ht_0)" +"(if actual-target_0" +"(hash-set" +" char-ht_0" +" key_84" +" actual-target_0)" +"(hash-remove char-ht_0 key_84))))" +"(let-values(((new-delimiter-ht_0)" +"(hash-set" +" delimiter-ht_0" +" key_84" +"(if target_0" +"(hash-ref" +"(readtable-delimiter-ht target_0)" +" mode_16" +" mode_16)" +" mode_16))))" +"(loop_101" +" rest-args_0" +" symbol-parser_0" +" new-char-ht_0" +" dispatch-ht_0" +" new-delimiter-ht_0))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(if(procedure? target_0)" +"(procedure-arity-includes? target_0 6)" +" #f)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'make-readtable" +" \"(procedure-arity-includes/c 6)\"" +" target_0)))" +"(values))))" +"(let-values(((new-char-ht_1)" +"(hash-set char-ht_0 key_84 target_0)))" +"(let-values(((new-delimiter-ht_1)" +"(hash-set" +" delimiter-ht_0" +" key_84" +"(if(eq? mode_16 'terminating-macro)" +" 'delimit" +" 'no-delimit))))" +"(loop_101" +" rest-args_0" +" symbol-parser_0" +" new-char-ht_1" +" dispatch-ht_0" +" new-delimiter-ht_1))))))))))))))))))))))" +" loop_101)" +" args_7" +"(if rt_0(readtable-symbol-parser rt_0) #f)" +"(if rt_0(readtable-char-ht rt_0) '#hasheqv())" +"(if rt_0(readtable-dispatch-ht rt_0) '#hasheqv())" +"(if rt_0(readtable-delimiter-ht rt_0) '#hasheqv()))))))" +"(define-values" +"(*readtable-effective-char)" +"(lambda(rt_1 c_54)" +"(begin" +"(let-values(((target_1)(hash-ref(readtable-char-ht rt_1) c_54 #f)))" +"(if(not target_1)(let-values() c_54)(if(char? target_1)(let-values() target_1)(let-values() '#\\x)))))))" +"(define-values" +"(effective-char)" +"(lambda(c_55 config_11)" +"(begin" +"(let-values(((rt_2)(read-config-readtable config_11))((c_56) c_55))" +"(if(let-values(((or-part_23)(not rt_2)))(if or-part_23 or-part_23(not(char? c_56))))" +"(let-values() c_56)" +"(let-values()(*readtable-effective-char rt_2 c_56)))))))" +"(define-values" +"(readtable-handler)" +"(lambda(config_12 c_57)" +"(begin" +"(let-values(((rt_3)(read-config-readtable config_12)))" +"(if rt_3" +"(let-values(((target_2)(hash-ref(readtable-char-ht rt_3) c_57 #f)))" +"(if target_2(if(not(char? target_2)) target_2 #f) #f))" +" #f)))))" +"(define-values" +"(readtable-dispatch-handler)" +"(lambda(config_13 c_58)" +"(begin" +"(let-values((()(begin(force-parameters! config_13)(values))))" +"(let-values(((rt_4)(read-config-readtable config_13)))" +"(if rt_4(hash-ref(readtable-dispatch-ht rt_4) c_58 #f) #f))))))" +"(define-values" +"(readtable-apply)" +"(lambda(handler_0 c_59 in_3 config_14 line_3 col_2 pos_106)" +"(begin" +"(let-values(((for-syntax?_6)(read-config-for-syntax? config_14)))" +"(let-values(((v_88)" +"(if(not for-syntax?_6)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_14)" +"(let-values()" +"(if(procedure-arity-includes? handler_0 2)" +"(handler_0 c_59 in_3)" +"(handler_0 c_59 in_3 #f line_3 col_2 pos_106)))))" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_14)" +"(let-values()" +"(handler_0 c_59 in_3(read-config-source config_14) line_3 col_2 pos_106)))))))" +"(if(1/special-comment? v_88) v_88(coerce v_88 in_3 config_14)))))))" +"(define-values" +"(1/readtable-mapping)" +"(lambda(rt_5 c_60)" +"(begin" +" 'readtable-mapping" +"(let-values((()" +"(begin" +"(if(1/readtable? rt_5)" +"(void)" +" (let-values () (raise-argument-error 'readtable-mapping \"readtable?\" rt_5)))" +"(values))))" +"(let-values((()" +"(begin" +" (if (char? c_60) (void) (let-values () (raise-argument-error 'readtable-mapping \"char?\" c_60)))" +"(values))))" +"(let-values(((handler_1)(hash-ref(readtable-char-ht rt_5) c_60 #f)))" +"(values" +"(let-values(((or-part_228)" +"(if handler_1" +"(if(char? handler_1)" +"(let-values() handler_1)" +"(if(eq? 'delimit(hash-ref(readtable-delimiter-ht rt_5) c_60 #f))" +"(let-values() 'terminating-macro)" +"(let-values() 'non-terminating-macro)))" +" #f)))" +"(if or-part_228 or-part_228 c_60))" +"(if(char? handler_1) #f handler_1)" +"(hash-ref(readtable-dispatch-ht rt_5) c_60 #f))))))))" +"(define-values" +"(readtable-equivalent-chars)" +"(lambda(rt_6 c_61)" +"(begin" +"(let-values(((ht_152)(readtable-char-ht rt_6)))" +"(append" +"(if(hash-ref ht_152 c_61 #f) null(list c_61))" +"(reverse$1" +"(let-values(((ht_153) ht_152))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_153)))" +"((letrec-values(((for-loop_259)" +"(lambda(fold-var_79 i_171)" +"(begin" +" 'for-loop" +"(if i_171" +"(let-values(((k_39 v_223)(hash-iterate-key+value ht_153 i_171)))" +"(let-values(((fold-var_272)" +"(let-values(((fold-var_82) fold-var_79))" +"(if(eqv? v_223 c_61)" +"(let-values(((fold-var_232) fold-var_82))" +"(let-values(((fold-var_13)" +"(let-values()" +"(cons(let-values() k_39) fold-var_232))))" +"(values fold-var_13)))" +" fold-var_82))))" +"(if(not #f)" +"(for-loop_259 fold-var_272(hash-iterate-next ht_153 i_171))" +" fold-var_272)))" +" fold-var_79)))))" +" for-loop_259)" +" null" +"(hash-iterate-first ht_153))))))))))" +"(define-values" +"(struct:special special1.1 special? special-value)" +"(let-values(((struct:_76 make-_76 ?_76 -ref_76 -set!_76)" +"(let-values()" +"(let-values()(make-struct-type 'special #f 1 0 #f null(current-inspector) #f '(0) #f 'special)))))" +"(values struct:_76 make-_76 ?_76(make-struct-field-accessor -ref_76 0 'value))))" +"(define-values" +"(wrap)" +"(lambda(s-exp_3 in_2 config_7 rep_0)" +"(begin" +"(let-values(((wrap_6)(read-config-wrap config_7)))" +"(if wrap_6(wrap_6 s-exp_3(port+config->srcloc in_2 config_7) rep_0) s-exp_3)))))" +"(define-values(consume-char)(lambda(in_4 c_32)(begin(begin(read-char in_4)(void)))))" +"(define-values" +"(consume-char/special)" +"(lambda(in_5 config_15 c_33)" +"(begin(begin(read-char-or-special in_5 special1.1(read-config-source config_15))(void)))))" +"(define-values" +"(reader-error10.1)" +"(lambda(continuation-marks1_0" +" continuation-marks4_0" +" due-to2_0" +" due-to5_0" +" who3_1" +" who6_0" +" in7_0" +" config8_0" +" str9_0" +" new-rest_0)" +"(begin" +" 'reader-error10" +"(let-values(((in_6) in7_0))" +"(let-values(((config_16) config8_0))" +"(let-values(((continuation-marks_0)" +"(if continuation-marks4_0 continuation-marks1_0(current-continuation-marks))))" +"(let-values(((due-to_0)(if due-to5_0 due-to2_0 '#\\x)))" +"(let-values(((who_25)(if who6_0 who3_1(if(read-config-for-syntax? config_16) 'read-syntax 'read))))" +"(let-values(((str_25) str9_0))" +"(let-values(((args_9) new-rest_0))" +" (let-values (((msg_0) (format \"~a: ~a\" who_25 (apply format str_25 args_9))))" +"(let-values(((srcloc_9)(if in_6(port+config->srcloc in_6 config_16) #f)))" +"(raise" +"((if(eof-object? due-to_0)" +"(let-values() exn:fail:read:eof)" +"(if(not(char? due-to_0))" +"(let-values() exn:fail:read:non-char)" +"(let-values() exn:fail:read)))" +"(let-values(((s_161)" +"(if(error-print-source-location)" +"(if srcloc_9(srcloc->string srcloc_9) #f)" +" #f)))" +" (if s_161 (string-append s_161 \": \" msg_0) msg_0))" +" continuation-marks_0" +"(if srcloc_9(list srcloc_9) null)))))))))))))))" +"(define-values" +"(bad-syntax-error18.1)" +"(lambda(due-to13_0 due-to14_0 in15_0 config16_0 str17_0)" +"(begin" +" 'bad-syntax-error18" +"(let-values(((in_7) in15_0))" +"(let-values(((config_17) config16_0))" +"(let-values(((str_26) str17_0))" +"(let-values(((due-to_1)(if due-to14_0 due-to13_0 '#\\x)))" +"(let-values()" +" (let-values (((due-to23_0) due-to_1) ((temp24_6) \"bad syntax `~a`\") ((str25_0) str_26))" +"(reader-error10.1 #f #f due-to23_0 #t #f #f in_7 config_17 temp24_6(list str25_0)))))))))))" +"(define-values" +"(catch-and-reraise-as-reader/proc)" +"(lambda(in_8 config_18 thunk_5)" +"(begin" +"(let-values(((with-handlers-predicate26_0) exn:fail?)" +"((with-handlers-handler27_0)" +"(lambda(exn_2)" +"(begin" +" 'with-handlers-handler27" +" (let-values (((temp30_2) \"~a\")" +"((temp31_4)" +"(let-values(((s_458)(exn-message exn_2)))" +" (regexp-replace \"^[a-z-]*: \" s_458 \"\")))" +"((temp32_2)(exn-continuation-marks exn_2)))" +"(reader-error10.1 temp32_2 #t #f #f #f #f in_8 config_18 temp30_2(list temp31_4)))))))" +"(let-values(((bpz_3)(continuation-mark-set-first #f break-enabled-key)))" +"(call-handled-body" +" bpz_3" +"(lambda(e_74)" +"(select-handler/no-breaks e_74 bpz_3(list(cons with-handlers-predicate26_0 with-handlers-handler27_0))))" +"(lambda()(thunk_5))))))))" +"(define-values" +"(port-next-location*)" +"(lambda(in_4 init-c_0)" +"(begin" +"(if(not init-c_0)" +"(let-values()(port-next-location in_4))" +"(let-values()" +"(let-values(((line_4 col_3 pos_107)(port-next-location in_4)))" +"(values line_4(if col_3(max 0(sub1 col_3)) #f)(if pos_107(max 1(sub1 pos_107)) #f))))))))" +"(define-values" +"(read-char/skip-whitespace-and-comments)" +"(lambda(init-c_1 read-one_0 in_5 config_15)" +"(begin" +"(let-values(((rt_7)(read-config-readtable config_15)))" +"(let-values(((source_3)(read-config-source config_15)))" +"((letrec-values(((skip-loop_0)" +"(lambda(init-c_2)" +"(begin" +" 'skip-loop" +"(let-values(((c_36)" +"(let-values(((or-part_159) init-c_2))" +"(if or-part_159" +" or-part_159" +"(let-values(((in_9) in_5)((source_4) source_3))" +"(read-char-or-special in_9 special1.1 source_4))))))" +"(let-values(((ec_0)" +"(let-values(((rt_8) rt_7)((c_62) c_36))" +"(if(let-values(((or-part_5)(not rt_8)))" +"(if or-part_5 or-part_5(not(char? c_62))))" +"(let-values() c_62)" +"(let-values()(*readtable-effective-char rt_8 c_62))))))" +"(if(eof-object? ec_0)" +"(let-values() c_36)" +"(if(not(char? ec_0))" +"(let-values()" +"(let-values(((v_1)(special-value c_36)))" +"(if(if(1/special-comment? v_1)" +"(not(read-config-keep-comment? config_15))" +" #f)" +"(let-values()(skip-loop_0 #f))" +"(let-values() c_36))))" +"(if(char-whitespace? ec_0)" +"(let-values()(skip-loop_0 #f))" +"(if(char=? '#\\; ec_0)" +"(let-values()" +"(begin" +"((letrec-values(((loop_76)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_48)" +"(let-values(((in_10) in_5)" +"((source_5) source_3))" +"(read-char-or-special" +" in_10" +" special1.1" +" source_5))))" +"(if(let-values(((or-part_291)" +"(eof-object? c_48)))" +"(if or-part_291" +" or-part_291" +"(eqv?" +" '#\\newline" +"(effective-char c_48 config_15))))" +"(void)" +"(let-values()(loop_76))))))))" +" loop_76))" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))" +"(if(if(char=? '#\\# ec_0)" +"(eqv?" +" '#\\|" +"(let-values(((in_11) in_5)((skip-count_0) 0)((source_6) source_3))" +"(peek-char-or-special in_11 skip-count_0 special1.1 source_6)))" +" #f)" +"(let-values()" +"(begin" +"(skip-pipe-comment! c_36 in_5 config_15)" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))" +"(if(if(char=? '#\\# ec_0)" +"(if(eqv?" +" '#\\!" +"(let-values(((in_6) in_5)" +"((skip-count_1) 0)" +"((source_7) source_3))" +"(peek-char-or-special" +" in_6" +" skip-count_1" +" special1.1" +" source_7)))" +"(let-values(((c3_1)" +"(let-values(((in_12) in_5)" +"((skip-count_2) 1)" +"((source_8) source_3))" +"(peek-char-or-special" +" in_12" +" skip-count_2" +" special1.1" +" source_8))))" +"(let-values(((or-part_71)(eqv? '#\\space c3_1)))" +"(if or-part_71 or-part_71(eqv? '#\\/ c3_1))))" +" #f)" +" #f)" +"(let-values()" +"(begin" +"(skip-unix-line-comment! in_5 config_15)" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))" +"(if(if(char=? '#\\# ec_0)" +"(eqv?" +" '#\\;" +"(let-values(((in_13) in_5)" +"((skip-count_3) 0)" +"((source_9) source_3))" +"(peek-char-or-special in_13 skip-count_3 special1.1 source_9)))" +" #f)" +"(let-values()" +"(let-values((()(begin(consume-char in_5 '#\\;)(values))))" +"(let-values(((v_224)(read-one_0 #f in_5 config_15)))" +"(begin" +"(if(eof-object? v_224)" +"(let-values()" +"(let-values(((v3_0) v_224)" +"((temp4_3)" +" \"expected a commented-out element for `~a;', but found end-of-file\")" +"((ec5_0) ec_0))" +"(reader-error10.1" +" #f" +" #f" +" v3_0" +" #t" +" #f" +" #f" +" in_5" +" config_15" +" temp4_3" +"(list ec5_0))))" +"(void))" +"(if(read-config-keep-comment? config_15)" +"(result-special-comment)" +"(skip-loop_0 #f))))))" +"(let-values() c_36))))))))))))))" +" skip-loop_0)" +" init-c_1))))))" +"(define-values(result-special-comment)(lambda()(begin(special1.1(1/make-special-comment #f)))))" +"(define-values" +"(skip-pipe-comment!)" +"(lambda(init-c_3 in_14 config_19)" +"(begin" +"(let-values(((source_10)(read-config-source config_19)))" +"(let-values(((line_5 col_4 pos_108)(port-next-location in_14)))" +"(begin" +"(consume-char in_14 '#\\|)" +"((letrec-values(((loop_100)" +"(lambda(prev-c_0 depth_10)" +"(begin" +" 'loop" +"(let-values(((c_63)" +"(let-values(((in_15) in_14)((source_11) source_10))" +"(read-char-or-special in_15 special1.1 source_11))))" +"(if(eof-object? c_63)" +"(let-values()" +"(let-values(((temp7_2)(reading-at config_19 line_5 col_4 pos_108))" +"((c8_0) c_63)" +" ((temp9_2) \"end of file in `#|` comment\"))" +"(reader-error10.1 #f #f c8_0 #t #f #f in_14 temp7_2 temp9_2(list))))" +"(if(not(char? c_63))" +"(let-values()(loop_100 #f depth_10))" +"(if(if(char=? '#\\| c_63)(eqv? prev-c_0 '#\\#) #f)" +"(let-values()(loop_100 #f(add1 depth_10)))" +"(if(if(char=? '#\\# c_63)(eqv? prev-c_0 '#\\|) #f)" +"(let-values()" +"(if(positive? depth_10)" +"(let-values()(loop_100 #f(sub1 depth_10)))" +"(void)))" +"(let-values()(loop_100 c_63 depth_10)))))))))))" +" loop_100)" +" #f" +" 0)))))))" +"(define-values" +"(skip-unix-line-comment!)" +"(lambda(in_16 config_20)" +"(begin" +"((letrec-values(((loop_102)" +"(lambda(backslash?_0)" +"(begin" +" 'loop" +"(let-values(((c_64)" +"(let-values(((in_17) in_16)((source_12)(read-config-source config_20)))" +"(read-char-or-special in_17 special1.1 source_12))))" +"(if(eof-object? c_64)" +"(let-values()(void))" +"(if(not(char? c_64))" +"(let-values()(loop_102 #f))" +"(if(char=? c_64 '#\\newline)" +"(let-values()(if backslash?_0(let-values()(loop_102 #f))(void)))" +"(if(char=? c_64 '#\\\\)" +"(let-values()(loop_102 #t))" +"(let-values()(loop_102 #f)))))))))))" +" loop_102)" +" #f))))" +"(define-values" +"(readtable-char-delimiter?)" +"(lambda(rt_9 c_32 config_7)" +"(begin" +"(let-values(((dc_0)" +"(let-values(((or-part_2)(if rt_9(hash-ref(readtable-delimiter-ht rt_9) c_32 #f) #f)))" +"(if or-part_2 or-part_2 c_32))))" +"(if(eq? dc_0 'no-delimit)" +"(let-values() #f)" +"(if(not(char? dc_0))" +"(let-values() #t)" +"(let-values()" +"(let-values(((or-part_26)(char-whitespace? dc_0)))" +"(if or-part_26" +" or-part_26" +"(let-values(((or-part_298)(char=? dc_0 '#\\()))" +"(if or-part_298" +" or-part_298" +"(let-values(((or-part_284)(char=? dc_0 '#\\))))" +"(if or-part_284" +" or-part_284" +"(let-values(((or-part_27)(char=? dc_0 '#\\[)))" +"(if or-part_27" +" or-part_27" +"(let-values(((or-part_10)(char=? dc_0 '#\\])))" +"(if or-part_10" +" or-part_10" +"(let-values(((or-part_159)(char=? dc_0 '#\\{)))" +"(if or-part_159" +" or-part_159" +"(let-values(((or-part_12)(char=? dc_0 '#\\})))" +"(if or-part_12" +" or-part_12" +"(let-values(((or-part_13)(char=? dc_0 '#\\')))" +"(if or-part_13" +" or-part_13" +"(let-values(((or-part_215)(char=? dc_0 '#\\`)))" +"(if or-part_215" +" or-part_215" +"(let-values(((or-part_3)(char=? dc_0 '#\\,)))" +"(if or-part_3" +" or-part_3" +"(let-values(((or-part_4)(char=? dc_0 '#\\;)))" +"(if or-part_4" +" or-part_4" +" (let-values (((or-part_5) (char=? dc_0 '#\\\")))" +"(if or-part_5" +" or-part_5" +"(if(char=? dc_0 '#\\.)" +"(check-parameter 1/read-cdot config_7)" +" #f))))))))))))))))))))))))))))))))" +"(define-values" +"(char-delimiter?)" +"(lambda(c_14 config_21)(begin(readtable-char-delimiter?(read-config-readtable config_21) c_14 config_21))))" +"(define-values" +"(char-closer?)" +"(lambda(ec_1 config_8)" +"(begin" +"(if(not(eof-object? ec_1))" +"(let-values(((or-part_1)(char=? ec_1 '#\\))))" +"(if or-part_1" +" or-part_1" +"(let-values(((or-part_11)(char=? ec_1 '#\\])))(if or-part_11 or-part_11(char=? ec_1 '#\\})))))" +" #f))))" +" (define-values (closer-name) (lambda (c_33 config_22) (begin (effective-char-names c_33 config_22 \"closer\"))))" +" (define-values (opener-name) (lambda (c_34 config_23) (begin (effective-char-names c_34 config_23 \"opener\"))))" +"(define-values" +"(effective-char-names)" +"(lambda(c_36 config_24 fallback-str_0)" +"(begin" +"(let-values(((rt_10)(read-config-readtable config_24)))" +"(if(not rt_10)" +" (let-values () (format \"`~a`\" c_36))" +"(let-values()" +"(let-values(((cs_1)(readtable-equivalent-chars rt_10 c_36)))" +"(if(null? cs_1)" +"(let-values() fallback-str_0)" +"(if(null?(cdr cs_1))" +" (let-values () (format \"`~a`\" (car cs_1)))" +"(if(null?(cddr cs_1))" +" (let-values () (format \"`~a` or `~a`\" (car cs_1) (cadr cs_1)))" +"(let-values()" +"(apply" +" string-append" +"((letrec-values(((loop_103)" +"(lambda(cs_2)" +"(begin" +" 'loop" +"(if(null?(cdr cs_2))" +" (let-values () (list (format \"or `~a`\" (car cs_2))))" +"(let-values()" +" (cons (format \"`~a`, \" (car cs_2)) (loop_103 (cdr cs_2)))))))))" +" loop_103)" +" cs_1)))))))))))))" +"(define-values" +"(closer->opener)" +"(lambda(c_62)" +"(begin" +"(let-values(((tmp_37) c_62))" +"(if(equal? tmp_37 '#\\))" +"(let-values() '#\\()" +"(if(equal? tmp_37 '#\\])" +"(let-values() '#\\[)" +"(if(equal? tmp_37 '#\\})(let-values() '#\\{)(let-values() c_62))))))))" +" (define-values (dot-name) (lambda (config_25) (begin \"`.`\")))" +"(define-values" +"(all-openers-str)" +"(lambda(config_21)" +"(begin" +"(let-values(((p_57)(opener-name '#\\( config_21)))" +"(let-values(((s_10)" +"(if(check-parameter 1/read-square-bracket-as-paren config_21)(opener-name '#\\[ config_21) #f)))" +"(let-values(((c_49)" +"(if(check-parameter 1/read-curly-brace-as-paren config_21)(opener-name '#\\{ config_21) #f)))" +"(if(if s_10 c_49 #f)" +" (let-values () (format \"~a, ~a, or ~a\" p_57 s_10 c_49))" +"(if(let-values(((or-part_290) s_10))(if or-part_290 or-part_290 c_49))" +"(let-values()" +" (format \"~a or ~a\" p_57 (let-values (((or-part_291) s_10)) (if or-part_291 or-part_291 c_49))))" +"(let-values() p_57)))))))))" +"(define-values" +"(struct:accum-string" +" accum-string1.1" +" accum-string?" +" accum-string-pos" +" accum-string-str" +" set-accum-string-pos!" +" set-accum-string-str!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'accum-string #f 2 0 #f null(current-inspector) #f '() #f 'accum-string)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'pos)" +"(make-struct-field-accessor -ref_0 1 'str)" +"(make-struct-field-mutator -set!_0 0 'pos)" +"(make-struct-field-mutator -set!_0 1 'str))))" +"(define-values" +"(accum-string-init!)" +"(lambda(config_26)" +"(begin" +"(let-values(((st_1)(read-config-st config_26)))" +"(let-values(((a_65)(read-config-state-accum-str st_1)))" +"(if a_65" +"(let-values()(begin(set-read-config-state-accum-str! st_1 #f)(set-accum-string-pos! a_65 0) a_65))" +"(let-values()(accum-string1.1 0(make-string 32)))))))))" +"(define-values" +"(accum-string-add!)" +"(lambda(a_66 c_65)" +"(begin" +"(let-values(((pos_109)(accum-string-pos a_66)))" +"(let-values(((str_27)(accum-string-str a_66)))" +"(let-values(((str2_0)" +"(if(< pos_109(string-length str_27))" +"(let-values() str_27)" +"(let-values()" +"(let-values(((str2_1)(make-string(*(string-length str_27) 2))))" +"(begin(string-copy! str2_1 0 str_27)(set-accum-string-str! a_66 str2_1) str2_1))))))" +"(begin(string-set! str2_0 pos_109 c_65)(set-accum-string-pos! a_66(add1 pos_109)))))))))" +"(define-values(accum-string-count)(lambda(a_67)(begin(accum-string-pos a_67))))" +"(define-values(set-accum-string-count!)(lambda(a_68 pos_11)(begin(set-accum-string-pos! a_68 pos_11))))" +"(define-values" +"(accum-string-convert!)" +"(lambda(a_69 convert_1 start-pos_6)" +"(begin" +"(let-values(((str_28)(accum-string-str a_69)))" +"(let-values(((s_74)(convert_1(substring str_28 start-pos_6(accum-string-pos a_69)))))" +"(let-values(((len_36)(string-length s_74)))" +"(begin" +"(if(<(+ len_36 start-pos_6)(string-length str_28))" +"(void)" +"(let-values()" +"(let-values(((str2_2)(make-string(+ start-pos_6 len_36))))" +"(begin(string-copy! str2_2 0 str_28 0 start-pos_6)(set-accum-string-str! a_69 str2_2)))))" +"(string-copy!(accum-string-str a_69) start-pos_6 s_74)" +"(set-accum-string-pos! a_69(+ start-pos_6 len_36)))))))))" +"(define-values" +"(accum-string-get!6.1)" +"(lambda(start-pos2_0 start-pos3_0 a4_0 config5_0)" +"(begin" +" 'accum-string-get!6" +"(let-values(((a_70) a4_0))" +"(let-values(((config_27) config5_0))" +"(let-values(((start-pos_7)(if start-pos3_0 start-pos2_0 0)))" +"(let-values()" +"(let-values(((s_185)(substring(accum-string-str a_70) start-pos_7(accum-string-pos a_70))))" +"(begin(accum-string-abandon! a_70 config_27) s_185)))))))))" +"(define-values" +"(accum-string-get-bytes!13.1)" +"(lambda(start-pos9_0 start-pos10_0 a11_0 config12_0)" +"(begin" +" 'accum-string-get-bytes!13" +"(let-values(((a_61) a11_0))" +"(let-values(((config_28) config12_0))" +"(let-values(((start-pos_8)(if start-pos10_0 start-pos9_0 0)))" +"(let-values()" +"(let-values(((bstr_3)" +"(string->bytes/latin-1(accum-string-str a_61) #f start-pos_8(accum-string-pos a_61))))" +"(begin(accum-string-abandon! a_61 config_28) bstr_3)))))))))" +"(define-values" +"(accum-string-abandon!)" +"(lambda(a_71 config_29)(begin(set-read-config-state-accum-str!(read-config-st config_29) a_71))))" +"(define-values" +"(struct:indentation" +" indentation1.1" +" indentation?" +" indentation-closer" +" indentation-suspicious-closer" +" indentation-multiline?" +" indentation-start-line" +" indentation-last-line" +" indentation-suspicious-line" +" indentation-max-indent" +" indentation-suspicious-quote" +" set-indentation-suspicious-closer!" +" set-indentation-multiline?!" +" set-indentation-last-line!" +" set-indentation-suspicious-line!" +" set-indentation-max-indent!" +" set-indentation-suspicious-quote!)" +"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)" +"(let-values()" +"(let-values()" +"(make-struct-type 'indentation #f 8 0 #f null(current-inspector) #f '(0 3) #f 'indentation)))))" +"(values" +" struct:_0" +" make-_0" +" ?_0" +"(make-struct-field-accessor -ref_0 0 'closer)" +"(make-struct-field-accessor -ref_0 1 'suspicious-closer)" +"(make-struct-field-accessor -ref_0 2 'multiline?)" +"(make-struct-field-accessor -ref_0 3 'start-line)" +"(make-struct-field-accessor -ref_0 4 'last-line)" +"(make-struct-field-accessor -ref_0 5 'suspicious-line)" +"(make-struct-field-accessor -ref_0 6 'max-indent)" +"(make-struct-field-accessor -ref_0 7 'suspicious-quote)" +"(make-struct-field-mutator -set!_0 1 'suspicious-closer)" +"(make-struct-field-mutator -set!_0 2 'multiline?)" +"(make-struct-field-mutator -set!_0 4 'last-line)" +"(make-struct-field-mutator -set!_0 5 'suspicious-line)" +"(make-struct-field-mutator -set!_0 6 'max-indent)" +"(make-struct-field-mutator -set!_0 7 'suspicious-quote))))" +"(define-values" +"(make-indentation)" +"(lambda(closer_0 in_18 config_30)" +"(begin" +"(let-values(((line_6 col_5 pos_110)(port-next-location in_18)))" +"(indentation1.1 closer_0 #f #f line_6 line_6 #f(if col_5(add1 col_5) #f) #f)))))" +"(define-values" +"(track-indentation!)" +"(lambda(config_31 line_7 col_6)" +"(begin" +"(let-values(((indts_0)(read-config-indentations config_31)))" +"(let-values(((indt_0)(if(pair? indts_0)(car indts_0) #f)))" +"(if(if indt_0" +"(if line_7(if(indentation-last-line indt_0)(> line_7(indentation-last-line indt_0)) #f) #f)" +" #f)" +"(let-values()" +"(begin" +"(set-indentation-last-line! indt_0 line_7)" +"(set-indentation-multiline?! indt_0 #t)" +"(if(>= col_6(indentation-max-indent indt_0))" +"(let-values()(set-indentation-max-indent! indt_0 col_6))" +"(let-values()" +"(if(indentation-suspicious-line indt_0)" +"(void)" +"(let-values()" +"(begin" +"(set-indentation-suspicious-closer! indt_0(indentation-closer indt_0))" +"(set-indentation-suspicious-line! indt_0 line_7))))))))" +"(void)))))))" +"(define-values" +"(indentation-possible-cause)" +"(lambda(config_32)" +"(begin" +"(let-values(((indt_1)(car(read-config-indentations config_32))))" +"(if(indentation-suspicious-line indt_1)" +"(let-values()" +"(format" +" \"\\n possible cause: indentation suggests a missing ~a before line ~a\"" +"(closer-name(indentation-suspicious-closer indt_1) config_32)" +"(indentation-suspicious-line indt_1)))" +" (let-values () \"\"))))))" +"(define-values" +"(indentation-unexpected-closer-message)" +"(lambda(ec_2 c_43 config_33)" +"(begin" +"(let-values(((indts_1)(read-config-indentations config_33)))" +"(if(null? indts_1)" +" (let-values () (format \"unexpected `~a`\" c_43))" +"(let-values()" +"(let-values(((indt_2)(car indts_1)))" +"(string-append" +"(if(char=? ec_2(indentation-closer indt_2))" +" (let-values () (format \"unexpected `~a`\" c_43))" +"(let-values()" +"(let-values(((missing_2)" +"(let-values(((or-part_262)" +"(let-values(((lst_300)(cdr indts_1)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_300)))" +"((letrec-values(((for-loop_260)" +"(lambda(result_37 lst_301)" +"(begin" +" 'for-loop" +"(if(pair? lst_301)" +"(let-values(((indt_3)(unsafe-car lst_301))" +"((rest_169)" +"(unsafe-cdr lst_301)))" +"(let-values(((result_112)" +"(let-values()" +"(let-values(((result_76)" +"(let-values()" +"(let-values()" +"(if(char=?" +" ec_2" +"(indentation-closer" +" indt_3))" +" \"missing\"" +" #f)))))" +"(values result_76)))))" +"(if(if(not" +"((lambda x_80 result_112)" +" indt_3))" +"(not #f)" +" #f)" +"(for-loop_260 result_112 rest_169)" +" result_112)))" +" result_37)))))" +" for-loop_260)" +" #f" +" lst_300)))))" +" (if or-part_262 or-part_262 \"expected\"))))" +"(let-values(((opener-str_0)(opener-name(closer->opener(indentation-closer indt_2)) config_33)))" +"(format" +" \"~a ~a to close ~a, found instead `~a`\"" +" missing_2" +"(closer-name(indentation-closer indt_2) config_33)" +"(if(indentation-multiline? indt_2)" +" (let-values () (format \"~a on line ~a\" opener-str_0 (indentation-start-line indt_2)))" +" (let-values () (format \"preceding ~a\" opener-str_0)))" +" c_43)))))" +"(indentation-possible-cause config_33)))))))))" +"(define-values" +"(read-unwrapped-sequence17.1)" +"(lambda(dot-mode2_0" +" dot-mode7_0" +" elem-config1_0" +" elem-config6_0" +" first-read-one5_0" +" first-read-one10_0" +" shape-tag?3_0" +" shape-tag?8_0" +" whitespace-read-one4_0" +" whitespace-read-one9_0" +" read-one11_0" +" opener-c12_0" +" opener13_0" +" closer14_0" +" in15_1" +" seq-config16_0)" +"(begin" +" 'read-unwrapped-sequence17" +"(let-values(((read-one_1) read-one11_0))" +"(let-values(((opener-c_0) opener-c12_0))" +"(let-values(((opener_0) opener13_0))" +"(let-values(((closer_1) closer14_0))" +"(let-values(((in_10) in15_1))" +"(let-values(((seq-config_0) seq-config16_0))" +"(let-values(((elem-config_0)(if elem-config6_0 elem-config1_0(next-readtable seq-config_0))))" +"(let-values(((dot-mode_0)(if dot-mode7_0 dot-mode2_0 'all)))" +"(let-values(((shape-tag?_0)(if shape-tag?8_0 shape-tag?3_0 #f)))" +"(let-values(((whitespace-read-one_0)" +"(if whitespace-read-one9_0 whitespace-read-one4_0 read-one_1)))" +"(let-values(((first-read-one_0)(if first-read-one10_0 first-read-one5_0 read-one_1)))" +"(let-values()" +"(let-values(((head_0) #f))" +"(let-values(((indentation_0)(make-indentation closer_1 in_10 seq-config_0)))" +"(let-values(((config_16)" +"(let-values(((v_5) elem-config_0))" +"(let-values(((the-struct_56) v_5))" +"(if(read-config/outer? the-struct_56)" +"(let-values(((indentations20_0)" +"(cons" +" indentation_0" +"(read-config-indentations seq-config_0)))" +"((inner21_0)(read-config/outer-inner v_5)))" +"(read-config/outer1.1" +" inner21_0" +"(read-config/outer-wrap the-struct_56)" +"(read-config/outer-line the-struct_56)" +"(read-config/outer-col the-struct_56)" +"(read-config/outer-pos the-struct_56)" +" indentations20_0" +"(read-config/outer-keep-comment? the-struct_56)))" +"(raise-argument-error" +" 'struct-copy" +" \"read-config/outer?\"" +" the-struct_56))))))" +"(let-values(((config/keep-comment_0)(keep-comment config_16)))" +"(let-values(((read-one/not-eof_0)" +"(lambda(init-c_4 read-one_2 config_34)" +"(begin" +" 'read-one/not-eof" +"(let-values(((e_69)(read-one_2 init-c_4 in_10 config_34)))" +"(begin" +"(if(eof-object? e_69)" +"(let-values()" +"(let-values(((e24_0) e_69)" +"((temp25_5)" +" \"expected a ~a to close `~a`~a\")" +"((temp26_4)" +"(closer-name closer_1 config_34))" +"((opener-c27_0) opener-c_0)" +"((temp28_0)" +"(indentation-possible-cause config_34)))" +"(reader-error10.1" +" #f" +" #f" +" e24_0" +" #t" +" #f" +" #f" +" in_10" +" config_34" +" temp25_5" +"(list temp26_4 opener-c27_0 temp28_0))))" +"(void))" +" e_69))))))" +"(let-values(((seq_0)" +"((letrec-values(((loop_104)" +"(lambda(depth_11" +" accum_0" +" init-c_5" +" first?_1" +" first-read-one_1)" +"(begin" +" 'loop" +"(let-values(((c_66)" +"(read-char/skip-whitespace-and-comments" +" init-c_5" +" whitespace-read-one_0" +" in_10" +" seq-config_0)))" +"(let-values(((ec_3)" +"(effective-char" +" c_66" +" seq-config_0)))" +"(if(eqv? ec_3 closer_1)" +"(let-values()" +"(if(null? accum_0)" +" null" +"(reverse$1 accum_0)))" +"(if(if(not first?_1)" +"(if(eqv? ec_3 '#\\.)" +"(if(check-parameter" +" 1/read-accept-dot" +" config_16)" +"(char-delimiter?" +"(let-values(((in_19)" +" in_10)" +"((skip-count_4)" +" 0)" +"((source_13)" +"(read-config-source" +" config_16)))" +"(peek-char-or-special" +" in_19" +" skip-count_4" +" special1.1" +" source_13))" +" seq-config_0)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(let-values(((dot-line_0" +" dot-col_0" +" dot-pos_0)" +"(port-next-location*" +" in_10" +" c_66)))" +"(let-values((()" +"(begin" +"(track-indentation!" +" config_16" +" dot-line_0" +" dot-col_0)" +"(values))))" +"(let-values((()" +"(begin" +"(if(if dot-mode_0" +"(not" +" head_0)" +" #f)" +"(void)" +"(let-values()" +"(let-values(((in29_1)" +" in_10)" +"((temp30_3)" +"(reading-at" +" config_16" +" dot-line_0" +" dot-col_0" +" dot-pos_0))" +"((temp31_5)" +" \"illegal use of `.`\"))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in29_1" +" temp30_3" +" temp31_5" +"(list)))))" +"(values))))" +"(let-values(((v_35)" +"(read-one/not-eof_0" +" #f" +" first-read-one_1" +" config_16)))" +"(let-values(((rest-c_0)" +"(read-char/skip-whitespace-and-comments" +" #f" +" whitespace-read-one_0" +" in_10" +" seq-config_0)))" +"(let-values(((rest-ec_0)" +"(effective-char" +" rest-c_0" +" seq-config_0)))" +"(if(eqv?" +" rest-ec_0" +" closer_1)" +"(let-values()" +"(if(null?" +" accum_0)" +" v_35" +"(append" +"(reverse$1" +" accum_0)" +" v_35)))" +"(if(if(eqv?" +" rest-ec_0" +" '#\\.)" +"(if(check-parameter" +" 1/read-accept-dot" +" config_16)" +"(if(check-parameter" +" 1/read-accept-infix-dot" +" config_16)" +"(char-delimiter?" +"(let-values(((in_17)" +" in_10)" +"((skip-count_5)" +" 0)" +"((source_14)" +"(read-config-source" +" config_16)))" +"(peek-char-or-special" +" in_17" +" skip-count_5" +" special1.1" +" source_14))" +" seq-config_0)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(let-values((()" +"(begin" +"(set! head_0" +"(box" +" v_35))" +"(values))))" +"(let-values(((dot2-line_0" +" dot2-col_0" +" dot2-pos_0)" +"(port-next-location" +" in_10)))" +"(let-values((()" +"(begin" +"(track-indentation!" +" config_16" +" dot2-line_0" +" dot2-col_0)" +"(values))))" +"(let-values(((post-c_0)" +"(read-char/skip-whitespace-and-comments" +" #f" +" whitespace-read-one_0" +" in_10" +" seq-config_0)))" +"(let-values(((post-ec_0)" +"(effective-char" +" post-c_0" +" seq-config_0)))" +"(begin" +"(if(let-values(((or-part_299)" +"(eof-object?" +" post-ec_0)))" +"(if or-part_299" +" or-part_299" +"(eqv?" +" post-ec_0" +" closer_1)))" +"(let-values()" +"(let-values(((temp33_2)" +"(reading-at" +" config_16" +" dot-line_0" +" dot-col_0" +" dot-pos_0))" +"((post-ec34_0)" +" post-ec_0)" +"((temp35_1)" +" \"illegal use of `.`\"))" +"(reader-error10.1" +" #f" +" #f" +" post-ec34_0" +" #t" +" #f" +" #f" +" in_10" +" temp33_2" +" temp35_1" +"(list))))" +"(void))" +"(loop_104" +" depth_11" +" accum_0" +" post-c_0" +" #f" +" read-one_1))))))))" +"(let-values()" +"(let-values(((temp37_2)" +"(reading-at" +" config_16" +" dot-line_0" +" dot-col_0" +" dot-pos_0))" +"((rest-c38_0)" +" rest-c_0)" +"((temp39_5)" +" \"illegal use of `.`\"))" +"(reader-error10.1" +" #f" +" #f" +" rest-c38_0" +" #t" +" #f" +" #f" +" in_10" +" temp37_2" +" temp39_5" +"(list)))))))))))))" +"(let-values()" +"(let-values(((v_55)" +"(read-one/not-eof_0" +" c_66" +" first-read-one_1" +" config/keep-comment_0)))" +"(if(1/special-comment? v_55)" +"(let-values()" +"(loop_104" +" depth_11" +" accum_0" +" #f" +" #f" +" read-one_1))" +"(if(> depth_11 1024)" +"(let-values()" +"(loop_104" +" depth_11" +"(cons v_55 accum_0)" +" #f" +" #f" +" read-one_1))" +"(let-values()" +"(cons" +" v_55" +"(loop_104" +"(add1 depth_11)" +" null" +" #f" +" #f" +" read-one_1)))))))))))))))" +" loop_104)" +" 0" +" null" +" #f" +" #t" +" first-read-one_0)))" +"(let-values(((full-seq_0)(if head_0(cons(unbox head_0) seq_0) seq_0)))" +"(if shape-tag?_0" +"(add-shape-tag opener_0 in_10 config_16 full-seq_0)" +" full-seq_0)))))))))))))))))))))))" +"(define-values" +"(add-shape-tag)" +"(lambda(opener_1 in_20 config_35 seq_1)" +"(begin" +"(let-values(((tag_0)" +"(let-values(((tmp_38) opener_1))" +"(if(equal? tmp_38 '#\\[)" +"(let-values()(if(check-parameter 1/read-square-bracket-with-tag config_35) '#%brackets #f))" +"(if(equal? tmp_38 '#\\{)" +"(let-values()(if(check-parameter 1/read-curly-brace-with-tag config_35) '#%braces #f))" +"(let-values() #f))))))" +"(if tag_0(cons(wrap tag_0 in_20 config_35 #f) seq_1) seq_1)))))" +" (define-values (not-an-fX.1) (lambda (who_26 v_225) (begin 'not-an-fX (raise-argument-error who_26 \"fixnum?\" v_225))))" +"(define-values" +"(not-an-fX.1$1)" +" (lambda (who_26 v_225) (begin 'not-an-fX (raise-argument-error who_26 \"flonum?\" v_225))))" +"(define-values" +"(read-digits13.1)" +"(lambda(base1_0" +" init3_0" +" init7_0" +" max-count2_0" +" zero-digits-result4_0" +" zero-digits-result8_0" +" in11_0" +" config12_1" +" accum-str9_0" +" accum-str10_0)" +"(begin" +" 'read-digits13" +"(let-values(((in_21) in11_0))" +"(let-values(((config_36) config12_1))" +"(let-values(((accum-str_0)(if accum-str10_0 accum-str9_0 #f)))" +"(let-values(((base_22) base1_0))" +"(let-values(((max-count_0) max-count2_0))" +"(let-values(((init-v_0)(if init7_0 init3_0 0)))" +"(let-values(((zero-digits-result_0)(if zero-digits-result8_0 zero-digits-result4_0 #f)))" +"(let-values()" +"(let-values(((c_67)" +"(let-values(((in_22) in_21)" +"((skip-count_6) 0)" +"((source_15)(read-config-source config_36)))" +"(peek-char-or-special in_22 skip-count_6 special1.1 source_15))))" +"(if(digit?$1 c_67 base_22)" +"(let-values()" +"(begin" +"(consume-char in_21 c_67)" +"(if accum-str_0(let-values()(accum-string-add! accum-str_0 c_67))(void))" +"((letrec-values(((loop_105)" +"(lambda(v_224 max-count_1)" +"(begin" +" 'loop" +"(if(zero? max-count_1)" +"(let-values() v_224)" +"(let-values()" +"(let-values(((c_51)" +"(let-values(((in_23) in_21)" +"((skip-count_7) 0)" +"((source_16)" +"(read-config-source config_36)))" +"(peek-char-or-special" +" in_23" +" skip-count_7" +" special1.1" +" source_16))))" +"(if(digit?$1 c_51 base_22)" +"(let-values()" +"(begin" +"(consume-char in_21 c_51)" +"(if accum-str_0" +"(let-values()(accum-string-add! accum-str_0 c_51))" +"(void))" +"(loop_105" +"(+(digit->number c_51)(* v_224 base_22))" +"(sub1 max-count_1))))" +"(let-values() v_224)))))))))" +" loop_105)" +"(+(digit->number c_67)(* init-v_0 base_22))" +"(sub1 max-count_0))))" +"(if zero-digits-result_0" +"(let-values() zero-digits-result_0)" +"(let-values() c_67)))))))))))))))" +"(define-values" +"(digit?$1)" +"(lambda(c_56 base_23)" +"(begin" +" 'digit?" +"(if(not(char? c_56))" +"(let-values() #f)" +"(if(= base_23 8)" +"(let-values()(octal-digit? c_56))" +"(if(= base_23 16)(let-values()(hex-digit? c_56))(let-values()(decimal-digit? c_56))))))))" +"(define-values(decimal-digit?)(lambda(c_68)(begin(if(char>=? c_68 '#\\0)(char<=? c_68 '#\\9) #f))))" +"(define-values(octal-digit?)(lambda(c_57)(begin(if(char>=? c_57 '#\\0)(char<=? c_57 '#\\7) #f))))" +"(define-values" +"(hex-digit?)" +"(lambda(c_69)" +"(begin" +"(let-values(((or-part_67)(if(char>=? c_69 '#\\0)(char<=? c_69 '#\\9) #f)))" +"(if or-part_67" +" or-part_67" +"(let-values(((or-part_101)(if(char>=? c_69 '#\\A)(char<=? c_69 '#\\F) #f)))" +"(if or-part_101 or-part_101(if(char>=? c_69 '#\\a)(char<=? c_69 '#\\f) #f))))))))" +"(define-values" +"(digit->number)" +"(lambda(c_58)" +"(begin" +"(if(if(char>=? c_58 '#\\0)(char<=? c_58 '#\\9) #f)" +"(let-values()(-(char->integer c_58)(char->integer '#\\0)))" +"(if(if(char>=? c_58 '#\\A)(char<=? c_58 '#\\F) #f)" +"(let-values()(-(char->integer c_58)(-(char->integer '#\\A) 10)))" +"(let-values()(-(char->integer c_58)(-(char->integer '#\\a) 10))))))))" +"(define-values(string->number$1) string->number)" +"(define-values" +"(1/string->number)" +"(let-values(((string->number8_0)" +"(lambda(s7_2 radix1_0 convert-mode2_0 decimal-mode3_0 radix4_0 convert-mode5_0 decimal-mode6_0)" +"(begin" +" 'string->number8" +"(let-values(((s_183) s7_2))" +"(let-values(((radix_0)(if radix4_0 radix1_0 10)))" +"(let-values(((convert-mode_0)(if convert-mode5_0 convert-mode2_0 'number-or-false)))" +"(let-values(((decimal-mode_0)" +"(if decimal-mode6_0" +" decimal-mode3_0" +"(if(1/read-decimal-as-inexact) 'decimal-as-inexact 'decimal-as-exact))))" +"(let-values()" +"(let-values()" +"(let-values()" +"(begin" +"(if(string? s_183)" +"(void)" +" (let-values () (raise-argument-error 'string->number \"string?\" s_183)))" +"(if((lambda(p_67)(if(exact-integer? radix_0)(<= 2 radix_0 16) #f)) radix_0)" +"(void)" +"(let-values()" +" (raise-argument-error 'string->number \"(integer-in 2 16)\" radix_0)))" +"(if((lambda(p_59)" +"(let-values(((or-part_7)(eq? p_59 'number-or-false)))" +"(if or-part_7 or-part_7(eq? p_59 'read))))" +" convert-mode_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'string->number" +" \"(or/c 'number-or-false 'read)\"" +" convert-mode_0)))" +"(if((lambda(p_68)" +"(let-values(((or-part_9)(eq? p_68 'decimal-as-inexact)))" +"(if or-part_9 or-part_9(eq? p_68 'decimal-as-exact))))" +" decimal-mode_0)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'string->number" +" \"(or/c 'decimal-as-inexact decimal-as-exact)\"" +" decimal-mode_0)))" +"(let-values(((temp70_1) 0)" +"((temp71_0)(string-length s_183))" +"((radix72_0) radix_0)" +"((temp73_0) #f)" +"((decimal-mode74_0) decimal-mode_0)" +"((convert-mode75_0) convert-mode_0))" +"(do-string->number20.1" +" #f" +" #f" +" temp73_0" +" s_183" +" temp70_1" +" temp71_0" +" radix72_0" +" decimal-mode74_0" +" convert-mode75_0))))))))))))))" +"(case-lambda" +"((s_459)(begin 'string->number(string->number8_0 s_459 #f #f #f #f #f #f)))" +"((s_460 radix_1 convert-mode_1 decimal-mode3_1)" +"(string->number8_0 s_460 radix_1 convert-mode_1 decimal-mode3_1 #t #t #t))" +"((s_78 radix_2 convert-mode2_1)(string->number8_0 s_78 radix_2 convert-mode2_1 #f #t #t #f))" +"((s_428 radix1_1)(string->number8_0 s_428 radix1_1 #f #f #t #f #f)))))" +"(define-values" +"(do-string->number20.1)" +"(lambda(in-complex11_0" +" in-complex13_0" +" radix-set?10_0" +" s14_0" +" start15_0" +" end16_0" +" radix17_0" +" exactness18_0" +" convert-mode19_0)" +"(begin" +" 'do-string->number20" +"(let-values(((s_22) s14_0))" +"(let-values(((start_44) start15_0))" +"(let-values(((end_33) end16_0))" +"(let-values(((radix_3) radix17_0))" +"(let-values(((radix-set?_0) radix-set?10_0))" +"(let-values(((exactness_0) exactness18_0))" +"(let-values(((in-complex_0)(if in-complex13_0 in-complex11_0 #f)))" +"(let-values(((convert-mode_2) convert-mode19_0))" +"(let-values()" +"(if(= start_44 end_33)" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +" (let-values () (format \"no digits\"))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((c_70)(string-ref s_22 start_44)))" +"(if(char=? '#\\# c_70)" +"(let-values()" +"(let-values(((next_4)(add1 start_44)))" +"(if(= next_4 end_33)" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +" (let-values () (format \"no character after `#` indicator in `~.a`\" s_22))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((i_35)(string-ref s_22 next_4)))" +"(let-values(((tmp_39) i_35))" +"(let-values(((index_2)" +"(if(char? tmp_39)" +"(let-values(((codepoint_0)(char->integer tmp_39)))" +"(if(if(unsafe-fx>= codepoint_0 66)" +"(unsafe-fx< codepoint_0 121)" +" #f)" +"(let-values(((tbl_0)" +" '#(2" +" 0" +" 2" +" 1" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 2" +" 1" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 2)))" +"(unsafe-vector*-ref" +" tbl_0" +"(unsafe-fx- codepoint_0 66)))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_2 1)" +"(let-values()" +"(if(eq?(read-complains convert-mode_2) 'must-read)" +"(let-values()" +"(format" +" \"bad `#` indicator `~a` at `~.a`\"" +" i_35" +"(substring s_22 start_44 end_33)))" +"(let-values() #f)))" +"(if(unsafe-fx< index_2 2)" +"(let-values()" +"(if(let-values(((or-part_261)(exactness-set? exactness_0)))" +"(if or-part_261 or-part_261 in-complex_0))" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +"(let-values()" +"(format" +" \"misplaced exactness specification at `~.a`\"" +"(substring s_22 start_44 end_33)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((temp77_0)(add1 next_4))" +"((end78_0) end_33)" +"((radix79_0) radix_3)" +"((radix-set?80_0) radix-set?_0)" +"((temp81_1)" +"(if(let-values(((or-part_300)" +"(char=? i_35 '#\\e)))" +"(if or-part_300" +" or-part_300" +"(char=? i_35 '#\\E)))" +" 'exact" +" 'inexact))" +"((temp82_3)" +"(if(eq? convert-mode_2 'read)" +" 'must-read" +" convert-mode_2)))" +"(do-string->number20.1" +" #f" +" #f" +" radix-set?80_0" +" s_22" +" temp77_0" +" end78_0" +" radix79_0" +" temp81_1" +" temp82_3)))))" +"(let-values()" +"(if(let-values(((or-part_135) radix-set?_0))" +"(if or-part_135 or-part_135 in-complex_0))" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +"(let-values()" +"(format" +" \"misplaced radix specification at `~.a`\"" +"(substring s_22 start_44 end_33)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((radix_4)" +"(let-values(((tmp_40) i_35))" +"(if(if(equal? tmp_40 '#\\b)" +" #t" +"(equal? tmp_40 '#\\B))" +"(let-values() 2)" +"(if(if(equal? tmp_40 '#\\o)" +" #t" +"(equal? tmp_40 '#\\O))" +"(let-values() 8)" +"(if(if(equal? tmp_40 '#\\d)" +" #t" +"(equal? tmp_40 '#\\D))" +"(let-values() 10)" +"(let-values() 16)))))))" +"(let-values(((temp84_2)(add1 next_4))" +"((end85_0) end_33)" +"((radix86_0) radix_4)" +"((temp87_2) #t)" +"((exactness88_0) exactness_0)" +"((temp89_4)" +"(if(eq? convert-mode_2 'read)" +" 'must-read" +" convert-mode_2)))" +"(do-string->number20.1" +" #f" +" #f" +" temp87_2" +" s_22" +" temp84_2" +" end85_0" +" radix86_0" +" exactness88_0" +" temp89_4)))))))))))))))" +"(let-values(((c1_27)" +"(if(char-sign? c_70)" +"(read-special-number s_22 start_44 end_33 convert-mode_2)" +" #f)))" +"(if c1_27" +"((lambda(v_226)" +"(if(eq? exactness_0 'exact)" +"(let-values()" +"(if(eq? convert-mode_2 'must-read)" +" (let-values () (format \"no exact representation for `~a`\" v_226))" +"(let-values() #f)))" +"(let-values() v_226)))" +" c1_27)" +"(let-values(((c2_3)" +"(if(char-sign? c_70)" +"(if(not in-complex_0)" +"(if(>(- end_33 start_44) 7)" +"(if(char=? '#\\i(string-ref s_22(sub1 end_33)))" +"(if(char-sign?(string-ref s_22 6))" +"(read-special-number" +" s_22" +" start_44" +"(+ start_44 6)" +" convert-mode_2)" +" #f)" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if c2_3" +"((lambda(v_227)" +"(let-values(((temp91_0)(+ start_44 6))" +"((temp92_1)(sub1 end_33))" +"((radix93_0) radix_3)" +"((exactness94_0) exactness_0)" +"((convert-mode95_0) convert-mode_2)" +"((temp96_3) 'i)" +"((v97_0) v_227)" +"((temp98_3)" +"(lambda(v_228 v2_0)" +"(begin 'temp98(make-rectangular v_228 v2_0)))))" +"(read-for-special-compound65.1" +" temp96_3" +" #f" +" #f" +" s_22" +" temp91_0" +" temp92_1" +" radix93_0" +" exactness94_0" +" convert-mode95_0" +" v97_0" +" temp98_3)))" +" c2_3)" +"(let-values(((c3_2)" +"(if(not in-complex_0)" +"(if(>=(- end_33 start_44) 7)" +"(if(char=? '#\\i(string-ref s_22(sub1 end_33)))" +"(if(char-sign?(string-ref s_22(- end_33 7)))" +"(read-special-number" +" s_22" +"(- end_33 7)" +"(sub1 end_33)" +" convert-mode_2)" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if c3_2" +"((lambda(v2_1)" +"(if(if(= start_44(- end_33 7))(not(extflonum? v2_1)) #f)" +"(let-values()(make-rectangular 0 v2_1))" +"(let-values()" +"(let-values(((temp101_2)(- end_33 7))" +"((radix102_0) radix_3)" +"((exactness103_0) exactness_0)" +"((convert-mode104_0) convert-mode_2)" +"((temp105_2) 'i)" +"((temp106_2) #t)" +"((v2107_0) v2_1)" +"((temp108_2)" +"(lambda(v2_2 v_202)" +"(begin 'temp108(make-rectangular v_202 v2_2)))))" +"(read-for-special-compound65.1" +" temp105_2" +" temp106_2" +" #t" +" s_22" +" start_44" +" temp101_2" +" radix102_0" +" exactness103_0" +" convert-mode104_0" +" v2107_0" +" temp108_2)))))" +" c3_2)" +"(let-values(((c4_0)" +"(if(char-sign? c_70)" +"(if(not in-complex_0)" +"(if(>(- end_33 start_44) 7)" +"(if(char=? '#\\@(string-ref s_22(+ start_44 6)))" +"(read-special-number" +" s_22" +" start_44" +"(+ start_44 6)" +" convert-mode_2)" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if c4_0" +"((lambda(v_204)" +"(let-values(((temp110_4)(+ start_44 7))" +"((end111_0) end_33)" +"((radix112_0) radix_3)" +"((exactness113_0) exactness_0)" +"((convert-mode114_0) convert-mode_2)" +"((temp115_0) '@)" +"((v116_0) v_204)" +"((temp117_3)" +"(lambda(v_210 v2_3)" +"(begin 'temp117(make-polar v_210 v2_3)))))" +"(read-for-special-compound65.1" +" temp115_0" +" #f" +" #f" +" s_22" +" temp110_4" +" end111_0" +" radix112_0" +" exactness113_0" +" convert-mode114_0" +" v116_0" +" temp117_3)))" +" c4_0)" +"(let-values(((c5_1)" +"(if(not in-complex_0)" +"(if(>(- end_33 start_44) 7)" +"(if(char=? '#\\@(string-ref s_22(- end_33 7)))" +"(read-special-number" +" s_22" +"(- end_33 6)" +" end_33" +" convert-mode_2)" +" #f)" +" #f)" +" #f)))" +"(if c5_1" +"((lambda(v2_4)" +"(let-values(((temp120_1)(- end_33 7))" +"((radix121_0) radix_3)" +"((exactness122_0) exactness_0)" +"((convert-mode123_0) convert-mode_2)" +"((temp124_3) '@)" +"((temp125_2) #t)" +"((v2126_0) v2_4)" +"((temp127_3)" +"(lambda(v2_5 v_229)" +"(begin 'temp127(make-polar v_229 v2_5)))))" +"(read-for-special-compound65.1" +" temp124_3" +" temp125_2" +" #t" +" s_22" +" start_44" +" temp120_1" +" radix121_0" +" exactness122_0" +" convert-mode123_0" +" v2126_0" +" temp127_3)))" +" c5_1)" +"(let-values()" +"(let-values(((radix-set?132_0) radix-set?_0)" +"((exactness133_0) exactness_0)" +"((in-complex134_0) in-complex_0)" +"((convert-mode135_0) convert-mode_2))" +"(do-string->non-special-number33.1" +" in-complex134_0" +" #t" +" radix-set?132_0" +" s_22" +" start_44" +" end_33" +" radix_3" +" exactness133_0" +" convert-mode135_0)))))))))))))))))))))))))))))" +"(define-values" +"(do-string->non-special-number33.1)" +"(lambda(in-complex24_0" +" in-complex26_0" +" radix-set?23_0" +" s27_1" +" start28_0" +" end29_0" +" radix30_0" +" exactness31_0" +" convert-mode32_0)" +"(begin" +" 'do-string->non-special-number33" +"(let-values(((s_86) s27_1))" +"(let-values(((start_45) start28_0))" +"(let-values(((end_34) end29_0))" +"(let-values(((radix_5) radix30_0))" +"(let-values(((radix-set?_1) radix-set?23_0))" +"(let-values(((exactness_1) exactness31_0))" +"(let-values(((in-complex_1)(if in-complex26_0 in-complex24_0 #f)))" +"(let-values(((convert-mode_3) convert-mode32_0))" +"(let-values()" +"((letrec-values(((loop_106)" +"(lambda(i_172" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" must-i?_0)" +"(begin" +" 'loop" +"(if(= i_172 end_34)" +"(let-values()" +"(if(if(not any-digits?_0)(not i-pos_3) #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"no digits in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(if must-i?_0(not i-pos_3) #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many signs in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(if sign-pos_0" +"(let-values(((or-part_301)" +"(if dot-pos_1(< dot-pos_1 sign-pos_0) #f)))" +"(if or-part_301" +" or-part_301" +"(if slash-pos_0(< slash-pos_0 sign-pos_0) #f)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced sign in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if i-pos_3" +"(let-values()" +"(let-values(((temp140_0)(sub1 end_34))" +"((i-pos141_0) i-pos_3)" +"((sign-pos142_0) sign-pos_0)" +"((radix143_0) radix_5)" +"((radix-set?144_0) radix-set?_1)" +"((exactness145_0) exactness_1)" +"((temp146_0) 'i)" +"((convert-mode147_0) convert-mode_3))" +"(string->complex-number50.1" +" temp146_0" +" radix-set?144_0" +" s_86" +" start_45" +" sign-pos_0" +" sign-pos_0" +" temp140_0" +" i-pos141_0" +" sign-pos142_0" +" radix143_0" +" exactness145_0" +" convert-mode147_0)))" +"(if @-pos_0" +"(let-values()" +"(let-values(((temp151_1)(add1 @-pos_0))" +"((end152_0) end_34)" +"((i-pos153_0) i-pos_3)" +"((sign-pos154_0) sign-pos_0)" +"((radix155_0) radix_5)" +"((radix-set?156_0) radix-set?_1)" +"((exactness157_0) exactness_1)" +"((temp158_0) '@)" +"((convert-mode159_0) convert-mode_3))" +"(string->complex-number50.1" +" temp158_0" +" radix-set?156_0" +" s_86" +" start_45" +" @-pos_0" +" temp151_1" +" end152_0" +" i-pos153_0" +" sign-pos154_0" +" radix155_0" +" exactness157_0" +" convert-mode159_0)))" +"(let-values()" +"(string->real-number" +" s_86" +" start_45" +" end_34" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" any-hashes?_0" +" radix_5" +" exactness_1" +" convert-mode_3))))))))" +"(let-values()" +"(let-values(((c_71)(string-ref s_86 i_172)))" +"(if(digit? c_71 radix_5)" +"(let-values()" +"(loop_106" +"(add1 i_172)" +" #t" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" must-i?_0))" +"(if(char=? c_71 '#\\#)" +"(let-values()" +"(loop_106" +"(add1 i_172)" +" #t" +" #t" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +" exp-pos_0" +" must-i?_0))" +"(if(char-sign? c_71)" +"(let-values()" +"(if(if sign-pos_0 must-i?_0 #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many signs in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_106" +"(add1 i_172)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" i_172" +" dot-pos_1" +" slash-pos_0" +" #f" +"(if(> i_172 start_45)" +"(let-values(((or-part_302)(not @-pos_0)))" +"(if or-part_302" +" or-part_302" +"(> i_172(add1 @-pos_0))))" +" #f)))))" +"(if(char=? c_71 '#\\.)" +"(let-values()" +"(if(let-values(((or-part_303)" +"(if exp-pos_0" +"(let-values(((or-part_304)" +"(not sign-pos_0)))" +"(if or-part_304" +" or-part_304" +"(> exp-pos_0 sign-pos_0)))" +" #f)))" +"(if or-part_303" +" or-part_303" +"(if dot-pos_1" +"(let-values(((or-part_305)(not sign-pos_0)))" +"(if or-part_305" +" or-part_305" +"(> dot-pos_1 sign-pos_0)))" +" #f)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced `.` in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(if slash-pos_0" +"(let-values(((or-part_106)(not sign-pos_0)))" +"(if or-part_106" +" or-part_106" +"(> slash-pos_0 sign-pos_0)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"decimal points and fractions annot be mixed `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_106" +"(add1 i_172)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" i_172" +" #f" +" #f" +" must-i?_0)))))" +"(if(char=? c_71 '#\\/)" +"(let-values()" +"(if(if dot-pos_1" +"(let-values(((or-part_61)(not sign-pos_0)))" +"(if or-part_61" +" or-part_61" +"(> dot-pos_1 sign-pos_0)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"decimal points and fractions annot be mixed `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(let-values(((or-part_107)" +"(if exp-pos_0" +"(let-values(((or-part_62)" +"(not sign-pos_0)))" +"(if or-part_62" +" or-part_62" +"(> exp-pos_0 sign-pos_0)))" +" #f)))" +"(if or-part_107" +" or-part_107" +"(if slash-pos_0" +"(let-values(((or-part_63)" +"(not sign-pos_0)))" +"(if or-part_63" +" or-part_63" +"(> slash-pos_0 sign-pos_0)))" +" #f)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced `/` in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_106" +"(add1 i_172)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" #f" +" i_172" +" #f" +" must-i?_0)))))" +"(if(let-values(((or-part_306)(char=? c_71 '#\\e)))" +"(if or-part_306" +" or-part_306" +"(let-values(((or-part_307)(char=? c_71 '#\\E)))" +"(if or-part_307" +" or-part_307" +"(let-values(((or-part_308)" +"(char=? c_71 '#\\f)))" +"(if or-part_308" +" or-part_308" +"(let-values(((or-part_181)" +"(char=? c_71 '#\\F)))" +"(if or-part_181" +" or-part_181" +"(let-values(((or-part_309)" +"(char=? c_71 '#\\d)))" +"(if or-part_309" +" or-part_309" +"(let-values(((or-part_310)" +"(char=? c_71 '#\\D)))" +"(if or-part_310" +" or-part_310" +"(let-values(((or-part_311)" +"(char=?" +" c_71" +" '#\\s)))" +"(if or-part_311" +" or-part_311" +"(let-values(((or-part_312)" +"(char=?" +" c_71" +" '#\\S)))" +"(if or-part_312" +" or-part_312" +"(let-values(((or-part_313)" +"(char=?" +" c_71" +" '#\\l)))" +"(if or-part_313" +" or-part_313" +"(let-values(((or-part_314)" +"(char=?" +" c_71" +" '#\\L)))" +"(if or-part_314" +" or-part_314" +"(let-values(((or-part_315)" +"(char=?" +" c_71" +" '#\\t)))" +"(if or-part_315" +" or-part_315" +"(char=?" +" c_71" +" '#\\T)))))))))))))))))))))))" +"(let-values()" +"(if exp-pos_0" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"misplaced `~a` in `~.a`\"" +" c_71" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(if(<(add1 i_172) end_34)" +"(char-sign?(string-ref s_86(add1 i_172)))" +" #f)" +"(let-values()" +"(loop_106" +"(+ i_172 2)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +"(let-values(((or-part_316) exp-pos_0))" +"(if or-part_316 or-part_316 i_172))" +" must-i?_0))" +"(let-values()" +"(loop_106" +"(+ i_172 1)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" @-pos_0" +" sign-pos_0" +" dot-pos_1" +" slash-pos_0" +"(let-values(((or-part_317) exp-pos_0))" +"(if or-part_317 or-part_317 i_172))" +" must-i?_0)))))" +"(if(char=? c_71 '#\\@)" +"(let-values()" +"(if(eq? in-complex_1 'i)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"cannot mix `@` and `i` in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(let-values(((or-part_318) @-pos_0))" +"(if or-part_318" +" or-part_318" +"(eq? in-complex_1 '@)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many `@`s in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(= i_172 start_45)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"`@` cannot be at start in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if must-i?_0" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"too many signs in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_106" +"(add1 i_172)" +" any-digits?_0" +" any-hashes?_0" +" i-pos_3" +" i_172" +" #f" +" #f" +" #f" +" #f" +" must-i?_0)))))))" +"(if(if(let-values(((or-part_319)" +"(char=? c_71 '#\\i)))" +"(if or-part_319" +" or-part_319" +"(char=? c_71 '#\\I)))" +" sign-pos_0" +" #f)" +"(let-values()" +"(if(let-values(((or-part_320) @-pos_0))" +"(if or-part_320" +" or-part_320" +"(eq? in-complex_1 '@)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"cannot mix `@` and `i` in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(if(let-values(((or-part_321)" +"(<(add1 i_172) end_34)))" +"(if or-part_321" +" or-part_321" +"(eq? in-complex_1 'i)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +"(format" +" \"`i' must be at the end in `~.a`\"" +"(substring s_86 start_45 end_34)))" +"(let-values() #f)))" +"(let-values()" +"(loop_106" +"(add1 i_172)" +" any-digits?_0" +" any-hashes?_0" +" i_172" +" @-pos_0" +" sign-pos_0" +" #f" +" #f" +" #f" +" #f)))))" +"(let-values()" +"(if(char=? c_71 '#\\nul)" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +" (format \"nul character in `~.a`\" s_86))" +"(let-values() #f)))" +"(let-values()" +"(if(eq? convert-mode_3 'must-read)" +"(let-values()" +" (format \"bad digit `~a`\" c_71))" +"(let-values() #f))))))))))))))))))))" +" loop_106)" +" start_45" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f)))))))))))))" +"(define-values" +"(string->complex-number50.1)" +"(lambda(in-complex37_0" +" radix-set?36_0" +" s40_0" +" start141_0" +" end142_0" +" start243_0" +" end244_0" +" i-pos45_0" +" sign-pos46_0" +" radix47_0" +" exactness48_0" +" convert-mode49_0)" +"(begin" +" 'string->complex-number50" +"(let-values(((s_461) s40_0))" +"(let-values(((start1_0) start141_0))" +"(let-values(((end1_0) end142_0))" +"(let-values(((start2_0) start243_0))" +"(let-values(((end2_0) end244_0))" +"(let-values()" +"(let-values()" +"(let-values(((radix_6) radix47_0))" +"(let-values(((radix-set?_2) radix-set?36_0))" +"(let-values(((exactness_2) exactness48_0))" +"(let-values(((in-complex_2) in-complex37_0))" +"(let-values(((convert-mode_4) convert-mode49_0))" +"(let-values()" +"(let-values(((v1_0)" +"(if(= start1_0 end1_0)" +"(let-values()(if(eq? exactness_2 'inexact) 0.0 0))" +"(let-values()" +"(let-values(((radix-set?164_0) radix-set?_2)" +"((exactness165_0) exactness_2)" +"((in-complex166_0) in-complex_2)" +"((convert-mode167_0) convert-mode_4))" +"(do-string->number20.1" +" in-complex166_0" +" #t" +" radix-set?164_0" +" s_461" +" start1_0" +" end1_0" +" radix_6" +" exactness165_0" +" convert-mode167_0))))))" +"(let-values(((v2_6)" +"(if(if(eq? in-complex_2 'i)(=(- end2_0 start2_0) 1) #f)" +"(let-values()" +"(let-values(((neg?_0)(char=?(string-ref s_461 start2_0) '#\\-)))" +"(if(eq? exactness_2 'inexact)" +"(let-values()(if neg?_0 -1.0 1.0))" +"(let-values()(if neg?_0 -1 1)))))" +"(let-values()" +"(let-values(((radix-set?172_0) radix-set?_2)" +"((exactness173_0) exactness_2)" +"((in-complex174_0) in-complex_2)" +"((convert-mode175_0) convert-mode_4))" +"(do-string->number20.1" +" in-complex174_0" +" #t" +" radix-set?172_0" +" s_461" +" start2_0" +" end2_0" +" radix_6" +" exactness173_0" +" convert-mode175_0))))))" +"(if(let-values(((or-part_322)(not v1_0)))" +"(if or-part_322 or-part_322(not v2_6)))" +"(let-values() #f)" +"(if(if(let-values(((or-part_323)(extflonum? v1_0)))" +"(if or-part_323 or-part_323(extflonum? v2_6)))" +"(not(eq? convert-mode_4 'must-read))" +" #f)" +"(let-values()(fail-extflonum convert-mode_4 v1_0))" +"(if(string? v1_0)" +"(let-values() v1_0)" +"(if(extflonum? v1_0)" +"(let-values()(fail-extflonum convert-mode_4 v1_0))" +"(if(string? v2_6)" +"(let-values() v2_6)" +"(if(extflonum? v2_6)" +"(let-values()(fail-extflonum convert-mode_4 v2_6))" +"(if(eq? in-complex_2 'i)" +"(let-values()(make-rectangular v1_0 v2_6))" +"(let-values()" +"(let-values(((p_69)(make-polar v1_0 v2_6)))" +"(if(eq? exactness_2 'exact)" +"(inexact->exact p_69)" +" p_69))))))))))))))))))))))))))))" +"(define-values" +"(string->real-number)" +"(lambda(s_462 start_46 end_35 dot-pos_2 slash-pos_1 exp-pos_1 any-hashes?_1 radix_7 exactness_3 convert-mode_5)" +"(begin" +"(let-values(((extfl-mark?_0)" +"(lambda()(begin 'extfl-mark?(char=?(char-downcase(string-ref s_462 exp-pos_1)) '#\\t)))))" +"(let-values(((simple?_0)" +"(if(not slash-pos_1)" +"(if(let-values(((or-part_324)(eq? exactness_3 'inexact)))" +"(if or-part_324" +" or-part_324" +"(let-values(((or-part_325)(eq? exactness_3 'decimal-as-inexact)))" +"(if or-part_325 or-part_325(if(not dot-pos_2)(not exp-pos_1) #f)))))" +"(if(let-values(((or-part_326)(not exp-pos_1)))" +"(if or-part_326" +" or-part_326" +"(let-values(((or-part_229)(not(eq? convert-mode_5 'number-or-false))))" +"(if or-part_229 or-part_229(not(extfl-mark?_0))))))" +"(not(if any-hashes?_1(hashes? s_462 start_46 end_35) #f))" +" #f)" +" #f)" +" #f)))" +"(let-values(((has-sign?_0)(if(> end_35 start_46)(char-sign?(string-ref s_462 start_46)) #f)))" +"(if(=(- end_35 start_46)(+(if dot-pos_2 1 0)(if exp-pos_1 1 0)(if has-sign?_0 1 0)))" +"(let-values()" +"(if(= end_35 start_46)" +" (if (eq? convert-mode_5 'must-read) (let-values () (format \"missing digits\")) (let-values () #f))" +"(if(eq? convert-mode_5 'must-read)" +" (let-values () (format \"missing digits in `~.a`\" (substring s_462 start_46 end_35)))" +"(let-values() #f))))" +"(if simple?_0" +"(let-values()" +"(if(if exp-pos_1" +"(=" +"(- exp-pos_1 start_46)" +"(+(if(if dot-pos_2(< dot-pos_2 exp-pos_1) #f) 1 0)(if has-sign?_0 1 0)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +" (format \"missing digits before exponent marker in `~.a`\" (substring s_462 start_46 end_35)))" +"(let-values() #f)))" +"(if(if exp-pos_1" +"(let-values(((or-part_327)(= exp-pos_1(sub1 end_35))))" +"(if or-part_327" +" or-part_327" +"(if(= exp-pos_1(- end_35 2))(char-sign?(string-ref s_462(sub1 end_35))) #f)))" +" #f)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +" (format \"missing digits after exponent marker in `~.a`\" (substring s_462 start_46 end_35)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_30)" +"(string->number$1" +"(maybe-substring s_462 start_46 end_35)" +" radix_7" +"(if(let-values(((or-part_328)(eq? convert-mode_5 'number-or-false)))" +"(if or-part_328" +" or-part_328" +"(let-values(((or-part_230)(not exp-pos_1)))" +"(if or-part_230 or-part_230(not(extfl-mark?_0))))))" +" 'number-or-false" +" 'read))))" +"(if(let-values(((or-part_329)(not n_30)))(if or-part_329 or-part_329(string? n_30)))" +"(let-values()" +"(error" +" 'string->number" +" \"host `string->number` failed on ~s\"" +"(substring s_462 start_46 end_35)))" +"(if(eq? exactness_3 'inexact)" +"(let-values()" +"(if(extflonum? n_30)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +"(format" +" \"cannot convert extflonum `~.a` to inexact\"" +"(substring s_462 start_46 end_35)))" +"(let-values() #f)))" +"(if(if(eqv? n_30 0)(char=?(string-ref s_462 start_46) '#\\-) #f)" +"(let-values() -0.0)" +"(let-values()(exact->inexact n_30)))))" +"(let-values() n_30))))))))" +"(if exp-pos_1" +"(let-values()" +"(let-values(((m-v_0)" +"(string->real-number" +" s_462" +" start_46" +" exp-pos_1" +" dot-pos_2" +" slash-pos_1" +" #f" +" any-hashes?_1" +" radix_7" +" 'exact" +" convert-mode_5)))" +"(let-values(((e-v_0)" +"(string->exact-integer-number s_462(+ exp-pos_1 1) end_35 radix_7 convert-mode_5)))" +"(let-values(((real->precision-inexact_0)" +"(lambda(r_47)" +"(begin" +" 'real->precision-inexact" +"(let-values(((tmp_41)(string-ref s_462 exp-pos_1)))" +"(if(if(equal? tmp_41 '#\\s)" +" #t" +"(if(equal? tmp_41 '#\\S)" +" #t" +"(if(equal? tmp_41 '#\\f) #t(equal? tmp_41 '#\\F))))" +"(let-values()(real->single-flonum r_47))" +"(if(if(equal? tmp_41 '#\\t) #t(equal? tmp_41 '#\\T))" +"(let-values()" +"(if(extflonum-available?)" +"(real->extfl r_47)" +"(string->number$1" +"(replace-hashes s_462 start_46 end_35)" +" radix_7" +" 'read)))" +"(let-values()(real->double-flonum r_47)))))))))" +"(let-values(((get-extfl?_0)(extfl-mark?_0)))" +"(if(let-values(((or-part_330)(not m-v_0)))(if or-part_330 or-part_330(not e-v_0)))" +"(let-values() #f)" +"(if(string? m-v_0)" +"(let-values() m-v_0)" +"(if(string? e-v_0)" +"(let-values() e-v_0)" +"(if(if(eq? convert-mode_5 'number-or-false) get-extfl?_0 #f)" +"(let-values() #f)" +"(if(if(let-values(((or-part_331)(eq? exactness_3 'inexact)))" +"(if or-part_331 or-part_331(eq? exactness_3 'decimal-as-inexact)))" +"(>(abs e-v_0)(if get-extfl?_0 6000 400))" +" #f)" +"(let-values()" +"(real->precision-inexact_0" +"(if(eqv? m-v_0 0)" +"(let-values()(if(char=?(string-ref s_462 start_46) '#\\-) -0.0 0.0))" +"(if(positive? m-v_0)" +"(let-values()(if(positive? e-v_0) +inf.0 0.0))" +"(let-values()(if(positive? e-v_0) -inf.0 -0.0))))))" +"(if(if(exactness-set? exactness_3) get-extfl?_0 #f)" +"(let-values()" +"(if(eq? convert-mode_5 'must-read)" +"(let-values()" +"(format" +" \"cannot convert extflonum `~.a` to ~a\"" +"(substring s_462 start_46 end_35)" +" exactness_3))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_31)(* m-v_0(expt radix_7 e-v_0))))" +"(if(if(not get-extfl?_0)" +"(let-values(((or-part_332)(eq? exactness_3 'exact)))" +"(if or-part_332 or-part_332(eq? exactness_3 'decimal-as-exact)))" +" #f)" +"(let-values() n_31)" +"(if(if(eqv? n_31 0)(char=?(string-ref s_462 start_46) '#\\-) #f)" +"(let-values()(real->precision-inexact_0 -0.0))" +"(let-values()(real->precision-inexact_0 n_31)))))))))))))))))" +"(if slash-pos_1" +"(let-values()" +"(let-values(((n-v_0)" +"(string->real-number" +" s_462" +" start_46" +" slash-pos_1" +" #f" +" #f" +" #f" +" any-hashes?_1" +" radix_7" +" 'exact" +" convert-mode_5)))" +"(let-values(((d-v_0)" +"(string->real-number" +" s_462" +"(add1 slash-pos_1)" +" end_35" +" #f" +" #f" +" #f" +" any-hashes?_1" +" radix_7" +" 'exact" +" convert-mode_5)))" +"(let-values(((get-inexact?_0)" +"(lambda(from-pos_0)" +"(begin" +" 'get-inexact?" +"(let-values(((or-part_333)(eq? exactness_3 'inexact)))" +"(if or-part_333" +" or-part_333" +"(if(not(eq? exactness_3 'exact))" +"(hashes? s_462 from-pos_0 end_35)" +" #f)))))))" +"(if(let-values(((or-part_334)(not n-v_0)))(if or-part_334 or-part_334(not d-v_0)))" +"(let-values() #f)" +"(if(string? n-v_0)" +"(let-values() n-v_0)" +"(if(string? d-v_0)" +"(let-values() d-v_0)" +"(if(eqv? d-v_0 0)" +"(let-values()" +"(if(get-inexact?_0(add1 slash-pos_1))" +"(let-values()(if(negative? n-v_0) -inf.0 +inf.0))" +"(let-values()" +"(if(eq?(read-complains convert-mode_5) 'must-read)" +"(let-values()" +" (format \"division by zero in `~.a`\" (substring s_462 start_46 end_35)))" +"(let-values() #f)))))" +"(let-values()" +"(let-values(((n_32)(/ n-v_0 d-v_0)))" +"(if(get-inexact?_0 start_46)(exact->inexact n_32) n_32)))))))))))" +"(let-values()" +"(string->decimal-number" +" s_462" +" start_46" +" end_35" +" dot-pos_2" +" radix_7" +" exactness_3" +" convert-mode_5))))))))))))" +"(define-values" +"(string->decimal-number)" +"(lambda(s_445 start_47 end_36 dot-pos_3 radix_8 exactness_4 convert-mode_6)" +"(begin" +"(let-values(((get-exact?_0)" +"(let-values(((or-part_335)(eq? exactness_4 'exact)))" +"(if or-part_335 or-part_335(eq? exactness_4 'decimal-as-exact)))))" +"(let-values(((new-str_0)(make-string(- end_36 start_47(if(if dot-pos_3 get-exact?_0 #f) 1 0)))))" +"((letrec-values(((loop_107)" +"(lambda(i_173 j_3 hashes-pos_0)" +"(begin" +" 'loop" +"(if(< i_173 start_47)" +"(let-values()" +"(if(= hashes-pos_0 start_47)" +"(let-values()" +"(if(eq? convert-mode_6 'must-read)" +"(let-values()" +" (format \"misplaced `#` in `~.a`\" (substring s_445 start_47 end_36)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_33)(string->number$1 new-str_0 radix_8)))" +"(if(not n_33)" +"(let-values()(fail-bad-number convert-mode_6 s_445 start_47 end_36))" +"(if(not get-exact?_0)" +"(let-values()" +"(if(if(eqv? n_33 0)(char=?(string-ref s_445 start_47) '#\\-) #f)" +" -0.0" +"(exact->inexact n_33)))" +"(if(if dot-pos_3 get-exact?_0 #f)" +"(let-values()(/ n_33(expt 10(- end_36 dot-pos_3 1))))" +"(let-values() n_33))))))))" +"(let-values()" +"(let-values(((c_72)(string-ref s_445 i_173)))" +"(if(char=? c_72 '#\\.)" +"(let-values()" +"(if get-exact?_0" +"(let-values()" +"(loop_107" +"(sub1 i_173)" +" j_3" +"(if(= hashes-pos_0(add1 i_173)) i_173 hashes-pos_0)))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 c_72)" +"(loop_107" +"(sub1 i_173)" +"(sub1 j_3)" +"(if(= hashes-pos_0(add1 i_173)) i_173 hashes-pos_0))))))" +"(if(let-values(((or-part_336)(char=? c_72 '#\\-)))" +"(if or-part_336 or-part_336(char=? c_72 '#\\+)))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 c_72)" +"(loop_107" +"(sub1 i_173)" +"(sub1 j_3)" +"(if(= hashes-pos_0(add1 i_173)) i_173 hashes-pos_0))))" +"(if(char=? c_72 '#\\#)" +"(let-values()" +"(if(= hashes-pos_0(add1 i_173))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 '#\\0)" +"(loop_107(sub1 i_173)(sub1 j_3) i_173)))" +"(let-values()" +"(if(eq? convert-mode_6 'must-read)" +"(let-values()" +"(format" +" \"misplaced `#` in `~.a`\"" +"(substring s_445 start_47 end_36)))" +"(let-values() #f)))))" +"(let-values()" +"(begin" +"(string-set! new-str_0 j_3 c_72)" +"(loop_107(sub1 i_173)(sub1 j_3) hashes-pos_0)))))))))))))" +" loop_107)" +"(sub1 end_36)" +"(sub1(string-length new-str_0))" +" end_36))))))" +"(define-values" +"(string->exact-integer-number)" +"(lambda(s_352 start_48 end_37 radix_9 convert-mode_7)" +"(begin" +"(if(hashes? s_352 start_48 end_37)" +"(let-values()" +"(if(eq? convert-mode_7 'must-read)" +" (let-values () (format \"misplaced `#` in `~.a`\" (substring s_352 start_48 end_37)))" +"(let-values() #f)))" +"(let-values()" +"(let-values(((n_34)(string->number$1(maybe-substring s_352 start_48 end_37) radix_9)))" +"(if(not n_34)" +"(let-values()" +"(if(eq? convert-mode_7 'must-read)" +" (let-values () (format \"bad exponent `~.a`\" (substring s_352 start_48 end_37)))" +"(let-values() #f)))" +"(let-values() n_34))))))))" +"(define-values" +"(read-special-number)" +"(lambda(s_447 start_49 end_38 convert-mode_8)" +"(begin" +"(if(=(- end_38 start_49) 6)" +"(if(let-values(((or-part_337)(char=?(string-ref s_447 start_49) '#\\+)))" +"(if or-part_337 or-part_337(char=?(string-ref s_447 start_49) '#\\-)))" +"(let-values(((or-part_224)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 1))) '#\\i)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 2))) '#\\n)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 3))) '#\\f)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 4))) '#\\.)" +"(let-values(((or-part_338)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 5))) '#\\0)" +"(if(char=?(string-ref s_447 start_49) '#\\+) +inf.0 -inf.0)" +" #f)))" +"(if or-part_338" +" or-part_338" +"(let-values(((or-part_339)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 5))) '#\\f)" +"(if(char=?(string-ref s_447 start_49) '#\\+) +inf.f -inf.f)" +" #f)))" +"(if or-part_339" +" or-part_339" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 5))) '#\\t)" +"(if(not(eq? convert-mode_8 'number-or-false))" +"(if(char=?(string-ref s_447 start_49) '#\\+) '+inf.t '-inf.t)" +" #f)" +" #f)))))" +" #f)" +" #f)" +" #f)" +" #f)))" +"(if or-part_224" +" or-part_224" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 1))) '#\\n)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 2))) '#\\a)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 3))) '#\\n)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 4))) '#\\.)" +"(let-values(((or-part_340)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 5))) '#\\0) +nan.0 #f)))" +"(if or-part_340" +" or-part_340" +"(let-values(((or-part_341)" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 5))) '#\\f) +nan.f #f)))" +"(if or-part_341" +" or-part_341" +"(if(char=?(char-downcase(string-ref s_447(+ start_49 5))) '#\\t)" +"(if(not(eq? convert-mode_8 'number-or-false)) '+nan.t #f)" +" #f)))))" +" #f)" +" #f)" +" #f)" +" #f)))" +" #f)" +" #f))))" +"(define-values" +"(fail-extflonum)" +"(lambda(convert-mode_9 v_230)" +"(begin" +"(if(eq? convert-mode_9 'must-read)" +" (let-values () (format \"cannot combine extflonum `~a` into complex number\" v_230))" +"(let-values() #f)))))" +"(define-values" +"(read-for-special-compound65.1)" +"(lambda(in-complex53_0" +" reading-first?54_0" +" reading-first?56_0" +" s57_0" +" start58_0" +" end59_0" +" radix60_0" +" exactness61_0" +" convert-mode62_0" +" v63_0" +" combine64_0)" +"(begin" +" 'read-for-special-compound65" +"(let-values(((s_463) s57_0))" +"(let-values(((start_50) start58_0))" +"(let-values(((end_39) end59_0))" +"(let-values(((radix_10) radix60_0))" +"(let-values(((exactness_5) exactness61_0))" +"(let-values(((convert-mode_10) convert-mode62_0))" +"(let-values(((in-complex_3) in-complex53_0))" +"(let-values(((reading-first?_0)(if reading-first?56_0 reading-first?54_0 #f)))" +"(let-values(((v_231) v63_0))" +"(let-values(((combine_1) combine64_0))" +"(let-values()" +"(if(eq? exactness_5 'exact)" +"(let-values()" +"(if(eq? convert-mode_10 'must-read)" +" (let-values () (format \"no exact representation for `~a`\" v_231))" +"(let-values() #f)))" +"(if(if(extflonum? v_231)" +"(let-values(((or-part_342)(not reading-first?_0)))" +"(if or-part_342 or-part_342(not(eq? convert-mode_10 'must-read))))" +" #f)" +"(let-values()(fail-extflonum convert-mode_10 v_231))" +"(let-values()" +"(let-values(((v2_7)" +"(let-values(((temp180_0) #t)" +"((exactness181_0) exactness_5)" +"((in-complex182_0) in-complex_3)" +"((convert-mode183_0) convert-mode_10))" +"(do-string->number20.1" +" in-complex182_0" +" #t" +" temp180_0" +" s_463" +" start_50" +" end_39" +" radix_10" +" exactness181_0" +" convert-mode183_0))))" +"(if(string? v2_7)" +"(let-values() v2_7)" +"(if(not v2_7)" +"(let-values() v2_7)" +"(if(extflonum? v_231)" +"(let-values()(fail-extflonum convert-mode_10 v_231))" +"(let-values()(combine_1 v_231 v2_7)))))))))))))))))))))))" +"(define-values" +"(hashes?)" +"(lambda(s_464 start_51 end_40)" +"(begin" +"(let-values(((v*_6 start*_5 stop*_6 step*_5)" +"(normalise-inputs" +" 'in-string" +" \"string\"" +"(lambda(x_81)(string? x_81))" +"(lambda(x_82)(unsafe-string-length x_82))" +" s_464" +" start_51" +" end_40" +" 1)))" +"(begin" +" #t" +"((letrec-values(((for-loop_261)" +"(lambda(result_113 idx_5)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< idx_5 stop*_6)" +"(let-values(((c_73)(string-ref v*_6 idx_5)))" +"(let-values(((result_114)" +"(let-values()" +"(let-values(((result_115)" +"(let-values()(let-values()(char=? c_73 '#\\#)))))" +"(values result_115)))))" +"(if(if(not((lambda x_83 result_114) c_73))(not #f) #f)" +"(for-loop_261 result_114(unsafe-fx+ idx_5 1))" +" result_114)))" +" result_113)))))" +" for-loop_261)" +" #f" +" start*_5))))))" +"(define-values" +"(replace-hashes)" +"(lambda(s_264 start_52 end_41)" +"(begin" +"(let-values(((new-s_7)(make-string(- end_41 start_52))))" +"(begin" +"(let-values(((v*_7 start*_6 stop*_7 step*_6)" +"(normalise-inputs" +" 'in-string" +" \"string\"" +"(lambda(x_84)(string? x_84))" +"(lambda(x_85)(unsafe-string-length x_85))" +" s_264" +" start_52" +" end_41" +" 1))" +"((start_53) 0))" +"(begin" +" #t" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_53)))" +"((letrec-values(((for-loop_262)" +"(lambda(idx_6 pos_111)" +"(begin" +" 'for-loop" +"(if(if(unsafe-fx< idx_6 stop*_7) #t #f)" +"(let-values(((c_74)(string-ref v*_7 idx_6))((i_174) pos_111))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(char=? c_74 '#\\#)" +"(string-set! new-s_7 i_174 '#\\0)" +"(string-set! new-s_7 i_174 c_74)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_262(unsafe-fx+ idx_6 1)(+ pos_111 1))(values))))" +"(values))))))" +" for-loop_262)" +" start*_6" +" start_53)))" +"(void)" +" new-s_7)))))" +"(define-values" +"(maybe-substring)" +"(lambda(s_465 start_54 end_42)" +"(begin(if(if(= 0 start_54)(= end_42(string-length s_465)) #f) s_465(substring s_465 start_54 end_42)))))" +"(define-values" +"(exactness-set?)" +"(lambda(exactness_6)" +"(begin" +"(let-values(((or-part_343)(eq? exactness_6 'exact)))(if or-part_343 or-part_343(eq? exactness_6 'inexact))))))" +"(define-values" +"(char-sign?)" +"(lambda(c_75)" +"(begin(let-values(((or-part_344)(char=? c_75 '#\\-)))(if or-part_344 or-part_344(char=? c_75 '#\\+))))))" +"(define-values" +"(digit?)" +"(lambda(c_76 radix_11)" +"(begin" +"(let-values(((v_232)(char->integer c_76)))" +"(let-values(((or-part_345)" +"(if(>= v_232(char->integer '#\\0))(<(- v_232(char->integer '#\\0)) radix_11) #f)))" +"(if or-part_345" +" or-part_345" +"(if(> radix_11 10)" +"(let-values(((or-part_346)" +"(if(>= v_232(char->integer '#\\a))(<(- v_232(-(char->integer '#\\a) 10)) radix_11) #f)))" +"(if or-part_346" +" or-part_346" +"(if(>= v_232(char->integer '#\\A))(<(- v_232(-(char->integer '#\\A) 10)) radix_11) #f)))" +" #f)))))))" +"(define-values" +"(fail-bad-number)" +"(lambda(convert-mode_11 s_454 start_55 end_43)" +"(begin" +"(if(eq? convert-mode_11 'must-read)" +" (let-values () (format \"bad number `~.a`\" (substring s_454 start_55 end_43)))" +"(let-values() #f)))))" +"(define-values" +"(read-complains)" +"(lambda(convert-mode_12)(begin(if(eq? convert-mode_12 'read) 'must-read convert-mode_12))))" +"(define-values" +"(read-symbol-or-number8.1)" +"(lambda(extra-prefix2_0 extra-prefix4_0 mode1_0 mode3_0 init-c5_0 in6_0 config7_0)" +"(begin" +" 'read-symbol-or-number8" +"(let-values(((init-c_2) init-c5_0))" +"(let-values(((in_24) in6_0))" +"(let-values(((config_24) config7_0))" +"(let-values(((mode_17)(if mode3_0 mode1_0 'symbol-or-number)))" +"(let-values(((extra-prefix_0)(if extra-prefix4_0 extra-prefix2_0 #f)))" +"(let-values()" +"(let-values(((rt_11)(read-config-readtable config_24)))" +"(let-values(((c1_28)" +"(if rt_11" +"(if(let-values(((or-part_3)(eq? mode_17 'symbol-or-number)))" +"(if or-part_3 or-part_3(eq? mode_17 'symbol/indirect)))" +"(readtable-symbol-parser rt_11)" +" #f)" +" #f)))" +"(if c1_28" +"((lambda(handler_2)" +"(readtable-apply" +" handler_2" +" init-c_2" +" in_24" +" config_24" +"(read-config-line config_24)" +"(read-config-col config_24)" +"(read-config-pos config_24)))" +" c1_28)" +"(let-values()" +"(let-values(((accum-str_1)(accum-string-init! config_24)))" +"(let-values(((quoted-ever?_0) #f))" +"(let-values(((case-sens?_0)(check-parameter read-case-sensitive config_24)))" +"(let-values((()" +"(begin" +"(if extra-prefix_0" +"(let-values()(accum-string-add! accum-str_1 extra-prefix_0))" +"(void))" +"(values))))" +"(let-values(((source_17)(read-config-source config_24)))" +"(let-values(((unexpected-quoted_0)" +"(lambda(c_77 after-c_0)" +"(begin" +" 'unexpected-quoted" +"(let-values(((c13_1) c_77)" +" ((temp14_6) \"~a following `~a` in ~a\")" +"((temp15_5)" +"(if(eof-object? c_77)" +" \"end-of-file\"" +" \"non-character\"))" +"((after-c16_0) after-c_0)" +"((temp17_2)" +"(if(eq? mode_17 'keyword)" +" (let-values () \"keyword\")" +"(if(string? mode_17)" +" (let-values () \"number\")" +" (let-values () \"symbol\")))))" +"(reader-error10.1" +" #f" +" #f" +" c13_1" +" #t" +" #f" +" #f" +" in_24" +" config_24" +" temp14_6" +"(list temp15_5 after-c16_0 temp17_2)))))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_108)" +"(lambda(init-c_6" +" pipe-quote-c_0" +" foldcase-from_0)" +"(begin" +" 'loop" +"(let-values(((c_78)" +"(let-values(((or-part_70)" +" init-c_6))" +"(if or-part_70" +" or-part_70" +"(let-values(((in_22)" +" in_24)" +"((skip-count_6)" +" 0)" +"((source_15)" +" source_17))" +"(peek-char-or-special" +" in_22" +" skip-count_6" +" special1.1" +" source_15))))))" +"(let-values(((ec_4)" +"(let-values(((rt_12) rt_11)" +"((c_79) c_78))" +"(if(let-values(((or-part_165)" +"(not" +" rt_12)))" +"(if or-part_165" +" or-part_165" +"(not" +"(char? c_79))))" +"(let-values() c_79)" +"(let-values()" +"(*readtable-effective-char" +" rt_12" +" c_79))))))" +"(if(if pipe-quote-c_0" +"(not(char? ec_4))" +" #f)" +"(let-values()" +"(begin" +"(if init-c_6" +"(void)" +"(let-values()" +"(consume-char/special" +" in_24" +" config_24" +" c_78)))" +"(unexpected-quoted_0" +" c_78" +" pipe-quote-c_0)))" +"(if(if(not pipe-quote-c_0)" +"(readtable-char-delimiter?" +" rt_11" +" c_78" +" config_24)" +" #f)" +"(let-values()" +"(if case-sens?_0" +"(void)" +"(let-values()" +"(accum-string-convert!" +" accum-str_1" +" string-foldcase" +" foldcase-from_0))))" +"(if(if pipe-quote-c_0" +"(char=? c_78 pipe-quote-c_0)" +" #f)" +"(let-values()" +"(begin" +"(if init-c_6" +"(void)" +"(let-values()" +"(consume-char" +" in_24" +" c_78)))" +"(loop_108" +" #f" +" #f" +"(accum-string-count" +" accum-str_1))))" +"(if(if(char=? ec_4 '#\\|)" +"(check-parameter" +" read-accept-bar-quote" +" config_24)" +" #f)" +"(let-values()" +"(begin" +"(if init-c_6" +"(void)" +"(let-values()" +"(consume-char" +" in_24" +" c_78)))" +"(set! quoted-ever?_0 #t)" +"(if case-sens?_0" +"(void)" +"(let-values()" +"(accum-string-convert!" +" accum-str_1" +" string-foldcase" +" foldcase-from_0)))" +"(loop_108" +" #f" +" c_78" +"(accum-string-count" +" accum-str_1))))" +"(if(if(char=? ec_4 '#\\\\)" +"(not pipe-quote-c_0)" +" #f)" +"(let-values()" +"(let-values((()" +"(begin" +"(if init-c_6" +"(void)" +"(let-values()" +"(consume-char" +" in_24" +" c_78)))" +"(values))))" +"(let-values(((next-c_0)" +"(let-values(((in_23)" +" in_24)" +"((source_18)" +" source_17))" +"(read-char-or-special" +" in_23" +" special1.1" +" source_18))))" +"(begin" +"(if(char? next-c_0)" +"(void)" +"(let-values()" +"(unexpected-quoted_0" +" next-c_0" +" c_78)))" +"(if(let-values(((or-part_31)" +" pipe-quote-c_0))" +"(if or-part_31" +" or-part_31" +" case-sens?_0))" +"(void)" +"(let-values()" +"(accum-string-convert!" +" accum-str_1" +" string-foldcase" +" foldcase-from_0)))" +"(accum-string-add!" +" accum-str_1" +" next-c_0)" +"(set! quoted-ever?_0" +" #t)" +"(loop_108" +" #f" +" #f" +"(accum-string-count" +" accum-str_1))))))" +"(let-values()" +"(begin" +"(if init-c_6" +"(void)" +"(let-values()" +"(consume-char" +" in_24" +" c_78)))" +"(accum-string-add!" +" accum-str_1" +" c_78)" +"(loop_108" +" #f" +" pipe-quote-c_0" +" foldcase-from_0))))))))))))))" +" loop_108)" +" init-c_2" +" #f" +" 0)" +"(values))))" +"(let-values(((str_29)" +"(let-values(((accum-str18_0) accum-str_1)" +"((config19_0) config_24))" +"(accum-string-get!6.1 #f #f accum-str18_0 config19_0))))" +"(let-values((()" +"(begin" +"(if(if(= 1(string-length str_29))" +"(if(not quoted-ever?_0)" +"(char=?" +" '#\\." +"(effective-char(string-ref str_29 0) config_24))" +" #f)" +" #f)" +"(let-values()" +"(let-values(((in20_1) in_24)" +"((config21_0) config_24)" +" ((temp22_5) \"illegal use of `.`\"))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in20_1" +" config21_0" +" temp22_5" +"(list))))" +"(void))" +"(values))))" +"(let-values(((num_0)" +"(if(let-values(((or-part_9)" +"(eq? mode_17 'symbol-or-number)))" +"(if or-part_9 or-part_9(string? mode_17)))" +"(if(not quoted-ever?_0)" +"(1/string->number" +"(if(string? mode_17)" +"(string-append mode_17 str_29)" +" str_29)" +" 10" +" 'read" +"(if(check-parameter 1/read-decimal-as-inexact config_24)" +" 'decimal-as-inexact" +" 'decimal-as-exact))" +" #f)" +" #f)))" +"(begin" +"(if(string? num_0)" +"(let-values()" +"(let-values(((in23_0) in_24)" +"((config24_0) config_24)" +" ((temp25_6) \"~a\")" +"((num26_0) num_0))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in23_0" +" config24_0" +" temp25_6" +"(list num26_0))))" +"(void))" +"(if(if(not num_0)(string? mode_17) #f)" +"(let-values()" +"(let-values(((in27_0) in_24)" +"((config28_0) config_24)" +" ((temp29_2) \"bad number: `~a`\")" +"((temp30_4)(string-append mode_17 str_29)))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in27_0" +" config28_0" +" temp29_2" +"(list temp30_4))))" +"(void))" +"(wrap" +"(let-values(((or-part_33) num_0))" +"(if or-part_33" +" or-part_33" +"(let-values(((or-part_297)" +"(if(eq? mode_17 'keyword)" +"(string->keyword str_29)" +" #f)))" +"(if or-part_297 or-part_297(string->symbol str_29)))))" +" in_24" +" config_24" +" str_29)))))))))))))))))))))))))" +"(define-values" +"(read-fixnum)" +"(lambda(read-one_3 init-c_0 in_5 config_15)" +"(begin" +"(let-values(((c_33)(read-char/skip-whitespace-and-comments init-c_0 read-one_3 in_5 config_15)))" +"(let-values(((line_8 col_7 pos_112)(port-next-location* in_5 c_33)))" +" (let-values (((v_93) (read-number-literal c_33 in_5 config_15 \"#e\")))" +"(if(fixnum? v_93)" +"(let-values() v_93)" +"(if(eof-object? v_93)" +"(let-values() v_93)" +"(let-values()" +"(let-values(((in1_0) in_5)" +"((temp2_5)(reading-at config_15 line_8 col_7 pos_112))" +" ((temp3_6) \"expected a fixnum, found ~a\")" +"((v4_1) v_93))" +"(reader-error10.1 #f #f #f #f #f #f in1_0 temp2_5 temp3_6(list v4_1))))))))))))" +"(define-values" +"(read-flonum)" +"(lambda(read-one_4 init-c_7 in_25 config_37)" +"(begin" +"(let-values(((c_14)(read-char/skip-whitespace-and-comments init-c_7 read-one_4 in_25 config_37)))" +"(let-values(((line_9 col_8 pos_92)(port-next-location* in_25 c_14)))" +" (let-values (((v_29) (read-number-literal c_14 in_25 config_37 \"#i\")))" +"(if(flonum? v_29)" +"(let-values() v_29)" +"(if(eof-object? v_29)" +"(let-values() v_29)" +"(let-values()" +"(let-values(((in5_0) in_25)" +"((temp6_2)(reading-at config_37 line_9 col_8 pos_92))" +" ((temp7_3) \"expected a flonum, found ~a\")" +"((v8_0) v_29))" +"(reader-error10.1 #f #f #f #f #f #f in5_0 temp6_2 temp7_3(list v8_0))))))))))))" +"(define-values" +"(read-number-literal)" +"(lambda(c_80 in_26 config_38 mode_18)" +"(begin" +"(if(not(char? c_80))" +"(let-values() c_80)" +"(let-values()" +"(let-values(((mode12_0) mode_18))(read-symbol-or-number8.1 #f #f mode12_0 #t c_80 in_26 config_38)))))))" +"(define-values" +"(read-vector11.1)" +"(lambda(length2_0 length4_0 mode1_0 mode3_0 read-one5_0 opener-c6_0 opener7_0 closer8_0 in9_1 config10_0)" +"(begin" +" 'read-vector11" +"(let-values(((read-one_5) read-one5_0))" +"(let-values(((opener-c_1) opener-c6_0))" +"(let-values(((opener_2) opener7_0))" +"(let-values(((closer_2) closer8_0))" +"(let-values(((in_27) in9_1))" +"(let-values(((config_39) config10_0))" +"(let-values(((vector-mode_0)(if mode3_0 mode1_0 'any)))" +"(let-values(((expected-len_0)(if length4_0 length2_0 #f)))" +"(let-values()" +"(let-values(((read-one-element_0)" +"(let-values(((tmp_31) vector-mode_0))" +"(if(equal? tmp_31 'any)" +"(let-values() read-one_5)" +"(if(equal? tmp_31 'fixnum)" +"(let-values()" +"(lambda(init-c_8 in_28 config_40)" +"(begin" +" 'read-one-element" +"(read-fixnum read-one_5 init-c_8 in_28 config_40))))" +"(if(equal? tmp_31 'flonum)" +"(let-values()" +"(lambda(init-c_9 in_29 config_41)" +"(begin" +" 'read-one-element" +"(read-flonum read-one_5 init-c_9 in_29 config_41))))" +"(let-values()(void))))))))" +"(let-values(((seq_2)" +"(let-values(((read-one20_0) read-one_5)((temp21_1) #f))" +"(read-unwrapped-sequence17.1" +" temp21_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" read-one20_0" +" #t" +" read-one-element_0" +" opener-c_1" +" opener_2" +" closer_2" +" in_27" +" config_39))))" +"(let-values(((vec_64)" +"(if(not expected-len_0)" +"(let-values()" +"(let-values(((tmp_42) vector-mode_0))" +"(if(equal? tmp_42 'any)" +"(let-values()(list->vector seq_2))" +"(if(equal? tmp_42 'fixnum)" +"(let-values()" +"(let-values(((len_37)(length seq_2)))" +"(begin" +"(if(exact-nonnegative-integer? len_37)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/fxvector" +" \"exact-nonnegative-integer?\"" +" len_37)))" +"(let-values(((fill_0) 0))" +"(let-values(((v_83)(make-fxvector len_37 fill_0)))" +"(begin" +"(if(zero? len_37)" +"(void)" +"(let-values()" +"(let-values(((lst_263) seq_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_263)))" +"((letrec-values(((for-loop_97)" +"(lambda(i_1 lst_302)" +"(begin" +" 'for-loop" +"(if(pair? lst_302)" +"(let-values(((e_75)" +"(unsafe-car" +" lst_302))" +"((rest_170)" +"(unsafe-cdr" +" lst_302)))" +"(let-values(((i_175)" +"(let-values(((i_3)" +" i_1))" +"(let-values(((i_36)" +"(let-values()" +"(begin" +"(let-values(((elem_0)" +"(let-values()" +" e_75)))" +"(if(fixnum?" +" elem_0)" +"(unsafe-fxvector-set!" +" v_83" +" i_3" +" elem_0)" +"(not-an-fX.1" +" 'for*/vector" +" elem_0)))" +"(unsafe-fx+" +" 1" +" i_3)))))" +"(values" +" i_36)))))" +"(if(if(not" +"((lambda x_86" +"(unsafe-fx=" +" i_175" +" len_37))" +" e_75))" +"(not #f)" +" #f)" +"(for-loop_97" +" i_175" +" rest_170)" +" i_175)))" +" i_1)))))" +" for-loop_97)" +" 0" +" lst_263)))))" +" v_83))))))" +"(if(equal? tmp_42 'flonum)" +"(let-values()" +"(let-values(((len_38)(length seq_2)))" +"(begin" +"(if(exact-nonnegative-integer? len_38)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'for/flvector" +" \"exact-nonnegative-integer?\"" +" len_38)))" +"(let-values(((fill_1) 0.0))" +"(let-values(((v_233)(make-flvector len_38 fill_1)))" +"(begin" +"(if(zero? len_38)" +"(void)" +"(let-values()" +"(let-values(((lst_78) seq_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_78)))" +"((letrec-values(((for-loop_263)" +"(lambda(i_56 lst_54)" +"(begin" +" 'for-loop" +"(if(pair? lst_54)" +"(let-values(((e_76)" +"(unsafe-car" +" lst_54))" +"((rest_171)" +"(unsafe-cdr" +" lst_54)))" +"(let-values(((i_176)" +"(let-values(((i_177)" +" i_56))" +"(let-values(((i_89)" +"(let-values()" +"(begin" +"(let-values(((elem_1)" +"(let-values()" +" e_76)))" +"(if(flonum?" +" elem_1)" +"(unsafe-flvector-set!" +" v_233" +" i_177" +" elem_1)" +"(not-an-fX.1$1" +" 'for*/vector" +" elem_1)))" +"(unsafe-fx+" +" 1" +" i_177)))))" +"(values" +" i_89)))))" +"(if(if(not" +"((lambda x_24" +"(unsafe-fx=" +" i_176" +" len_38))" +" e_76))" +"(not #f)" +" #f)" +"(for-loop_263" +" i_176" +" rest_171)" +" i_176)))" +" i_56)))))" +" for-loop_263)" +" 0" +" lst_78)))))" +" v_233))))))" +"(let-values()(void)))))))" +"(let-values()" +"(let-values(((len_39)(length seq_2)))" +"(if(= expected-len_0 len_39)" +"(let-values()(list->vector seq_2))" +"(if(< expected-len_0 len_39)" +"(let-values()" +"(let-values(((in22_0) in_27)" +"((config23_0) config_39)" +"((temp24_7)" +" \"~avector length ~a is too small, ~a values provided\")" +"((temp25_7)" +"(let-values(((tmp_43) vector-mode_0))" +"(if(equal? tmp_43 'any)" +" (let-values () \"\")" +"(if(equal? tmp_43 'fixnum)" +" (let-values () \"fx\")" +"(if(equal? tmp_43 'flonum)" +" (let-values () \"fl\")" +"(let-values()(void)))))))" +"((expected-len26_0) expected-len_0)" +"((len27_0) len_39))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in22_0" +" config23_0" +" temp24_7" +"(list temp25_7 expected-len26_0 len27_0))))" +"(let-values()" +"(let-values(((last-or_0)" +"(lambda(v_234)" +"(begin" +" 'last-or" +"(if(null? seq_2)" +"(wrap v_234 in_27 config_39 #f)" +"((letrec-values(((loop_109)" +"(lambda(seq_3)" +"(begin" +" 'loop" +"(if(null?(cdr seq_3))" +"(car seq_3)" +"(loop_109" +"(cdr seq_3)))))))" +" loop_109)" +" seq_2))))))" +"(let-values((()" +"(begin" +"(if(>=(integer-length expected-len_0) 48)" +"(let-values()" +"(raise" +"(exn:fail:out-of-memory" +" \"out of memory\"" +"(current-continuation-marks))))" +"(void))" +"(values))))" +"(let-values(((vec_65)" +"(let-values(((tmp_44) vector-mode_0))" +"(if(equal? tmp_44 'any)" +"(let-values()" +"(make-vector" +" expected-len_0" +"(last-or_0 0)))" +"(if(equal? tmp_44 'fixnum)" +"(let-values()" +"(make-fxvector" +" expected-len_0" +"(last-or_0 0)))" +"(if(equal? tmp_44 'flonum)" +"(let-values()" +"(make-flvector" +" expected-len_0" +"(last-or_0 0.0)))" +"(let-values()(void))))))))" +"(begin" +"(let-values(((tmp_45) vector-mode_0))" +"(if(equal? tmp_45 'any)" +"(let-values()" +"(begin" +"(let-values(((lst_8) seq_2)((start_17) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_8)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_17)))" +"((letrec-values(((for-loop_16)" +"(lambda(lst_303 pos_113)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_303)" +" #t" +" #f)" +"(let-values(((e_77)" +"(unsafe-car" +" lst_303))" +"((rest_172)" +"(unsafe-cdr" +" lst_303))" +"((i_92)" +" pos_113))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(vector-set!" +" vec_65" +" i_92" +" e_77))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_16" +" rest_172" +"(+ pos_113 1))" +"(values))))" +"(values))))))" +" for-loop_16)" +" lst_8" +" start_17)))" +"(void)))" +"(if(equal? tmp_45 'fixnum)" +"(let-values()" +"(begin" +"(let-values(((lst_220) seq_2)((start_56) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_220)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-naturals start_56)))" +"((letrec-values(((for-loop_17)" +"(lambda(lst_158 pos_114)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_158)" +" #t" +" #f)" +"(let-values(((e_40)" +"(unsafe-car" +" lst_158))" +"((rest_7)" +"(unsafe-cdr" +" lst_158))" +"((i_178)" +" pos_114))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(fxvector-set!" +" vec_65" +" i_178" +" e_40))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_17" +" rest_7" +"(+" +" pos_114" +" 1))" +"(values))))" +"(values))))))" +" for-loop_17)" +" lst_220" +" start_56)))" +"(void)))" +"(if(equal? tmp_45 'flonum)" +"(let-values()" +"(begin" +"(let-values(((lst_282) seq_2)((start_57) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_282)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-naturals start_57)))" +"((letrec-values(((for-loop_264)" +"(lambda(lst_304" +" pos_115)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_304)" +" #t" +" #f)" +"(let-values(((e_78)" +"(unsafe-car" +" lst_304))" +"((rest_92)" +"(unsafe-cdr" +" lst_304))" +"((i_95)" +" pos_115))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(flvector-set!" +" vec_65" +" i_95" +" e_78))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_264" +" rest_92" +"(+" +" pos_115" +" 1))" +"(values))))" +"(values))))))" +" for-loop_264)" +" lst_282" +" start_57)))" +"(void)))" +"(let-values()(void))))))" +" vec_65))))))))))))" +"(wrap vec_64 in_27 config_39 opener_2))))))))))))))))" +"(define-values" +"(read-fixnum-or-flonum-vector)" +"(lambda(read-one_6 dispatch-c_0 c_81 c2_4 in_30 config_42)" +"(begin" +"(let-values(((vector-mode_1)(if(char=? c2_4 '#\\x) 'fixnum 'flonum)))" +"(let-values((()(begin(consume-char in_30 c2_4)(values))))" +"(let-values((()" +"(begin" +"(if(read-config-for-syntax? config_42)" +"(let-values()" +"(let-values(((in28_0) in_30)" +"((config29_0) config_42)" +" ((temp30_5) \"literal f~avectors not allowed\")" +"((c231_0) c2_4))" +"(reader-error10.1 #f #f #f #f #f #f in28_0 config29_0 temp30_5(list c231_0))))" +"(void))" +"(values))))" +"(let-values(((c3_2)" +"(let-values(((in_31) in_30)((source_19)(read-config-source config_42)))" +"(read-char-or-special in_31 special1.1 source_19))))" +"(let-values(((vector-len_0 len-str_0 c4_1)" +"(if(decimal-digit? c3_2)" +"(let-values()(read-simple-number in_30 config_42 c3_2))" +" (let-values () (values #f \"\" c3_2)))))" +"(let-values(((tmp_46) c4_1))" +"(if(equal? tmp_46 '#\\()" +"(let-values()" +"(let-values(((temp33_3) '#\\()" +"((temp34_1) '#\\()" +"((temp35_2) '#\\))" +"((in36_0) in_30)" +"((config37_0) config_42)" +"((vector-mode38_0) vector-mode_1)" +"((vector-len39_0) vector-len_0))" +"(read-vector11.1" +" vector-len39_0" +" #t" +" vector-mode38_0" +" #t" +" read-one_6" +" temp33_3" +" temp34_1" +" temp35_2" +" in36_0" +" config37_0)))" +"(if(equal? tmp_46 '#\\[)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_42)" +"(let-values()" +"(let-values(((temp41_3) '#\\[)" +"((temp42_2) '#\\[)" +"((temp43_2) '#\\])" +"((in44_0) in_30)" +"((config45_0) config_42)" +"((vector-mode46_0) vector-mode_1)" +"((vector-len47_0) vector-len_0))" +"(read-vector11.1" +" vector-len47_0" +" #t" +" vector-mode46_0" +" #t" +" read-one_6" +" temp41_3" +" temp42_2" +" temp43_2" +" in44_0" +" config45_0)))" +"(let-values()" +"(let-values(((in48_0) in_30)" +"((config49_0) config_42)" +" ((temp50_2) (format \"~a~a\" dispatch-c_0 (format \"~a~a\" c_81 c2_4))))" +"(bad-syntax-error18.1 #f #f in48_0 config49_0 temp50_2)))))" +"(if(equal? tmp_46 '#\\{)" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_42)" +"(let-values()" +"(let-values(((temp52_3) '#\\{)" +"((temp53_3) '#\\{)" +"((temp54_3) '#\\})" +"((in55_0) in_30)" +"((config56_0) config_42)" +"((vector-mode57_0) vector-mode_1)" +"((vector-len58_0) vector-len_0))" +"(read-vector11.1" +" vector-len58_0" +" #t" +" vector-mode57_0" +" #t" +" read-one_6" +" temp52_3" +" temp53_3" +" temp54_3" +" in55_0" +" config56_0)))" +"(let-values()" +"(let-values(((in59_0) in_30)" +"((config60_0) config_42)" +" ((temp61_2) (format \"~a~a\" dispatch-c_0 (format \"~a~a\" c_81 c2_4))))" +"(bad-syntax-error18.1 #f #f in59_0 config60_0 temp61_2)))))" +"(let-values()" +"(let-values(((c464_0) c4_1)" +" ((temp65_2) \"expected `(`, `[`, or `{` after `#~a~a~a`\")" +"((c66_0) c_81)" +"((c267_0) c2_4)" +"((len-str68_0) len-str_0))" +"(reader-error10.1" +" #f" +" #f" +" c464_0" +" #t" +" #f" +" #f" +" in_30" +" config_42" +" temp65_2" +"(list c66_0 c267_0 len-str68_0))))))))))))))))" +"(define-values" +"(read-simple-number)" +"(lambda(in_32 config_43 init-c_10)" +"(begin" +"(let-values(((accum-str_2)(accum-string-init! config_43)))" +"(let-values((()(begin(accum-string-add! accum-str_2 init-c_10)(values))))" +"(let-values(((init-v_1)(digit->number init-c_10)))" +"(let-values(((v_235)" +"(let-values(((temp72_0) 10)" +"((temp73_1) +inf.0)" +"((init-v74_0) init-v_1)" +"((init-v75_0) init-v_1))" +"(read-digits13.1" +" temp72_0" +" init-v74_0" +" #t" +" temp73_1" +" init-v75_0" +" #t" +" in_32" +" config_43" +" accum-str_2" +" #t))))" +"(values" +" v_235" +"(let-values(((accum-str76_0) accum-str_2)((config77_0) config_43))" +"(accum-string-get!6.1 #f #f accum-str76_0 config77_0))" +"(let-values(((in_33) in_32)((source_20)(read-config-source config_43)))" +"(read-char-or-special in_33 special1.1 source_20))))))))))" +"(define-values" +"(read-struct)" +"(lambda(read-one_3 dispatch-c_1 in_5 config_15)" +"(begin" +"(let-values(((c_33)" +"(let-values(((in_28) in_5)((source_21)(read-config-source config_15)))" +"(read-char-or-special in_28 special1.1 source_21))))" +"(let-values(((ec_5)(effective-char c_33 config_15)))" +"(let-values(((seq_4)" +"(let-values(((tmp_47) ec_5))" +"(if(equal? tmp_47 '#\\()" +"(let-values()(read-struct-sequence read-one_3 c_33 '#\\( '#\\) in_5 config_15))" +"(if(equal? tmp_47 '#\\[)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_15)" +"(let-values()(read-struct-sequence read-one_3 c_33 '#\\[ '#\\] in_5 config_15))" +"(let-values()" +"(let-values(((in1_1) in_5)" +"((config2_0) config_15)" +" ((temp3_7) (format \"~as~a\" dispatch-c_1 c_33)))" +"(bad-syntax-error18.1 #f #f in1_1 config2_0 temp3_7)))))" +"(if(equal? tmp_47 '#\\{)" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_15)" +"(let-values()(read-struct-sequence read-one_3 c_33 '#\\{ '#\\} in_5 config_15))" +"(let-values()" +"(let-values(((in4_1) in_5)" +"((config5_1) config_15)" +" ((temp6_3) (format \"~as~a\" dispatch-c_1 c_33)))" +"(bad-syntax-error18.1 #f #f in4_1 config5_1 temp6_3)))))" +"(let-values()" +"(let-values(((in7_1) in_5)" +"((config8_1) config_15)" +" ((temp9_3) \"expected ~a after `~as`\")" +"((temp10_0)(all-openers-str config_15))" +"((dispatch-c11_0) dispatch-c_1))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in7_1" +" config8_1" +" temp9_3" +"(list temp10_0 dispatch-c11_0))))))))))" +"(let-values((()" +"(begin" +"(if(null? seq_4)" +"(let-values()" +"(let-values(((in12_2) in_5)" +"((config13_0) config_15)" +" ((temp14_1) \"missing structure description in `~as' form\")" +"((dispatch-c15_0) dispatch-c_1))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in12_2" +" config13_0" +" temp14_1" +"(list dispatch-c15_0))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(prefab-key?(car seq_4))" +"(void)" +"(let-values()" +"(let-values(((in16_0) in_5)" +"((config17_0) config_15)" +" ((temp18_4) \"invalid structure description in `~as' form\")" +"((dispatch-c19_0) dispatch-c_1))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in16_0" +" config17_0" +" temp18_4" +"(list dispatch-c19_0)))))" +"(values))))" +"(let-values(((st_2)" +"(let-values(((with-handlers-predicate20_0) exn:fail?)" +"((with-handlers-handler21_0)" +"(lambda(exn_3)(begin 'with-handlers-handler21 #f))))" +"(let-values(((bpz_4)(continuation-mark-set-first #f break-enabled-key)))" +"(call-handled-body" +" bpz_4" +"(lambda(e_79)" +"(select-handler/no-breaks" +" e_79" +" bpz_4" +"(list(cons with-handlers-predicate20_0 with-handlers-handler21_0))))" +"(lambda()(prefab-key->struct-type(car seq_4)(length(cdr seq_4)))))))))" +"(begin" +"(if st_2" +"(void)" +"(let-values()" +"(let-values(((in22_1) in_5)" +"((config23_1) config_15)" +"((temp24_8)" +"(string-append" +" \"mismatch between structure description\"" +" \" and number of provided field values in `~as' form\"))" +"((dispatch-c25_0) dispatch-c_1))" +"(reader-error10.1 #f #f #f #f #f #f in22_1 config23_1 temp24_8(list dispatch-c25_0)))))" +"(if(read-config-for-syntax? config_15)" +"(let-values()" +"(if(all-fields-immutable?(car seq_4))" +"(void)" +"(let-values()" +"(let-values(((in26_0) in_5)" +"((config27_0) config_15)" +" ((temp28_3) \"cannot read mutable `~as' form as syntax\")" +"((dispatch-c29_0) dispatch-c_1))" +"(reader-error10.1 #f #f #f #f #f #f in26_0 config27_0 temp28_3(list dispatch-c29_0))))))" +"(void))" +"(wrap(apply make-prefab-struct seq_4) in_5 config_15 ec_5)))))))))))" +"(define-values" +"(read-struct-sequence)" +"(lambda(read-one_7 opener-c_2 opener_3 closer_3 in_16 config_20)" +"(begin" +"(let-values(((temp36_4)" +"(lambda(init-c_11 in_34 config_44)(read-one_7 init-c_11 in_34(disable-wrapping config_44)))))" +"(read-unwrapped-sequence17.1" +" #f" +" #f" +" #f" +" #f" +" temp36_4" +" #t" +" #f" +" #f" +" #f" +" #f" +" read-one_7" +" opener-c_2" +" opener_3" +" closer_3" +" in_16" +" config_20)))))" +"(define-values" +"(read-vector-or-graph)" +"(lambda(read-one_3 dispatch-c_1 init-c_12 in_35 config_45)" +"(begin" +"(let-values(((accum-str_3)(accum-string-init! config_45)))" +"(let-values((()(begin(accum-string-add! accum-str_3 init-c_12)(values))))" +"(let-values(((init-v_2)(digit->number init-c_12)))" +"(let-values(((v_28)" +"(let-values(((temp4_4) 10)((temp5_7) +inf.0)((init-v6_0) init-v_2)((init-v7_0) init-v_2))" +"(read-digits13.1" +" temp4_4" +" init-v6_0" +" #t" +" temp5_7" +" init-v7_0" +" #t" +" in_35" +" config_45" +" accum-str_3" +" #t))))" +"(let-values(((post-line_0 post-col_0 post-pos_0)(port-next-location in_35)))" +"(let-values(((get-accum_0)" +"(lambda(c_67)" +"(begin" +" 'get-accum" +"(format" +" \"~a~a~a\"" +" dispatch-c_1" +"(let-values(((accum-str8_0) accum-str_3)((config9_0) config_45))" +"(accum-string-get!6.1 #f #f accum-str8_0 config9_0))" +" c_67)))))" +"(let-values(((c_82)" +"(let-values(((in_36) in_35)((source_9)(read-config-source config_45)))" +"(read-char-or-special in_36 special1.1 source_9))))" +"(let-values(((ec_6)(effective-char c_82 config_45)))" +"(let-values(((tmp_48) ec_6))" +"(if(equal? tmp_48 '#\\()" +"(let-values()" +"(begin" +"(accum-string-abandon! accum-str_3 config_45)" +"(let-values(((temp12_4) '#\\()" +"((temp13_2) '#\\))" +"((in14_0) in_35)" +"((config15_0) config_45)" +"((v16_0) v_28))" +"(read-vector11.1 v16_0 #t #f #f read-one_3 c_82 temp12_4 temp13_2 in14_0 config15_0))))" +"(if(equal? tmp_48 '#\\[)" +"(let-values()" +"(begin" +"(accum-string-abandon! accum-str_3 config_45)" +"(if(check-parameter 1/read-square-bracket-as-paren config_45)" +"(let-values()" +"(let-values(((temp19_1) '#\\[)" +"((temp20_2) '#\\])" +"((in21_1) in_35)" +"((config22_0) config_45)" +"((v23_0) v_28))" +"(read-vector11.1" +" v23_0" +" #t" +" #f" +" #f" +" read-one_3" +" c_82" +" temp19_1" +" temp20_2" +" in21_1" +" config22_0)))" +"(let-values()" +"(let-values(((in24_0) in_35)" +"((config25_0) config_45)" +"((temp26_5)(get-accum_0(get-accum_0 c_82))))" +"(bad-syntax-error18.1 #f #f in24_0 config25_0 temp26_5))))))" +"(if(equal? tmp_48 '#\\{)" +"(let-values()" +"(begin" +"(accum-string-abandon! accum-str_3 config_45)" +"(if(check-parameter 1/read-curly-brace-as-paren config_45)" +"(let-values()" +"(let-values(((temp29_3) '#\\{)" +"((temp30_6) '#\\})" +"((in31_1) in_35)" +"((config32_0) config_45)" +"((v33_0) v_28))" +"(read-vector11.1" +" v33_0" +" #t" +" #f" +" #f" +" read-one_3" +" c_82" +" temp29_3" +" temp30_6" +" in31_1" +" config32_0)))" +"(let-values()" +"(let-values(((in34_0) in_35)" +"((config35_0) config_45)" +"((temp36_5)(get-accum_0(get-accum_0 c_82))))" +"(bad-syntax-error18.1 #f #f in34_0 config35_0 temp36_5))))))" +"(let-values()" +"(let-values(((tmp_6) c_82))" +"(if(if(equal? tmp_6 '#\\=) #t(equal? tmp_6 '#\\#))" +"(let-values()" +"(begin" +"(if(let-values(((or-part_347)(read-config-for-syntax? config_45)))" +"(if or-part_347" +" or-part_347" +"(not(check-parameter 1/read-accept-graph config_45))))" +"(let-values()" +"(let-values(((in37_0) in_35)" +"((config38_0) config_45)" +" ((temp39_6) \"`#...~a` forms not ~a\")" +"((c40_0) c_82)" +"((temp41_4)" +"(if(read-config-for-syntax? config_45)" +" \"enabled\"" +" \"allowed in `read-syntax` mode\")))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in37_0" +" config38_0" +" temp39_6" +"(list c40_0 temp41_4))))" +"(void))" +"(if(<=(accum-string-count accum-str_3) 8)" +"(void)" +"(let-values()" +"(let-values(((in42_0) in_35)" +"((config43_0) config_45)" +" ((temp44_2) \"graph ID too long in `~a~a~a`\")" +"((dispatch-c45_0) dispatch-c_1)" +"((temp46_3)" +"(let-values(((accum-str48_0) accum-str_3)" +"((config49_1) config_45))" +"(accum-string-get!6.1 #f #f accum-str48_0 config49_1)))" +"((c47_0) c_82))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in42_0" +" config43_0" +" temp44_2" +"(list dispatch-c45_0 temp46_3 c47_0)))))" +"(let-values(((tmp_49) c_82))" +"(if(equal? tmp_49 '#\\=)" +"(let-values()" +"(let-values(((ph_1)(make-placeholder 'placeholder)))" +"(let-values(((ht_154)(get-graph-hash config_45)))" +"(let-values((()" +"(begin" +"(if(hash-ref ht_154 v_28 #f)" +"(let-values()" +"(let-values(((in50_0) in_35)" +"((config51_0) config_45)" +" ((temp52_4) \"multiple `~a~a~a` tags\")" +"((dispatch-c53_0) dispatch-c_1)" +"((temp54_4)" +"(let-values(((accum-str56_0)" +" accum-str_3)" +"((config57_0)" +" config_45))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str56_0" +" config57_0)))" +"((c55_0) c_82))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in50_0" +" config51_0" +" temp52_4" +"(list dispatch-c53_0 temp54_4 c55_0))))" +"(void))" +"(values))))" +"(let-values((()(begin(hash-set! ht_154 v_28 ph_1)(values))))" +"(let-values(((result-v_0)" +"(read-one_3 #f in_35(next-readtable config_45))))" +"(begin" +"(if(eof-object? result-v_0)" +"(let-values()" +"(let-values(((result-v60_0) result-v_0)" +"((temp61_3)" +" \"expected an element for graph after `~a~a~a`, found end-of-file\")" +"((dispatch-c62_0) dispatch-c_1)" +"((temp63_2)" +"(let-values(((accum-str65_0) accum-str_3)" +"((config66_0) config_45))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str65_0" +" config66_0)))" +"((c64_0) c_82))" +"(reader-error10.1" +" #f" +" #f" +" result-v60_0" +" #t" +" #f" +" #f" +" in_35" +" config_45" +" temp61_3" +"(list dispatch-c62_0 temp63_2 c64_0))))" +"(void))" +"(accum-string-abandon! accum-str_3 config_45)" +"(placeholder-set! ph_1 result-v_0)" +" ph_1)))))))" +"(if(equal? tmp_49 '#\\#)" +"(let-values()" +"(begin0" +"(hash-ref" +"(let-values(((or-part_227)" +"(read-config-state-graph(read-config-st config_45))))" +"(if or-part_227 or-part_227 '#hash()))" +" v_28" +"(lambda()" +"(let-values(((in67_0) in_35)" +"((config68_0) config_45)" +" ((temp69_1) \"no preceding `~a~a=` for `~a~a~a`\")" +"((dispatch-c70_0) dispatch-c_1)" +"((v71_0) v_28)" +"((dispatch-c72_0) dispatch-c_1)" +"((temp73_2)" +"(let-values(((accum-str75_0) accum-str_3)" +"((config76_0) config_45))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str75_0" +" config76_0)))" +"((c74_0) c_82))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in67_0" +" config68_0" +" temp69_1" +"(list dispatch-c70_0 v71_0 dispatch-c72_0 temp73_2 c74_0)))))" +"(accum-string-abandon! accum-str_3 config_45)))" +"(let-values()(void)))))))" +"(let-values()" +"(let-values(((c79_0) c_82)" +" ((temp80_3) \"bad syntax `~a`\")" +"((temp81_2)(get-accum_0 c_82)))" +"(reader-error10.1" +" #f" +" #f" +" c79_0" +" #t" +" #f" +" #f" +" in_35" +" config_45" +" temp80_3" +"(list temp81_2))))))))))))))))))))))" +"(define-values" +"(get-graph-hash)" +"(lambda(config_46)" +"(begin" +"(let-values(((st_3)(read-config-st config_46)))" +"(let-values(((or-part_263)(read-config-state-graph st_3)))" +"(if or-part_263" +" or-part_263" +"(let-values(((ht_155)(make-hasheqv)))(begin(set-read-config-state-graph! st_3 ht_155) ht_155))))))))" +"(define-values" +"(coerce-key)" +"(lambda(key_85 config_8)" +"(begin" +"(let-values(((for-syntax?_7)(read-config-for-syntax? config_8)))" +"((read-config-coerce-key config_8) for-syntax?_7 key_85)))))" +"(define-values" +"(read-hash)" +"(lambda(read-one_3 dispatch-c_1 init-c_12 in_35 config_45)" +"(begin" +"(let-values(((accum-str_3)(accum-string-init! config_45)))" +"(let-values((()(begin(accum-string-add! accum-str_3 dispatch-c_1)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_3 init-c_12)(values))))" +"(let-values(((get-next!_0)" +"(lambda(expect-c_0 expect-alt-c_0)" +"(begin" +" 'get-next!" +"(let-values(((c_83)" +"(let-values(((in_27) in_35)((source_22)(read-config-source config_45)))" +"(read-char-or-special in_27 special1.1 source_22))))" +"(begin" +"(if(let-values(((or-part_6)(eqv? c_83 expect-c_0)))" +"(if or-part_6 or-part_6(eqv? c_83 expect-alt-c_0)))" +"(void)" +"(let-values()" +"(let-values(((c3_3) c_83)" +" ((temp4_5) \"expected `~a` after `~a`\")" +"((expect-c5_0) expect-c_0)" +"((temp6_0)" +"(let-values(((accum-str7_0) accum-str_3)((config8_2) config_45))" +"(accum-string-get!6.1 #f #f accum-str7_0 config8_2))))" +"(reader-error10.1" +" #f" +" #f" +" c3_3" +" #t" +" #f" +" #f" +" in_35" +" config_45" +" temp4_5" +"(list expect-c5_0 temp6_0)))))" +"(accum-string-add! accum-str_3 c_83)))))))" +"(let-values((()(begin(get-next!_0 '#\\a '#\\A)(values))))" +"(let-values((()(begin(get-next!_0 '#\\s '#\\S)(values))))" +"(let-values((()(begin(get-next!_0 '#\\h '#\\H)(values))))" +"(let-values(((content_10 opener_4 mode_19)" +"((letrec-values(((loop_110)" +"(lambda(mode_3)" +"(begin" +" 'loop" +"(let-values(((c_80)" +"(let-values(((in_6) in_35)" +"((source_23)" +"(read-config-source config_45)))" +"(read-char-or-special" +" in_6" +" special1.1" +" source_23))))" +"(let-values(((ec_7)(effective-char c_80 config_45)))" +"(let-values(((tmp_50) ec_7))" +"(if(equal? tmp_50 '#\\()" +"(let-values()" +"(let-values(((read-one-key+value_0)" +"(make-read-one-key+value" +" read-one_3" +" c_80" +" '#\\))))" +"(values" +"(let-values(((temp11_3) '#\\()" +"((temp12_5) '#\\))" +"((in13_0) in_35)" +"((config14_0) config_45)" +"((config15_1) config_45)" +"((temp16_6) #f))" +"(read-unwrapped-sequence17.1" +" temp16_6" +" #t" +" config15_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" read-one-key+value_0" +" c_80" +" temp11_3" +" temp12_5" +" in13_0" +" config14_0))" +" ec_7" +" mode_3)))" +"(if(equal? tmp_50 '#\\[)" +"(let-values()" +"(if(check-parameter" +" 1/read-square-bracket-as-paren" +" config_45)" +"(let-values()" +"(let-values(((read-one-key+value_1)" +"(make-read-one-key+value" +" read-one_3" +" c_80" +" '#\\])))" +"(values" +"(let-values(((temp19_2) '#\\[)" +"((temp20_3) '#\\])" +"((in21_2) in_35)" +"((config22_1) config_45)" +"((config23_2) config_45)" +"((temp24_9) #f))" +"(read-unwrapped-sequence17.1" +" temp24_9" +" #t" +" config23_2" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" read-one-key+value_1" +" c_80" +" temp19_2" +" temp20_3" +" in21_2" +" config22_1))" +" ec_7" +" mode_3)))" +"(let-values()" +"(let-values(((in25_0) in_35)" +"((config26_0) config_45)" +" ((temp27_6) \"illegal use of `~a`\")" +"((c28_0) c_80))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in25_0" +" config26_0" +" temp27_6" +"(list c28_0))))))" +"(if(equal? tmp_50 '#\\{)" +"(let-values()" +"(if(check-parameter" +" 1/read-curly-brace-as-paren" +" config_45)" +"(let-values()" +"(let-values(((read-one-key+value_2)" +"(make-read-one-key+value" +" read-one_3" +" c_80" +" '#\\})))" +"(values" +"(let-values(((temp31_6) '#\\{)" +"((temp32_3) '#\\})" +"((in33_0) in_35)" +"((config34_0) config_45)" +"((config35_1) config_45)" +"((temp36_0) #f))" +"(read-unwrapped-sequence17.1" +" temp36_0" +" #t" +" config35_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" read-one-key+value_2" +" c_80" +" temp31_6" +" temp32_3" +" in33_0" +" config34_0))" +" ec_7" +" mode_3)))" +"(let-values()" +"(let-values(((in37_1) in_35)" +"((config38_1) config_45)" +"((temp39_7)" +" \"illegal use of `~a`\")" +"((c40_1) c_80))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in37_1" +" config38_1" +" temp39_7" +"(list c40_1))))))" +"(if(if(equal? tmp_50 '#\\e)" +" #t" +"(equal? tmp_50 '#\\E))" +"(let-values()" +"(begin" +"(accum-string-add! accum-str_3 c_80)" +"(get-next!_0 '#\\q '#\\Q)" +"(loop_110 'eq)))" +"(if(if(equal? tmp_50 '#\\v)" +" #t" +"(equal? tmp_50 '#\\V))" +"(let-values()" +"(begin" +"(accum-string-add! accum-str_3 c_80)" +"(if(eq? mode_3 'eq)" +"(loop_110 'eqv)" +"(let-values(((in41_0) in_35)" +"((config42_0) config_45)" +"((temp43_3)" +" \"bad syntax `~a`\")" +"((temp44_3)" +"(let-values(((accum-str45_0)" +" accum-str_3)" +"((config46_0)" +" config_45))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str45_0" +" config46_0))))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in41_0" +" config42_0" +" temp43_3" +"(list temp44_3))))))" +"(let-values()" +"(begin" +"(if(char? c_80)" +"(let-values()" +"(accum-string-add! accum-str_3 c_80))" +"(void))" +"(let-values(((c49_0) c_80)" +" ((temp50_3) \"bad syntax `~a`\")" +"((temp51_2)" +"(let-values(((accum-str52_0)" +" accum-str_3)" +"((config53_0)" +" config_45))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str52_0" +" config53_0))))" +"(reader-error10.1" +" #f" +" #f" +" c49_0" +" #t" +" #f" +" #f" +" in_35" +" config_45" +" temp50_3" +"(list temp51_2)))))))))))))))))" +" loop_110)" +" 'equal)))" +"(let-values(((graph?_0)(if(read-config-state-graph(read-config-st config_45)) #t #f)))" +"(wrap" +"(let-values(((tmp_44) mode_19))" +"(if(equal? tmp_44 'equal)" +"(let-values()" +"(if graph?_0(make-hash-placeholder content_10)(make-immutable-hash content_10)))" +"(if(equal? tmp_44 'eq)" +"(let-values()" +"(if graph?_0(make-hasheq-placeholder content_10)(make-immutable-hasheq content_10)))" +"(if(equal? tmp_44 'eqv)" +"(let-values()" +"(if graph?_0" +"(make-hasheqv-placeholder content_10)" +"(make-immutable-hasheqv content_10)))" +"(let-values()(void))))))" +" in_35" +" config_45" +" opener_4)))))))))))))" +"(define-values" +"(make-read-one-key+value)" +"(lambda(read-one_8 overall-opener-c_0 overall-closer-ec_0)" +"(begin" +"(lambda(init-c_13 in_37 config_47)" +"(let-values(((c_84)(read-char/skip-whitespace-and-comments init-c_13 read-one_8 in_37 config_47)))" +"(let-values(((open-line_0 open-col_0 open-pos_0)(port-next-location* in_37 c_84)))" +"(let-values(((ec_8)(effective-char c_84 config_47)))" +"(let-values(((elem-config_1)(next-readtable config_47)))" +"(let-values(((closer_4)" +"(let-values(((tmp_51) ec_8))" +"(if(equal? tmp_51 '#\\()" +"(let-values() '#\\))" +"(if(equal? tmp_51 '#\\[)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_47) '#\\] #f))" +"(if(equal? tmp_51 '#\\{)" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_47) '#\\} #f))" +"(let-values() #f)))))))" +"(if(not closer_4)" +"(let-values()" +"(if(eof-object? c_84)" +"(let-values()" +"(let-values(((temp55_2)(reading-at config_47 open-line_0 open-col_0 open-pos_0))" +"((c56_0) c_84)" +" ((temp57_1) \"expected ~a to close `~a`\")" +"((temp58_3)(closer-name overall-closer-ec_0 config_47))" +"((overall-opener-c59_0) overall-opener-c_0))" +"(reader-error10.1" +" #f" +" #f" +" c56_0" +" #t" +" #f" +" #f" +" in_37" +" temp55_2" +" temp57_1" +"(list temp58_3 overall-opener-c59_0))))" +"(if(char-closer? ec_8 config_47)" +"(let-values()" +"(let-values(((in60_0) in_37)" +"((temp61_4)(reading-at config_47 open-line_0 open-col_0 open-pos_0))" +" ((temp62_1) \"~a\")" +"((temp63_3)(indentation-unexpected-closer-message ec_8 c_84 config_47)))" +"(reader-error10.1 #f #f #f #f #f #f in60_0 temp61_4 temp62_1(list temp63_3))))" +"(let-values()" +"(let-values(((v_89)(read-one_8 c_84 in_37(keep-comment elem-config_1))))" +"(if(1/special-comment? v_89)" +"(let-values()" +"((make-read-one-key+value read-one_8 overall-opener-c_0 overall-closer-ec_0)" +" #f" +" in_37" +" config_47))" +"(let-values()" +"(let-values(((in64_0) in_37)" +"((temp65_3)(reading-at config_47 open-line_0 open-col_0 open-pos_0))" +" ((temp66_3) \"expected ~a to start a hash pair\")" +"((temp67_1)(all-openers-str config_47)))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in64_0" +" temp65_3" +" temp66_3" +"(list temp67_1))))))))))" +"(let-values()" +"(let-values(((k_40)(read-one_8 #f in_37(disable-wrapping elem-config_1))))" +"(let-values(((dot-c_0)(read-char/skip-whitespace-and-comments #f read-one_8 in_37 config_47)))" +"(let-values(((dot-line_1 dot-col_1 dot-pos_4)(port-next-location* in_37 dot-c_0)))" +"(let-values(((dot-ec_0)(effective-char dot-c_0 config_47)))" +"(let-values((()" +"(begin" +"(if(if(eqv? dot-ec_0 '#\\.)" +"(char-delimiter?" +"(let-values(((in_38) in_37)" +"((skip-count_8) 0)" +"((source_24)(read-config-source config_47)))" +"(peek-char-or-special in_38 skip-count_8 special1.1 source_24))" +" config_47)" +" #f)" +"(void)" +"(let-values()" +"(let-values(((temp69_2)" +"(reading-at config_47 dot-line_1 dot-col_1 dot-pos_4))" +"((dot-c70_0) dot-c_0)" +" ((temp71_1) \"expected ~a and value for hash\")" +"((temp72_1)(dot-name config_47)))" +"(reader-error10.1" +" #f" +" #f" +" dot-c70_0" +" #t" +" #f" +" #f" +" in_37" +" temp69_2" +" temp71_1" +"(list temp72_1)))))" +"(values))))" +"(let-values(((v_236)(read-one_8 #f in_37 elem-config_1)))" +"(let-values(((closer-c_0)" +"(read-char/skip-whitespace-and-comments #f read-one_8 in_37 config_47)))" +"(let-values(((closer-line_0 closer-col_0 closer-pos_0)" +"(port-next-location* in_37 closer-c_0)))" +"(let-values(((closer-ec_0)(effective-char closer-c_0 config_47)))" +"(begin" +"(if(eqv? closer-ec_0 closer_4)" +"(void)" +"(let-values()" +"(let-values(((temp74_0)" +"(reading-at" +" config_47" +" closer-line_0" +" closer-col_0" +" closer-pos_0))" +"((closer-c75_0) closer-c_0)" +" ((temp76_0) \"expected ~a after value within a hash\")" +"((temp77_1)(closer-name closer_4 config_47)))" +"(reader-error10.1" +" #f" +" #f" +" closer-c75_0" +" #t" +" #f" +" #f" +" in_37" +" temp74_0" +" temp76_0" +"(list temp77_1)))))" +"(cons(coerce-key k_40 elem-config_1) v_236))))))))))))))))))))))" +"(define-values" +"(read-string5.1)" +"(lambda(mode1_1 mode2_0 in3_0 config4_0)" +"(begin" +" 'read-string5" +"(let-values(((in_39) in3_0))" +"(let-values(((config_22) config4_0))" +"(let-values(((mode_0)(if mode2_0 mode1_1 'string)))" +"(let-values()" +"(let-values(((source_25)(read-config-source config_22)))" +"(let-values(((accum-str_4)(accum-string-init! config_22)))" +"(let-values(((bad-end_0)" +"(lambda(c_85)" +"(begin" +" 'bad-end" +"(if(eof-object? c_85)" +"(let-values()" +" (let-values (((c10_1) c_85) ((temp11_4) \"expected a closing `\\\"`\"))" +"(reader-error10.1 #f #f c10_1 #t #f #f in_39 config_22 temp11_4(list))))" +"(let-values()" +"(let-values(((c14_0) c_85)" +" ((temp15_6) \"found non-character while reading a ~a\")" +"((mode16_0) mode_0))" +"(reader-error10.1" +" #f" +" #f" +" c14_0" +" #t" +" #f" +" #f" +" in_39" +" config_22" +" temp15_6" +"(list mode16_0)))))))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_111)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_86)" +"(let-values(((in_40) in_39)" +"((source_26) source_25))" +"(read-char-or-special" +" in_40" +" special1.1" +" source_26))))" +"(if(not(char? c_86))" +"(let-values()(bad-end_0 c_86))" +"(if(char=? '#\\\\ c_86)" +"(let-values()" +"(let-values(((escaping-c_0) c_86))" +"(let-values(((escaped-c_0)" +"(let-values(((in_41) in_39)" +"((source_6) source_25))" +"(read-char-or-special" +" in_41" +" special1.1" +" source_6))))" +"(let-values((()" +"(begin" +"(if(not(char? escaped-c_0))" +"(let-values()" +"(bad-end_0 escaped-c_0))" +"(void))" +"(values))))" +"(let-values(((unknown-error_0)" +"(lambda()" +"(begin" +" 'unknown-error" +"(let-values(((in17_0) in_39)" +"((config18_0)" +" config_22)" +"((temp19_3)" +" \"unknown escape sequence `~a~a` in ~a\")" +"((escaping-c20_0)" +" escaping-c_0)" +"((escaped-c21_0)" +" escaped-c_0)" +"((mode22_0)" +" mode_0))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in17_0" +" config18_0" +" temp19_3" +"(list" +" escaping-c20_0" +" escaped-c21_0" +" mode22_0)))))))" +"(begin" +"(let-values(((tmp_52) escaped-c_0))" +"(let-values(((index_3)" +"(if(char? tmp_52)" +"(let-values(((codepoint_1)" +"(char->integer" +" tmp_52)))" +"(if(if(unsafe-fx>=" +" codepoint_1" +" 10)" +"(unsafe-fx<" +" codepoint_1" +" 121)" +" #f)" +"(let-values(((tbl_1)" +" '#(10" +" 0" +" 0" +" 11" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 12" +" 12" +" 12" +" 12" +" 12" +" 12" +" 12" +" 12" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 15" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 1" +" 0" +" 0" +" 0" +" 0" +" 2" +" 3" +" 0" +" 0" +" 9" +" 7" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 5" +" 0" +" 0" +" 0" +" 8" +" 0" +" 4" +" 14" +" 6" +" 0" +" 13)))" +"(unsafe-vector*-ref" +" tbl_1" +"(unsafe-fx-" +" codepoint_1" +" 10)))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_3 7)" +"(if(unsafe-fx< index_3 3)" +"(if(unsafe-fx< index_3 1)" +"(let-values()(unknown-error_0))" +"(if(unsafe-fx< index_3 2)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" escaped-c_0))" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\u0007))))" +"(if(unsafe-fx< index_3 4)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\backspace))" +"(if(unsafe-fx< index_3 5)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\tab))" +"(if(unsafe-fx< index_3 6)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\newline))" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\vtab))))))" +"(if(unsafe-fx< index_3 11)" +"(if(unsafe-fx< index_3 8)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\page))" +"(if(unsafe-fx< index_3 9)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\return))" +"(if(unsafe-fx< index_3 10)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" '#\\u001B))" +"(let-values()(void)))))" +"(if(unsafe-fx< index_3 13)" +"(if(unsafe-fx< index_3 12)" +"(let-values()" +"(let-values(((maybe-newline-c_0)" +"(let-values(((in_36)" +" in_39)" +"((skip-count_9)" +" 0)" +"((source_27)" +" source_25))" +"(peek-char-or-special" +" in_36" +" skip-count_9" +" special1.1" +" source_27))))" +"(begin" +"(if(eqv?" +" maybe-newline-c_0" +" '#\\newline)" +"(let-values()" +"(consume-char" +" in_39" +" maybe-newline-c_0))" +"(void))" +"(void))))" +"(let-values()" +"(let-values(((pos_97)" +"(accum-string-count" +" accum-str_4)))" +"(let-values((()" +"(begin" +"(accum-string-add!" +" accum-str_4" +" escaped-c_0)" +"(values))))" +"(let-values(((init-v_3)" +"(digit->number" +" escaped-c_0)))" +"(let-values(((v_133)" +"(let-values(((temp26_6)" +" 8)" +"((temp27_7)" +" 2)" +"((init-v28_0)" +" init-v_3)" +"((init-v29_0)" +" init-v_3))" +"(read-digits13.1" +" temp26_6" +" init-v28_0" +" #t" +" temp27_7" +" init-v29_0" +" #t" +" in_39" +" config_22" +" accum-str_4" +" #t))))" +"(begin" +"(if(<= v_133 255)" +"(void)" +"(let-values()" +"(let-values(((in30_0)" +" in_39)" +"((config31_0)" +" config_22)" +"((temp32_3)" +" \"escape sequence `~a~a` is out of range in ~a\")" +"((escaping-c33_0)" +" escaping-c_0)" +"((temp34_2)" +"(let-values(((pos38_0)" +" pos_97))" +"(accum-string-get!6.1" +" pos38_0" +" #t" +" accum-str_4" +" config_22)))" +"((mode35_0)" +" mode_0))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in30_0" +" config31_0" +" temp32_3" +"(list" +" escaping-c33_0" +" temp34_2" +" mode35_0)))))" +"(set-accum-string-count!" +" accum-str_4" +" pos_97)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_133)))))))))" +"(if(unsafe-fx< index_3 14)" +"(let-values()" +"(let-values(((pos_96)" +"(accum-string-count" +" accum-str_4)))" +"(let-values(((v_76)" +"(let-values(((temp42_3)" +" 16)" +"((temp43_4)" +" 2))" +"(read-digits13.1" +" temp42_3" +" #f" +" #f" +" temp43_4" +" #f" +" #f" +" in_39" +" config_22" +" accum-str_4" +" #t))))" +"(begin" +"(if(integer? v_76)" +"(void)" +"(let-values()" +"(no-hex-digits" +" in_39" +" config_22" +" v_76" +" escaping-c_0" +" escaped-c_0)))" +"(set-accum-string-count!" +" accum-str_4" +" pos_96)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_76))))))" +"(if(unsafe-fx< index_3 15)" +"(let-values()" +"(let-values((()" +"(begin" +"(if(eq?" +" mode_0" +" 'string)" +"(void)" +"(let-values()" +"(unknown-error_0)))" +"(values))))" +"(let-values(((pos_95)" +"(accum-string-count" +" accum-str_4)))" +"(let-values(((v_35)" +"(let-values(((temp47_1)" +" 16)" +"((temp48_1)" +" 4))" +"(read-digits13.1" +" temp47_1" +" #f" +" #f" +" temp48_1" +" #f" +" #f" +" in_39" +" config_22" +" accum-str_4" +" #t))))" +"(begin" +"(if(integer? v_35)" +"(void)" +"(let-values()" +"(no-hex-digits" +" in_39" +" config_22" +" v_35" +" escaping-c_0" +" escaped-c_0)))" +"(if(let-values(((or-part_347)" +"(<" +" v_35" +" 55296)))" +"(if or-part_347" +" or-part_347" +"(>" +" v_35" +" 57343)))" +"(let-values()" +"(begin" +"(set-accum-string-count!" +" accum-str_4" +" pos_95)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_35))))" +"(let-values()" +"(let-values(((next!_0)" +"(lambda()" +"(begin" +" 'next!" +"(let-values(((next-c_1)" +"(let-values(((in_42)" +" in_39)" +"((source_14)" +" source_25))" +"(read-char-or-special" +" in_42" +" special1.1" +" source_14))))" +"(begin" +"(if(char?" +" next-c_1)" +"(let-values()" +"(accum-string-add!" +" accum-str_4" +" next-c_1))" +"(void))" +" next-c_1))))))" +"(let-values(((v2_8)" +"(let-values(((next-c_2)" +"(next!_0)))" +"(if(char=?" +" next-c_2" +" '#\\\\)" +"(let-values()" +"(let-values(((next-c_3)" +"(next!_0)))" +"(if(char=?" +" next-c_3" +" '#\\u)" +"(let-values()" +"(let-values(((v2_9)" +"(let-values(((temp52_5)" +" 16)" +"((temp53_4)" +" 4))" +"(read-digits13.1" +" temp52_5" +" #f" +" #f" +" temp53_4" +" #f" +" #f" +" in_39" +" config_22" +" accum-str_4" +" #t))))" +"(if(integer?" +" v2_9)" +"(let-values()" +"(if(>=" +" v2_9" +" 56320)" +"(if(<=" +" v2_9" +" 57343)" +" v2_9" +" #f)" +" #f))" +"(let-values()" +" v2_9))))" +"(let-values()" +" next-c_3))))" +"(let-values()" +" next-c_2)))))" +"(if(integer?" +" v2_8)" +"(let-values()" +"(let-values(((combined-v_0)" +"(+" +"(arithmetic-shift" +"(-" +" v_35" +" 55296)" +" 10)" +"(-" +" v2_8" +" 56320)" +" 65536)))" +"(if(>" +" combined-v_0" +" 1114111)" +"(let-values()" +"(let-values(((in54_0)" +" in_39)" +"((config55_0)" +" config_22)" +"((temp56_0)" +" \"escape sequence `~au~a` is out of range in string\")" +"((escaping-c57_0)" +" escaping-c_0)" +"((temp58_4)" +"(let-values(((pos61_0)" +" pos_95))" +"(accum-string-get!6.1" +" pos61_0" +" #t" +" accum-str_4" +" config_22))))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in54_0" +" config55_0" +" temp56_0" +"(list" +" escaping-c57_0" +" temp58_4))))" +"(let-values()" +"(begin" +"(set-accum-string-count!" +" accum-str_4" +" pos_95)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" combined-v_0)))))))" +"(let-values()" +"(let-values(((v264_0)" +" v2_8)" +"((temp65_4)" +" \"bad or incomplete surrogate-style encoding at `~au~a`\")" +"((escaping-c66_0)" +" escaping-c_0)" +"((temp67_2)" +"(let-values(((pos70_0)" +" pos_95))" +"(accum-string-get!6.1" +" pos70_0" +" #t" +" accum-str_4" +" config_22))))" +"(reader-error10.1" +" #f" +" #f" +" v264_0" +" #t" +" #f" +" #f" +" in_39" +" config_22" +" temp65_4" +"(list" +" escaping-c66_0" +" temp67_2))))))))))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(eq?" +" mode_0" +" 'string)" +"(void)" +"(let-values()" +"(unknown-error_0)))" +"(values))))" +"(let-values(((pos_116)" +"(accum-string-count" +" accum-str_4)))" +"(let-values(((v_84)" +"(let-values(((temp74_1)" +" 16)" +"((temp75_1)" +" 8))" +"(read-digits13.1" +" temp74_1" +" #f" +" #f" +" temp75_1" +" #f" +" #f" +" in_39" +" config_22" +" accum-str_4" +" #t))))" +"(begin" +"(if(integer? v_84)" +"(void)" +"(let-values()" +"(no-hex-digits" +" in_39" +" config_22" +" v_84" +" escaping-c_0" +" escaped-c_0)))" +"(if(if(let-values(((or-part_37)" +"(<" +" v_84" +" 55296)))" +"(if or-part_37" +" or-part_37" +"(>" +" v_84" +" 57343)))" +"(<=" +" v_84" +" 1114111)" +" #f)" +"(let-values()" +"(begin" +"(set-accum-string-count!" +" accum-str_4" +" pos_116)" +"(accum-string-add!" +" accum-str_4" +"(integer->char" +" v_84))))" +"(let-values()" +"(let-values(((in76_0)" +" in_39)" +"((config77_1)" +" config_22)" +"((temp78_4)" +" \"escape sequence `~aU~a` is out of range in string\")" +"((escaping-c79_0)" +" escaping-c_0)" +"((temp80_4)" +"(let-values(((pos83_0)" +" pos_116))" +"(accum-string-get!6.1" +" pos83_0" +" #t" +" accum-str_4" +" config_22))))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in76_0" +" config77_1" +" temp78_4" +"(list" +" escaping-c79_0" +" temp80_4)))))))))))))))))" +"(loop_111)))))))" +" (if (char=? '#\\\" c_86)" +"(let-values() null)" +"(let-values()" +"(begin" +"(if(eq? mode_0 '|byte string|)" +"(let-values()" +"(if(byte?(char->integer c_86))" +"(void)" +"(let-values()" +"(let-values(((in84_0) in_39)" +"((config85_0) config_22)" +"((temp86_0)" +" \"character `~a` is out of range in byte string\")" +"((c87_0) c_86))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in84_0" +" config85_0" +" temp86_0" +"(list c87_0))))))" +"(void))" +"(accum-string-add! accum-str_4 c_86)" +"(loop_111)))))))))))" +" loop_111))" +"(values))))" +"(let-values(((str_30)" +"(if(eq? mode_0 '|byte string|)" +"(let-values(((accum-str88_0) accum-str_4)((config89_0) config_22))" +"(accum-string-get-bytes!13.1 #f #f accum-str88_0 config89_0))" +"(let-values(((accum-str90_0) accum-str_4)((config91_0) config_22))" +"(accum-string-get!6.1 #f #f accum-str90_0 config91_0)))))" +"(wrap str_30 in_39 config_22 str_30)))))))))))))" +"(define-values" +"(read-here-string)" +"(lambda(in_43 config_48)" +"(begin" +"(let-values(((source_28)(read-config-source config_48)))" +"(let-values(((accum-str_5)(accum-string-init! config_48)))" +"(let-values(((full-terminator_0)" +"((letrec-values(((loop_112)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_87)" +"(let-values(((in_44) in_43)((source_29) source_28))" +"(read-char-or-special in_44 special1.1 source_29))))" +"(if(eof-object? c_87)" +"(let-values()" +"(let-values(((c94_0) c_87)" +"((temp95_2)" +" \"found end-of-file after `#<<` and before a newline\"))" +"(reader-error10.1" +" #f" +" #f" +" c94_0" +" #t" +" #f" +" #f" +" in_43" +" config_48" +" temp95_2" +"(list))))" +"(if(not(char? c_87))" +"(let-values()" +"(let-values(((c98_0) c_87)" +"((temp99_2)" +" \"found non-character while reading `#<<`\"))" +"(reader-error10.1" +" #f" +" #f" +" c98_0" +" #t" +" #f" +" #f" +" in_43" +" config_48" +" temp99_2" +"(list))))" +"(if(char=? c_87 '#\\newline)" +"(let-values() null)" +"(let-values()(cons c_87(loop_112)))))))))))" +" loop_112))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_113)" +"(lambda(terminator_0 terminator-accum_0)" +"(begin" +" 'loop" +"(let-values(((c_88)" +"(let-values(((in_45) in_43)((source_30) source_28))" +"(read-char-or-special in_45 special1.1 source_30))))" +"(if(eof-object? c_88)" +"(let-values()" +"(if(null? terminator_0)" +"(void)" +"(let-values()" +"(let-values(((c102_0) c_88)" +"((temp103_2)" +" \"found end-of-file before terminating `~a`\")" +"((temp104_2)(list->string full-terminator_0)))" +"(reader-error10.1" +" #f" +" #f" +" c102_0" +" #t" +" #f" +" #f" +" in_43" +" config_48" +" temp103_2" +"(list temp104_2))))))" +"(if(not(char? c_88))" +"(let-values()" +"(let-values(((c107_0) c_88)" +"((temp108_3)" +" \"found non-character while reading `#<<`\"))" +"(reader-error10.1" +" #f" +" #f" +" c107_0" +" #t" +" #f" +" #f" +" in_43" +" config_48" +" temp108_3" +"(list))))" +"(if(if(pair? terminator_0)" +"(char=? c_88(car terminator_0))" +" #f)" +"(let-values()" +"(loop_113" +"(cdr terminator_0)" +"(cons(car terminator_0) terminator-accum_0)))" +"(if(if(null? terminator_0)(char=? c_88 '#\\newline) #f)" +"(let-values()(void))" +"(let-values()" +"(begin" +"(if(null? terminator-accum_0)" +"(void)" +"(let-values()" +"(begin" +"(let-values(((lst_96)" +"(reverse$1 terminator-accum_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_96)))" +"((letrec-values(((for-loop_6)" +"(lambda(lst_305)" +"(begin" +" 'for-loop" +"(if(pair? lst_305)" +"(let-values(((c_89)" +"(unsafe-car" +" lst_305))" +"((rest_173)" +"(unsafe-cdr" +" lst_305)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(accum-string-add!" +" accum-str_5" +" c_89))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_6" +" rest_173)" +"(values))))" +"(values))))))" +" for-loop_6)" +" lst_96)))" +"(void))))" +"(accum-string-add! accum-str_5 c_88)" +"(loop_113 full-terminator_0 null))))))))))))" +" loop_113)" +" full-terminator_0" +" null)" +"(values))))" +"(let-values(((str_31)" +"(let-values(((accum-str109_0) accum-str_5)((config110_0) config_48))" +"(accum-string-get!6.1 #f #f accum-str109_0 config110_0))))" +"(wrap str_31 in_43 config_48 str_31)))))))))" +"(define-values" +"(no-hex-digits)" +"(lambda(in_46 config_49 c_90 escaping-c_1 escaped-c_1)" +"(begin" +"(let-values(((c113_0) c_90)" +" ((temp114_1) \"no hex digit following `~a~a`\")" +"((escaping-c115_0) escaping-c_1)" +"((escaped-c116_0) escaped-c_1))" +"(reader-error10.1 #f #f c113_0 #t #f #f in_46 config_49 temp114_1(list escaping-c115_0 escaped-c116_0))))))" +"(define-values" +"(read-character)" +"(lambda(in_4 config_8)" +"(begin" +"(let-values(((c_91)" +"(let-values(((in_39) in_4)((source_31)(read-config-source config_8)))" +"(read-char-or-special in_39 special1.1 source_31))))" +"(let-values(((char_0)" +"(if(eof-object? c_91)" +"(let-values()" +" (let-values (((c3_4) c_91) ((temp4_0) \"expected a character after `#\\\\`\"))" +"(reader-error10.1 #f #f c3_4 #t #f #f in_4 config_8 temp4_0(list))))" +"(if(not(char? c_91))" +"(let-values()" +" (let-values (((c7_1) c_91) ((temp8_4) \"found non-character after `#\\\\`\"))" +"(reader-error10.1 #f #f c7_1 #t #f #f in_4 config_8 temp8_4(list))))" +"(if(octal-digit? c_91)" +"(let-values()" +"(let-values(((c2_5)" +"(let-values(((in_47) in_4)" +"((skip-count_10) 0)" +"((source_32)(read-config-source config_8)))" +"(peek-char-or-special in_47 skip-count_10 special1.1 source_32))))" +"(if(if(char? c2_5)(octal-digit? c2_5) #f)" +"(let-values()" +"(let-values((()(begin(consume-char in_4 c2_5)(values))))" +"(let-values(((c3_5)" +"(let-values(((in_48) in_4)" +"((source_33)(read-config-source config_8)))" +"(read-char-or-special in_48 special1.1 source_33))))" +"(let-values(((v_1)" +"(if(if(char? c3_5)(octal-digit? c3_5) #f)" +"(let-values()" +"(+" +"(arithmetic-shift(digit->number c_91) 6)" +"(arithmetic-shift(digit->number c2_5) 3)" +"(digit->number c3_5)))" +"(let-values() #f))))" +"(begin" +"(if(if v_1(<= v_1 255) #f)" +"(void)" +"(let-values()" +"(let-values(((c311_0) c3_5)" +" ((temp12_6) \"bad character constant `#\\\\~a~a~a`\")" +"((c13_2) c_91)" +"((c214_0) c2_5)" +" ((temp15_7) (if (char? c3_5) c3_5 \"\")))" +"(reader-error10.1" +" #f" +" #f" +" c311_0" +" #t" +" #f" +" #f" +" in_4" +" config_8" +" temp12_6" +"(list c13_2 c214_0 temp15_7)))))" +"(integer->char v_1))))))" +"(let-values() c_91))))" +"(if(let-values(((or-part_259)(char=? c_91 '#\\u)))" +"(if or-part_259 or-part_259(char=? c_91 '#\\U)))" +"(let-values()" +"(let-values(((accum-str_6)(accum-string-init! config_8)))" +"(let-values(((v_3)" +"(let-values(((temp19_4) 16)((temp20_4)(if(char=? c_91 '#\\u) 4 8)))" +"(read-digits13.1" +" temp19_4" +" #f" +" #f" +" temp20_4" +" #f" +" #f" +" in_4" +" config_8" +" accum-str_6" +" #t))))" +"(if(integer? v_3)" +"(let-values()" +"(if(if(let-values(((or-part_29)(< v_3 55296)))" +"(if or-part_29 or-part_29(> v_3 57343)))" +"(<= v_3 1114111)" +" #f)" +"(let-values()" +"(begin(accum-string-abandon! accum-str_6 config_8)(integer->char v_3)))" +"(let-values()" +"(let-values(((in21_3) in_4)" +"((config22_2) config_8)" +" ((temp23_4) \"bad character constant `#\\\\u~a`\")" +"((temp24_10)" +"(let-values(((accum-str25_0) accum-str_6)" +"((config26_1) config_8))" +"(accum-string-get!6.1 #f #f accum-str25_0 config26_1))))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in21_3" +" config22_2" +" temp23_4" +"(list temp24_10))))))" +"(let-values()(begin(accum-string-abandon! accum-str_6 config_8) c_91))))))" +"(if(char-alphabetic? c_91)" +"(let-values()" +"(let-values(((next-c_4)" +"(let-values(((in_36) in_4)" +"((skip-count_9) 0)" +"((source_27)(read-config-source config_8)))" +"(peek-char-or-special in_36 skip-count_9 special1.1 source_27))))" +"(if(if(char? next-c_4)(char-alphabetic? next-c_4) #f)" +"(let-values()" +"(let-values(((accum-str_7)(accum-string-init! config_8)))" +"(let-values((()(begin(accum-string-add! accum-str_7 c_91)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_7 next-c_4)(values))))" +"(let-values((()(begin(consume-char in_4 next-c_4)(values))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_114)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((next-c_5)" +"(let-values(((in_14)" +" in_4)" +"((skip-count_11)" +" 0)" +"((source_34)" +"(read-config-source" +" config_8)))" +"(peek-char-or-special" +" in_14" +" skip-count_11" +" special1.1" +" source_34))))" +"(if(if(char? next-c_5)" +"(char-alphabetic?" +" next-c_5)" +" #f)" +"(let-values()" +"(begin" +"(accum-string-add!" +" accum-str_7" +" next-c_5)" +"(consume-char" +" in_4" +" next-c_5)" +"(loop_114)))" +"(void)))))))" +" loop_114))" +"(values))))" +"(let-values(((name_58)" +"(string-foldcase" +"(let-values(((accum-str27_0) accum-str_7)" +"((config28_1) config_8))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str27_0" +" config28_1)))))" +"(let-values(((tmp_53) name_58))" +" (if (if (equal? tmp_53 \"nul\") #t (equal? tmp_53 \"null\"))" +"(let-values() '#\\nul)" +" (if (equal? tmp_53 \"backspace\")" +"(let-values() '#\\backspace)" +" (if (equal? tmp_53 \"tab\")" +"(let-values() '#\\tab)" +" (if (if (equal? tmp_53 \"newline\")" +" #t" +" (equal? tmp_53 \"linefeed\"))" +"(let-values() '#\\newline)" +" (if (equal? tmp_53 \"vtab\")" +"(let-values() '#\\vtab)" +" (if (equal? tmp_53 \"page\")" +"(let-values() '#\\page)" +" (if (equal? tmp_53 \"return\")" +"(let-values() '#\\return)" +" (if (equal? tmp_53 \"space\")" +"(let-values() '#\\space)" +" (if (equal? tmp_53 \"rubout\")" +"(let-values() '#\\rubout)" +"(let-values()" +"(let-values(((in29_2) in_4)" +"((config30_0) config_8)" +"((temp31_7)" +" \"bad character constant `#\\\\~a`\")" +"((name32_0) name_58))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in29_2" +" config30_0" +" temp31_7" +"(list name32_0)))))))))))))))))))))" +"(let-values() c_91))))" +"(let-values() c_91))))))))" +"(wrap char_0 in_4 config_8 char_0))))))" +"(define-values" +"(read-quote)" +"(lambda(read-one_3 sym_27 desc_0 c_35 in_39 config_22)" +"(begin" +"(let-values(((wrapped-sym_0)(wrap sym_27 in_39 config_22 c_35)))" +"(let-values(((e_80)(read-one_3 #f in_39 config_22)))" +"(begin" +"(if(eof-object? e_80)" +"(let-values()" +"(let-values(((e3_0) e_80)" +" ((temp4_6) \"expected an element for ~a, found end-of-file\")" +"((desc5_0) desc_0))" +"(reader-error10.1 #f #f e3_0 #t #f #f in_39 config_22 temp4_6(list desc5_0))))" +"(void))" +"(wrap(list wrapped-sym_0 e_80) in_39 config_22 #f)))))))" +"(define-values" +"(read-delimited-constant)" +"(lambda(init-c_1 can-match?_0 chars_0 val_75 in_39 config_22)" +"(begin" +"(let-values(((accum-str_8)(accum-string-init! config_22)))" +"(begin" +"(accum-string-add! accum-str_8 init-c_1)" +"((letrec-values(((loop_115)" +"(lambda(chars_1)" +"(begin" +" 'loop" +"(let-values(((c_92)" +"(let-values(((in_49) in_39)" +"((skip-count_12) 0)" +"((source_4)(read-config-source config_22)))" +"(peek-char-or-special in_49 skip-count_12 special1.1 source_4))))" +"(if(char-delimiter? c_92 config_22)" +"(let-values()" +"(if(null? chars_1)" +"(void)" +"(let-values()" +"(let-values(((c3_6) c_92)" +" ((temp4_7) \"bad syntax `#~a`\")" +"((temp5_8)" +"(let-values(((accum-str6_0) accum-str_8)" +"((config7_1) config_22))" +"(accum-string-get!6.1 #f #f accum-str6_0 config7_1))))" +"(reader-error10.1" +" #f" +" #f" +" c3_6" +" #t" +" #f" +" #f" +" in_39" +" config_22" +" temp4_7" +"(list temp5_8))))))" +"(if(null? chars_1)" +"(let-values()" +"(begin" +"(accum-string-add! accum-str_8 c_92)" +"(let-values(((in8_0) in_39)" +"((config9_1) config_22)" +" ((temp10_4) \"bad syntax `#~a`\")" +"((temp11_2)" +"(let-values(((accum-str12_0) accum-str_8)" +"((config13_1) config_22))" +"(accum-string-get!6.1 #f #f accum-str12_0 config13_1))))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in8_0" +" config9_1" +" temp10_4" +"(list temp11_2)))))" +"(if(if can-match?_0(char=? c_92(car chars_1)) #f)" +"(let-values()" +"(begin" +"(consume-char in_39 c_92)" +"(accum-string-add! accum-str_8 c_92)" +"(loop_115(cdr chars_1))))" +"(let-values()" +"(begin" +"(consume-char/special in_39 config_22 c_92)" +"(accum-string-add! accum-str_8 c_92)" +"(let-values(((in14_1) in_39)" +"((config15_2) config_22)" +" ((temp16_7) \"bad syntax `#~a`\")" +"((temp17_3)" +"(let-values(((accum-str18_1) accum-str_8)" +"((config19_1) config_22))" +"(accum-string-get!6.1 #f #f accum-str18_1 config19_1))))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in14_1" +" config15_2" +" temp16_7" +"(list temp17_3)))))))))))))" +" loop_115)" +" chars_0)" +"(wrap" +" val_75" +" in_39" +" config_22" +"(let-values(((accum-str20_0) accum-str_8)((config21_1) config_22))" +"(accum-string-get!6.1 #f #f accum-str20_0 config21_1))))))))" +"(define-values" +"(read-box)" +"(lambda(read-one_3 dispatch-c_1 in_5 config_15)" +"(begin" +"(let-values((()" +"(begin" +"(if(check-parameter 1/read-accept-box config_15)" +"(void)" +"(let-values()" +"(let-values(((in1_2) in_5)" +"((config2_1) config_15)" +" ((temp3_8) \"`~a&` forms not enabled\")" +"((dispatch-c4_0) dispatch-c_1))" +"(reader-error10.1 #f #f #f #f #f #f in1_2 config2_1 temp3_8(list dispatch-c4_0)))))" +"(values))))" +"(let-values(((e_70)(read-one_3 #f in_5(next-readtable config_15))))" +"(begin" +"(if(eof-object? e_70)" +"(let-values()" +"(let-values(((e7_1) e_70)" +" ((temp8_4) \"expected an element for `~a&` box, found end-of-file\")" +"((dispatch-c9_0) dispatch-c_1))" +"(reader-error10.1 #f #f e7_1 #t #f #f in_5 config_15 temp8_4(list dispatch-c9_0))))" +"(void))" +"(wrap(box e_70) in_5 config_15 #f)))))))" +"(define-values" +"(read-regexp)" +"(lambda(mode-c_0 accum-str_9 in_5 config_15)" +"(begin" +"(let-values(((c3_7)" +"(let-values(((in_50) in_5)((source_35)(read-config-source config_15)))" +"(read-char-or-special in_50 special1.1 source_35))))" +"(let-values(((no-wrap-config_0)(disable-wrapping config_15)))" +"(let-values(((rx_0)" +"(let-values(((tmp_17) c3_7))" +" (if (equal? tmp_17 '#\\\")" +"(let-values()" +"(let-values((()(begin(accum-string-abandon! accum-str_9 config_15)(values))))" +"(let-values(((str_32)" +"(let-values(((in1_3) in_5)((no-wrap-config2_0) no-wrap-config_0))" +"(read-string5.1 #f #f in1_3 no-wrap-config2_0))))" +"(catch-and-reraise-as-reader/proc" +" in_5" +" config_15" +"(lambda()((if(char=? mode-c_0 '#\\r) regexp pregexp) str_32))))))" +"(if(equal? tmp_17 '#\\#)" +"(let-values()" +"(let-values((()(begin(accum-string-add! accum-str_9 c3_7)(values))))" +"(let-values(((c4_2)" +"(let-values(((in_25) in_5)" +"((source_36)(read-config-source config_15)))" +"(read-char-or-special in_25 special1.1 source_36))))" +"(let-values(((tmp_54) c4_2))" +" (if (equal? tmp_54 '#\\\")" +"(let-values()" +"(let-values((()" +"(begin(accum-string-abandon! accum-str_9 config_15)(values))))" +"(let-values(((bstr_4)" +"(let-values(((temp5_9) '|byte string|))" +"(read-string5.1 temp5_9 #t in_5 no-wrap-config_0))))" +"(catch-and-reraise-as-reader/proc" +" in_5" +" config_15" +"(lambda()" +"((if(char=? mode-c_0 '#\\r) byte-regexp byte-pregexp) bstr_4))))))" +"(let-values()" +"(let-values(((c48_0) c4_2)" +" ((temp9_4) \"expected `\\\"` after `~a`\")" +"((temp10_5)" +"(let-values(((accum-str11_0) accum-str_9)" +"((config12_2) config_15))" +"(accum-string-get!6.1 #f #f accum-str11_0 config12_2))))" +"(reader-error10.1" +" #f" +" #f" +" c48_0" +" #t" +" #f" +" #f" +" in_5" +" config_15" +" temp9_4" +"(list temp10_5)))))))))" +"(let-values()" +"(let-values(((c315_0) c3_7)" +" ((temp16_7) \"expected `\\\"` or `#` after `~a`\")" +"((temp17_3)" +"(let-values(((accum-str18_1) accum-str_9)((config19_1) config_15))" +"(accum-string-get!6.1 #f #f accum-str18_1 config19_1))))" +"(reader-error10.1" +" #f" +" #f" +" c315_0" +" #t" +" #f" +" #f" +" in_5" +" config_15" +" temp16_7" +"(list temp17_3)))))))))" +"(wrap rx_0 in_5 config_15 #f)))))))" +"(define-values" +"(read-extension-reader)" +"(lambda(read-one_9 read-recur_0 dispatch-c_2 in_24 config_24)" +"(begin" +"(let-values(((extend-str_0)" +"(read-extension-prefix(cons dispatch-c_2 '(#\\r #\\e)) '(#\\a #\\d #\\e #\\r) in_24 config_24)))" +"(let-values((()" +"(begin" +"(if(check-parameter 1/read-accept-reader config_24)" +"(void)" +"(let-values()" +"(let-values(((in52_0) in_24)" +"((config53_1) config_24)" +" ((temp54_5) \"`~a` not enabled\")" +"((extend-str55_0) extend-str_0))" +"(reader-error10.1 #f #f #f #f #f #f in52_0 config53_1 temp54_5(list extend-str55_0)))))" +"(values))))" +"(let-values(((mod-path-wrapped_0)(read-one_9 #f in_24(next-readtable config_24))))" +"(begin" +"(if(eof-object? mod-path-wrapped_0)" +"(let-values()" +"(let-values(((mod-path-wrapped58_0) mod-path-wrapped_0)" +" ((temp59_3) \"expected a datum after `~a`, found end-of-file\")" +"((extend-str60_0) extend-str_0))" +"(reader-error10.1" +" #f" +" #f" +" mod-path-wrapped58_0" +" #t" +" #f" +" #f" +" in_24" +" config_24" +" temp59_3" +"(list extend-str60_0))))" +"(void))" +"(let-values(((temp47_2)((read-config-coerce config_24) #f mod-path-wrapped_0 #f))" +"((read-recur48_0) read-recur_0)" +"((in49_0) in_24)" +"((config50_0) config_24)" +"((mod-path-wrapped51_0) mod-path-wrapped_0))" +"(read-extension44.1" +" #f" +" #f" +" mod-path-wrapped51_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp47_2" +" read-recur48_0" +" in49_0" +" config50_0)))))))))" +"(define-values" +"(read-extension-lang7.1)" +"(lambda(get-info?1_0 get-info?2_0 read-recur3_0 dispatch-c4_1 in5_1 config6_0)" +"(begin" +" 'read-extension-lang7" +"(let-values(((read-recur_1) read-recur3_0))" +"(let-values(((dispatch-c_3) dispatch-c4_1))" +"(let-values(((in_51) in5_1))" +"(let-values(((config_50) config6_0))" +"(let-values(((get-info?_0)(if get-info?2_0 get-info?1_0 #f)))" +"(let-values()" +"(let-values(((extend-str_1)" +"(read-extension-prefix(cons dispatch-c_3 '(#\\l)) '(#\\a #\\n #\\g) in_51 config_50)))" +"(let-values(((c_67)" +"(let-values(((in_22) in_51)((source_37)(read-config-source config_50)))" +"(read-char-or-special in_22 special1.1 source_37))))" +"(begin" +"(if(char=? c_67 '#\\space)" +"(void)" +"(let-values()" +"(let-values(((in67_1) in_51)" +"((config68_1) config_50)" +" ((temp69_3) \"expected a single space after `~a`\")" +"((extend-str70_0) extend-str_1))" +"(reader-error10.1 #f #f #f #f #f #f in67_1 config68_1 temp69_3(list extend-str70_0)))))" +"(let-values(((temp65_5) '|#lang|)((get-info?66_0) get-info?_0))" +"(read-lang29.1" +" get-info?66_0" +" #t" +" #f" +" #f" +" temp65_5" +" extend-str_1" +" read-recur_1" +" in_51" +" config_50))))))))))))))" +"(define-values" +"(read-extension-#!16.1)" +"(lambda(get-info?10_0 get-info?11_0 read-recur12_0 dispatch-c13_0 in14_2 config15_3)" +"(begin" +" 'read-extension-#!16" +"(let-values(((read-recur_2) read-recur12_0))" +"(let-values(((dispatch-c_4) dispatch-c13_0))" +"(let-values(((in_37) in14_2))" +"(let-values(((config_47) config15_3))" +"(let-values(((get-info?_1)(if get-info?11_0 get-info?10_0 #f)))" +"(let-values()" +"(let-values(((c_68)" +"(let-values(((in_52) in_37)((source_38)(read-config-source config_47)))" +"(read-char-or-special in_52 special1.1 source_38))))" +"(begin" +"(if(char-lang-nonsep? c_68)" +"(void)" +"(let-values()" +"(let-values(((in78_0) in_37)" +"((config79_0) config_47)" +"((temp80_5)" +"(if(char? c_68)(string dispatch-c_4 '#\\! c_68)(string dispatch-c_4 '#\\!))))" +"(bad-syntax-error18.1 #f #f in78_0 config79_0 temp80_5))))" +"(let-values(((temp71_2)(string dispatch-c_4 '#\\!))" +"((read-recur72_0) read-recur_2)" +"((in73_0) in_37)" +"((config74_0) config_47)" +"((c75_0) c_68)" +"((temp76_1) '|#!|)" +"((get-info?77_0) get-info?_1))" +"(read-lang29.1" +" get-info?77_0" +" #t" +" c75_0" +" #t" +" temp76_1" +" temp71_2" +" read-recur72_0" +" in73_0" +" config74_0)))))))))))))" +"(define-values" +"(read-lang29.1)" +"(lambda(get-info?20_0 get-info?23_0 init-c19_0 init-c22_0 who21_0 extend-str25_0 read-recur26_0 in27_1 config28_2)" +"(begin" +" 'read-lang29" +"(let-values(((extend-str_2) extend-str25_0))" +"(let-values(((read-recur_3) read-recur26_0))" +"(let-values(((in_53) in27_1))" +"(let-values(((config_51) config28_2))" +"(let-values(((init-c_14)(if init-c22_0 init-c19_0 #f)))" +"(let-values(((get-info?_2)(if get-info?23_0 get-info?20_0 #f)))" +"(let-values(((who_27) who21_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(if(check-parameter 1/read-accept-reader config_51)" +"(check-parameter 1/read-accept-lang config_51)" +" #f)" +"(void)" +"(let-values()" +"(let-values(((in88_0) in_53)" +"((config89_1) config_51)" +" ((temp90_2) \"`~a` not enabled\")" +"((extend-str91_0) extend-str_2))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in88_0" +" config89_1" +" temp90_2" +"(list extend-str91_0)))))" +"(values))))" +"(let-values(((accum-str_10)(accum-string-init! config_51)))" +"(let-values((()" +"(begin" +"(if init-c_14" +"(let-values()(accum-string-add! accum-str_10 init-c_14))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"((letrec-values(((loop_116)" +"(lambda()" +"(begin" +" 'loop" +"(let-values(((c_93)" +"(let-values(((in_54) in_53)" +"((skip-count_13) 0)" +"((source_39)" +"(read-config-source" +" config_51)))" +"(peek-char-or-special" +" in_54" +" skip-count_13" +" special1.1" +" source_39))))" +"(if(eof-object? c_93)" +"(let-values()(void))" +"(if(not(char? c_93))" +"(let-values()" +"(begin" +"(consume-char/special in_53 config_51 c_93)" +"(let-values(((c94_1) c_93)" +"((temp95_3)" +" \"found non-character while reading `#~a'\")" +"((extend-str96_0)" +" extend-str_2))" +"(reader-error10.1" +" #f" +" #f" +" c94_1" +" #t" +" #f" +" #f" +" in_53" +" config_51" +" temp95_3" +"(list extend-str96_0)))))" +"(if(char-whitespace? c_93)" +"(let-values()(void))" +"(if(let-values(((or-part_348)" +"(char-lang-nonsep? c_93)))" +"(if or-part_348" +" or-part_348" +"(char=? '#\\/ c_93)))" +"(let-values()" +"(begin" +"(consume-char in_53 c_93)" +"(accum-string-add! accum-str_10 c_93)" +"(loop_116)))" +"(let-values()" +"(begin" +"(consume-char in_53 c_93)" +"(let-values(((in97_0) in_53)" +"((config98_0) config_51)" +"((temp99_3)" +"(string-append" +" \"expected only alphanumeric, `-`, `+`, `_`, or `/`\"" +" \" characters for `~a`, found `~a`\"))" +"((extend-str100_0)" +" extend-str_2)" +"((c101_0) c_93))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in97_0" +" config98_0" +" temp99_3" +"(list" +" extend-str100_0" +" c101_0))))))))))))))" +" loop_116))" +"(values))))" +"(let-values(((lang-str_0)" +"(let-values(((accum-str102_0) accum-str_10)((config103_0) config_51))" +"(accum-string-get!6.1 #f #f accum-str102_0 config103_0))))" +"(let-values((()" +"(begin" +" (if (equal? lang-str_0 \"\")" +"(let-values()" +"(let-values(((in104_0) in_53)" +"((config105_0) config_51)" +"((temp106_3)" +" \"expected a non-empty sequence of alphanumeric, `-`, `+`, `_`, or `/` after `~a`\")" +"((extend-str107_0) extend-str_2))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in104_0" +" config105_0" +" temp106_3" +"(list extend-str107_0))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(char=? '#\\/(string-ref lang-str_0 0))" +"(let-values()" +"(let-values(((in108_0) in_53)" +"((config109_0) config_51)" +"((temp110_5)" +" \"expected a name that does not start `/` after `~a`\")" +"((extend-str111_0) extend-str_2))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in108_0" +" config109_0" +" temp110_5" +"(list extend-str111_0))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(char=?" +" '#\\/" +"(string-ref lang-str_0(sub1(string-length lang-str_0))))" +"(let-values()" +"(let-values(((in112_0) in_53)" +"((config113_0) config_51)" +"((temp114_2)" +" \"expected a name that does not end `/` after `~a`\")" +"((extend-str115_0) extend-str_2))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in112_0" +" config113_0" +" temp114_2" +"(list extend-str115_0))))" +"(void))" +"(values))))" +"(let-values(((submod-path_0)" +"(list* 'submod(string->symbol lang-str_0) '(reader))))" +"(let-values(((reader-path_0)" +" (string->symbol (string-append lang-str_0 \"/lang/reader\"))))" +"(let-values(((submod-path81_0) submod-path_0)" +"((reader-path82_0) reader-path_0)" +"((read-recur83_0) read-recur_3)" +"((in84_1) in_53)" +"((config85_1) config_51)" +"((get-info?86_0) get-info?_2)" +"((who87_0) who_27))" +"(read-extension44.1" +" get-info?86_0" +" #t" +" #f" +" #f" +" submod-path81_0" +" #t" +" who87_0" +" #t" +" reader-path82_0" +" read-recur83_0" +" in84_1" +" config85_1)))))))))))))))))))))))" +"(define-values" +"(char-lang-nonsep?)" +"(lambda(c_94)" +"(begin" +"(if(<(char->integer c_94) 128)" +"(let-values(((or-part_265)(char-alphabetic? c_94)))" +"(if or-part_265" +" or-part_265" +"(let-values(((or-part_287)(char-numeric? c_94)))" +"(if or-part_287" +" or-part_287" +"(let-values(((or-part_288)(char=? '#\\- c_94)))" +"(if or-part_288" +" or-part_288" +"(let-values(((or-part_349)(char=? '#\\+ c_94)))" +"(if or-part_349 or-part_349(char=? '#\\_ c_94)))))))))" +" #f))))" +"(define-values" +"(read-extension-prefix)" +"(lambda(already_0 wanted_0 in_55 config_52)" +"(begin" +"(let-values(((accum-str_11)(accum-string-init! config_52)))" +"(begin" +"(let-values(((lst_197) already_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_197)))" +"((letrec-values(((for-loop_265)" +"(lambda(lst_306)" +"(begin" +" 'for-loop" +"(if(pair? lst_306)" +"(let-values(((c_95)(unsafe-car lst_306))((rest_104)(unsafe-cdr lst_306)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(accum-string-add! accum-str_11 c_95))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_265 rest_104)(values))))" +"(values))))))" +" for-loop_265)" +" lst_197)))" +"(void)" +"((letrec-values(((loop_117)" +"(lambda(wanted_1)" +"(begin" +" 'loop" +"(if(null? wanted_1)" +"(void)" +"(let-values()" +"(let-values(((c_26)" +"(let-values(((in_56) in_55)" +"((source_40)(read-config-source config_52)))" +"(read-char-or-special in_56 special1.1 source_40))))" +"(begin" +"(if(char? c_26)(let-values()(accum-string-add! accum-str_11 c_26))(void))" +"(if(eqv? c_26(car wanted_1))" +"(void)" +"(let-values()" +"(let-values(((temp120_2)" +"(let-values(((accum-str122_0) accum-str_11)" +"((config123_0) config_52))" +"(accum-string-get!6.1 #f #f accum-str122_0 config123_0)))" +"((c121_0) c_26))" +"(bad-syntax-error18.1 c121_0 #t in_55 config_52 temp120_2))))" +"(loop_117(cdr wanted_1))))))))))" +" loop_117)" +" wanted_0)" +"(let-values(((accum-str116_0) accum-str_11)((config117_0) config_52))" +"(accum-string-get!6.1 #f #f accum-str116_0 config117_0)))))))" +"(define-values" +"(read-extension44.1)" +"(lambda(get-info?34_0" +" get-info?38_0" +" mod-path-wrapped33_0" +" mod-path-wrapped37_0" +" try-first-mod-path32_0" +" try-first-mod-path36_0" +" who35_0" +" who39_0" +" mod-path-datum40_0" +" read-recur41_0" +" in42_1" +" config43_1)" +"(begin" +" 'read-extension44" +"(let-values(((try-first-mod-path_0)(if try-first-mod-path36_0 try-first-mod-path32_0 #f)))" +"(let-values(((mod-path-datum_0) mod-path-datum40_0))" +"(let-values(((read-recur_4) read-recur41_0))" +"(let-values(((in_57) in42_1))" +"(let-values(((config_53) config43_1))" +"(let-values(((mod-path-wrapped_1)" +"(if mod-path-wrapped37_0" +" mod-path-wrapped33_0" +"((read-config-coerce config_53) #t mod-path-datum_0 #f))))" +"(let-values(((get-info?_3)(if get-info?38_0 get-info?34_0 #f)))" +"(let-values(((who_28)(if who39_0 who35_0 '|#reader|)))" +"(let-values()" +"(let-values((()(begin(force-parameters! config_53)(values))))" +"(let-values(((guard_0)(1/current-reader-guard)))" +"(let-values(((mod-path_27)" +"(let-values(((or-part_350)" +"(if try-first-mod-path_0" +"(let-values(((mod-path_28)(guard_0 try-first-mod-path_0)))" +"(if((read-config-module-declared? config_53)" +" try-first-mod-path_0)" +" mod-path_28" +" #f))" +" #f)))" +"(if or-part_350 or-part_350(guard_0 mod-path-datum_0)))))" +"(let-values(((for-syntax?_8)(read-config-for-syntax? config_53)))" +"(let-values(((dynamic-require_2)(read-config-dynamic-require config_53)))" +"(let-values(((no-value_0)(gensym)))" +"(let-values(((extension_0)" +"(if get-info?_3" +"(let-values()" +"(dynamic-require_2 mod-path_27 'get-info(lambda() no-value_0)))" +"(let-values()" +"(dynamic-require_2" +" mod-path_27" +"(if for-syntax?_8 'read-syntax 'read))))))" +"(if(eq? extension_0 no-value_0)" +"(let-values() #f)" +"(let-values()" +"(let-values(((result-v_1)" +"(if(if for-syntax?_8(not get-info?_3) #f)" +"(let-values()" +"(if(procedure-arity-includes? extension_0 6)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()" +"(extension_0" +"(read-config-source config_53)" +" in_57" +" mod-path-wrapped_1" +"(read-config-line config_53)" +"(read-config-col config_53)" +"(read-config-pos config_53)))))" +"(if(procedure-arity-includes? extension_0 2)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()" +"(extension_0" +"(read-config-source config_53)" +" in_57))))" +"(let-values()" +"(raise-argument-error" +" who_28" +" \"(or/c (procedure-arity-includes?/c 2) (procedure-arity-includes?/c 6))\"" +" extension_0)))))" +"(let-values()" +"(if(procedure-arity-includes? extension_0 5)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()" +"(extension_0" +" in_57" +" mod-path-wrapped_1" +"(read-config-line config_53)" +"(read-config-col config_53)" +"(read-config-pos config_53)))))" +"(if get-info?_3" +"(let-values()" +"(raise-argument-error" +" who_28" +" \"(procedure-arity-includes?/c 5)\"" +" extension_0))" +"(if(procedure-arity-includes? extension_0 1)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-read-config" +" config_53)" +"(let-values()(extension_0 in_57))))" +"(let-values()" +"(raise-argument-error" +" who_28" +" \"(or/c (procedure-arity-includes?/c 1) (procedure-arity-includes?/c 5))\"" +" extension_0)))))))))" +"(if get-info?_3" +"(let-values()" +"(begin" +"(if(if(procedure? result-v_1)" +"(procedure-arity-includes? result-v_1 2)" +" #f)" +"(void)" +"(let-values()" +"(raise-result-error" +" 'read-language" +" \"(procedure-arity-includes?/c 2)\"" +" result-v_1)))" +" result-v_1))" +"(if(1/special-comment? result-v_1)" +"(let-values()(read-recur_4 in_57 config_53))" +"(let-values()" +"(coerce result-v_1 in_57 config_53))))))))))))))))))))))))))" +"(define-values" +"(read-language/get-info)" +"(lambda(read-one_3 in_2 config_7 fail-k_5)" +"(begin" +"(let-values(((c_33)(read-char/skip-whitespace-and-comments #f read-one_3 in_2 config_7)))" +"(let-values(((line_8 col_7 pos_112)(port-next-location* in_2 c_33)))" +"(let-values(((l-config_0)" +"(override-parameter 1/read-accept-reader(reading-at config_7 line_8 col_7 pos_112) #t)))" +"(if(not(eqv? c_33 '#\\#))" +" (let-values () (if fail-k_5 (fail-k_5) (lang-error in_2 l-config_0 \"\" c_33)))" +"(let-values()" +"(let-values(((c2_6)" +"(let-values(((in_49) in_2)((source_41)(read-config-source l-config_0)))" +"(read-char-or-special in_49 special1.1 source_41))))" +"(if(eqv? c2_6 '#\\l)" +"(let-values()" +"(let-values(((temp5_10) #t))" +"(read-extension-lang7.1 temp5_10 #t read-one_3 c_33 in_2 l-config_0)))" +"(if(eqv? c2_6 '#\\!)" +"(let-values()" +"(let-values(((temp10_6) #t))" +"(read-extension-#!16.1 temp10_6 #t read-one_3 c_33 in_2 l-config_0)))" +"(let-values()" +"(if fail-k_5(fail-k_5)(lang-error in_2 l-config_0(string c_33) c2_6))))))))))))))" +"(define-values" +"(lang-error)" +"(lambda(in_25 config_37 prefix_7 c_86)" +"(begin" +"(let-values(((add-prefix_0)" +"(lambda(s_10)" +"(begin" +" 'add-prefix" +" (if (string=? prefix_7 \"\") (format \"`~a` followed by ~a\" prefix_7 s_10) s_10)))))" +"(let-values(((c13_3) c_86)" +"((temp14_0) 'read-language)" +"((temp15_0)" +"(string-append" +" \"expected (after whitespace and comments) `#lang ` or `#!` followed\"" +" \" immediately by a language name, found ~a\"))" +"((temp16_0)" +"(if(eof-object? c_86)" +" (let-values () (add-prefix_0 \"end-of-file\"))" +"(if(not(char? c_86))" +" (let-values () (add-prefix_0 \"non-character\"))" +" (let-values () (format \"`~a~a`\" prefix_7 c_86))))))" +"(reader-error10.1 #f #f c13_3 #t temp14_0 #t in_25 config_37 temp15_0(list temp16_0)))))))" +"(define-values" +"(read30.1)" +"(lambda(coerce12_1" +" coerce26_0" +" coerce-key13_1" +" coerce-key27_0" +" dynamic-require10_1" +" dynamic-require24_0" +" for-syntax?8_0" +" for-syntax?22_0" +" init-c2_0" +" init-c16_0" +" keep-comment?14_1" +" keep-comment?28_0" +" local-graph?6_0" +" local-graph?20_0" +" module-declared?11_1" +" module-declared?25_0" +" next-readtable3_0" +" next-readtable17_0" +" read-compiled9_1" +" read-compiled23_0" +" readtable4_0" +" readtable18_0" +" recursive?5_0" +" recursive?19_0" +" source7_0" +" source21_0" +" wrap1_0" +" wrap15_0" +" in29_3)" +"(begin" +" 'read30" +"(let-values(((in_21) in29_3))" +"(let-values(((wrap_7)(if wrap15_0 wrap1_0 #f)))" +"(let-values(((init-c_6)(if init-c16_0 init-c2_0 #f)))" +"(let-values(((next-readtable_3)(if next-readtable17_0 next-readtable3_0(1/current-readtable))))" +"(let-values(((readtable_3)(if readtable18_0 readtable4_0 next-readtable_3)))" +"(let-values(((recursive?_0)(if recursive?19_0 recursive?5_0 #f)))" +"(let-values(((local-graph?_1)(if local-graph?20_0 local-graph?6_0 #f)))" +"(let-values(((source_8)(if source21_0 source7_0 #f)))" +"(let-values(((for-syntax?_9)(if for-syntax?22_0 for-syntax?8_0 #f)))" +"(let-values(((read-compiled_2)(if read-compiled23_0 read-compiled9_1 #f)))" +"(let-values(((dynamic-require_3)(if dynamic-require24_0 dynamic-require10_1 #f)))" +"(let-values(((module-declared?_2)(if module-declared?25_0 module-declared?11_1 #f)))" +"(let-values(((coerce_2)(if coerce26_0 coerce12_1 #f)))" +"(let-values(((coerce-key_2)(if coerce-key27_0 coerce-key13_1 #f)))" +"(let-values(((keep-comment?_3)" +"(if keep-comment?28_0 keep-comment?14_1 recursive?_0)))" +"(let-values()" +"(let-values(((config_54)" +"(let-values(((c1_29)(if recursive?_0(current-read-config) #f)))" +"(if c1_29" +"((lambda(config_55)" +"(let-values(((for-syntax?53_0) for-syntax?_9)" +"((wrap54_1) wrap_7)" +"((readtable55_0) readtable_3)" +"((next-readtable56_0) next-readtable_3)" +"((local-graph?57_0) local-graph?_1)" +"((keep-comment?58_0) keep-comment?_3))" +"(read-config-update42.1" +" for-syntax?53_0" +" keep-comment?58_0" +" next-readtable56_0" +" #t" +" readtable55_0" +" local-graph?57_0" +" wrap54_1" +" config_55)))" +" c1_29)" +"(let-values()" +"(let-values(((readtable59_0) readtable_3)" +"((next-readtable60_0) next-readtable_3)" +"((source61_0) source_8)" +"((for-syntax?62_0) for-syntax?_9)" +"((wrap63_0) wrap_7)" +"((read-compiled64_0) read-compiled_2)" +"((dynamic-require65_0) dynamic-require_3)" +"((module-declared?66_0) module-declared?_2)" +"((coerce67_0) coerce_2)" +"((coerce-key68_0) coerce-key_2)" +"((keep-comment?69_0) keep-comment?_3))" +"(make-read-config26.1" +" coerce67_0" +" #t" +" coerce-key68_0" +" #t" +" dynamic-require65_0" +" #t" +" for-syntax?62_0" +" #t" +" keep-comment?69_0" +" #t" +" module-declared?66_0" +" #t" +" next-readtable60_0" +" #t" +" read-compiled64_0" +" #t" +" readtable59_0" +" #t" +" source61_0" +" #t" +" wrap63_0" +" #t)))))))" +"(let-values(((v_133)(read-one init-c_6 in_21 config_54)))" +"(if(if(let-values(((or-part_347)(not recursive?_0)))" +"(if or-part_347 or-part_347 local-graph?_1))" +"(read-config-state-graph(read-config-st config_54))" +" #f)" +"(let-values()" +"(catch-and-reraise-as-reader/proc" +" #f" +" config_54" +"(lambda()(make-reader-graph v_133))))" +"(if(if recursive?_0" +"(if(not local-graph?_1)" +"(if(not for-syntax?_9)" +"(if(not(eof-object? v_133))(not(1/special-comment? v_133)) #f)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(begin(get-graph-hash config_54)(make-placeholder v_133)))" +"(let-values() v_133))))))))))))))))))))))))" +"(define-values" +"(read-language49.1)" +"(lambda(coerce38_0" +" coerce45_0" +" coerce-key39_0" +" coerce-key46_0" +" dynamic-require36_0" +" dynamic-require43_0" +" for-syntax?33_0" +" for-syntax?40_0" +" module-declared?37_0" +" module-declared?44_0" +" read-compiled35_0" +" read-compiled42_0" +" wrap34_0" +" wrap41_0" +" in47_0" +" fail-k48_0)" +"(begin" +" 'read-language49" +"(let-values(((in_58) in47_0))" +"(let-values(((fail-k_6) fail-k48_0))" +"(let-values(((for-syntax?_10)(if for-syntax?40_0 for-syntax?33_0 #f)))" +"(let-values(((wrap_8)(if wrap41_0 wrap34_0 #f)))" +"(let-values(((read-compiled_3)(if read-compiled42_0 read-compiled35_0 #f)))" +"(let-values(((dynamic-require_4)(if dynamic-require43_0 dynamic-require36_0 #f)))" +"(let-values(((module-declared?_3)(if module-declared?44_0 module-declared?37_0 #f)))" +"(let-values(((coerce_3)(if coerce45_0 coerce38_0 #f)))" +"(let-values(((coerce-key_3)(if coerce-key46_0 coerce-key39_0 #f)))" +"(let-values()" +"(let-values(((config_56)" +"(let-values(((temp70_2) #f)" +"((temp71_3) #f)" +"((for-syntax?72_0) for-syntax?_10)" +"((wrap73_0) wrap_8)" +"((read-compiled74_0) read-compiled_3)" +"((dynamic-require75_0) dynamic-require_4)" +"((module-declared?76_0) module-declared?_3)" +"((coerce77_0) coerce_3)" +"((coerce-key78_0) coerce-key_3))" +"(make-read-config26.1" +" coerce77_0" +" #t" +" coerce-key78_0" +" #t" +" dynamic-require75_0" +" #t" +" for-syntax?72_0" +" #t" +" #f" +" #f" +" module-declared?76_0" +" #t" +" temp71_3" +" #t" +" read-compiled74_0" +" #t" +" temp70_2" +" #t" +" #f" +" #f" +" wrap73_0" +" #t))))" +"(let-values(((l-config_1)(override-parameter 1/read-accept-reader config_56 #f)))" +"(read-language/get-info read-undotted in_58 config_56 fail-k_6))))))))))))))))" +"(define-values" +"(read-one)" +"(lambda(init-c_15 in_59 config_57)" +"(begin" +"(if(not(check-parameter 1/read-cdot config_57))" +"(let-values()(read-undotted init-c_15 in_59 config_57))" +"(if(check-parameter 1/read-cdot config_57)" +"(let-values()" +"(let-values(((line_10 col_9 pos_98)(port-next-location in_59)))" +"(let-values(((v_237)(read-undotted init-c_15 in_59 config_57)))" +"(if(1/special-comment? v_237)" +"(let-values() v_237)" +"(let-values()" +"((letrec-values(((loop_118)" +"(lambda(v_238)" +"(begin" +" 'loop" +"(let-values(((c_96)" +"(let-values(((in_60) in_59)" +"((skip-count_14) 0)" +"((source_42)(read-config-source config_57)))" +"(peek-char-or-special" +" in_60" +" skip-count_14" +" special1.1" +" source_42))))" +"(let-values(((ec_9)(effective-char c_96 config_57)))" +"(if(not(char? ec_9))" +"(let-values() v_238)" +"(if(char-whitespace? ec_9)" +"(let-values()(begin(consume-char in_59 c_96)(loop_118 v_238)))" +"(if(char=? ec_9 '#\\.)" +"(let-values()" +"(let-values(((dot-line_2 dot-col_2 dot-pos_5)" +"(port-next-location in_59)))" +"(let-values((()(begin(consume-char in_59 c_96)(values))))" +"(let-values(((cdot_0)" +"(wrap" +" '#%dot" +" in_59" +"(reading-at" +" config_57" +" dot-line_2" +" dot-col_2" +" dot-pos_5)" +" '#\\.)))" +"(let-values(((post-v_0)" +"(read-undotted #f in_59 config_57)))" +"(loop_118" +"(wrap" +"(list cdot_0 v_238 post-v_0)" +" in_59" +"(reading-at config_57 line_10 col_9 pos_98)" +" '#\\.)))))))" +"(let-values() v_238))))))))))" +" loop_118)" +" v_237))))))" +"(void))))))" +"(define-values" +"(read-undotted)" +"(lambda(init-c_16 in_61 config_58)" +"(begin" +"(let-values(((c_97)(read-char/skip-whitespace-and-comments init-c_16 read-one in_61 config_58)))" +"(let-values(((line_11 col_10 pos_117)(port-next-location* in_61 c_97)))" +"(if(eof-object? c_97)" +"(let-values() eof)" +"(if(not(char? c_97))" +"(let-values()" +"(let-values(((v_239)(special-value c_97)))" +"(if(1/special-comment? v_239)" +"(let-values()(if(read-config-keep-comment? config_58) v_239(read-undotted #f in_61 config_58)))" +"(let-values()(coerce v_239 in_61(reading-at config_58 line_11 col_10 pos_117))))))" +"(let-values(((c2_7)(readtable-handler config_58 c_97)))" +"(if c2_7" +"((lambda(handler_3)" +"(let-values(((v_240)(readtable-apply handler_3 c_97 in_61 config_58 line_11 col_10 pos_117)))" +"(retry-special-comment v_240 in_61 config_58)))" +" c2_7)" +"(let-values()" +"(let-values(((ec_10)(effective-char c_97 config_58)))" +"(let-values((()" +"(begin" +"(if(not(char-closer? ec_10 config_58))" +"(let-values()(track-indentation! config_58 line_11 col_10))" +"(void))" +"(values))))" +"(let-values(((r-config_0)(reading-at(discard-comment config_58) line_11 col_10 pos_117)))" +"(let-values(((tmp_55) ec_10))" +"(let-values(((index_4)" +"(if(char? tmp_55)" +"(let-values(((codepoint_2)(char->integer tmp_55)))" +"(if(if(unsafe-fx>= codepoint_2 34)(unsafe-fx< codepoint_2 126) #f)" +"(if(unsafe-fx< codepoint_2 91)" +"(if(unsafe-fx< codepoint_2 40)" +"(let-values(((tbl_2) '#(11 1 0 0 0 2)))" +"(unsafe-vector*-ref tbl_2(unsafe-fx- codepoint_2 34)))" +"(if(unsafe-fx< codepoint_2 42)" +"(let-values(((tbl_3) '#(5 6)))" +"(unsafe-vector*-ref tbl_3(unsafe-fx- codepoint_2 40)))" +"(if(unsafe-fx< codepoint_2 44)" +" 0" +"(if(unsafe-fx< codepoint_2 45) 4 0))))" +"(let-values(((tbl_4)" +" '#(7" +" 0" +" 8" +" 0" +" 0" +" 3" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 0" +" 9" +" 12" +" 10)))" +"(unsafe-vector*-ref tbl_4(unsafe-fx- codepoint_2 91))))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_4 6)" +"(if(unsafe-fx< index_4 2)" +"(if(unsafe-fx< index_4 1)" +"(let-values()" +"(let-values(((v_141)" +"(let-values(((temp82_4)" +"(if(let-values(((or-part_351)(eq? c_97 ec_10)))" +"(if or-part_351" +" or-part_351" +"(if(<(char->integer ec_10) 128)" +"(char-numeric? ec_10)" +" #f)))" +" 'symbol-or-number" +" 'symbol/indirect)))" +"(read-symbol-or-number8.1" +" #f" +" #f" +" temp82_4" +" #t" +" c_97" +" in_61" +" r-config_0))))" +"(retry-special-comment v_141 in_61 config_58)))" +"(let-values()(read-dispatch c_97 in_61 r-config_0 config_58)))" +"(if(unsafe-fx< index_4 3)" +" (let-values () (read-quote read-one 'quote \"quoting '\" c_97 in_61 r-config_0))" +"(if(unsafe-fx< index_4 4)" +"(let-values()" +"(if(check-parameter 1/read-accept-quasiquote config_58)" +"(let-values()" +" (read-quote read-one 'quasiquote \"quasiquoting `\" c_97 in_61 r-config_0))" +"(let-values()" +"(let-values(((in83_0) in_61)" +"((r-config84_0) r-config_0)" +" ((temp85_1) \"illegal use of `~a`\")" +"((c86_0) c_97))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in83_0" +" r-config84_0" +" temp85_1" +"(list c86_0))))))" +"(if(unsafe-fx< index_4 5)" +"(let-values()" +"(if(check-parameter 1/read-accept-quasiquote config_58)" +"(let-values()" +"(let-values(((c2_8)" +"(let-values(((in_62) in_61)" +"((skip-count_15) 0)" +"((source_43)(read-config-source config_58)))" +"(peek-char-or-special" +" in_62" +" skip-count_15" +" special1.1" +" source_43))))" +"(if(eqv? c2_8 '#\\@)" +"(begin" +"(consume-char in_61 c2_8)" +"(read-quote" +" read-one" +" 'unquote-splicing" +" \"unquoting ,@\"" +" c_97" +" in_61" +" r-config_0))" +" (read-quote read-one 'unquote \"unquoting ,\" c_97 in_61 r-config_0))))" +"(let-values()" +"(let-values(((in87_0) in_61)" +"((r-config88_0) r-config_0)" +" ((temp89_5) \"illegal use of `~a`\")" +"((c90_0) c_97))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in87_0" +" r-config88_0" +" temp89_5" +"(list c90_0))))))" +"(let-values()" +"(wrap" +"(let-values(((temp93_4) '#\\()" +"((temp94_3) '#\\))" +"((in95_0) in_61)" +"((r-config96_0) r-config_0)" +"((temp97_4) #t))" +"(read-unwrapped-sequence17.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp97_4" +" #t" +" #f" +" #f" +" read-one" +" ec_10" +" temp93_4" +" temp94_3" +" in95_0" +" r-config96_0))" +" in_61" +" r-config_0" +" ec_10))))))" +"(if(unsafe-fx< index_4 9)" +"(if(unsafe-fx< index_4 7)" +"(let-values()" +"(let-values(((in98_0) in_61)" +"((r-config99_0) r-config_0)" +" ((temp100_2) \"~a\")" +"((temp101_3)" +"(indentation-unexpected-closer-message ec_10 c_97 r-config_0)))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in98_0" +" r-config99_0" +" temp100_2" +"(list temp101_3))))" +"(if(unsafe-fx< index_4 8)" +"(let-values()" +"(if(let-values(((or-part_352)" +"(check-parameter 1/read-square-bracket-as-paren config_58)))" +"(if or-part_352" +" or-part_352" +"(check-parameter 1/read-square-bracket-with-tag config_58)))" +"(let-values()" +"(wrap" +"(let-values(((temp104_3) '#\\[)" +"((temp105_3) '#\\])" +"((in106_0) in_61)" +"((r-config107_0) r-config_0)" +"((temp108_4) #t))" +"(read-unwrapped-sequence17.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp108_4" +" #t" +" #f" +" #f" +" read-one" +" ec_10" +" temp104_3" +" temp105_3" +" in106_0" +" r-config107_0))" +" in_61" +" r-config_0" +" ec_10))" +"(let-values()" +"(let-values(((in109_0) in_61)" +"((r-config110_0) r-config_0)" +" ((temp111_2) \"illegal use of `~a`\")" +"((c112_0) c_97))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in109_0" +" r-config110_0" +" temp111_2" +"(list c112_0))))))" +"(let-values()" +"(if(let-values(((or-part_353)" +"(check-parameter 1/read-square-bracket-as-paren config_58)))" +"(if or-part_353" +" or-part_353" +"(check-parameter 1/read-square-bracket-with-tag config_58)))" +"(let-values()" +"(let-values(((in113_0) in_61)" +"((r-config114_0) r-config_0)" +" ((temp115_1) \"~a\")" +"((temp116_2)" +"(indentation-unexpected-closer-message" +" ec_10" +" c_97" +" r-config_0)))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in113_0" +" r-config114_0" +" temp115_1" +"(list temp116_2))))" +"(let-values()" +"(let-values(((in117_0) in_61)" +"((r-config118_0) r-config_0)" +" ((temp119_0) \"illegal use of `~a`\")" +"((c120_0) c_97))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in117_0" +" r-config118_0" +" temp119_0" +"(list c120_0))))))))" +"(if(unsafe-fx< index_4 10)" +"(let-values()" +"(if(let-values(((or-part_354)" +"(check-parameter 1/read-curly-brace-as-paren config_58)))" +"(if or-part_354" +" or-part_354" +"(check-parameter 1/read-curly-brace-with-tag config_58)))" +"(let-values()" +"(wrap" +"(let-values(((temp123_3) '#\\{)" +"((temp124_4) '#\\})" +"((in125_0) in_61)" +"((r-config126_0) r-config_0)" +"((temp127_4) #t))" +"(read-unwrapped-sequence17.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp127_4" +" #t" +" #f" +" #f" +" read-one" +" ec_10" +" temp123_3" +" temp124_4" +" in125_0" +" r-config126_0))" +" in_61" +" r-config_0" +" ec_10))" +"(let-values()" +"(let-values(((in128_0) in_61)" +"((r-config129_0) r-config_0)" +" ((temp130_3) \"illegal use of `~a`\")" +"((c131_0) c_97))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in128_0" +" r-config129_0" +" temp130_3" +"(list c131_0))))))" +"(if(unsafe-fx< index_4 11)" +"(let-values()" +"(if(let-values(((or-part_355)" +"(check-parameter 1/read-curly-brace-as-paren config_58)))" +"(if or-part_355" +" or-part_355" +"(check-parameter 1/read-curly-brace-with-tag config_58)))" +"(let-values()" +"(let-values(((in132_0) in_61)" +"((r-config133_0) r-config_0)" +" ((temp134_2) \"~a\")" +"((temp135_1)" +"(indentation-unexpected-closer-message" +" ec_10" +" c_97" +" r-config_0)))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in132_0" +" r-config133_0" +" temp134_2" +"(list temp135_1))))" +"(let-values()" +"(let-values(((in136_0) in_61)" +"((r-config137_0) r-config_0)" +" ((temp138_2) \"illegal use of `~a`\")" +"((c139_0) c_97))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in136_0" +" r-config137_0" +" temp138_2" +"(list c139_0))))))" +"(if(unsafe-fx< index_4 12)" +"(let-values()" +"(let-values(((in140_0) in_61)((r-config141_0) r-config_0))" +"(read-string5.1 #f #f in140_0 r-config141_0)))" +"(let-values()" +"(let-values(((temp145_1) 'symbol))" +"(read-symbol-or-number8.1" +" #f" +" #f" +" temp145_1" +" #t" +" c_97" +" in_61" +" r-config_0)))))))))))))))))))))))" +"(define-values" +"(read-dispatch)" +"(lambda(dispatch-c_5 in_63 config_59 orig-config_0)" +"(begin" +"(let-values(((c_98)" +"(let-values(((in_64) in_63)((source_44)(read-config-source config_59)))" +"(read-char-or-special in_64 special1.1 source_44))))" +"(if(eof-object? c_98)" +"(let-values()" +" (let-values (((c148_0) c_98) ((temp149_0) \"bad syntax `~a`\") ((dispatch-c150_0) dispatch-c_5))" +"(reader-error10.1 #f #f c148_0 #t #f #f in_63 config_59 temp149_0(list dispatch-c150_0))))" +"(if(not(char? c_98))" +"(let-values()" +" (let-values (((c153_0) c_98) ((temp154_1) \"bad syntax `~a`\") ((dispatch-c155_0) dispatch-c_5))" +"(reader-error10.1 #f #f c153_0 #t #f #f in_63 config_59 temp154_1(list dispatch-c155_0))))" +"(let-values(((c3_8)(readtable-dispatch-handler orig-config_0 c_98)))" +"(if c3_8" +"((lambda(handler_4)" +"(let-values(((line_12)(read-config-line config_59)))" +"(let-values(((col_11)(read-config-col config_59)))" +"(let-values(((pos_118)(read-config-pos config_59)))" +"(let-values(((v_144)(readtable-apply handler_4 c_98 in_63 config_59 line_12 col_11 pos_118)))" +"(retry-special-comment v_144 in_63 orig-config_0))))))" +" c3_8)" +"(let-values()" +"(let-values()" +"(let-values(((tmp_56) c_98))" +"(let-values(((index_5)" +"(if(char? tmp_56)" +"(let-values(((codepoint_3)(char->integer tmp_56)))" +"(if(if(unsafe-fx>= codepoint_3 33)(unsafe-fx< codepoint_3 127) #f)" +"(let-values(((tbl_5)" +" '#(34" +" 11" +" 0" +" 0" +" 13" +" 6" +" 7" +" 2" +" 0" +" 0" +" 0" +" 9" +" 0" +" 0" +" 0" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 1" +" 14" +" 0" +" 12" +" 0" +" 0" +" 0" +" 0" +" 0" +" 22" +" 29" +" 25" +" 18" +" 16" +" 0" +" 30" +" 20" +" 0" +" 0" +" 0" +" 0" +" 0" +" 24" +" 0" +" 0" +" 0" +" 0" +" 15" +" 0" +" 0" +" 0" +" 28" +" 0" +" 0" +" 3" +" 10" +" 0" +" 0" +" 0" +" 8" +" 0" +" 26" +" 29" +" 21" +" 17" +" 16" +" 0" +" 30" +" 19" +" 0" +" 0" +" 33" +" 0" +" 0" +" 23" +" 32" +" 0" +" 31" +" 5" +" 15" +" 0" +" 0" +" 0" +" 27" +" 0" +" 0" +" 4" +" 0" +" 0" +" 35)))" +"(unsafe-vector*-ref tbl_5(unsafe-fx- codepoint_3 33)))" +" 0))" +" 0)))" +"(if(unsafe-fx< index_5 17)" +"(if(unsafe-fx< index_5 8)" +"(if(unsafe-fx< index_5 3)" +"(if(unsafe-fx< index_5 1)" +"(let-values()" +"(let-values(((in156_0) in_63)" +"((config157_0) config_59)" +" ((temp158_1) \"bad syntax `~a~a`\")" +"((dispatch-c159_0) dispatch-c_5)" +"((c160_0) c_98))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in156_0" +" config157_0" +" temp158_1" +"(list dispatch-c159_0 c160_0))))" +"(if(unsafe-fx< index_5 2)" +"(let-values()(read-vector-or-graph read-one dispatch-c_5 c_98 in_63 config_59))" +"(let-values()" +"(let-values(((read-one161_0) read-one)" +"((temp162_2) '#\\()" +"((temp163_1) '#\\()" +"((temp164_0) '#\\))" +"((in165_0) in_63)" +"((config166_0) config_59))" +"(read-vector11.1" +" #f" +" #f" +" #f" +" #f" +" read-one161_0" +" temp162_2" +" temp163_1" +" temp164_0" +" in165_0" +" config166_0)))))" +"(if(unsafe-fx< index_5 5)" +"(if(unsafe-fx< index_5 4)" +"(let-values()" +"(if(check-parameter 1/read-square-bracket-as-paren config_59)" +"(let-values()" +"(let-values(((read-one167_0) read-one)" +"((temp168_0) '#\\[)" +"((temp169_0) '#\\[)" +"((temp170_2) '#\\])" +"((in171_0) in_63)" +"((config172_0) config_59))" +"(read-vector11.1" +" #f" +" #f" +" #f" +" #f" +" read-one167_0" +" temp168_0" +" temp169_0" +" temp170_2" +" in171_0" +" config172_0)))" +"(let-values()" +"(let-values(((in173_0) in_63)" +"((config174_0) config_59)" +" ((temp175_0) (format \"~a~a\" dispatch-c_5 c_98)))" +"(bad-syntax-error18.1 #f #f in173_0 config174_0 temp175_0)))))" +"(let-values()" +"(if(check-parameter 1/read-curly-brace-as-paren config_59)" +"(let-values()" +"(let-values(((read-one176_0) read-one)" +"((temp177_0) '#\\{)" +"((temp178_0) '#\\{)" +"((temp179_0) '#\\})" +"((in180_0) in_63)" +"((config181_0) config_59))" +"(read-vector11.1" +" #f" +" #f" +" #f" +" #f" +" read-one176_0" +" temp177_0" +" temp178_0" +" temp179_0" +" in180_0" +" config181_0)))" +"(let-values()" +"(let-values(((in182_0) in_63)" +"((config183_0) config_59)" +" ((temp184_0) (format \"~a~a\" dispatch-c_5 c_98)))" +"(bad-syntax-error18.1 #f #f in182_0 config183_0 temp184_0))))))" +"(if(unsafe-fx< index_5 6)" +"(let-values()(read-struct read-one dispatch-c_5 in_63 config_59))" +"(if(unsafe-fx< index_5 7)" +"(let-values()(read-box read-one dispatch-c_5 in_63 config_59))" +" (let-values () (read-quote read-one 'syntax \"quoting #'\" c_98 in_63 config_59))))))" +"(if(unsafe-fx< index_5 12)" +"(if(unsafe-fx< index_5 9)" +"(let-values()" +" (read-quote read-one 'quasisyntax \"quasiquoting #`\" c_98 in_63 config_59))" +"(if(unsafe-fx< index_5 10)" +"(let-values()" +"(let-values(((c2_9)" +"(let-values(((in_65) in_63)" +"((skip-count_16) 0)" +"((source_45)(read-config-source config_59)))" +"(peek-char-or-special in_65 skip-count_16 special1.1 source_45))))" +"(if(eqv? c2_9 '#\\@)" +"(begin" +"(consume-char in_63 c2_9)" +" (read-quote read-one 'unsyntax-splicing \"unquoting #,@\" c_98 in_63 config_59))" +" (read-quote read-one 'unsyntax \"unquoting #,\" c_98 in_63 config_59))))" +"(if(unsafe-fx< index_5 11)" +"(let-values()(read-character in_63 config_59))" +"(let-values()" +"(let-values(((temp187_1) '|byte string|))" +"(read-string5.1 temp187_1 #t in_63 config_59))))))" +"(if(unsafe-fx< index_5 14)" +"(if(unsafe-fx< index_5 13)" +"(let-values()" +"(let-values(((c2_10)" +"(let-values(((in_66) in_63)" +"((skip-count_17) 0)" +"((source_46)(read-config-source config_59)))" +"(peek-char-or-special in_66 skip-count_17 special1.1 source_46))))" +"(if(eqv? '#\\< c2_10)" +"(let-values()" +"(begin(consume-char in_63 '#\\<)(read-here-string in_63 config_59)))" +"(let-values()" +"(let-values(((c2190_0) c2_10)" +" ((temp191_1) \"bad syntax `~a<`\")" +"((dispatch-c192_0) dispatch-c_5))" +"(reader-error10.1" +" #f" +" #f" +" c2190_0" +" #t" +" #f" +" #f" +" in_63" +" config_59" +" temp191_1" +"(list dispatch-c192_0)))))))" +"(let-values()" +"(let-values(((dispatch-c196_0) dispatch-c_5)((temp197_0) 'symbol))" +"(read-symbol-or-number8.1 dispatch-c196_0 #t temp197_0 #t c_98 in_63 config_59))))" +"(if(unsafe-fx< index_5 15)" +"(let-values()" +"(let-values(((temp198_0) #f)" +"((in199_0) in_63)" +"((config200_0) config_59)" +"((temp201_0) 'keyword))" +"(read-symbol-or-number8.1 #f #f temp201_0 #t temp198_0 in199_0 config200_0)))" +"(if(unsafe-fx< index_5 16)" +"(let-values()" +"(let-values(((c2_11)" +"(let-values(((in_67) in_63)" +"((skip-count_18) 0)" +"((source_47)(read-config-source config_59)))" +"(peek-char-or-special in_67 skip-count_18 special1.1 source_47))))" +"(if(char-delimiter? c2_11 config_59)" +"(let-values()(wrap #t in_63 config_59 c_98))" +"(let-values()" +"(read-delimited-constant" +" c_98" +"(char=? c_98 '#\\t)" +" '(#\\r #\\u #\\e)" +" #t" +" in_63" +" config_59)))))" +"(let-values()" +"(let-values(((c2_12)" +"(let-values(((in_68) in_63)" +"((skip-count_19) 0)" +"((source_48)(read-config-source config_59)))" +"(peek-char-or-special in_68 skip-count_19 special1.1 source_48))))" +"(if(char-delimiter? c2_12 config_59)" +"(let-values()(wrap #f in_63 config_59 c_98))" +"(if(let-values(((or-part_356)(char=? c2_12 '#\\x)))" +"(if or-part_356 or-part_356(char=? c2_12 '#\\l)))" +"(let-values()" +"(read-fixnum-or-flonum-vector" +" read-one" +" dispatch-c_5" +" c_98" +" c2_12" +" in_63" +" config_59))" +"(let-values()" +"(read-delimited-constant" +" c_98" +"(char=? c_98 '#\\f)" +" '(#\\a #\\l #\\s #\\e)" +" #f" +" in_63" +" config_59)))))))))))" +"(if(unsafe-fx< index_5 26)" +"(if(unsafe-fx< index_5 21)" +"(if(unsafe-fx< index_5 18)" +"(let-values()" +"(let-values(((temp202_0) #f)" +"((in203_0) in_63)" +"((config204_0) config_59)" +" ((temp205_0) \"#e\"))" +"(read-symbol-or-number8.1 #f #f temp205_0 #t temp202_0 in203_0 config204_0)))" +"(if(unsafe-fx< index_5 19)" +"(let-values()" +"(let-values(((temp206_0) #f)" +"((in207_0) in_63)" +"((config208_0) config_59)" +" ((temp209_0) \"#E\"))" +"(read-symbol-or-number8.1 #f #f temp209_0 #t temp206_0 in207_0 config208_0)))" +"(if(unsafe-fx< index_5 20)" +"(let-values()" +"(let-values(((temp210_0) #f)" +"((in211_0) in_63)" +"((config212_0) config_59)" +" ((temp213_0) \"#i\"))" +"(read-symbol-or-number8.1 #f #f temp213_0 #t temp210_0 in211_0 config212_0)))" +"(let-values()" +"(let-values(((temp214_0) #f)" +"((in215_0) in_63)" +"((config216_0) config_59)" +" ((temp217_0) \"#I\"))" +"(read-symbol-or-number8.1 #f #f temp217_0 #t temp214_0 in215_0 config216_0))))))" +"(if(unsafe-fx< index_5 23)" +"(if(unsafe-fx< index_5 22)" +"(let-values()" +"(let-values(((temp218_0) #f)" +"((in219_0) in_63)" +"((config220_0) config_59)" +" ((temp221_1) \"#d\"))" +"(read-symbol-or-number8.1 #f #f temp221_1 #t temp218_0 in219_0 config220_0)))" +"(let-values()" +"(let-values(((temp222_0) #f)" +"((in223_0) in_63)" +"((config224_0) config_59)" +" ((temp225_1) \"#B\"))" +"(read-symbol-or-number8.1 #f #f temp225_1 #t temp222_0 in223_0 config224_0))))" +"(if(unsafe-fx< index_5 24)" +"(let-values()" +"(let-values(((temp226_1) #f)" +"((in227_0) in_63)" +"((config228_0) config_59)" +" ((temp229_1) \"#o\"))" +"(read-symbol-or-number8.1 #f #f temp229_1 #t temp226_1 in227_0 config228_0)))" +"(if(unsafe-fx< index_5 25)" +"(let-values()" +"(let-values(((temp230_0) #f)" +"((in231_0) in_63)" +"((config232_0) config_59)" +" ((temp233_1) \"#O\"))" +"(read-symbol-or-number8.1 #f #f temp233_1 #t temp230_0 in231_0 config232_0)))" +"(let-values()" +"(let-values(((temp234_0) #f)" +"((in235_0) in_63)" +"((config236_0) config_59)" +" ((temp237_1) \"#D\"))" +"(read-symbol-or-number8.1" +" #f" +" #f" +" temp237_1" +" #t" +" temp234_0" +" in235_0" +" config236_0)))))))" +"(if(unsafe-fx< index_5 30)" +"(if(unsafe-fx< index_5 27)" +"(let-values()" +"(let-values(((temp238_0) #f)" +"((in239_0) in_63)" +"((config240_0) config_59)" +" ((temp241_1) \"#b\"))" +"(read-symbol-or-number8.1 #f #f temp241_1 #t temp238_0 in239_0 config240_0)))" +"(if(unsafe-fx< index_5 28)" +"(let-values()" +"(let-values(((temp242_0) #f)" +"((in243_0) in_63)" +"((config244_0) config_59)" +" ((temp245_0) \"#x\"))" +"(read-symbol-or-number8.1 #f #f temp245_0 #t temp242_0 in243_0 config244_0)))" +"(if(unsafe-fx< index_5 29)" +"(let-values()" +"(let-values(((temp246_0) #f)" +"((in247_0) in_63)" +"((config248_0) config_59)" +" ((temp249_0) \"#X\"))" +"(read-symbol-or-number8.1 #f #f temp249_0 #t temp246_0 in247_0 config248_0)))" +"(let-values()" +"(let-values(((c2_13)" +"(let-values(((in_69) in_63)" +"((source_49)(read-config-source config_59)))" +"(read-char-or-special in_69 special1.1 source_49))))" +"(let-values(((tmp_57) c2_13))" +"(if(if(equal? tmp_57 '#\\s) #t(equal? tmp_57 '#\\S))" +"(let-values()" +"(read-one #f in_63(override-parameter read-case-sensitive config_59 #t)))" +"(if(if(equal? tmp_57 '#\\i) #t(equal? tmp_57 '#\\I))" +"(let-values()" +"(read-one" +" #f" +" in_63" +"(override-parameter read-case-sensitive config_59 #f)))" +"(let-values()" +"(let-values(((c2252_0) c2_13)" +" ((temp253_0) \"expected `s', `S`, `i', or `I` after `~a~a`\")" +"((dispatch-c254_0) dispatch-c_5)" +"((c255_0) c_98))" +"(reader-error10.1" +" #f" +" #f" +" c2252_0" +" #t" +" #f" +" #f" +" in_63" +" config_59" +" temp253_0" +"(list dispatch-c254_0 c255_0))))))))))))" +"(if(unsafe-fx< index_5 32)" +"(if(unsafe-fx< index_5 31)" +"(let-values()(read-hash read-one dispatch-c_5 c_98 in_63 config_59))" +"(let-values()" +"(let-values(((accum-str_12)(accum-string-init! config_59)))" +"(let-values((()(begin(accum-string-add! accum-str_12 dispatch-c_5)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_12 c_98)(values))))" +"(let-values(((c2_14)" +"(let-values(((in_70) in_63)" +"((source_50)(read-config-source config_59)))" +"(read-char-or-special in_70 special1.1 source_50))))" +"(begin" +"(if(char? c2_14)" +"(let-values()(accum-string-add! accum-str_12 c2_14))" +"(void))" +"(let-values(((tmp_58) c2_14))" +"(if(equal? tmp_58 '#\\x)" +"(let-values()(read-regexp c_98 accum-str_12 in_63 config_59))" +"(if(equal? tmp_58 '#\\e)" +"(let-values()" +"(read-extension-reader" +" read-one" +" read-undotted" +" dispatch-c_5" +" in_63" +" config_59))" +"(let-values()" +"(let-values(((c2258_0) c2_14)" +"((temp259_0)" +"(let-values(((accum-str260_0) accum-str_12)" +"((config261_0) config_59))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str260_0" +" config261_0))))" +"(bad-syntax-error18.1" +" c2258_0" +" #t" +" in_63" +" config_59" +" temp259_0)))))))))))))" +"(if(unsafe-fx< index_5 33)" +"(let-values()" +"(let-values(((accum-str_13)(accum-string-init! config_59)))" +"(let-values((()(begin(accum-string-add! accum-str_13 dispatch-c_5)(values))))" +"(let-values((()(begin(accum-string-add! accum-str_13 c_98)(values))))" +"(let-values(((c2_15)" +"(let-values(((in_71) in_63)" +"((source_51)(read-config-source config_59)))" +"(read-char-or-special in_71 special1.1 source_51))))" +"(begin" +"(if(char? c2_15)" +"(let-values()(accum-string-add! accum-str_13 c2_15))" +"(void))" +"(let-values(((tmp_59) c2_15))" +"(if(equal? tmp_59 '#\\x)" +"(let-values()(read-regexp c_98 accum-str_13 in_63 config_59))" +"(let-values()" +"(let-values(((c2264_0) c2_15)" +"((temp265_0)" +"(let-values(((accum-str266_0) accum-str_13)" +"((config267_0) config_59))" +"(accum-string-get!6.1" +" #f" +" #f" +" accum-str266_0" +" config267_0))))" +"(bad-syntax-error18.1" +" c2264_0" +" #t" +" in_63" +" config_59" +" temp265_0)))))))))))" +"(if(unsafe-fx< index_5 34)" +"(let-values()" +"(let-values(((read-undotted268_0) read-undotted)" +"((dispatch-c269_0) dispatch-c_5)" +"((in270_0) in_63)" +"((config271_0) config_59))" +"(read-extension-lang7.1" +" #f" +" #f" +" read-undotted268_0" +" dispatch-c269_0" +" in270_0" +" config271_0)))" +"(if(unsafe-fx< index_5 35)" +"(let-values()" +"(let-values(((read-undotted272_0) read-undotted)" +"((dispatch-c273_0) dispatch-c_5)" +"((in274_0) in_63)" +"((config275_0) config_59))" +"(read-extension-#!16.1" +" #f" +" #f" +" read-undotted272_0" +" dispatch-c273_0" +" in274_0" +" config275_0)))" +"(let-values()" +"(if(check-parameter 1/read-accept-compiled config_59)" +"(let-values()" +"(wrap((read-config-read-compiled config_59) in_63) in_63 config_59 c_98))" +"(let-values()" +"(let-values(((in276_0) in_63)" +"((config277_0) config_59)" +" ((temp278_0) \"`~a~~` compiled expressions not enabled\")" +"((dispatch-c279_0) dispatch-c_5))" +"(reader-error10.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" in276_0" +" config277_0" +" temp278_0" +"(list dispatch-c279_0)))))))))))))))))))))))))" +"(define-values" +"(retry-special-comment)" +"(lambda(v_241 in_72 config_60)" +"(begin" +"(if(1/special-comment? v_241)" +"(let-values()(if(read-config-keep-comment? config_60) v_241(read-undotted #f in_72 config_60)))" +"(let-values() v_241)))))" +"(define-values" +"(1/module-declared?)" +"(let-values(((module-declared?4_0)" +"(lambda(mod3_0 load?1_0 load?2_0)" +"(begin" +" 'module-declared?4" +"(let-values(((mod_4) mod3_0))" +"(let-values(((load?_3)(if load?2_0 load?1_0 #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(module-reference? mod_4)" +"(void)" +"(let-values()" +"(raise-argument-error 'module-declared? module-reference-str mod_4)))" +"(values))))" +"(let-values(((ns_110)(1/current-namespace)))" +"(let-values(((name_68)" +"(let-values(((load?36_0) load?_3))" +"(reference->resolved-module-path32.1 load?36_0 mod_4))))" +"(if(namespace->module ns_110 name_68) #t #f)))))))))))" +"(case-lambda" +"((mod_5)(begin 'module-declared?(module-declared?4_0 mod_5 #f #f)))" +"((mod_6 load?1_1)(module-declared?4_0 mod_6 load?1_1 #t)))))" +"(define-values" +"(1/module-predefined?)" +"(lambda(mod_7)" +"(begin" +" 'module-predefined?" +"(let-values((()" +"(begin" +"(if(module-reference? mod_7)" +"(void)" +"(let-values()(raise-argument-error 'module-predefined? module-reference-str mod_7)))" +"(values))))" +"(let-values(((ns_54)(1/current-namespace)))" +"(let-values(((name_0)(let-values(((temp38_2) #f))(reference->resolved-module-path32.1 temp38_2 mod_7))))" +"(let-values(((m_24)(namespace->module ns_54 name_0)))(if m_24(module-is-predefined? m_24) #f))))))))" +"(define-values" +"(module->)" +"(let-values(((module->11_0)" +"(lambda(extract8_0 who9_0 mod10_0 load?6_0 load?7_0)" +"(begin" +" 'module->11" +"(let-values(((extract_1) extract8_0))" +"(let-values(((who_29) who9_0))" +"(let-values(((mod_8) mod10_0))" +"(let-values(((load?_4)(if load?7_0 load?6_0 #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(module-reference? mod_8)" +"(void)" +"(let-values()" +"(raise-argument-error who_29 module-reference-str mod_8)))" +"(values))))" +"(let-values(((m_25)" +"(namespace->module/complain" +" who_29" +"(1/current-namespace)" +"(let-values(((load?40_0) load?_4))" +"(reference->resolved-module-path32.1 load?40_0 mod_8)))))" +"(extract_1 m_25))))))))))))" +"(case-lambda" +"((extract_2 who_30 mod_9)(begin(module->11_0 extract_2 who_30 mod_9 #f #f)))" +"((extract_3 who_31 mod_10 load?6_1)(module->11_0 extract_3 who_31 mod_10 load?6_1 #t)))))" +"(define-values" +"(1/module->language-info)" +"(let-values(((module->language-info16_0)" +"(lambda(mod15_0 load?13_0 load?14_0)" +"(begin" +" 'module->language-info16" +"(let-values(((mod_11) mod15_0))" +"(let-values(((load?_5)(if load?14_0 load?13_0 #f)))" +"(let-values()(module-> module-language-info 'module->language-info mod_11 load?_5))))))))" +"(case-lambda" +"((mod_12)(begin 'module->language-info(module->language-info16_0 mod_12 #f #f)))" +"((mod_13 load?13_1)(module->language-info16_0 mod_13 load?13_1 #t)))))" +"(define-values" +"(1/module->imports)" +"(lambda(mod_14)(begin 'module->imports(module-> module-requires 'module->imports mod_14))))" +"(define-values" +"(1/module->exports)" +"(lambda(mod_15)" +"(begin" +" 'module->exports" +"(let-values(((provides_12 self_26)" +"(module->" +"(lambda(m_26)(values(module-provides m_26)(module-self m_26)))" +" 'module->exports" +" mod_15)))" +"(provides->api-provides provides_12 self_26)))))" +"(define-values" +"(1/module->indirect-exports)" +"(lambda(mod_16)" +"(begin" +" 'module->indirect-exports" +"(module->" +"(lambda(m_27)(variables->api-nonprovides(module-provides m_27)((module-get-all-variables m_27))))" +" 'module->indirect-exports" +" mod_16))))" +"(define-values" +"(1/module-provide-protected?)" +"(lambda(mod_17 sym_90)" +"(begin" +" 'module-provide-protected?" +"(module->" +"(lambda(m_28)" +"(let-values(((b/p_3)(hash-ref(module-provides m_28) sym_90 #f)))" +"(let-values(((or-part_168)(not b/p_3)))(if or-part_168 or-part_168(provided-as-protected? b/p_3)))))" +" 'module-provide-protected?" +" mod_17))))" +"(define-values" +"(1/module->namespace)" +"(let-values(((module->namespace21_0)" +"(lambda(mod20_0 ns18_1 ns19_0)" +"(begin" +" 'module->namespace21" +"(let-values(((mod_18) mod20_0))" +"(let-values(((ns_111)(if ns19_0 ns18_1(1/current-namespace))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(module-reference? mod_18)" +"(void)" +"(let-values()" +"(raise-argument-error 'module->namespace module-reference-str mod_18)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_111)" +"(void)" +"(let-values()" +" (raise-argument-error 'module->namespace \"namespace?\" ns_111)))" +"(values))))" +"(let-values(((name_41)" +"(let-values(((temp45_1) #t))" +"(reference->resolved-module-path32.1 temp45_1 mod_18))))" +"(let-values(((phase_94)(namespace-phase ns_111)))" +"(let-values(((m-ns_17)" +"(let-values(((ns46_0) ns_111)" +"((name47_1) name_41)" +"((phase48_0) phase_94))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns46_0" +" name47_1" +" phase48_0))))" +"(begin" +"(if m-ns_17" +"(void)" +"(let-values()" +"(begin" +"(namespace->module/complain 'module->namespace ns_111 name_41)" +"(raise-arguments-error" +" 'module->namespace" +" \"module not instantiated in the current namespace\"" +" \"name\"" +" name_41))))" +"(if(inspector-superior?(current-code-inspector)(namespace-inspector m-ns_17))" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'module->namespace" +" \"current code inspector cannot access namespace of module\"" +" \"module name\"" +" name_41)))" +"(if(namespace-get-root-expand-ctx m-ns_17)" +"(void)" +"(let-values()" +"(namespace-set-root-expand-ctx!" +" m-ns_17" +"(let-values()(make-root-expand-context11.1 #f #f #f #f #f #f #f #f)))))" +"(let-values(((ns41_2) ns_111)" +"((temp42_4)(namespace-mpi m-ns_17))" +"((phase43_2) phase_94))" +"(namespace-module-make-available!112.1 #f #f ns41_2 temp42_4 phase43_2))" +" m-ns_17)))))))))))))" +"(case-lambda" +"((mod_19)(begin 'module->namespace(module->namespace21_0 mod_19 #f #f)))" +"((mod_20 ns18_2)(module->namespace21_0 mod_20 ns18_2 #t)))))" +"(define-values" +"(1/namespace-unprotect-module)" +"(let-values(((namespace-unprotect-module27_0)" +"(lambda(insp25_0 mod26_0 ns23_0 ns24_1)" +"(begin" +" 'namespace-unprotect-module27" +"(let-values(((insp_18) insp25_0))" +"(let-values(((mod_21) mod26_0))" +"(let-values(((ns_112)(if ns24_1 ns23_0(1/current-namespace))))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(inspector? insp_18)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-unprotect-module" +" \"inspector?\"" +" insp_18)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/module-path? mod_21)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-unprotect-module" +" \"module-path?\"" +" mod_21)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(1/namespace? ns_112)" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'namespace-unprotect-module" +" \"namespace?\"" +" ns_112)))" +"(values))))" +"(let-values(((name_69)" +"(let-values(((temp50_4) #f))" +"(reference->resolved-module-path32.1 temp50_4 mod_21))))" +"(let-values(((phase_95)(namespace-phase ns_112)))" +"(let-values(((m-ns_18)" +"(let-values(((ns51_1) ns_112)" +"((name52_0) name_69)" +"((phase53_0) phase_95))" +"(namespace->module-namespace82.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ns51_1" +" name52_0" +" phase53_0))))" +"(begin" +"(if m-ns_18" +"(void)" +"(let-values()" +"(raise-arguments-error" +" 'namespace-unprotect-module" +" \"module not instantiated\"" +" \"module name\"" +" name_69)))" +"(if(inspector-superior? insp_18(namespace-inspector m-ns_18))" +"(let-values()" +"(set-namespace-inspector!" +" m-ns_18" +"(make-inspector(current-code-inspector))))" +"(void)))))))))))))))))" +"(case-lambda" +"((insp_12 mod_22)(begin 'namespace-unprotect-module(namespace-unprotect-module27_0 insp_12 mod_22 #f #f)))" +"((insp_19 mod_23 ns23_1)(namespace-unprotect-module27_0 insp_19 mod_23 ns23_1 #t)))))" +"(define-values" +"(namespace->module/complain)" +"(lambda(who_32 ns_113 name_62)" +"(begin" +"(let-values(((or-part_25)(namespace->module ns_113 name_62)))" +"(if or-part_25" +" or-part_25" +" (raise-arguments-error who_32 \"unknown module in the current namespace\" \"name\" name_62))))))" +"(define-values" +"(module-reference?)" +"(lambda(mod_24)" +"(begin" +"(let-values(((or-part_357)(1/module-path? mod_24)))" +"(if or-part_357" +" or-part_357" +"(let-values(((or-part_255)(1/module-path-index? mod_24)))" +"(if or-part_255 or-part_255(1/resolved-module-path? mod_24))))))))" +" (define-values (module-reference-str) \"(or/c module-path? module-path-index? resolved-module-path?)\")" +"(define-values" +"(reference->resolved-module-path32.1)" +"(lambda(load?29_0 mod31_0)" +"(begin" +" 'reference->resolved-module-path32" +"(let-values(((mod_25) mod31_0))" +"(let-values(((load?_6) load?29_0))" +"(let-values()" +"(if(1/resolved-module-path? mod_25)" +"(let-values() mod_25)" +"(let-values()" +"(let-values(((mpi_46)(if(1/module-path-index? mod_25) mod_25(1/module-path-index-join mod_25 #f))))" +"(1/module-path-index-resolve mpi_46 load?_6))))))))))" +"(define-values" +"(read-syntax$1)" +"(lambda(src_0 in_73)" +"(begin" +" 'read-syntax" +"(if(default-read-handler? in_73)" +"(let-values()" +"(begin" +"(maybe-flush-stdout in_73)" +"(let-values(((temp24_11) #t)((src25_0) src_0))" +"(read*14.1 temp24_11 #f #f #f #f #f #f #f #f src25_0 #t in_73))))" +"(let-values()(values((port-read-handler in_73) in_73 src_0)))))))" +"(define-values" +"(read-syntax/recursive$1)" +"(lambda(src_1 in_49 start_42 readtable_4 graph?_1)" +"(begin" +" 'read-syntax/recursive" +"(let-values(((temp27_8) #t)" +"((temp28_4) #t)" +"((src29_0) src_1)" +"((start30_0) start_42)" +"((readtable31_1) readtable_4)" +"((temp32_4)(not graph?_1)))" +"(read*14.1 temp27_8 start30_0 #t temp32_4 #t readtable31_1 #t temp28_4 #t src29_0 #t in_49)))))" +"(define-values" +"(read$1)" +"(lambda(in_10)" +"(begin" +" 'read" +"(if(default-read-handler? in_10)" +"(let-values()" +"(begin" +"(maybe-flush-stdout in_10)" +"(let-values(((temp34_3) #f))(read*14.1 temp34_3 #f #f #f #f #f #f #f #f #f #f in_10))))" +"(let-values()(values((port-read-handler in_10) in_10)))))))" +"(define-values" +"(read/recursive$1)" +"(lambda(in_74 start_58 readtable_5 graph?_2)" +"(begin" +" 'read/recursive" +"(let-values(((temp36_6) #f)" +"((temp37_3) #t)" +"((start38_0) start_58)" +"((readtable39_0) readtable_5)" +"((temp40_3)(not graph?_2)))" +"(read*14.1 temp36_6 start38_0 #t temp40_3 #t readtable39_0 #t temp37_3 #t #f #f in_74)))))" +"(define-values" +"(read*14.1)" +"(lambda(for-syntax?1_0" +" init-c4_0" +" init-c10_0" +" local-graph?6_1" +" local-graph?12_0" +" readtable5_0" +" readtable11_0" +" recursive?2_0" +" recursive?8_0" +" source3_0" +" source9_0" +" in13_1)" +"(begin" +" 'read*14" +"(let-values(((in_14) in13_1))" +"(let-values(((for-syntax?_11) for-syntax?1_0))" +"(let-values(((recursive?_1)(if recursive?8_0 recursive?2_0 #f)))" +"(let-values(((source_34)(if source9_0 source3_0 #f)))" +"(let-values(((init-c_17)(if init-c10_0 init-c4_0 #f)))" +"(let-values(((readtable_6)(if readtable11_0 readtable5_0(1/current-readtable))))" +"(let-values(((local-graph?_2)(if local-graph?12_0 local-graph?6_1 #f)))" +"(let-values()" +"(let-values()" +"(let-values(((for-syntax?42_0) for-syntax?_11)" +"((recursive?43_0) recursive?_1)" +"((source44_0) source_34)" +"((temp45_2)(if for-syntax?_11 read-to-syntax #f))" +"((init-c46_0) init-c_17)" +"((readtable47_0) readtable_6)" +"((local-graph?48_0) local-graph?_2)" +"((read-compiled-linklet49_0) 1/read-compiled-linklet)" +"((dynamic-require-reader50_0) dynamic-require-reader)" +"((read-module-declared?51_0) read-module-declared?)" +"((read-coerce52_0) read-coerce)" +"((read-coerce-key53_0) read-coerce-key))" +"(read30.1" +" read-coerce52_0" +" #t" +" read-coerce-key53_0" +" #t" +" dynamic-require-reader50_0" +" #t" +" for-syntax?42_0" +" #t" +" init-c46_0" +" #t" +" #f" +" #f" +" local-graph?48_0" +" #t" +" read-module-declared?51_0" +" #t" +" #f" +" #f" +" read-compiled-linklet49_0" +" #t" +" readtable47_0" +" #t" +" recursive?43_0" +" #t" +" source44_0" +" #t" +" temp45_2" +" #t" +" in_14))))))))))))))" +"(define-values" +"(read-language$1)" +"(lambda(in_75 fail-thunk_0)" +"(begin" +" 'read-language" +"(let-values(((temp56_1) #t)" +"((read-to-syntax57_0) read-to-syntax)" +"((read-compiled-linklet58_0) 1/read-compiled-linklet)" +"((dynamic-require-reader59_0) dynamic-require-reader)" +"((read-module-declared?60_0) read-module-declared?)" +"((read-coerce61_0) read-coerce)" +"((read-coerce-key62_0) read-coerce-key))" +"(read-language49.1" +" read-coerce61_0" +" #t" +" read-coerce-key62_0" +" #t" +" dynamic-require-reader59_0" +" #t" +" temp56_1" +" #t" +" read-module-declared?60_0" +" #t" +" read-compiled-linklet58_0" +" #t" +" read-to-syntax57_0" +" #t" +" in_75" +" fail-thunk_0)))))" +"(define-values" +"(read-to-syntax)" +"(lambda(s-exp_4 srcloc_10 rep_1)" +"(begin" +"(let-values(((the-struct_89) empty-syntax))" +"(if(syntax?$1 the-struct_89)" +"(let-values(((content63_0)(datum-intern-literal s-exp_4))" +"((srcloc64_0) srcloc_10)" +"((props65_0)" +"(let-values(((tmp_60) rep_1))" +"(if(equal? tmp_60 '#\\[)" +"(let-values() original-square-props)" +"(if(equal? tmp_60 '#\\{)" +"(let-values() original-curly-props)" +"(let-values() original-props))))))" +"(syntax1.1" +" content63_0" +"(syntax-scopes the-struct_89)" +"(syntax-shifted-multi-scopes the-struct_89)" +"(syntax-scope-propagations+tamper the-struct_89)" +"(syntax-mpi-shifts the-struct_89)" +" srcloc64_0" +" props65_0" +"(syntax-inspector the-struct_89)))" +" (raise-argument-error 'struct-copy \"syntax?\" the-struct_89))))))" +"(define-values(original-props)(syntax-props(syntax-property$1 empty-syntax original-property-sym #t)))" +"(define-values" +"(original-square-props)" +"(syntax-props(syntax-property$1(syntax-property$1 empty-syntax original-property-sym #t) 'paren-shape '#\\[)))" +"(define-values" +"(original-curly-props)" +"(syntax-props(syntax-property$1(syntax-property$1 empty-syntax original-property-sym #t) 'paren-shape '#\\{)))" +"(define-values(read-module-declared?)(lambda(mod-path_29)(begin(1/module-declared? mod-path_29 #t))))" +"(define-values" +"(read-coerce)" +"(lambda(for-syntax?_12 v_242 srcloc_11)" +"(begin" +"(if(not for-syntax?_12)" +"(let-values()(if(syntax?$1 v_242)(let-values()(syntax->datum$1 v_242))(let-values() v_242)))" +"(let-values()(datum->syntax$1 #f v_242(if srcloc_11(to-srcloc-stx srcloc_11) #f)))))))" +"(define-values" +"(read-coerce-key)" +"(lambda(for-syntax?_13 k_41)" +"(begin(if for-syntax?_13(let-values()(datum-intern-literal k_41))(let-values() k_41)))))" +"(define-values(default-read-handler) #f)" +"(define-values" +"(default-read-handler?)" +"(lambda(in_76)" +"(begin" +"(if(not default-read-handler)" +"(let-values()(begin(set! default-read-handler(port-read-handler in_76)) #t))" +"(let-values()(eq? default-read-handler(port-read-handler in_76)))))))" +"(define-values(orig-input-port)(current-input-port))" +"(define-values(orig-output-port)(current-output-port))" +"(define-values(orig-error-port)(current-error-port))" +"(define-values" +"(maybe-flush-stdout)" +"(lambda(in_77)" +"(begin" +"(if(eq? in_77 orig-input-port)" +"(let-values()(begin(flush-output orig-output-port)(flush-output orig-error-port)))" +"(void)))))" +"(define-values" +"(dynamic-require-reader)" +"(let-values(((dynamic-require-reader21_0)" +"(lambda(mod-path19_0 sym20_0 fail-thunk17_0 fail-thunk18_0)" +"(begin" +" 'dynamic-require-reader21" +"(let-values(((mod-path_30) mod-path19_0))" +"(let-values(((sym_91) sym20_0))" +"(let-values(((fail-thunk_1)" +"(if fail-thunk18_0 fail-thunk17_0 default-dynamic-require-fail-thunk)))" +"(let-values()" +"(let-values(((root-ns_0)(namespace-root-namespace(1/current-namespace))))" +"(if root-ns_0" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" root-ns_0)" +"(let-values()(1/dynamic-require mod-path_30 sym_91 fail-thunk_1)))" +"(1/dynamic-require mod-path_30 sym_91 fail-thunk_1)))))))))))" +"(case-lambda" +"((mod-path_31 sym_14)(begin(dynamic-require-reader21_0 mod-path_31 sym_14 #f #f)))" +"((mod-path_32 sym_92 fail-thunk17_1)(dynamic-require-reader21_0 mod-path_32 sym_92 fail-thunk17_1 #t)))))" +"(define-values" +"(1/read-syntax)" +"(let-values(((read-syntax5_0)" +"(lambda(src1_0 in2_0 src3_0 in4_2)" +"(begin" +" 'read-syntax5" +"(let-values(((src_0)(if src3_0 src1_0(object-name(current-input-port)))))" +"(let-values(((in_73)(if in4_2 in2_0(current-input-port))))" +"(let-values()" +"(begin" +"(if(input-port? in_73)" +"(void)" +" (let-values () (raise-argument-error 'read-syntax \"input-port?\" in_73)))" +"(read-syntax$1 src_0 in_73)))))))))" +"(case-lambda" +"(()(begin 'read-syntax(read-syntax5_0 #f #f #f #f)))" +"((src_2 in2_1)(read-syntax5_0 src_2 in2_1 #t #t))" +"((src1_1)(read-syntax5_0 src1_1 #f #t #f)))))" +"(define-values" +"(1/read-syntax/recursive)" +"(let-values(((read-syntax/recursive17_0)" +"(lambda(src7_0" +" in8_1" +" start9_0" +" readtable10_0" +" graph?11_0" +" src12_0" +" in13_2" +" start14_0" +" readtable15_0" +" graph?16_0)" +"(begin" +" 'read-syntax/recursive17" +"(let-values(((src_3)(if src12_0 src7_0(object-name(current-input-port)))))" +"(let-values(((in_74)(if in13_2 in8_1(current-input-port))))" +"(let-values(((start_58)(if start14_0 start9_0 #f)))" +"(let-values(((readtable_5)(if readtable15_0 readtable10_0(1/current-readtable))))" +"(let-values(((graph?_2)(if graph?16_0 graph?11_0 #t)))" +"(let-values()" +"(begin" +"(if(input-port? in_74)" +"(void)" +" (let-values () (raise-argument-error 'read-syntax/recursive \"input-port?\" in_74)))" +"(if(let-values(((or-part_259)(char? start_58)))" +"(if or-part_259 or-part_259(not start_58)))" +"(void)" +"(let-values()" +" (raise-argument-error 'read-syntax/recursive \"(or/c char? #f)\" start_58)))" +"(if(let-values(((or-part_160)(1/readtable? readtable_5)))" +"(if or-part_160 or-part_160(not readtable_5)))" +"(void)" +"(let-values()" +" (raise-argument-error 'read-syntax/recursive \"(or/c readtable? #f)\" readtable_5)))" +"(read-syntax/recursive$1 src_3 in_74 start_58 readtable_5 graph?_2))))))))))))" +"(case-lambda" +"(()(begin 'read-syntax/recursive(read-syntax/recursive17_0 #f #f #f #f #f #f #f #f #f #f)))" +"((src_4 in_21 start_59 readtable_7 graph?11_1)" +"(read-syntax/recursive17_0 src_4 in_21 start_59 readtable_7 graph?11_1 #t #t #t #t #t))" +"((src_5 in_78 start_60 readtable10_1)" +"(read-syntax/recursive17_0 src_5 in_78 start_60 readtable10_1 #f #t #t #t #t #f))" +"((src_6 in_13 start9_1)(read-syntax/recursive17_0 src_6 in_13 start9_1 #f #f #t #t #t #f #f))" +"((src_7 in8_2)(read-syntax/recursive17_0 src_7 in8_2 #f #f #f #t #t #f #f #f))" +"((src7_1)(read-syntax/recursive17_0 src7_1 #f #f #f #f #t #f #f #f #f)))))" +"(define-values" +"(1/read)" +"(let-values(((read21_0)" +"(lambda(in19_0 in20_2)" +"(begin" +" 'read21" +"(let-values(((in_79)(if in20_2 in19_0(current-input-port))))" +"(let-values()" +"(begin" +"(if(input-port? in_79)" +"(void)" +" (let-values () (raise-argument-error 'read \"input-port?\" in_79)))" +"(read$1 in_79))))))))" +"(case-lambda(()(begin 'read(read21_0 #f #f)))((in19_1)(read21_0 in19_1 #t)))))" +"(define-values" +"(1/read/recursive)" +"(let-values(((read/recursive31_0)" +"(lambda(in23_1 start24_0 readtable25_0 graph?26_0 in27_2 start28_1 readtable29_0 graph?30_0)" +"(begin" +" 'read/recursive31" +"(let-values(((in_15)(if in27_2 in23_1(current-input-port))))" +"(let-values(((start_61)(if start28_1 start24_0 #f)))" +"(let-values(((readtable_8)(if readtable29_0 readtable25_0(1/current-readtable))))" +"(let-values(((graph?_3)(if graph?30_0 graph?26_0 #t)))" +"(let-values()" +"(begin" +"(if(input-port? in_15)" +"(void)" +" (let-values () (raise-argument-error 'read/recursive \"input-port?\" in_15)))" +"(if(let-values(((or-part_168)(char? start_61)))" +"(if or-part_168 or-part_168(not start_61)))" +"(void)" +" (let-values () (raise-argument-error 'read/recursive \"(or/c char? #f)\" start_61)))" +"(if(let-values(((or-part_169)(1/readtable? readtable_8)))" +"(if or-part_169 or-part_169(not readtable_8)))" +"(void)" +"(let-values()" +" (raise-argument-error 'read/recursive \"(or/c readtable? #f)\" readtable_8)))" +"(read/recursive$1 in_15 start_61 readtable_8 graph?_3)))))))))))" +"(case-lambda" +"(()(begin 'read/recursive(read/recursive31_0 #f #f #f #f #f #f #f #f)))" +"((in_16 start_62 readtable_9 graph?26_1)(read/recursive31_0 in_16 start_62 readtable_9 graph?26_1 #t #t #t #t))" +"((in_34 start_63 readtable25_1)(read/recursive31_0 in_34 start_63 readtable25_1 #f #t #t #t #f))" +"((in_80 start24_1)(read/recursive31_0 in_80 start24_1 #f #f #t #t #f #f))" +"((in23_2)(read/recursive31_0 in23_2 #f #f #f #t #f #f #f)))))" +"(define-values" +"(1/read-language)" +"(let-values(((read-language37_0)" +"(lambda(in33_1 fail-thunk34_0 in35_0 fail-thunk36_0)" +"(begin" +" 'read-language37" +"(let-values(((in_7)(if in35_0 in33_1(current-input-port))))" +"(let-values(((fail-thunk_2)(if fail-thunk36_0 fail-thunk34_0 read-language-fail-thunk)))" +"(let-values()" +"(begin" +"(if(input-port? in_7)" +"(void)" +" (let-values () (raise-argument-error 'read-language \"input-port?\" in_7)))" +"(if(if(procedure? fail-thunk_2)(procedure-arity-includes? fail-thunk_2 0) #f)" +"(void)" +"(let-values()" +" (raise-argument-error 'read-language \"(procedure-arity-includes?/c 0)\" fail-thunk_2)))" +"(read-language$1" +" in_7" +"(if(eq? fail-thunk_2 read-language-fail-thunk) #f fail-thunk_2))))))))))" +"(case-lambda" +"(()(begin 'read-language(read-language37_0 #f #f #f #f)))" +"((in_81 fail-thunk34_1)(read-language37_0 in_81 fail-thunk34_1 #t #t))" +"((in33_2)(read-language37_0 in33_2 #f #t #f)))))" +" (define-values (read-language-fail-thunk) (lambda () (begin (error \"fail\"))))" +"(define-values" +"(eval$1)" +"(case-lambda" +"((s_0)(begin 'eval((1/current-eval)(intro s_0))))" +"((s_157 ns_58)" +"(begin" +" (if (1/namespace? ns_58) (void) (let-values () (raise-argument-error 'eval \"namespace?\" ns_58)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) 1/current-namespace ns_58)" +"(let-values()((1/current-eval)(intro s_157 ns_58))))))))" +"(define-values" +"(1/eval-syntax)" +"(case-lambda" +"((s_1)" +"(begin" +" 'eval-syntax" +"(begin" +" (if (syntax?$1 s_1) (void) (let-values () (raise-argument-error 'eval-syntax \"syntax?\" s_1)))" +"((1/current-eval) s_1))))" +"((s_169 ns_114)" +"(begin" +" (if (syntax?$1 s_169) (void) (let-values () (raise-argument-error 'eval-syntax \"syntax?\" s_169)))" +" (if (1/namespace? ns_114) (void) (let-values () (raise-argument-error 'eval-syntax \"namespace?\" ns_114)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) 1/current-namespace ns_114)" +"(let-values()((1/current-eval) s_169)))))))" +"(define-values(compile$1)(lambda(s_2)(begin 'compile((1/current-compile)(intro s_2) #f))))" +"(define-values" +"(1/compile-syntax)" +"(lambda(s_3)" +"(begin" +" 'compile-syntax" +"(begin" +" (if (syntax?$1 s_3) (void) (let-values () (raise-argument-error 'compile-syntax \"syntax?\" s_3)))" +"((1/current-compile) s_3 #f)))))" +"(define-values(1/expand)(lambda(s_170)(begin 'expand(expand$1(intro s_170)(1/current-namespace) #t))))" +"(define-values" +"(1/expand-syntax)" +"(lambda(s_145)" +"(begin" +" 'expand-syntax" +"(begin" +" (if (syntax?$1 s_145) (void) (let-values () (raise-argument-error 'expand-syntax \"syntax?\" s_145)))" +"(expand$1 s_145(1/current-namespace) #t)))))" +"(define-values(1/expand-once)(lambda(s_70)(begin 'expand-once(expand-once$1(intro s_70)))))" +"(define-values" +"(1/expand-syntax-once)" +"(lambda(s_9)" +"(begin" +" 'expand-syntax-once" +"(begin" +" (if (syntax?$1 s_9) (void) (let-values () (raise-argument-error 'expand-syntax-once \"syntax?\" s_9)))" +"(expand-once$1 s_9)))))" +"(define-values" +"(1/expand-to-top-form)" +"(lambda(s_466)(begin 'expand-to-top-form(expand-to-top-form$1(intro s_466)))))" +"(define-values" +"(1/expand-syntax-to-top-form)" +"(lambda(s_422)" +"(begin" +" 'expand-syntax-to-top-form" +"(begin" +" (if (syntax?$1 s_422) (void) (let-values () (raise-argument-error 'expand-syntax-to-top-form \"syntax?\" s_422)))" +"(expand-to-top-form$1 s_422)))))" +"(define-values" +"(intro)" +"(let-values(((intro4_0)" +"(lambda(given-s3_0 ns1_6 ns2_1)" +"(begin" +" 'intro4" +"(let-values(((given-s_1) given-s3_0))" +"(let-values(((ns_115)(if ns2_1 ns1_6(1/current-namespace))))" +"(let-values()" +"(let-values(((s_10)(if(syntax?$1 given-s_1) given-s_1(1/datum->syntax #f given-s_1))))" +"(1/namespace-syntax-introduce s_10 ns_115)))))))))" +"(case-lambda((given-s_2)(begin(intro4_0 given-s_2 #f #f)))((given-s_3 ns1_7)(intro4_0 given-s_3 ns1_7 #t)))))" +"(define-values" +"(declare-primitive-module!)" +"(lambda(name_70 inst_7 in-ns_0 protected_0 cross-phase-persistent?_3)" +"(begin" +"(let-values(((mpi_47)(1/module-path-index-join(list 'quote name_70) #f)))" +"(let-values(((in-ns1_0) in-ns_0)" +"((temp2_6)" +"(let-values(((temp4_6)(1/current-module-declare-source))" +"((cross-phase-persistent?5_0) cross-phase-persistent?_3)" +"((temp6_4)(zero?(hash-count protected_0)))" +"((mpi7_0) mpi_47)" +"((temp8_5)" +"(hasheqv" +" 0" +"(let-values(((lst_260)(1/instance-variable-names inst_7)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_260)))" +"((letrec-values(((for-loop_202)" +"(lambda(table_163 lst_94)" +"(begin" +" 'for-loop" +"(if(pair? lst_94)" +"(let-values(((sym_93)(unsafe-car lst_94))" +"((rest_45)(unsafe-cdr lst_94)))" +"(let-values(((table_204)" +"(let-values(((table_205) table_163))" +"(let-values(((table_164)" +"(let-values()" +"(let-values(((key_86" +" val_76)" +"(let-values()" +"(let-values(((binding_27)" +"(let-values(((mpi10_0)" +" mpi_47)" +"((temp11_5)" +" 0)" +"((sym12_0)" +" sym_93))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" mpi10_0" +" temp11_5" +" sym12_0))))" +"(values" +" sym_93" +"(if(hash-ref" +" protected_0" +" sym_93" +" #f)" +"(provided1.1" +" binding_27" +" #t" +" #f)" +" binding_27))))))" +"(hash-set" +" table_205" +" key_86" +" val_76)))))" +"(values table_164)))))" +"(if(not #f)" +"(for-loop_202 table_204 rest_45)" +" table_204)))" +" table_163)))))" +" for-loop_202)" +" '#hash()" +" lst_260)))))" +"((temp9_5)" +"(lambda(data-box_5" +" ns_116" +" phase-shift_19" +" phase-level_21" +" self_27" +" bulk-binding-registry_18" +" insp_20)" +"(if(= 0 phase-level_21)" +"(let-values()" +"(begin" +"(let-values(((lst_302)(1/instance-variable-names inst_7)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_302)))" +"((letrec-values(((for-loop_220)" +"(lambda(lst_264)" +"(begin" +" 'for-loop" +"(if(pair? lst_264)" +"(let-values(((sym_94)(unsafe-car lst_264))" +"((rest_174)(unsafe-cdr lst_264)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((val_77)" +"(1/instance-variable-value" +" inst_7" +" sym_94)))" +"(namespace-set-variable!" +" ns_116" +" 0" +" sym_94" +" val_77)))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_220 rest_174)" +"(values))))" +"(values))))))" +" for-loop_220)" +" lst_302)))" +"(void)))" +"(void)))))" +"(make-module39.1" +" cross-phase-persistent?5_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp9_5" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp6_4" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp8_5" +" #f" +" #f" +" mpi7_0" +" temp4_6" +" #t" +" #f" +" #f" +" #f" +" #f)))" +"((temp3_9)(substitute-module-declare-name name_70)))" +"(declare-module!58.1 #f #f in-ns1_0 temp2_6 temp3_9))))))" +"(define-values" +"(1/prop:missing-module 1/exn:missing-module? 1/exn:missing-module-accessor)" +"(make-struct-type-property" +" 'missing-module" +"(lambda(v_27 info_6)" +"(begin" +"(if(if(procedure? v_27)(procedure-arity-includes? v_27 1) #f)" +"(void)" +" (let-values () (raise-argument-error 'guard-for-prop:missing-module \"(procedure-arity-includes/c 1)\" v_27)))" +" v_27))))" +"(define-values" +"(1/struct:exn:fail:filesystem:missing-module" +" 1/make-exn:fail:filesystem:missing-module" +" 1/exn:fail:filesystem:missing-module?" +" 1/exn:fail:filesystem:missing-module-path)" +"(let-values(((struct:_77 make-_77 ?_77 -ref_77 -set!_77)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:filesystem:missing-module" +" struct:exn:fail:filesystem" +" 1" +" 0" +" #f" +"(list" +"(cons 1/prop:missing-module(lambda(e_81)(1/exn:fail:filesystem:missing-module-path e_81))))" +" #f" +" #f" +" '(0)" +" #f" +" 'exn:fail:filesystem:missing-module)))))" +"(values struct:_77 make-_77 ?_77(make-struct-field-accessor -ref_77 0 'path))))" +"(define-values" +"(1/struct:exn:fail:syntax:missing-module" +" 1/make-exn:fail:syntax:missing-module" +" 1/exn:fail:syntax:missing-module?" +" 1/exn:fail:syntax:missing-module-path)" +"(let-values(((struct:_62 make-_62 ?_62 -ref_62 -set!_62)" +"(let-values()" +"(let-values()" +"(make-struct-type" +" 'exn:fail:syntax:missing-module" +" 1/struct:exn:fail:syntax" +" 1" +" 0" +" #f" +"(list(cons 1/prop:missing-module(lambda(e_82)(1/exn:fail:syntax:missing-module-path e_82))))" +" #f" +" #f" +" '(0)" +" #f" +" 'exn:fail:syntax:missing-module)))))" +"(values struct:_62 make-_62 ?_62(make-struct-field-accessor -ref_62 0 'path))))" +"(define-values" +"(1/current-module-path-for-load)" +"(make-parameter" +" #f" +"(lambda(v_180)" +"(begin" +"(if(let-values(((or-part_30)(not v_180)))" +"(if or-part_30" +" or-part_30" +"(let-values(((or-part_31)(1/module-path? v_180)))" +"(if or-part_31 or-part_31(if(syntax?$1 v_180)(1/module-path?(syntax->datum$1 v_180)) #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'current-module-path-for-load" +"(string-append" +" \"(or/c module-path?\"" +" \" (and/c syntax? (lambda (stx) (module-path? (syntax->datum stx))))\"" +" \" #f)\")" +" v_180)))" +" v_180))))" +"(define-values" +"(maybe-raise-missing-module)" +"(lambda(name_71 filename_0 pre_0 rel_0 post_0 errstr_0)" +"(begin" +"(let-values(((path_11)(1/current-module-path-for-load)))" +"(if path_11" +"(let-values()" +"(begin" +"(if(syntax?$1 path_11)" +"(let-values()" +"(raise" +"(1/make-exn:fail:syntax:missing-module" +"(format" +"(string-append" +" \"~a: cannot open module file\\n\"" +" \" module path: ~a\\n\"" +" \" path: ~a~a~a~a\\n\"" +" \" system error: ~a\")" +"(if(syntax-srcloc path_11)(srcloc->string(syntax-srcloc path_11)) name_71)" +"(syntax->datum$1 path_11)" +" filename_0" +" pre_0" +" rel_0" +" post_0" +" errstr_0)" +"(current-continuation-marks)" +"(list path_11)" +"(syntax->datum$1 path_11))))" +"(void))" +"(raise" +"(1/make-exn:fail:filesystem:missing-module" +"(format" +"(string-append" +" \"~a: cannot open module file\\n\"" +" \" module path: ~a\\n\"" +" \" path: ~a~a~a~a\\n\"" +" \" system error: ~a\")" +" name_71" +" path_11" +" filename_0" +" pre_0" +" rel_0" +" post_0" +" errstr_0)" +"(current-continuation-marks)" +" path_11))))" +"(void))))))" +"(define-values" +"(1/local-expand)" +"(let-values(((local-expand6_0)" +"(lambda(s3_2 context4_0 stop-ids5_0 intdefs1_0 intdefs2_0)" +"(begin" +" 'local-expand6" +"(let-values(((s_2) s3_2))" +"(let-values(((context_10) context4_0))" +"(let-values(((stop-ids_2) stop-ids5_0))" +"(let-values(((intdefs_3)(if intdefs2_0 intdefs1_0 #f)))" +"(let-values()" +"(let-values(((temp59_4) 'local-expand)" +"((s60_0) s_2)" +"((context61_0) context_10)" +"((stop-ids62_0) stop-ids_2)" +"((intdefs63_0) intdefs_3))" +"(do-local-expand56.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp59_4" +" s60_0" +" context61_0" +" stop-ids62_0" +" intdefs63_0" +" #t)))))))))))" +"(case-lambda" +"((s_171 context_1 stop-ids_3)(begin 'local-expand(local-expand6_0 s_171 context_1 stop-ids_3 #f #f)))" +"((s_147 context_11 stop-ids_4 intdefs1_1)(local-expand6_0 s_147 context_11 stop-ids_4 intdefs1_1 #t)))))" +"(define-values" +"(1/local-expand/capture-lifts)" +"(let-values(((local-expand/capture-lifts15_0)" +"(lambda(s12_2 context13_0 stop-ids14_0 intdefs8_0 lift-key9_0 intdefs10_0 lift-key11_0)" +"(begin" +" 'local-expand/capture-lifts15" +"(let-values(((s_426) s12_2))" +"(let-values(((context_12) context13_0))" +"(let-values(((stop-ids_5) stop-ids14_0))" +"(let-values(((intdefs_4)(if intdefs10_0 intdefs8_0 #f)))" +"(let-values(((lift-key_4)(if lift-key11_0 lift-key9_0(generate-lift-key))))" +"(let-values()" +"(let-values(((temp64_2) 'local-expand)" +"((s65_0) s_426)" +"((context66_0) context_12)" +"((stop-ids67_0) stop-ids_5)" +"((intdefs68_0) intdefs_4)" +"((temp69_4) #t)" +"((lift-key70_0) lift-key_4))" +"(do-local-expand56.1" +" #f" +" #f" +" temp69_4" +" #t" +" lift-key70_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp64_2" +" s65_0" +" context66_0" +" stop-ids67_0" +" intdefs68_0" +" #t))))))))))))" +"(case-lambda" +"((s_6 context_13 stop-ids_6)" +"(begin 'local-expand/capture-lifts(local-expand/capture-lifts15_0 s_6 context_13 stop-ids_6 #f #f #f #f)))" +"((s_183 context_14 stop-ids_7 intdefs_5 lift-key9_1)" +"(local-expand/capture-lifts15_0 s_183 context_14 stop-ids_7 intdefs_5 lift-key9_1 #t #t))" +"((s_184 context_15 stop-ids_8 intdefs8_1)" +"(local-expand/capture-lifts15_0 s_184 context_15 stop-ids_8 intdefs8_1 #f #t #f)))))" +"(define-values" +"(1/local-transformer-expand)" +"(let-values(((local-transformer-expand22_0)" +"(lambda(s19_1 context20_0 stop-ids21_0 intdefs17_0 intdefs18_0)" +"(begin" +" 'local-transformer-expand22" +"(let-values(((s_162) s19_1))" +"(let-values(((context_16) context20_0))" +"(let-values(((stop-ids_9) stop-ids21_0))" +"(let-values(((intdefs_6)(if intdefs18_0 intdefs17_0 #f)))" +"(let-values()" +"(let-values(((temp71_4) 'local-expand)" +"((s72_0) s_162)" +"((context73_0) context_16)" +"((stop-ids74_0) stop-ids_9)" +"((intdefs75_0) intdefs_6)" +"((temp76_2) #t))" +"(do-local-expand56.1" +" temp76_2" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp71_4" +" s72_0" +" context73_0" +" stop-ids74_0" +" intdefs75_0" +" #t)))))))))))" +"(case-lambda" +"((s_181 context_17 stop-ids_10)" +"(begin 'local-transformer-expand(local-transformer-expand22_0 s_181 context_17 stop-ids_10 #f #f)))" +"((s_11 context_18 stop-ids_11 intdefs17_1)" +"(local-transformer-expand22_0 s_11 context_18 stop-ids_11 intdefs17_1 #t)))))" +"(define-values" +"(1/local-transformer-expand/capture-lifts)" +"(let-values(((local-transformer-expand/capture-lifts31_0)" +"(lambda(s28_2 context29_0 stop-ids30_0 intdefs24_0 lift-key25_0 intdefs26_1 lift-key27_0)" +"(begin" +" 'local-transformer-expand/capture-lifts31" +"(let-values(((s_186) s28_2))" +"(let-values(((context_19) context29_0))" +"(let-values(((stop-ids_12) stop-ids30_0))" +"(let-values(((intdefs_7)(if intdefs26_1 intdefs24_0 #f)))" +"(let-values(((lift-key_0)(if lift-key27_0 lift-key25_0(generate-lift-key))))" +"(let-values()" +"(let-values(((temp77_2) 'local-expand)" +"((s78_0) s_186)" +"((context79_0) context_19)" +"((stop-ids80_0) stop-ids_12)" +"((intdefs81_0) intdefs_7)" +"((temp82_5) #t)" +"((temp83_3) #t)" +"((lift-key84_0) lift-key_0))" +"(do-local-expand56.1" +" temp82_5" +" #t" +" temp83_3" +" #t" +" lift-key84_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp77_2" +" s78_0" +" context79_0" +" stop-ids80_0" +" intdefs81_0" +" #t))))))))))))" +"(case-lambda" +"((s_305 context_20 stop-ids_13)" +"(begin" +" 'local-transformer-expand/capture-lifts" +"(local-transformer-expand/capture-lifts31_0 s_305 context_20 stop-ids_13 #f #f #f #f)))" +"((s_467 context_21 stop-ids_14 intdefs_8 lift-key25_1)" +"(local-transformer-expand/capture-lifts31_0 s_467 context_21 stop-ids_14 intdefs_8 lift-key25_1 #t #t))" +"((s_468 context_22 stop-ids_15 intdefs24_1)" +"(local-transformer-expand/capture-lifts31_0 s_468 context_22 stop-ids_15 intdefs24_1 #f #t #f)))))" +"(define-values" +"(1/syntax-local-expand-expression)" +"(let-values(((syntax-local-expand-expression36_0)" +"(lambda(s35_0 opaque-only?33_0 opaque-only?34_0)" +"(begin" +" 'syntax-local-expand-expression36" +"(let-values(((s_458) s35_0))" +"(let-values(((opaque-only?_0)(if opaque-only?34_0 opaque-only?33_0 #f)))" +"(let-values()" +"(let-values(((exp-s_12)" +"(let-values(((temp85_2) 'syntax-local-expand-expression)" +"((s86_0) s_458)" +"((temp87_3) 'expression)" +"((null88_0) null)" +"((temp89_6) #f)" +"((opaque-only?90_0) opaque-only?_0)" +"((temp91_1) #t)" +"((temp92_2) #t))" +"(do-local-expand56.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp91_1" +" #t" +" opaque-only?90_0" +" #t" +" temp92_2" +" #t" +" temp85_2" +" s86_0" +" temp87_3" +" null88_0" +" temp89_6" +" #t))))" +"(let-values(((ctx_69)(let-values()(get-current-expand-context17.1 #f #f #f #f))))" +"(let-values(((ae_1)" +"(flip-introduction-scopes" +"(datum->syntax$1" +" #f" +"(already-expanded1.1" +"(if(parsed? exp-s_12)" +" exp-s_12" +"(flip-introduction-scopes exp-s_12 ctx_69))" +"(expand-context-binding-layer ctx_69)))" +" ctx_69)))" +"(begin" +"(let-values(((obs_31)(expand-context-observer ctx_69)))" +"(if obs_31" +"(let-values()(let-values()(call-expand-observe obs_31 'opaque-expr ae_1)))" +"(void)))" +"(let-values(((obs_49)(expand-context-observer ctx_69)))" +"(if obs_49" +"(let-values()(let-values()(call-expand-observe obs_49 'exit-local exp-s_12)))" +"(void)))" +"(values(if(not opaque-only?_0) exp-s_12 #f) ae_1))))))))))))" +"(case-lambda" +"((s_26)(begin 'syntax-local-expand-expression(syntax-local-expand-expression36_0 s_26 #f #f)))" +"((s_309 opaque-only?33_1)(syntax-local-expand-expression36_0 s_309 opaque-only?33_1 #t)))))" +"(define-values" +"(do-local-expand56.1)" +"(lambda(as-transformer?39_0" +" as-transformer?45_0" +" capture-lifts?38_0" +" capture-lifts?44_0" +" lift-key41_0" +" lift-key47_0" +" skip-log-exit?43_0" +" skip-log-exit?49_0" +" to-parsed-ok?40_0" +" to-parsed-ok?46_0" +" track-to-be-defined?42_0" +" track-to-be-defined?48_0" +" who52_1" +" s-or-s-exp53_0" +" context54_0" +" stop-ids55_0" +" intdefs50_0" +" intdefs51_0)" +"(begin" +" 'do-local-expand56" +"(let-values(((who_33) who52_1))" +"(let-values(((s-or-s-exp_0) s-or-s-exp53_0))" +"(let-values(((context_23) context54_0))" +"(let-values(((stop-ids_16) stop-ids55_0))" +"(let-values(((intdefs_9)(if intdefs51_0 intdefs50_0 #f)))" +"(let-values(((capture-lifts?_0)(if capture-lifts?44_0 capture-lifts?38_0 #f)))" +"(let-values(((as-transformer?_5)(if as-transformer?45_0 as-transformer?39_0 #f)))" +"(let-values(((to-parsed-ok?_1)(if to-parsed-ok?46_0 to-parsed-ok?40_0 #f)))" +"(let-values(((lift-key_5)" +"(if lift-key47_0" +" lift-key41_0" +"(if(let-values(((or-part_45) capture-lifts?_0))" +"(if or-part_45 or-part_45 as-transformer?_5))" +"(generate-lift-key)" +" #f))))" +"(let-values(((track-to-be-defined?_1)" +"(if track-to-be-defined?48_0 track-to-be-defined?42_0 #f)))" +"(let-values(((skip-log-exit?_0)(if skip-log-exit?49_0 skip-log-exit?43_0 #f)))" +"(let-values()" +"(let-values()" +"(let-values(((s_311)(datum->syntax$1 #f s-or-s-exp_0)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_358)(list? context_23)))" +"(if or-part_358" +" or-part_358" +"(memq" +" context_23" +"(if as-transformer?_5" +" '(expression top-level)" +" '(expression top-level module module-begin)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_33" +"(if as-transformer?_5" +" \"(or/c 'expression 'top-level list?)\"" +" \"(or/c 'expression 'top-level 'module 'module-begin list?)\")" +" context_23)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_359)(not stop-ids_16)))" +"(if or-part_359" +" or-part_359" +"(if(list? stop-ids_16)" +"(andmap2 identifier? stop-ids_16)" +" #f)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_33" +" \"(or/c (listof identifier?) #f)\"" +" stop-ids_16)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_360)(not intdefs_9)))" +"(if or-part_360" +" or-part_360" +"(let-values(((or-part_361)" +"(1/internal-definition-context? intdefs_9)))" +"(if or-part_361" +" or-part_361" +"(if(list? intdefs_9)" +"(andmap2 1/internal-definition-context? intdefs_9)" +" #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" who_33" +" \"(or/c #f internal-definitionc-context? (listof internal-definitionc-context?))\"" +" intdefs_9)))" +"(values))))" +"(let-values(((ctx_70)" +"(let-values(((who93_0) who_33))" +"(get-current-expand-context17.1 #f #f who93_0 #t))))" +"(let-values(((phase_25)" +"(if as-transformer?_5" +"(add1(expand-context-phase ctx_70))" +"(expand-context-phase ctx_70))))" +"(let-values(((local-ctx_0)" +"(let-values(((context95_0) context_23)" +"((phase96_0) phase_25)" +"((intdefs97_0) intdefs_9)" +"((stop-ids98_0) stop-ids_16)" +"((to-parsed-ok?99_0) to-parsed-ok?_1)" +"((track-to-be-defined?100_0)" +" track-to-be-defined?_1))" +"(make-local-expand-context37.1" +" context95_0" +" intdefs97_0" +" phase96_0" +" #t" +" stop-ids98_0" +" #t" +" to-parsed-ok?99_0" +" #t" +" track-to-be-defined?100_0" +" #t" +" ctx_70))))" +"(let-values((()" +"(begin" +"(namespace-visit-available-modules!" +"(expand-context-namespace ctx_70)" +" phase_25)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_50)" +"(expand-context-observer local-ctx_0)))" +"(if obs_50" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_50" +" 'enter-local" +" s_311)))" +"(void)))" +"(values))))" +"(let-values(((input-s_1)" +"(let-values(((temp101_4)" +"(flip-introduction-scopes s_311 ctx_70))" +"((intdefs102_0) intdefs_9))" +"(add-intdef-scopes21.1" +" #f" +" #f" +" #f" +" #f" +" temp101_4" +" intdefs102_0))))" +"(let-values((()" +"(begin" +"(if as-transformer?_5" +"(let-values()" +"(let-values(((obs_51)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_51" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_51 'phase-up)))" +"(void))))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_52)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_52" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_52" +" 'local-pre" +" input-s_1)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if stop-ids_16" +"(let-values()" +"(let-values(((obs_53)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_53" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_53" +" 'start-expand)))" +"(void))))" +"(void))" +"(values))))" +"(let-values(((output-s_0)" +"(if(if as-transformer?_5 capture-lifts?_0 #f)" +"(let-values()" +"(let-values(((context105_0) context_23)" +"((temp106_4) #f)" +"((temp107_0) #t)" +"((lift-key108_0) lift-key_5)" +"((temp109_2) #t)" +"((temp110_6) #t))" +"(expand-transformer47.1" +" temp109_2" +" #t" +" temp107_0" +" #t" +" context105_0" +" #t" +" temp106_4" +" #t" +" temp110_6" +" #t" +" lift-key108_0" +" #t" +" input-s_1" +" local-ctx_0)))" +"(if as-transformer?_5" +"(let-values()" +"(let-values(((context113_0) context_23)" +"((temp114_3) #f)" +"((temp115_2)" +"(eq? 'top-level context_23))" +"((lift-key116_0) lift-key_5)" +"((temp117_4) #t))" +"(expand-transformer47.1" +" #f" +" #f" +" temp115_2" +" #t" +" context113_0" +" #t" +" temp114_3" +" #t" +" temp117_4" +" #t" +" lift-key116_0" +" #t" +" input-s_1" +" local-ctx_0)))" +"(if capture-lifts?_0" +"(let-values()" +"(let-values(((temp120_3) #t)" +"((lift-key121_0)" +" lift-key_5)" +"((temp122_3) #t))" +"(expand/capture-lifts30.1" +" temp122_3" +" #t" +" temp120_3" +" #t" +" #f" +" #f" +" lift-key121_0" +" #t" +" input-s_1" +" local-ctx_0)))" +"(let-values()" +"(let-values(((input-s123_0) input-s_1)" +"((local-ctx124_0)" +" local-ctx_0))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" input-s123_0" +" local-ctx124_0))))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_54)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_54" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_54" +" 'local-post" +" output-s_0)))" +"(void)))" +"(values))))" +"(let-values(((result-s_8)" +"(if(parsed? output-s_0)" +" output-s_0" +"(flip-introduction-scopes" +" output-s_0" +" ctx_70))))" +"(begin" +"(if skip-log-exit?_0" +"(void)" +"(let-values()" +"(let-values(((obs_55)" +"(expand-context-observer" +" local-ctx_0)))" +"(if obs_55" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_55" +" 'exit-local" +" result-s_8)))" +"(void)))))" +" result-s_8)))))))))))))))))))))))))))))))))" +"(define-values" +"(1/syntax-tainted?)" +"(lambda(s_0)" +"(begin" +" 'syntax-tainted?" +"(begin" +" (if (syntax?$1 s_0) (void) (let-values () (raise-argument-error 'syntax-tainted? \"syntax?\" s_0)))" +"(syntax-tainted?$1 s_0)))))" +"(define-values" +"(1/syntax-arm)" +"(let-values(((syntax-arm6_0)" +"(lambda(s5_2 maybe-insp1_0 use-mode?2_0 maybe-insp3_0 use-mode?4_0)" +"(begin" +" 'syntax-arm6" +"(let-values(((s_3) s5_2))" +"(let-values(((maybe-insp_0)(if maybe-insp3_0 maybe-insp1_0 #f)))" +"(let-values(((use-mode?_0)(if use-mode?4_0 use-mode?2_0 #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_3)" +"(void)" +" (let-values () (raise-argument-error 'syntax-arm \"syntax?\" s_3)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_12)(not maybe-insp_0)))" +"(if or-part_12 or-part_12(inspector? maybe-insp_0)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'syntax-arm" +" \"(or/c inspector? #f)\"" +" maybe-insp_0)))" +"(values))))" +"(let-values(((insp_21)(inspector-for-taint maybe-insp_0)))" +"(if use-mode?_0" +"(let-values()" +"(taint-dispatch" +" s_3" +"(lambda(s_466)(syntax-arm$1 s_466 insp_21))" +"(1/syntax-local-phase-level)))" +"(let-values()(syntax-arm$1 s_3 insp_21))))))))))))))" +"(case-lambda" +"((s_422)(begin 'syntax-arm(syntax-arm6_0 s_422 #f #f #f #f)))" +"((s_469 maybe-insp_1 use-mode?2_1)(syntax-arm6_0 s_469 maybe-insp_1 use-mode?2_1 #t #t))" +"((s_470 maybe-insp1_1)(syntax-arm6_0 s_470 maybe-insp1_1 #f #t #f)))))" +"(define-values" +"(1/syntax-disarm)" +"(lambda(s_411 maybe-insp_2)" +"(begin" +" 'syntax-disarm" +"(let-values((()" +"(begin" +"(if(syntax?$1 s_411)" +"(void)" +" (let-values () (raise-argument-error 'syntax-disarm \"syntax?\" s_411)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_290)(not maybe-insp_2)))" +"(if or-part_290 or-part_290(inspector? maybe-insp_2)))" +"(void)" +" (let-values () (raise-argument-error 'syntax-disarm \"(or/c inspector? #f)\" maybe-insp_2)))" +"(values))))" +"(let-values(((insp_22)(inspector-for-taint maybe-insp_2)))(syntax-disarm$1 s_411 insp_22)))))))" +"(define-values" +"(1/syntax-rearm)" +"(let-values(((syntax-rearm12_0)" +"(lambda(s10_0 from-s11_0 use-mode?8_0 use-mode?9_0)" +"(begin" +" 'syntax-rearm12" +"(let-values(((s_40) s10_0))" +"(let-values(((from-s_2) from-s11_0))" +"(let-values(((use-mode?_1)(if use-mode?9_0 use-mode?8_0 #f)))" +"(let-values()" +"(begin" +"(if(syntax?$1 s_40)" +"(void)" +" (let-values () (raise-argument-error 'syntax-disarm \"syntax?\" s_40)))" +"(if(syntax?$1 from-s_2)" +"(void)" +" (let-values () (raise-argument-error 'syntax-disarm \"syntax?\" from-s_2)))" +"(if use-mode?_1" +"(let-values()" +"(taint-dispatch" +" s_40" +"(lambda(s_427)(syntax-rearm$1 s_427 from-s_2))" +"(1/syntax-local-phase-level)))" +"(let-values()(syntax-rearm$1 s_40 from-s_2))))))))))))" +"(case-lambda" +"((s_182 from-s_3)(begin 'syntax-rearm(syntax-rearm12_0 s_182 from-s_3 #f #f)))" +"((s_174 from-s_4 use-mode?8_1)(syntax-rearm12_0 s_174 from-s_4 use-mode?8_1 #t)))))" +"(define-values" +"(1/syntax-taint)" +"(lambda(s_161)" +"(begin" +" 'syntax-taint" +"(begin" +" (if (syntax?$1 s_161) (void) (let-values () (raise-argument-error 'syntax-taint \"syntax?\" s_161)))" +"(syntax-taint$1 s_161)))))" +"(define-values" +"(inspector-for-taint)" +"(lambda(maybe-insp_3)" +"(begin" +"(let-values(((or-part_83) maybe-insp_3))" +"(if or-part_83" +" or-part_83" +"(let-values(((or-part_84)(current-module-code-inspector)))" +"(if or-part_84 or-part_84(current-code-inspector))))))))" +"(define-values" +"(1/variable-reference->empty-namespace)" +"(lambda(vr_0)" +"(begin" +" 'variable-reference->empty-namespace" +"(begin" +"(if(1/variable-reference? vr_0)" +"(void)" +" (let-values () (raise-argument-error 'variable-reference->empty-namespace \"variable-reference?\" vr_0)))" +"(let-values(((temp1_3)(1/variable-reference->namespace vr_0)))(new-namespace9.1 #f #f #f #f temp1_3 #t))))))" +"(define-values" +"(1/variable-reference->namespace)" +"(lambda(vr_1)" +"(begin" +" 'variable-reference->namespace" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_1)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->namespace \"variable-reference?\" vr_1)))" +"(values))))" +"(let-values(((inst_8)(1/variable-reference->instance vr_1)))" +"(if(symbol? inst_8)" +"(let-values()" +"(1/module->namespace(list 'quote inst_8)(1/instance-data(1/variable-reference->instance vr_1 #t))))" +"(if(not inst_8)" +"(let-values()(1/instance-data(1/variable-reference->instance vr_1 #t)))" +"(let-values()(1/instance-data inst_8)))))))))" +"(define-values" +"(1/variable-reference->module-path-index)" +"(lambda(vr_2)" +"(begin" +" 'variable-reference->module-path-index" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_2)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->module-path-index \"variable-reference?\" vr_2)))" +"(values))))" +"(let-values(((mpi_47)(namespace-mpi(1/variable-reference->namespace vr_2))))" +"(if(top-level-module-path-index? mpi_47) #f mpi_47))))))" +"(define-values" +"(1/variable-reference->resolved-module-path)" +"(lambda(vr_3)" +"(begin" +" 'variable-reference->resolved-module-path" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_3)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->resolved-module-path \"variable-reference?\" vr_3)))" +"(values))))" +"(let-values(((mpi_48)(1/variable-reference->module-path-index vr_3)))" +"(if mpi_48(1/module-path-index-resolve mpi_48) #f))))))" +"(define-values" +"(1/variable-reference->module-source)" +"(lambda(vr_4)" +"(begin" +" 'variable-reference->module-source" +"(let-values((()" +"(begin" +"(if(1/variable-reference? vr_4)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->module-source \"variable-reference?\" vr_4)))" +"(values))))" +"(let-values(((ns_117)(1/variable-reference->namespace vr_4)))(namespace-source-name ns_117))))))" +"(define-values" +"(1/variable-reference->phase)" +"(lambda(vr_5)" +"(begin" +" 'variable-reference->phase" +"(begin" +"(if(1/variable-reference? vr_5)" +"(void)" +" (let-values () (raise-argument-error 'variable-reference->phase \"variable-reference?\" vr_5)))" +"(namespace-phase(1/variable-reference->namespace vr_5))))))" +"(define-values" +"(1/variable-reference->module-base-phase)" +"(lambda(vr_6)" +"(begin" +" 'variable-reference->module-base-phase" +"(begin" +"(if(1/variable-reference? vr_6)" +"(void)" +" (let-values () (raise-argument-error 'variable-reference->module-base-phase \"variable-reference?\" vr_6)))" +"(namespace-0-phase(1/variable-reference->namespace vr_6))))))" +"(define-values" +"(1/variable-reference->module-declaration-inspector)" +"(lambda(vr_7)" +"(begin" +" 'variable-reference->module-declaration-inspector" +"(begin" +"(if(1/variable-reference? vr_7)" +"(void)" +"(let-values()" +" (raise-argument-error 'variable-reference->module-declaration-inspector \"variable-reference?\" vr_7)))" +"(if(1/variable-reference->instance vr_7)" +"(let-values()" +"(raise-arguments-error" +" 'variable-reference->module-declaration-inspector" +" \"variable reference does not refer to an anonymous module variable\"" +" \"variable reference\"" +" vr_7))" +"(void))" +"(let-values(((or-part_215)(namespace-declaration-inspector(1/variable-reference->namespace vr_7))))" +"(if or-part_215" +" or-part_215" +"(raise-arguments-error" +" 'variable-reference->module-declaration-inspector" +" \"given variable reference is not from a module\")))))))" +"(define-values" +"(primitive-ids)" +"(seteq" +" 'syntax?" +" 'syntax-e" +" 'syntax->datum" +" 'datum->syntax" +" 'bound-identifier=?" +" 'free-identifier=?" +" 'free-transformer-identifier=?" +" 'free-template-identifier=?" +" 'free-label-identifier=?" +" 'identifier-binding" +" 'identifier-transformer-binding" +" 'identifier-template-binding" +" 'identifier-label-binding" +" 'identifier-binding-symbol" +" 'identifier-prune-lexical-context" +" 'syntax-debug-info" +" 'syntax-track-origin" +" 'syntax-shift-phase-level" +" 'syntax-source-module" +" 'identifier-prune-to-source-module" +" 'syntax-source" +" 'syntax-line" +" 'syntax-column" +" 'syntax-position" +" 'syntax-span" +" 'syntax->list" +" 'syntax-property" +" 'syntax-property-preserved?" +" 'syntax-property-symbol-keys" +" 'syntax-original?" +" 'syntax-tainted?" +" 'syntax-arm" +" 'syntax-disarm" +" 'syntax-rearm" +" 'syntax-taint" +" 'raise-syntax-error" +" 'struct:exn:fail:syntax" +" 'exn:fail:syntax" +" 'make-exn:fail:syntax" +" 'exn:fail:syntax?" +" 'exn:fail:syntax-exprs" +" 'struct:exn:fail:syntax:unbound" +" 'exn:fail:syntax:unbound" +" 'make-exn:fail:syntax:unbound" +" 'exn:fail:syntax:unbound?" +" 'current-module-path-for-load" +" 'prop:missing-module" +" 'exn:missing-module?" +" 'exn:missing-module-accessor" +" 'struct:exn:fail:filesystem:missing-module" +" 'exn:fail:filesystem:missing-module" +" 'make-exn:fail:filesystem:missing-module" +" 'exn:fail:filesystem:missing-module?" +" 'exn:fail:filesystem:missing-module-path" +" 'struct:exn:fail:syntax:missing-module" +" 'exn:fail:syntax:missing-module" +" 'make-exn:fail:syntax:missing-module" +" 'exn:fail:syntax:missing-module?" +" 'exn:fail:syntax:missing-module-path" +" 'syntax-transforming?" +" 'syntax-transforming-with-lifts?" +" 'syntax-transforming-module-expression?" +" 'syntax-local-transforming-module-provides?" +" 'syntax-local-context" +" 'syntax-local-introduce" +" 'syntax-local-identifier-as-binding" +" 'syntax-local-phase-level" +" 'syntax-local-name" +" 'make-syntax-introducer" +" 'make-syntax-delta-introducer" +" 'syntax-local-value" +" 'syntax-local-value/immediate" +" 'syntax-local-lift-expression" +" 'syntax-local-lift-values-expression" +" 'syntax-local-lift-context" +" 'syntax-local-lift-module" +" 'syntax-local-lift-require" +" 'syntax-local-lift-provide" +" 'syntax-local-lift-module-end-declaration" +" 'syntax-local-module-defined-identifiers" +" 'syntax-local-module-required-identifiers" +" 'syntax-local-module-exports" +" 'syntax-local-submodules" +" 'syntax-local-get-shadower" +" 'local-expand" +" 'local-expand/capture-lifts" +" 'local-transformer-expand" +" 'local-transformer-expand/capture-lifts" +" 'syntax-local-expand-expression" +" 'internal-definition-context?" +" 'syntax-local-make-definition-context" +" 'syntax-local-bind-syntaxes" +" 'internal-definition-context-binding-identifiers" +" 'internal-definition-context-introduce" +" 'internal-definition-context-seal" +" 'identifier-remove-from-definition-context" +" 'make-set!-transformer" +" 'prop:set!-transformer" +" 'set!-transformer?" +" 'set!-transformer-procedure" +" 'rename-transformer?" +" 'prop:rename-transformer" +" 'make-rename-transformer" +" 'rename-transformer-target" +" 'prop:liberal-define-context" +" 'liberal-define-context?" +" 'prop:expansion-contexts" +" 'module-path?" +" 'resolved-module-path?" +" 'make-resolved-module-path" +" 'resolved-module-path-name" +" 'module-path-index?" +" 'module-path-index-resolve" +" 'module-path-index-join" +" 'module-path-index-split" +" 'module-path-index-submodule" +" 'current-module-name-resolver" +" 'current-module-declare-name" +" 'current-module-declare-source" +" 'current-namespace" +" 'namespace-module-registry" +" 'namespace?" +" 'variable-reference->empty-namespace" +" 'variable-reference->namespace" +" 'variable-reference->resolved-module-path" +" 'variable-reference->module-path-index" +" 'variable-reference->module-source" +" 'variable-reference->phase" +" 'variable-reference->module-base-phase" +" 'variable-reference->module-declaration-inspector" +" 'read-syntax" +" 'read-syntax/recursive))" +"(void" +"(begin" +"(add-core-primitive! 'syntax? syntax?$1)" +"(add-core-primitive! 'syntax-e 1/syntax-e)" +"(add-core-primitive! 'syntax->datum 1/syntax->datum)" +"(add-core-primitive! 'datum->syntax 1/datum->syntax)" +"(add-core-primitive! 'bound-identifier=? 1/bound-identifier=?)" +"(add-core-primitive! 'free-identifier=? 1/free-identifier=?)" +"(add-core-primitive! 'free-transformer-identifier=? 1/free-transformer-identifier=?)" +"(add-core-primitive! 'free-template-identifier=? 1/free-template-identifier=?)" +"(add-core-primitive! 'free-label-identifier=? 1/free-label-identifier=?)" +"(add-core-primitive! 'identifier-binding 1/identifier-binding)" +"(add-core-primitive! 'identifier-transformer-binding 1/identifier-transformer-binding)" +"(add-core-primitive! 'identifier-template-binding 1/identifier-template-binding)" +"(add-core-primitive! 'identifier-label-binding 1/identifier-label-binding)" +"(add-core-primitive! 'identifier-binding-symbol 1/identifier-binding-symbol)" +"(add-core-primitive! 'identifier-prune-lexical-context 1/identifier-prune-lexical-context)" +"(add-core-primitive! 'syntax-debug-info 1/syntax-debug-info)" +"(add-core-primitive! 'syntax-track-origin 1/syntax-track-origin)" +"(add-core-primitive! 'syntax-shift-phase-level 1/syntax-shift-phase-level)" +"(add-core-primitive! 'syntax-source-module 1/syntax-source-module)" +"(add-core-primitive! 'identifier-prune-to-source-module 1/identifier-prune-to-source-module)" +"(add-core-primitive! 'syntax-source 1/syntax-source)" +"(add-core-primitive! 'syntax-line 1/syntax-line)" +"(add-core-primitive! 'syntax-column 1/syntax-column)" +"(add-core-primitive! 'syntax-position 1/syntax-position)" +"(add-core-primitive! 'syntax-span 1/syntax-span)" +"(add-core-primitive! 'syntax->list 1/syntax->list)" +"(add-core-primitive! 'syntax-property syntax-property$1)" +"(add-core-primitive! 'syntax-property-preserved? 1/syntax-property-preserved?)" +"(add-core-primitive! 'syntax-property-symbol-keys 1/syntax-property-symbol-keys)" +"(add-core-primitive! 'syntax-original? 1/syntax-original?)" +"(add-core-primitive! 'syntax-tainted? 1/syntax-tainted?)" +"(add-core-primitive! 'syntax-arm 1/syntax-arm)" +"(add-core-primitive! 'syntax-disarm 1/syntax-disarm)" +"(add-core-primitive! 'syntax-rearm 1/syntax-rearm)" +"(add-core-primitive! 'syntax-taint 1/syntax-taint)" +"(add-core-primitive! 'raise-syntax-error raise-syntax-error$1)" +"(add-core-primitive! 'struct:exn:fail:syntax 1/struct:exn:fail:syntax)" +"(add-core-primitive! 'exn:fail:syntax make-exn:fail:syntax$1)" +"(add-core-primitive! 'make-exn:fail:syntax make-exn:fail:syntax$1)" +"(add-core-primitive! 'exn:fail:syntax? 1/exn:fail:syntax?)" +"(add-core-primitive! 'exn:fail:syntax-exprs 1/exn:fail:syntax-exprs)" +"(add-core-primitive! 'struct:exn:fail:syntax:unbound 1/struct:exn:fail:syntax:unbound)" +"(add-core-primitive! 'exn:fail:syntax:unbound make-exn:fail:syntax:unbound$1)" +"(add-core-primitive! 'make-exn:fail:syntax:unbound make-exn:fail:syntax:unbound$1)" +"(add-core-primitive! 'exn:fail:syntax:unbound? 1/exn:fail:syntax:unbound?)" +"(add-core-primitive! 'current-module-path-for-load 1/current-module-path-for-load)" +"(add-core-primitive! 'prop:missing-module 1/prop:missing-module)" +"(add-core-primitive! 'exn:missing-module? 1/exn:missing-module?)" +"(add-core-primitive! 'exn:missing-module-accessor 1/exn:missing-module-accessor)" +"(add-core-primitive! 'struct:exn:fail:filesystem:missing-module 1/struct:exn:fail:filesystem:missing-module)" +"(add-core-primitive! 'exn:fail:filesystem:missing-module 1/make-exn:fail:filesystem:missing-module)" +"(add-core-primitive! 'make-exn:fail:filesystem:missing-module 1/make-exn:fail:filesystem:missing-module)" +"(add-core-primitive! 'exn:fail:filesystem:missing-module? 1/exn:fail:filesystem:missing-module?)" +"(add-core-primitive! 'exn:fail:filesystem:missing-module-path 1/exn:fail:filesystem:missing-module-path)" +"(add-core-primitive! 'struct:exn:fail:syntax:missing-module 1/struct:exn:fail:syntax:missing-module)" +"(add-core-primitive! 'exn:fail:syntax:missing-module 1/make-exn:fail:syntax:missing-module)" +"(add-core-primitive! 'make-exn:fail:syntax:missing-module 1/make-exn:fail:syntax:missing-module)" +"(add-core-primitive! 'exn:fail:syntax:missing-module? 1/exn:fail:syntax:missing-module?)" +"(add-core-primitive! 'exn:fail:syntax:missing-module-path 1/exn:fail:syntax:missing-module-path)" +"(add-core-primitive! 'syntax-transforming? 1/syntax-transforming?)" +"(add-core-primitive! 'syntax-transforming-with-lifts? 1/syntax-transforming-with-lifts?)" +"(add-core-primitive! 'syntax-transforming-module-expression? 1/syntax-transforming-module-expression?)" +"(add-core-primitive! 'syntax-local-transforming-module-provides? 1/syntax-local-transforming-module-provides?)" +"(add-core-primitive! 'syntax-local-context 1/syntax-local-context)" +"(add-core-primitive! 'syntax-local-introduce 1/syntax-local-introduce)" +"(add-core-primitive! 'syntax-local-identifier-as-binding 1/syntax-local-identifier-as-binding)" +"(add-core-primitive! 'syntax-local-phase-level 1/syntax-local-phase-level)" +"(add-core-primitive! 'syntax-local-name 1/syntax-local-name)" +"(add-core-primitive! 'make-syntax-introducer 1/make-syntax-introducer)" +"(add-core-primitive! 'make-syntax-delta-introducer 1/make-syntax-delta-introducer)" +"(add-core-primitive! 'syntax-local-value 1/syntax-local-value)" +"(add-core-primitive! 'syntax-local-value/immediate 1/syntax-local-value/immediate)" +"(add-core-primitive! 'syntax-local-lift-expression 1/syntax-local-lift-expression)" +"(add-core-primitive! 'syntax-local-lift-values-expression 1/syntax-local-lift-values-expression)" +"(add-core-primitive! 'syntax-local-lift-context 1/syntax-local-lift-context)" +"(add-core-primitive! 'syntax-local-lift-module 1/syntax-local-lift-module)" +"(add-core-primitive! 'syntax-local-lift-require 1/syntax-local-lift-require)" +"(add-core-primitive! 'syntax-local-lift-provide 1/syntax-local-lift-provide)" +"(add-core-primitive! 'syntax-local-lift-module-end-declaration 1/syntax-local-lift-module-end-declaration)" +"(add-core-primitive! 'syntax-local-module-defined-identifiers 1/syntax-local-module-defined-identifiers)" +"(add-core-primitive! 'syntax-local-module-required-identifiers 1/syntax-local-module-required-identifiers)" +"(add-core-primitive! 'syntax-local-module-exports 1/syntax-local-module-exports)" +"(add-core-primitive! 'syntax-local-submodules 1/syntax-local-submodules)" +"(add-core-primitive! 'syntax-local-get-shadower 1/syntax-local-get-shadower)" +"(add-core-primitive! 'local-expand 1/local-expand)" +"(add-core-primitive! 'local-expand/capture-lifts 1/local-expand/capture-lifts)" +"(add-core-primitive! 'local-transformer-expand 1/local-transformer-expand)" +"(add-core-primitive! 'local-transformer-expand/capture-lifts 1/local-transformer-expand/capture-lifts)" +"(add-core-primitive! 'syntax-local-expand-expression 1/syntax-local-expand-expression)" +"(add-core-primitive! 'internal-definition-context? 1/internal-definition-context?)" +"(add-core-primitive! 'syntax-local-make-definition-context 1/syntax-local-make-definition-context)" +"(add-core-primitive! 'syntax-local-bind-syntaxes 1/syntax-local-bind-syntaxes)" +"(add-core-primitive!" +" 'internal-definition-context-binding-identifiers" +" 1/internal-definition-context-binding-identifiers)" +"(add-core-primitive! 'internal-definition-context-introduce 1/internal-definition-context-introduce)" +"(add-core-primitive! 'internal-definition-context-seal 1/internal-definition-context-seal)" +"(add-core-primitive! 'identifier-remove-from-definition-context 1/identifier-remove-from-definition-context)" +"(add-core-primitive! 'make-set!-transformer 1/make-set!-transformer)" +"(add-core-primitive! 'prop:set!-transformer 1/prop:set!-transformer)" +"(add-core-primitive! 'set!-transformer? 1/set!-transformer?)" +"(add-core-primitive! 'set!-transformer-procedure 1/set!-transformer-procedure)" +"(add-core-primitive! 'rename-transformer? 1/rename-transformer?)" +"(add-core-primitive! 'prop:rename-transformer 1/prop:rename-transformer)" +"(add-core-primitive! 'make-rename-transformer 1/make-rename-transformer)" +"(add-core-primitive! 'rename-transformer-target 1/rename-transformer-target)" +"(add-core-primitive! 'prop:liberal-define-context 1/prop:liberal-define-context)" +"(add-core-primitive! 'liberal-define-context? has-liberal-define-context-property?)" +"(add-core-primitive! 'prop:expansion-contexts 1/prop:expansion-contexts)" +"(add-core-primitive! 'module-path? 1/module-path?)" +"(add-core-primitive! 'resolved-module-path? 1/resolved-module-path?)" +"(add-core-primitive! 'make-resolved-module-path 1/make-resolved-module-path)" +"(add-core-primitive! 'resolved-module-path-name 1/resolved-module-path-name)" +"(add-core-primitive! 'module-path-index? 1/module-path-index?)" +"(add-core-primitive! 'module-path-index-resolve 1/module-path-index-resolve)" +"(add-core-primitive! 'module-path-index-join 1/module-path-index-join)" +"(add-core-primitive! 'module-path-index-split 1/module-path-index-split)" +"(add-core-primitive! 'module-path-index-submodule 1/module-path-index-submodule)" +"(add-core-primitive! 'current-module-name-resolver 1/current-module-name-resolver)" +"(add-core-primitive! 'current-module-declare-name 1/current-module-declare-name)" +"(add-core-primitive! 'current-module-declare-source 1/current-module-declare-source)" +"(add-core-primitive! 'current-namespace 1/current-namespace)" +"(add-core-primitive! 'namespace-module-registry 1/namespace-module-registry)" +"(add-core-primitive! 'namespace? 1/namespace?)" +"(add-core-primitive! 'variable-reference->empty-namespace 1/variable-reference->empty-namespace)" +"(add-core-primitive! 'variable-reference->namespace 1/variable-reference->namespace)" +"(add-core-primitive! 'variable-reference->resolved-module-path 1/variable-reference->resolved-module-path)" +"(add-core-primitive! 'variable-reference->module-path-index 1/variable-reference->module-path-index)" +"(add-core-primitive! 'variable-reference->module-source 1/variable-reference->module-source)" +"(add-core-primitive! 'variable-reference->phase 1/variable-reference->phase)" +"(add-core-primitive! 'variable-reference->module-base-phase 1/variable-reference->module-base-phase)" +"(add-core-primitive!" +" 'variable-reference->module-declaration-inspector" +" 1/variable-reference->module-declaration-inspector)" +"(add-core-primitive! 'read-syntax 1/read-syntax)" +"(add-core-primitive! 'read-syntax/recursive 1/read-syntax/recursive)))" +"(define-values" +"(declare-kernel-module!8.1)" +"(lambda(eval1_0 main-ids2_0 read-ids3_0 ns7_1)" +"(begin" +" 'declare-kernel-module!8" +"(let-values(((ns_85) ns7_1))" +"(let-values()" +"(let-values(((main-ids_0) main-ids2_0))" +"(let-values(((read-ids_0) read-ids3_0))" +"(let-values()" +"(begin" +"(let-values(((temp53_5) '#%kernel)" +"((temp54_6) '#%runtime)" +"((temp55_3)(set-union primitive-ids(set-union main-ids_0 read-ids_0)))" +"((temp56_2)" +"(hasheq" +" 'variable-reference?" +" 1/variable-reference?" +" 'variable-reference-constant?" +" 1/variable-reference-constant?" +" 'variable-reference-from-unsafe?" +" 1/variable-reference-from-unsafe?))" +"((ns57_0) ns_85))" +"(copy-runtime-module!26.1 #f #f temp56_2 #t ns57_0 #f #f #f #f temp55_3 #t temp54_6 #t temp53_5))" +"(let-values(((temp58_5) '#%kernel)((temp59_5) '(#%core #%runtime #%main #%read))((ns60_0) ns_85))" +"(declare-reexporting-module!50.1 ns60_0 #f #f temp58_5 temp59_5)))))))))))" +"(define-values" +"(copy-runtime-module!26.1)" +"(lambda(alts14_0" +" alts21_0" +" extras15_0" +" extras22_0" +" namespace12_0" +" primitive?16_0" +" primitive?23_0" +" protected?17_0" +" protected?24_0" +" skip13_0" +" skip20_0" +" to11_0" +" to18_0" +" name25_0)" +"(begin" +" 'copy-runtime-module!26" +"(let-values(((name_72) name25_0))" +"(let-values(((to-name_0)(if to18_0 to11_0 name_72)))" +"(let-values(((ns_118) namespace12_0))" +"(let-values(((skip-syms_0)(if skip20_0 skip13_0(seteq))))" +"(let-values(((alts_0)(if alts21_0 alts14_0 '#hasheq())))" +"(let-values(((extras_0)(if extras22_0 extras15_0 '#hasheq())))" +"(let-values(((primitive?_9)(if primitive?23_0 primitive?16_0 #t)))" +"(let-values(((protected?_2)(if protected?24_0 protected?17_0 #f)))" +"(let-values()" +"(let-values(((prims_0)(1/primitive-table name_72)))" +"(let-values((()" +"(begin" +"(let-values(((ht_156) prims_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_156)))" +"((letrec-values(((for-loop_242)" +"(lambda(i_178)" +"(begin" +" 'for-loop" +"(if i_178" +"(let-values(((sym_95)" +"(hash-iterate-key ht_156 i_178)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(register-built-in-symbol!" +" sym_95))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_242" +"(hash-iterate-next ht_156 i_178))" +"(values))))" +"(values))))))" +" for-loop_242)" +"(hash-iterate-first ht_156))))" +"(values))))" +"(let-values()" +"(let-values(((ht_157)" +"(let-values(((ht_158) prims_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_158)))" +"((letrec-values(((for-loop_264)" +"(lambda(table_206 i_179)" +"(begin" +" 'for-loop" +"(if i_179" +"(let-values(((sym_96 val_78)" +"(hash-iterate-key+value" +" ht_158" +" i_179)))" +"(let-values(((table_13)" +"(let-values(((table_14)" +" table_206))" +"(if(set-member?" +" skip-syms_0" +" sym_96)" +" table_14" +"(let-values(((table_207)" +" table_14))" +"(let-values(((table_208)" +"(let-values()" +"(let-values(((key_87" +" val_79)" +"(let-values()" +"(values" +" sym_96" +"(let-values(((or-part_75)" +"(hash-ref" +" alts_0" +" sym_96" +" #f)))" +"(if or-part_75" +" or-part_75" +" val_78))))))" +"(hash-set" +" table_207" +" key_87" +" val_79)))))" +"(values table_208)))))))" +"(if(not #f)" +"(for-loop_264" +" table_13" +"(hash-iterate-next ht_158 i_179))" +" table_13)))" +" table_206)))))" +" for-loop_264)" +" '#hasheq()" +"(hash-iterate-first ht_158))))))" +"(let-values(((ht+extras_0)" +"(let-values(((ht_159) extras_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_159)))" +"((letrec-values(((for-loop_266)" +"(lambda(ht_160 i_180)" +"(begin" +" 'for-loop" +"(if i_180" +"(let-values(((k_42 v_40)" +"(hash-iterate-key+value" +" ht_159" +" i_180)))" +"(let-values(((ht_161)" +"(let-values(((ht_151)" +" ht_160))" +"(let-values(((ht_162)" +"(let-values()" +"(hash-set" +" ht_151" +" k_42" +" v_40))))" +"(values ht_162)))))" +"(if(not #f)" +"(for-loop_266" +" ht_161" +"(hash-iterate-next ht_159 i_180))" +" ht_161)))" +" ht_160)))))" +" for-loop_266)" +" ht_157" +"(hash-iterate-first ht_159))))))" +"(let-values(((ns63_0) ns_118)" +"((primitive?64_0) primitive?_9)" +"((protected?65_0) protected?_2))" +"(declare-hash-based-module!41.1" +" ns63_0" +" primitive?64_0" +" #t" +" #f" +" #f" +" protected?65_0" +" #t" +" #f" +" #f" +" to-name_0" +" ht+extras_0)))))))))))))))))))" +"(define-values" +"(declare-hash-based-module!41.1)" +"(lambda(namespace29_0" +" primitive?30_0" +" primitive?35_0" +" protected32_0" +" protected37_0" +" protected?31_0" +" protected?36_0" +" register-builtin?33_0" +" register-builtin?38_0" +" name39_0" +" ht40_0)" +"(begin" +" 'declare-hash-based-module!41" +"(let-values(((name_73) name39_0))" +"(let-values(((ht_163) ht40_0))" +"(let-values(((ns_119) namespace29_0))" +"(let-values(((primitive?_6)(if primitive?35_0 primitive?30_0 #f)))" +"(let-values(((protected?_3)(if protected?36_0 protected?31_0 #f)))" +"(let-values(((protected-syms_0)(if protected37_0 protected32_0 null)))" +"(let-values(((register-builtin?_0)(if register-builtin?38_0 register-builtin?33_0 #f)))" +"(let-values()" +"(let-values(((mpi_49)(1/module-path-index-join(list 'quote name_73) #f)))" +"(let-values(((ns66_1) ns_119)" +"((temp67_3)" +"(let-values(((temp69_5) #t)" +"((primitive?70_0) primitive?_6)" +"((temp71_5) #t)" +"((temp72_2)(not protected?_3))" +"((mpi73_1) mpi_49)" +"((temp74_2)" +"(hasheqv" +" 0" +"(let-values(((ht_164) ht_163))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_164)))" +"((letrec-values(((for-loop_189)" +"(lambda(table_209 i_181)" +"(begin" +" 'for-loop" +"(if i_181" +"(let-values(((sym_97)" +"(hash-iterate-key" +" ht_164" +" i_181)))" +"(let-values(((table_36)" +"(let-values(((table_37)" +" table_209))" +"(let-values(((table_210)" +"(let-values()" +"(let-values(((key_88" +" val_80)" +"(let-values()" +"(let-values((()" +"(begin" +"(if register-builtin?_0" +"(let-values()" +"(register-built-in-symbol!" +" sym_97))" +"(void))" +"(values))))" +"(let-values(((binding_28)" +"(let-values(((mpi76_0)" +" mpi_49)" +"((temp77_3)" +" 0)" +"((sym78_0)" +" sym_97))" +"(make-module-binding22.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" mpi76_0" +" temp77_3" +" sym78_0))))" +"(values" +" sym_97" +"(if(let-values(((or-part_362)" +" protected?_3))" +"(if or-part_362" +" or-part_362" +"(member" +" sym_97" +" protected-syms_0)))" +"(provided1.1" +" binding_28" +" #t" +" #f)" +" binding_28)))))))" +"(hash-set" +" table_37" +" key_88" +" val_80)))))" +"(values" +" table_210)))))" +"(if(not #f)" +"(for-loop_189" +" table_36" +"(hash-iterate-next" +" ht_164" +" i_181))" +" table_36)))" +" table_209)))))" +" for-loop_189)" +" '#hash()" +"(hash-iterate-first ht_164))))))" +"((temp75_2)" +"(lambda(data-box_6" +" ns_120" +" phase-shift_20" +" phase-level_5" +" self_7" +" bulk-binding-registry_2" +" insp_23)" +"(if(= 0 phase-level_5)" +"(let-values()" +"(begin" +"(let-values(((ht_125) ht_163))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash ht_125)))" +"((letrec-values(((for-loop_267)" +"(lambda(i_182)" +"(begin" +" 'for-loop" +"(if i_182" +"(let-values(((sym_98 val_81)" +"(hash-iterate-key+value" +" ht_125" +" i_182)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-variable!" +" ns_120" +" 0" +" sym_98" +" val_81))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_267" +"(hash-iterate-next" +" ht_125" +" i_182))" +"(values))))" +"(values))))))" +" for-loop_267)" +"(hash-iterate-first ht_125))))" +"(void)))" +"(void)))))" +"(make-module39.1" +" temp69_5" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp75_2" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp72_2" +" #t" +" #f" +" #f" +" temp71_5" +" #t" +" #f" +" #f" +" primitive?70_0" +" #t" +" temp74_2" +" #f" +" #f" +" mpi73_1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f)))" +"((temp68_1)(1/module-path-index-resolve mpi_49)))" +"(declare-module!58.1 #f #f ns66_1 temp67_3 temp68_1))))))))))))))" +"(define-values" +"(declare-reexporting-module!50.1)" +"(lambda(namespace45_0 reexport?44_0 reexport?46_0 name48_0 require-names49_0)" +"(begin" +" 'declare-reexporting-module!50" +"(let-values(((name_74) name48_0))" +"(let-values(((require-names_0) require-names49_0))" +"(let-values(((reexport?_0)(if reexport?46_0 reexport?44_0 #t)))" +"(let-values(((ns_121) namespace45_0))" +"(let-values()" +"(let-values(((mpi_50)(1/module-path-index-join(list 'quote name_74) #f)))" +"(let-values(((require-mpis_0)" +"(reverse$1" +"(let-values(((lst_150) require-names_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_150)))" +"((letrec-values(((for-loop_244)" +"(lambda(fold-var_273 lst_307)" +"(begin" +" 'for-loop" +"(if(pair? lst_307)" +"(let-values(((require-name_0)(unsafe-car lst_307))" +"((rest_175)(unsafe-cdr lst_307)))" +"(let-values(((fold-var_138)" +"(let-values(((fold-var_274) fold-var_273))" +"(let-values(((fold-var_275)" +"(let-values()" +"(cons" +"(let-values()" +"(1/module-path-index-join" +"(list" +" 'quote" +" require-name_0)" +" #f))" +" fold-var_274))))" +"(values fold-var_275)))))" +"(if(not #f)" +"(for-loop_244 fold-var_138 rest_175)" +" fold-var_138)))" +" fold-var_273)))))" +" for-loop_244)" +" null" +" lst_150))))))" +"(let-values(((ns79_1) ns_121)" +"((temp80_6)" +"(let-values(((temp82_6) #t)" +"((temp83_4) #t)" +"((mpi84_0) mpi_50)" +"((temp85_3)(list(cons 0 require-mpis_0)))" +"((temp86_1)" +"(if reexport?_0" +"(hasheqv" +" 0" +"(let-values(((lst_308) require-mpis_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_308)))" +"((letrec-values(((for-loop_120)" +"(lambda(table_211 lst_309)" +"(begin" +" 'for-loop" +"(if(pair? lst_309)" +"(let-values(((require-mpi_0)" +"(unsafe-car lst_309))" +"((rest_176)" +"(unsafe-cdr lst_309)))" +"(let-values(((table_212)" +"(let-values(((m_29)" +"(namespace->module" +" ns_121" +"(1/module-path-index-resolve" +" require-mpi_0))))" +"(begin" +" #t" +"((letrec-values(((for-loop_268)" +"(lambda(table_213)" +"(begin" +" 'for-loop" +"(let-values()" +"(let-values(((table_214)" +"(let-values(((ht_165)" +"(hash-ref" +"(shift-provides-module-path-index" +"(module-provides" +" m_29)" +"(module-self" +" m_29)" +" require-mpi_0)" +" 0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-in-hash" +" ht_165)))" +"((letrec-values(((for-loop_121)" +"(lambda(table_107" +" i_183)" +"(begin" +" 'for-loop" +"(if i_183" +"(let-values(((sym_99" +" binding_29)" +"(hash-iterate-key+value" +" ht_165" +" i_183)))" +"(let-values(((table_32)" +"(let-values(((table_215)" +" table_107))" +"(let-values(((table_108)" +"(let-values()" +"(let-values(((key_89" +" val_82)" +"(let-values()" +"(values" +" sym_99" +" binding_29))))" +"(hash-set" +" table_215" +" key_89" +" val_82)))))" +"(values" +" table_108)))))" +"(if(not" +" #f)" +"(for-loop_121" +" table_32" +"(hash-iterate-next" +" ht_165" +" i_183))" +" table_32)))" +" table_107)))))" +" for-loop_121)" +" table_213" +"(hash-iterate-first" +" ht_165))))))" +" table_214))))))" +" for-loop_268)" +" table_211)))))" +"(if(not #f)" +"(for-loop_120 table_212 rest_176)" +" table_212)))" +" table_211)))))" +" for-loop_120)" +" '#hash()" +" lst_308))))" +" '#hasheqv()))" +"((void87_0) void))" +"(make-module39.1" +" temp82_6" +" #t" +" #f" +" #f" +" #f" +" #f" +" void87_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp83_4" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp86_1" +" temp85_3" +" #t" +" mpi84_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f)))" +"((temp81_3)(1/module-path-index-resolve mpi_50)))" +"(declare-module!58.1 #f #f ns79_1 temp80_6 temp81_3))))))))))))" +"(define-values" +"(read-primitives)" +"(hasheq" +" 'read" +" 1/read" +" 'read/recursive" +" 1/read/recursive" +" 'read-language" +" 1/read-language" +" 'string->number" +" 1/string->number" +" 'current-reader-guard" +" 1/current-reader-guard" +" 'read-square-bracket-as-paren" +" 1/read-square-bracket-as-paren" +" 'read-curly-brace-as-paren" +" 1/read-curly-brace-as-paren" +" 'read-square-bracket-with-tag" +" 1/read-square-bracket-with-tag" +" 'read-curly-brace-with-tag" +" 1/read-curly-brace-with-tag" +" 'read-cdot" +" 1/read-cdot" +" 'read-accept-graph" +" 1/read-accept-graph" +" 'read-accept-compiled" +" 1/read-accept-compiled" +" 'read-accept-box" +" 1/read-accept-box" +" 'read-decimal-as-inexact" +" 1/read-decimal-as-inexact" +" 'read-accept-dot" +" 1/read-accept-dot" +" 'read-accept-infix-dot" +" 1/read-accept-infix-dot" +" 'read-accept-quasiquote" +" 1/read-accept-quasiquote" +" 'read-accept-reader" +" 1/read-accept-reader" +" 'read-accept-lang" +" 1/read-accept-lang" +" 'current-readtable" +" 1/current-readtable" +" 'readtable?" +" 1/readtable?" +" 'make-readtable" +" 1/make-readtable" +" 'readtable-mapping" +" 1/readtable-mapping" +" 'special-comment?" +" 1/special-comment?" +" 'make-special-comment" +" 1/make-special-comment" +" 'special-comment-value" +" 1/special-comment-value))" +"(define-values" +"(main-primitives)" +"(hasheq" +" 'eval" +" eval$1" +" 'eval-syntax" +" 1/eval-syntax" +" 'compile" +" compile$1" +" 'compile-syntax" +" 1/compile-syntax" +" 'expand" +" 1/expand" +" 'expand-syntax" +" 1/expand-syntax" +" 'expand-once" +" 1/expand-once" +" 'expand-syntax-once" +" 1/expand-syntax-once" +" 'expand-to-top-form" +" 1/expand-to-top-form" +" 'expand-syntax-to-top-form" +" 1/expand-syntax-to-top-form" +" 'dynamic-require" +" 1/dynamic-require" +" 'dynamic-require-for-syntax" +" 1/dynamic-require-for-syntax" +" 'load" +" 1/load" +" 'load-extension" +" 1/load-extension" +" 'load/use-compiled" +" 1/load/use-compiled" +" 'current-eval" +" 1/current-eval" +" 'current-compile" +" 1/current-compile" +" 'current-load" +" 1/current-load" +" 'current-load/use-compiled" +" 1/current-load/use-compiled" +" 'collection-path" +" 1/collection-path" +" 'collection-file-path" +" 1/collection-file-path" +" 'find-library-collection-paths" +" 1/find-library-collection-paths" +" 'find-library-collection-links" +" 1/find-library-collection-links" +" 'current-library-collection-paths" +" 1/current-library-collection-paths" +" 'current-library-collection-links" +" 1/current-library-collection-links" +" 'use-compiled-file-paths" +" 1/use-compiled-file-paths" +" 'current-compiled-file-roots" +" 1/current-compiled-file-roots" +" 'use-compiled-file-check" +" 1/use-compiled-file-check" +" 'use-collection-link-paths" +" 1/use-collection-link-paths" +" 'use-user-specific-search-paths" +" 1/use-user-specific-search-paths" +" 'compiled-expression?" +" 1/compiled-expression?" +" 'compiled-module-expression?" +" 1/compiled-module-expression?" +" 'module-compiled-name" +" 1/module-compiled-name" +" 'module-compiled-submodules" +" 1/module-compiled-submodules" +" 'module-compiled-language-info" +" 1/module-compiled-language-info" +" 'module-compiled-imports" +" 1/module-compiled-imports" +" 'module-compiled-exports" +" 1/module-compiled-exports" +" 'module-compiled-indirect-exports" +" 1/module-compiled-indirect-exports" +" 'compiled-expression-recompile" +" 1/compiled-expression-recompile" +" 'make-empty-namespace" +" 1/make-empty-namespace" +" 'namespace-attach-module" +" 1/namespace-attach-module" +" 'namespace-attach-module-declaration" +" 1/namespace-attach-module-declaration" +" 'namespace-symbol->identifier" +" 1/namespace-symbol->identifier" +" 'namespace-module-identifier" +" 1/namespace-module-identifier" +" 'namespace-syntax-introduce" +" 1/namespace-syntax-introduce" +" 'namespace-require" +" 1/namespace-require" +" 'namespace-require/copy" +" 1/namespace-require/copy" +" 'namespace-require/constant" +" 1/namespace-require/constant" +" 'namespace-require/expansion-time" +" 1/namespace-require/expansion-time" +" 'namespace-variable-value" +" 1/namespace-variable-value" +" 'namespace-set-variable-value!" +" 1/namespace-set-variable-value!" +" 'namespace-undefine-variable!" +" 1/namespace-undefine-variable!" +" 'namespace-mapped-symbols" +" 1/namespace-mapped-symbols" +" 'namespace-base-phase" +" 1/namespace-base-phase" +" 'module-declared?" +" 1/module-declared?" +" 'module-predefined?" +" 1/module-predefined?" +" 'module->language-info" +" 1/module->language-info" +" 'module->imports" +" 1/module->imports" +" 'module->exports" +" 1/module->exports" +" 'module->indirect-exports" +" 1/module->indirect-exports" +" 'module-compiled-cross-phase-persistent?" +" 1/module-compiled-cross-phase-persistent?" +" 'module-provide-protected?" +" 1/module-provide-protected?" +" 'module->namespace" +" 1/module->namespace" +" 'namespace-unprotect-module" +" 1/namespace-unprotect-module))" +"(define-values" +"(utils-primitives)" +"(hasheq" +" 'path-string?" +" path-string?" +" 'normal-case-path" +" normal-case-path" +" 'path-replace-extension" +" path-replace-extension" +" 'path-add-extension" +" path-add-extension" +" 'reroot-path" +" reroot-path" +" 'path-list-string->path-list" +" path-list-string->path-list" +" 'find-executable-path" +" find-executable-path" +" 'call-with-default-reading-parameterization" +" call-with-default-reading-parameterization" +" 'collection-path" +" 1/collection-path" +" 'collection-file-path" +" 1/collection-file-path" +" 'find-library-collection-paths" +" 1/find-library-collection-paths" +" 'find-library-collection-links" +" 1/find-library-collection-links" +" 'load/use-compiled" +" 1/load/use-compiled" +" 'find-main-config" +" find-main-config" +" 'find-main-collects" +" find-main-collects))" +"(define-values(expobs-primitives)(hasheq 'current-expand-observe current-expand-observe))" +"(define-values" +"(struct:TH-place-channel TH-place-channel TH-place-channel? TH-place-channel-ref TH-place-channel-set!)" +"(make-struct-type 'TH-place-channel #f 2 0 #f(list(cons prop:evt(lambda(x_87)(TH-place-channel-ref x_87 0))))))" +"(define-values" +"(TH-place-channel-in TH-place-channel-out)" +"(values(lambda(x_88)(TH-place-channel-ref x_88 0))(lambda(x_89)(TH-place-channel-ref x_89 1))))" +"(define-values" +"(place-struct-primitives)" +"(hasheq" +" 'struct:TH-place-channel" +" struct:TH-place-channel" +" 'TH-place-channel" +" TH-place-channel" +" 'TH-place-channel?" +" TH-place-channel?" +" 'TH-place-channel-in" +" TH-place-channel-in" +" 'TH-place-channel-out" +" TH-place-channel-out))" +"(define-values" +"(linklet-primitives)" +"(hasheq" +" 'primitive-table" +" 1/primitive-table" +" 'primitive->compiled-position" +" 1/primitive->compiled-position" +" 'compiled-position->primitive" +" 1/compiled-position->primitive" +" 'primitive-in-category?" +" 1/primitive-in-category?" +" 'linklet?" +" 1/linklet?" +" 'compile-linklet" +" 1/compile-linklet" +" 'recompile-linklet" +" 1/recompile-linklet" +" 'eval-linklet" +" 1/eval-linklet" +" 'read-compiled-linklet" +" 1/read-compiled-linklet" +" 'instantiate-linklet" +" 1/instantiate-linklet" +" 'linklet-import-variables" +" 1/linklet-import-variables" +" 'linklet-export-variables" +" 1/linklet-export-variables" +" 'instance?" +" 1/instance?" +" 'make-instance" +" 1/make-instance" +" 'instance-name" +" 1/instance-name" +" 'instance-data" +" 1/instance-data" +" 'instance-variable-names" +" 1/instance-variable-names" +" 'instance-variable-value" +" 1/instance-variable-value" +" 'instance-set-variable-value!" +" 1/instance-set-variable-value!" +" 'instance-unset-variable!" +" 1/instance-unset-variable!" +" 'linklet-directory?" +" 1/linklet-directory?" +" 'hash->linklet-directory" +" 1/hash->linklet-directory" +" 'linklet-directory->hash" +" 1/linklet-directory->hash" +" 'linklet-bundle?" +" 1/linklet-bundle?" +" 'hash->linklet-bundle" +" 1/hash->linklet-bundle" +" 'linklet-bundle->hash" +" 1/linklet-bundle->hash" +" 'variable-reference?" +" 1/variable-reference?" +" 'variable-reference->instance" +" 1/variable-reference->instance" +" 'variable-reference-constant?" +" 1/variable-reference-constant?" +" 'variable-reference-from-unsafe?" +" 1/variable-reference-from-unsafe?))" +"(define-values" +"(with-module-reading-parameterization)" +"(lambda(thunk_1)" +"(begin" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #t" +" 1/read-accept-compiled" +" #t" +" read-case-sensitive" +" #t" +" 1/read-square-bracket-as-paren" +" #t" +" 1/read-curly-brace-as-paren" +" #t" +" 1/read-square-bracket-with-tag" +" #f" +" 1/read-curly-brace-with-tag" +" #f" +" 1/read-accept-box" +" #t" +" read-accept-bar-quote" +" #t" +" 1/read-accept-graph" +" #t" +" 1/read-decimal-as-inexact" +" #t" +" 1/read-cdot" +" #f" +" 1/read-accept-dot" +" #t" +" 1/read-accept-infix-dot" +" #t" +" 1/read-accept-quasiquote" +" #t" +" 1/current-readtable" +" #f)" +"(let-values()(thunk_1))))))" +"(define-values" +"(check-module-form)" +"(lambda(exp_0 filename_1)" +"(begin" +"(if(let-values(((or-part_298)(eof-object? exp_0)))" +"(if or-part_298 or-part_298(eof-object?(1/syntax-e exp_0))))" +"(let-values()" +"(if filename_1" +"(error" +" 'load-handler" +" (string-append \"expected a `module' declaration, but found end-of-file\\n\" \" file: ~a\")" +" filename_1)" +" #f))" +"(if(1/compiled-module-expression?(1/syntax-e exp_0))" +"(let-values() exp_0)" +"(if(if(syntax?$1 exp_0)" +"(if(pair?(1/syntax-e exp_0))" +"(if(eq? 'module(1/syntax-e(car(1/syntax-e exp_0))))" +"(let-values(((r_48)(cdr(1/syntax-e exp_0))))" +"(let-values(((r_49)(if(syntax?$1 r_48)(1/syntax-e r_48) r_48)))" +"(if(pair? r_49)(identifier?(car r_49)) #f)))" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(1/datum->syntax exp_0(cons(1/namespace-module-identifier)(cdr(1/syntax-e exp_0))) exp_0 exp_0))" +"(let-values()" +"(if filename_1" +"(error" +" 'default-load-handler" +" (string-append \"expected a `module' declaration, but found something else\\n\" \" file: ~a\")" +" filename_1)" +" #f))))))))" +"(define-values" +"(default-load-handler)" +"(lambda(path_12 expected-mod_0)" +"(begin" +"(let-values((()" +"(begin" +"(if(path-string? path_12)" +"(void)" +" (let-values () (raise-argument-error 'default-load-handler \"path-string?\" path_12)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_11)(not expected-mod_0)))" +"(if or-part_11" +" or-part_11" +"(let-values(((or-part_2)(symbol? expected-mod_0)))" +"(if or-part_2" +" or-part_2" +"(if(pair? expected-mod_0)" +"(if(list? expected-mod_0)" +"(if(let-values(((or-part_26)(not(car expected-mod_0))))" +"(if or-part_26 or-part_26(symbol?(car expected-mod_0))))" +"(andmap2 symbol?(cdr expected-mod_0))" +" #f)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'default-load-handler" +" \"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))\"" +" expected-mod_0)))" +"(values))))" +"(let-values(((maybe-count-lines!_0)" +"(lambda(i_124)" +"(begin" +" 'maybe-count-lines!" +" (if (regexp-match? '#rx\"[.]zo$\" path_12)" +"(void)" +"(let-values()(port-count-lines! i_124)))))))" +"(if expected-mod_0" +"(let-values()" +"((call-with-input-module-file" +" path_12" +"(lambda(i_184)" +"(begin" +"(maybe-count-lines!_0 i_184)" +"(with-module-reading-parameterization+delay-source" +" path_12" +"(lambda()" +"(let-values(((c1_30)(linklet-directory-start i_184)))" +"(if c1_30" +"((lambda(pos_119)" +"(let-values(((b-pos_0)" +"(search-directory i_184 pos_119(encode-symbols expected-mod_0))))" +"(if b-pos_0" +"(let-values()" +"(begin" +"(file-position i_184 b-pos_0)" +"(let-values(((or-part_12)(cached-bundle i_184)))" +"(if or-part_12" +" or-part_12" +"(let-values(((v_0)(1/read i_184)))" +"(if(1/compiled-module-expression? v_0)" +"(lambda()((1/current-eval) v_0))" +"(error" +" 'default-load-handler" +"(string-append" +" \"expected a compiled module\\n\"" +" \" in: ~e\\n\"" +" \" found: ~e\")" +"(object-name i_184)" +" v_0)))))))" +"(if(pair? expected-mod_0)" +"(let-values() void)" +"(let-values()" +"(error" +" 'default-load-handler" +" (string-append \"could not find main module\\n\" \" in: ~e\")" +"(object-name i_184)))))))" +" c1_30)" +"(if(if(pair? expected-mod_0)(not(car expected-mod_0)) #f)" +"(let-values() void)" +"(let-values(((c2_16)(cached-bundle i_184)))" +"(if c2_16" +"((lambda(thunk_6) thunk_6) c2_16)" +"(let-values()" +"(let-values(((s_171)(1/read-syntax(object-name i_184) i_184)))" +"(let-values((()" +"(begin" +"(if(eof-object? s_171)" +"(let-values()" +"(error" +" 'default-load-handler" +"(string-append" +" \"expected a `module' declaration;\\n\"" +" \" found end-of-file\\n\"" +" \" in: ~e\")" +"(object-name i_184)))" +"(void))" +"(values))))" +"(let-values(((m-s_0)(check-module-form s_171 path_12)))" +"(let-values(((s2_7)(1/read-syntax(object-name i_184) i_184)))" +"(begin" +"(if(eof-object? s2_7)" +"(void)" +"(let-values()" +"(error" +" 'default-load-handler" +"(string-append" +" \"expected a `module' declaration;\\n\"" +" \" found an extra form\\n\"" +" \" in: ~e\\n\"" +" \" found: ~.s\")" +"(object-name i_184)" +" s2_7)))" +"(lambda()((1/current-eval) m-s_0))))))))))))))))))))" +"(let-values()" +"(let-values(((add-top-interaction_0)" +"(lambda(s_411)" +"(begin" +" 'add-top-interaction" +"(1/namespace-syntax-introduce" +"(1/datum->syntax #f(cons '#%top-interaction s_411)))))))" +"(let-values(((path1_0) path_12)" +"((temp2_7)" +"(lambda(i_74)" +"(begin" +" 'temp2" +"(begin" +"(maybe-count-lines!_0 i_74)" +"((letrec-values(((loop_119)" +"(lambda(vals_7)" +"(begin" +" 'loop" +"(let-values(((s_303)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/read-accept-compiled" +" #t" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #t)" +"(let-values()" +"(if(load-on-demand-enabled)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" read-on-demand-source" +"(path->complete-path path_12))" +"(let-values()" +"(1/read-syntax" +"(object-name i_74)" +" i_74)))" +"(1/read-syntax" +"(object-name i_74)" +" i_74))))))" +"(if(eof-object? s_303)" +"(apply values vals_7)" +"(loop_119" +"(call-with-continuation-prompt" +"(lambda()" +"(call-with-values" +"(lambda()" +"((1/current-eval)(add-top-interaction_0 s_303)))" +" list))" +"(default-continuation-prompt-tag)" +"(lambda args_10" +"(apply" +" abort-current-continuation" +"(default-continuation-prompt-tag)" +" args_10))))))))))" +" loop_119)" +"(list(void))))))))" +"(call-with-input-file*61.1 #f #f path1_0 temp2_7)))))))))))" +"(define-values" +"(linklet-bundle-or-directory-start)" +"(lambda(i_145 tag_1)" +"(begin" +"(let-values(((version-length_0)(string-length(version))))" +"(if(equal?(peek-byte i_145)(char->integer '#\\#))" +"(if(equal?(peek-byte i_145 1)(char->integer '#\\~))" +"(if(equal?(peek-byte i_145 2) version-length_0)" +"(if(equal?(peek-bytes version-length_0 3 i_145)(string->bytes/utf-8(version)))" +"(if(equal?(peek-byte i_145(+ 3 version-length_0))(char->integer tag_1))(+ version-length_0 4) #f)" +" #f)" +" #f)" +" #f)" +" #f)))))" +"(define-values" +"(linklet-directory-start)" +"(lambda(i_185)" +"(begin(let-values(((pos_93)(linklet-bundle-or-directory-start i_185 '#\\D)))(if pos_93(+ pos_93 4) #f)))))" +"(define-values" +"(linklet-bundle-hash-code)" +"(lambda(i_80)" +"(begin" +"(let-values(((pos_14)(linklet-bundle-or-directory-start i_80 '#\\B)))" +"(let-values(((hash-code_5)(if pos_14(peek-bytes 20 pos_14 i_80) #f)))" +"(if(bytes? hash-code_5)" +"(if(= 20(bytes-length hash-code_5))" +"(if(let-values(((vec_66 len_40)" +"(let-values(((vec_67) hash-code_5))" +"(begin(check-bytes vec_67)(values vec_67(unsafe-bytes-length vec_67))))))" +"(begin" +" #f" +"((letrec-values(((for-loop_220)" +"(lambda(result_116 pos_120)" +"(begin" +" 'for-loop" +"(if(unsafe-fx< pos_120 len_40)" +"(let-values(((c_52)(unsafe-bytes-ref vec_66 pos_120)))" +"(let-values(((result_117)" +"(let-values()" +"(let-values(((result_118)" +"(let-values()" +"(let-values()(not(eq? c_52 0))))))" +"(values result_118)))))" +"(if(if(not((lambda x_90 result_117) c_52))(not #f) #f)" +"(for-loop_220 result_117(unsafe-fx+ 1 pos_120))" +" result_117)))" +" result_116)))))" +" for-loop_220)" +" #f" +" 0)))" +" hash-code_5" +" #f)" +" #f)" +" #f))))))" +"(define-values" +"(cached-bundle)" +"(lambda(i_186)" +"(begin" +"(let-values(((c3_9)(module-cache-ref(make-module-cache-key(linklet-bundle-hash-code i_186)))))" +"(if c3_9" +"((lambda(declare-module_0)(lambda()(declare-module_0(1/current-namespace)))) c3_9)" +"(let-values() #f))))))" +"(define-values" +"(read-number)" +"(lambda(i_41)" +"(begin" +"(let-values(((read-byte/not-eof_0)" +"(lambda(i_187)" +"(begin" +" 'read-byte/not-eof" +"(let-values(((v_243)(read-byte i_187)))(if(eof-object? v_243) 0 v_243))))))" +"(bitwise-ior" +"(read-byte/not-eof_0 i_41)" +"(arithmetic-shift(read-byte/not-eof_0 i_41) 8)" +"(arithmetic-shift(read-byte/not-eof_0 i_41) 16)" +"(arithmetic-shift(read-byte/not-eof_0 i_41) 24))))))" +"(define-values" +"(search-directory)" +"(lambda(i_188 pos_121 bstr_5)" +"(begin" +"(if(zero? pos_121)" +"(let-values() #f)" +"(let-values()" +"(let-values((()(begin(file-position i_188 pos_121)(values))))" +"(let-values(((name-len_0)(read-number i_188)))" +"(let-values(((v_244)(read-bytes name-len_0 i_188)))" +"(begin" +"(if(if(bytes? v_244)(=(bytes-length v_244) name-len_0) #f)" +"(void)" +"(let-values()" +"(error" +" 'deafult-load-handler" +"(string-append" +" \"failure getting submodule path\\n\"" +" \" in: ~e\\n\"" +" \" at position: ~a\\n\"" +" \" expected bytes: ~a\\n\"" +" \" read bytes: ~e\")" +"(object-name i_188)" +" pos_121" +" name-len_0" +" v_244)))" +"(if(bytes=? bstr_5 v_244)" +"(let-values()(read-number i_188))" +"(if(bytesbytes/utf-8" +"(symbol->string s_471))))" +"(let-values(((len_41)" +"(bytes-length bstr_6)))" +"(if(< len_41 255)" +"(let-values()" +"(bytes-append" +"(bytes len_41)" +" bstr_6))" +"(let-values()" +"(bytes-append" +" 255" +"(integer->integer-bytes" +" len_41" +" 4" +" #f" +" #f)" +" bstr_6))))))" +" fold-var_68))))" +"(values fold-var_69)))))" +"(if(not #f)(for-loop_102 fold-var_20 rest_42) fold-var_20)))" +" fold-var_67)))))" +" for-loop_102)" +" null" +" lst_310))))))))))" +"(define-values" +"(with-module-reading-parameterization+delay-source)" +"(lambda(path_13 thunk_7)" +"(begin" +"(if(load-on-demand-enabled)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" read-on-demand-source" +"(path->complete-path path_13))" +"(let-values()(with-module-reading-parameterization thunk_7)))" +"(with-module-reading-parameterization thunk_7)))))" +"(define-values" +"(call-with-input-module-file)" +"(lambda(path_14 proc_9)" +"(begin" +"(let-values(((i_189) #f))" +"(dynamic-wind" +"(lambda()(set! i_189(let-values(((temp4_8) #t))(open-input-file6.1 temp4_8 #t #f #f path_14))))" +"(lambda()(proc_9 i_189))" +"(lambda()(close-input-port i_189)))))))" +"(define-values(dll-suffix)(system-type 'so-suffix))" +"(define-values" +"(default-load/use-compiled)" +"(let-values(((resolve_0)" +"(lambda(s_157)" +"(begin" +" 'resolve" +"(if(complete-path? s_157)" +" s_157" +"(let-values(((d_36)(current-load-relative-directory)))" +"(if d_36(path->complete-path s_157 d_36) s_157)))))))" +"(let-values(((date-of-1_0)" +"(lambda(a_28)" +"(begin" +" 'date-of-1" +"(let-values(((v_67)(file-or-directory-modify-seconds a_28 #f(lambda() #f))))" +"(if v_67(cons a_28 v_67) #f))))))" +"(let-values(((date-of_0)" +"(lambda(a_35 modes_1 roots_1)" +"(begin" +" 'date-of" +"(ormap2" +"(lambda(root-dir_0)" +"(ormap2" +"(lambda(compiled-dir_0)" +"(let-values(((a_36)(a_35 root-dir_0 compiled-dir_0)))(date-of-1_0 a_36)))" +" modes_1))" +" roots_1)))))" +"(let-values(((date>=?_0)" +"(lambda(modes_2 roots_2 a_72 bm_0)" +"(begin" +" 'date>=?" +"(if a_72" +"(let-values(((am_0)(date-of_0 a_72 modes_2 roots_2)))" +"(let-values(((or-part_28)(if(not bm_0) am_0 #f)))" +"(if or-part_28" +" or-part_28" +"(if am_0(if bm_0(if(>=(cdr am_0)(cdr bm_0)) am_0 #f) #f) #f))))" +" #f)))))" +"(let-values(((with-dir*_0)" +"(lambda(base_24 t_55)" +"(begin" +" 'with-dir*" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" current-load-relative-directory" +"(if(path? base_24) base_24(current-directory)))" +"(let-values()(t_55)))))))" +"(lambda(path_15 expect-module_0)" +"(begin" +"(let-values((()" +"(begin" +"(if(path-string? path_15)" +"(void)" +" (let-values () (raise-argument-error 'load/use-compiled \"path-string?\" path_15)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_164)(not expect-module_0)))" +"(if or-part_164" +" or-part_164" +"(let-values(((or-part_76)(symbol? expect-module_0)))" +"(if or-part_76" +" or-part_76" +"(if(list? expect-module_0)" +"(if(>(length expect-module_0) 1)" +"(if(let-values(((or-part_77)(symbol?(car expect-module_0))))" +"(if or-part_77 or-part_77(not(car expect-module_0))))" +"(andmap2 symbol?(cdr expect-module_0))" +" #f)" +" #f)" +" #f)))))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'load/use-compiled" +" \"(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))\"" +" path_15)))" +"(values))))" +"(let-values(((name_75)(if expect-module_0(1/current-module-declare-name) #f)))" +"(let-values(((ns-hts_0)" +"(if name_75" +"(registry-table-ref(1/namespace-module-registry(1/current-namespace)))" +" #f)))" +"(let-values(((use-path/src_0)(if ns-hts_0(hash-ref(cdr ns-hts_0) name_75 #f) #f)))" +"(if use-path/src_0" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-module-declare-source" +"(cadr use-path/src_0))" +"(let-values()" +"(with-dir*_0" +"(caddr use-path/src_0)" +"(lambda()((1/current-load)(car use-path/src_0) expect-module_0)))))" +"(let-values(((orig-path_0)(resolve_0 path_15)))" +"(let-values(((base_22 orig-file_0 dir?_7)(split-path path_15)))" +"(let-values(((file_1 alt-file_0)" +"(if expect-module_0" +"(let-values(((b_47)(path->bytes orig-file_0)))" +"(let-values(((len_7)(bytes-length b_47)))" +"(if(if(>= len_7 4)" +" (bytes=? #\".rkt\" (subbytes b_47 (- len_7 4)))" +" #f)" +"(let-values()" +"(values" +" orig-file_0" +"(bytes->path" +" (bytes-append (subbytes b_47 0 (- len_7 4)) #\".ss\"))))" +"(let-values()(values orig-file_0 #f)))))" +"(values orig-file_0 #f))))" +"(let-values(((path_16)" +"(if(eq? file_1 orig-file_0) orig-path_0(build-path base_22 file_1))))" +"(let-values(((alt-path_0)" +"(if alt-file_0" +"(if(eq? alt-file_0 orig-file_0)" +" orig-path_0" +"(build-path base_22 alt-file_0))" +" #f)))" +"(let-values(((base_25)(if(eq? base_22 'relative) 'same base_22)))" +"(let-values(((modes_3)(1/use-compiled-file-paths)))" +"(let-values(((roots_3)(1/current-compiled-file-roots)))" +"(let-values(((reroot_0)" +"(lambda(p_70 d_37)" +"(begin" +" 'reroot" +"(if(eq? d_37 'same)" +"(let-values() p_70)" +"(if(relative-path? d_37)" +"(let-values()(build-path p_70 d_37))" +"(let-values()(reroot-path p_70 d_37))))))))" +"(let-values(((main-path-d_0)(date-of-1_0 path_16)))" +"(let-values(((alt-path-d_0)" +"(if alt-path_0" +"(if(not main-path-d_0)(date-of-1_0 alt-path_0) #f)" +" #f)))" +"(let-values(((path-d_0)" +"(let-values(((or-part_55) main-path-d_0))" +"(if or-part_55 or-part_55 alt-path-d_0))))" +"(let-values(((get-so_0)" +"(lambda(file_2 rep-sfx?_0)" +"(begin" +" 'get-so" +"(lambda(root-dir_1 compiled-dir_1)" +"(build-path" +"(reroot_0 base_25 root-dir_1)" +" compiled-dir_1" +" \"native\"" "(system-library-subpath)" -"(if rep-sfx?" -"(path-add-extension" -" file" -" dll-suffix)" -" file)))))" -"(zo(lambda(root-dir compiled-dir)" -"(build-path(reroot base root-dir)" -" compiled-dir" -" (path-add-extension file #\".zo\"))))" -"(alt-zo(lambda(root-dir compiled-dir)" -"(build-path(reroot base root-dir)" -" compiled-dir" -" (path-add-extension alt-file #\".zo\"))))" -"(so(get-so file #t))" -"(alt-so(get-so alt-file #t))" -"(try-main?(or main-path-d(not alt-path-d)))" -"(try-alt?(and alt-file(or alt-path-d(not main-path-d))))" -"(with-dir(lambda(t)(with-dir* base t))))" -"(cond" -"((and try-main?" -"(date>=? modes roots so path-d))" -" =>(lambda(so-d)" -"(parameterize((current-module-declare-source #f))" -"(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))" -"((and try-alt?" -"(date>=? modes roots alt-so alt-path-d))" -" =>(lambda(so-d)" -"(parameterize((current-module-declare-source alt-path))" -"(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))" -"((and try-main?" -"(date>=? modes roots zo path-d))" -" =>(lambda(zo-d)" -"(register-zo-path name ns-hts(car zo-d) #f base)" -"(parameterize((current-module-declare-source #f))" -"(with-dir(lambda()((current-load)(car zo-d) expect-module))))))" -"((and try-alt?" -"(date>=? modes roots alt-zo path-d))" -" =>(lambda(zo-d)" -"(register-zo-path name ns-hts(car zo-d) alt-path base)" -"(parameterize((current-module-declare-source alt-path))" -"(with-dir(lambda()((current-load)(car zo-d) expect-module))))))" -"((or(not(pair? expect-module))" -"(car expect-module))" -"(let((p(if try-main? path alt-path)))" -"(unless(and(pair? expect-module)" -"(not(file-exists? p)))" -"(parameterize((current-module-declare-source(and expect-module " -"(not try-main?)" -" p)))" -"(with-dir(lambda()((current-load) p expect-module))))))))))))))" -"(define(register-zo-path name ns-hts path src-path base)" -"(when ns-hts" -"(hash-set!(cdr ns-hts) name(list path src-path base))))" -"(define-values(default-reader-guard)" -"(lambda(path) path))" -"(define-values(-module-hash-table-table)(make-weak-hasheq)) " -"(define CACHE-N 512)" -"(define-values(-path-cache)(make-vector CACHE-N #f)) " -"(define(path-cache-get p)" -"(let*((i(modulo(abs(equal-hash-code p)) CACHE-N))" -"(w(vector-ref -path-cache i))" -"(l(and w(weak-box-value w))))" -"(and l" -"(let((a(assoc p l)))" -"(and a(cdr a))))))" -"(define(path-cache-set! p v)" -"(let*((i(modulo(abs(equal-hash-code p)) CACHE-N))" -"(w(vector-ref -path-cache i))" -"(l(and w(weak-box-value w))))" -"(vector-set! -path-cache i(make-weak-box(cons(cons p v)(or l null))))))" +"(if rep-sfx?_0" +"(path-add-extension file_2 dll-suffix)" +" file_2)))))))" +"(let-values(((zo_0)" +"(lambda(root-dir_2 compiled-dir_2)" +"(begin" +" 'zo" +"(build-path" +"(reroot_0 base_25 root-dir_2)" +" compiled-dir_2" +" (path-add-extension file_1 #\".zo\"))))))" +"(let-values(((alt-zo_0)" +"(lambda(root-dir_3 compiled-dir_3)" +"(begin" +" 'alt-zo" +"(build-path" +"(reroot_0 base_25 root-dir_3)" +" compiled-dir_3" +" (path-add-extension alt-file_0 #\".zo\"))))))" +"(let-values(((so_0)(get-so_0 file_1 #t)))" +"(let-values(((alt-so_0)(get-so_0 alt-file_0 #t)))" +"(let-values(((try-main?_0)" +"(let-values(((or-part_347) main-path-d_0))" +"(if or-part_347" +" or-part_347" +"(not alt-path-d_0)))))" +"(let-values(((try-alt?_0)" +"(if alt-file_0" +"(let-values(((or-part_363)" +" alt-path-d_0))" +"(if or-part_363" +" or-part_363" +"(not main-path-d_0)))" +" #f)))" +"(let-values(((with-dir_0)" +"(lambda(t_56)" +"(begin" +" 'with-dir" +"(with-dir*_0 base_25 t_56)))))" +"(let-values(((c1_31)" +"(if try-main?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" so_0" +" path-d_0)" +" #f)))" +"(if c1_31" +"((lambda(so-d_0)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" #f)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((current-load-extension)" +"(car so-d_0)" +" expect-module_0))))))" +" c1_31)" +"(let-values(((c2_17)" +"(if try-alt?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" alt-so_0" +" alt-path-d_0)" +" #f)))" +"(if c2_17" +"((lambda(so-d_1)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" alt-path_0)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((current-load-extension)" +"(car so-d_1)" +" expect-module_0))))))" +" c2_17)" +"(let-values(((c3_10)" +"(if try-main?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" zo_0" +" path-d_0)" +" #f)))" +"(if c3_10" +"((lambda(zo-d_0)" +"(begin" +"(register-zo-path" +" name_75" +" ns-hts_0" +"(car zo-d_0)" +" #f" +" base_25)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" #f)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((1/current-load)" +"(car zo-d_0)" +" expect-module_0)))))))" +" c3_10)" +"(let-values(((c4_3)" +"(if try-alt?_0" +"(date>=?_0" +" modes_3" +" roots_3" +" alt-zo_0" +" path-d_0)" +" #f)))" +"(if c4_3" +"((lambda(zo-d_1)" +"(begin" +"(register-zo-path" +" name_75" +" ns-hts_0" +"(car zo-d_1)" +" alt-path_0" +" base_25)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +" alt-path_0)" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((1/current-load)" +"(car zo-d_1)" +" expect-module_0)))))))" +" c4_3)" +"(if(let-values(((or-part_364)" +"(not" +"(pair?" +" expect-module_0))))" +"(if or-part_364" +" or-part_364" +"(car expect-module_0)))" +"(let-values()" +"(let-values(((p_71)" +"(if try-main?_0" +" path_16" +" alt-path_0)))" +"(if(if(pair?" +" expect-module_0)" +"(not" +"(file-exists? p_71))" +" #f)" +"(void)" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-source" +"(if expect-module_0" +"(if(not try-main?_0)" +" p_71" +" #f)" +" #f))" +"(let-values()" +"(with-dir_0" +"(lambda()" +"((1/current-load)" +" p_71" +" expect-module_0)))))))))" +"(void))))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(register-zo-path)" +"(lambda(name_76 ns-hts_1 path_17 src-path_0 base_26)" +"(begin(if ns-hts_1(let-values()(hash-set!(cdr ns-hts_1) name_76(list path_17 src-path_0 base_26)))(void)))))" +"(define-values(default-reader-guard)(lambda(path_18)(begin path_18)))" +"(define-values(-module-hash-table-table)(make-weak-hasheq))" +"(define-values" +"(registry-table-ref)" +"(lambda(reg_0)" +"(begin(let-values(((e_40)(hash-ref -module-hash-table-table reg_0 #f)))(if e_40(ephemeron-value e_40) #f)))))" +"(define-values" +"(registry-table-set!)" +"(lambda(reg_1 v_199)(begin(hash-set! -module-hash-table-table reg_1(make-ephemeron reg_1 v_199)))))" +"(define-values(CACHE-N) 512)" +"(define-values(-path-cache)(make-vector CACHE-N #f))" +"(define-values" +"(path-cache-get)" +"(lambda(p_72)" +"(begin" +"(let-values(((i_27)(modulo(abs(equal-hash-code p_72)) CACHE-N)))" +"(let-values(((w_1)(vector-ref -path-cache i_27)))" +"(let-values(((l_81)(if w_1(weak-box-value w_1) #f)))" +"(if l_81(let-values(((a_71)(1/assoc p_72 l_81)))(if a_71(cdr a_71) #f)) #f)))))))" +"(define-values" +"(path-cache-set!)" +"(lambda(p_73 v_89)" +"(begin" +"(let-values(((i_95)(modulo(abs(equal-hash-code p_73)) CACHE-N)))" +"(let-values(((w_2)(vector-ref -path-cache i_95)))" +"(let-values(((l_70)(if w_2(weak-box-value w_2) #f)))" +"(vector-set!" +" -path-cache" +" i_95" +"(make-weak-box" +"(cons(cons p_73 v_89)(let-values(((or-part_72) l_70))(if or-part_72 or-part_72 null)))))))))))" "(define-values(-loading-filename)(gensym))" "(define-values(-loading-prompt-tag)(make-continuation-prompt-tag 'module-loading))" "(define-values(-prev-relto) #f)" "(define-values(-prev-relto-dir) #f)" -"(define(split-relative-string s coll-mode?)" -"(let((l(let loop((s s))" -"(let((len(string-length s)))" -"(let iloop((i 0))" -"(cond" -"((= i len)(list s))" -"((char=? #\\/(string-ref s i))" -"(cons(substring s 0 i)" -"(loop(substring s(add1 i)))))" -"(else(iloop(add1 i)))))))))" -"(if coll-mode?" -" l" -"(let loop((l l))" -"(if(null?(cdr l))" -"(values null(car l))" -"(let-values(((c f)(loop(cdr l))))" -"(values(cons(car l) c) f)))))))" -"(define(format-source-location stx)" -"(srcloc->string(srcloc(syntax-source stx)" -"(syntax-line stx)" -"(syntax-column stx)" -"(syntax-position stx)" -"(syntax-span stx))))" -"(define-values(orig-paramz) #f)" -"(define-values(standard-module-name-resolver)" +"(define-values" +"(split-relative-string)" +"(lambda(s_467 coll-mode?_0)" +"(begin" +"(let-values(((l_19)" +"((letrec-values(((loop_120)" +"(lambda(s_472)" +"(begin" +" 'loop" +"(let-values(((len_42)(string-length s_472)))" +"((letrec-values(((iloop_2)" +"(lambda(i_190)" +"(begin" +" 'iloop" +"(if(= i_190 len_42)" +"(let-values()(list s_472))" +"(if(char=? '#\\/(string-ref s_472 i_190))" "(let-values()" -"(define-values(planet-resolver) #f)" -"(define-values(prep-planet-resolver!)" +"(cons" +"(substring s_472 0 i_190)" +"(loop_120(substring s_472(add1 i_190)))))" +"(let-values()(iloop_2(add1 i_190)))))))))" +" iloop_2)" +" 0))))))" +" loop_120)" +" s_467)))" +"(if coll-mode?_0" +" l_19" +"((letrec-values(((loop_96)" +"(lambda(l_79)" +"(begin" +" 'loop" +"(if(null?(cdr l_79))" +"(values null(car l_79))" +"(let-values(((c_99 f_39)(loop_96(cdr l_79))))" +"(values(cons(car l_79) c_99) f_39)))))))" +" loop_96)" +" l_19))))))" +"(define-values" +"(format-source-location)" +"(lambda(stx_16)" +"(begin" +"(srcloc->string" +"(srcloc" +"(1/syntax-source stx_16)" +"(1/syntax-line stx_16)" +"(1/syntax-column stx_16)" +"(1/syntax-position stx_16)" +"(1/syntax-span stx_16))))))" +"(define-values(orig-paramz) #f)" +"(define-values" +"(standard-module-name-resolver)" +"(let-values()" +"(let-values(((planet-resolver_0) #f))" +"(let-values(((prep-planet-resolver!_0)" "(lambda()" -"(unless planet-resolver" +"(begin" +" 'prep-planet-resolver!" +"(if planet-resolver_0" +"(void)" +"(let-values()" "(with-continuation-mark" " parameterization-key" " orig-paramz" -" (set! planet-resolver (dynamic-require '(lib \"planet/resolver.rkt\") 'planet-module-name-resolver))))))" -"(define-values(standard-module-name-resolver)" -"(case-lambda " -"((s from-namespace) " -"(unless(resolved-module-path? s)" -"(raise-argument-error 'standard-module-name-resolver" -" \"resolved-module-path?\"" -" s))" -"(unless(or(not from-namespace)(namespace? from-namespace))" -"(raise-argument-error 'standard-module-name-resolver" -" \"(or/c #f namespace?)\"" -" from-namespace))" -"(when planet-resolver" -"(planet-resolver s))" -"(let((hts(or(hash-ref -module-hash-table-table" -"(namespace-module-registry(current-namespace))" +"(set! planet-resolver_0" +" (1/dynamic-require '(lib \"planet/resolver.rkt\") 'planet-module-name-resolver)))))))))" +"(letrec-values(((standard-module-name-resolver_0)" +"(case-lambda" +"((s_166 from-namespace_1)" +"(begin" +" 'standard-module-name-resolver" +"(begin" +"(if(1/resolved-module-path? s_166)" +"(void)" +"(let-values()" +" (raise-argument-error 'standard-module-name-resolver \"resolved-module-path?\" s_166)))" +"(if(let-values(((or-part_282)(not from-namespace_1)))" +"(if or-part_282 or-part_282(1/namespace? from-namespace_1)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"(or/c #f namespace?)\"" +" from-namespace_1)))" +"(if planet-resolver_0(let-values()(planet-resolver_0 s_166))(void))" +"(let-values(((hts_1)" +"(let-values(((or-part_256)" +"(registry-table-ref" +"(1/namespace-module-registry(1/current-namespace)))))" +"(if or-part_256" +" or-part_256" +"(let-values(((hts_2)(cons(make-hasheq)(make-hasheq))))" +"(begin" +"(registry-table-set!" +"(1/namespace-module-registry(1/current-namespace))" +" hts_2)" +" hts_2))))))" +"(begin" +"(hash-set!(car hts_1) s_166 'declared)" +"(if from-namespace_1" +"(let-values()" +"(let-values(((root-name_2)" +"(if(pair?(1/resolved-module-path-name s_166))" +"(1/make-resolved-module-path" +"(car(1/resolved-module-path-name s_166)))" +" s_166))" +"((from-hts_0)" +"(registry-table-ref" +"(1/namespace-module-registry from-namespace_1))))" +"(if from-hts_0" +"(let-values()" +"(let-values(((use-path/src_1)(hash-ref(cdr from-hts_0) root-name_2 #f)))" +"(if use-path/src_1" +"(let-values()(hash-set!(cdr hts_1) root-name_2 use-path/src_1))" +"(void))))" +"(void))))" +"(void)))))))" +"((s_473 relto_0 stx_17)" +"(begin" +"(log-message" +"(current-logger)" +" 'error" +" \"default module name resolver called with three arguments (deprecated)\"" " #f)" -"(let((hts(cons(make-hasheq)(make-hasheq))))" -"(hash-set! -module-hash-table-table" -"(namespace-module-registry(current-namespace))" -" hts)" -" hts))))" -"(hash-set!(car hts) s 'declared)" -"(when from-namespace" -"(let((root-name(if(pair?(resolved-module-path-name s))" -"(make-resolved-module-path(car(resolved-module-path-name s)))" -" s))" -"(from-hts(hash-ref -module-hash-table-table" -"(namespace-module-registry from-namespace)" -" #f)))" -"(when from-hts" -"(let((use-path/src(hash-ref(cdr from-hts) root-name #f)))" -"(when use-path/src" -"(hash-set!(cdr hts) root-name use-path/src))))))))" -"((s relto stx) " -"(log-message(current-logger) 'error" -" \"default module name resolver called with three arguments (deprecated)\"" -" #f)" -"(standard-module-name-resolver s relto stx #t)) " -"((s relto stx load?)" -"(unless(module-path? s)" -"(if(syntax? stx)" -"(raise-syntax-error #f" -" \"bad module path\"" -" stx)" -"(raise-argument-error 'standard-module-name-resolver" -" \"module-path?\"" -" s)))" -"(unless(or(not relto)(resolved-module-path? relto))" -"(raise-argument-error 'standard-module-name-resolver" -" \"(or/c #f resolved-module-path?)\"" -" relto))" -"(unless(or(not stx)(syntax? stx))" -"(raise-argument-error 'standard-module-name-resolver" -" \"(or/c #f syntax?)\"" -" stx))" -"(define(flatten-sub-path base orig-l)" -"(let loop((a null)(l orig-l))" -"(cond" -"((null? l)(if(null? a)" -" base" -"(cons base(reverse a))))" -" ((equal? (car l) \"..\")" -"(if(null? a)" +"(standard-module-name-resolver_0 s_473 relto_0 stx_17 #t)))" +"((s_26 relto_1 stx_18 load?_7)" +"(let-values((()" +"(begin" +"(if(1/module-path? s_26)" +"(void)" +"(let-values()" +"(if(syntax?$1 stx_18)" +" (raise-syntax-error$1 #f \"bad module path\" stx_18)" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"module-path?\"" +" s_26))))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_147)(not relto_1)))" +"(if or-part_147 or-part_147(1/resolved-module-path? relto_1)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"(or/c #f resolved-module-path?)\"" +" relto_1)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_57)(not stx_18)))" +"(if or-part_57 or-part_57(syntax?$1 stx_18)))" +"(void)" +"(let-values()" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"(or/c #f syntax?)\"" +" stx_18)))" +"(values))))" +"(let-values(((flatten-sub-path_0)" +"(lambda(base_27 orig-l_10)" +"(begin" +" 'flatten-sub-path" +"((letrec-values(((loop_121)" +"(lambda(a_73 l_33)" +"(begin" +" 'loop" +"(if(null? l_33)" +"(let-values()" +"(if(null? a_73)" +" base_27" +"(cons base_27(reverse$1 a_73))))" +" (if (equal? (car l_33) \"..\")" +"(let-values()" +"(if(null? a_73)" "(error" " 'standard-module-name-resolver" -" \"too many \\\"..\\\"s in submodule path: ~.s\"" -"(list* 'submod" -" (if (equal? base \".\") " -" base " -"(if(path? base)" -" base" -"(list(if(symbol? base) 'quote 'file) base)))" -" orig-l))" -"(loop(cdr a)(cdr l))))" -"(else(loop(cons(car l) a)(cdr l))))))" -"(cond" -"((and(pair? s)(eq?(car s) 'quote))" -"(make-resolved-module-path(cadr s)))" -"((and(pair? s)(eq?(car s) 'submod)" -"(pair?(cadr s))(eq?(caadr s) 'quote))" -"(make-resolved-module-path(flatten-sub-path(cadadr s)(cddr s))))" -"((and(pair? s)(eq?(car s) 'submod)" -" (or (equal? (cadr s) \".\")" -" (equal? (cadr s) \"..\"))" -"(and relto" -"(let((p(resolved-module-path-name relto)))" -"(or(symbol? p)" -"(and(pair? p)(symbol?(car p)))))))" -"(define rp(resolved-module-path-name relto))" -"(make-resolved-module-path(flatten-sub-path(if(pair? rp)(car rp) rp)" -" (let ((r (if (equal? (cadr s) \"..\")" -"(cdr s)" -"(cddr s))))" -"(if(pair? rp)" -"(append(cdr rp) r)" -" r)))))" -"((and(pair? s)(eq?(car s) 'planet))" -"(prep-planet-resolver!)" -"(planet-resolver s relto stx load? #f orig-paramz))" -"((and(pair? s)" -"(eq?(car s) 'submod)" -"(pair?(cadr s))" -"(eq?(caadr s) 'planet))" -"(prep-planet-resolver!)" -"(planet-resolver(cadr s) relto stx load?(cddr s) orig-paramz))" -"(else" -"(let((get-dir(lambda()" -"(or(and relto" -"(if(eq? relto -prev-relto)" -" -prev-relto-dir" -"(let((p(resolved-module-path-name relto)))" -"(let((p(if(pair? p)(car p) p)))" -"(and(path? p)" -"(let-values(((base n d?)(split-path p)))" -"(set! -prev-relto relto)" -"(set! -prev-relto-dir base)" -" base))))))" -"(current-load-relative-directory)" -"(current-directory))))" -"(get-reg(lambda()" -"(namespace-module-registry(current-namespace))))" -"(show-collection-err(lambda(msg)" -"(let((msg(string-append" -"(or(and stx" -"(error-print-source-location)" -"(format-source-location stx))" -" \"standard-module-name-resolver\")" -" \": \"" -" (regexp-replace #rx\"\\n\" " -" msg" -" (format \"\\n for module path: ~s\\n\"" -" s)))))" -"(raise" -"(if stx" -"(exn:fail:syntax:missing-module" -" msg" -"(current-continuation-marks)" -"(list stx)" -" s)" -"(exn:fail:filesystem:missing-module" -" msg" -"(current-continuation-marks)" -" s))))))" -"(ss->rkt(lambda(s)" -"(let((len(string-length s)))" -"(if(and(len . >= . 3)" -"(equal? #\\.(string-ref s(- len 3)))" -"(equal? #\\s(string-ref s(- len 2)))" -"(equal? #\\s(string-ref s(- len 1))))" -" (string-append (substring s 0 (- len 3)) \".rkt\")" -" s))))" -"(path-ss->rkt(lambda(p)" -"(let-values(((base name dir?)(split-path p)))" -" (if (regexp-match #rx\"[.]ss$\" (path->bytes name))" -" (path-replace-extension p #\".rkt\")" -" p))))" -"(s(if(and(pair? s)(eq? 'submod(car s)))" -"(let((v(cadr s)))" -" (if (or (equal? v \".\")" -" (equal? v \"..\"))" -"(if relto" -"(let((p(resolved-module-path-name relto)))" -"(if(pair? p)" -"(car p)" -" p))" -"(error 'standard-module-name-resolver" -" \"no base path for relative submodule path: ~.s\"" -" s))" -" v))" -" s))" -"(subm-path(if(and(pair? s)(eq? 'submod(car s)))" -" (let ((p (if (and (or (equal? (cadr s) \".\")" -" (equal? (cadr s) \"..\"))" -" relto)" -"(let((p(resolved-module-path-name relto))" -" (r (if (equal? (cadr s) \"..\")" -"(cdr s)" -"(cddr s))))" -"(if(pair? p)" -"(flatten-sub-path(car p)(append(cdr p) r))" -"(flatten-sub-path p r)))" -" (flatten-sub-path \".\" " -" (if (equal? (cadr s) \"..\")" -"(cdr s)" -"(cddr s))))))" -"(if(pair? p)" -"(cdr p)" -" #f))" -" #f)))" -"(let((s-parsed" -"(cond" -"((symbol? s)" -"(or(path-cache-get(cons s(get-reg)))" -"(let-values(((cols file)(split-relative-string(symbol->string s) #f)))" -"(let*((f-file(if(null? cols)" -" \"main.rkt\"" -" (string-append file \".rkt\"))))" -"(find-col-file show-collection-err" -"(if(null? cols) file(car cols))" -"(if(null? cols) null(cdr cols))" -" f-file" -" #t)))))" -"((string? s)" -"(let*((dir(get-dir)))" -"(or(path-cache-get(cons s dir))" -"(let-values(((cols file)(split-relative-string s #f)))" -"(if(null? cols)" -"(build-path dir(ss->rkt file))" -"(apply build-path " -" dir" -"(append" -"(map(lambda(s)" -"(cond" -" ((string=? s \".\") 'same)" -" ((string=? s \"..\") 'up)" -"(else s)))" -" cols)" -"(list(ss->rkt file)))))))))" -"((path? s) " -"(path-ss->rkt(simplify-path(if(complete-path? s)" -" s" -"(path->complete-path s(get-dir))))))" -"((eq?(car s) 'lib)" -"(or(path-cache-get(cons s(get-reg)))" -"(let*-values(((cols file)(split-relative-string(cadr s) #f))" -"((old-style?)(if(null?(cddr s))" -"(and(null? cols)" -" (regexp-match? #rx\"[.]\" file))" -" #t)))" -"(let*((f-file(if old-style?" -"(ss->rkt file)" -"(if(null? cols)" -" \"main.rkt\"" -" (if (regexp-match? #rx\"[.]\" file)" -"(ss->rkt file)" -" (string-append file \".rkt\"))))))" -"(let-values(((cols)" -"(if old-style?" -"(append(if(null?(cddr s))" -" '(\"mzlib\")" -"(apply append" -"(map(lambda(p)" -"(split-relative-string p #t))" -"(cddr s))))" -" cols)" -"(if(null? cols)" -"(list file)" -" cols))))" -"(find-col-file show-collection-err" -"(car cols)" -"(cdr cols)" -" f-file" -" #t))))))" -"((eq?(car s) 'file)" -"(path-ss->rkt " -"(simplify-path(path->complete-path(expand-user-path(cadr s))(get-dir))))))))" -"(unless(or(path? s-parsed)" -"(vector? s-parsed))" -"(if stx" -"(raise-syntax-error" -" 'require" -" (format \"bad module path~a\" (if s-parsed" -"(car s-parsed)" -" \"\"))" -" stx)" -"(raise-argument-error " -" 'standard-module-name-resolver" -" \"module-path?\"" -" s)))" -"(let*((filename(if(vector? s-parsed)" -"(vector-ref s-parsed 0)" -"(simplify-path(cleanse-path s-parsed) #f)))" -"(normal-filename(if(vector? s-parsed)" -"(vector-ref s-parsed 1)" -"(normal-case-path filename))))" -"(let-values(((base name dir?)(if(vector? s-parsed)" -"(values 'ignored(vector-ref s-parsed 2) 'ignored)" -"(split-path filename))))" -"(let*((no-sfx(if(vector? s-parsed)" -"(vector-ref s-parsed 3)" -" (path-replace-extension name #\"\"))))" -"(let*((root-modname(if(vector? s-parsed)" -"(vector-ref s-parsed 4)" -"(make-resolved-module-path filename)))" -"(hts(or(hash-ref -module-hash-table-table" -"(get-reg)" +" \"too many \\\"..\\\"s in submodule path: ~.s\"" +"(list*" +" 'submod" +" (if (equal? base_27 \".\")" +" base_27" +"(if(path? base_27)" +" base_27" +"(list" +"(if(symbol? base_27)" +" 'quote" +" 'file)" +" base_27)))" +" orig-l_10))" +"(loop_121(cdr a_73)(cdr l_33))))" +"(let-values()" +"(loop_121" +"(cons(car l_33) a_73)" +"(cdr l_33)))))))))" +" loop_121)" +" null" +" orig-l_10)))))" +"(if(if(pair? s_26)(eq?(car s_26) 'quote) #f)" +"(let-values()(1/make-resolved-module-path(cadr s_26)))" +"(if(if(pair? s_26)" +"(if(eq?(car s_26) 'submod)" +"(if(pair?(cadr s_26))(eq?(caadr s_26) 'quote) #f)" " #f)" -"(let((hts(cons(make-hasheq)(make-hasheq))))" -"(hash-set! -module-hash-table-table" -"(get-reg)" -" hts)" -" hts)))" -"(modname(if subm-path" -"(make-resolved-module-path " -"(cons(resolved-module-path-name root-modname)" -" subm-path))" -" root-modname)))" -"(when load?" -"(let((got(hash-ref(car hts) modname #f)))" -"(unless got" -"(let((loading" -"(let((tag(if(continuation-prompt-available? -loading-prompt-tag)" +" #f)" +"(let-values()" +"(1/make-resolved-module-path(flatten-sub-path_0(cadadr s_26)(cddr s_26))))" +"(if(if(pair? s_26)" +"(if(eq?(car s_26) 'submod)" +" (if (let-values (((or-part_98) (equal? (cadr s_26) \".\")))" +" (if or-part_98 or-part_98 (equal? (cadr s_26) \"..\")))" +"(if relto_1" +"(let-values(((p_74)(1/resolved-module-path-name relto_1)))" +"(let-values(((or-part_38)(symbol? p_74)))" +"(if or-part_38" +" or-part_38" +"(if(pair? p_74)(symbol?(car p_74)) #f))))" +" #f)" +" #f)" +" #f)" +" #f)" +"(let-values()" +"(let-values(((rp_0)(1/resolved-module-path-name relto_1)))" +"(1/make-resolved-module-path" +"(flatten-sub-path_0" +"(if(pair? rp_0)(car rp_0) rp_0)" +"(let-values(((r_50)" +" (if (equal? (cadr s_26) \"..\") (cdr s_26) (cddr s_26))))" +"(if(pair? rp_0)(append(cdr rp_0) r_50) r_50))))))" +"(if(if(pair? s_26)(eq?(car s_26) 'planet) #f)" +"(let-values()" +"(begin" +"(prep-planet-resolver!_0)" +"(planet-resolver_0 s_26 relto_1 stx_18 load?_7 #f orig-paramz)))" +"(if(if(pair? s_26)" +"(if(eq?(car s_26) 'submod)" +"(if(pair?(cadr s_26))(eq?(caadr s_26) 'planet) #f)" +" #f)" +" #f)" +"(let-values()" +"(begin" +"(prep-planet-resolver!_0)" +"(planet-resolver_0" +"(cadr s_26)" +" relto_1" +" stx_18" +" load?_7" +"(cddr s_26)" +" orig-paramz)))" +"(let-values()" +"(let-values(((get-dir_0)" +"(lambda()" +"(begin" +" 'get-dir" +"(let-values(((or-part_58)" +"(if relto_1" +"(if(eq? relto_1 -prev-relto)" +" -prev-relto-dir" +"(let-values(((p_75)" +"(1/resolved-module-path-name" +" relto_1)))" +"(let-values(((p_76)" +"(if(pair? p_75)" +"(car p_75)" +" p_75)))" +"(if(path? p_76)" +"(let-values(((base_28" +" n_35" +" d?_0)" +"(split-path" +" p_76)))" +"(begin" +"(set! -prev-relto relto_1)" +"(set! -prev-relto-dir" +" base_28)" +" base_28))" +" #f))))" +" #f)))" +"(if or-part_58" +" or-part_58" +"(let-values(((or-part_45)" +"(current-load-relative-directory)))" +"(if or-part_45" +" or-part_45" +"(current-directory))))))))" +"((get-reg_0)" +"(lambda()" +"(begin" +" 'get-reg" +"(1/namespace-module-registry(1/current-namespace)))))" +"((show-collection-err_0)" +"(lambda(msg_1)" +"(begin" +" 'show-collection-err" +"(let-values(((msg_2)" +"(string-append" +"(let-values(((or-part_139)" +"(if stx_18" +"(if(error-print-source-location)" +"(format-source-location" +" stx_18)" +" #f)" +" #f)))" +"(if or-part_139" +" or-part_139" +" \"standard-module-name-resolver\"))" +" \": \"" +"(regexp-replace" +" '#rx\"\\n\"" +" msg_1" +"(format" +" \"\\n for module path: ~s\\n\"" +" s_26)))))" +"(raise" +"(if stx_18" +"(1/make-exn:fail:syntax:missing-module" +" msg_2" +"(current-continuation-marks)" +"(list stx_18)" +" s_26)" +"(1/make-exn:fail:filesystem:missing-module" +" msg_2" +"(current-continuation-marks)" +" s_26)))))))" +"((ss->rkt_0)" +"(lambda(s_474)" +"(begin" +" 'ss->rkt" +"(let-values(((len_43)(string-length s_474)))" +"(if(if(>= len_43 3)" +"(if(equal?" +" '#\\." +"(string-ref s_474(- len_43 3)))" +"(if(equal?" +" '#\\s" +"(string-ref s_474(- len_43 2)))" +"(equal?" +" '#\\s" +"(string-ref s_474(- len_43 1)))" +" #f)" +" #f)" +" #f)" +"(string-append" +"(substring s_474 0(- len_43 3))" +" \".rkt\")" +" s_474)))))" +"((path-ss->rkt_0)" +"(lambda(p_77)" +"(begin" +" 'path-ss->rkt" +"(let-values(((base_29 name_77 dir?_8)" +"(split-path p_77)))" +" (if (regexp-match '#rx\"[.]ss$\" (path->bytes name_77))" +" (path-replace-extension p_77 #\".rkt\")" +" p_77)))))" +"((s_31)" +"(if(if(pair? s_26)(eq? 'submod(car s_26)) #f)" +"(let-values(((v_245)(cadr s_26)))" +" (if (let-values (((or-part_359) (equal? v_245 \".\")))" +" (if or-part_359 or-part_359 (equal? v_245 \"..\")))" +"(if relto_1" +"(let-values(((p_78)" +"(1/resolved-module-path-name" +" relto_1)))" +"(if(pair? p_78)(car p_78) p_78))" +"(error" +" 'standard-module-name-resolver" +" \"no base path for relative submodule path: ~.s\"" +" s_26))" +" v_245))" +" s_26))" +"((subm-path_0)" +"(if(if(pair? s_26)(eq? 'submod(car s_26)) #f)" +"(let-values(((p_79)" +"(if(if(let-values(((or-part_46)" +"(equal?" +"(cadr s_26)" +" \".\")))" +"(if or-part_46" +" or-part_46" +" (equal? (cadr s_26) \"..\")))" +" relto_1" +" #f)" +"(let-values(((p_80)" +"(1/resolved-module-path-name" +" relto_1))" +"((r_15)" +"(if(equal?" +"(cadr s_26)" +" \"..\")" +"(cdr s_26)" +"(cddr s_26))))" +"(if(pair? p_80)" +"(flatten-sub-path_0" +"(car p_80)" +"(append(cdr p_80) r_15))" +"(flatten-sub-path_0 p_80 r_15)))" +"(flatten-sub-path_0" +" \".\"" +" (if (equal? (cadr s_26) \"..\")" +"(cdr s_26)" +"(cddr s_26))))))" +"(if(pair? p_79)(cdr p_79) #f))" +" #f)))" +"(let-values(((s-parsed_0)" +"(if(symbol? s_31)" +"(let-values()" +"(let-values(((or-part_49)" +"(path-cache-get" +"(cons s_31(get-reg_0)))))" +"(if or-part_49" +" or-part_49" +"(let-values(((cols_0 file_3)" +"(split-relative-string" +"(symbol->string s_31)" +" #f)))" +"(let-values(((f-file_0)" +"(if(null? cols_0)" +" \"main.rkt\"" +"(string-append" +" file_3" +" \".rkt\"))))" +"(find-col-file" +" show-collection-err_0" +"(if(null? cols_0) file_3(car cols_0))" +"(if(null? cols_0) null(cdr cols_0))" +" f-file_0" +" #t))))))" +"(if(string? s_31)" +"(let-values()" +"(let-values(((dir_4)(get-dir_0)))" +"(let-values(((or-part_365)" +"(path-cache-get" +"(cons s_31 dir_4))))" +"(if or-part_365" +" or-part_365" +"(let-values(((cols_1 file_4)" +"(split-relative-string" +" s_31" +" #f)))" +"(if(null? cols_1)" +"(build-path dir_4(ss->rkt_0 file_4))" +"(apply" +" build-path" +" dir_4" +"(append" +"(map2" +"(lambda(s_159)" +" (if (string=? s_159 \".\")" +"(let-values() 'same)" +" (if (string=? s_159 \"..\")" +"(let-values() 'up)" +"(let-values() s_159))))" +" cols_1)" +"(list(ss->rkt_0 file_4))))))))))" +"(if(path? s_31)" +"(let-values()" +"(path-ss->rkt_0" +"(simplify-path" +"(if(complete-path? s_31)" +" s_31" +"(path->complete-path s_31(get-dir_0))))))" +"(if(eq?(car s_31) 'lib)" +"(let-values()" +"(let-values(((or-part_88)" +"(path-cache-get" +"(cons s_31(get-reg_0)))))" +"(if or-part_88" +" or-part_88" +"(let-values(((cols_2 file_5)" +"(split-relative-string" +"(cadr s_31)" +" #f)))" +"(let-values(((old-style?_0)" +"(if(null?(cddr s_31))" +"(if(null? cols_2)" +"(regexp-match?" +" '#rx\"[.]\"" +" file_5)" +" #f)" +" #t)))" +"(let-values(((f-file_1)" +"(if old-style?_0" +"(ss->rkt_0 file_5)" +"(if(null? cols_2)" +" \"main.rkt\"" +"(if(regexp-match?" +" '#rx\"[.]\"" +" file_5)" +"(ss->rkt_0 file_5)" +"(string-append" +" file_5" +" \".rkt\"))))))" +"(let-values(((cols_3)" +"(if old-style?_0" +"(append" +"(if(null?" +"(cddr s_31))" +" '(\"mzlib\")" +"(apply" +" append" +"(map2" +"(lambda(p_81)" +"(split-relative-string" +" p_81" +" #t))" +"(cddr s_31))))" +" cols_2)" +"(if(null? cols_2)" +"(list file_5)" +" cols_2))))" +"(find-col-file" +" show-collection-err_0" +"(car cols_3)" +"(cdr cols_3)" +" f-file_1" +" #t))))))))" +"(if(eq?(car s_31) 'file)" +"(let-values()" +"(path-ss->rkt_0" +"(simplify-path" +"(path->complete-path" +"(expand-user-path(cadr s_31))" +"(get-dir_0)))))" +"(void))))))))" +"(begin" +"(if(let-values(((or-part_366)(path? s-parsed_0)))" +"(if or-part_366 or-part_366(vector? s-parsed_0)))" +"(void)" +"(let-values()" +"(if stx_18" +"(raise-syntax-error$1" +" 'require" +"(format" +" \"bad module path~a\"" +" (if s-parsed_0 (car s-parsed_0) \"\"))" +" stx_18)" +"(raise-argument-error" +" 'standard-module-name-resolver" +" \"module-path?\"" +" s_31))))" +"(let-values(((filename_2)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 0)" +"(simplify-path(cleanse-path s-parsed_0) #f))))" +"(let-values(((normal-filename_0)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 1)" +"(normal-case-path filename_2))))" +"(let-values(((base_30 name_78 dir?_9)" +"(if(vector? s-parsed_0)" +"(values" +" 'ignored" +"(vector-ref s-parsed_0 2)" +" 'ignored)" +"(split-path filename_2))))" +"(let-values(((no-sfx_0)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 3)" +" (path-replace-extension name_78 #\"\"))))" +"(let-values(((root-modname_0)" +"(if(vector? s-parsed_0)" +"(vector-ref s-parsed_0 4)" +"(1/make-resolved-module-path filename_2))))" +"(let-values(((hts_3)" +"(let-values(((or-part_367)" +"(registry-table-ref" +"(get-reg_0))))" +"(if or-part_367" +" or-part_367" +"(let-values(((hts_4)" +"(cons" +"(make-hasheq)" +"(make-hasheq))))" +"(begin" +"(registry-table-set!" +"(get-reg_0)" +" hts_4)" +" hts_4))))))" +"(let-values(((modname_0)" +"(if subm-path_0" +"(1/make-resolved-module-path" +"(cons" +"(1/resolved-module-path-name" +" root-modname_0)" +" subm-path_0))" +" root-modname_0)))" +"(begin" +"(if load?_7" +"(let-values()" +"(let-values(((got_0)" +"(hash-ref" +"(car hts_3)" +" modname_0" +" #f)))" +"(if got_0" +"(void)" +"(let-values()" +"(let-values(((loading_0)" +"(let-values(((tag_2)" +"(if(continuation-prompt-available?" +" -loading-prompt-tag)" " -loading-prompt-tag" "(default-continuation-prompt-tag))))" "(continuation-mark-set-first" " #f" " -loading-filename" " null" -" tag)))" -"(nsr(get-reg)))" -"(for-each" -"(lambda(s)" -"(when(and(equal?(cdr s) normal-filename)" -"(eq?(car s) nsr))" +" tag_2)))" +"((nsr_0)(get-reg_0)))" +"(begin" +"(for-each2" +"(lambda(s_405)" +"(if(if(equal?" +"(cdr s_405)" +" normal-filename_0)" +"(eq?(car s_405) nsr_0)" +" #f)" +"(let-values()" "(error" " 'standard-module-name-resolver" -" \"cycle in loading\\n at path: ~a\\n paths:~a\"" -" filename" -"(apply string-append" -"(let loop((l(reverse loading)))" -"(if(null? l)" +" \"cycle in loading\\n at path: ~a\\n paths:~a\"" +" filename_2" +"(apply" +" string-append" +"((letrec-values(((loop_122)" +"(lambda(l_82)" +"(begin" +" 'loop" +"(if(null?" +" l_82)" " '()" -" (list* \"\\n \" (path->string (cdar l)) (loop (cdr l)))))))))" -" loading)" -"((if(continuation-prompt-available? -loading-prompt-tag)" -"(lambda(f)(f))" -"(lambda(f)(call-with-continuation-prompt f -loading-prompt-tag)))" +"(list*" +" \"\\n \"" +"(path->string" +"(cdar" +" l_82))" +"(loop_122" +"(cdr" +" l_82))))))))" +" loop_122)" +"(reverse$1 loading_0)))))" +"(void)))" +" loading_0)" +"((if(continuation-prompt-available?" +" -loading-prompt-tag)" +"(lambda(f_40)(f_40))" +"(lambda(f_24)" +"(call-with-continuation-prompt" +" f_24" +" -loading-prompt-tag)))" "(lambda()" -"(with-continuation-mark -loading-filename(cons(cons nsr normal-filename)" -" loading)" -"(parameterize((current-module-declare-name root-modname)" -"(current-module-path-for-load" -"((if stx" -"(lambda(p)(datum->syntax #f p stx))" +"(with-continuation-mark" +" -loading-filename" +"(cons" +"(cons nsr_0 normal-filename_0)" +" loading_0)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" 1/current-module-declare-name" +" root-modname_0" +" 1/current-module-path-for-load" +"((if stx_18" +"(lambda(p_82)" +"(1/datum->syntax" +" #f" +" p_82" +" stx_18))" " values)" -"(cond" -"((symbol? s) s)" -"((and(pair? s)(eq?(car s) 'lib)) s)" -"(else(if(resolved-module-path? root-modname)" -"(let((src(resolved-module-path-name root-modname)))" -"(if(symbol? src)" -"(list 'quote src)" -" src))" -" root-modname))))))" -"((current-load/use-compiled) " -" filename " -"(let((sym(string->symbol(path->string no-sfx))))" -"(if subm-path" -"(if(hash-ref(car hts) root-modname #f)" -"(cons #f subm-path)" -"(cons sym subm-path))" -" sym)))))))))))" -"(when(and(not(vector? s-parsed))" -" load?" -"(or(string? s)" -"(symbol? s)" -"(and(pair? s)" -"(eq?(car s) 'lib))))" -"(path-cache-set!(if(string? s)" -"(cons s(get-dir))" -"(cons s(get-reg)))" -"(vector filename" -" normal-filename" -" name" -" no-sfx" -" root-modname)))" -" modname)))))))))))" -" standard-module-name-resolver))" -"(define-values(boot)" +"(if(symbol? s_31)" +"(let-values() s_31)" +"(if(if(pair? s_31)" +"(eq?(car s_31) 'lib)" +" #f)" +"(let-values() s_31)" +"(let-values()" +"(if(1/resolved-module-path?" +" root-modname_0)" +"(let-values(((src_8)" +"(1/resolved-module-path-name" +" root-modname_0)))" +"(if(symbol? src_8)" +"(list" +" 'quote" +" src_8)" +" src_8))" +" root-modname_0))))))" +"(let-values()" +"((1/current-load/use-compiled)" +" filename_2" +"(let-values(((sym_100)" +"(string->symbol" +"(path->string" +" no-sfx_0))))" +"(if subm-path_0" +"(if(hash-ref" +"(car hts_3)" +" root-modname_0" +" #f)" +"(cons #f subm-path_0)" +"(cons" +" sym_100" +" subm-path_0))" +" sym_100))))))))))))))" +"(void))" +"(if(if(not(vector? s-parsed_0))" +"(if load?_7" +"(let-values(((or-part_266)" +"(string? s_31)))" +"(if or-part_266" +" or-part_266" +"(let-values(((or-part_368)" +"(symbol? s_31)))" +"(if or-part_368" +" or-part_368" +"(if(pair? s_31)" +"(eq?(car s_31) 'lib)" +" #f)))))" +" #f)" +" #f)" +"(let-values()" +"(path-cache-set!" +"(if(string? s_31)" +"(cons s_31(get-dir_0))" +"(cons s_31(get-reg_0)))" +"(vector" +" filename_2" +" normal-filename_0" +" name_78" +" no-sfx_0" +" root-modname_0)))" +"(void))" +" modname_0)))))))))))))))))))))))))" +" standard-module-name-resolver_0)))))" +"(define-values" +"(default-eval-handler)" +"(lambda(s_61)" +"(begin" +"(1/eval" +" s_61" +"(1/current-namespace)" +"(let-values(((c_100)(1/current-compile)))" +"(lambda(e_83 ns_122)" +"(if(eq? ns_122(1/current-namespace))" +"(c_100 e_83 #t)" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization(continuation-mark-set-first #f parameterization-key) 1/current-namespace ns_122)" +"(let-values()(c_100 e_83 #t))))))))))" +"(define-values" +"(default-compile-handler)" +"(lambda(s_62 immediate-eval?_0)(begin(1/compile s_62(1/current-namespace)(not immediate-eval?_0)))))" +"(define-values" +"(default-read-interaction)" +"(lambda(src_9 in_0)" +"(begin" +"(begin" +"(if(input-port? in_0)" +"(void)" +" (let-values () (raise-argument-error 'default-read-interaction \"input-port?\" in_0)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/read-accept-reader" +" #t" +" 1/read-accept-lang" +" #f)" +"(let-values()(1/read-syntax src_9 in_0)))))))" +"(define-values" +"(boot)" "(lambda()" +"(begin" +"(begin" "(seal)" -"(current-module-name-resolver standard-module-name-resolver)" -"(current-load/use-compiled default-load/use-compiled)" -"(current-reader-guard default-reader-guard)))" -"(define-values(seal)" +"(1/current-module-name-resolver standard-module-name-resolver)" +"(1/current-load/use-compiled default-load/use-compiled)" +"(1/current-reader-guard default-reader-guard)" +"(1/current-eval default-eval-handler)" +"(1/current-compile default-compile-handler)" +"(1/current-load default-load-handler)" +"(current-read-interaction default-read-interaction)))))" +"(define-values" +"(seal)" +"(lambda()(begin(set! orig-paramz(reparameterize(continuation-mark-set-first #f parameterization-key))))))" +"(define-values(boot-primitives)(hash 'boot boot 'seal seal 'orig-paramz orig-paramz))" +"(define-values" +"(prepare-next-phase-namespace)" +"(lambda(ctx_71)" +"(begin" +"(let-values(((phase_40)(add1(expand-context-phase ctx_71))))" +"(let-values(((ns_58)(namespace->namespace-at-phase(expand-context-namespace ctx_71) phase_40)))" +"(namespace-visit-available-modules! ns_58 phase_40))))))" +"(define-values" +"(expand-body7.1)" +"(lambda(source1_0 stratified?2_0 stratified?4_0 bodys5_0 ctx6_0)" +"(begin" +" 'expand-body7" +"(let-values(((bodys_7) bodys5_0))" +"(let-values(((ctx_14) ctx6_0))" +"(let-values(((s_40) source1_0))" +"(let-values(((stratified?_0)(if stratified?4_0 stratified?2_0 #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_56)(expand-context-observer ctx_14)))" +"(if obs_56" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_56 'enter-block(datum->syntax$1 #f bodys_7))))" +"(void)))" +"(values))))" +"(let-values(((inside-sc_0)(new-scope 'intdef)))" +"(let-values(((init-bodys_0)" +"(reverse$1" +"(let-values(((lst_264) bodys_7))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_264)))" +"((letrec-values(((for-loop_269)" +"(lambda(fold-var_65 lst_168)" +"(begin" +" 'for-loop" +"(if(pair? lst_168)" +"(let-values(((body_11)(unsafe-car lst_168))" +"((rest_140)(unsafe-cdr lst_168)))" +"(let-values(((fold-var_11)" +"(let-values(((fold-var_12) fold-var_65))" +"(let-values(((fold-var_211)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" body_11" +" inside-sc_0))" +" fold-var_12))))" +"(values fold-var_211)))))" +"(if(not #f)" +"(for-loop_269 fold-var_11 rest_140)" +" fold-var_11)))" +" fold-var_65)))))" +" for-loop_269)" +" null" +" lst_264))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_57)(expand-context-observer ctx_14)))" +"(if obs_57" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_57" +" 'block-renames" +"(datum->syntax$1 #f init-bodys_0)" +"(datum->syntax$1 #f bodys_7))))" +"(void)))" +"(values))))" +"(let-values(((phase_138)(expand-context-phase ctx_14)))" +"(let-values(((frame-id_2)(make-reference-record)))" +"(let-values(((def-ctx-scopes_6)(box null)))" +"(let-values(((body-ctx_0)" +"(let-values(((v_246) ctx_14))" +"(let-values(((the-struct_90) v_246))" +"(if(expand-context/outer? the-struct_90)" +"(let-values(((context51_0)(list(make-liberal-define-context)))" +"((name52_1) #f)" +"((only-immediate?53_0) #t)" +"((def-ctx-scopes54_0) def-ctx-scopes_6)" +"((post-expansion-scope55_0) inside-sc_0)" +"((post-expansion-scope-action56_0) add-scope)" +"((scopes57_1)" +"(cons inside-sc_0(expand-context-scopes ctx_14)))" +"((use-site-scopes58_0)(box null))" +"((frame-id59_0) frame-id_2)" +"((reference-records60_0)" +"(cons" +" frame-id_2" +"(expand-context-reference-records ctx_14)))" +"((inner61_0)(root-expand-context/outer-inner v_246)))" +"(expand-context/outer1.1" +" inner61_0" +" post-expansion-scope55_0" +" use-site-scopes58_0" +" frame-id59_0" +" context51_0" +"(expand-context/outer-env the-struct_90)" +" post-expansion-scope-action56_0" +" scopes57_1" +" def-ctx-scopes54_0" +"(expand-context/outer-binding-layer the-struct_90)" +" reference-records60_0" +" only-immediate?53_0" +"(expand-context/outer-need-eventually-defined the-struct_90)" +"(expand-context/outer-current-introduction-scopes the-struct_90)" +" name52_1))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_90))))))" +"(let-values(((maybe-increment-binding-layer_0)" +"(lambda(ids_28 body-ctx_1)" +"(begin" +" 'maybe-increment-binding-layer" +"(if(eq?" +"(expand-context-binding-layer body-ctx_1)" +"(expand-context-binding-layer ctx_14))" +"(increment-binding-layer ids_28 body-ctx_1 inside-sc_0)" +"(expand-context-binding-layer body-ctx_1))))))" +"(let-values(((name_79)(expand-context-name ctx_14)))" +"((letrec-values(((loop_123)" +"(lambda(body-ctx_2" +" bodys_8" +" done-bodys_0" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0)" +"(begin" +" 'loop" +"(if(null? bodys_8)" +"(let-values()" +"(let-values(((temp65_6)(reverse$1 val-idss_0))" +"((temp66_4)(reverse$1 val-keyss_0))" +"((temp67_4)(reverse$1 val-rhss_0))" +"((temp68_2)(reverse$1 track-stxs_0))" +"((temp69_6)(reverse$1 stx-clauses_0))" +"((temp70_3)(reverse$1 done-bodys_0))" +"((s71_0) s_40)" +"((stratified?72_0) stratified?_0)" +"((name73_0) name_79)" +"((temp74_3)(reverse$1 trans-idss_1)))" +"(finish-expanding-body27.1" +" temp74_3" +" name73_0" +" s71_0" +" stratified?72_0" +" body-ctx_2" +" frame-id_2" +" def-ctx-scopes_6" +" temp65_6" +" temp66_4" +" temp67_4" +" temp68_2" +" temp69_6" +" temp70_3)))" +"(let-values()" +"(let-values(((rest-bodys_0)(cdr bodys_8)))" +"(let-values((()" +"(begin" +"(let-values(((obs_58)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_58" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_58" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-body_0)" +"(let-values(((temp75_3)(car bodys_8))" +"((temp76_3)" +"(if(if name_79" +"(null?" +"(cdr bodys_8))" +" #f)" +"(let-values(((v_85)" +" body-ctx_2))" +"(let-values(((the-struct_91)" +" v_85))" +"(if(expand-context/outer?" +" the-struct_91)" +"(let-values(((name77_0)" +" name_79)" +"((inner78_0)" +"(root-expand-context/outer-inner" +" v_85)))" +"(expand-context/outer1.1" +" inner78_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_91)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_91)" +"(root-expand-context/outer-frame-id" +" the-struct_91)" +"(expand-context/outer-context" +" the-struct_91)" +"(expand-context/outer-env" +" the-struct_91)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_91)" +"(expand-context/outer-scopes" +" the-struct_91)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_91)" +"(expand-context/outer-binding-layer" +" the-struct_91)" +"(expand-context/outer-reference-records" +" the-struct_91)" +"(expand-context/outer-only-immediate?" +" the-struct_91)" +"(expand-context/outer-need-eventually-defined" +" the-struct_91)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_91)" +" name77_0))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_91))))" +" body-ctx_2)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" temp75_3" +" temp76_3))))" +"(let-values(((disarmed-exp-body_0)" +"(syntax-disarm$1 exp-body_0)))" +"(let-values(((tmp_61)" +"(core-form-sym" +" disarmed-exp-body_0" +" phase_138)))" +"(if(equal? tmp_61 'begin)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_59)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_59" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_59" +" 'prim-begin)))" +"(void)))" +"(values))))" +"(let-values(((ok?_0 begin79_0 e80_0)" +"(let-values(((s_396)" +" disarmed-exp-body_0))" +"(let-values(((orig-s_39)" +" s_396))" +"(let-values(((begin79_1" +" e80_1)" +"(let-values(((s_475)" +"(if(syntax?$1" +" s_396)" +"(syntax-e$1" +" s_396)" +" s_396)))" +"(if(pair?" +" s_475)" +"(let-values(((begin81_0)" +"(let-values(((s_44)" +"(car" +" s_475)))" +" s_44))" +"((e82_0)" +"(let-values(((s_167)" +"(cdr" +" s_475)))" +"(let-values(((s_168)" +"(if(syntax?$1" +" s_167)" +"(syntax-e$1" +" s_167)" +" s_167)))" +"(let-values(((flat-s_24)" +"(to-syntax-list.1" +" s_168)))" +"(if(not" +" flat-s_24)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_39))" +"(let-values()" +" flat-s_24)))))))" +"(values" +" begin81_0" +" e82_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_39)))))" +"(values" +" #t" +" begin79_1" +" e80_1))))))" +"(let-values(((track_0)" +"(lambda(e_84)" +"(begin" +" 'track" +"(syntax-track-origin$1" +" e_84" +" exp-body_0)))))" +"(let-values(((splice-bodys_0)" +"(append" +"(map2 track_0 e80_0)" +" rest-bodys_0)))" +"(begin" +"(let-values(((obs_60)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_60" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_60" +" 'splice" +" splice-bodys_0)))" +"(void)))" +"(loop_123" +" body-ctx_2" +" splice-bodys_0" +" done-bodys_0" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0)))))))" +"(if(equal? tmp_61 'define-values)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_61)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_61" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_61" +" 'prim-define-values)))" +"(void)))" +"(values))))" +"(let-values(((ok?_33" +" define-values83_0" +" id84_0" +" rhs85_0)" +"(let-values(((s_85)" +" disarmed-exp-body_0))" +"(let-values(((orig-s_40)" +" s_85))" +"(let-values(((define-values83_1" +" id84_1" +" rhs85_1)" +"(let-values(((s_46)" +"(if(syntax?$1" +" s_85)" +"(syntax-e$1" +" s_85)" +" s_85)))" +"(if(pair?" +" s_46)" +"(let-values(((define-values86_0)" +"(let-values(((s_393)" +"(car" +" s_46)))" +" s_393))" +"((id87_0" +" rhs88_0)" +"(let-values(((s_47)" +"(cdr" +" s_46)))" +"(let-values(((s_69)" +"(if(syntax?$1" +" s_47)" +"(syntax-e$1" +" s_47)" +" s_47)))" +"(if(pair?" +" s_69)" +"(let-values(((id89_0)" +"(let-values(((s_50)" +"(car" +" s_69)))" +"(let-values(((s_311)" +"(if(syntax?$1" +" s_50)" +"(syntax-e$1" +" s_50)" +" s_50)))" +"(let-values(((flat-s_25)" +"(to-syntax-list.1" +" s_311)))" +"(if(not" +" flat-s_25)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40))" +"(let-values()" +"(let-values(((id_16)" +"(let-values(((lst_311)" +" flat-s_25))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_311)))" +"((letrec-values(((for-loop_270)" +"(lambda(id_100" +" lst_312)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_312)" +"(let-values(((s_315)" +"(unsafe-car" +" lst_312))" +"((rest_177)" +"(unsafe-cdr" +" lst_312)))" +"(let-values(((id_101)" +"(let-values(((id_80)" +" id_100))" +"(let-values(((id_81)" +"(let-values()" +"(let-values(((id92_0)" +"(let-values()" +"(if(let-values(((or-part_47)" +"(if(syntax?$1" +" s_315)" +"(symbol?" +"(syntax-e$1" +" s_315))" +" #f)))" +"(if or-part_47" +" or-part_47" +"(symbol?" +" s_315)))" +" s_315" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_40" +" s_315)))))" +"(cons" +" id92_0" +" id_80)))))" +"(values" +" id_81)))))" +"(if(not" +" #f)" +"(for-loop_270" +" id_101" +" rest_177)" +" id_101)))" +" id_100)))))" +" for-loop_270)" +" null" +" lst_311)))))" +"(reverse$1" +" id_16))))))))" +"((rhs90_0)" +"(let-values(((s_476)" +"(cdr" +" s_69)))" +"(let-values(((s_477)" +"(if(syntax?$1" +" s_476)" +"(syntax-e$1" +" s_476)" +" s_476)))" +"(if(pair?" +" s_477)" +"(let-values(((rhs91_0)" +"(let-values(((s_54)" +"(car" +" s_477)))" +" s_54))" +"(()" +"(let-values(((s_413)" +"(cdr" +" s_477)))" +"(let-values(((s_317)" +"(if(syntax?$1" +" s_413)" +"(syntax-e$1" +" s_413)" +" s_413)))" +"(if(null?" +" s_317)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40))))))" +"(values" +" rhs91_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40))))))" +"(values" +" id89_0" +" rhs90_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40))))))" +"(values" +" define-values86_0" +" id87_0" +" rhs88_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40)))))" +"(values" +" #t" +" define-values83_1" +" id84_1" +" rhs85_1))))))" +"(let-values(((ids_4)" +"(remove-use-site-scopes" +" id84_0" +" body-ctx_2)))" +"(let-values((()" +"(begin" +"(let-values(((obs_62)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_62" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_62" +" 'rename-one" +"(datum->syntax$1" +" #f" +"(list" +" ids_4" +" rhs85_0)))))" +"(void)))" +"(values))))" +"(let-values(((new-dups_0)" +"(let-values(((ids93_0)" +" ids_4)" +"((phase94_0)" +" phase_138)" +"((exp-body95_0)" +" exp-body_0)" +"((dups96_0)" +" dups_0))" +"(check-no-duplicate-ids8.1" +" #f" +" #f" +" ids93_0" +" phase94_0" +" exp-body95_0" +" dups96_0" +" #t))))" +"(let-values(((counter_5)" +"(root-expand-context-counter" +" ctx_14)))" +"(let-values(((keys_5)" +"(reverse$1" +"(let-values(((lst_191)" +" ids_4))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_191)))" +"((letrec-values(((for-loop_12)" +"(lambda(fold-var_276" +" lst_313)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_313)" +"(let-values(((id_102)" +"(unsafe-car" +" lst_313))" +"((rest_178)" +"(unsafe-cdr" +" lst_313)))" +"(let-values(((fold-var_242)" +"(let-values(((fold-var_243)" +" fold-var_276))" +"(let-values(((fold-var_229)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((frame-id100_0)" +" frame-id_2)" +"((exp-body101_0)" +" exp-body_0))" +"(add-local-binding!35.1" +" frame-id100_0" +" #t" +" exp-body101_0" +" #t" +" id_102" +" phase_138" +" counter_5)))" +" fold-var_243))))" +"(values" +" fold-var_229)))))" +"(if(not" +" #f)" +"(for-loop_12" +" fold-var_242" +" rest_178)" +" fold-var_242)))" +" fold-var_276)))))" +" for-loop_12)" +" null" +" lst_191))))))" +"(let-values(((extended-env_0)" +"(let-values(((lst_314)" +" keys_5)" +"((lst_221)" +" ids_4))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_314)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_221)))" +"((letrec-values(((for-loop_229)" +"(lambda(env_17" +" lst_192" +" lst_223)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_192)" +"(pair?" +" lst_223)" +" #f)" +"(let-values(((key_90)" +"(unsafe-car" +" lst_192))" +"((rest_179)" +"(unsafe-cdr" +" lst_192))" +"((id_103)" +"(unsafe-car" +" lst_223))" +"((rest_102)" +"(unsafe-cdr" +" lst_223)))" +"(let-values(((env_18)" +"(let-values(((env_19)" +" env_17))" +"(let-values(((env_20)" +"(let-values()" +"(env-extend" +" env_19" +" key_90" +"(local-variable1.1" +" id_103)))))" +"(values" +" env_20)))))" +"(if(not" +" #f)" +"(for-loop_229" +" env_18" +" rest_179" +" rest_102)" +" env_18)))" +" env_17)))))" +" for-loop_229)" +"(expand-context-env" +" body-ctx_2)" +" lst_314" +" lst_221)))))" +"(loop_123" +"(let-values(((v_247)" +" body-ctx_2))" +"(let-values(((the-struct_52)" +" v_247))" +"(if(expand-context/outer?" +" the-struct_52)" +"(let-values(((env102_0)" +" extended-env_0)" +"((binding-layer103_0)" +"(maybe-increment-binding-layer_0" +" ids_4" +" body-ctx_2))" +"((inner104_0)" +"(root-expand-context/outer-inner" +" v_247)))" +"(expand-context/outer1.1" +" inner104_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_52)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_52)" +"(root-expand-context/outer-frame-id" +" the-struct_52)" +"(expand-context/outer-context" +" the-struct_52)" +" env102_0" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_52)" +"(expand-context/outer-scopes" +" the-struct_52)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_52)" +" binding-layer103_0" +"(expand-context/outer-reference-records" +" the-struct_52)" +"(expand-context/outer-only-immediate?" +" the-struct_52)" +"(expand-context/outer-need-eventually-defined" +" the-struct_52)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_52)" +"(expand-context/outer-name" +" the-struct_52)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_52))))" +" rest-bodys_0" +" null" +"(cons" +" ids_4" +"(append" +"(reverse$1" +"(let-values(((lst_195)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_195)))" +"((letrec-values(((for-loop_41)" +"(lambda(fold-var_187" +" lst_196)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_196)" +"(let-values(((done-body_0)" +"(unsafe-car" +" lst_196))" +"((rest_180)" +"(unsafe-cdr" +" lst_196)))" +"(let-values(((fold-var_277)" +"(let-values(((fold-var_278)" +" fold-var_187))" +"(let-values(((fold-var_279)" +"(let-values()" +"(cons" +"(let-values()" +" null)" +" fold-var_278))))" +"(values" +" fold-var_279)))))" +"(if(not" +" #f)" +"(for-loop_41" +" fold-var_277" +" rest_180)" +" fold-var_277)))" +" fold-var_187)))))" +" for-loop_41)" +" null" +" lst_195))))" +" val-idss_0))" +"(cons" +" keys_5" +"(append" +"(reverse$1" +"(let-values(((lst_315)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_315)))" +"((letrec-values(((for-loop_271)" +"(lambda(fold-var_190" +" lst_316)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_316)" +"(let-values(((done-body_1)" +"(unsafe-car" +" lst_316))" +"((rest_181)" +"(unsafe-cdr" +" lst_316)))" +"(let-values(((fold-var_280)" +"(let-values(((fold-var_281)" +" fold-var_190))" +"(let-values(((fold-var_282)" +"(let-values()" +"(cons" +"(let-values()" +" null)" +" fold-var_281))))" +"(values" +" fold-var_282)))))" +"(if(not" +" #f)" +"(for-loop_271" +" fold-var_280" +" rest_181)" +" fold-var_280)))" +" fold-var_190)))))" +" for-loop_271)" +" null" +" lst_315))))" +" val-keyss_0))" +"(cons" +" rhs85_0" +"(append" +"(reverse$1" +"(let-values(((lst_148)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_148)))" +"((letrec-values(((for-loop_115)" +"(lambda(fold-var_283" +" lst_317)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_317)" +"(let-values(((done-body_2)" +"(unsafe-car" +" lst_317))" +"((rest_182)" +"(unsafe-cdr" +" lst_317)))" +"(let-values(((fold-var_41)" +"(let-values(((fold-var_284)" +" fold-var_283))" +"(let-values(((fold-var_22)" +"(let-values()" +"(cons" +"(let-values()" +"(no-binds" +" done-body_2" +" s_40" +" phase_138))" +" fold-var_284))))" +"(values" +" fold-var_22)))))" +"(if(not" +" #f)" +"(for-loop_115" +" fold-var_41" +" rest_182)" +" fold-var_41)))" +" fold-var_283)))))" +" for-loop_115)" +" null" +" lst_148))))" +" val-rhss_0))" +"(cons" +" exp-body_0" +"(append" +"(reverse$1" +"(let-values(((lst_102)" +" done-bodys_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_102)))" +"((letrec-values(((for-loop_117)" +"(lambda(fold-var_25" +" lst_149)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_149)" +"(let-values(((done-body_3)" +"(unsafe-car" +" lst_149))" +"((rest_75)" +"(unsafe-cdr" +" lst_149)))" +"(let-values(((fold-var_131)" +"(let-values(((fold-var_132)" +" fold-var_25))" +"(let-values(((fold-var_133)" +"(let-values()" +"(cons" +"(let-values()" +" #f)" +" fold-var_132))))" +"(values" +" fold-var_133)))))" +"(if(not" +" #f)" +"(for-loop_117" +" fold-var_131" +" rest_75)" +" fold-var_131)))" +" fold-var_25)))))" +" for-loop_117)" +" null" +" lst_102))))" +" track-stxs_0))" +" trans-idss_1" +" stx-clauses_0" +" new-dups_0))))))))))" +"(if(equal? tmp_61 'define-syntaxes)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_63)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_63" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_63" +" 'prim-define-syntaxes)))" +"(void)))" +"(values))))" +"(let-values(((ok?_4" +" define-syntaxes105_0" +" id106_0" +" rhs107_0)" +"(let-values(((s_93)" +" disarmed-exp-body_0))" +"(let-values(((orig-s_41)" +" s_93))" +"(let-values(((define-syntaxes105_1" +" id106_1" +" rhs107_1)" +"(let-values(((s_95)" +"(if(syntax?$1" +" s_93)" +"(syntax-e$1" +" s_93)" +" s_93)))" +"(if(pair?" +" s_95)" +"(let-values(((define-syntaxes108_0)" +"(let-values(((s_478)" +"(car" +" s_95)))" +" s_478))" +"((id109_0" +" rhs110_0)" +"(let-values(((s_438)" +"(cdr" +" s_95)))" +"(let-values(((s_479)" +"(if(syntax?$1" +" s_438)" +"(syntax-e$1" +" s_438)" +" s_438)))" +"(if(pair?" +" s_479)" +"(let-values(((id111_0)" +"(let-values(((s_480)" +"(car" +" s_479)))" +"(let-values(((s_209)" +"(if(syntax?$1" +" s_480)" +"(syntax-e$1" +" s_480)" +" s_480)))" +"(let-values(((flat-s_26)" +"(to-syntax-list.1" +" s_209)))" +"(if(not" +" flat-s_26)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_41))" +"(let-values()" +"(let-values(((id_104)" +"(let-values(((lst_40)" +" flat-s_26))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_40)))" +"((letrec-values(((for-loop_54)" +"(lambda(id_105" +" lst_41)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_41)" +"(let-values(((s_67)" +"(unsafe-car" +" lst_41))" +"((rest_17)" +"(unsafe-cdr" +" lst_41)))" +"(let-values(((id_106)" +"(let-values(((id_107)" +" id_105))" +"(let-values(((id_108)" +"(let-values()" +"(let-values(((id114_0)" +"(let-values()" +"(if(let-values(((or-part_351)" +"(if(syntax?$1" +" s_67)" +"(symbol?" +"(syntax-e$1" +" s_67))" +" #f)))" +"(if or-part_351" +" or-part_351" +"(symbol?" +" s_67)))" +" s_67" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_41" +" s_67)))))" +"(cons" +" id114_0" +" id_107)))))" +"(values" +" id_108)))))" +"(if(not" +" #f)" +"(for-loop_54" +" id_106" +" rest_17)" +" id_106)))" +" id_105)))))" +" for-loop_54)" +" null" +" lst_40)))))" +"(reverse$1" +" id_104))))))))" +"((rhs112_0)" +"(let-values(((s_102)" +"(cdr" +" s_479)))" +"(let-values(((s_154)" +"(if(syntax?$1" +" s_102)" +"(syntax-e$1" +" s_102)" +" s_102)))" +"(if(pair?" +" s_154)" +"(let-values(((rhs113_0)" +"(let-values(((s_481)" +"(car" +" s_154)))" +" s_481))" +"(()" +"(let-values(((s_482)" +"(cdr" +" s_154)))" +"(let-values(((s_483)" +"(if(syntax?$1" +" s_482)" +"(syntax-e$1" +" s_482)" +" s_482)))" +"(if(null?" +" s_483)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_41))))))" +"(values" +" rhs113_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_41))))))" +"(values" +" id111_0" +" rhs112_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_41))))))" +"(values" +" define-syntaxes108_0" +" id109_0" +" rhs110_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_41)))))" +"(values" +" #t" +" define-syntaxes105_1" +" id106_1" +" rhs107_1))))))" +"(let-values(((ids_29)" +"(remove-use-site-scopes" +" id106_0" +" body-ctx_2)))" +"(let-values((()" +"(begin" +"(let-values(((obs_64)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_64" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_64" +" 'rename-one" +"(datum->syntax$1" +" #f" +"(list" +" ids_29" +" rhs107_0)))))" +"(void)))" +"(values))))" +"(let-values(((new-dups_1)" +"(let-values(((ids115_0)" +" ids_29)" +"((phase116_0)" +" phase_138)" +"((exp-body117_0)" +" exp-body_0)" +"((dups118_0)" +" dups_0))" +"(check-no-duplicate-ids8.1" +" #f" +" #f" +" ids115_0" +" phase116_0" +" exp-body117_0" +" dups118_0" +" #t))))" +"(let-values(((counter_6)" +"(root-expand-context-counter" +" ctx_14)))" +"(let-values(((keys_6)" +"(reverse$1" +"(let-values(((lst_318)" +" ids_29))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_318)))" +"((letrec-values(((for-loop_272)" +"(lambda(fold-var_285" +" lst_319)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_319)" +"(let-values(((id_109)" +"(unsafe-car" +" lst_319))" +"((rest_183)" +"(unsafe-cdr" +" lst_319)))" +"(let-values(((fold-var_286)" +"(let-values(((fold-var_287)" +" fold-var_285))" +"(let-values(((fold-var_288)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((frame-id122_0)" +" frame-id_2)" +"((exp-body123_0)" +" exp-body_0))" +"(add-local-binding!35.1" +" frame-id122_0" +" #t" +" exp-body123_0" +" #t" +" id_109" +" phase_138" +" counter_6)))" +" fold-var_287))))" +"(values" +" fold-var_288)))))" +"(if(not" +" #f)" +"(for-loop_272" +" fold-var_286" +" rest_183)" +" fold-var_286)))" +" fold-var_285)))))" +" for-loop_272)" +" null" +" lst_318))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_65)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_65" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_65" +" 'prepare-env)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(prepare-next-phase-namespace" +" ctx_14)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_66)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_66" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_66" +" 'enter-bind)))" +"(void)))" +"(values))))" +"(let-values(((vals_8)" +"(eval-for-syntaxes-binding" +" rhs107_0" +" ids_29" +" body-ctx_2)))" +"(let-values(((extended-env_1)" +"(let-values(((lst_320)" +" keys_6)" +"((lst_321)" +" vals_8)" +"((lst_322)" +" ids_29))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_320)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_321)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_322)))" +"((letrec-values(((for-loop_273)" +"(lambda(env_21" +" lst_323" +" lst_324" +" lst_325)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_323)" +"(if(pair?" +" lst_324)" +"(pair?" +" lst_325)" +" #f)" +" #f)" +"(let-values(((key_91)" +"(unsafe-car" +" lst_323))" +"((rest_184)" +"(unsafe-cdr" +" lst_323))" +"((val_83)" +"(unsafe-car" +" lst_324))" +"((rest_185)" +"(unsafe-cdr" +" lst_324))" +"((id_110)" +"(unsafe-car" +" lst_325))" +"((rest_186)" +"(unsafe-cdr" +" lst_325)))" +"(let-values(((env_22)" +"(let-values(((env_23)" +" env_21))" +"(let-values(((env_24)" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_83" +" id_110" +" phase_138" +" body-ctx_2)" +"(env-extend" +" env_23" +" key_91" +" val_83)))))" +"(values" +" env_24)))))" +"(if(not" +" #f)" +"(for-loop_273" +" env_22" +" rest_184" +" rest_185" +" rest_186)" +" env_22)))" +" env_21)))))" +" for-loop_273)" +"(expand-context-env" +" body-ctx_2)" +" lst_320" +" lst_321" +" lst_322)))))" +"(begin" +"(let-values(((obs_67)" +"(expand-context-observer" +" body-ctx_2)))" +"(if obs_67" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_67" +" 'exit-bind)))" +"(void)))" +"(loop_123" +"(let-values(((v_248)" +" body-ctx_2))" +"(let-values(((the-struct_92)" +" v_248))" +"(if(expand-context/outer?" +" the-struct_92)" +"(let-values(((env124_0)" +" extended-env_1)" +"((binding-layer125_0)" +"(maybe-increment-binding-layer_0" +" ids_29" +" body-ctx_2))" +"((inner126_0)" +"(root-expand-context/outer-inner" +" v_248)))" +"(expand-context/outer1.1" +" inner126_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_92)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_92)" +"(root-expand-context/outer-frame-id" +" the-struct_92)" +"(expand-context/outer-context" +" the-struct_92)" +" env124_0" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_92)" +"(expand-context/outer-scopes" +" the-struct_92)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_92)" +" binding-layer125_0" +"(expand-context/outer-reference-records" +" the-struct_92)" +"(expand-context/outer-only-immediate?" +" the-struct_92)" +"(expand-context/outer-need-eventually-defined" +" the-struct_92)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_92)" +"(expand-context/outer-name" +" the-struct_92)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_92))))" +" rest-bodys_0" +" done-bodys_0" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +"(cons" +" ids_29" +" trans-idss_1)" +"(cons" +"(datum->syntax$1" +" #f" +"(list" +" ids_29" +" rhs107_0)" +" rhs107_0)" +" stx-clauses_0)" +" new-dups_1)))))))))))))))" +"(let-values()" +"(if stratified?_0" +"(let-values()" +"(begin" +"(if(null? done-bodys_0)" +"(void)" +"(let-values()" +"(error" +" \"internal error: accumulated expressions not empty\")))" +"(loop_123" +" body-ctx_2" +" null" +"(if(if(null? val-idss_0)" +"(null? trans-idss_1)" +" #f)" +"(reverse$1" +"(cons" +" exp-body_0" +" rest-bodys_0))" +"(list" +"(datum->syntax$1" +" #f" +"(cons" +"(core-id" +" '#%stratified-body" +" phase_138)" +"(cons" +" exp-body_0" +" rest-bodys_0)))))" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0)))" +"(let-values()" +"(loop_123" +" body-ctx_2" +" rest-bodys_0" +"(cons exp-body_0 done-bodys_0)" +" val-idss_0" +" val-keyss_0" +" val-rhss_0" +" track-stxs_0" +" trans-idss_1" +" stx-clauses_0" +" dups_0))))))))))))))))))" +" loop_123)" +" body-ctx_0" +" init-bodys_0" +" null" +" null" +" null" +" null" +" null" +" null" +" null" +"(make-check-no-duplicate-table))))))))))))))))))))" +"(define-values" +"(finish-expanding-body27.1)" +"(lambda(disappeared-transformer-bindings13_0" +" name12_0" +" source10_0" +" stratified?11_0" +" body-ctx18_0" +" frame-id19_0" +" def-ctx-scopes20_0" +" val-idss21_0" +" val-keyss22_0" +" val-rhss23_0" +" track-stxs24_0" +" stx-clauses25_0" +" done-bodys26_0)" +"(begin" +" 'finish-expanding-body27" +"(let-values(((body-ctx_3) body-ctx18_0))" +"(let-values(((frame-id_13) frame-id19_0))" +"(let-values(((def-ctx-scopes_7) def-ctx-scopes20_0))" +"(let-values(((val-idss_1) val-idss21_0))" +"(let-values(((val-keyss_1) val-keyss22_0))" +"(let-values(((val-rhss_1) val-rhss23_0))" +"(let-values(((track-stxs_1) track-stxs24_0))" +"(let-values(((stx-clauses_1) stx-clauses25_0))" +"(let-values(((done-bodys_1) done-bodys26_0))" +"(let-values(((s_484) source10_0))" +"(let-values(((stratified?_1) stratified?11_0))" +"(let-values(((name_80) name12_0))" +"(let-values(((disappeared-transformer-bindings_0) disappeared-transformer-bindings13_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(null? done-bodys_1)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"no expression after a sequence of internal definitions\"" +" s_484))" +"(void))" +"(values))))" +"(let-values(((finish-ctx_0)" +"(let-values(((v_249)" +"(accumulate-def-ctx-scopes" +" body-ctx_3" +" def-ctx-scopes_7)))" +"(let-values(((the-struct_93) v_249))" +"(if(expand-context/outer? the-struct_93)" +"(let-values(((context127_0) 'expression)" +"((use-site-scopes128_0)(box null))" +"((scopes129_0)" +"(append" +"(unbox" +"(root-expand-context-use-site-scopes" +" body-ctx_3))" +"(expand-context-scopes body-ctx_3)))" +"((only-immediate?130_0) #f)" +"((def-ctx-scopes131_0) #f)" +"((post-expansion-scope132_0) #f)" +"((inner133_0)" +"(root-expand-context/outer-inner v_249)))" +"(expand-context/outer1.1" +" inner133_0" +" post-expansion-scope132_0" +" use-site-scopes128_0" +"(root-expand-context/outer-frame-id the-struct_93)" +" context127_0" +"(expand-context/outer-env the-struct_93)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_93)" +" scopes129_0" +" def-ctx-scopes131_0" +"(expand-context/outer-binding-layer the-struct_93)" +"(expand-context/outer-reference-records the-struct_93)" +" only-immediate?130_0" +"(expand-context/outer-need-eventually-defined the-struct_93)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_93)" +"(expand-context/outer-name the-struct_93)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_93))))))" +"(let-values(((finish-bodys_0)" "(lambda()" -"(set! orig-paramz" -"(reparameterize " -"(continuation-mark-set-first #f parameterization-key))))))" -); - EVAL_ONE_STR( -"(module #%builtin '#%kernel" -"(#%require '#%expobs" -"(only '#%foreign) " -"(only '#%unsafe) " -"(only '#%flfxnum) " -" '#%boot" -" '#%place-struct" -" '#%paramz" -" '#%network" -" '#%utils" -"(only '#%place)" -"(only '#%futures)" -"(only '#%linklet)))" -); +"(begin" +" 'finish-bodys" +"(let-values(((block->list?_0)(null? val-idss_1)))" +"(let-values((()" +"(begin" +"(if block->list?_0" +"(void)" +"(let-values()" +"(let-values(((obs_68)" +"(expand-context-observer" +" body-ctx_3)))" +"(if obs_68" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_68" +" 'next-group)))" +"(void)))))" +"(values))))" +"(let-values(((last-i_1)(sub1(length done-bodys_1))))" +"(let-values((()" +"(begin" +"(let-values(((obs_69)" +"(expand-context-observer" +" body-ctx_3)))" +"(if obs_69" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_69" +" 'enter-list" +"(datum->syntax$1" +" #f" +" done-bodys_1))))" +"(void)))" +"(values))))" +"(let-values(((exp-bodys_0)" +"(reverse$1" +"(let-values(((lst_326) done-bodys_1)" +"((start_64) 0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_326)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-naturals start_64)))" +"((letrec-values(((for-loop_132)" +"(lambda(fold-var_289" +" lst_327" +" pos_122)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_327)" +" #t" +" #f)" +"(let-values(((done-body_4)" +"(unsafe-car" +" lst_327))" +"((rest_187)" +"(unsafe-cdr" +" lst_327))" +"((i_167)" +" pos_122))" +"(let-values(((fold-var_290)" +"(let-values(((fold-var_203)" +" fold-var_289))" +"(let-values(((fold-var_255)" +"(let-values()" +"(cons" +"(let-values()" +"(begin" +"(let-values(((obs_70)" +"(expand-context-observer" +" body-ctx_3)))" +"(if obs_70" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_70" +" 'next)))" +"(void)))" +"(let-values(((done-body134_0)" +" done-body_4)" +"((temp135_2)" +"(if(if name_80" +"(=" +" i_167" +" last-i_1)" +" #f)" +"(let-values(((v_250)" +" finish-ctx_0))" +"(let-values(((the-struct_94)" +" v_250))" +"(if(expand-context/outer?" +" the-struct_94)" +"(let-values(((name136_0)" +" name_80)" +"((inner137_1)" +"(root-expand-context/outer-inner" +" v_250)))" +"(expand-context/outer1.1" +" inner137_1" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_94)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_94)" +"(root-expand-context/outer-frame-id" +" the-struct_94)" +"(expand-context/outer-context" +" the-struct_94)" +"(expand-context/outer-env" +" the-struct_94)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_94)" +"(expand-context/outer-scopes" +" the-struct_94)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_94)" +"(expand-context/outer-binding-layer" +" the-struct_94)" +"(expand-context/outer-reference-records" +" the-struct_94)" +"(expand-context/outer-only-immediate?" +" the-struct_94)" +"(expand-context/outer-need-eventually-defined" +" the-struct_94)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_94)" +" name136_0))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_94))))" +" finish-ctx_0)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" done-body134_0" +" temp135_2))))" +" fold-var_203))))" +"(values" +" fold-var_255)))))" +"(if(not" +" #f)" +"(for-loop_132" +" fold-var_290" +" rest_187" +"(+" +" pos_122" +" 1))" +" fold-var_290)))" +" fold-var_289)))))" +" for-loop_132)" +" null" +" lst_326" +" start_64))))))" +"(begin" +"(let-values(((obs_71)" +"(expand-context-observer body-ctx_3)))" +"(if obs_71" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_71" +" 'exit-list" +"(datum->syntax$1 #f exp-bodys_0))))" +"(void)))" +"(reference-record-clear! frame-id_13)" +" exp-bodys_0))))))))))" +"(if(if(null? val-idss_1)(null? disappeared-transformer-bindings_0) #f)" +"(let-values()" +"(begin" +"(let-values(((obs_72)(expand-context-observer finish-ctx_0)))" +"(if obs_72" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_72" +" 'block->list" +"(datum->syntax$1 s_484 done-bodys_1))))" +"(void)))" +"(finish-bodys_0)))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_73)" +"(expand-context-observer finish-ctx_0)))" +"(if obs_73" +"(let-values()" +"(log-letrec-values$1" +" obs_73" +" finish-ctx_0" +" s_484" +" val-idss_1" +" val-rhss_1" +" track-stxs_1" +" stx-clauses_1" +" done-bodys_1))" +"(void)))" +"(values))))" +"(let-values(((exp-s_13)" +"(let-values(((temp142_1)(not stratified?_1))" +"((frame-id143_0) frame-id_13)" +"((finish-ctx144_0) finish-ctx_0)" +"((s145_0) s_484)" +"((temp146_1)(pair? stx-clauses_1))" +"((finish-bodys147_0) finish-bodys_0)" +"((temp148_1) #f))" +"(expand-and-split-bindings-by-reference48.1" +" finish-ctx144_0" +" frame-id143_0" +" finish-bodys147_0" +" temp146_1" +" s145_0" +" temp142_1" +" temp148_1" +" val-idss_1" +" val-keyss_1" +" val-rhss_1" +" track-stxs_1))))" +"(begin" +"(let-values(((obs_74)(expand-context-observer body-ctx_3)))" +"(if obs_74" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_74 'exit-prim exp-s_13)" +"(call-expand-observe obs_74 'return exp-s_13))))" +"(void)))" +"(if(expand-context-to-parsed? body-ctx_3)" +"(list exp-s_13)" +"(list" +"(attach-disappeared-transformer-bindings" +" exp-s_13" +" disappeared-transformer-bindings_0))))))))))))))))))))))))))))" +"(define-values" +"(expand-and-split-bindings-by-reference48.1)" +"(lambda(ctx32_0" +" frame-id31_0" +" get-body35_0" +" had-stxes?34_0" +" source33_0" +" split?30_0" +" track?36_0" +" idss44_0" +" keyss45_0" +" rhss46_0" +" track-stxs47_0)" +"(begin" +" 'expand-and-split-bindings-by-reference48" +"(let-values(((idss_1) idss44_0))" +"(let-values(((keyss_0) keyss45_0))" +"(let-values(((rhss_1) rhss46_0))" +"(let-values(((track-stxs_2) track-stxs47_0))" +"(let-values(((split?_0) split?30_0))" +"(let-values(((frame-id_14) frame-id31_0))" +"(let-values(((ctx_72) ctx32_0))" +"(let-values(((s_370) source33_0))" +"(let-values(((had-stxes?_0) had-stxes?34_0))" +"(let-values(((get-body_0) get-body35_0))" +"(let-values(((track?_1) track?36_0))" +"(let-values()" +"(let-values(((phase_139)(expand-context-phase ctx_72)))" +"((letrec-values(((loop_124)" +"(lambda(idss_2" +" keyss_1" +" rhss_2" +" track-stxs_3" +" accum-idss_0" +" accum-keyss_0" +" accum-rhss_0" +" accum-track-stxs_0" +" track?_2" +" get-list?_0" +" can-log?_0)" +"(begin" +" 'loop" +"(if(null? idss_2)" +"(let-values()" +"(if(if(null? accum-idss_0) get-list?_0 #f)" +"(let-values()(get-body_0))" +"(let-values()" +"(let-values(((exp-body_1)(get-body_0)))" +"(let-values(((result-s_9)" +"(if(expand-context-to-parsed? ctx_72)" +"(if(null? accum-idss_0)" +"(parsed-let-values17.1" +"(keep-properties-only s_370)" +" null" +" null" +" exp-body_1)" +"(parsed-letrec-values18.1" +"(keep-properties-only s_370)" +"(reverse$1 accum-idss_0)" +"(reverse$1" +"(map2" +" list" +" accum-keyss_0" +" accum-rhss_0))" +" exp-body_1))" +"(let-values(((track?149_0) track?_2)" +"((s150_0) s_370)" +"((temp151_2)" +"(list*" +"(if(null? accum-idss_0)" +"(core-id" +" 'let-values" +" phase_139)" +"(core-id" +" 'letrec-values" +" phase_139))" +"(build-clauses" +" accum-idss_0" +" accum-rhss_0" +" accum-track-stxs_0)" +" exp-body_1)))" +"(rebuild5.1" +" track?149_0" +" #t" +" s150_0" +" temp151_2)))))" +"(begin" +"(let-values(((obs_75)" +"(expand-context-observer ctx_72)))" +"(if obs_75" +"(let-values()" +"(if(if can-log?_0" +"(log-tag? had-stxes?_0 ctx_72)" +" #f)" +"(let-values()" +"(call-expand-observe" +" obs_75" +" 'tag" +" result-s_9))" +"(void)))" +"(void)))" +"(if get-list?_0(list result-s_9) result-s_9)))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_76)" +"(expand-context-observer" +" ctx_72)))" +"(if obs_76" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_76 'next)))" +"(void)))" +"(values))))" +"(let-values(((ids_30)(car idss_2)))" +"(let-values(((expanded-rhs_0)" +"(let-values(((temp152_1)(car rhss_2))" +"((temp153_0)" +"(as-named-context" +" ctx_72" +" ids_30)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" temp152_1" +" temp153_0))))" +"(let-values(((track-stx_0)(car track-stxs_3)))" +"(let-values(((local-or-forward-references?_0)" +"(reference-record-forward-references?" +" frame-id_14)))" +"(let-values((()" +"(begin" +"(reference-record-bound!" +" frame-id_14" +"(car keyss_1))" +"(values))))" +"(let-values(((forward-references?_0)" +"(reference-record-forward-references?" +" frame-id_14)))" +"(if(if(not local-or-forward-references?_0)" +" split?_0" +" #f)" +"(let-values()" +"(let-values((()" +"(begin" +"(if(null? accum-idss_0)" +"(void)" +"(let-values()" +"(error" +" \"internal error: accumulated ids not empty\")))" +"(values))))" +"(let-values(((exp-rest_0)" +"(loop_124" +"(cdr idss_2)" +"(cdr keyss_1)" +"(cdr rhss_2)" +"(cdr track-stxs_3)" +" null" +" null" +" null" +" null" +" #f" +" #t" +" #f)))" +"(let-values(((result-s_10)" +"(if(expand-context-to-parsed?" +" ctx_72)" +"(parsed-let-values17.1" +"(keep-properties-only" +" s_370)" +"(list ids_30)" +"(list" +"(list" +"(car keyss_1)" +" expanded-rhs_0))" +" exp-rest_0)" +"(let-values(((track?154_0)" +" track?_2)" +"((s155_0)" +" s_370)" +"((temp156_0)" +"(list*" +"(core-id" +" 'let-values" +" phase_139)" +"(list" +"(build-clause" +" ids_30" +" expanded-rhs_0" +" track-stx_0))" +" exp-rest_0)))" +"(rebuild5.1" +" track?154_0" +" #t" +" s155_0" +" temp156_0)))))" +"(begin" +"(let-values(((obs_77)" +"(expand-context-observer" +" ctx_72)))" +"(if obs_77" +"(let-values()" +"(if(if can-log?_0" +"(log-tag?" +" had-stxes?_0" +" ctx_72)" +" #f)" +"(let-values()" +"(call-expand-observe" +" obs_77" +" 'tag" +" result-s_10))" +"(void)))" +"(void)))" +"(if get-list?_0" +"(list result-s_10)" +" result-s_10))))))" +"(if(if(not forward-references?_0)" +"(let-values(((or-part_369) split?_0))" +"(if or-part_369" +" or-part_369" +"(null?(cdr idss_2))))" +" #f)" +"(let-values()" +"(let-values(((exp-rest_1)" +"(loop_124" +"(cdr idss_2)" +"(cdr keyss_1)" +"(cdr rhss_2)" +"(cdr track-stxs_3)" +" null" +" null" +" null" +" null" +" #f" +" #t" +" #f)))" +"(let-values(((result-s_11)" +"(if(expand-context-to-parsed?" +" ctx_72)" +"(parsed-letrec-values18.1" +"(keep-properties-only" +" s_370)" +"(reverse$1" +"(cons" +" ids_30" +" accum-idss_0))" +"(reverse$1" +"(cons" +"(list" +"(car keyss_1)" +" expanded-rhs_0)" +"(map2" +" list" +" accum-keyss_0" +" accum-rhss_0)))" +" exp-rest_1)" +"(let-values(((track?157_0)" +" track?_2)" +"((s158_0)" +" s_370)" +"((temp159_2)" +"(list*" +"(core-id" +" 'letrec-values" +" phase_139)" +"(build-clauses" +"(cons" +" ids_30" +" accum-idss_0)" +"(cons" +" expanded-rhs_0" +" accum-rhss_0)" +"(cons" +" track-stx_0" +" accum-track-stxs_0))" +" exp-rest_1)))" +"(rebuild5.1" +" track?157_0" +" #t" +" s158_0" +" temp159_2)))))" +"(begin" +"(let-values(((obs_78)" +"(expand-context-observer" +" ctx_72)))" +"(if obs_78" +"(let-values()" +"(if(if can-log?_0" +"(log-tag?" +" had-stxes?_0" +" ctx_72)" +" #f)" +"(let-values()" +"(call-expand-observe" +" obs_78" +" 'tag" +" result-s_11))" +"(void)))" +"(void)))" +"(if get-list?_0" +"(list result-s_11)" +" result-s_11)))))" +"(let-values()" +"(loop_124" +"(cdr idss_2)" +"(cdr keyss_1)" +"(cdr rhss_2)" +"(cdr track-stxs_3)" +"(cons ids_30 accum-idss_0)" +"(cons(car keyss_1) accum-keyss_0)" +"(cons expanded-rhs_0 accum-rhss_0)" +"(cons track-stx_0 accum-track-stxs_0)" +" track?_2" +" get-list?_0" +" can-log?_0)))))))))))))))))" +" loop_124)" +" idss_1" +" keyss_0" +" rhss_1" +" track-stxs_2" +" null" +" null" +" null" +" null" +" track?_1" +" #f" +" #t)))))))))))))))))" +"(define-values" +"(build-clauses)" +"(lambda(accum-idss_1 accum-rhss_1 accum-track-stxs_1)" +"(begin(map2 build-clause(reverse$1 accum-idss_1)(reverse$1 accum-rhss_1)(reverse$1 accum-track-stxs_1)))))" +"(define-values" +"(build-clause)" +"(lambda(ids_31 rhs_19 track-stx_1)" +"(begin" +"(let-values(((clause_2)(datum->syntax$1 #f(list ids_31 rhs_19))))" +"(if track-stx_1(syntax-track-origin$1 clause_2 track-stx_1) clause_2)))))" +"(define-values" +"(no-binds)" +"(lambda(expr_10 s_485 phase_140)" +"(begin" +"(let-values(((s-runtime-stx_0)(syntax-shift-phase-level$1 runtime-stx phase_140)))" +"(datum->syntax$1" +"(core-id '#%app phase_140)" +"(list(core-id 'begin phase_140) expr_10(list(datum->syntax$1 s-runtime-stx_0 'values)))" +" s_485)))))" +"(define-values" +"(log-tag?)" +"(lambda(had-stxes?_1 ctx_73)(begin(if had-stxes?_1(not(expand-context-only-immediate? ctx_73)) #f))))" +"(define-values" +"(log-letrec-values$1)" +"(lambda(obs_79 ctx_74 s_486 val-idss_2 val-rhss_2 track-stxs_4 stx-clauses_2 done-bodys_2)" +"(begin" +" 'log-letrec-values" +"(let-values(((phase_141)(expand-context-phase ctx_74)))" +"(let-values(((clauses_0)" +"(reverse$1" +"(let-values(((lst_328) val-idss_2)((lst_329) val-rhss_2)((lst_330) track-stxs_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_328)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_329)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_330)))" +"((letrec-values(((for-loop_274)" +"(lambda(fold-var_291 lst_238 lst_331 lst_332)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_238)(if(pair? lst_331)(pair? lst_332) #f) #f)" +"(let-values(((val-ids_0)(unsafe-car lst_238))" +"((rest_188)(unsafe-cdr lst_238))" +"((val-rhs_0)(unsafe-car lst_331))" +"((rest_189)(unsafe-cdr lst_331))" +"((track-stx_2)(unsafe-car lst_332))" +"((rest_190)(unsafe-cdr lst_332)))" +"(let-values(((fold-var_292)" +"(let-values(((fold-var_293) fold-var_291))" +"(let-values(((fold-var_294)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list val-ids_0 val-rhs_0)" +" track-stx_2))" +" fold-var_293))))" +"(values fold-var_294)))))" +"(if(not #f)" +"(for-loop_274 fold-var_292 rest_188 rest_189 rest_190)" +" fold-var_292)))" +" fold-var_291)))))" +" for-loop_274)" +" null" +" lst_328" +" lst_329" +" lst_330))))))" +"(let-values(((had-stxes?_2)(not(null? stx-clauses_2))))" +"(let-values(((lv-id_0)(core-id(if had-stxes?_2 'letrec-syntaxes+values 'letrec-values) phase_141)))" +"(let-values(((lv-s_0)" +"(datum->syntax$1" +" #f" +"(if had-stxes?_2" +"(list* lv-id_0 stx-clauses_2 clauses_0 done-bodys_2)" +"(list* lv-id_0 clauses_0 done-bodys_2))" +" s_486)))" +"(begin" +"(call-expand-observe obs_79 'block->letrec(list lv-s_0))" +"(call-expand-observe obs_79 'visit lv-s_0)" +"(call-expand-observe obs_79 'resolve lv-id_0)" +"(call-expand-observe obs_79 'enter-prim lv-s_0)" +"(if had-stxes?_2" +"(let-values()" +"(begin" +"(call-expand-observe obs_79 'prim-letrec-syntaxes+values #f)" +"(call-expand-observe" +" obs_79" +" 'letrec-syntaxes-renames" +" stx-clauses_2" +" clauses_0" +"(datum->syntax$1 #f done-bodys_2 s_486))" +"(call-expand-observe obs_79 'prepare-env)" +"(call-expand-observe obs_79 'next-group)" +"(if(null? val-idss_2)" +"(void)" +"(let-values()" +"(begin" +"(call-expand-observe obs_79 'prim-letrec-values)" +"(call-expand-observe" +" obs_79" +" 'let-renames" +" clauses_0" +"(datum->syntax$1 #f done-bodys_2 s_486)))))))" +"(let-values()" +"(begin" +"(call-expand-observe obs_79 'prim-letrec-values #f)" +"(call-expand-observe" +" obs_79" +" 'let-renames" +" clauses_0" +"(datum->syntax$1 #f done-bodys_2 s_486))))))))))))))" +"(define-values" +"(lambda-clause-expander)" +"(lambda(s_70 disarmed-s_5 formals_1 bodys_9 ctx_75 log-renames-tag_0)" +"(begin" +"(let-values(((sc_31)(new-scope 'local)))" +"(let-values(((phase_78)(expand-context-phase ctx_75)))" +"(let-values(((ids_32)(parse-and-flatten-formals formals_1 sc_31 disarmed-s_5)))" +"(let-values((()" +"(begin" +" (let-values (((temp37_4) \"argument name\"))" +"(check-no-duplicate-ids8.1 temp37_4 #t ids_32 phase_78 s_70 #f #f))" +"(values))))" +"(let-values(((counter_7)(root-expand-context-counter ctx_75)))" +"(let-values(((keys_7)" +"(reverse$1" +"(let-values(((lst_269) ids_32))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_269)))" +"((letrec-values(((for-loop_275)" +"(lambda(fold-var_63 lst_38)" +"(begin" +" 'for-loop" +"(if(pair? lst_38)" +"(let-values(((id_111)(unsafe-car lst_38))" +"((rest_191)(unsafe-cdr lst_38)))" +"(let-values(((fold-var_295)" +"(let-values(((fold-var_64) fold-var_63))" +"(let-values(((fold-var_150)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((s41_0)" +" s_70))" +"(add-local-binding!35.1" +" #f" +" #f" +" s41_0" +" #t" +" id_111" +" phase_78" +" counter_7)))" +" fold-var_64))))" +"(values fold-var_150)))))" +"(if(not #f)" +"(for-loop_275 fold-var_295 rest_191)" +" fold-var_295)))" +" fold-var_63)))))" +" for-loop_275)" +" null" +" lst_269))))))" +"(let-values(((body-env_0)" +"(let-values(((lst_302) keys_7)((lst_23) ids_32))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_302)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_23)))" +"((letrec-values(((for-loop_20)" +"(lambda(env_25 lst_24 lst_168)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_24)(pair? lst_168) #f)" +"(let-values(((key_92)(unsafe-car lst_24))" +"((rest_140)(unsafe-cdr lst_24))" +"((id_112)(unsafe-car lst_168))" +"((rest_141)(unsafe-cdr lst_168)))" +"(let-values(((env_26)" +"(let-values(((env_27) env_25))" +"(let-values(((env_28)" +"(let-values()" +"(env-extend" +" env_27" +" key_92" +"(local-variable1.1" +" id_112)))))" +"(values env_28)))))" +"(if(not #f)" +"(for-loop_20 env_26 rest_140 rest_141)" +" env_26)))" +" env_25)))))" +" for-loop_20)" +"(expand-context-env ctx_75)" +" lst_302" +" lst_23)))))" +"(let-values(((sc-formals_0)(add-scope formals_1 sc_31)))" +"(let-values(((sc-bodys_0)" +"(reverse$1" +"(let-values(((lst_17) bodys_9))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_17)))" +"((letrec-values(((for-loop_10)" +"(lambda(fold-var_164 lst_18)" +"(begin" +" 'for-loop" +"(if(pair? lst_18)" +"(let-values(((body_12)(unsafe-car lst_18))" +"((rest_5)(unsafe-cdr lst_18)))" +"(let-values(((fold-var_296)" +"(let-values(((fold-var_167)" +" fold-var_164))" +"(let-values(((fold-var_297)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" body_12" +" sc_31))" +" fold-var_167))))" +"(values fold-var_297)))))" +"(if(not #f)" +"(for-loop_10 fold-var_296 rest_5)" +" fold-var_296)))" +" fold-var_164)))))" +" for-loop_10)" +" null" +" lst_17))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_80)(expand-context-observer ctx_75)))" +"(if obs_80" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_80" +" log-renames-tag_0" +" sc-formals_0" +"(datum->syntax$1 #f sc-bodys_0))))" +"(void)))" +"(values))))" +"(let-values(((body-ctx_4)" +"(let-values(((v_251) ctx_75))" +"(let-values(((the-struct_95) v_251))" +"(if(expand-context/outer? the-struct_95)" +"(let-values(((env42_0) body-env_0)" +"((scopes43_0)(cons sc_31(expand-context-scopes ctx_75)))" +"((binding-layer44_0)" +"(increment-binding-layer ids_32 ctx_75 sc_31))" +"((frame-id45_0) #f)" +"((inner46_1)(root-expand-context/outer-inner v_251)))" +"(expand-context/outer1.1" +" inner46_1" +"(root-expand-context/outer-post-expansion-scope the-struct_95)" +"(root-expand-context/outer-use-site-scopes the-struct_95)" +" frame-id45_0" +"(expand-context/outer-context the-struct_95)" +" env42_0" +"(expand-context/outer-post-expansion-scope-action the-struct_95)" +" scopes43_0" +"(expand-context/outer-def-ctx-scopes the-struct_95)" +" binding-layer44_0" +"(expand-context/outer-reference-records the-struct_95)" +"(expand-context/outer-only-immediate? the-struct_95)" +"(expand-context/outer-need-eventually-defined the-struct_95)" +"(expand-context/outer-current-introduction-scopes the-struct_95)" +"(expand-context/outer-name the-struct_95)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_95))))))" +"(let-values(((exp-body_2)" +"(let-values(((temp49_2)" +"(let-values(((temp52_6) #t))" +"(keep-as-needed74.1 #f #f temp52_6 #t #f #f ctx_75 s_70))))" +"(expand-body7.1 temp49_2 #f #f sc-bodys_0 body-ctx_4))))" +"(values" +"(if(expand-context-to-parsed? ctx_75)" +"(unflatten-like-formals keys_7 formals_1)" +" sc-formals_0)" +" exp-body_2))))))))))))))))" +"(define-values" +"(make-expand-lambda)" +"(lambda(get-lambda_0)" +"(begin" +"(lambda(s_181 ctx_76)" +"(let-values((()" +"(begin" +"(let-values(((obs_81)(expand-context-observer ctx_76)))" +"(if obs_81(let-values()(let-values()(call-expand-observe obs_81 'prim-lambda)))(void)))" +"(values))))" +"(let-values(((disarmed-s_6)(syntax-disarm$1 s_181)))" +"(let-values(((ok?_34 lambda53_0 formals54_0 body55_0)" +"(let-values(((s_76) disarmed-s_6))" +"(let-values(((orig-s_42) s_76))" +"(let-values(((lambda53_1 formals54_1 body55_1)" +"(let-values(((s_305)(if(syntax?$1 s_76)(syntax-e$1 s_76) s_76)))" +"(if(pair? s_305)" +"(let-values(((lambda56_0)(let-values(((s_187)(car s_305))) s_187))" +"((formals57_0 body58_0)" +"(let-values(((s_487)(cdr s_305)))" +"(let-values(((s_403)" +"(if(syntax?$1 s_487)" +"(syntax-e$1 s_487)" +" s_487)))" +"(if(pair? s_403)" +"(let-values(((formals59_0)" +"(let-values(((s_488)(car s_403)))" +" s_488))" +"((body60_0)" +"(let-values(((s_489)(cdr s_403)))" +"(let-values(((s_163)" +"(if(syntax?$1 s_489)" +"(syntax-e$1 s_489)" +" s_489)))" +"(let-values(((flat-s_27)" +"(to-syntax-list.1" +" s_163)))" +"(if(not flat-s_27)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_42))" +"(if(null? flat-s_27)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_42))" +"(let-values()" +" flat-s_27))))))))" +"(values formals59_0 body60_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_42))))))" +"(values lambda56_0 formals57_0 body58_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_42)))))" +"(values #t lambda53_1 formals54_1 body55_1))))))" +"(let-values(((rebuild-s_4)" +"(let-values(((temp63_4) #t))(keep-as-needed74.1 #f #f #f #f temp63_4 #t ctx_76 s_181))))" +"(let-values(((formals_2 body_13)" +"(lambda-clause-expander s_181 disarmed-s_6 formals54_0 body55_0 ctx_76 'lambda-renames)))" +"(if(expand-context-to-parsed? ctx_76)" +"(parsed-lambda5.1 rebuild-s_4 formals_2 body_13)" +"(let-values(((rebuild-s64_0) rebuild-s_4)" +"((temp65_7)(list*(get-lambda_0 ctx_76 lambda53_0) formals_2 body_13)))" +"(rebuild5.1 #f #f rebuild-s64_0 temp65_7))))))))))))" +"(void(add-core-form!* 'lambda(make-expand-lambda(lambda(ctx_77 lam-id_0) lam-id_0))))" +"(void" +"(add-core-form!*" +" 'λ" +"(make-expand-lambda" +"(lambda(ctx_78 lam-id_1)" +"(datum->syntax$1" +"(syntax-shift-phase-level$1 core-stx(expand-context-phase ctx_78))" +" 'lambda" +" lam-id_1" +" lam-id_1)))))" +"(void" +"(add-core-form!*" +" 'case-lambda" +"(lambda(s_490 ctx_79)" +"(let-values((()" +"(begin" +"(let-values(((obs_32)(expand-context-observer ctx_79)))" +"(if obs_32" +"(let-values()(let-values()(call-expand-observe obs_32 'prim-case-lambda)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_7)(syntax-disarm$1 s_490)))" +"(let-values(((ok?_35 case-lambda66_0 formals67_0 body68_0)" +"(let-values(((s_32) disarmed-s_7))" +"(let-values(((orig-s_43) s_32))" +"(let-values(((case-lambda66_1 formals67_1 body68_1)" +"(let-values(((s_69)(if(syntax?$1 s_32)(syntax-e$1 s_32) s_32)))" +"(if(pair? s_69)" +"(let-values(((case-lambda69_0)(let-values(((s_311)(car s_69))) s_311))" +"((formals70_0 body71_0)" +"(let-values(((s_474)(cdr s_69)))" +"(let-values(((s_491)" +"(if(syntax?$1 s_474)" +"(syntax-e$1 s_474)" +" s_474)))" +"(let-values(((flat-s_28)(to-syntax-list.1 s_491)))" +"(if(not flat-s_28)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_43))" +"(let-values()" +"(let-values(((formals_3 body_14)" +"(let-values(((lst_312) flat-s_28))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_312)))" +"((letrec-values(((for-loop_276)" +"(lambda(formals_4" +" body_15" +" lst_98)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_98)" +"(let-values(((s_433)" +"(unsafe-car" +" lst_98))" +"((rest_192)" +"(unsafe-cdr" +" lst_98)))" +"(let-values(((formals_5" +" body_16)" +"(let-values(((formals_6)" +" formals_4)" +"((body_17)" +" body_15))" +"(let-values(((formals_7" +" body_18)" +"(let-values()" +"(let-values(((formals78_0" +" body79_0)" +"(let-values()" +"(let-values(((s_55)" +"(if(syntax?$1" +" s_433)" +"(syntax-e$1" +" s_433)" +" s_433)))" +"(if(pair?" +" s_55)" +"(let-values(((formals72_0)" +"(let-values(((s_319)" +"(car" +" s_55)))" +" s_319))" +"((body73_0)" +"(let-values(((s_492)" +"(cdr" +" s_55)))" +"(let-values(((s_388)" +"(if(syntax?$1" +" s_492)" +"(syntax-e$1" +" s_492)" +" s_492)))" +"(let-values(((flat-s_29)" +"(to-syntax-list.1" +" s_388)))" +"(if(not" +" flat-s_29)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_43))" +"(if(null?" +" flat-s_29)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_43))" +"(let-values()" +" flat-s_29))))))))" +"(values" +" formals72_0" +" body73_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_43))))))" +"(values" +"(cons" +" formals78_0" +" formals_6)" +"(cons" +" body79_0" +" body_17))))))" +"(values" +" formals_7" +" body_18)))))" +"(if(not" +" #f)" +"(for-loop_276" +" formals_5" +" body_16" +" rest_192)" +"(values" +" formals_5" +" body_16))))" +"(values" +" formals_4" +" body_15))))))" +" for-loop_276)" +" null" +" null" +" lst_312)))))" +"(values" +"(reverse$1 formals_3)" +"(reverse$1 body_14))))))))))" +"(values case-lambda69_0 formals70_0 body71_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_43)))))" +"(values #t case-lambda66_1 formals67_1 body68_1))))))" +"(let-values(((ok?_36 case-lambda74_0 clause75_0)" +"(let-values(((s_56) disarmed-s_7))" +"(let-values(((orig-s_44) s_56))" +"(let-values(((case-lambda74_1 clause75_1)" +"(let-values(((s_304)(if(syntax?$1 s_56)(syntax-e$1 s_56) s_56)))" +"(if(pair? s_304)" +"(let-values(((case-lambda76_0)" +"(let-values(((s_391)(car s_304))) s_391))" +"((clause77_0)" +"(let-values(((s_493)(cdr s_304)))" +"(let-values(((s_57)" +"(if(syntax?$1 s_493)" +"(syntax-e$1 s_493)" +" s_493)))" +"(let-values(((flat-s_30)(to-syntax-list.1 s_57)))" +"(if(not flat-s_30)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_44))" +"(let-values() flat-s_30)))))))" +"(values case-lambda76_0 clause77_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_44)))))" +"(values #t case-lambda74_1 clause75_1))))))" +"(let-values(((rebuild-s_5)" +"(let-values(((temp82_7) #t))(keep-as-needed74.1 #f #f #f #f temp82_7 #t ctx_79 s_490))))" +"(let-values(((clauses_1)" +"(reverse$1" +"(let-values(((lst_192) formals67_0)((lst_223) body68_0)((lst_224) clause75_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_192)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_223)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_224)))" +"((letrec-values(((for-loop_277)" +"(lambda(fold-var_298 lst_333 lst_334 lst_335)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_333)" +"(if(pair? lst_334)(pair? lst_335) #f)" +" #f)" +"(let-values(((formals_8)(unsafe-car lst_333))" +"((rest_193)(unsafe-cdr lst_333))" +"((body_19)(unsafe-car lst_334))" +"((rest_194)(unsafe-cdr lst_334))" +"((clause_3)(unsafe-car lst_335))" +"((rest_195)(unsafe-cdr lst_335)))" +"(let-values(((fold-var_299)" +"(let-values(((fold-var_300) fold-var_298))" +"(let-values(((fold-var_187)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_82)" +"(expand-context-observer" +" ctx_79)))" +"(if obs_82" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_82" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((rebuild-clause_0)" +"(let-values(((ctx83_0)" +" ctx_79)" +"((clause84_0)" +" clause_3))" +"(keep-as-needed74.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ctx83_0" +" clause84_0))))" +"(let-values(((exp-formals_0" +" exp-body_3)" +"(lambda-clause-expander" +" s_490" +" disarmed-s_7" +" formals_8" +" body_19" +" ctx_79" +" 'case-lambda-renames)))" +"(if(expand-context-to-parsed?" +" ctx_79)" +"(list" +" exp-formals_0" +" exp-body_3)" +"(let-values(((rebuild-clause85_0)" +" rebuild-clause_0)" +"((temp86_2)" +"(list*" +" exp-formals_0" +" exp-body_3)))" +"(rebuild5.1" +" #f" +" #f" +" rebuild-clause85_0" +" temp86_2)))))))" +" fold-var_300))))" +"(values fold-var_187)))))" +"(if(not #f)" +"(for-loop_277 fold-var_299 rest_193 rest_194 rest_195)" +" fold-var_299)))" +" fold-var_298)))))" +" for-loop_277)" +" null" +" lst_192" +" lst_223" +" lst_224))))))" +"(if(expand-context-to-parsed? ctx_79)" +"(parsed-case-lambda6.1 rebuild-s_5 clauses_1)" +"(let-values(((rebuild-s87_0) rebuild-s_5)((temp88_3)(list* case-lambda66_0 clauses_1)))" +"(rebuild5.1 #f #f rebuild-s87_0 temp88_3))))))))))))" +"(define-values" +"(parse-and-flatten-formals)" +"(lambda(all-formals_0 sc_32 s_321)" +"(begin" +"((letrec-values(((loop_125)" +"(lambda(formals_9)" +"(begin" +" 'loop" +"(if(identifier? formals_9)" +"(let-values()(list(add-scope formals_9 sc_32)))" +"(if(syntax?$1 formals_9)" +"(let-values()" +"(let-values(((p_83)(syntax-e$1 formals_9)))" +"(if(pair? p_83)" +"(let-values()(loop_125 p_83))" +"(if(null? p_83)" +"(let-values() null)" +" (let-values () (raise-syntax-error$1 #f \"not an identifier\" s_321 p_83))))))" +"(if(pair? formals_9)" +"(let-values()" +"(begin" +"(if(identifier?(car formals_9))" +"(void)" +"(let-values()" +" (raise-syntax-error$1 #f \"not an identifier\" s_321 (car formals_9))))" +"(cons(add-scope(car formals_9) sc_32)(loop_125(cdr formals_9)))))" +"(if(null? formals_9)" +"(let-values() null)" +"(let-values()" +" (raise-syntax-error$1 \"bad argument sequence\" s_321 all-formals_0))))))))))" +" loop_125)" +" all-formals_0))))" +"(define-values" +"(unflatten-like-formals)" +"(lambda(keys_8 formals_10)" +"(begin" +"((letrec-values(((loop_126)" +"(lambda(keys_9 formals_11)" +"(begin" +" 'loop" +"(if(null? formals_11)" +"(let-values() null)" +"(if(pair? formals_11)" +"(let-values()(cons(car keys_9)(loop_126(cdr keys_9)(cdr formals_11))))" +"(if(syntax?$1 formals_11)" +"(let-values()(loop_126 keys_9(syntax-e$1 formals_11)))" +"(let-values()(car keys_9)))))))))" +" loop_126)" +" keys_8" +" formals_10))))" +"(define-values" +"(make-let-values-form11.1)" +"(lambda(log-tag1_0" +" rec?3_0" +" rec?8_0" +" renames-log-tag5_0" +" renames-log-tag10_0" +" split-by-reference?4_0" +" split-by-reference?9_0" +" syntaxes?2_0" +" syntaxes?7_0)" +"(begin" +" 'make-let-values-form11" +"(let-values(((log-tag_0) log-tag1_0))" +"(let-values(((syntaxes?_0)(if syntaxes?7_0 syntaxes?2_0 #f)))" +"(let-values(((rec?_1)(if rec?8_0 rec?3_0 #f)))" +"(let-values(((split-by-reference?_0)(if split-by-reference?9_0 split-by-reference?4_0 #f)))" +"(let-values(((renames-log-tag_0)(if renames-log-tag10_0 renames-log-tag5_0 'let-renames)))" +"(let-values()" +"(lambda(s_89 ctx_80)" +"(let-values((()" +"(begin" +"(let-values(((obs_83)(expand-context-observer ctx_80)))" +"(if obs_83" +"(let-values()(let-values()(call-expand-observe obs_83 log-tag_0)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_8)(syntax-disarm$1 s_89)))" +"(let-values(((ok?_37" +" letrec-syntaxes+values89_0" +" id:trans90_0" +" trans-rhs91_0" +" id:val92_0" +" val-rhs93_0" +" body94_0)" +"(let-values(((s_107) disarmed-s_8))" +"(if(if syntaxes?_0 #t #f)" +"(let-values(((orig-s_45) s_107))" +"(let-values(((letrec-syntaxes+values89_1" +" id:trans90_1" +" trans-rhs91_1" +" id:val92_1" +" val-rhs93_1" +" body94_1)" +"(let-values(((s_213)" +"(if(syntax?$1 s_107)" +"(syntax-e$1 s_107)" +" s_107)))" +"(if(pair? s_213)" +"(let-values(((letrec-syntaxes+values95_0)" +"(let-values(((s_494)(car s_213))) s_494))" +"((id:trans96_0" +" trans-rhs97_0" +" id:val98_0" +" val-rhs99_0" +" body100_0)" +"(let-values(((s_111)(cdr s_213)))" +"(let-values(((s_495)" +"(if(syntax?$1 s_111)" +"(syntax-e$1 s_111)" +" s_111)))" +"(if(pair? s_495)" +"(let-values(((id:trans101_0" +" trans-rhs102_0)" +"(let-values(((s_496)" +"(car" +" s_495)))" +"(let-values(((s_113)" +"(if(syntax?$1" +" s_496)" +"(syntax-e$1" +" s_496)" +" s_496)))" +"(let-values(((flat-s_31)" +"(to-syntax-list.1" +" s_113)))" +"(if(not" +" flat-s_31)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +"(let-values(((id:trans_0" +" trans-rhs_0)" +"(let-values(((lst_336)" +" flat-s_31))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_336)))" +"((letrec-values(((for-loop_278)" +"(lambda(id:trans_1" +" trans-rhs_1" +" lst_337)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_337)" +"(let-values(((s_497)" +"(unsafe-car" +" lst_337))" +"((rest_196)" +"(unsafe-cdr" +" lst_337)))" +"(let-values(((id:trans_2" +" trans-rhs_2)" +"(let-values(((id:trans_3)" +" id:trans_1)" +"((trans-rhs_3)" +" trans-rhs_1))" +"(let-values(((id:trans_4" +" trans-rhs_4)" +"(let-values()" +"(let-values(((id:trans132_0" +" trans-rhs133_0)" +"(let-values()" +"(let-values(((s_221)" +"(if(syntax?$1" +" s_497)" +"(syntax-e$1" +" s_497)" +" s_497)))" +"(if(pair?" +" s_221)" +"(let-values(((id:trans106_0)" +"(let-values(((s_498)" +"(car" +" s_221)))" +"(let-values(((s_440)" +"(if(syntax?$1" +" s_498)" +"(syntax-e$1" +" s_498)" +" s_498)))" +"(let-values(((flat-s_32)" +"(to-syntax-list.1" +" s_440)))" +"(if(not" +" flat-s_32)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +"(let-values(((id:trans_5)" +"(let-values(((lst_338)" +" flat-s_32))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_338)))" +"((letrec-values(((for-loop_279)" +"(lambda(id:trans_6" +" lst_339)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_339)" +"(let-values(((s_499)" +"(unsafe-car" +" lst_339))" +"((rest_197)" +"(unsafe-cdr" +" lst_339)))" +"(let-values(((id:trans_7)" +"(let-values(((id:trans_8)" +" id:trans_6))" +"(let-values(((id:trans_9)" +"(let-values()" +"(let-values(((id:trans134_0)" +"(let-values()" +"(if(let-values(((or-part_370)" +"(if(syntax?$1" +" s_499)" +"(symbol?" +"(syntax-e$1" +" s_499))" +" #f)))" +"(if or-part_370" +" or-part_370" +"(symbol?" +" s_499)))" +" s_499" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_45" +" s_499)))))" +"(cons" +" id:trans134_0" +" id:trans_8)))))" +"(values" +" id:trans_9)))))" +"(if(not" +" #f)" +"(for-loop_279" +" id:trans_7" +" rest_197)" +" id:trans_7)))" +" id:trans_6)))))" +" for-loop_279)" +" null" +" lst_338)))))" +"(reverse$1" +" id:trans_5))))))))" +"((trans-rhs107_0)" +"(let-values(((s_500)" +"(cdr" +" s_221)))" +"(let-values(((s_501)" +"(if(syntax?$1" +" s_500)" +"(syntax-e$1" +" s_500)" +" s_500)))" +"(if(pair?" +" s_501)" +"(let-values(((trans-rhs108_0)" +"(let-values(((s_502)" +"(car" +" s_501)))" +" s_502))" +"(()" +"(let-values(((s_503)" +"(cdr" +" s_501)))" +"(let-values(((s_504)" +"(if(syntax?$1" +" s_503)" +"(syntax-e$1" +" s_503)" +" s_503)))" +"(if(null?" +" s_504)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" trans-rhs108_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" id:trans106_0" +" trans-rhs107_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +"(cons" +" id:trans132_0" +" id:trans_3)" +"(cons" +" trans-rhs133_0" +" trans-rhs_3))))))" +"(values" +" id:trans_4" +" trans-rhs_4)))))" +"(if(not" +" #f)" +"(for-loop_278" +" id:trans_2" +" trans-rhs_2" +" rest_196)" +"(values" +" id:trans_2" +" trans-rhs_2))))" +"(values" +" id:trans_1" +" trans-rhs_1))))))" +" for-loop_278)" +" null" +" null" +" lst_336)))))" +"(values" +"(reverse$1" +" id:trans_0)" +"(reverse$1" +" trans-rhs_0)))))))))" +"((id:val103_0" +" val-rhs104_0" +" body105_0)" +"(let-values(((s_123)" +"(cdr" +" s_495)))" +"(let-values(((s_505)" +"(if(syntax?$1" +" s_123)" +"(syntax-e$1" +" s_123)" +" s_123)))" +"(if(pair? s_505)" +"(let-values(((id:val109_0" +" val-rhs110_0)" +"(let-values(((s_506)" +"(car" +" s_505)))" +"(let-values(((s_507)" +"(if(syntax?$1" +" s_506)" +"(syntax-e$1" +" s_506)" +" s_506)))" +"(let-values(((flat-s_33)" +"(to-syntax-list.1" +" s_507)))" +"(if(not" +" flat-s_33)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +"(let-values(((id:val_0" +" val-rhs_1)" +"(let-values(((lst_201)" +" flat-s_33))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_201)))" +"((letrec-values(((for-loop_280)" +"(lambda(id:val_1" +" val-rhs_2" +" lst_204)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_204)" +"(let-values(((s_508)" +"(unsafe-car" +" lst_204))" +"((rest_198)" +"(unsafe-cdr" +" lst_204)))" +"(let-values(((id:val_2" +" val-rhs_3)" +"(let-values(((id:val_3)" +" id:val_1)" +"((val-rhs_4)" +" val-rhs_2))" +"(let-values(((id:val_4" +" val-rhs_5)" +"(let-values()" +"(let-values(((id:val135_0" +" val-rhs136_0)" +"(let-values()" +"(let-values(((s_231)" +"(if(syntax?$1" +" s_508)" +"(syntax-e$1" +" s_508)" +" s_508)))" +"(if(pair?" +" s_231)" +"(let-values(((id:val112_0)" +"(let-values(((s_233)" +"(car" +" s_231)))" +"(let-values(((s_234)" +"(if(syntax?$1" +" s_233)" +"(syntax-e$1" +" s_233)" +" s_233)))" +"(let-values(((flat-s_34)" +"(to-syntax-list.1" +" s_234)))" +"(if(not" +" flat-s_34)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +"(let-values(((id:val_5)" +"(let-values(((lst_340)" +" flat-s_34))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_340)))" +"((letrec-values(((for-loop_281)" +"(lambda(id:val_6" +" lst_341)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_341)" +"(let-values(((s_340)" +"(unsafe-car" +" lst_341))" +"((rest_199)" +"(unsafe-cdr" +" lst_341)))" +"(let-values(((id:val_7)" +"(let-values(((id:val_8)" +" id:val_6))" +"(let-values(((id:val_9)" +"(let-values()" +"(let-values(((id:val137_0)" +"(let-values()" +"(if(let-values(((or-part_331)" +"(if(syntax?$1" +" s_340)" +"(symbol?" +"(syntax-e$1" +" s_340))" +" #f)))" +"(if or-part_331" +" or-part_331" +"(symbol?" +" s_340)))" +" s_340" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_45" +" s_340)))))" +"(cons" +" id:val137_0" +" id:val_8)))))" +"(values" +" id:val_9)))))" +"(if(not" +" #f)" +"(for-loop_281" +" id:val_7" +" rest_199)" +" id:val_7)))" +" id:val_6)))))" +" for-loop_281)" +" null" +" lst_340)))))" +"(reverse$1" +" id:val_5))))))))" +"((val-rhs113_0)" +"(let-values(((s_347)" +"(cdr" +" s_231)))" +"(let-values(((s_509)" +"(if(syntax?$1" +" s_347)" +"(syntax-e$1" +" s_347)" +" s_347)))" +"(if(pair?" +" s_509)" +"(let-values(((val-rhs114_0)" +"(let-values(((s_510)" +"(car" +" s_509)))" +" s_510))" +"(()" +"(let-values(((s_511)" +"(cdr" +" s_509)))" +"(let-values(((s_236)" +"(if(syntax?$1" +" s_511)" +"(syntax-e$1" +" s_511)" +" s_511)))" +"(if(null?" +" s_236)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" val-rhs114_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" id:val112_0" +" val-rhs113_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +"(cons" +" id:val135_0" +" id:val_3)" +"(cons" +" val-rhs136_0" +" val-rhs_4))))))" +"(values" +" id:val_4" +" val-rhs_5)))))" +"(if(not" +" #f)" +"(for-loop_280" +" id:val_2" +" val-rhs_3" +" rest_198)" +"(values" +" id:val_2" +" val-rhs_3))))" +"(values" +" id:val_1" +" val-rhs_2))))))" +" for-loop_280)" +" null" +" null" +" lst_201)))))" +"(values" +"(reverse$1" +" id:val_0)" +"(reverse$1" +" val-rhs_1)))))))))" +"((body111_0)" +"(let-values(((s_512)" +"(cdr" +" s_505)))" +"(let-values(((s_348)" +"(if(syntax?$1" +" s_512)" +"(syntax-e$1" +" s_512)" +" s_512)))" +"(let-values(((flat-s_35)" +"(to-syntax-list.1" +" s_348)))" +"(if(not" +" flat-s_35)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(if(null?" +" flat-s_35)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))" +"(let-values()" +" flat-s_35))))))))" +"(values" +" id:val109_0" +" val-rhs110_0" +" body111_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" id:trans101_0" +" trans-rhs102_0" +" id:val103_0" +" val-rhs104_0" +" body105_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_45))))))" +"(values" +" letrec-syntaxes+values95_0" +" id:trans96_0" +" trans-rhs97_0" +" id:val98_0" +" val-rhs99_0" +" body100_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_45)))))" +"(values" +" #t" +" letrec-syntaxes+values89_1" +" id:trans90_1" +" trans-rhs91_1" +" id:val92_1" +" val-rhs93_1" +" body94_1)))" +"(values #f #f #f #f #f #f #f)))))" +"(let-values(((ok?_38 let-values115_0 id:val116_0 val-rhs117_0 body118_0)" +"(let-values(((s_445) disarmed-s_8))" +"(if(if(not syntaxes?_0) #t #f)" +"(let-values(((orig-s_46) s_445))" +"(let-values(((let-values115_1 id:val116_1 val-rhs117_1 body118_1)" +"(let-values(((s_239)" +"(if(syntax?$1 s_445)" +"(syntax-e$1 s_445)" +" s_445)))" +"(if(pair? s_239)" +"(let-values(((let-values119_0)" +"(let-values(((s_242)(car s_239)))" +" s_242))" +"((id:val120_0 val-rhs121_0 body122_0)" +"(let-values(((s_243)(cdr s_239)))" +"(let-values(((s_513)" +"(if(syntax?$1 s_243)" +"(syntax-e$1 s_243)" +" s_243)))" +"(if(pair? s_513)" +"(let-values(((id:val123_0" +" val-rhs124_0)" +"(let-values(((s_352)" +"(car" +" s_513)))" +"(let-values(((s_514)" +"(if(syntax?$1" +" s_352)" +"(syntax-e$1" +" s_352)" +" s_352)))" +"(let-values(((flat-s_36)" +"(to-syntax-list.1" +" s_514)))" +"(if(not" +" flat-s_36)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))" +"(let-values()" +"(let-values(((id:val_10" +" val-rhs_6)" +"(let-values(((lst_342)" +" flat-s_36))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_342)))" +"((letrec-values(((for-loop_282)" +"(lambda(id:val_11" +" val-rhs_7" +" lst_212)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_212)" +"(let-values(((s_450)" +"(unsafe-car" +" lst_212))" +"((rest_200)" +"(unsafe-cdr" +" lst_212)))" +"(let-values(((id:val_12" +" val-rhs_8)" +"(let-values(((id:val_13)" +" id:val_11)" +"((val-rhs_9)" +" val-rhs_7))" +"(let-values(((id:val_14" +" val-rhs_10)" +"(let-values()" +"(let-values(((id:val138_0" +" val-rhs139_0)" +"(let-values()" +"(let-values(((s_361)" +"(if(syntax?$1" +" s_450)" +"(syntax-e$1" +" s_450)" +" s_450)))" +"(if(pair?" +" s_361)" +"(let-values(((id:val126_0)" +"(let-values(((s_515)" +"(car" +" s_361)))" +"(let-values(((s_516)" +"(if(syntax?$1" +" s_515)" +"(syntax-e$1" +" s_515)" +" s_515)))" +"(let-values(((flat-s_37)" +"(to-syntax-list.1" +" s_516)))" +"(if(not" +" flat-s_37)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))" +"(let-values()" +"(let-values(((id:val_15)" +"(let-values(((lst_343)" +" flat-s_37))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_343)))" +"((letrec-values(((for-loop_283)" +"(lambda(id:val_16" +" lst_344)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_344)" +"(let-values(((s_517)" +"(unsafe-car" +" lst_344))" +"((rest_201)" +"(unsafe-cdr" +" lst_344)))" +"(let-values(((id:val_17)" +"(let-values(((id:val_18)" +" id:val_16))" +"(let-values(((id:val_19)" +"(let-values()" +"(let-values(((id:val140_0)" +"(let-values()" +"(if(let-values(((or-part_371)" +"(if(syntax?$1" +" s_517)" +"(symbol?" +"(syntax-e$1" +" s_517))" +" #f)))" +"(if or-part_371" +" or-part_371" +"(symbol?" +" s_517)))" +" s_517" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_46" +" s_517)))))" +"(cons" +" id:val140_0" +" id:val_18)))))" +"(values" +" id:val_19)))))" +"(if(not" +" #f)" +"(for-loop_283" +" id:val_17" +" rest_201)" +" id:val_17)))" +" id:val_16)))))" +" for-loop_283)" +" null" +" lst_343)))))" +"(reverse$1" +" id:val_15))))))))" +"((val-rhs127_0)" +"(let-values(((s_518)" +"(cdr" +" s_361)))" +"(let-values(((s_519)" +"(if(syntax?$1" +" s_518)" +"(syntax-e$1" +" s_518)" +" s_518)))" +"(if(pair?" +" s_519)" +"(let-values(((val-rhs128_0)" +"(let-values(((s_248)" +"(car" +" s_519)))" +" s_248))" +"(()" +"(let-values(((s_249)" +"(cdr" +" s_519)))" +"(let-values(((s_520)" +"(if(syntax?$1" +" s_249)" +"(syntax-e$1" +" s_249)" +" s_249)))" +"(if(null?" +" s_520)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))))))" +"(values" +" val-rhs128_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))))))" +"(values" +" id:val126_0" +" val-rhs127_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))))))" +"(values" +"(cons" +" id:val138_0" +" id:val_13)" +"(cons" +" val-rhs139_0" +" val-rhs_9))))))" +"(values" +" id:val_14" +" val-rhs_10)))))" +"(if(not" +" #f)" +"(for-loop_282" +" id:val_12" +" val-rhs_8" +" rest_200)" +"(values" +" id:val_12" +" val-rhs_8))))" +"(values" +" id:val_11" +" val-rhs_7))))))" +" for-loop_282)" +" null" +" null" +" lst_342)))))" +"(values" +"(reverse$1" +" id:val_10)" +"(reverse$1" +" val-rhs_6)))))))))" +"((body125_0)" +"(let-values(((s_521)" +"(cdr" +" s_513)))" +"(let-values(((s_522)" +"(if(syntax?$1" +" s_521)" +"(syntax-e$1" +" s_521)" +" s_521)))" +"(let-values(((flat-s_38)" +"(to-syntax-list.1" +" s_522)))" +"(if(not" +" flat-s_38)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))" +"(if(null?" +" flat-s_38)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))" +"(let-values()" +" flat-s_38))))))))" +"(values" +" id:val123_0" +" val-rhs124_0" +" body125_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_46))))))" +"(values" +" let-values119_0" +" id:val120_0" +" val-rhs121_0" +" body122_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_46)))))" +"(values #t let-values115_1 id:val116_1 val-rhs117_1 body118_1)))" +"(values #f #f #f #f #f)))))" +"(let-values(((sc_7)(new-scope 'local)))" +"(let-values(((phase_142)(expand-context-phase ctx_80)))" +"(let-values(((frame-id_15)(if syntaxes?_0(make-reference-record) #f)))" +"(let-values(((trans-idss_2)" +"(reverse$1" +"(let-values(((lst_345)(if syntaxes?_0 id:trans90_0 null)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_345)))" +"((letrec-values(((for-loop_284)" +"(lambda(fold-var_301 lst_346)" +"(begin" +" 'for-loop" +"(if(pair? lst_346)" +"(let-values(((ids_33)" +"(unsafe-car lst_346))" +"((rest_202)" +"(unsafe-cdr lst_346)))" +"(let-values(((fold-var_302)" +"(let-values(((fold-var_303)" +" fold-var_301))" +"(let-values(((fold-var_269)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_347)" +" ids_33))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_347)))" +"((letrec-values(((for-loop_285)" +"(lambda(fold-var_304" +" lst_348)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_348)" +"(let-values(((id_113)" +"(unsafe-car" +" lst_348))" +"((rest_203)" +"(unsafe-cdr" +" lst_348)))" +"(let-values(((fold-var_305)" +"(let-values(((fold-var_306)" +" fold-var_304))" +"(let-values(((fold-var_307)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_113" +" sc_7))" +" fold-var_306))))" +"(values" +" fold-var_307)))))" +"(if(not" +" #f)" +"(for-loop_285" +" fold-var_305" +" rest_203)" +" fold-var_305)))" +" fold-var_304)))))" +" for-loop_285)" +" null" +" lst_347)))))" +" fold-var_303))))" +"(values" +" fold-var_269)))))" +"(if(not #f)" +"(for-loop_284 fold-var_302 rest_202)" +" fold-var_302)))" +" fold-var_301)))))" +" for-loop_284)" +" null" +" lst_345))))))" +"(let-values(((val-idss_3)" +"(reverse$1" +"(let-values(((lst_349)(if syntaxes?_0 id:val92_0 id:val116_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_349)))" +"((letrec-values(((for-loop_286)" +"(lambda(fold-var_308 lst_350)" +"(begin" +" 'for-loop" +"(if(pair? lst_350)" +"(let-values(((ids_20)" +"(unsafe-car lst_350))" +"((rest_204)" +"(unsafe-cdr lst_350)))" +"(let-values(((fold-var_309)" +"(let-values(((fold-var_310)" +" fold-var_308))" +"(let-values(((fold-var_311)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_351)" +" ids_20))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_351)))" +"((letrec-values(((for-loop_287)" +"(lambda(fold-var_312" +" lst_352)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_352)" +"(let-values(((id_114)" +"(unsafe-car" +" lst_352))" +"((rest_205)" +"(unsafe-cdr" +" lst_352)))" +"(let-values(((fold-var_313)" +"(let-values(((fold-var_314)" +" fold-var_312))" +"(let-values(((fold-var_315)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_114" +" sc_7))" +" fold-var_314))))" +"(values" +" fold-var_315)))))" +"(if(not" +" #f)" +"(for-loop_287" +" fold-var_313" +" rest_205)" +" fold-var_313)))" +" fold-var_312)))))" +" for-loop_287)" +" null" +" lst_351)))))" +" fold-var_310))))" +"(values" +" fold-var_311)))))" +"(if(not #f)" +"(for-loop_286" +" fold-var_309" +" rest_204)" +" fold-var_309)))" +" fold-var_308)))))" +" for-loop_286)" +" null" +" lst_349))))))" +"(let-values(((val-rhss_3)" +"(if rec?_1" +"(reverse$1" +"(let-values(((lst_353)" +"(if syntaxes?_0 val-rhs93_0 val-rhs117_0)))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_353)))" +"((letrec-values(((for-loop_288)" +"(lambda(fold-var_316 lst_354)" +"(begin" +" 'for-loop" +"(if(pair? lst_354)" +"(let-values(((rhs_20)" +"(unsafe-car lst_354))" +"((rest_206)" +"(unsafe-cdr lst_354)))" +"(let-values(((fold-var_317)" +"(let-values(((fold-var_318)" +" fold-var_316))" +"(let-values(((fold-var_319)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" rhs_20" +" sc_7))" +" fold-var_318))))" +"(values" +" fold-var_319)))))" +"(if(not #f)" +"(for-loop_288" +" fold-var_317" +" rest_206)" +" fold-var_317)))" +" fold-var_316)))))" +" for-loop_288)" +" null" +" lst_353))))" +"(if syntaxes?_0 val-rhs93_0 val-rhs117_0))))" +"(let-values((()" +"(begin" +"(let-values(((temp129_2)(list trans-idss_2 val-idss_3))" +"((phase130_0) phase_142)" +"((s131_0) s_89))" +"(check-no-duplicate-ids8.1" +" #f" +" #f" +" temp129_2" +" phase130_0" +" s131_0" +" #f" +" #f))" +"(values))))" +"(let-values(((counter_8)(root-expand-context-counter ctx_80)))" +"(let-values(((trans-keyss_0)" +"(reverse$1" +"(let-values(((lst_355) trans-idss_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_355)))" +"((letrec-values(((for-loop_289)" +"(lambda(fold-var_320 lst_356)" +"(begin" +" 'for-loop" +"(if(pair? lst_356)" +"(let-values(((ids_34)" +"(unsafe-car" +" lst_356))" +"((rest_207)" +"(unsafe-cdr" +" lst_356)))" +"(let-values(((fold-var_321)" +"(let-values(((fold-var_322)" +" fold-var_320))" +"(let-values(((fold-var_323)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_357)" +" ids_34))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_357)))" +"((letrec-values(((for-loop_290)" +"(lambda(fold-var_324" +" lst_358)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_358)" +"(let-values(((id_115)" +"(unsafe-car" +" lst_358))" +"((rest_208)" +"(unsafe-cdr" +" lst_358)))" +"(let-values(((fold-var_325)" +"(let-values(((fold-var_98)" +" fold-var_324))" +"(let-values(((fold-var_99)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((frame-id144_0)" +" frame-id_15)" +"((s145_1)" +" s_89))" +"(add-local-binding!35.1" +" frame-id144_0" +" #t" +" s145_1" +" #t" +" id_115" +" phase_142" +" counter_8)))" +" fold-var_98))))" +"(values" +" fold-var_99)))))" +"(if(not" +" #f)" +"(for-loop_290" +" fold-var_325" +" rest_208)" +" fold-var_325)))" +" fold-var_324)))))" +" for-loop_290)" +" null" +" lst_357)))))" +" fold-var_322))))" +"(values" +" fold-var_323)))))" +"(if(not #f)" +"(for-loop_289" +" fold-var_321" +" rest_207)" +" fold-var_321)))" +" fold-var_320)))))" +" for-loop_289)" +" null" +" lst_355))))))" +"(let-values(((val-keyss_2)" +"(reverse$1" +"(let-values(((lst_359) val-idss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_359)))" +"((letrec-values(((for-loop_291)" +"(lambda(fold-var_326 lst_360)" +"(begin" +" 'for-loop" +"(if(pair? lst_360)" +"(let-values(((ids_35)" +"(unsafe-car" +" lst_360))" +"((rest_209)" +"(unsafe-cdr" +" lst_360)))" +"(let-values(((fold-var_327)" +"(let-values(((fold-var_328)" +" fold-var_326))" +"(let-values(((fold-var_329)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_361)" +" ids_35))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_361)))" +"((letrec-values(((for-loop_292)" +"(lambda(fold-var_330" +" lst_362)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_362)" +"(let-values(((id_116)" +"(unsafe-car" +" lst_362))" +"((rest_210)" +"(unsafe-cdr" +" lst_362)))" +"(let-values(((fold-var_331)" +"(let-values(((fold-var_332)" +" fold-var_330))" +"(let-values(((fold-var_333)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((frame-id149_0)" +" frame-id_15)" +"((s150_1)" +" s_89))" +"(add-local-binding!35.1" +" frame-id149_0" +" #t" +" s150_1" +" #t" +" id_116" +" phase_142" +" counter_8)))" +" fold-var_332))))" +"(values" +" fold-var_333)))))" +"(if(not" +" #f)" +"(for-loop_292" +" fold-var_331" +" rest_210)" +" fold-var_331)))" +" fold-var_330)))))" +" for-loop_292)" +" null" +" lst_361)))))" +" fold-var_328))))" +"(values" +" fold-var_329)))))" +"(if(not #f)" +"(for-loop_291" +" fold-var_327" +" rest_209)" +" fold-var_327)))" +" fold-var_326)))))" +" for-loop_291)" +" null" +" lst_359))))))" +"(let-values(((bodys_10)" +"(reverse$1" +"(let-values(((lst_363)" +"(if syntaxes?_0 body94_0 body118_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_363)))" +"((letrec-values(((for-loop_293)" +"(lambda(fold-var_334 lst_364)" +"(begin" +" 'for-loop" +"(if(pair? lst_364)" +"(let-values(((body_20)" +"(unsafe-car" +" lst_364))" +"((rest_211)" +"(unsafe-cdr" +" lst_364)))" +"(let-values(((fold-var_335)" +"(let-values(((fold-var_336)" +" fold-var_334))" +"(let-values(((fold-var_337)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" body_20" +" sc_7))" +" fold-var_336))))" +"(values" +" fold-var_337)))))" +"(if(not #f)" +"(for-loop_293" +" fold-var_335" +" rest_211)" +" fold-var_335)))" +" fold-var_334)))))" +" for-loop_293)" +" null" +" lst_363))))))" +"(let-values((()" +"(begin" +"(let-values(((obs_84)" +"(expand-context-observer ctx_80)))" +"(if obs_84" +"(let-values()" +"(log-let-renames" +" obs_84" +" renames-log-tag_0" +" val-idss_3" +" val-rhss_3" +" bodys_10" +" trans-idss_2" +"(if syntaxes?_0 trans-rhs91_0 #f)" +" sc_7))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if syntaxes?_0" +"(let-values()" +"(begin" +"(let-values(((obs_85)" +"(expand-context-observer" +" ctx_80)))" +"(if obs_85" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_85" +" 'prepare-env)))" +"(void)))" +"(prepare-next-phase-namespace ctx_80)))" +"(void))" +"(values))))" +"(let-values(((trans-valss_0)" +"(reverse$1" +"(let-values(((lst_365)" +"(if syntaxes?_0 trans-rhs91_0 '()))" +"((lst_366) trans-idss_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_365)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_366)))" +"((letrec-values(((for-loop_294)" +"(lambda(fold-var_338" +" lst_231" +" lst_367)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_231)" +"(pair? lst_367)" +" #f)" +"(let-values(((rhs_19)" +"(unsafe-car" +" lst_231))" +"((rest_212)" +"(unsafe-cdr" +" lst_231))" +"((ids_36)" +"(unsafe-car" +" lst_367))" +"((rest_213)" +"(unsafe-cdr" +" lst_367)))" +"(let-values(((fold-var_339)" +"(let-values(((fold-var_340)" +" fold-var_338))" +"(let-values(((fold-var_341)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_86)" +"(expand-context-observer" +" ctx_80)))" +"(if obs_86" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_86" +" 'next)" +"(call-expand-observe" +" obs_86" +" 'enter-bind))))" +"(void)))" +"(values))))" +"(let-values(((trans-val_1)" +"(eval-for-syntaxes-binding" +"(add-scope" +" rhs_19" +" sc_7)" +" ids_36" +" ctx_80)))" +"(begin" +"(let-values(((obs_79)" +"(expand-context-observer" +" ctx_80)))" +"(if obs_79" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_79" +" 'exit-bind)))" +"(void)))" +" trans-val_1))))" +" fold-var_340))))" +"(values" +" fold-var_341)))))" +"(if(not #f)" +"(for-loop_294" +" fold-var_339" +" rest_212" +" rest_213)" +" fold-var_339)))" +" fold-var_338)))))" +" for-loop_294)" +" null" +" lst_365" +" lst_366))))))" +"(let-values(((rec-val-env_0)" +"(let-values(((lst_368) val-keyss_2)" +"((lst_120) val-idss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_368)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_120)))" +"((letrec-values(((for-loop_295)" +"(lambda(env_29" +" lst_234" +" lst_235)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_234)" +"(pair? lst_235)" +" #f)" +"(let-values(((keys_10)" +"(unsafe-car" +" lst_234))" +"((rest_156)" +"(unsafe-cdr" +" lst_234))" +"((ids_37)" +"(unsafe-car" +" lst_235))" +"((rest_214)" +"(unsafe-cdr" +" lst_235)))" +"(let-values(((env_6)" +"(let-values(((env_30)" +" env_29))" +"(let-values(((lst_328)" +" keys_10)" +"((lst_329)" +" ids_37))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_328)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_329)))" +"((letrec-values(((for-loop_296)" +"(lambda(env_31" +" lst_369" +" lst_238)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_369)" +"(pair?" +" lst_238)" +" #f)" +"(let-values(((key_93)" +"(unsafe-car" +" lst_369))" +"((rest_215)" +"(unsafe-cdr" +" lst_369))" +"((id_117)" +"(unsafe-car" +" lst_238))" +"((rest_188)" +"(unsafe-cdr" +" lst_238)))" +"(let-values(((env_32)" +"(let-values(((env_33)" +" env_31))" +"(let-values(((env_34)" +"(let-values()" +"(env-extend" +" env_33" +" key_93" +"(local-variable1.1" +" id_117)))))" +"(values" +" env_34)))))" +"(if(not" +" #f)" +"(for-loop_296" +" env_32" +" rest_215" +" rest_188)" +" env_32)))" +" env_31)))))" +" for-loop_296)" +" env_30" +" lst_328" +" lst_329))))))" +"(if(not #f)" +"(for-loop_295" +" env_6" +" rest_156" +" rest_214)" +" env_6)))" +" env_29)))))" +" for-loop_295)" +"(expand-context-env ctx_80)" +" lst_368" +" lst_120)))))" +"(let-values(((rec-env_0)" +"(let-values(((lst_370) trans-keyss_0)" +"((lst_371) trans-valss_0)" +"((lst_372) trans-idss_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_370)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_371)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_372)))" +"((letrec-values(((for-loop_297)" +"(lambda(env_35" +" lst_241" +" lst_373" +" lst_374)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_241)" +"(if(pair?" +" lst_373)" +"(pair?" +" lst_374)" +" #f)" +" #f)" +"(let-values(((keys_11)" +"(unsafe-car" +" lst_241))" +"((rest_216)" +"(unsafe-cdr" +" lst_241))" +"((vals_9)" +"(unsafe-car" +" lst_373))" +"((rest_217)" +"(unsafe-cdr" +" lst_373))" +"((ids_38)" +"(unsafe-car" +" lst_374))" +"((rest_218)" +"(unsafe-cdr" +" lst_374)))" +"(let-values(((env_36)" +"(let-values(((env_37)" +" env_35))" +"(let-values(((env_38)" +"(let-values()" +"(let-values(((lst_121)" +" keys_11)" +"((lst_375)" +" vals_9)" +"((lst_376)" +" ids_38))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_121)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_375)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_376)))" +"((letrec-values(((for-loop_298)" +"(lambda(env_39" +" lst_377" +" lst_378" +" lst_379)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_377)" +"(if(pair?" +" lst_378)" +"(pair?" +" lst_379)" +" #f)" +" #f)" +"(let-values(((key_94)" +"(unsafe-car" +" lst_377))" +"((rest_219)" +"(unsafe-cdr" +" lst_377))" +"((val_84)" +"(unsafe-car" +" lst_378))" +"((rest_220)" +"(unsafe-cdr" +" lst_378))" +"((id_118)" +"(unsafe-car" +" lst_379))" +"((rest_221)" +"(unsafe-cdr" +" lst_379)))" +"(let-values(((env_40)" +"(let-values(((env_41)" +" env_39))" +"(let-values(((env_42)" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_84" +" id_118" +" phase_142" +" ctx_80)" +"(env-extend" +" env_41" +" key_94" +" val_84)))))" +"(values" +" env_42)))))" +"(if(not" +" #f)" +"(for-loop_298" +" env_40" +" rest_219" +" rest_220" +" rest_221)" +" env_40)))" +" env_39)))))" +" for-loop_298)" +" env_37" +" lst_121" +" lst_375" +" lst_376))))))" +"(values" +" env_38)))))" +"(if(not #f)" +"(for-loop_297" +" env_36" +" rest_216" +" rest_217" +" rest_218)" +" env_36)))" +" env_35)))))" +" for-loop_297)" +" rec-val-env_0" +" lst_370" +" lst_371" +" lst_372)))))" +"(let-values(((expr-ctx_0)(as-expression-context ctx_80)))" +"(let-values(((orig-rrs_0)" +"(expand-context-reference-records" +" expr-ctx_0)))" +"(let-values(((rec-ctx_0)" +"(let-values(((v_252) expr-ctx_0))" +"(let-values(((the-struct_96) v_252))" +"(if(expand-context/outer?" +" the-struct_96)" +"(let-values(((env151_1) rec-env_0)" +"((scopes152_0)" +"(cons" +" sc_7" +"(expand-context-scopes" +" ctx_80)))" +"((reference-records153_0)" +"(if split-by-reference?_0" +"(cons" +" frame-id_15" +" orig-rrs_0)" +" orig-rrs_0))" +"((binding-layer154_0)" +"(increment-binding-layer" +"(cons" +" trans-idss_2" +" val-idss_3)" +" ctx_80" +" sc_7))" +"((inner155_1)" +"(root-expand-context/outer-inner" +" v_252)))" +"(expand-context/outer1.1" +" inner155_1" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_96)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_96)" +"(root-expand-context/outer-frame-id" +" the-struct_96)" +"(expand-context/outer-context" +" the-struct_96)" +" env151_1" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_96)" +" scopes152_0" +"(expand-context/outer-def-ctx-scopes" +" the-struct_96)" +" binding-layer154_0" +" reference-records153_0" +"(expand-context/outer-only-immediate?" +" the-struct_96)" +"(expand-context/outer-need-eventually-defined" +" the-struct_96)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_96)" +"(expand-context/outer-name" +" the-struct_96)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_96))))))" +"(let-values(((letrec-values-id_0)" +"(if(not" +"(expand-context-to-parsed? ctx_80))" +"(if syntaxes?_0" +"(core-id 'letrec-values phase_142)" +" let-values115_0)" +" #f)))" +"(let-values(((rebuild-s_6)" +"(let-values(((temp158_2) #t))" +"(keep-as-needed74.1" +" #f" +" #f" +" temp158_2" +" #t" +" #f" +" #f" +" ctx_80" +" s_89))))" +"(let-values(((val-name-idss_0)" +"(if(expand-context-to-parsed?" +" ctx_80)" +"(reverse$1" +"(let-values(((lst_380)" +" val-idss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_380)))" +"((letrec-values(((for-loop_299)" +"(lambda(fold-var_106" +" lst_381)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_381)" +"(let-values(((val-ids_1)" +"(unsafe-car" +" lst_381))" +"((rest_222)" +"(unsafe-cdr" +" lst_381)))" +"(let-values(((fold-var_342)" +"(let-values(((fold-var_343)" +" fold-var_106))" +"(let-values(((fold-var_344)" +"(let-values()" +"(cons" +"(let-values()" +"(reverse$1" +"(let-values(((lst_382)" +" val-ids_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_382)))" +"((letrec-values(((for-loop_300)" +"(lambda(fold-var_345" +" lst_383)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_383)" +"(let-values(((val-id_0)" +"(unsafe-car" +" lst_383))" +"((rest_223)" +"(unsafe-cdr" +" lst_383)))" +"(let-values(((fold-var_109)" +"(let-values(((fold-var_346)" +" fold-var_345))" +"(let-values(((fold-var_347)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(syntax-e$1" +" val-id_0)" +" val-id_0" +" val-id_0))" +" fold-var_346))))" +"(values" +" fold-var_347)))))" +"(if(not" +" #f)" +"(for-loop_300" +" fold-var_109" +" rest_223)" +" fold-var_109)))" +" fold-var_345)))))" +" for-loop_300)" +" null" +" lst_382)))))" +" fold-var_343))))" +"(values" +" fold-var_344)))))" +"(if(not" +" #f)" +"(for-loop_299" +" fold-var_342" +" rest_222)" +" fold-var_342)))" +" fold-var_106)))))" +" for-loop_299)" +" null" +" lst_380))))" +" val-idss_3)))" +"(let-values((()" +"(begin" +"(if syntaxes?_0" +"(let-values()" +"(let-values(((obs_87)" +"(expand-context-observer" +" ctx_80)))" +"(if obs_87" +"(let-values()" +"(log-letrec-values" +" obs_87" +" val-idss_3" +" val-rhss_3" +" bodys_10))" +"(void))))" +"(void))" +"(values))))" +"(let-values(((get-body_1)" +"(lambda()" +"(begin" +" 'get-body" +"(let-values((()" +"(begin" +"(let-values(((obs_88)" +"(expand-context-observer" +" ctx_80)))" +"(if obs_88" +"(let-values()" +"(if(not" +"(if syntaxes?_0" +"(null?" +" val-idss_3)" +" #f))" +"(let-values()" +"(call-expand-observe" +" obs_88" +" 'next-group))" +"(void)))" +"(void)))" +"(values))))" +"(let-values(((body-ctx_5)" +"(let-values(((v_253)" +" rec-ctx_0))" +"(let-values(((the-struct_97)" +" v_253))" +"(if(expand-context/outer?" +" the-struct_97)" +"(let-values(((reference-records162_0)" +" orig-rrs_0)" +"((inner163_0)" +"(root-expand-context/outer-inner" +" v_253)))" +"(expand-context/outer1.1" +" inner163_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_97)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_97)" +"(root-expand-context/outer-frame-id" +" the-struct_97)" +"(expand-context/outer-context" +" the-struct_97)" +"(expand-context/outer-env" +" the-struct_97)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_97)" +"(expand-context/outer-scopes" +" the-struct_97)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_97)" +"(expand-context/outer-binding-layer" +" the-struct_97)" +" reference-records162_0" +"(expand-context/outer-only-immediate?" +" the-struct_97)" +"(expand-context/outer-need-eventually-defined" +" the-struct_97)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_97)" +"(expand-context/outer-name" +" the-struct_97)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_97))))))" +"(let-values(((temp160_2)" +"(let-values(((ctx165_0)" +" ctx_80))" +"(as-tail-context23.1" +" ctx165_0" +" body-ctx_5)))" +"((rebuild-s161_0)" +" rebuild-s_6))" +"(expand-body7.1" +" rebuild-s161_0" +" #f" +" #f" +" bodys_10" +" temp160_2))))))))" +"(let-values(((result-s_12)" +"(if(not" +" split-by-reference?_0)" +"(let-values()" +"(let-values(((clauses_2)" +"(reverse$1" +"(let-values(((lst_384)" +" val-name-idss_0)" +"((lst_385)" +" val-keyss_2)" +"((lst_386)" +" val-rhss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_384)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_385)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_386)))" +"((letrec-values(((for-loop_158)" +"(lambda(fold-var_116" +" lst_387" +" lst_388" +" lst_389)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_387)" +"(if(pair?" +" lst_388)" +"(pair?" +" lst_389)" +" #f)" +" #f)" +"(let-values(((ids_39)" +"(unsafe-car" +" lst_387))" +"((rest_224)" +"(unsafe-cdr" +" lst_387))" +"((keys_12)" +"(unsafe-car" +" lst_388))" +"((rest_225)" +"(unsafe-cdr" +" lst_388))" +"((rhs_21)" +"(unsafe-car" +" lst_389))" +"((rest_226)" +"(unsafe-cdr" +" lst_389)))" +"(let-values(((fold-var_348)" +"(let-values(((fold-var_119)" +" fold-var_116))" +"(let-values(((fold-var_120)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_89)" +"(expand-context-observer" +" ctx_80)))" +"(if obs_89" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_89" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-rhs_4)" +"(let-values(((rhs166_0)" +" rhs_21)" +"((temp167_1)" +"(if rec?_1" +"(as-named-context" +" rec-ctx_0" +" ids_39)" +"(as-named-context" +" expr-ctx_0" +" ids_39))))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" rhs166_0" +" temp167_1))))" +"(if(expand-context-to-parsed?" +" ctx_80)" +"(list" +" keys_12" +" exp-rhs_4)" +"(list" +" ids_39" +" exp-rhs_4)))))" +" fold-var_119))))" +"(values" +" fold-var_120)))))" +"(if(not" +" #f)" +"(for-loop_158" +" fold-var_348" +" rest_224" +" rest_225" +" rest_226)" +" fold-var_348)))" +" fold-var_116)))))" +" for-loop_158)" +" null" +" lst_384" +" lst_385" +" lst_386))))))" +"(let-values(((exp-body_4)" +"(get-body_1)))" +"(begin" +"(if frame-id_15" +"(let-values()" +"(reference-record-clear!" +" frame-id_15))" +"(void))" +"(if(expand-context-to-parsed?" +" ctx_80)" +"(if rec?_1" +"(parsed-letrec-values18.1" +" rebuild-s_6" +" val-name-idss_0" +" clauses_2" +" exp-body_4)" +"(parsed-let-values17.1" +" rebuild-s_6" +" val-name-idss_0" +" clauses_2" +" exp-body_4))" +"(let-values(((rebuild-s168_0)" +" rebuild-s_6)" +"((temp169_1)" +"(list*" +" letrec-values-id_0" +" clauses_2" +" exp-body_4)))" +"(rebuild5.1" +" #f" +" #f" +" rebuild-s168_0" +" temp169_1)))))))" +"(let-values()" +"(let-values(((temp173_0)" +"(reverse$1" +"(let-values(((lst_390)" +" val-idss_3))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_390)))" +"((letrec-values(((for-loop_301)" +"(lambda(fold-var_349" +" lst_391)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_391)" +"(let-values(((rhs_22)" +"(unsafe-car" +" lst_391))" +"((rest_227)" +"(unsafe-cdr" +" lst_391)))" +"(let-values(((fold-var_350)" +"(let-values(((fold-var_351)" +" fold-var_349))" +"(let-values(((fold-var_352)" +"(let-values()" +"(cons" +"(let-values()" +" #f)" +" fold-var_351))))" +"(values" +" fold-var_352)))))" +"(if(not" +" #f)" +"(for-loop_301" +" fold-var_350" +" rest_227)" +" fold-var_350)))" +" fold-var_349)))))" +" for-loop_301)" +" null" +" lst_390)))))" +"((temp174_0)" +" #t)" +"((frame-id175_0)" +" frame-id_15)" +"((rec-ctx176_0)" +" rec-ctx_0)" +"((rebuild-s177_0)" +" rebuild-s_6)" +"((syntaxes?178_0)" +" syntaxes?_0)" +"((get-body179_0)" +" get-body_1)" +"((temp180_1)" +" #t))" +"(expand-and-split-bindings-by-reference48.1" +" rec-ctx176_0" +" frame-id175_0" +" get-body179_0" +" syntaxes?178_0" +" rebuild-s177_0" +" temp174_0" +" temp180_1" +" val-idss_3" +" val-keyss_2" +" val-rhss_3" +" temp173_0))))))" +"(if(expand-context-to-parsed? ctx_80)" +" result-s_12" +"(attach-disappeared-transformer-bindings" +" result-s_12" +" trans-idss_2)))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(log-let-renames)" +"(lambda(obs_90 renames-log-tag_1 val-idss_4 val-rhss_4 bodys_11 trans-idss_3 trans-rhss_0 sc_33)" +"(begin" +"(let-values(((vals+body_0)" +"(cons" +"(reverse$1" +"(let-values(((lst_392) val-idss_4)((lst_59) val-rhss_4))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_392)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_59)))" +"((letrec-values(((for-loop_302)" +"(lambda(fold-var_353 lst_393 lst_394)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_393)(pair? lst_394) #f)" +"(let-values(((val-ids_2)(unsafe-car lst_393))" +"((rest_228)(unsafe-cdr lst_393))" +"((val-rhs_11)(unsafe-car lst_394))" +"((rest_229)(unsafe-cdr lst_394)))" +"(let-values(((fold-var_354)" +"(let-values(((fold-var_355) fold-var_353))" +"(let-values(((fold-var_356)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list val-ids_2 val-rhs_11)))" +" fold-var_355))))" +"(values fold-var_356)))))" +"(if(not #f)" +"(for-loop_302 fold-var_354 rest_228 rest_229)" +" fold-var_354)))" +" fold-var_353)))))" +" for-loop_302)" +" null" +" lst_392" +" lst_59))))" +"(datum->syntax$1 #f bodys_11))))" +"(call-expand-observe" +" obs_90" +" renames-log-tag_1" +"(if(not trans-rhss_0)" +" vals+body_0" +"(cons" +"(reverse$1" +"(let-values(((lst_62) trans-idss_3)((lst_395) trans-rhss_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_62)))" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_395)))" +"((letrec-values(((for-loop_303)" +"(lambda(fold-var_357 lst_396 lst_397)" +"(begin" +" 'for-loop" +"(if(if(pair? lst_396)(pair? lst_397) #f)" +"(let-values(((trans-ids_0)(unsafe-car lst_396))" +"((rest_230)(unsafe-cdr lst_396))" +"((trans-rhs_5)(unsafe-car lst_397))" +"((rest_231)(unsafe-cdr lst_397)))" +"(let-values(((fold-var_122)" +"(let-values(((fold-var_358) fold-var_357))" +"(let-values(((fold-var_359)" +"(let-values()" +"(cons" +"(let-values()" +"(datum->syntax$1" +" #f" +"(list" +" trans-ids_0" +"(add-scope trans-rhs_5 sc_33))))" +" fold-var_358))))" +"(values fold-var_359)))))" +"(if(not #f)(for-loop_303 fold-var_122 rest_230 rest_231) fold-var_122)))" +" fold-var_357)))))" +" for-loop_303)" +" null" +" lst_62" +" lst_395))))" +" vals+body_0)))))))" +"(define-values" +"(log-letrec-values)" +"(lambda(obs_91 val-idss_5 val-rhss_5 bodys_12)" +"(begin" +"(begin" +"(call-expand-observe obs_91 'next-group)" +"(if(null? val-idss_5)" +"(void)" +"(let-values()" +"(begin" +"(call-expand-observe obs_91 'prim-letrec-values)" +"(log-let-renames obs_91 'let-renames val-idss_5 val-rhss_5 bodys_12 #f #f #f))))))))" +"(void" +"(add-core-form!*" +" 'let-values" +"(let-values(((temp181_0) 'prim-let-values))(make-let-values-form11.1 temp181_0 #f #f #f #f #f #f #f #f))))" +"(void" +"(add-core-form!*" +" 'letrec-values" +"(let-values(((temp182_1) #t)((temp183_0) 'prim-letrec-values))" +"(make-let-values-form11.1 temp183_0 temp182_1 #t #f #f #f #f #f #f))))" +"(void" +"(add-core-form!*" +" 'letrec-syntaxes+values" +"(let-values(((temp184_1) #t)" +"((temp185_0) #t)" +"((temp186_0) #t)" +"((temp187_2) 'prim-letrec-syntaxes+values)" +"((temp188_1) 'letrec-syntaxes-renames))" +"(make-let-values-form11.1 temp187_2 temp185_0 #t temp188_1 #t temp186_0 #t temp184_1 #t))))" +"(void" +"(add-core-form!*" +" '#%stratified-body" +"(lambda(s_523 ctx_81)" +"(let-values((()" +"(begin" +"(let-values(((obs_92)(expand-context-observer ctx_81)))" +"(if obs_92" +"(let-values()(let-values()(call-expand-observe obs_92 'prim-#%stratified)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_9)(syntax-disarm$1 s_523)))" +"(let-values(((ok?_39 #%stratified-body189_0 body190_0)" +"(let-values(((s_524) disarmed-s_9))" +"(let-values(((orig-s_47) s_524))" +"(let-values(((#%stratified-body189_1 body190_1)" +"(let-values(((s_525)(if(syntax?$1 s_524)(syntax-e$1 s_524) s_524)))" +"(if(pair? s_525)" +"(let-values(((#%stratified-body191_0)" +"(let-values(((s_526)(car s_525))) s_526))" +"((body192_0)" +"(let-values(((s_527)(cdr s_525)))" +"(let-values(((s_528)" +"(if(syntax?$1 s_527)" +"(syntax-e$1 s_527)" +" s_527)))" +"(let-values(((flat-s_39)(to-syntax-list.1 s_528)))" +"(if(not flat-s_39)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_47))" +"(if(null? flat-s_39)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_47))" +"(let-values() flat-s_39))))))))" +"(values #%stratified-body191_0 body192_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_47)))))" +"(values #t #%stratified-body189_1 body190_1))))))" +"(let-values(((rebuild-s_7)" +"(let-values(((temp195_0) #t))(keep-as-needed74.1 #f #f temp195_0 #t #f #f ctx_81 s_523))))" +"(let-values(((exp-body_5)" +"(let-values(((temp196_0) body190_0)" +"((ctx197_0) ctx_81)" +"((temp198_1) #t)" +"((rebuild-s199_0) rebuild-s_7))" +"(expand-body7.1 rebuild-s199_0 temp198_1 #t temp196_0 ctx197_0))))" +"(if(expand-context-to-parsed? ctx_81)" +"(parsed-begin12.1 rebuild-s_7 exp-body_5)" +"(let-values(((rebuild-s200_0) rebuild-s_7)" +"((temp201_1)" +"(if(null?(cdr exp-body_5))" +"(car exp-body_5)" +"(list*(core-id 'begin(expand-context-phase ctx_81)) exp-body_5))))" +"(rebuild5.1 #f #f rebuild-s200_0 temp201_1)))))))))))" +"(void" +"(add-core-form!*" +" '#%datum" +"(lambda(s_529 ctx_82)" +"(let-values((()" +"(begin" +"(let-values(((obs_93)(expand-context-observer ctx_82)))" +"(if obs_93(let-values()(let-values()(call-expand-observe obs_93 'prim-#%datum)))(void)))" +"(values))))" +"(let-values(((disarmed-s_10)(syntax-disarm$1 s_529)))" +"(let-values(((ok?_40 #%datum202_0 datum203_0)" +"(let-values(((s_193) disarmed-s_10))" +"(let-values(((orig-s_48) s_193))" +"(let-values(((#%datum202_1 datum203_1)" +"(let-values(((s_530)(if(syntax?$1 s_193)(syntax-e$1 s_193) s_193)))" +"(if(pair? s_530)" +"(let-values(((#%datum204_0)(let-values(((s_531)(car s_530))) s_531))" +"((datum205_0)(let-values(((s_532)(cdr s_530))) s_532)))" +"(values #%datum204_0 datum205_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_48)))))" +"(values #t #%datum202_1 datum203_1))))))" +"(let-values(((datum_2) datum203_0))" +"(let-values((()" +"(begin" +"(if(if(syntax?$1 datum_2)(keyword?(syntax-e$1 datum_2)) #f)" +"(let-values()" +" (raise-syntax-error$1 '#%datum \"keyword misused as an expression\" #f datum_2))" +"(void))" +"(values))))" +"(let-values(((phase_143)(expand-context-phase ctx_82)))" +"(if(if(expand-context-to-parsed? ctx_82)(free-id-set-empty?(expand-context-stops ctx_82)) #f)" +"(parsed-quote14.1(keep-properties-only~ s_529)(syntax->datum$1 datum_2))" +"(let-values(((s206_0) s_529)((temp207_0)(list(core-id 'quote phase_143) datum_2)))" +"(rebuild5.1 #f #f s206_0 temp207_0))))))))))))" +"(void" +"(add-core-form!*" +" '#%app" +"(lambda(s_533 ctx_83)" +"(let-values((()" +"(begin" +"(let-values(((obs_94)(expand-context-observer ctx_83)))" +"(if obs_94(let-values()(let-values()(call-expand-observe obs_94 'prim-#%app)))(void)))" +"(values))))" +"(let-values(((disarmed-s_11)(syntax-disarm$1 s_533)))" +"(let-values(((ok?_41 #%app208_0 e209_0)" +"(let-values(((s_534) disarmed-s_11))" +"(let-values(((orig-s_49) s_534))" +"(let-values(((#%app208_1 e209_1)" +"(let-values(((s_535)(if(syntax?$1 s_534)(syntax-e$1 s_534) s_534)))" +"(if(pair? s_535)" +"(let-values(((#%app210_0)(let-values(((s_536)(car s_535))) s_536))" +"((e211_0)" +"(let-values(((s_537)(cdr s_535)))" +"(let-values(((s_538)" +"(if(syntax?$1 s_537)" +"(syntax-e$1 s_537)" +" s_537)))" +"(let-values(((flat-s_40)(to-syntax-list.1 s_538)))" +"(if(not flat-s_40)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_49))" +"(let-values() flat-s_40)))))))" +"(values #%app210_0 e211_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_49)))))" +"(values #t #%app208_1 e209_1))))))" +"(let-values(((es_3) e209_0))" +"(if(null? es_3)" +"(let-values()" +"(let-values(((phase_144)(expand-context-phase ctx_83)))" +"(if(expand-context-to-parsed? ctx_83)" +"(parsed-quote14.1(keep-properties-only~ s_533) null)" +"(let-values(((s212_0) s_533)((temp213_1)(list(core-id 'quote phase_144) null)))" +"(rebuild5.1 #f #f s212_0 temp213_1)))))" +"(let-values()" +"(let-values(((keep-for-parsed?_1)(eq?(system-type 'vm) 'chez-scheme)))" +"(let-values(((rebuild-s_8)" +"(let-values(((keep-for-parsed?216_0) keep-for-parsed?_1))" +"(keep-as-needed74.1 #f #f #f #f keep-for-parsed?216_0 #t ctx_83 s_533))))" +"(let-values(((prefixless_0)(cdr(syntax-e$1 disarmed-s_11))))" +"(let-values(((rebuild-prefixless_0)" +"(if(syntax?$1 prefixless_0)" +"(let-values(((keep-for-parsed?219_0) keep-for-parsed?_1))" +"(keep-as-needed74.1 #f #f #f #f keep-for-parsed?219_0 #t ctx_83 prefixless_0))" +" #f)))" +"(let-values(((expr-ctx_1)(as-expression-context ctx_83)))" +"(let-values((()" +"(begin" +"(let-values(((obs_95)(expand-context-observer expr-ctx_1)))" +"(if obs_95" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_95" +" 'enter-list" +"(datum->syntax$1 #f es_3 s_533))" +"(call-expand-observe obs_95 'next))))" +"(void)))" +"(values))))" +"(let-values(((rest-es_0)(cdr es_3)))" +"(let-values(((exp-rator_0)" +"(let-values(((temp220_1)(car es_3))((expr-ctx221_0) expr-ctx_1))" +"(expand7.1 #f #f #f #f temp220_1 expr-ctx221_0))))" +"(let-values(((exp-es_0)" +"(reverse$1" +"(let-values(((lst_398) rest-es_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_398)))" +"((letrec-values(((for-loop_304)" +"(lambda(fold-var_56 lst_399)" +"(begin" +" 'for-loop" +"(if(pair? lst_399)" +"(let-values(((e_85)(unsafe-car lst_399))" +"((rest_232)" +"(unsafe-cdr lst_399)))" +"(let-values(((fold-var_360)" +"(let-values(((fold-var_361)" +" fold-var_56))" +"(let-values(((fold-var_362)" +"(let-values()" +"(cons" +"(let-values()" +"(begin" +"(let-values(((obs_96)" +"(expand-context-observer" +" expr-ctx_1)))" +"(if obs_96" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_96" +" 'next)))" +"(void)))" +"(let-values(((e222_0)" +" e_85)" +"((expr-ctx223_0)" +" expr-ctx_1))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" e222_0" +" expr-ctx223_0))))" +" fold-var_361))))" +"(values" +" fold-var_362)))))" +"(if(not #f)" +"(for-loop_304 fold-var_360 rest_232)" +" fold-var_360)))" +" fold-var_56)))))" +" for-loop_304)" +" null" +" lst_398))))))" +"(if(expand-context-to-parsed? ctx_83)" +"(let-values()" +"(parsed-app7.1" +"(let-values(((or-part_372) rebuild-prefixless_0))" +"(if or-part_372 or-part_372 rebuild-s_8))" +" exp-rator_0" +" exp-es_0))" +"(let-values()" +"(let-values(((es_4)" +"(let-values(((exp-es_1)(cons exp-rator_0 exp-es_0)))" +"(if rebuild-prefixless_0" +"(let-values(((rebuild-prefixless226_0) rebuild-prefixless_0)" +"((exp-es227_0) exp-es_1))" +"(rebuild5.1 #f #f rebuild-prefixless226_0 exp-es227_0))" +" exp-es_1))))" +"(begin" +"(let-values(((obs_97)(expand-context-observer expr-ctx_1)))" +"(if obs_97" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_97" +" 'exit-list" +"(datum->syntax$1 #f es_4 rebuild-s_8))))" +"(void)))" +"(let-values(((rebuild-s224_0) rebuild-s_8)" +"((temp225_2)(cons #%app208_0 es_4)))" +"(rebuild5.1 #f #f rebuild-s224_0 temp225_2))))))))))))))))))))))))" +"(void" +"(add-core-form!*" +" 'quote" +"(lambda(s_539 ctx_84)" +"(let-values((()" +"(begin" +"(let-values(((obs_98)(expand-context-observer ctx_84)))" +"(if obs_98(let-values()(let-values()(call-expand-observe obs_98 'prim-quote)))(void)))" +"(values))))" +"(let-values(((ok?_42 quote228_0 datum229_0)" +"(let-values(((s_540)(syntax-disarm$1 s_539)))" +"(let-values(((orig-s_50) s_540))" +"(let-values(((quote228_1 datum229_1)" +"(let-values(((s_541)(if(syntax?$1 s_540)(syntax-e$1 s_540) s_540)))" +"(if(pair? s_541)" +"(let-values(((quote230_0)(let-values(((s_542)(car s_541))) s_542))" +"((datum231_0)" +"(let-values(((s_543)(cdr s_541)))" +"(let-values(((s_544)" +"(if(syntax?$1 s_543)" +"(syntax-e$1 s_543)" +" s_543)))" +"(if(pair? s_544)" +"(let-values(((datum232_0)" +"(let-values(((s_545)(car s_544))) s_545))" +"(()" +"(let-values(((s_546)(cdr s_544)))" +"(let-values(((s_547)" +"(if(syntax?$1 s_546)" +"(syntax-e$1 s_546)" +" s_546)))" +"(if(null? s_547)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_50))))))" +"(values datum232_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_50))))))" +"(values quote230_0 datum231_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_50)))))" +"(values #t quote228_1 datum229_1))))))" +"(if(expand-context-to-parsed? ctx_84)" +"(parsed-quote14.1(keep-properties-only~ s_539)(syntax->datum$1 datum229_0))" +" s_539))))))" +"(void" +"(add-core-form!*" +" 'quote-syntax" +"(lambda(s_548 ctx_85)" +"(let-values((()" +"(begin" +"(let-values(((obs_99)(expand-context-observer ctx_85)))" +"(if obs_99" +"(let-values()(let-values()(call-expand-observe obs_99 'prim-quote-syntax)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_12)(syntax-disarm$1 s_548)))" +"(let-values(((ok?_43 quote-syntax233_0 datum234_0)" +"(let-values(((s_549) disarmed-s_12))" +"(if(let-values(((s_550)(if(syntax?$1 s_549)(syntax-e$1 s_549) s_549)))" +"(if(pair? s_550)" +"(if(let-values(((s_551)(car s_550))) #t)" +"(let-values(((s_552)(cdr s_550)))" +"(let-values(((s_553)(if(syntax?$1 s_552)(syntax-e$1 s_552) s_552)))" +"(if(pair? s_553)" +"(if(let-values(((s_554)(car s_553))) #t)" +"(let-values(((s_555)(cdr s_553)))" +"(let-values(((s_556)(if(syntax?$1 s_555)(syntax-e$1 s_555) s_555)))" +"(if(pair? s_556)" +"(if(let-values(((s_557)(car s_556)))" +"(let-values(((s_558)" +"(if(syntax?$1 s_557)(syntax-e$1 s_557) s_557)))" +"(eq? '#:local s_558)))" +"(let-values(((s_559)(cdr s_556)))" +"(let-values(((s_560)" +"(if(syntax?$1 s_559)(syntax-e$1 s_559) s_559)))" +"(null? s_560)))" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((quote-syntax233_1 datum234_1)" +"(let-values(((s_561)(if(syntax?$1 s_549)(syntax-e$1 s_549) s_549)))" +"(let-values(((quote-syntax235_0)" +"(let-values(((s_562)(car s_561))) s_562))" +"((datum236_0)" +"(let-values(((s_563)(cdr s_561)))" +"(let-values(((s_564)" +"(if(syntax?$1 s_563)" +"(syntax-e$1 s_563)" +" s_563)))" +"(let-values(((datum237_0)" +"(let-values(((s_565)(car s_564))) s_565))" +"(()" +"(let-values(((s_566)(cdr s_564)))" +"(let-values(((s_567)" +"(if(syntax?$1 s_566)" +"(syntax-e$1 s_566)" +" s_566)))" +"(let-values((()" +"(let-values(((s_568)" +"(car" +" s_567)))" +"(let-values(((s_569)" +"(if(syntax?$1" +" s_568)" +"(syntax-e$1" +" s_568)" +" s_568)))" +"(values))))" +"(()" +"(let-values(((s_570)" +"(cdr" +" s_567)))" +"(let-values(((s_571)" +"(if(syntax?$1" +" s_570)" +"(syntax-e$1" +" s_570)" +" s_570)))" +"(values)))))" +"(values))))))" +"(values datum237_0))))))" +"(values quote-syntax235_0 datum236_0)))))" +"(values #t quote-syntax233_1 datum234_1)))" +"(values #f #f #f)))))" +"(let-values(((ok?_44 quote-syntax238_0 datum239_0)" +"(let-values(((s_572) disarmed-s_12))" +"(if(if(not ok?_43) #t #f)" +"(let-values(((orig-s_51) s_572))" +"(let-values(((quote-syntax238_1 datum239_1)" +"(let-values(((s_573)(if(syntax?$1 s_572)(syntax-e$1 s_572) s_572)))" +"(if(pair? s_573)" +"(let-values(((quote-syntax240_0)" +"(let-values(((s_574)(car s_573))) s_574))" +"((datum241_0)" +"(let-values(((s_575)(cdr s_573)))" +"(let-values(((s_576)" +"(if(syntax?$1 s_575)" +"(syntax-e$1 s_575)" +" s_575)))" +"(if(pair? s_576)" +"(let-values(((datum242_0)" +"(let-values(((s_577)(car s_576)))" +" s_577))" +"(()" +"(let-values(((s_578)(cdr s_576)))" +"(let-values(((s_579)" +"(if(syntax?$1 s_578)" +"(syntax-e$1 s_578)" +" s_578)))" +"(if(null? s_579)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_51))))))" +"(values datum242_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_51))))))" +"(values quote-syntax240_0 datum241_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_51)))))" +"(values #t quote-syntax238_1 datum239_1)))" +"(values #f #f #f)))))" +"(if ok?_43" +"(let-values()" +"(let-values((()" +"(begin" +"(reference-records-all-used!(expand-context-reference-records ctx_85))" +"(values))))" +"(let-values(((ok?_45 _243_0 _244_0 kw245_0)" +"(let-values(((s_273) disarmed-s_12))" +"(let-values(((orig-s_52) s_273))" +"(let-values(((_243_1 _244_1 kw245_1)" +"(let-values(((s_275)" +"(if(syntax?$1 s_273)(syntax-e$1 s_273) s_273)))" +"(if(pair? s_275)" +"(let-values(((_246_0)" +"(let-values(((s_277)(car s_275))) s_277))" +"((_247_0 kw248_0)" +"(let-values(((s_278)(cdr s_275)))" +"(let-values(((s_279)" +"(if(syntax?$1 s_278)" +"(syntax-e$1 s_278)" +" s_278)))" +"(if(pair? s_279)" +"(let-values(((_249_0)" +"(let-values(((s_580)" +"(car s_279)))" +" s_580))" +"((kw250_0)" +"(let-values(((s_581)" +"(cdr s_279)))" +"(let-values(((s_582)" +"(if(syntax?$1" +" s_581)" +"(syntax-e$1" +" s_581)" +" s_581)))" +"(if(pair? s_582)" +"(let-values(((kw251_0)" +"(let-values(((s_583)" +"(car" +" s_582)))" +" s_583))" +"(()" +"(let-values(((s_584)" +"(cdr" +" s_582)))" +"(let-values(((s_585)" +"(if(syntax?$1" +" s_584)" +"(syntax-e$1" +" s_584)" +" s_584)))" +"(if(null?" +" s_585)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_52))))))" +"(values kw251_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_52))))))" +"(values _249_0 kw250_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_52))))))" +"(values _246_0 _247_0 kw248_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_52)))))" +"(values #t _243_1 _244_1 kw245_1))))))" +"(if(expand-context-to-parsed? ctx_85)" +"(parsed-quote-syntax15.1(keep-properties-only~ s_548) datum234_0)" +"(let-values(((s252_0) s_548)((temp253_1)(list quote-syntax233_0 datum234_0 kw245_0)))" +"(rebuild5.1 #f #f s252_0 temp253_1))))))" +"(let-values()" +"(let-values(((datum-s_0)(remove-scopes datum239_0(expand-context-scopes ctx_85))))" +"(if(if(expand-context-to-parsed? ctx_85)(free-id-set-empty?(expand-context-stops ctx_85)) #f)" +"(parsed-quote-syntax15.1(keep-properties-only~ s_548) datum-s_0)" +"(let-values(((s254_0) s_548)((temp255_0)(list quote-syntax238_0 datum-s_0)))" +"(rebuild5.1 #f #f s254_0 temp255_0)))))))))))))" +"(void" +"(add-core-form!*" +" 'if" +"(lambda(s_280 ctx_86)" +"(let-values((()" +"(begin" +"(let-values(((obs_100)(expand-context-observer ctx_86)))" +"(if obs_100(let-values()(let-values()(call-expand-observe obs_100 'prim-if)))(void)))" +"(values))))" +"(let-values(((disarmed-s_13)(syntax-disarm$1 s_280)))" +"(let-values(((ok?_46 if256_0 tst257_0 thn258_0 els259_0)" +"(let-values(((s_586) disarmed-s_13))" +"(let-values(((orig-s_53) s_586))" +"(let-values(((if256_1 tst257_1 thn258_1 els259_1)" +"(let-values(((s_587)(if(syntax?$1 s_586)(syntax-e$1 s_586) s_586)))" +"(if(pair? s_587)" +"(let-values(((if260_0)(let-values(((s_588)(car s_587))) s_588))" +"((tst261_0 thn262_0 els263_0)" +"(let-values(((s_589)(cdr s_587)))" +"(let-values(((s_590)" +"(if(syntax?$1 s_589)" +"(syntax-e$1 s_589)" +" s_589)))" +"(if(pair? s_590)" +"(let-values(((tst264_0)" +"(let-values(((s_591)(car s_590)))" +" s_591))" +"((thn265_0 els266_0)" +"(let-values(((s_592)(cdr s_590)))" +"(let-values(((s_290)" +"(if(syntax?$1 s_592)" +"(syntax-e$1 s_592)" +" s_592)))" +"(if(pair? s_290)" +"(let-values(((thn267_0)" +"(let-values(((s_593)" +"(car" +" s_290)))" +" s_593))" +"((els268_0)" +"(let-values(((s_291)" +"(cdr" +" s_290)))" +"(let-values(((s_594)" +"(if(syntax?$1" +" s_291)" +"(syntax-e$1" +" s_291)" +" s_291)))" +"(if(pair? s_594)" +"(let-values(((els269_0)" +"(let-values(((s_292)" +"(car" +" s_594)))" +" s_292))" +"(()" +"(let-values(((s_293)" +"(cdr" +" s_594)))" +"(let-values(((s_294)" +"(if(syntax?$1" +" s_293)" +"(syntax-e$1" +" s_293)" +" s_293)))" +"(if(null?" +" s_294)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_53))))))" +"(values" +" els269_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_53))))))" +"(values thn267_0 els268_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_53))))))" +"(values tst264_0 thn265_0 els266_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_53))))))" +"(values if260_0 tst261_0 thn262_0 els263_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_53)))))" +"(values #t if256_1 tst257_1 thn258_1 els259_1))))))" +"(let-values(((expr-ctx_2)(as-expression-context ctx_86)))" +"(let-values(((tail-ctx_0)(let-values(((ctx271_0) ctx_86))(as-tail-context23.1 ctx271_0 expr-ctx_2))))" +"(let-values(((rebuild-s_9)" +"(let-values(((ctx272_0) ctx_86)((s273_0) s_280))" +"(keep-as-needed74.1 #f #f #f #f #f #f ctx272_0 s273_0))))" +"(let-values(((exp-tst_0)" +"(let-values(((temp274_0) tst257_0)((expr-ctx275_0) expr-ctx_2))" +"(expand7.1 #f #f #f #f temp274_0 expr-ctx275_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_101)(expand-context-observer ctx_86)))" +"(if obs_101" +"(let-values()(let-values()(call-expand-observe obs_101 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-thn_0)" +"(let-values(((temp276_0) thn258_0)((tail-ctx277_0) tail-ctx_0))" +"(expand7.1 #f #f #f #f temp276_0 tail-ctx277_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_102)(expand-context-observer ctx_86)))" +"(if obs_102" +"(let-values()(let-values()(call-expand-observe obs_102 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-els_0)" +"(let-values(((temp278_1) els259_0)((tail-ctx279_0) tail-ctx_0))" +"(expand7.1 #f #f #f #f temp278_1 tail-ctx279_0))))" +"(if(expand-context-to-parsed? ctx_86)" +"(parsed-if8.1 rebuild-s_9 exp-tst_0 exp-thn_0 exp-els_0)" +"(let-values(((rebuild-s280_0) rebuild-s_9)" +"((temp281_0)(list if256_0 exp-tst_0 exp-thn_0 exp-els_0)))" +"(rebuild5.1 #f #f rebuild-s280_0 temp281_0)))))))))))))))))" +"(void" +"(add-core-form!*" +" 'with-continuation-mark" +"(lambda(s_595 ctx_87)" +"(let-values((()" +"(begin" +"(let-values(((obs_103)(expand-context-observer ctx_87)))" +"(if obs_103" +"(let-values()(let-values()(call-expand-observe obs_103 'prim-with-continuation-mark)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_14)(syntax-disarm$1 s_595)))" +"(let-values(((ok?_47 with-continuation-mark282_0 key283_0 val284_0 body285_0)" +"(let-values(((s_596) disarmed-s_14))" +"(let-values(((orig-s_54) s_596))" +"(let-values(((with-continuation-mark282_1 key283_1 val284_1 body285_1)" +"(let-values(((s_597)(if(syntax?$1 s_596)(syntax-e$1 s_596) s_596)))" +"(if(pair? s_597)" +"(let-values(((with-continuation-mark286_0)" +"(let-values(((s_598)(car s_597))) s_598))" +"((key287_0 val288_0 body289_0)" +"(let-values(((s_599)(cdr s_597)))" +"(let-values(((s_600)" +"(if(syntax?$1 s_599)" +"(syntax-e$1 s_599)" +" s_599)))" +"(if(pair? s_600)" +"(let-values(((key290_0)" +"(let-values(((s_601)(car s_600)))" +" s_601))" +"((val291_0 body292_0)" +"(let-values(((s_602)(cdr s_600)))" +"(let-values(((s_603)" +"(if(syntax?$1 s_602)" +"(syntax-e$1 s_602)" +" s_602)))" +"(if(pair? s_603)" +"(let-values(((val293_0)" +"(let-values(((s_604)" +"(car" +" s_603)))" +" s_604))" +"((body294_0)" +"(let-values(((s_605)" +"(cdr" +" s_603)))" +"(let-values(((s_606)" +"(if(syntax?$1" +" s_605)" +"(syntax-e$1" +" s_605)" +" s_605)))" +"(if(pair? s_606)" +"(let-values(((body295_0)" +"(let-values(((s_607)" +"(car" +" s_606)))" +" s_607))" +"(()" +"(let-values(((s_608)" +"(cdr" +" s_606)))" +"(let-values(((s_609)" +"(if(syntax?$1" +" s_608)" +"(syntax-e$1" +" s_608)" +" s_608)))" +"(if(null?" +" s_609)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_54))))))" +"(values" +" body295_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_54))))))" +"(values val293_0 body294_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_54))))))" +"(values key290_0 val291_0 body292_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_54))))))" +"(values with-continuation-mark286_0 key287_0 val288_0 body289_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_54)))))" +"(values #t with-continuation-mark282_1 key283_1 val284_1 body285_1))))))" +"(let-values(((expr-ctx_3)(as-expression-context ctx_87)))" +"(let-values(((rebuild-s_10)" +"(let-values(((ctx296_0) ctx_87)((s297_0) s_595))" +"(keep-as-needed74.1 #f #f #f #f #f #f ctx296_0 s297_0))))" +"(let-values(((exp-key_0)" +"(let-values(((temp298_0) key283_0)((expr-ctx299_0) expr-ctx_3))" +"(expand7.1 #f #f #f #f temp298_0 expr-ctx299_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_104)(expand-context-observer ctx_87)))" +"(if obs_104" +"(let-values()(let-values()(call-expand-observe obs_104 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-val_0)" +"(let-values(((temp300_1) val284_0)((expr-ctx301_0) expr-ctx_3))" +"(expand7.1 #f #f #f #f temp300_1 expr-ctx301_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_105)(expand-context-observer ctx_87)))" +"(if obs_105" +"(let-values()(let-values()(call-expand-observe obs_105 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-body_6)" +"(let-values(((temp302_0) body285_0)" +"((temp303_0)" +"(let-values(((ctx305_0) ctx_87))" +"(as-tail-context23.1 ctx305_0 expr-ctx_3))))" +"(expand7.1 #f #f #f #f temp302_0 temp303_0))))" +"(if(expand-context-to-parsed? ctx_87)" +"(parsed-with-continuation-mark10.1 rebuild-s_10 exp-key_0 exp-val_0 exp-body_6)" +"(let-values(((rebuild-s306_0) rebuild-s_10)" +"((temp307_0)(list with-continuation-mark282_0 exp-key_0 exp-val_0 exp-body_6)))" +"(rebuild5.1 #f #f rebuild-s306_0 temp307_0))))))))))))))))" +"(define-values" +"(make-begin20.1)" +"(lambda(last-is-tail?15_0 list-start-index14_0 log-tag18_0 parsed-begin19_0)" +"(begin" +" 'make-begin20" +"(let-values(((log-tag_1) log-tag18_0))" +"(let-values(((parsed-begin_0) parsed-begin19_0))" +"(let-values(((list-start-index_0) list-start-index14_0))" +"(let-values(((last-is-tail?_0) last-is-tail?15_0))" +"(let-values()" +"(lambda(s_610 ctx_88)" +"(let-values((()" +"(begin" +"(let-values(((obs_106)(expand-context-observer ctx_88)))" +"(if obs_106" +"(let-values()(let-values()(call-expand-observe obs_106 log-tag_1)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_15)(syntax-disarm$1 s_610)))" +"(let-values(((ok?_48 begin308_0 e309_0)" +"(let-values(((s_611) disarmed-s_15))" +"(let-values(((orig-s_55) s_611))" +"(let-values(((begin308_1 e309_1)" +"(let-values(((s_612)" +"(if(syntax?$1 s_611)(syntax-e$1 s_611) s_611)))" +"(if(pair? s_612)" +"(let-values(((begin310_0)" +"(let-values(((s_613)(car s_612))) s_613))" +"((e311_0)" +"(let-values(((s_614)(cdr s_612)))" +"(let-values(((s_615)" +"(if(syntax?$1 s_614)" +"(syntax-e$1 s_614)" +" s_614)))" +"(let-values(((flat-s_41)" +"(to-syntax-list.1 s_615)))" +"(if(not flat-s_41)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_55))" +"(if(null? flat-s_41)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_55))" +"(let-values() flat-s_41))))))))" +"(values begin310_0 e311_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_55)))))" +"(values #t begin308_1 e309_1))))))" +"(let-values(((expr-ctx_4)" +"(if last-is-tail?_0" +"(as-begin-expression-context ctx_88)" +"(as-expression-context ctx_88))))" +"(let-values(((rebuild-s_11)" +"(let-values(((ctx312_0) ctx_88)((s313_0) s_610))" +"(keep-as-needed74.1 #f #f #f #f #f #f ctx312_0 s313_0))))" +"(let-values(((exp-es_2)" +"((letrec-values(((loop_127)" +"(lambda(es_5 index_6)" +"(begin" +" 'loop" +"(begin" +"(if(zero? index_6)" +"(let-values()" +"(let-values(((obs_107)" +"(expand-context-observer ctx_88)))" +"(if obs_107" +"(let-values()" +"(begin" +"(if(zero? list-start-index_0)" +"(void)" +"(let-values()" +"(call-expand-observe obs_107 'next)))" +"(call-expand-observe" +" obs_107" +" 'enter-list" +"(datum->syntax$1 #f es_5 rebuild-s_11))))" +"(void))))" +"(void))" +"(if(null? es_5)" +"(let-values() null)" +"(let-values()" +"(let-values(((rest-es_1)(cdr es_5)))" +"(begin" +"(let-values(((obs_108)" +"(expand-context-observer" +" ctx_88)))" +"(if obs_108" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_108 'next)))" +"(void)))" +"(cons" +"(let-values(((temp314_0)(car es_5))" +"((temp315_0)" +"(if(if last-is-tail?_0" +"(null? rest-es_1)" +" #f)" +"(let-values(((ctx317_0)" +" ctx_88))" +"(as-tail-context23.1" +" ctx317_0" +" expr-ctx_4))" +" expr-ctx_4)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" temp314_0" +" temp315_0))" +"(loop_127 rest-es_1(sub1 index_6))))))))))))" +" loop_127)" +" e309_0" +" list-start-index_0)))" +"(begin" +"(let-values(((obs_109)(expand-context-observer ctx_88)))" +"(if obs_109" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_109" +" 'exit-list" +"(datum->syntax$1 #f(list-tail exp-es_2 list-start-index_0) rebuild-s_11))))" +"(void)))" +"(if(expand-context-to-parsed? ctx_88)" +"(parsed-begin_0 rebuild-s_11 exp-es_2)" +"(let-values(((rebuild-s318_0) rebuild-s_11)((temp319_0)(cons begin308_0 exp-es_2)))" +"(rebuild5.1 #f #f rebuild-s318_0 temp319_0)))))))))))))))))))" +"(void" +"(add-core-form!*" +" 'begin" +"(let-values(((nonempty-begin_0)" +"(let-values(((temp320_0) 'prim-begin)" +"((parsed-begin321_0) parsed-begin12.1)" +"((temp322_0) 0)" +"((temp323_0) #t))" +"(make-begin20.1 temp323_0 temp322_0 temp320_0 parsed-begin321_0))))" +"(lambda(s_616 ctx_89)" +"(let-values(((context_24)(expand-context-context ctx_89)))" +"(if(let-values(((or-part_373)(eq? context_24 'top-level)))" +"(if or-part_373 or-part_373(eq? context_24 'module)))" +"(let-values()" +"(let-values(((disarmed-s_16)(syntax-disarm$1 s_616)))" +"(let-values(((ok?_49 begin324_0)" +"(let-values(((s_617) disarmed-s_16))" +"(if(let-values(((s_618)(if(syntax?$1 s_617)(syntax-e$1 s_617) s_617)))" +"(if(pair? s_618)" +"(if(let-values(((s_619)(car s_618))) #t)" +"(let-values(((s_620)(cdr s_618)))" +"(let-values(((s_621)(if(syntax?$1 s_620)(syntax-e$1 s_620) s_620)))" +"(null? s_621)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((begin324_1)" +"(let-values(((s_622)(if(syntax?$1 s_617)(syntax-e$1 s_617) s_617)))" +"(let-values(((begin325_0)" +"(let-values(((s_623)(car s_622))) s_623))" +"(()" +"(let-values(((s_624)(cdr s_622)))" +"(let-values(((s_625)" +"(if(syntax?$1 s_624)" +"(syntax-e$1 s_624)" +" s_624)))" +"(values)))))" +"(values begin325_0)))))" +"(values #t begin324_1)))" +"(values #f #f)))))" +"(if ok?_49 s_616(nonempty-begin_0 s_616 ctx_89)))))" +"(let-values()(nonempty-begin_0 s_616 ctx_89))))))))" +"(void" +"(add-core-form!*" +" 'begin0" +"(let-values(((temp326_0) 'prim-begin0)((parsed-begin0327_0) parsed-begin013.1)((temp328_0) 1)((temp329_0) #f))" +"(make-begin20.1 temp329_0 temp328_0 temp326_0 parsed-begin0327_0))))" +"(define-values" +"(register-eventual-variable!?)" +"(lambda(id_119 ctx_90)" +"(begin" +"(if(if(expand-context-need-eventually-defined ctx_90)(>=(expand-context-phase ctx_90) 1) #f)" +"(let-values()" +"(begin" +"(hash-update!" +"(expand-context-need-eventually-defined ctx_90)" +"(expand-context-phase ctx_90)" +"(lambda(l_83)(cons id_119 l_83))" +" null)" +" #t))" +"(let-values() #f)))))" +"(void" +"(add-core-form!*" +" '#%top" +"(let-values(((core334_0)" +"(lambda(s332_0 ctx333_0 implicit-omitted?330_0 implicit-omitted?331_0)" +"(begin" +" 'core334" +"(let-values(((s_626) s332_0))" +"(let-values(((ctx_91) ctx333_0))" +"(let-values(((implicit-omitted?_0)(if implicit-omitted?331_0 implicit-omitted?330_0 #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_110)(expand-context-observer ctx_91)))" +"(if obs_110" +"(let-values()" +"(let-values()(call-expand-observe obs_110 'prim-#%top)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_17)(syntax-disarm$1 s_626)))" +"(let-values(((id_120)" +"(if implicit-omitted?_0" +"(let-values() s_626)" +"(let-values()" +"(let-values(((ok?_50 #%top336_0 id337_0)" +"(let-values(((s_627) disarmed-s_17))" +"(let-values(((orig-s_56) s_627))" +"(let-values(((#%top336_1 id337_1)" +"(let-values(((s_628)" +"(if(syntax?$1 s_627)" +"(syntax-e$1 s_627)" +" s_627)))" +"(if(pair? s_628)" +"(let-values(((#%top338_0)" +"(let-values(((s_629)" +"(car" +" s_628)))" +" s_629))" +"((id339_0)" +"(let-values(((s_630)" +"(cdr" +" s_628)))" +"(if(let-values(((or-part_374)" +"(if(syntax?$1" +" s_630)" +"(symbol?" +"(syntax-e$1" +" s_630))" +" #f)))" +"(if or-part_374" +" or-part_374" +"(symbol?" +" s_630)))" +" s_630" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_56" +" s_630)))))" +"(values #%top338_0 id339_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_56)))))" +"(values #t #%top336_1 id337_1))))))" +" id337_0)))))" +"(let-values(((b_90)" +"(let-values(((temp341_0)(expand-context-phase ctx_91))" +"((temp342_0) 'ambiguous))" +"(resolve+shift30.1" +" temp342_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" id_120" +" temp341_0))))" +"(if(eq? b_90 'ambiguous)" +"(let-values()(raise-ambiguous-error id_120 ctx_91))" +"(if(if b_90" +"(if(module-binding? b_90)" +"(eq?" +"(module-binding-module b_90)" +"(namespace-mpi(expand-context-namespace ctx_91)))" +" #f)" +" #f)" +"(let-values()" +"(if(expand-context-to-parsed? ctx_91)" +"(parsed-id2.1 id_120 b_90 #f)" +"(if(top-level-module-path-index?(module-binding-module b_90))" +"(let-values() s_626)" +"(let-values() id_120))))" +"(if(register-eventual-variable!? id_120 ctx_91)" +"(let-values()" +"(if(expand-context-to-parsed? ctx_91)" +"(parsed-id2.1 id_120 b_90 #f)" +" id_120))" +"(let-values()" +"(if(not(expand-context-allow-unbound? ctx_91))" +"(let-values()" +"(raise-unbound-syntax-error" +" #f" +" \"unbound identifier\"" +" id_120" +" #f" +" null" +"(syntax-debug-info-string id_120 ctx_91)))" +"(let-values()" +"(let-values(((tl-id_1)" +"(add-scope" +" id_120" +"(root-expand-context-top-level-bind-scope ctx_91))))" +"(let-values(((tl-b_1)" +"(let-values(((tl-id343_0) tl-id_1)" +"((temp344_0)" +"(expand-context-phase ctx_91)))" +"(resolve33.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" tl-id343_0" +" temp344_0))))" +"(if tl-b_1" +"(let-values()" +"(if(expand-context-to-parsed? ctx_91)" +"(parsed-top-id4.1 tl-id_1 tl-b_1 #f)" +"(if implicit-omitted?_0" +"(let-values() id_120)" +"(let-values()" +"(let-values(((ok?_51 #%top345_0 id346_0)" +"(let-values(((s_631) disarmed-s_17))" +"(let-values(((orig-s_57) s_631))" +"(let-values(((#%top345_1 id346_1)" +"(let-values(((s_632)" +"(if(syntax?$1" +" s_631)" +"(syntax-e$1" +" s_631)" +" s_631)))" +"(if(pair? s_632)" +"(let-values(((#%top347_0)" +"(let-values(((s_633)" +"(car" +" s_632)))" +" s_633))" +"((id348_0)" +"(let-values(((s_634)" +"(cdr" +" s_632)))" +"(if(let-values(((or-part_375)" +"(if(syntax?$1" +" s_634)" +"(symbol?" +"(syntax-e$1" +" s_634))" +" #f)))" +"(if or-part_375" +" or-part_375" +"(symbol?" +" s_634)))" +" s_634" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_57" +" s_634)))))" +"(values" +" #%top347_0" +" id348_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_57)))))" +"(values #t #%top345_1 id346_1))))))" +"(let-values(((s349_0) s_626)" +"((temp350_0)(cons #%top345_0 id_120)))" +"(rebuild5.1 #f #f s349_0 temp350_0)))))))" +"(let-values()" +"(if(expand-context-to-parsed? ctx_91)" +"(parsed-top-id4.1 id_120 b_90 #f)" +" s_626)))))))))))))))))))))))" +"(case-lambda" +"((s_635 ctx_92)(core334_0 s_635 ctx_92 #f #f))" +"((s_636 ctx_93 implicit-omitted?330_1)(core334_0 s_636 ctx_93 implicit-omitted?330_1 #t))))))" +"(void" +"(add-core-form!*" +" 'set!" +"(lambda(s_637 ctx_94)" +"(let-values((()" +"(begin" +"(let-values(((obs_111)(expand-context-observer ctx_94)))" +"(if obs_111(let-values()(let-values()(call-expand-observe obs_111 'prim-set!)))(void)))" +"(values))))" +"(let-values(((disarmed-s_18)(syntax-disarm$1 s_637)))" +"(let-values(((ok?_52 set!351_0 id352_0 rhs353_0)" +"(let-values(((s_638) disarmed-s_18))" +"(let-values(((orig-s_58) s_638))" +"(let-values(((set!351_1 id352_1 rhs353_1)" +"(let-values(((s_639)(if(syntax?$1 s_638)(syntax-e$1 s_638) s_638)))" +"(if(pair? s_639)" +"(let-values(((set!354_0)(let-values(((s_640)(car s_639))) s_640))" +"((id355_0 rhs356_0)" +"(let-values(((s_641)(cdr s_639)))" +"(let-values(((s_642)" +"(if(syntax?$1 s_641)" +"(syntax-e$1 s_641)" +" s_641)))" +"(if(pair? s_642)" +"(let-values(((id357_0)" +"(let-values(((s_643)(car s_642)))" +"(if(let-values(((or-part_376)" +"(if(syntax?$1 s_643)" +"(symbol?" +"(syntax-e$1" +" s_643))" +" #f)))" +"(if or-part_376" +" or-part_376" +"(symbol? s_643)))" +" s_643" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_58" +" s_643))))" +"((rhs358_0)" +"(let-values(((s_644)(cdr s_642)))" +"(let-values(((s_645)" +"(if(syntax?$1 s_644)" +"(syntax-e$1 s_644)" +" s_644)))" +"(if(pair? s_645)" +"(let-values(((rhs359_0)" +"(let-values(((s_646)" +"(car" +" s_645)))" +" s_646))" +"(()" +"(let-values(((s_647)" +"(cdr" +" s_645)))" +"(let-values(((s_648)" +"(if(syntax?$1" +" s_647)" +"(syntax-e$1" +" s_647)" +" s_647)))" +"(if(null? s_648)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_58))))))" +"(values rhs359_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_58))))))" +"(values id357_0 rhs358_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_58))))))" +"(values set!354_0 id355_0 rhs356_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_58)))))" +"(values #t set!351_1 id352_1 rhs353_1))))))" +"(let-values(((id_121) id352_0))" +"((letrec-values(((rename-loop_0)" +"(lambda(id_122 from-rename?_0)" +"(begin" +" 'rename-loop" +"(let-values(((binding_30)" +"(let-values(((temp361_0)(expand-context-phase ctx_94))" +"((temp362_0) 'ambiguous)" +"((temp363_0) #t))" +"(resolve+shift30.1" +" temp362_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp363_0" +" #t" +" #f" +" #f" +" id_122" +" temp361_0))))" +"(let-values((()" +"(begin" +"(if(eq? binding_30 'ambiguous)" +"(let-values()(raise-ambiguous-error id_122 ctx_94))" +"(void))" +"(values))))" +"(let-values(((t_57 primitive?_10 insp_24)" +"(if binding_30" +"(let-values(((binding364_0) binding_30)" +"((ctx365_0) ctx_94)" +"((s366_0) s_637))" +"(lookup17.1 #f #f #f #f binding364_0 ctx365_0 s366_0))" +"(values #f #f #f))))" +"(begin" +"(let-values(((obs_112)(expand-context-observer ctx_94)))" +"(if obs_112" +"(let-values()" +"(let-values()(call-expand-observe obs_112 'resolve id_122)))" +"(void)))" +"(if(let-values(((or-part_377)(variable? t_57)))" +"(if or-part_377" +" or-part_377" +"(if(not binding_30)" +"(let-values(((or-part_378)" +"(register-eventual-variable!? id_122 ctx_94)))" +"(if or-part_378" +" or-part_378" +"(expand-context-allow-unbound? ctx_94)))" +" #f)))" +"(let-values()" +"(let-values((()" +"(begin" +"(if(if(module-binding? binding_30)" +"(not" +"(eq?" +"(module-binding-module binding_30)" +"(namespace-mpi" +"(expand-context-namespace ctx_94))))" +" #f)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"cannot mutate module-required identifier\"" +" s_637" +" id_122))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_113)" +"(expand-context-observer ctx_94)))" +"(if obs_113" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_113 'next)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(register-variable-referenced-if-local! binding_30)" +"(values))))" +"(let-values(((rebuild-s_12)" +"(let-values(((ctx367_0) ctx_94)((s368_0) s_637))" +"(keep-as-needed74.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ctx367_0" +" s368_0))))" +"(let-values(((exp-rhs_5)" +"(let-values(((temp369_0) rhs353_0)" +"((temp370_0)" +"(as-expression-context ctx_94)))" +"(expand7.1 #f #f #f #f temp369_0 temp370_0))))" +"(if(expand-context-to-parsed? ctx_94)" +"(parsed-set!9.1" +" rebuild-s_12" +"(parsed-id2.1 id_122 binding_30 #f)" +" exp-rhs_5)" +"(let-values(((rebuild-s371_0) rebuild-s_12)" +"((temp372_0)" +"(list" +" set!351_0" +"(let-values(((temp375_0)" +"(free-id-set-empty-or-just-module*?" +"(expand-context-stops" +" ctx_94))))" +"(substitute-variable6.1" +" temp375_0" +" id_122" +" t_57))" +" exp-rhs_5)))" +"(rebuild5.1 #f #f rebuild-s371_0 temp372_0)))))))))" +"(if(not binding_30)" +"(let-values()" +"(raise-unbound-syntax-error" +" #f" +" \"unbound identifier\"" +" s_637" +" id_122" +" null" +"(syntax-debug-info-string id_122 ctx_94)))" +"(if(1/set!-transformer? t_57)" +"(let-values()" +"(if(not-in-this-expand-context? t_57 ctx_94)" +"(let-values()" +"(let-values(((temp376_0)" +"(avoid-current-expand-context" +"(substitute-set!-rename" +" s_637" +" disarmed-s_18" +" set!351_0" +" rhs353_0" +" id_122" +" from-rename?_0" +" ctx_94)" +" t_57" +" ctx_94))" +"((ctx377_0) ctx_94))" +"(expand7.1 #f #f #f #f temp376_0 ctx377_0)))" +"(let-values()" +"(let-values(((exp-s_14 re-ctx_1)" +"(apply-transformer" +" t_57" +" insp_24" +" s_637" +" id_122" +" ctx_94" +" binding_30)))" +"(if(expand-context-just-once? ctx_94)" +"(let-values() exp-s_14)" +"(let-values()" +"(let-values(((exp-s378_0) exp-s_14)" +"((re-ctx379_0) re-ctx_1))" +"(expand7.1 #f #f #f #f exp-s378_0 re-ctx379_0))))))))" +"(if(1/rename-transformer? t_57)" +"(let-values()" +"(if(not-in-this-expand-context? t_57 ctx_94)" +"(let-values()" +"(let-values(((temp380_0)" +"(avoid-current-expand-context" +"(substitute-set!-rename" +" s_637" +" disarmed-s_18" +" set!351_0" +" rhs353_0" +" id_122" +" from-rename?_0" +" ctx_94" +" t_57)" +" t_57" +" ctx_94))" +"((ctx381_0) ctx_94))" +"(expand7.1 #f #f #f #f temp380_0 ctx381_0)))" +"(let-values()" +"(rename-loop_0" +"(rename-transformer-target-in-context t_57 ctx_94)" +" #t))))" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"cannot mutate syntax identifier\"" +" s_637" +" id_122))))))))))))))" +" rename-loop_0)" +" id_121" +" #f))))))))" +"(define-values" +"(substitute-set!-rename)" +"(let-values(((substitute-set!-rename32_0)" +"(lambda(s25_0 disarmed-s26_0 set!-id27_0 id28_0 rhs-s29_0 from-rename?30_0 ctx31_0 t23_0 t24_0)" +"(begin" +" 'substitute-set!-rename32" +"(let-values(((s_649) s25_0))" +"(let-values(((disarmed-s_19) disarmed-s26_0))" +"(let-values(((set!-id_0) set!-id27_0))" +"(let-values(((id_123) id28_0))" +"(let-values(((rhs-s_0) rhs-s29_0))" +"(let-values(((from-rename?_1) from-rename?30_0))" +"(let-values(((ctx_95) ctx31_0))" +"(let-values(((t_58)(if t24_0 t23_0 #f)))" +"(let-values()" +"(if(let-values(((or-part_379) t_58))" +"(if or-part_379 or-part_379 from-rename?_1))" +"(let-values()" +"(let-values(((new-id_1)" +"(if t_58" +"(rename-transformer-target-in-context t_58 ctx_95)" +" id_123)))" +"(syntax-rearm$1" +"(datum->syntax$1" +" disarmed-s_19" +"(list set!-id_0 new-id_1 rhs-s_0)" +" disarmed-s_19" +" disarmed-s_19)" +" s_649)))" +"(let-values() s_649)))))))))))))))" +"(case-lambda" +"((s_650 disarmed-s_20 set!-id_1 id_124 rhs-s_1 from-rename?_2 ctx_96)" +"(begin(substitute-set!-rename32_0 s_650 disarmed-s_20 set!-id_1 id_124 rhs-s_1 from-rename?_2 ctx_96 #f #f)))" +"((s_651 disarmed-s_21 set!-id_2 id_125 rhs-s_2 from-rename?_3 ctx_97 t23_1)" +"(substitute-set!-rename32_0 s_651 disarmed-s_21 set!-id_2 id_125 rhs-s_2 from-rename?_3 ctx_97 t23_1 #t)))))" +"(void" +"(add-core-form!*" +" '#%variable-reference" +"(lambda(s_652 ctx_98)" +"(let-values((()" +"(begin" +"(let-values(((obs_114)(expand-context-observer ctx_98)))" +"(if obs_114" +"(let-values()(let-values()(call-expand-observe obs_114 'prim-#%variable-reference)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_22)(syntax-disarm$1 s_652)))" +"(let-values(((ok?_53 #%variable-reference382_0 id383_0)" +"(let-values(((s_653) disarmed-s_22))" +"(if(let-values(((s_654)(if(syntax?$1 s_653)(syntax-e$1 s_653) s_653)))" +"(if(pair? s_654)" +"(if(let-values(((s_655)(car s_654))) #t)" +"(let-values(((s_656)(cdr s_654)))" +"(let-values(((s_657)(if(syntax?$1 s_656)(syntax-e$1 s_656) s_656)))" +"(if(pair? s_657)" +"(if(let-values(((s_658)(car s_657)))" +"(let-values(((or-part_380)" +"(if(syntax?$1 s_658)(symbol?(syntax-e$1 s_658)) #f)))" +"(if or-part_380 or-part_380(symbol? s_658))))" +"(let-values(((s_659)(cdr s_657)))" +"(let-values(((s_660)(if(syntax?$1 s_659)(syntax-e$1 s_659) s_659)))" +"(null? s_660)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((#%variable-reference382_1 id383_1)" +"(let-values(((s_661)(if(syntax?$1 s_653)(syntax-e$1 s_653) s_653)))" +"(let-values(((#%variable-reference384_0)" +"(let-values(((s_662)(car s_661))) s_662))" +"((id385_0)" +"(let-values(((s_663)(cdr s_661)))" +"(let-values(((s_664)" +"(if(syntax?$1 s_663)" +"(syntax-e$1 s_663)" +" s_663)))" +"(let-values(((id386_0)" +"(let-values(((s_665)(car s_664))) s_665))" +"(()" +"(let-values(((s_666)(cdr s_664)))" +"(let-values(((s_667)" +"(if(syntax?$1 s_666)" +"(syntax-e$1 s_666)" +" s_666)))" +"(values)))))" +"(values id386_0))))))" +"(values #%variable-reference384_0 id385_0)))))" +"(values #t #%variable-reference382_1 id383_1)))" +"(values #f #f #f)))))" +"(let-values(((ok?_54 #%variable-reference387_0 #%top388_0 id389_0)" +"(let-values(((s_668) disarmed-s_22))" +"(if(if(not ok?_53)" +"(let-values(((s_669)(if(syntax?$1 s_668)(syntax-e$1 s_668) s_668)))" +"(if(pair? s_669)" +"(if(let-values(((s_670)(car s_669))) #t)" +"(let-values(((s_671)(cdr s_669)))" +"(let-values(((s_672)(if(syntax?$1 s_671)(syntax-e$1 s_671) s_671)))" +"(if(pair? s_672)" +"(if(let-values(((s_673)(car s_672)))" +"(let-values(((s_674)" +"(if(syntax?$1 s_673)(syntax-e$1 s_673) s_673)))" +"(if(pair? s_674)" +"(if(let-values(((s_675)(car s_674))) #t)" +"(let-values(((s_676)(cdr s_674)))" +"(let-values(((or-part_381)" +"(if(syntax?$1 s_676)" +"(symbol?(syntax-e$1 s_676))" +" #f)))" +"(if or-part_381 or-part_381(symbol? s_676))))" +" #f)" +" #f)))" +"(let-values(((s_677)(cdr s_672)))" +"(let-values(((s_678)(if(syntax?$1 s_677)(syntax-e$1 s_677) s_677)))" +"(null? s_678)))" +" #f)" +" #f)))" +" #f)" +" #f))" +" #f)" +"(let-values()" +"(let-values(((#%variable-reference387_1 #%top388_1 id389_1)" +"(let-values(((s_679)(if(syntax?$1 s_668)(syntax-e$1 s_668) s_668)))" +"(let-values(((#%variable-reference390_0)" +"(let-values(((s_680)(car s_679))) s_680))" +"((#%top391_0 id392_0)" +"(let-values(((s_681)(cdr s_679)))" +"(let-values(((s_682)" +"(if(syntax?$1 s_681)" +"(syntax-e$1 s_681)" +" s_681)))" +"(let-values(((#%top393_0 id394_0)" +"(let-values(((s_683)(car s_682)))" +"(let-values(((s_684)" +"(if(syntax?$1 s_683)" +"(syntax-e$1 s_683)" +" s_683)))" +"(let-values(((#%top395_0)" +"(let-values(((s_685)" +"(car" +" s_684)))" +" s_685))" +"((id396_0)" +"(let-values(((s_686)" +"(cdr" +" s_684)))" +" s_686)))" +"(values #%top395_0 id396_0)))))" +"(()" +"(let-values(((s_687)(cdr s_682)))" +"(let-values(((s_688)" +"(if(syntax?$1 s_687)" +"(syntax-e$1 s_687)" +" s_687)))" +"(values)))))" +"(values #%top393_0 id394_0))))))" +"(values #%variable-reference390_0 #%top391_0 id392_0)))))" +"(values #t #%variable-reference387_1 #%top388_1 id389_1)))" +"(values #f #f #f #f)))))" +"(let-values(((ok?_55 #%variable-reference397_0)" +"(let-values(((s_689) disarmed-s_22))" +"(if(if(not(let-values(((or-part_382) ok?_53))(if or-part_382 or-part_382 ok?_54)))" +" #t" +" #f)" +"(let-values(((orig-s_59) s_689))" +"(let-values(((#%variable-reference397_1)" +"(let-values(((s_690)(if(syntax?$1 s_689)(syntax-e$1 s_689) s_689)))" +"(if(pair? s_690)" +"(let-values(((#%variable-reference398_0)" +"(let-values(((s_691)(car s_690))) s_691))" +"(()" +"(let-values(((s_692)(cdr s_690)))" +"(let-values(((s_693)" +"(if(syntax?$1 s_692)" +"(syntax-e$1 s_692)" +" s_692)))" +"(if(null? s_693)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_59))))))" +"(values #%variable-reference398_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_59)))))" +"(values #t #%variable-reference397_1)))" +"(values #f #f)))))" +"(if(let-values(((or-part_383) ok?_53))(if or-part_383 or-part_383 ok?_54))" +"(let-values()" +"(let-values(((var-id_0)(if ok?_53 id383_0 id389_0)))" +"(let-values(((binding_31)" +"(let-values(((temp400_0)(expand-context-phase ctx_98))((temp401_0) 'ambiguous))" +"(resolve+shift30.1 temp401_0 #t #f #f #f #f #f #f #f #f var-id_0 temp400_0))))" +"(let-values((()" +"(begin" +"(if(eq? binding_31 'ambiguous)" +"(let-values()(raise-ambiguous-error var-id_0 ctx_98))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_384) binding_31))" +"(if or-part_384 or-part_384(expand-context-allow-unbound? ctx_98)))" +"(void)" +"(let-values()" +"(raise-unbound-syntax-error" +" #f" +" \"unbound identifier\"" +" s_652" +" var-id_0" +" null" +"(syntax-debug-info-string var-id_0 ctx_98))))" +"(values))))" +"(let-values(((t_59 primitive?_11 insp-of-t_7)" +"(if binding_31" +"(let-values(((s405_0) s_652)" +"((temp406_0)(expand-context-in-local-expand? ctx_98)))" +"(lookup17.1 s405_0 #t temp406_0 #t binding_31 ctx_98 var-id_0))" +"(values #f #f #f))))" +"(begin" +"(if(if t_59(not(variable? t_59)) #f)" +"(let-values()" +" (raise-syntax-error$1 #f \"identifier does not refer to a variable\" var-id_0 s_652))" +"(void))" +"(if(expand-context-to-parsed? ctx_98)" +"(parsed-#%variable-reference11.1" +"(keep-properties-only~ s_652)" +"(if ok?_54" +"(let-values()(parsed-top-id4.1 var-id_0 binding_31 #f))" +"(let-values()(parsed-id2.1 var-id_0 binding_31 #f))))" +" s_652))))))))" +"(let-values()" +"(if(expand-context-to-parsed? ctx_98)" +"(parsed-#%variable-reference11.1(keep-properties-only~ s_652) #f)" +" s_652)))))))))))" +"(void" +"(add-core-form!*" +" '#%expression" +"(lambda(s_694 ctx_99)" +"(let-values((()" +"(begin" +"(let-values(((obs_115)(expand-context-observer ctx_99)))" +"(if obs_115" +"(let-values()(let-values()(call-expand-observe obs_115 'prim-#%expression)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_23)(syntax-disarm$1 s_694)))" +"(let-values(((ok?_56 #%expression407_0 e408_0)" +"(let-values(((s_695) disarmed-s_23))" +"(let-values(((orig-s_60) s_695))" +"(let-values(((#%expression407_1 e408_1)" +"(let-values(((s_696)(if(syntax?$1 s_695)(syntax-e$1 s_695) s_695)))" +"(if(pair? s_696)" +"(let-values(((#%expression409_0)" +"(let-values(((s_697)(car s_696))) s_697))" +"((e410_0)" +"(let-values(((s_698)(cdr s_696)))" +"(let-values(((s_699)" +"(if(syntax?$1 s_698)" +"(syntax-e$1 s_698)" +" s_698)))" +"(if(pair? s_699)" +"(let-values(((e411_0)" +"(let-values(((s_700)(car s_699)))" +" s_700))" +"(()" +"(let-values(((s_701)(cdr s_699)))" +"(let-values(((s_702)" +"(if(syntax?$1 s_701)" +"(syntax-e$1 s_701)" +" s_701)))" +"(if(null? s_702)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_60))))))" +"(values e411_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_60))))))" +"(values #%expression409_0 e410_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_60)))))" +"(values #t #%expression407_1 e408_1))))))" +"(let-values(((rebuild-s_13)" +"(let-values(((temp414_0) #t))(keep-as-needed74.1 temp414_0 #t #f #f #f #f ctx_99 s_694))))" +"(let-values(((exp-e_0)" +"(let-values(((temp415_0) e408_0)" +"((temp416_0)" +"(let-values(((temp417_0)(as-expression-context ctx_99))((ctx418_0) ctx_99))" +"(as-tail-context23.1 ctx418_0 temp417_0))))" +"(expand7.1 #f #f #f #f temp415_0 temp416_0))))" +"(if(expand-context-to-parsed? ctx_99)" +" exp-e_0" +"(let-values(((tmp_62)" +"(if(not(expand-context-in-local-expand? ctx_99))(expand-context-context ctx_99) #f)))" +"(if(equal? tmp_62 'expression)" +"(let-values()" +"(let-values(((result-s_13)(syntax-track-origin$1 exp-e_0 rebuild-s_13)))" +"(begin" +"(let-values(((obs_116)(expand-context-observer ctx_99)))" +"(if obs_116" +"(let-values()(let-values()(call-expand-observe obs_116 'tag result-s_13)))" +"(void)))" +" result-s_13)))" +"(let-values()" +"(let-values(((rebuild-s419_0) rebuild-s_13)((temp420_0)(list #%expression407_0 exp-e_0)))" +"(rebuild5.1 #f #f rebuild-s419_0 temp420_0))))))))))))))" +" (void (add-core-form!* 'unquote (lambda (s_703 ctx_100) (raise-syntax-error$1 #f \"not in quasiquote\" s_703))))" +" (void (add-core-form!* 'unquote-splicing (lambda (s_704 ctx_101) (raise-syntax-error$1 #f \"not in quasiquote\" s_704))))" +"(define-values" +"(binding-for-transformer?)" +"(lambda(b_41 id_126 at-phase_12 ns_123)" +"(begin" +"(if(not at-phase_12)" +"(let-values()" +"(let-values(((m_30)" +"(namespace->module ns_123(1/module-path-index-resolve(module-binding-nominal-module b_41)))))" +"(let-values(((b/p_4)" +"(hash-ref" +"(hash-ref(module-provides m_30)(module-binding-nominal-phase b_41) '#hasheq())" +"(module-binding-nominal-sym b_41)" +" #f)))" +"(provided-as-transformer? b/p_4))))" +"(let-values()" +"(let-values(((val_85 primitive?_12 insp_25)" +"(let-values(((b1_8) b_41)" +"((empty-env2_0) empty-env)" +"((null3_0) null)" +"((ns4_0) ns_123)" +"((at-phase5_0) at-phase_12)" +"((id6_0) id_126))" +"(binding-lookup48.1 #f #f #f #f b1_8 empty-env2_0 null3_0 ns4_0 at-phase5_0 id6_0))))" +"(not(variable? val_85))))))))" +"(define-values(layers) '(raw phaseless id))" +"(define-values(provide-form-name) 'provide)" +"(define-values" +"(parse-and-expand-provides!)" +"(lambda(specs_0 orig-s_61 rp_1 self_28 phase_41 ctx_102)" +"(begin" +"(let-values(((ns_124)(expand-context-namespace ctx_102)))" +"((letrec-values(((loop_115)" +"(lambda(specs_1 at-phase_13 protected?_4 layer_6)" +"(begin" +" 'loop" +"(let-values(((track-stxess_0 exp-specss_0)" +"(let-values(((track-stxes_0 exp-specs_0)" +"(let-values(((lst_73) specs_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_73)))" +"((letrec-values(((for-loop_91)" +"(lambda(track-stxes_1" +" exp-specs_1" +" lst_400)" +"(begin" +" 'for-loop" +"(if(pair? lst_400)" +"(let-values(((spec_0)" +"(unsafe-car" +" lst_400))" +"((rest_233)" +"(unsafe-cdr" +" lst_400)))" +"(let-values(((track-stxes_2" +" exp-specs_2)" +"(let-values(((track-stxes_3)" +" track-stxes_1)" +"((exp-specs_3)" +" exp-specs_1))" +"(let-values(((track-stxes_4" +" exp-specs_4)" +"(let-values()" +"(let-values(((track-stxes1_0" +" exp-specs2_0)" +"(let-values()" +"(let-values(((disarmed-spec_0)" +"(syntax-disarm$1" +" spec_0)))" +"(let-values(((fm_2)" +"(if(pair?" +"(syntax-e$1" +" disarmed-spec_0))" +"(if(identifier?" +"(car" +"(syntax-e$1" +" disarmed-spec_0)))" +"(syntax-e$1" +"(car" +"(syntax-e$1" +" disarmed-spec_0)))" +" #f)" +" #f)))" +"(let-values(((check-nested_1)" +"(lambda(want-layer_3)" +"(begin" +" 'check-nested" +"(if(member" +" want-layer_3" +"(member" +" layer_6" +" layers))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +"(format" +" \"nested `~a' not allowed\"" +" fm_2)" +" orig-s_61" +" spec_0)))))))" +"(let-values(((tmp_63)" +" fm_2))" +"(let-values(((index_7)" +"(if(symbol?" +" tmp_63)" +"(hash-ref" +" '#hasheq((all-defined" +" ." +" 9)" +"(all-defined-except" +" ." +" 10)" +"(all-from" +" ." +" 7)" +"(all-from-except" +" ." +" 8)" +"(expand" +" ." +" 13)" +"(for-label" +" ." +" 3)" +"(for-meta" +" ." +" 1)" +"(for-syntax" +" ." +" 2)" +"(prefix-all-defined" +" ." +" 11)" +"(prefix-all-defined-except" +" ." +" 12)" +"(protect" +" ." +" 4)" +"(rename ." +" 5)" +"(struct" +" ." +" 6))" +" tmp_63" +"(lambda()" +" 0))" +" 0)))" +"(if(unsafe-fx<" +" index_7" +" 6)" +"(if(unsafe-fx<" +" index_7" +" 2)" +"(if(unsafe-fx<" +" index_7" +" 1)" +"(let-values()" +"(if(identifier?" +" spec_0)" +"(let-values()" +"(begin" +"(parse-identifier!" +" spec_0" +" orig-s_61" +"(syntax-e$1" +" spec_0)" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4)" +"(values" +" null" +"(list" +" spec_0))))" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"bad syntax\"" +" orig-s_61" +" spec_0))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'raw)" +"(values))))" +"(let-values(((ok?_57" +" for-meta3_0" +" phase-level4_0" +" spec5_0)" +"(let-values(((s_307)" +" disarmed-spec_0))" +"(let-values(((orig-s_62)" +" s_307))" +"(let-values(((for-meta3_1" +" phase-level4_1" +" spec5_1)" +"(let-values(((s_459)" +"(if(syntax?$1" +" s_307)" +"(syntax-e$1" +" s_307)" +" s_307)))" +"(if(pair?" +" s_459)" +"(let-values(((for-meta6_0)" +"(let-values(((s_179)" +"(car" +" s_459)))" +" s_179))" +"((phase-level7_0" +" spec8_0)" +"(let-values(((s_78)" +"(cdr" +" s_459)))" +"(let-values(((s_412)" +"(if(syntax?$1" +" s_78)" +"(syntax-e$1" +" s_78)" +" s_78)))" +"(if(pair?" +" s_412)" +"(let-values(((phase-level9_0)" +"(let-values(((s_181)" +"(car" +" s_412)))" +" s_181))" +"((spec10_0)" +"(let-values(((s_399)" +"(cdr" +" s_412)))" +"(let-values(((s_148)" +"(if(syntax?$1" +" s_399)" +"(syntax-e$1" +" s_399)" +" s_399)))" +"(let-values(((flat-s_42)" +"(to-syntax-list.1" +" s_148)))" +"(if(not" +" flat-s_42)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_62))" +"(let-values()" +" flat-s_42)))))))" +"(values" +" phase-level9_0" +" spec10_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_62))))))" +"(values" +" for-meta6_0" +" phase-level7_0" +" spec8_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_62)))))" +"(values" +" #t" +" for-meta3_1" +" phase-level4_1" +" spec5_1))))))" +"(let-values(((p_68)" +"(syntax-e$1" +" phase-level4_0)))" +"(let-values((()" +"(begin" +"(if(phase?" +" p_68)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"bad `for-meta' phase\"" +" orig-s_61" +" spec_0)))" +"(values))))" +"(let-values(((track-stxes_5" +" exp-specs_5)" +"(loop_115" +" spec5_0" +"(phase+" +" p_68" +" at-phase_13)" +" protected?_4" +" 'phaseless)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_5" +"(let-values(((spec11_0)" +" spec_0)" +"((temp12_7)" +"(list*" +" for-meta3_0" +" phase-level4_0" +" exp-specs_5)))" +"(rebuild5.1" +" #f" +" #f" +" spec11_0" +" temp12_7))))))))))))" +"(if(unsafe-fx<" +" index_7" +" 3)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'raw)" +"(values))))" +"(let-values(((ok?_58" +" for-syntax13_0" +" spec14_0)" +"(let-values(((s_20)" +" disarmed-spec_0))" +"(let-values(((orig-s_63)" +" s_20))" +"(let-values(((for-syntax13_1" +" spec14_1)" +"(let-values(((s_23)" +"(if(syntax?$1" +" s_20)" +"(syntax-e$1" +" s_20)" +" s_20)))" +"(if(pair?" +" s_23)" +"(let-values(((for-syntax15_0)" +"(let-values(((s_305)" +"(car" +" s_23)))" +" s_305))" +"((spec16_0)" +"(let-values(((s_25)" +"(cdr" +" s_23)))" +"(let-values(((s_705)" +"(if(syntax?$1" +" s_25)" +"(syntax-e$1" +" s_25)" +" s_25)))" +"(let-values(((flat-s_43)" +"(to-syntax-list.1" +" s_705)))" +"(if(not" +" flat-s_43)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_63))" +"(let-values()" +" flat-s_43)))))))" +"(values" +" for-syntax15_0" +" spec16_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_63)))))" +"(values" +" #t" +" for-syntax13_1" +" spec14_1))))))" +"(let-values(((track-stxes_6" +" exp-specs_6)" +"(loop_115" +" spec14_0" +"(phase+" +" 1" +" at-phase_13)" +" protected?_4" +" 'phaseless)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_6" +"(let-values(((spec17_0)" +" spec_0)" +"((temp18_5)" +"(list*" +" for-syntax13_0" +" exp-specs_6)))" +"(rebuild5.1" +" #f" +" #f" +" spec17_0" +" temp18_5)))))))))" +"(if(unsafe-fx<" +" index_7" +" 4)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'raw)" +"(values))))" +"(let-values(((ok?_59" +" for-label19_0" +" spec20_0)" +"(let-values(((s_44)" +" disarmed-spec_0))" +"(let-values(((orig-s_24)" +" s_44))" +"(let-values(((for-label19_1" +" spec20_1)" +"(let-values(((s_706)" +"(if(syntax?$1" +" s_44)" +"(syntax-e$1" +" s_44)" +" s_44)))" +"(if(pair?" +" s_706)" +"(let-values(((for-label21_0)" +"(let-values(((s_473)" +"(car" +" s_706)))" +" s_473))" +"((spec22_0)" +"(let-values(((s_45)" +"(cdr" +" s_706)))" +"(let-values(((s_397)" +"(if(syntax?$1" +" s_45)" +"(syntax-e$1" +" s_45)" +" s_45)))" +"(let-values(((flat-s_44)" +"(to-syntax-list.1" +" s_397)))" +"(if(not" +" flat-s_44)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_24))" +"(let-values()" +" flat-s_44)))))))" +"(values" +" for-label21_0" +" spec22_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_24)))))" +"(values" +" #t" +" for-label19_1" +" spec20_1))))))" +"(let-values(((track-stxes_7" +" exp-specs_7)" +"(loop_115" +" spec20_0" +" #f" +" protected?_4" +" 'phaseless)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_7" +"(let-values(((spec23_0)" +" spec_0)" +"((temp24_12)" +"(list*" +" for-label19_0" +" exp-specs_7)))" +"(rebuild5.1" +" #f" +" #f" +" spec23_0" +" temp24_12)))))))))" +"(if(unsafe-fx<" +" index_7" +" 5)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values((()" +"(begin" +"(if protected?_4" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"nested `protect' not allowed\"" +" orig-s_61" +" spec_0))" +"(void))" +"(values))))" +"(let-values(((ok?_60" +" protect25_0" +" p-spec26_0)" +"(let-values(((s_85)" +" disarmed-spec_0))" +"(let-values(((orig-s_40)" +" s_85))" +"(let-values(((protect25_1" +" p-spec26_1)" +"(let-values(((s_31)" +"(if(syntax?$1" +" s_85)" +"(syntax-e$1" +" s_85)" +" s_85)))" +"(if(pair?" +" s_31)" +"(let-values(((protect27_0)" +"(let-values(((s_707)" +"(car" +" s_31)))" +" s_707))" +"((p-spec28_0)" +"(let-values(((s_708)" +"(cdr" +" s_31)))" +"(let-values(((s_393)" +"(if(syntax?$1" +" s_708)" +"(syntax-e$1" +" s_708)" +" s_708)))" +"(let-values(((flat-s_45)" +"(to-syntax-list.1" +" s_393)))" +"(if(not" +" flat-s_45)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40))" +"(let-values()" +" flat-s_45)))))))" +"(values" +" protect27_0" +" p-spec28_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_40)))))" +"(values" +" #t" +" protect25_1" +" p-spec26_1))))))" +"(let-values(((track-stxes_8" +" exp-specs_8)" +"(loop_115" +" p-spec26_0" +" at-phase_13" +" #t" +" layer_6)))" +"(values" +" null" +"(list" +"(syntax-track-origin*" +" track-stxes_8" +"(let-values(((spec29_0)" +" spec_0)" +"((temp30_7)" +"(list*" +" protect25_0" +" exp-specs_8)))" +"(rebuild5.1" +" #f" +" #f" +" spec29_0" +" temp30_7))))))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_61" +" rename31_0" +" id:from32_0" +" id:to33_0)" +"(let-values(((s_476)" +" disarmed-spec_0))" +"(let-values(((orig-s_64)" +" s_476))" +"(let-values(((rename31_1" +" id:from32_1" +" id:to33_1)" +"(let-values(((s_317)" +"(if(syntax?$1" +" s_476)" +"(syntax-e$1" +" s_476)" +" s_476)))" +"(if(pair?" +" s_317)" +"(let-values(((rename34_0)" +"(let-values(((s_159)" +"(car" +" s_317)))" +" s_159))" +"((id:from35_0" +" id:to36_0)" +"(let-values(((s_319)" +"(cdr" +" s_317)))" +"(let-values(((s_492)" +"(if(syntax?$1" +" s_319)" +"(syntax-e$1" +" s_319)" +" s_319)))" +"(if(pair?" +" s_492)" +"(let-values(((id:from37_0)" +"(let-values(((s_56)" +"(car" +" s_492)))" +"(if(let-values(((or-part_60)" +"(if(syntax?$1" +" s_56)" +"(symbol?" +"(syntax-e$1" +" s_56))" +" #f)))" +"(if or-part_60" +" or-part_60" +"(symbol?" +" s_56)))" +" s_56" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_64" +" s_56))))" +"((id:to38_0)" +"(let-values(((s_389)" +"(cdr" +" s_492)))" +"(let-values(((s_709)" +"(if(syntax?$1" +" s_389)" +"(syntax-e$1" +" s_389)" +" s_389)))" +"(if(pair?" +" s_709)" +"(let-values(((id:to39_0)" +"(let-values(((s_390)" +"(car" +" s_709)))" +"(if(let-values(((or-part_104)" +"(if(syntax?$1" +" s_390)" +"(symbol?" +"(syntax-e$1" +" s_390))" +" #f)))" +"(if or-part_104" +" or-part_104" +"(symbol?" +" s_390)))" +" s_390" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_64" +" s_390))))" +"(()" +"(let-values(((s_391)" +"(cdr" +" s_709)))" +"(let-values(((s_493)" +"(if(syntax?$1" +" s_391)" +"(syntax-e$1" +" s_391)" +" s_391)))" +"(if(null?" +" s_493)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_64))))))" +"(values" +" id:to39_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_64))))))" +"(values" +" id:from37_0" +" id:to38_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_64))))))" +"(values" +" rename34_0" +" id:from35_0" +" id:to36_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_64)))))" +"(values" +" #t" +" rename31_1" +" id:from32_1" +" id:to33_1))))))" +"(begin" +"(parse-identifier!" +" id:from32_0" +" orig-s_61" +"(syntax-e$1" +" id:to33_0)" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4)" +"(values" +" null" +"(list" +" spec_0))))))))))" +"(if(unsafe-fx<" +" index_7" +" 9)" +"(if(unsafe-fx<" +" index_7" +" 7)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_62" +" struct40_0" +" id:struct41_0" +" id:field42_0)" +"(let-values(((s_36)" +" disarmed-spec_0))" +"(let-values(((orig-s_65)" +" s_36))" +"(let-values(((struct40_1" +" id:struct41_1" +" id:field42_1)" +"(let-values(((s_710)" +"(if(syntax?$1" +" s_36)" +"(syntax-e$1" +" s_36)" +" s_36)))" +"(if(pair?" +" s_710)" +"(let-values(((struct43_0)" +"(let-values(((s_200)" +"(car" +" s_710)))" +" s_200))" +"((id:struct44_0" +" id:field45_0)" +"(let-values(((s_37)" +"(cdr" +" s_710)))" +"(let-values(((s_86)" +"(if(syntax?$1" +" s_37)" +"(syntax-e$1" +" s_37)" +" s_37)))" +"(if(pair?" +" s_86)" +"(let-values(((id:struct46_0)" +"(let-values(((s_711)" +"(car" +" s_86)))" +"(if(let-values(((or-part_258)" +"(if(syntax?$1" +" s_711)" +"(symbol?" +"(syntax-e$1" +" s_711))" +" #f)))" +"(if or-part_258" +" or-part_258" +"(symbol?" +" s_711)))" +" s_711" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_65" +" s_711))))" +"((id:field47_0)" +"(let-values(((s_321)" +"(cdr" +" s_86)))" +"(let-values(((s_394)" +"(if(syntax?$1" +" s_321)" +"(syntax-e$1" +" s_321)" +" s_321)))" +"(if(pair?" +" s_394)" +"(let-values(((id:field48_0)" +"(let-values(((s_64)" +"(car" +" s_394)))" +"(let-values(((s_322)" +"(if(syntax?$1" +" s_64)" +"(syntax-e$1" +" s_64)" +" s_64)))" +"(let-values(((flat-s_46)" +"(to-syntax-list.1" +" s_322)))" +"(if(not" +" flat-s_46)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_65))" +"(let-values()" +"(let-values(((id:field_0)" +"(let-values(((lst_100)" +" flat-s_46))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_100)))" +"((letrec-values(((for-loop_116)" +"(lambda(id:field_1" +" lst_401)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_401)" +"(let-values(((s_66)" +"(unsafe-car" +" lst_401))" +"((rest_234)" +"(unsafe-cdr" +" lst_401)))" +"(let-values(((id:field_2)" +"(let-values(((id:field_3)" +" id:field_1))" +"(let-values(((id:field_4)" +"(let-values()" +"(let-values(((id:field49_0)" +"(let-values()" +"(if(let-values(((or-part_385)" +"(if(syntax?$1" +" s_66)" +"(symbol?" +"(syntax-e$1" +" s_66))" +" #f)))" +"(if or-part_385" +" or-part_385" +"(symbol?" +" s_66)))" +" s_66" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_65" +" s_66)))))" +"(cons" +" id:field49_0" +" id:field_3)))))" +"(values" +" id:field_4)))))" +"(if(not" +" #f)" +"(for-loop_116" +" id:field_2" +" rest_234)" +" id:field_2)))" +" id:field_1)))))" +" for-loop_116)" +" null" +" lst_100)))))" +"(reverse$1" +" id:field_0))))))))" +"(()" +"(let-values(((s_204)" +"(cdr" +" s_394)))" +"(let-values(((s_406)" +"(if(syntax?$1" +" s_204)" +"(syntax-e$1" +" s_204)" +" s_204)))" +"(if(null?" +" s_406)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_65))))))" +"(values" +" id:field48_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_65))))))" +"(values" +" id:struct46_0" +" id:field47_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_65))))))" +"(values" +" struct43_0" +" id:struct44_0" +" id:field45_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_65)))))" +"(values" +" #t" +" struct40_1" +" id:struct41_1" +" id:field42_1))))))" +"(begin" +"(parse-struct!" +" id:struct41_0" +" orig-s_61" +" id:field42_0" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4)" +"(values" +" null" +"(list" +" spec_0))))))" +"(if(unsafe-fx<" +" index_7" +" 8)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_63" +" all-from50_0" +" mod-path51_0)" +"(let-values(((s_409)" +" disarmed-spec_0))" +"(let-values(((orig-s_66)" +" s_409))" +"(let-values(((all-from50_1" +" mod-path51_1)" +"(let-values(((s_712)" +"(if(syntax?$1" +" s_409)" +"(syntax-e$1" +" s_409)" +" s_409)))" +"(if(pair?" +" s_712)" +"(let-values(((all-from52_0)" +"(let-values(((s_417)" +"(car" +" s_712)))" +" s_417))" +"((mod-path53_0)" +"(let-values(((s_207)" +"(cdr" +" s_712)))" +"(let-values(((s_208)" +"(if(syntax?$1" +" s_207)" +"(syntax-e$1" +" s_207)" +" s_207)))" +"(if(pair?" +" s_208)" +"(let-values(((mod-path54_0)" +"(let-values(((s_93)" +"(car" +" s_208)))" +" s_93))" +"(()" +"(let-values(((s_713)" +"(cdr" +" s_208)))" +"(let-values(((s_323)" +"(if(syntax?$1" +" s_713)" +"(syntax-e$1" +" s_713)" +" s_713)))" +"(if(null?" +" s_323)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66))))))" +"(values" +" mod-path54_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66))))))" +"(values" +" all-from52_0" +" mod-path53_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_66)))))" +"(values" +" #t" +" all-from50_1" +" mod-path51_1))))))" +"(begin" +"(parse-all-from" +" mod-path51_0" +" orig-s_61" +" self_28" +" null" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4" +" ctx_102)" +"(values" +" null" +"(list" +" spec_0))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_64" +" all-from-except55_0" +" mod-path56_0" +" id57_0)" +"(let-values(((s_210)" +" disarmed-spec_0))" +"(let-values(((orig-s_67)" +" s_210))" +"(let-values(((all-from-except55_1" +" mod-path56_1" +" id57_1)" +"(let-values(((s_98)" +"(if(syntax?$1" +" s_210)" +"(syntax-e$1" +" s_210)" +" s_210)))" +"(if(pair?" +" s_98)" +"(let-values(((all-from-except58_0)" +"(let-values(((s_714)" +"(car" +" s_98)))" +" s_714))" +"((mod-path59_0" +" id60_0)" +"(let-values(((s_102)" +"(cdr" +" s_98)))" +"(let-values(((s_154)" +"(if(syntax?$1" +" s_102)" +"(syntax-e$1" +" s_102)" +" s_102)))" +"(if(pair?" +" s_154)" +"(let-values(((mod-path61_0)" +"(let-values(((s_482)" +"(car" +" s_154)))" +" s_482))" +"((id62_0)" +"(let-values(((s_483)" +"(cdr" +" s_154)))" +"(let-values(((s_715)" +"(if(syntax?$1" +" s_483)" +"(syntax-e$1" +" s_483)" +" s_483)))" +"(let-values(((flat-s_47)" +"(to-syntax-list.1" +" s_715)))" +"(if(not" +" flat-s_47)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_67))" +"(let-values()" +"(let-values(((id_127)" +"(let-values(((lst_402)" +" flat-s_47))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_402)))" +"((letrec-values(((for-loop_305)" +"(lambda(id_128" +" lst_403)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_403)" +"(let-values(((s_326)" +"(unsafe-car" +" lst_403))" +"((rest_235)" +"(unsafe-cdr" +" lst_403)))" +"(let-values(((id_109)" +"(let-values(((id_129)" +" id_128))" +"(let-values(((id_130)" +"(let-values()" +"(let-values(((id63_0)" +"(let-values()" +"(if(let-values(((or-part_386)" +"(if(syntax?$1" +" s_326)" +"(symbol?" +"(syntax-e$1" +" s_326))" +" #f)))" +"(if or-part_386" +" or-part_386" +"(symbol?" +" s_326)))" +" s_326" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_67" +" s_326)))))" +"(cons" +" id63_0" +" id_129)))))" +"(values" +" id_130)))))" +"(if(not" +" #f)" +"(for-loop_305" +" id_109" +" rest_235)" +" id_109)))" +" id_128)))))" +" for-loop_305)" +" null" +" lst_402)))))" +"(reverse$1" +" id_127)))))))))" +"(values" +" mod-path61_0" +" id62_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_67))))))" +"(values" +" all-from-except58_0" +" mod-path59_0" +" id60_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_67)))))" +"(values" +" #t" +" all-from-except55_1" +" mod-path56_1" +" id57_1))))))" +"(begin" +"(parse-all-from" +" mod-path56_0" +" orig-s_61" +" self_28" +" id57_0" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4" +" ctx_102)" +"(values" +" null" +"(list" +" spec_0))))))))" +"(if(unsafe-fx<" +" index_7" +" 11)" +"(if(unsafe-fx<" +" index_7" +" 10)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_65" +" all-defined64_0)" +"(let-values(((s_214)" +" disarmed-spec_0))" +"(let-values(((orig-s_68)" +" s_214))" +"(let-values(((all-defined64_1)" +"(let-values(((s_395)" +"(if(syntax?$1" +" s_214)" +"(syntax-e$1" +" s_214)" +" s_214)))" +"(if(pair?" +" s_395)" +"(let-values(((all-defined65_0)" +"(let-values(((s_716)" +"(car" +" s_395)))" +" s_716))" +"(()" +"(let-values(((s_494)" +"(cdr" +" s_395)))" +"(let-values(((s_111)" +"(if(syntax?$1" +" s_494)" +"(syntax-e$1" +" s_494)" +" s_494)))" +"(if(null?" +" s_111)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_68))))))" +"(values" +" all-defined65_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_68)))))" +"(values" +" #t" +" all-defined64_1))))))" +"(begin" +"(parse-all-from-module" +" self_28" +" spec_0" +" orig-s_61" +" null" +" #f" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4)" +"(values" +" null" +"(list" +" spec_0))))))" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_66" +" all-defined-except66_0" +" id67_0)" +"(let-values(((s_717)" +" disarmed-spec_0))" +"(let-values(((orig-s_69)" +" s_717))" +"(let-values(((all-defined-except66_1" +" id67_1)" +"(let-values(((s_217)" +"(if(syntax?$1" +" s_717)" +"(syntax-e$1" +" s_717)" +" s_717)))" +"(if(pair?" +" s_217)" +"(let-values(((all-defined-except68_0)" +"(let-values(((s_330)" +"(car" +" s_217)))" +" s_330))" +"((id69_0)" +"(let-values(((s_218)" +"(cdr" +" s_217)))" +"(let-values(((s_219)" +"(if(syntax?$1" +" s_218)" +"(syntax-e$1" +" s_218)" +" s_218)))" +"(let-values(((flat-s_48)" +"(to-syntax-list.1" +" s_219)))" +"(if(not" +" flat-s_48)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_69))" +"(let-values()" +"(let-values(((id_131)" +"(let-values(((lst_404)" +" flat-s_48))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_404)))" +"((letrec-values(((for-loop_306)" +"(lambda(id_132" +" lst_405)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_405)" +"(let-values(((s_498)" +"(unsafe-car" +" lst_405))" +"((rest_236)" +"(unsafe-cdr" +" lst_405)))" +"(let-values(((id_133)" +"(let-values(((id_134)" +" id_132))" +"(let-values(((id_30)" +"(let-values()" +"(let-values(((id70_0)" +"(let-values()" +"(if(let-values(((or-part_387)" +"(if(syntax?$1" +" s_498)" +"(symbol?" +"(syntax-e$1" +" s_498))" +" #f)))" +"(if or-part_387" +" or-part_387" +"(symbol?" +" s_498)))" +" s_498" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_69" +" s_498)))))" +"(cons" +" id70_0" +" id_134)))))" +"(values" +" id_30)))))" +"(if(not" +" #f)" +"(for-loop_306" +" id_133" +" rest_236)" +" id_133)))" +" id_132)))))" +" for-loop_306)" +" null" +" lst_404)))))" +"(reverse$1" +" id_131)))))))))" +"(values" +" all-defined-except68_0" +" id69_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_69)))))" +"(values" +" #t" +" all-defined-except66_1" +" id67_1))))))" +"(begin" +"(parse-all-from-module" +" self_28" +" spec_0" +" orig-s_61" +" id67_0" +" #f" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4)" +"(values" +" null" +"(list" +" spec_0)))))))" +"(if(unsafe-fx<" +" index_7" +" 12)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_67" +" prefix-all-defined71_0" +" id:prefix72_0)" +"(let-values(((s_504)" +" disarmed-spec_0))" +"(let-values(((orig-s_70)" +" s_504))" +"(let-values(((prefix-all-defined71_1" +" id:prefix72_1)" +"(let-values(((s_718)" +"(if(syntax?$1" +" s_504)" +"(syntax-e$1" +" s_504)" +" s_504)))" +"(if(pair?" +" s_718)" +"(let-values(((prefix-all-defined73_0)" +"(let-values(((s_507)" +"(car" +" s_718)))" +" s_507))" +"((id:prefix74_0)" +"(let-values(((s_719)" +"(cdr" +" s_718)))" +"(let-values(((s_720)" +"(if(syntax?$1" +" s_719)" +"(syntax-e$1" +" s_719)" +" s_719)))" +"(if(pair?" +" s_720)" +"(let-values(((id:prefix75_0)" +"(let-values(((s_721)" +"(car" +" s_720)))" +"(if(let-values(((or-part_388)" +"(if(syntax?$1" +" s_721)" +"(symbol?" +"(syntax-e$1" +" s_721))" +" #f)))" +"(if or-part_388" +" or-part_388" +"(symbol?" +" s_721)))" +" s_721" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_70" +" s_721))))" +"(()" +"(let-values(((s_722)" +"(cdr" +" s_720)))" +"(let-values(((s_462)" +"(if(syntax?$1" +" s_722)" +"(syntax-e$1" +" s_722)" +" s_722)))" +"(if(null?" +" s_462)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_70))))))" +"(values" +" id:prefix75_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_70))))))" +"(values" +" prefix-all-defined73_0" +" id:prefix74_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_70)))))" +"(values" +" #t" +" prefix-all-defined71_1" +" id:prefix72_1))))))" +"(begin" +"(parse-all-from-module" +" self_28" +" spec_0" +" orig-s_61" +" null" +"(syntax-e$1" +" id:prefix72_0)" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4)" +"(values" +" null" +"(list" +" spec_0))))))" +"(if(unsafe-fx<" +" index_7" +" 13)" +"(let-values()" +"(let-values((()" +"(begin" +"(check-nested_1" +" 'phaseless)" +"(values))))" +"(let-values(((ok?_68" +" prefix-all-defined-except76_0" +" id:prefix77_0" +" id78_0)" +"(let-values(((s_235)" +" disarmed-spec_0))" +"(let-values(((orig-s_71)" +" s_235))" +"(let-values(((prefix-all-defined-except76_1" +" id:prefix77_1" +" id78_1)" +"(let-values(((s_339)" +"(if(syntax?$1" +" s_235)" +"(syntax-e$1" +" s_235)" +" s_235)))" +"(if(pair?" +" s_339)" +"(let-values(((prefix-all-defined-except79_0)" +"(let-values(((s_343)" +"(car" +" s_339)))" +" s_343))" +"((id:prefix80_0" +" id81_0)" +"(let-values(((s_344)" +"(cdr" +" s_339)))" +"(let-values(((s_345)" +"(if(syntax?$1" +" s_344)" +"(syntax-e$1" +" s_344)" +" s_344)))" +"(if(pair?" +" s_345)" +"(let-values(((id:prefix82_0)" +"(let-values(((s_509)" +"(car" +" s_345)))" +"(if(let-values(((or-part_389)" +"(if(syntax?$1" +" s_509)" +"(symbol?" +"(syntax-e$1" +" s_509))" +" #f)))" +"(if or-part_389" +" or-part_389" +"(symbol?" +" s_509)))" +" s_509" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_71" +" s_509))))" +"((id83_0)" +"(let-values(((s_510)" +"(cdr" +" s_345)))" +"(let-values(((s_511)" +"(if(syntax?$1" +" s_510)" +"(syntax-e$1" +" s_510)" +" s_510)))" +"(let-values(((flat-s_49)" +"(to-syntax-list.1" +" s_511)))" +"(if(not" +" flat-s_49)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_71))" +"(let-values()" +"(let-values(((id_135)" +"(let-values(((lst_4)" +" flat-s_49))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_4)))" +"((letrec-values(((for-loop_307)" +"(lambda(id_136" +" lst_406)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_406)" +"(let-values(((s_723)" +"(unsafe-car" +" lst_406))" +"((rest_237)" +"(unsafe-cdr" +" lst_406)))" +"(let-values(((id_137)" +"(let-values(((id_138)" +" id_136))" +"(let-values(((id_139)" +"(let-values()" +"(let-values(((id84_2)" +"(let-values()" +"(if(let-values(((or-part_390)" +"(if(syntax?$1" +" s_723)" +"(symbol?" +"(syntax-e$1" +" s_723))" +" #f)))" +"(if or-part_390" +" or-part_390" +"(symbol?" +" s_723)))" +" s_723" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_71" +" s_723)))))" +"(cons" +" id84_2" +" id_138)))))" +"(values" +" id_139)))))" +"(if(not" +" #f)" +"(for-loop_307" +" id_137" +" rest_237)" +" id_137)))" +" id_136)))))" +" for-loop_307)" +" null" +" lst_4)))))" +"(reverse$1" +" id_135)))))))))" +"(values" +" id:prefix82_0" +" id83_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_71))))))" +"(values" +" prefix-all-defined-except79_0" +" id:prefix80_0" +" id81_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_71)))))" +"(values" +" #t" +" prefix-all-defined-except76_1" +" id:prefix77_1" +" id78_1))))))" +"(begin" +"(parse-all-from-module" +" self_28" +" spec_0" +" orig-s_61" +" id78_0" +"(syntax-e$1" +" id:prefix77_0)" +" at-phase_13" +" ns_124" +" rp_1" +" protected?_4)" +"(values" +" null" +"(list" +" spec_0))))))" +"(let-values()" +"(let-values(((ok?_69" +" expand85_0" +" id86_0" +" datum87_0)" +"(let-values(((s_724)" +" disarmed-spec_0))" +"(let-values(((orig-s_72)" +" s_724))" +"(let-values(((expand85_1" +" id86_1" +" datum87_1)" +"(let-values(((s_249)" +"(if(syntax?$1" +" s_724)" +"(syntax-e$1" +" s_724)" +" s_724)))" +"(if(pair?" +" s_249)" +"(let-values(((expand88_0)" +"(let-values(((s_250)" +"(car" +" s_249)))" +" s_250))" +"((id89_1" +" datum90_0)" +"(let-values(((s_463)" +"(cdr" +" s_249)))" +"(let-values(((s_251)" +"(if(syntax?$1" +" s_463)" +"(syntax-e$1" +" s_463)" +" s_463)))" +"(if(pair?" +" s_251)" +"(let-values(((id91_1" +" datum92_0)" +"(let-values(((s_725)" +"(car" +" s_251)))" +"(let-values(((s_253)" +"(if(syntax?$1" +" s_725)" +"(syntax-e$1" +" s_725)" +" s_725)))" +"(if(pair?" +" s_253)" +"(let-values(((id93_0)" +"(let-values(((s_726)" +"(car" +" s_253)))" +"(if(let-values(((or-part_391)" +"(if(syntax?$1" +" s_726)" +"(symbol?" +"(syntax-e$1" +" s_726))" +" #f)))" +"(if or-part_391" +" or-part_391" +"(symbol?" +" s_726)))" +" s_726" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_72" +" s_726))))" +"((datum94_0)" +"(let-values(((s_364)" +"(cdr" +" s_253)))" +" s_364)))" +"(values" +" id93_0" +" datum94_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_72)))))" +"(()" +"(let-values(((s_365)" +"(cdr" +" s_251)))" +"(let-values(((s_366)" +"(if(syntax?$1" +" s_365)" +"(syntax-e$1" +" s_365)" +" s_365)))" +"(if(null?" +" s_366)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_72))))))" +"(values" +" id91_1" +" datum92_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_72))))))" +"(values" +" expand88_0" +" id89_1" +" datum90_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_72)))))" +"(values" +" #t" +" expand85_1" +" id86_1" +" datum87_1))))))" +"(let-values(((ok?_70" +" expand95_0" +" form96_0)" +"(let-values(((s_367)" +" disarmed-spec_0))" +"(let-values(((orig-s_73)" +" s_367))" +"(let-values(((expand95_1" +" form96_1)" +"(let-values(((s_370)" +"(if(syntax?$1" +" s_367)" +"(syntax-e$1" +" s_367)" +" s_367)))" +"(if(pair?" +" s_370)" +"(let-values(((expand97_0)" +"(let-values(((s_373)" +"(car" +" s_370)))" +" s_373))" +"((form98_0)" +"(let-values(((s_374)" +"(cdr" +" s_370)))" +"(let-values(((s_375)" +"(if(syntax?$1" +" s_374)" +"(syntax-e$1" +" s_374)" +" s_374)))" +"(if(pair?" +" s_375)" +"(let-values(((form99_0)" +"(let-values(((s_727)" +"(car" +" s_375)))" +" s_727))" +"(()" +"(let-values(((s_728)" +"(cdr" +" s_375)))" +"(let-values(((s_729)" +"(if(syntax?$1" +" s_728)" +"(syntax-e$1" +" s_728)" +" s_728)))" +"(if(null?" +" s_729)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_73))))))" +"(values" +" form99_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_73))))))" +"(values" +" expand97_0" +" form98_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_73)))))" +"(values" +" #t" +" expand95_1" +" form96_1))))))" +"(let-values(((exp-spec_0)" +"(let-values(((temp104_4)" +" form96_0)" +"((temp105_4)" +"(let-values(((v_254)" +" ctx_102))" +"(let-values(((the-struct_98)" +" v_254))" +"(if(expand-context/outer?" +" the-struct_98)" +"(let-values(((def-ctx-scopes106_0)" +"(box" +" null))" +"((inner107_0)" +"(let-values(((the-struct_99)" +"(root-expand-context/outer-inner" +" v_254)))" +"(if(expand-context/inner?" +" the-struct_99)" +"(let-values(((stops108_0)" +"(free-id-set" +" at-phase_13" +"(list" +"(core-id" +" 'begin" +" at-phase_13)))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_99)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_99)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_99)" +"(root-expand-context/inner-defined-syms" +" the-struct_99)" +"(root-expand-context/inner-counter" +" the-struct_99)" +"(root-expand-context/inner-lift-key" +" the-struct_99)" +"(expand-context/inner-to-parsed?" +" the-struct_99)" +"(expand-context/inner-phase" +" the-struct_99)" +"(expand-context/inner-namespace" +" the-struct_99)" +"(expand-context/inner-just-once?" +" the-struct_99)" +"(expand-context/inner-module-begin-k" +" the-struct_99)" +"(expand-context/inner-allow-unbound?" +" the-struct_99)" +"(expand-context/inner-in-local-expand?" +" the-struct_99)" +" stops108_0" +"(expand-context/inner-declared-submodule-names" +" the-struct_99)" +"(expand-context/inner-lifts" +" the-struct_99)" +"(expand-context/inner-lift-envs" +" the-struct_99)" +"(expand-context/inner-module-lifts" +" the-struct_99)" +"(expand-context/inner-require-lifts" +" the-struct_99)" +"(expand-context/inner-to-module-lifts" +" the-struct_99)" +"(expand-context/inner-requires+provides" +" the-struct_99)" +"(expand-context/inner-observer" +" the-struct_99)" +"(expand-context/inner-for-serializable?" +" the-struct_99)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_99)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_99)))))" +"(expand-context/outer1.1" +" inner107_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_98)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_98)" +"(root-expand-context/outer-frame-id" +" the-struct_98)" +"(expand-context/outer-context" +" the-struct_98)" +"(expand-context/outer-env" +" the-struct_98)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_98)" +"(expand-context/outer-scopes" +" the-struct_98)" +" def-ctx-scopes106_0" +"(expand-context/outer-binding-layer" +" the-struct_98)" +"(expand-context/outer-reference-records" +" the-struct_98)" +"(expand-context/outer-only-immediate?" +" the-struct_98)" +"(expand-context/outer-need-eventually-defined" +" the-struct_98)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_98)" +"(expand-context/outer-name" +" the-struct_98)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_98))))))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" temp104_4" +" temp105_4))))" +"(let-values((()" +"(begin" +"(if(if(pair?" +"(syntax-e$1" +" exp-spec_0))" +"(if(identifier?" +"(car" +"(syntax-e$1" +" exp-spec_0)))" +"(eq?" +" 'begin" +"(core-form-sym" +" exp-spec_0" +" at-phase_13))" +" #f)" +" #f)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"expansion was not a `begin' sequence\"" +" orig-s_61" +" spec_0)))" +"(values))))" +"(let-values(((ok?_71" +" begin100_0" +" spec101_0)" +"(let-values(((s_379)" +" exp-spec_0))" +"(let-values(((orig-s_74)" +" s_379))" +"(let-values(((begin100_1" +" spec101_1)" +"(let-values(((s_380)" +"(if(syntax?$1" +" s_379)" +"(syntax-e$1" +" s_379)" +" s_379)))" +"(if(pair?" +" s_380)" +"(let-values(((begin102_0)" +"(let-values(((s_730)" +"(car" +" s_380)))" +" s_730))" +"((spec103_0)" +"(let-values(((s_464)" +"(cdr" +" s_380)))" +"(let-values(((s_382)" +"(if(syntax?$1" +" s_464)" +"(syntax-e$1" +" s_464)" +" s_464)))" +"(let-values(((flat-s_50)" +"(to-syntax-list.1" +" s_382)))" +"(if(not" +" flat-s_50)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_74))" +"(let-values()" +" flat-s_50)))))))" +"(values" +" begin102_0" +" spec103_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_74)))))" +"(values" +" #t" +" begin100_1" +" spec101_1))))))" +"(let-values(((track-stxes_9" +" exp-specs_9)" +"(loop_115" +" spec101_0" +" at-phase_13" +" protected?_4" +" layer_6)))" +"(values" +"(list*" +" spec_0" +" exp-spec_0" +" track-stxes_9)" +" exp-specs_9)))))))))))))))))))))" +"(values" +"(cons" +" track-stxes1_0" +" track-stxes_3)" +"(cons" +" exp-specs2_0" +" exp-specs_3))))))" +"(values" +" track-stxes_4" +" exp-specs_4)))))" +"(if(not #f)" +"(for-loop_91" +" track-stxes_2" +" exp-specs_2" +" rest_233)" +"(values" +" track-stxes_2" +" exp-specs_2))))" +"(values" +" track-stxes_1" +" exp-specs_1))))))" +" for-loop_91)" +" null" +" null" +" lst_73)))))" +"(values(reverse$1 track-stxes_0)(reverse$1 exp-specs_0)))))" +"(values(apply append track-stxess_0)(apply append exp-specss_0)))))))" +" loop_115)" +" specs_0" +" phase_41" +" #f" +" 'raw)))))" +"(define-values" +"(parse-identifier!)" +"(lambda(spec_1 orig-s_75 sym_101 at-phase_14 ns_125 rp_2 protected?_5)" +"(begin" +"(let-values(((b_91)(resolve+shift/extra-inspector spec_1 at-phase_14 ns_125)))" +"(let-values((()" +"(begin" +"(if b_91" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" \"provided identifier is not defined or required\"" +" orig-s_75" +" spec_1)))" +"(values))))" +"(let-values(((as-transformer?_6)(binding-for-transformer? b_91 spec_1 at-phase_14 ns_125)))" +"(let-values(((immed-b_0)" +"(let-values(((temp120_4) #t))" +"(resolve+shift30.1 #f #f #f #f #f #f temp120_4 #t #f #f spec_1 at-phase_14))))" +"(let-values(((protected?116_0) protected?_5)((as-transformer?117_0) as-transformer?_6))" +"(add-provide!107.1" +" protected?116_0" +" as-transformer?117_0" +" rp_2" +" sym_101" +" at-phase_14" +" b_91" +" immed-b_0" +" spec_1" +" orig-s_75)))))))))" +"(define-values" +"(parse-struct!)" +"(lambda(id:struct_0 orig-s_76 fields_0 at-phase_15 ns_126 rp_3 protected?_6)" +"(begin" +"(let-values(((mk_0)" +"(lambda(fmt_1)" +"(begin" +" 'mk" +"(let-values(((sym_102)(string->symbol(format fmt_1(syntax-e$1 id:struct_0)))))" +"(datum->syntax$1 id:struct_0 sym_102 id:struct_0))))))" +"(let-values(((mk2_0)" +"(lambda(fmt_2 field-id_0)" +"(begin" +" 'mk2" +"(let-values(((sym_103)" +"(string->symbol" +"(format fmt_2(syntax-e$1 id:struct_0)(syntax-e$1 field-id_0)))))" +"(datum->syntax$1 id:struct_0 sym_103 id:struct_0))))))" +"(begin" +" (let-values (((lst_407) (list \"~a\" \"make-~a\" \"struct:~a\" \"~a?\")))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_407)))" +"((letrec-values(((for-loop_308)" +"(lambda(lst_408)" +"(begin" +" 'for-loop" +"(if(pair? lst_408)" +"(let-values(((fmt_3)(unsafe-car lst_408))((rest_238)(unsafe-cdr lst_408)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((id_140)(mk_0 fmt_3)))" +"(parse-identifier!" +" id_140" +" orig-s_76" +"(syntax-e$1 id_140)" +" at-phase_15" +" ns_126" +" rp_3" +" protected?_6)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_308 rest_238)(values))))" +"(values))))))" +" for-loop_308)" +" lst_407)))" +"(void)" +"(let-values(((lst_409) fields_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_409)))" +"((letrec-values(((for-loop_309)" +"(lambda(lst_410)" +"(begin" +" 'for-loop" +"(if(pair? lst_410)" +"(let-values(((field_0)(unsafe-car lst_410))((rest_239)(unsafe-cdr lst_410)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((get-id_0)" +" (mk2_0 \"~a-~a\" field_0)))" +"(let-values(((set-id_0)" +"(mk2_0" +" \"set-~a-~a!\"" +" field_0)))" +"(begin" +"(parse-identifier!" +" get-id_0" +" orig-s_76" +"(syntax-e$1 get-id_0)" +" at-phase_15" +" ns_126" +" rp_3" +" protected?_6)" +"(parse-identifier!" +" set-id_0" +" orig-s_76" +"(syntax-e$1 set-id_0)" +" at-phase_15" +" ns_126" +" rp_3" +" protected?_6)))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_309 rest_239)(values))))" +"(values))))))" +" for-loop_309)" +" lst_409)))" +"(void)))))))" +"(define-values" +"(parse-all-from)" +"(lambda(mod-path-stx_0 orig-s_77 self_29 except-ids_0 at-phase_16 ns_127 rp_4 protected?_7 ctx_103)" +"(begin" +"(let-values(((mod-path_33)(syntax->datum$1 mod-path-stx_0)))" +"(let-values((()" +"(begin" +"(if(1/module-path? mod-path_33)" +"(void)" +"(let-values()" +" (raise-syntax-error$1 provide-form-name \"not a module path\" orig-s_77 mod-path-stx_0)))" +"(values))))" +"(let-values(((mpi_51)(module-path->mpi/context mod-path_33 ctx_103)))" +"(parse-all-from-module mpi_51 #f orig-s_77 except-ids_0 #f at-phase_16 ns_127 rp_4 protected?_7)))))))" +"(define-values" +"(parse-all-from-module)" +"(lambda(mpi_52 matching-stx_0 orig-s_78 except-ids_1 prefix-sym_0 at-phase_17 ns_26 rp_5 protected?_8)" +"(begin" +"(let-values(((requireds_2)(extract-module-requires rp_5 mpi_52 at-phase_17)))" +"(let-values(((phase-desc_0)" +"(lambda()" +"(begin" +" 'phase-desc" +"(if(zero-phase? at-phase_17)" +" (let-values () \"\")" +"(if(label-phase? at-phase_17)" +" (let-values () \" for-label\")" +" (let-values () (format \" for phase ~a\" at-phase_17))))))))" +"(let-values((()" +"(begin" +"(if requireds_2" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +" (format \"cannot provide from a module without a matching require~a\" (phase-desc_0))" +" orig-s_78" +" matching-stx_0)))" +"(values))))" +"(let-values(((add-prefix_1)" +"(lambda(sym_104)" +"(begin" +" 'add-prefix" +" (if prefix-sym_0 (string->symbol (format \"~a~a\" prefix-sym_0 sym_104)) sym_104)))))" +"(let-values(((found_0)(make-hasheq)))" +"(begin" +"(let-values(((lst_411) requireds_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_411)))" +"((letrec-values(((for-loop_310)" +"(lambda(lst_283)" +"(begin" +" 'for-loop" +"(if(pair? lst_283)" +"(let-values(((i_191)(unsafe-car lst_283))" +"((rest_240)(unsafe-cdr lst_283)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((id_141)" +"(required-id i_191)))" +"(let-values(((phase_145)" +"(required-phase" +" i_191)))" +"(if(let-values(((or-part_392)" +"(if matching-stx_0" +"(not" +"(if(eqv?" +" phase_145" +" at-phase_17)" +"(free-identifier=?$1" +" id_141" +"(datum->syntax$1" +" matching-stx_0" +"(syntax-e$1" +" id_141))" +" phase_145" +" phase_145)" +" #f))" +" #f)))" +"(if or-part_392" +" or-part_392" +"(let-values(((lst_234)" +" except-ids_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_234)))" +"((letrec-values(((for-loop_311)" +"(lambda(result_119" +" lst_412)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_412)" +"(let-values(((except-id_0)" +"(unsafe-car" +" lst_412))" +"((rest_214)" +"(unsafe-cdr" +" lst_412)))" +"(let-values(((result_120)" +"(let-values()" +"(let-values(((result_121)" +"(let-values()" +"(let-values()" +"(if(free-identifier=?$1" +" id_141" +" except-id_0" +" phase_145" +" phase_145)" +"(hash-set!" +" found_0" +" except-id_0" +" #t)" +" #f)))))" +"(values" +" result_121)))))" +"(if(if(not" +"((lambda x_91" +" result_120)" +" except-id_0))" +"(not" +" #f)" +" #f)" +"(for-loop_311" +" result_120" +" rest_214)" +" result_120)))" +" result_119)))))" +" for-loop_311)" +" #f" +" lst_234)))))" +"(void)" +"(let-values()" +"(let-values(((b_92)" +"(resolve+shift/extra-inspector" +" id_141" +" phase_145" +" ns_26)))" +"(let-values(((immed-b_1)" +"(let-values(((temp132_2)" +" #t))" +"(resolve+shift30.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp132_2" +" #t" +" #f" +" #f" +" id_141" +" phase_145))))" +"(let-values(((temp122_4)" +"(add-prefix_1" +"(syntax-e$1" +" id_141)))" +"((phase123_0)" +" phase_145)" +"((b124_0)" +" b_92)" +"((immed-b125_0)" +" immed-b_1)" +"((id126_0)" +" id_141)" +"((orig-s127_0)" +" orig-s_78)" +"((protected?128_0)" +" protected?_8)" +"((temp129_3)" +"(required-as-transformer?" +" i_191)))" +"(add-provide!107.1" +" protected?128_0" +" temp129_3" +" rp_5" +" temp122_4" +" phase123_0" +" b124_0" +" immed-b125_0" +" id126_0" +" orig-s127_0)))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_310 rest_240)(values))))" +"(values))))))" +" for-loop_310)" +" lst_411)))" +"(void)" +"(if(=(hash-count found_0)(length except-ids_1))" +"(void)" +"(let-values()" +"(begin" +"(let-values(((lst_370) except-ids_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_370)))" +"((letrec-values(((for-loop_312)" +"(lambda(lst_372)" +"(begin" +" 'for-loop" +"(if(pair? lst_372)" +"(let-values(((except-id_1)(unsafe-car lst_372))" +"((rest_241)(unsafe-cdr lst_372)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(if(let-values(((or-part_156)" +"(hash-ref" +" found_0" +" except-id_1" +" #f)))" +"(if or-part_156" +" or-part_156" +"(let-values(((lst_373)" +" requireds_2))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_373)))" +"((letrec-values(((for-loop_313)" +"(lambda(result_122" +" lst_141)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_141)" +"(let-values(((i_192)" +"(unsafe-car" +" lst_141))" +"((rest_217)" +"(unsafe-cdr" +" lst_141)))" +"(let-values(((result_123)" +"(let-values()" +"(let-values(((result_124)" +"(let-values()" +"(let-values()" +"(let-values(((id_142)" +"(required-id" +" i_192)))" +"(let-values(((phase_146)" +"(required-phase" +" i_192)))" +"(free-identifier=?$1" +" id_142" +" except-id_1" +" phase_146" +" phase_146)))))))" +"(values" +" result_124)))))" +"(if(if(not" +"((lambda x_92" +" result_123)" +" i_192))" +"(not" +" #f)" +" #f)" +"(for-loop_313" +" result_123" +" rest_217)" +" result_123)))" +" result_122)))))" +" for-loop_313)" +" #f" +" lst_373)))))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" provide-form-name" +"(format" +"(if matching-stx_0" +" \"excluded identifier was not defined or required in the module~a\"" +" \"excluded identifier was not required from the specified module~a\")" +"(phase-desc_0))" +" orig-s_78" +" except-id_1))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_312 rest_241)(values))))" +"(values))))))" +" for-loop_312)" +" lst_370)))" +"(void)))))))))))))" +"(define-values(check-cross-phase-persistent-form)(lambda(bodys_13)(begin(check-body bodys_13))))" +"(define-values" +"(check-body)" +"(lambda(bodys_14)" +"(begin" +"(begin" +"(let-values(((lst_71) bodys_14))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_71)))" +"((letrec-values(((for-loop_90)" +"(lambda(lst_413)" +"(begin" +" 'for-loop" +"(if(pair? lst_413)" +"(let-values(((body_21)(unsafe-car lst_413))((rest_242)(unsafe-cdr lst_413)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((p_47)" +"(if(expanded+parsed? body_21)" +"(expanded+parsed-parsed" +" body_21)" +" body_21)))" +"(if(parsed-define-values? p_47)" +"(let-values()" +"(check-expr" +"(parsed-define-values-rhs p_47)" +"(length" +"(parsed-define-values-syms p_47))" +" p_47))" +"(if(let-values(((or-part_27)" +"(parsed-#%declare?" +" p_47)))" +"(if or-part_27" +" or-part_27" +"(let-values(((or-part_10)" +"(parsed-module?" +" p_47)))" +"(if or-part_10" +" or-part_10" +"(syntax?$1 p_47)))))" +"(let-values()(void))" +"(let-values()(disallow p_47))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_90 rest_242)(values))))" +"(values))))))" +" for-loop_90)" +" lst_71)))" +"(void)))))" +"(define-values" +"(check-expr)" +"(lambda(e_86 num-results_0 enclosing_15)" +"(begin" +"(if(let-values(((or-part_215)(parsed-lambda? e_86)))(if or-part_215 or-part_215(parsed-case-lambda? e_86)))" +"(let-values()(check-count 1 num-results_0 enclosing_15))" +"(if(parsed-quote? e_86)" +"(let-values()" +"(begin(check-datum(parsed-quote-datum e_86) e_86)(check-count 1 num-results_0 enclosing_15)))" +"(if(parsed-app? e_86)" +"(let-values()" +"(let-values(((rands_1)(parsed-app-rands e_86)))" +"(begin" +"(let-values(((lst_260) rands_1))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_260)))" +"((letrec-values(((for-loop_202)" +"(lambda(lst_261)" +"(begin" +" 'for-loop" +"(if(pair? lst_261)" +"(let-values(((rand_0)(unsafe-car lst_261))" +"((rest_138)(unsafe-cdr lst_261)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(check-expr rand_0 1 e_86))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_202 rest_138)(values))))" +"(values))))))" +" for-loop_202)" +" lst_260)))" +"(void)" +"(let-values(((tmp_64)(cross-phase-primitive-name(parsed-app-rator e_86))))" +"(if(if(equal? tmp_64 'cons) #t(equal? tmp_64 'list))" +"(let-values()(check-count 1 num-results_0 enclosing_15))" +"(if(equal? tmp_64 'make-struct-type)" +"(let-values()(check-count 5 num-results_0 enclosing_15))" +"(if(equal? tmp_64 'make-struct-type-property)" +"(let-values()(check-count 3 num-results_0 enclosing_15))" +"(if(equal? tmp_64 'gensym)" +"(let-values()" +"(if(let-values(((or-part_289)(= 0(length rands_1))))" +"(if or-part_289" +" or-part_289" +"(if(= 1(length rands_1))(quoted-string?(car rands_1)) #f)))" +"(void)" +"(let-values()(disallow e_86))))" +"(if(equal? tmp_64 'string->uninterned-symbol)" +"(let-values()" +"(if(if(= 1(length rands_1))(quoted-string?(car rands_1)) #f)" +"(void)" +"(let-values()(disallow e_86))))" +"(let-values()(disallow e_86)))))))))))" +"(void)))))))" +"(define-values" +"(check-count)" +"(lambda(is-num_0 expected-num_0 enclosing_16)" +"(begin(if(= is-num_0 expected-num_0)(void)(let-values()(disallow enclosing_16))))))" +"(define-values" +"(check-datum)" +"(lambda(d_38 e_73)" +"(begin" +"(if(let-values(((or-part_160)(number? d_38)))" +"(if or-part_160" +" or-part_160" +"(let-values(((or-part_164)(boolean? d_38)))" +"(if or-part_164" +" or-part_164" +"(let-values(((or-part_76)(symbol? d_38)))" +"(if or-part_76" +" or-part_76" +"(let-values(((or-part_77)(string? d_38)))(if or-part_77 or-part_77(bytes? d_38)))))))))" +"(let-values()(void))" +"(let-values()(disallow e_73))))))" +"(define-values" +"(quoted-string?)" +"(lambda(e_87)(begin(if(parsed-quote? e_87)(string?(parsed-quote-datum e_87)) #f))))" +"(define-values" +"(cross-phase-primitive-name)" +"(lambda(id_143)" +"(begin" +"(if(parsed-id? id_143)" +"(let-values()" +"(let-values(((b_93)(parsed-id-binding id_143)))" +"(if(module-binding? b_93)" +"(if(eq? runtime-module-name(1/module-path-index-resolve(module-binding-module b_93)))" +"(module-binding-sym b_93)" +" #f)" +" #f)))" +"(let-values() #f)))))" +"(define-values" +"(disallow)" +"(lambda(body_22)" +"(begin" +"(raise-syntax-error$1" +" 'module" +" \"not allowed in a cross-phase persistent module\"" +"(if(parsed? body_22)(datum->syntax$1 #f body_22(parsed-s body_22)) body_22)))))" +"(void" +"(add-core-form!*" +" 'module" +"(lambda(s_184 ctx_104)" +"(begin" +"(if(eq?(expand-context-context ctx_104) 'top-level)" +"(void)" +"(let-values()" +"(begin" +"(let-values(((obs_117)(expand-context-observer ctx_104)))" +"(if obs_117(let-values()(let-values()(call-expand-observe obs_117 'prim-module)))(void)))" +" (raise-syntax-error$1 #f \"allowed only at the top level\" s_184))))" +"(let-values()" +"(let-values(((s223_0) s_184)((ctx224_0) ctx_104)((temp225_3) #f))" +"(expand-module18.1 #f #f #f #f #f #f #f #f #f #f #f #f #f #f s223_0 ctx224_0 temp225_3)))))))" +"(void" +"(add-core-form!*" +" 'module*" +"(lambda(s_307 ctx_105)" +"(begin" +"(let-values(((obs_118)(expand-context-observer ctx_105)))" +"(if obs_118(let-values()(let-values()(call-expand-observe obs_118 'prim-module)))(void)))" +" (raise-syntax-error$1 #f \"illegal use (not in a module top-level)\" s_307)))))" +"(void" +"(add-core-form!*" +" '#%module-begin" +"(lambda(s_83 ctx_106)" +"(begin" +"(let-values(((obs_119)(expand-context-observer ctx_106)))" +"(if obs_119(let-values()(let-values()(call-expand-observe obs_119 'prim-module-begin)))(void)))" +"(if(eq?(expand-context-context ctx_106) 'module-begin)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not in a module-definition context\" s_83)))" +"(if(expand-context-module-begin-k ctx_106)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not currently transforming a module\" s_83)))" +"((expand-context-module-begin-k ctx_106)" +" s_83" +"(let-values(((v_35) ctx_106))" +"(let-values(((the-struct_100) v_35))" +"(if(expand-context/outer? the-struct_100)" +"(let-values(((inner226_0)" +"(let-values(((the-struct_101)(root-expand-context/outer-inner v_35)))" +"(if(expand-context/inner? the-struct_101)" +"(let-values(((module-begin-k227_0) #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes the-struct_101)" +"(root-expand-context/inner-top-level-bind-scope the-struct_101)" +"(root-expand-context/inner-all-scopes-stx the-struct_101)" +"(root-expand-context/inner-defined-syms the-struct_101)" +"(root-expand-context/inner-counter the-struct_101)" +"(root-expand-context/inner-lift-key the-struct_101)" +"(expand-context/inner-to-parsed? the-struct_101)" +"(expand-context/inner-phase the-struct_101)" +"(expand-context/inner-namespace the-struct_101)" +"(expand-context/inner-just-once? the-struct_101)" +" module-begin-k227_0" +"(expand-context/inner-allow-unbound? the-struct_101)" +"(expand-context/inner-in-local-expand? the-struct_101)" +"(expand-context/inner-stops the-struct_101)" +"(expand-context/inner-declared-submodule-names the-struct_101)" +"(expand-context/inner-lifts the-struct_101)" +"(expand-context/inner-lift-envs the-struct_101)" +"(expand-context/inner-module-lifts the-struct_101)" +"(expand-context/inner-require-lifts the-struct_101)" +"(expand-context/inner-to-module-lifts the-struct_101)" +"(expand-context/inner-requires+provides the-struct_101)" +"(expand-context/inner-observer the-struct_101)" +"(expand-context/inner-for-serializable? the-struct_101)" +"(expand-context/inner-should-not-encounter-macros? the-struct_101)))" +" (raise-argument-error 'struct-copy \"expand-context/inner?\" the-struct_101)))))" +"(expand-context/outer1.1" +" inner226_0" +"(root-expand-context/outer-post-expansion-scope the-struct_100)" +"(root-expand-context/outer-use-site-scopes the-struct_100)" +"(root-expand-context/outer-frame-id the-struct_100)" +"(expand-context/outer-context the-struct_100)" +"(expand-context/outer-env the-struct_100)" +"(expand-context/outer-post-expansion-scope-action the-struct_100)" +"(expand-context/outer-scopes the-struct_100)" +"(expand-context/outer-def-ctx-scopes the-struct_100)" +"(expand-context/outer-binding-layer the-struct_100)" +"(expand-context/outer-reference-records the-struct_100)" +"(expand-context/outer-only-immediate? the-struct_100)" +"(expand-context/outer-need-eventually-defined the-struct_100)" +"(expand-context/outer-current-introduction-scopes the-struct_100)" +"(expand-context/outer-name the-struct_100)))" +" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_100)))))))))" +"(void" +"(add-core-form!*" +" '#%declare" +"(lambda(s_412 ctx_107)" +"(begin" +"(let-values(((obs_120)(expand-context-observer ctx_107)))" +"(if obs_120(let-values()(let-values()(call-expand-observe obs_120 'prim-declare)))(void)))" +" (raise-syntax-error$1 #f \"not allowed outside of a module body\" s_412)))))" +"(define-values" +"(expand-module18.1)" +"(lambda(always-produce-compiled?1_0" +" always-produce-compiled?8_0" +" enclosing-all-scopes-stx3_0" +" enclosing-all-scopes-stx10_0" +" enclosing-is-cross-phase-persistent?4_0" +" enclosing-is-cross-phase-persistent?11_0" +" enclosing-requires+provides5_0" +" enclosing-requires+provides12_0" +" keep-enclosing-scope-at-phase2_0" +" keep-enclosing-scope-at-phase9_0" +" modules-being-compiled7_0" +" modules-being-compiled14_0" +" mpis-for-enclosing-reset6_0" +" mpis-for-enclosing-reset13_0" +" s15_0" +" init-ctx16_0" +" enclosing-self17_0)" +"(begin" +" 'expand-module18" +"(let-values(((s_16) s15_0))" +"(let-values(((init-ctx_0) init-ctx16_0))" +"(let-values(((enclosing-self_1) enclosing-self17_0))" +"(let-values(((always-produce-compiled?_0)(if always-produce-compiled?8_0 always-produce-compiled?1_0 #f)))" +"(let-values(((keep-enclosing-scope-at-phase_0)" +"(if keep-enclosing-scope-at-phase9_0 keep-enclosing-scope-at-phase2_0 #f)))" +"(let-values(((enclosing-all-scopes-stx_0)" +"(if enclosing-all-scopes-stx10_0 enclosing-all-scopes-stx3_0 #f)))" +"(let-values(((enclosing-is-cross-phase-persistent?_0)" +"(if enclosing-is-cross-phase-persistent?11_0" +" enclosing-is-cross-phase-persistent?4_0" +" #f)))" +"(let-values(((enclosing-r+p_1)" +"(if enclosing-requires+provides12_0 enclosing-requires+provides5_0 #f)))" +"(let-values(((mpis-for-enclosing-reset_0)" +"(if mpis-for-enclosing-reset13_0 mpis-for-enclosing-reset6_0 #f)))" +"(let-values(((modules-being-compiled_3)" +"(if modules-being-compiled14_0 modules-being-compiled7_0(make-hasheq))))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_121)(expand-context-observer init-ctx_0)))" +"(if obs_121" +"(let-values()" +"(let-values()(call-expand-observe obs_121 'prim-module)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-s_24)(syntax-disarm$1 s_16)))" +"(let-values(((ok?_72 module228_0 id:module-name229_0 initial-require230_0 body231_0)" +"(let-values(((s_491) disarmed-s_24))" +"(let-values(((orig-s_79) s_491))" +"(let-values(((module228_1" +" id:module-name229_1" +" initial-require230_1" +" body231_1)" +"(let-values(((s_316)" +"(if(syntax?$1 s_491)" +"(syntax-e$1 s_491)" +" s_491)))" +"(if(pair? s_316)" +"(let-values(((module232_0)" +"(let-values(((s_731)(car s_316)))" +" s_731))" +"((id:module-name233_0" +" initial-require234_0" +" body235_0)" +"(let-values(((s_476)(cdr s_316)))" +"(let-values(((s_477)" +"(if(syntax?$1 s_476)" +"(syntax-e$1 s_476)" +" s_476)))" +"(if(pair? s_477)" +"(let-values(((id:module-name236_0)" +"(let-values(((s_317)" +"(car" +" s_477)))" +"(if(let-values(((or-part_365)" +"(if(syntax?$1" +" s_317)" +"(symbol?" +"(syntax-e$1" +" s_317))" +" #f)))" +"(if or-part_365" +" or-part_365" +"(symbol?" +" s_317)))" +" s_317" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_79" +" s_317))))" +"((initial-require237_0" +" body238_0)" +"(let-values(((s_55)" +"(cdr" +" s_477)))" +"(let-values(((s_318)" +"(if(syntax?$1" +" s_55)" +"(syntax-e$1" +" s_55)" +" s_55)))" +"(if(pair?" +" s_318)" +"(let-values(((initial-require239_0)" +"(let-values(((s_492)" +"(car" +" s_318)))" +" s_492))" +"((body240_0)" +"(let-values(((s_388)" +"(cdr" +" s_318)))" +"(let-values(((s_732)" +"(if(syntax?$1" +" s_388)" +"(syntax-e$1" +" s_388)" +" s_388)))" +"(let-values(((flat-s_51)" +"(to-syntax-list.1" +" s_732)))" +"(if(not" +" flat-s_51)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_79))" +"(let-values()" +" flat-s_51)))))))" +"(values" +" initial-require239_0" +" body240_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_79))))))" +"(values" +" id:module-name236_0" +" initial-require237_0" +" body238_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_79))))))" +"(values" +" module232_0" +" id:module-name233_0" +" initial-require234_0" +" body235_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_79)))))" +"(values" +" #t" +" module228_1" +" id:module-name229_1" +" initial-require230_1" +" body231_1))))))" +"(let-values(((rebuild-s_14)" +"(let-values(((temp255_1) #t)((temp256_0) #t))" +"(keep-as-needed74.1" +" #f" +" #f" +" temp256_0" +" #t" +" temp255_1" +" #t" +" init-ctx_0" +" s_16))))" +"(let-values(((initial-require_0)(syntax->datum$1 initial-require230_0)))" +"(let-values((()" +"(begin" +"(if(let-values(((or-part_366) keep-enclosing-scope-at-phase_0))" +"(if or-part_366" +" or-part_366" +"(1/module-path? initial-require_0)))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"not a module path\"" +" s_16" +" initial-require230_0)))" +"(values))))" +"(let-values(((phase_147) 0))" +"(let-values(((module-name-sym_0)(syntax-e$1 id:module-name229_0)))" +"(let-values(((outside-scope_1)(new-scope 'module)))" +"(let-values(((inside-scope_0)(new-multi-scope module-name-sym_0)))" +"(let-values(((self_30)" +"(make-self-module-path-index" +"(if enclosing-self_1" +" module-name-sym_0" +"(string->uninterned-symbol" +"(symbol->string module-name-sym_0)))" +" enclosing-self_1)))" +"(let-values(((enclosing-mod_1)" +"(if enclosing-self_1" +" (1/module-path-index-join '(submod \"..\") self_30)" +" #f)))" +"(let-values((()" +"(begin" +"(if(if enclosing-mod_1" +" mpis-for-enclosing-reset_0" +" #f)" +"(let-values()" +"(set-box!" +" mpis-for-enclosing-reset_0" +"(cons" +" enclosing-mod_1" +"(unbox mpis-for-enclosing-reset_0))))" +"(void))" +"(values))))" +"(let-values(((apply-module-scopes_0)" +"(make-apply-module-scopes" +" outside-scope_1" +" inside-scope_0" +" init-ctx_0" +" keep-enclosing-scope-at-phase_0" +" self_30" +" enclosing-self_1" +" enclosing-mod_1)))" +"(let-values(((initial-require-s_0)" +"(apply-module-scopes_0 initial-require230_0)))" +"(let-values(((all-scopes-s_0)" +"(if enclosing-all-scopes-stx_0" +"(apply-module-scopes_0" +"(syntax-shift-phase-level$1" +" enclosing-all-scopes-stx_0" +" keep-enclosing-scope-at-phase_0))" +" initial-require-s_0)))" +"(let-values(((root-ctx_6)" +"(let-values(((temp257_0)" +"(if keep-enclosing-scope-at-phase_0" +"(root-expand-context-module-scopes" +" init-ctx_0)" +" null))" +"((outside-scope258_0)" +" outside-scope_1)" +"((inside-scope259_0)" +" inside-scope_0)" +"((all-scopes-s260_0)" +" all-scopes-s_0))" +"(make-root-expand-context11.1" +" all-scopes-s260_0" +" #t" +" temp257_0" +" #t" +" outside-scope258_0" +" #t" +" inside-scope259_0" +" #t))))" +"(let-values(((new-module-scopes_0)" +"(root-expand-context-module-scopes" +" root-ctx_6)))" +"(let-values(((frame-id_16)" +"(root-expand-context-frame-id" +" root-ctx_6)))" +"(let-values(((make-m-ns244_0)" +"(lambda(for-submodule?241_0" +" for-submodule?242_0" +" ns243_0)" +"(begin" +" 'make-m-ns244" +"(let-values(((ns_11) ns243_0))" +"(let-values(((for-submodule?_1)" +"(if for-submodule?242_0" +" for-submodule?241_0" +"(if enclosing-self_1" +" #t" +" #f))))" +"(let-values()" +"(let-values(((self262_0)" +" self_30)" +"((root-ctx263_0)" +" root-ctx_6)" +"((for-submodule?264_0)" +" for-submodule?_1))" +"(make-module-namespace50.1" +" for-submodule?264_0" +" self262_0" +" root-ctx263_0" +" ns_11)))))))))" +"(let-values()" +"(let-values()" +"(let-values(((m-ns_19)" +"(let-values(((temp265_1)" +"(expand-context-namespace" +" init-ctx_0)))" +"(make-m-ns244_0" +" #f" +" #f" +" temp265_1))))" +"(let-values(((ctx_108)" +"(let-values(((v_97)" +"(copy-root-expand-context" +" init-ctx_0" +" root-ctx_6)))" +"(let-values(((the-struct_102)" +" v_97))" +"(if(expand-context/outer?" +" the-struct_102)" +"(let-values(((post-expansion-scope-action266_0)" +" add-scope)" +"((inner267_0)" +"(let-values(((the-struct_103)" +"(root-expand-context/outer-inner" +" v_97)))" +"(if(expand-context/inner?" +" the-struct_103)" +"(let-values(((allow-unbound?268_0)" +" #f)" +"((namespace269_0)" +" m-ns_19)" +"((phase270_0)" +" phase_147)" +"((just-once?271_0)" +" #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_103)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_103)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_103)" +"(root-expand-context/inner-defined-syms" +" the-struct_103)" +"(root-expand-context/inner-counter" +" the-struct_103)" +"(root-expand-context/inner-lift-key" +" the-struct_103)" +"(expand-context/inner-to-parsed?" +" the-struct_103)" +" phase270_0" +" namespace269_0" +" just-once?271_0" +"(expand-context/inner-module-begin-k" +" the-struct_103)" +" allow-unbound?268_0" +"(expand-context/inner-in-local-expand?" +" the-struct_103)" +"(expand-context/inner-stops" +" the-struct_103)" +"(expand-context/inner-declared-submodule-names" +" the-struct_103)" +"(expand-context/inner-lifts" +" the-struct_103)" +"(expand-context/inner-lift-envs" +" the-struct_103)" +"(expand-context/inner-module-lifts" +" the-struct_103)" +"(expand-context/inner-require-lifts" +" the-struct_103)" +"(expand-context/inner-to-module-lifts" +" the-struct_103)" +"(expand-context/inner-requires+provides" +" the-struct_103)" +"(expand-context/inner-observer" +" the-struct_103)" +"(expand-context/inner-for-serializable?" +" the-struct_103)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_103)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_103)))))" +"(expand-context/outer1.1" +" inner267_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_102)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_102)" +"(root-expand-context/outer-frame-id" +" the-struct_102)" +"(expand-context/outer-context" +" the-struct_102)" +"(expand-context/outer-env" +" the-struct_102)" +" post-expansion-scope-action266_0" +"(expand-context/outer-scopes" +" the-struct_102)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_102)" +"(expand-context/outer-binding-layer" +" the-struct_102)" +"(expand-context/outer-reference-records" +" the-struct_102)" +"(expand-context/outer-only-immediate?" +" the-struct_102)" +"(expand-context/outer-need-eventually-defined" +" the-struct_102)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_102)" +"(expand-context/outer-name" +" the-struct_102)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_102))))))" +"(let-values(((bodys_15)" +"(let-values(((scoped-s_0)" +"(apply-module-scopes_0" +" disarmed-s_24)))" +"(let-values(((ok?_73" +" _272_0" +" _273_0" +" _274_0" +" body275_0)" +"(let-values(((s_406)" +" scoped-s_0))" +"(let-values(((orig-s_80)" +" s_406))" +"(let-values(((_272_1" +" _273_1" +" _274_1" +" body275_1)" +"(let-values(((s_89)" +"(if(syntax?$1" +" s_406)" +"(syntax-e$1" +" s_406)" +" s_406)))" +"(if(pair?" +" s_89)" +"(let-values(((_276_0)" +"(let-values(((s_152)" +"(car" +" s_89)))" +" s_152))" +"((_277_0" +" _278_0" +" body279_0)" +"(let-values(((s_153)" +"(cdr" +" s_89)))" +"(let-values(((s_90)" +"(if(syntax?$1" +" s_153)" +"(syntax-e$1" +" s_153)" +" s_153)))" +"(if(pair?" +" s_90)" +"(let-values(((_280_0)" +"(let-values(((s_91)" +"(car" +" s_90)))" +" s_91))" +"((_281_0" +" body282_0)" +"(let-values(((s_712)" +"(cdr" +" s_90)))" +"(let-values(((s_206)" +"(if(syntax?$1" +" s_712)" +"(syntax-e$1" +" s_712)" +" s_712)))" +"(if(pair?" +" s_206)" +"(let-values(((_283_0)" +"(let-values(((s_207)" +"(car" +" s_206)))" +" s_207))" +"((body284_0)" +"(let-values(((s_208)" +"(cdr" +" s_206)))" +"(let-values(((s_92)" +"(if(syntax?$1" +" s_208)" +"(syntax-e$1" +" s_208)" +" s_208)))" +"(let-values(((flat-s_2)" +"(to-syntax-list.1" +" s_92)))" +"(if(not" +" flat-s_2)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_80))" +"(let-values()" +" flat-s_2)))))))" +"(values" +" _283_0" +" body284_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_80))))))" +"(values" +" _280_0" +" _281_0" +" body282_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_80))))))" +"(values" +" _276_0" +" _277_0" +" _278_0" +" body279_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_80)))))" +"(values" +" #t" +" _272_1" +" _273_1" +" _274_1" +" body275_1))))))" +" body275_0))))" +"(let-values(((requires+provides_6)" +"(let-values(((self285_0)" +" self_30))" +"(make-requires+provides8.1" +" #f" +" #f" +" self285_0))))" +"(let-values(((defined-syms_10)" +"(root-expand-context-defined-syms" +" root-ctx_6)))" +"(let-values(((compiled-submodules_1)" +"(make-hasheq)))" +"(let-values(((compiled-module-box_0)" +"(box #f)))" +"(let-values(((mpis-to-reset_0)" +"(box null)))" +"(let-values(((initial-require!249_0)" +"(lambda(bind?247_0)" +"(begin" +" 'initial-require!249" +"(let-values(((bind?_3)" +" bind?247_0))" +"(let-values()" +"(if(not" +" keep-enclosing-scope-at-phase_0)" +"(let-values()" +"(let-values(((bind?291_0)" +" bind?_3)" +"((temp292_0)" +" 'module))" +"(perform-initial-require!42.1" +" bind?291_0" +" temp292_0" +" initial-require_0" +" self_30" +" all-scopes-s_0" +" m-ns_19" +" requires+provides_6)))" +"(let-values()" +"(begin" +"(add-required-module!" +" requires+provides_6" +" enclosing-mod_1" +" keep-enclosing-scope-at-phase_0" +" enclosing-is-cross-phase-persistent?_0)" +"(let-values(((enclosing-r+p294_0)" +" enclosing-r+p_1)" +"((enclosing-mod295_0)" +" enclosing-mod_1)" +"((keep-enclosing-scope-at-phase296_0)" +" keep-enclosing-scope-at-phase_0))" +"(add-enclosing-module-defined-and-required!67.1" +" enclosing-r+p294_0" +" requires+provides_6" +" enclosing-mod295_0" +" keep-enclosing-scope-at-phase296_0))" +"(let-values(((m-ns297_0)" +" m-ns_19)" +"((enclosing-mod298_0)" +" enclosing-mod_1)" +"((keep-enclosing-scope-at-phase299_0)" +" keep-enclosing-scope-at-phase_0))" +"(namespace-module-visit!104.1" +" #f" +" #f" +" m-ns297_0" +" enclosing-mod298_0" +" keep-enclosing-scope-at-phase299_0)))))))))))" +"(let-values()" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_122)" +"(expand-context-observer" +" init-ctx_0)))" +"(if obs_122" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_122" +" 'prepare-env)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((temp252_0)" +" #t))" +"(initial-require!249_0" +" temp252_0))" +"(values))))" +"(let-values(((again?_0)" +" #f))" +"(letrec-values(((module-begin-k_1)" +"(lambda(mb-s_0" +" mb-init-ctx_0)" +"(begin" +" 'module-begin-k" +"(let-values((()" +"(begin" +"(if again?_0" +"(let-values()" +"(begin" +"(requires+provides-reset!" +" requires+provides_6)" +"(let-values(((temp304_0)" +" #f))" +"(initial-require!249_0" +" temp304_0))" +"(hash-clear!" +" compiled-submodules_1)" +"(set-box!" +" compiled-module-box_0" +" #f)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(set! again?_0" +" #t)" +"(values))))" +"(let-values(((ctx_109)" +"(let-values(((v_126)" +" mb-init-ctx_0))" +"(let-values(((the-struct_43)" +" v_126))" +"(if(expand-context/outer?" +" the-struct_43)" +"(let-values(((inner305_0)" +"(let-values(((the-struct_104)" +"(root-expand-context/outer-inner" +" v_126)))" +"(if(expand-context/inner?" +" the-struct_104)" +"(let-values(((module-begin-k306_0)" +"(lambda(s_214" +" ctx_3)" +"(begin" +" 'module-begin-k306" +"(let-values(((new-requires+provides_0)" +"(let-values(((requires+provides314_0)" +" requires+provides_6))" +"(make-requires+provides8.1" +" requires+provides314_0" +" #t" +" self_30))))" +"(let-values(((requires+provides307_0)" +" requires+provides_6)" +"((compiled-submodules308_0)" +" compiled-submodules_1)" +"((compiled-module-box309_0)" +" compiled-module-box_0)" +"((requires+provides310_0)" +" new-requires+provides_0)" +"((compiled-submodules311_0)" +"(make-hasheq))" +"((compiled-module-box312_0)" +"(box" +" #f)))" +"(dynamic-wind" +"(lambda()" +"(begin" +"(set! requires+provides_6" +" requires+provides310_0)" +"(set! compiled-submodules_1" +" compiled-submodules311_0)" +"(set! compiled-module-box_0" +" compiled-module-box312_0)))" +"(lambda()" +"(module-begin-k_1" +" s_214" +" ctx_3))" +"(lambda()" +"(begin" +"(set! requires+provides_6" +" requires+provides307_0)" +"(set! compiled-submodules_1" +" compiled-submodules308_0)" +"(set! compiled-module-box_0" +" compiled-module-box309_0))))))))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_104)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_104)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_104)" +"(root-expand-context/inner-defined-syms" +" the-struct_104)" +"(root-expand-context/inner-counter" +" the-struct_104)" +"(root-expand-context/inner-lift-key" +" the-struct_104)" +"(expand-context/inner-to-parsed?" +" the-struct_104)" +"(expand-context/inner-phase" +" the-struct_104)" +"(expand-context/inner-namespace" +" the-struct_104)" +"(expand-context/inner-just-once?" +" the-struct_104)" +" module-begin-k306_0" +"(expand-context/inner-allow-unbound?" +" the-struct_104)" +"(expand-context/inner-in-local-expand?" +" the-struct_104)" +"(expand-context/inner-stops" +" the-struct_104)" +"(expand-context/inner-declared-submodule-names" +" the-struct_104)" +"(expand-context/inner-lifts" +" the-struct_104)" +"(expand-context/inner-lift-envs" +" the-struct_104)" +"(expand-context/inner-module-lifts" +" the-struct_104)" +"(expand-context/inner-require-lifts" +" the-struct_104)" +"(expand-context/inner-to-module-lifts" +" the-struct_104)" +"(expand-context/inner-requires+provides" +" the-struct_104)" +"(expand-context/inner-observer" +" the-struct_104)" +"(expand-context/inner-for-serializable?" +" the-struct_104)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_104)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_104)))))" +"(expand-context/outer1.1" +" inner305_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_43)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_43)" +"(root-expand-context/outer-frame-id" +" the-struct_43)" +"(expand-context/outer-context" +" the-struct_43)" +"(expand-context/outer-env" +" the-struct_43)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_43)" +"(expand-context/outer-scopes" +" the-struct_43)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_43)" +"(expand-context/outer-binding-layer" +" the-struct_43)" +"(expand-context/outer-reference-records" +" the-struct_43)" +"(expand-context/outer-only-immediate?" +" the-struct_43)" +"(expand-context/outer-need-eventually-defined" +" the-struct_43)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_43)" +"(expand-context/outer-name" +" the-struct_43)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_43))))))" +"(let-values(((added-s_2)" +"(add-scope" +" mb-s_0" +" inside-scope_0)))" +"(let-values((()" +"(begin" +"(let-values(((obs_123)" +"(expand-context-observer" +" ctx_109)))" +"(if obs_123" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_123" +" 'rename-one" +" added-s_2)))" +"(void)))" +"(values))))" +"(let-values(((disarmed-mb-s_0)" +"(syntax-disarm$1" +" added-s_2)))" +"(let-values(((ok?_6" +" #%module-begin300_0" +" body301_0)" +"(let-values(((s_112)" +" disarmed-mb-s_0))" +"(let-values(((orig-s_81)" +" s_112))" +"(let-values(((#%module-begin300_1" +" body301_1)" +"(let-values(((s_113)" +"(if(syntax?$1" +" s_112)" +"(syntax-e$1" +" s_112)" +" s_112)))" +"(if(pair?" +" s_113)" +"(let-values(((#%module-begin302_0)" +"(let-values(((s_116)" +"(car" +" s_113)))" +" s_116))" +"((body303_0)" +"(let-values(((s_421)" +"(cdr" +" s_113)))" +"(let-values(((s_216)" +"(if(syntax?$1" +" s_421)" +"(syntax-e$1" +" s_421)" +" s_421)))" +"(let-values(((flat-s_52)" +"(to-syntax-list.1" +" s_216)))" +"(if(not" +" flat-s_52)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_81))" +"(let-values()" +" flat-s_52)))))))" +"(values" +" #%module-begin302_0" +" body303_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_81)))))" +"(values" +" #t" +" #%module-begin300_1" +" body301_1))))))" +"(let-values(((bodys_16)" +" body301_0))" +"(let-values(((rebuild-mb-s_0)" +"(let-values(((ctx315_0)" +" ctx_109)" +"((mb-s316_0)" +" mb-s_0))" +"(keep-as-needed74.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" ctx315_0" +" mb-s316_0))))" +"(let-values(((need-eventually-defined_1)" +"(make-hasheqv)))" +"(let-values(((module-ends_0)" +"(make-shared-module-ends)))" +"(let-values(((declared-keywords_0)" +"(make-hasheq)))" +"(let-values(((declared-submodule-names_3)" +"(make-hasheq)))" +"(let-values(((expression-expanded-bodys_0)" +"((letrec-values(((pass-1-and-2-loop_0)" +"(lambda(bodys_17" +" phase_148)" +"(begin" +" 'pass-1-and-2-loop" +"(let-values(((def-ctx-scopes_8)" +"(box" +" null)))" +"(let-values(((to-parsed?_5)" +"(expand-context-to-parsed?" +" ctx_109)))" +"(let-values(((partial-body-ctx_0)" +"(let-values(((v_255)" +" ctx_109))" +"(let-values(((the-struct_105)" +" v_255))" +"(if(expand-context/outer?" +" the-struct_105)" +"(let-values(((context325_0)" +" 'module)" +"((def-ctx-scopes326_0)" +" def-ctx-scopes_8)" +"((need-eventually-defined327_0)" +" need-eventually-defined_1)" +"((inner328_0)" +"(let-values(((the-struct_48)" +"(root-expand-context/outer-inner" +" v_255)))" +"(if(expand-context/inner?" +" the-struct_48)" +"(let-values(((phase329_0)" +" phase_148)" +"((namespace330_0)" +"(namespace->namespace-at-phase" +" m-ns_19" +" phase_148))" +"((stops331_0)" +"(free-id-set" +" phase_148" +"(module-expand-stop-ids" +" phase_148)))" +"((declared-submodule-names332_0)" +" declared-submodule-names_3)" +"((lifts333_0)" +"(let-values(((temp337_0)" +"(make-wrap-as-definition" +" self_30" +" frame-id_16" +" inside-scope_0" +" all-scopes-s_0" +" defined-syms_10" +" requires+provides_6)))" +"(make-lift-context6.1" +" #f" +" #f" +" temp337_0)))" +"((module-lifts334_0)" +"(make-module-lift-context" +" phase_148" +" #t))" +"((require-lifts335_0)" +"(make-require-lift-context" +" phase_148" +"(let-values(((declared-submodule-names341_0)" +" declared-submodule-names_3))" +"(make-parse-lifted-require220.1" +" declared-submodule-names341_0" +" m-ns_19" +" self_30" +" requires+provides_6))))" +"((to-module-lifts336_0)" +"(let-values(((module-ends343_0)" +" module-ends_0)" +"((temp344_1)" +" #f))" +"(make-to-module-lift-context27.1" +" temp344_1" +" module-ends343_0" +" phase_148))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_48)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_48)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_48)" +"(root-expand-context/inner-defined-syms" +" the-struct_48)" +"(root-expand-context/inner-counter" +" the-struct_48)" +"(root-expand-context/inner-lift-key" +" the-struct_48)" +"(expand-context/inner-to-parsed?" +" the-struct_48)" +" phase329_0" +" namespace330_0" +"(expand-context/inner-just-once?" +" the-struct_48)" +"(expand-context/inner-module-begin-k" +" the-struct_48)" +"(expand-context/inner-allow-unbound?" +" the-struct_48)" +"(expand-context/inner-in-local-expand?" +" the-struct_48)" +" stops331_0" +" declared-submodule-names332_0" +" lifts333_0" +"(expand-context/inner-lift-envs" +" the-struct_48)" +" module-lifts334_0" +" require-lifts335_0" +" to-module-lifts336_0" +"(expand-context/inner-requires+provides" +" the-struct_48)" +"(expand-context/inner-observer" +" the-struct_48)" +"(expand-context/inner-for-serializable?" +" the-struct_48)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_48)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_48)))))" +"(expand-context/outer1.1" +" inner328_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_105)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_105)" +"(root-expand-context/outer-frame-id" +" the-struct_105)" +" context325_0" +"(expand-context/outer-env" +" the-struct_105)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_105)" +"(expand-context/outer-scopes" +" the-struct_105)" +" def-ctx-scopes326_0" +"(expand-context/outer-binding-layer" +" the-struct_105)" +"(expand-context/outer-reference-records" +" the-struct_105)" +"(expand-context/outer-only-immediate?" +" the-struct_105)" +" need-eventually-defined327_0" +"(expand-context/outer-current-introduction-scopes" +" the-struct_105)" +"(expand-context/outer-name" +" the-struct_105)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_105))))))" +"(let-values(((partially-expanded-bodys_0)" +"(let-values(((phase346_0)" +" phase_148)" +"((partial-body-ctx347_0)" +" partial-body-ctx_0)" +"((m-ns348_0)" +" m-ns_19)" +"((self349_0)" +" self_30)" +"((frame-id350_0)" +" frame-id_16)" +"((requires+provides351_0)" +" requires+provides_6)" +"((need-eventually-defined352_0)" +" need-eventually-defined_1)" +"((all-scopes-s353_0)" +" all-scopes-s_0)" +"((defined-syms354_0)" +" defined-syms_10)" +"((declared-keywords355_0)" +" declared-keywords_0)" +"((declared-submodule-names356_0)" +" declared-submodule-names_3)" +"((compiled-submodules357_0)" +" compiled-submodules_1)" +"((modules-being-compiled358_0)" +" modules-being-compiled_3)" +"((mpis-to-reset359_0)" +" mpis-to-reset_0)" +"((pass-1-and-2-loop360_0)" +" pass-1-and-2-loop_0))" +"(partially-expand-bodys81.1" +" all-scopes-s353_0" +" compiled-submodules357_0" +" partial-body-ctx347_0" +" declared-keywords355_0" +" declared-submodule-names356_0" +" defined-syms354_0" +" frame-id350_0" +" pass-1-and-2-loop360_0" +" modules-being-compiled358_0" +" mpis-to-reset359_0" +" m-ns348_0" +" need-eventually-defined352_0" +" phase346_0" +" requires+provides351_0" +" self349_0" +" bodys_17))))" +"(let-values((()" +"(begin" +"(let-values(((obs_124)" +"(expand-context-observer" +" partial-body-ctx_0)))" +"(if obs_124" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_124" +" 'next-group)))" +"(void)))" +"(values))))" +"(let-values(((body-ctx_6)" +"(let-values(((v_256)" +"(accumulate-def-ctx-scopes" +" partial-body-ctx_0" +" def-ctx-scopes_8)))" +"(let-values(((the-struct_106)" +" v_256))" +"(if(expand-context/outer?" +" the-struct_106)" +"(let-values(((def-ctx-scopes361_0)" +" #f)" +"((post-expansion-scope362_0)" +" #f)" +"((inner363_0)" +"(let-values(((the-struct_107)" +"(root-expand-context/outer-inner" +" v_256)))" +"(if(expand-context/inner?" +" the-struct_107)" +"(let-values(((stops364_0)" +" empty-free-id-set)" +"((to-module-lifts365_0)" +"(let-values(((module-ends367_0)" +" module-ends_0)" +"((temp368_0)" +" #t))" +"(make-to-module-lift-context27.1" +" temp368_0" +" module-ends367_0" +" phase_148))))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_107)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_107)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_107)" +"(root-expand-context/inner-defined-syms" +" the-struct_107)" +"(root-expand-context/inner-counter" +" the-struct_107)" +"(root-expand-context/inner-lift-key" +" the-struct_107)" +"(expand-context/inner-to-parsed?" +" the-struct_107)" +"(expand-context/inner-phase" +" the-struct_107)" +"(expand-context/inner-namespace" +" the-struct_107)" +"(expand-context/inner-just-once?" +" the-struct_107)" +"(expand-context/inner-module-begin-k" +" the-struct_107)" +"(expand-context/inner-allow-unbound?" +" the-struct_107)" +"(expand-context/inner-in-local-expand?" +" the-struct_107)" +" stops364_0" +"(expand-context/inner-declared-submodule-names" +" the-struct_107)" +"(expand-context/inner-lifts" +" the-struct_107)" +"(expand-context/inner-lift-envs" +" the-struct_107)" +"(expand-context/inner-module-lifts" +" the-struct_107)" +"(expand-context/inner-require-lifts" +" the-struct_107)" +" to-module-lifts365_0" +"(expand-context/inner-requires+provides" +" the-struct_107)" +"(expand-context/inner-observer" +" the-struct_107)" +"(expand-context/inner-for-serializable?" +" the-struct_107)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_107)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_107)))))" +"(expand-context/outer1.1" +" inner363_0" +" post-expansion-scope362_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_106)" +"(root-expand-context/outer-frame-id" +" the-struct_106)" +"(expand-context/outer-context" +" the-struct_106)" +"(expand-context/outer-env" +" the-struct_106)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_106)" +"(expand-context/outer-scopes" +" the-struct_106)" +" def-ctx-scopes361_0" +"(expand-context/outer-binding-layer" +" the-struct_106)" +"(expand-context/outer-reference-records" +" the-struct_106)" +"(expand-context/outer-only-immediate?" +" the-struct_106)" +"(expand-context/outer-need-eventually-defined" +" the-struct_106)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_106)" +"(expand-context/outer-name" +" the-struct_106)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_106))))))" +"(let-values(((phase318_0)" +" phase_148)" +"((body-ctx319_0)" +" body-ctx_6)" +"((self320_0)" +" self_30)" +"((declared-submodule-names321_0)" +" declared-submodule-names_3)" +"((compiled-submodules322_0)" +" compiled-submodules_1)" +"((modules-being-compiled323_0)" +" modules-being-compiled_3)" +"((mpis-to-reset324_0)" +" mpis-to-reset_0))" +"(finish-expanding-body-expressons99.1" +" compiled-submodules322_0" +" body-ctx319_0" +" declared-submodule-names321_0" +" modules-being-compiled323_0" +" mpis-to-reset324_0" +" phase318_0" +" self320_0" +" partially-expanded-bodys_0))))))))))))" +" pass-1-and-2-loop_0)" +" bodys_16" +" phase_147)))" +"(let-values((()" +"(begin" +"(check-defined-by-now" +" need-eventually-defined_1" +" self_30" +" ctx_109)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_125)" +"(expand-context-observer" +" ctx_109)))" +"(if obs_125" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_125" +" 'next-group)))" +"(void)))" +"(values))))" +"(let-values(((fully-expanded-bodys-except-post-submodules_0)" +"(let-values(((requires+provides370_0)" +" requires+provides_6)" +"((declared-submodule-names371_0)" +" declared-submodule-names_3)" +"((m-ns372_0)" +" m-ns_19)" +"((phase373_0)" +" phase_147)" +"((self374_0)" +" self_30)" +"((ctx375_0)" +" ctx_109))" +"(resolve-provides115.1" +" ctx375_0" +" declared-submodule-names371_0" +" m-ns372_0" +" phase373_0" +" requires+provides370_0" +" self374_0" +" expression-expanded-bodys_0))))" +"(let-values(((is-cross-phase-persistent?_1)" +"(hash-ref" +" declared-keywords_0" +" '#:cross-phase-persistent" +" #f)))" +"(let-values((()" +"(begin" +"(if is-cross-phase-persistent?_1" +"(let-values()" +"(begin" +"(if(requires+provides-can-cross-phase-persistent?" +" requires+provides_6)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"cannot be cross-phase persistent due to required modules\"" +" rebuild-s_14" +"(hash-ref" +" declared-keywords_0" +" '#:cross-phase-persistent))))" +"(check-cross-phase-persistent-form" +" fully-expanded-bodys-except-post-submodules_0)))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_126)" +"(expand-context-observer" +" ctx_109)))" +"(if obs_126" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_126" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((submod-m-ns_0)" +"(let-values(((temp377_0)" +" #t))" +"(make-m-ns244_0" +" temp377_0" +" #t" +" m-ns_19))))" +"(let-values(((submod-ctx_0)" +"(let-values(((v_257)" +" ctx_109))" +"(let-values(((the-struct_108)" +" v_257))" +"(if(expand-context/outer?" +" the-struct_108)" +"(let-values(((frame-id378_0)" +" #f)" +"((post-expansion-scope379_0)" +" #f)" +"((inner380_0)" +"(let-values(((the-struct_109)" +"(root-expand-context/outer-inner" +" v_257)))" +"(if(expand-context/inner?" +" the-struct_109)" +"(let-values(((namespace381_0)" +" submod-m-ns_0))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_109)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_109)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_109)" +"(root-expand-context/inner-defined-syms" +" the-struct_109)" +"(root-expand-context/inner-counter" +" the-struct_109)" +"(root-expand-context/inner-lift-key" +" the-struct_109)" +"(expand-context/inner-to-parsed?" +" the-struct_109)" +"(expand-context/inner-phase" +" the-struct_109)" +" namespace381_0" +"(expand-context/inner-just-once?" +" the-struct_109)" +"(expand-context/inner-module-begin-k" +" the-struct_109)" +"(expand-context/inner-allow-unbound?" +" the-struct_109)" +"(expand-context/inner-in-local-expand?" +" the-struct_109)" +"(expand-context/inner-stops" +" the-struct_109)" +"(expand-context/inner-declared-submodule-names" +" the-struct_109)" +"(expand-context/inner-lifts" +" the-struct_109)" +"(expand-context/inner-lift-envs" +" the-struct_109)" +"(expand-context/inner-module-lifts" +" the-struct_109)" +"(expand-context/inner-require-lifts" +" the-struct_109)" +"(expand-context/inner-to-module-lifts" +" the-struct_109)" +"(expand-context/inner-requires+provides" +" the-struct_109)" +"(expand-context/inner-observer" +" the-struct_109)" +"(expand-context/inner-for-serializable?" +" the-struct_109)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_109)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_109)))))" +"(expand-context/outer1.1" +" inner380_0" +" post-expansion-scope379_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_108)" +" frame-id378_0" +"(expand-context/outer-context" +" the-struct_108)" +"(expand-context/outer-env" +" the-struct_108)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_108)" +"(expand-context/outer-scopes" +" the-struct_108)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_108)" +"(expand-context/outer-binding-layer" +" the-struct_108)" +"(expand-context/outer-reference-records" +" the-struct_108)" +"(expand-context/outer-only-immediate?" +" the-struct_108)" +"(expand-context/outer-need-eventually-defined" +" the-struct_108)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_108)" +"(expand-context/outer-name" +" the-struct_108)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_108))))))" +"(let-values(((declare-enclosing-module_0)" +"(delay" +"(lambda()" +"(begin" +" 'declare-enclosing-module" +"(let-values(((temp383_0)" +" id:module-name229_0)" +"((rebuild-s384_0)" +" rebuild-s_14)" +"((requires+provides385_0)" +" requires+provides_6)" +"((submod-m-ns386_0)" +" submod-m-ns_0)" +"((self387_0)" +" self_30)" +"((enclosing-self388_0)" +" enclosing-self_1)" +"((root-ctx389_0)" +" root-ctx_6)" +"((submod-ctx390_0)" +" submod-ctx_0)" +"((modules-being-compiled391_0)" +" modules-being-compiled_3)" +"((compiled-module-box392_0)" +" compiled-module-box_0))" +"(declare-module-for-expansion139.1" +" submod-ctx390_0" +" enclosing-self388_0" +" compiled-module-box392_0" +" temp383_0" +" modules-being-compiled391_0" +" submod-m-ns386_0" +" rebuild-s384_0" +" requires+provides385_0" +" root-ctx389_0" +" self387_0" +" fully-expanded-bodys-except-post-submodules_0)))))))" +"(let-values(((fully-expanded-bodys_0)" +"(if(stop-at-module*?" +" submod-ctx_0)" +"(let-values()" +" fully-expanded-bodys-except-post-submodules_0)" +"(let-values()" +"(let-values(((declare-enclosing-module394_0)" +" declare-enclosing-module_0)" +"((phase395_0)" +" phase_147)" +"((self396_0)" +" self_30)" +"((requires+provides397_0)" +" requires+provides_6)" +"((is-cross-phase-persistent?398_0)" +" is-cross-phase-persistent?_1)" +"((all-scopes-s399_0)" +" all-scopes-s_0)" +"((mpis-to-reset400_0)" +" mpis-to-reset_0)" +"((declared-submodule-names401_0)" +" declared-submodule-names_3)" +"((compiled-submodules402_0)" +" compiled-submodules_1)" +"((modules-being-compiled403_0)" +" modules-being-compiled_3)" +"((submod-ctx404_0)" +" submod-ctx_0))" +"(expand-post-submodules165.1" +" all-scopes-s399_0" +" compiled-submodules402_0" +" submod-ctx404_0" +" declare-enclosing-module394_0" +" declared-submodule-names401_0" +" is-cross-phase-persistent?398_0" +" modules-being-compiled403_0" +" mpis-to-reset400_0" +" phase395_0" +" requires+provides397_0" +" self396_0" +" fully-expanded-bodys-except-post-submodules_0))))))" +"(if(expand-context-to-parsed?" +" submod-ctx_0)" +"(let-values()" +"(parsed-#%module-begin24.1" +" rebuild-mb-s_0" +"(parsed-only" +" fully-expanded-bodys_0)))" +"(let-values()" +"(let-values(((mb-result-s_0)" +"(let-values(((rebuild-mb-s405_0)" +" rebuild-mb-s_0)" +"((temp406_1)" +"(list*" +" #%module-begin300_0" +"(syntax-only" +" fully-expanded-bodys_0))))" +"(rebuild5.1" +" #f" +" #f" +" rebuild-mb-s405_0" +" temp406_1))))" +"(if(not" +"(expand-context-in-local-expand?" +" submod-ctx_0))" +"(let-values()" +"(expanded+parsed1.1" +" mb-result-s_0" +"(parsed-#%module-begin24.1" +" rebuild-mb-s_0" +"(parsed-only" +" fully-expanded-bodys_0))))" +"(let-values()" +" mb-result-s_0)))))))))))))))))))))))))))))))))" +"(let-values(((mb-ctx_0)" +"(let-values(((v_258)" +" ctx_108))" +"(let-values(((the-struct_110)" +" v_258))" +"(if(expand-context/outer?" +" the-struct_110)" +"(let-values(((context407_0)" +" 'module-begin)" +"((inner408_0)" +"(let-values(((the-struct_111)" +"(root-expand-context/outer-inner" +" v_258)))" +"(if(expand-context/inner?" +" the-struct_111)" +"(let-values(((module-begin-k409_0)" +" module-begin-k_1)" +"((in-local-expand?410_0)" +" #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_111)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_111)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_111)" +"(root-expand-context/inner-defined-syms" +" the-struct_111)" +"(root-expand-context/inner-counter" +" the-struct_111)" +"(root-expand-context/inner-lift-key" +" the-struct_111)" +"(expand-context/inner-to-parsed?" +" the-struct_111)" +"(expand-context/inner-phase" +" the-struct_111)" +"(expand-context/inner-namespace" +" the-struct_111)" +"(expand-context/inner-just-once?" +" the-struct_111)" +" module-begin-k409_0" +"(expand-context/inner-allow-unbound?" +" the-struct_111)" +" in-local-expand?410_0" +"(expand-context/inner-stops" +" the-struct_111)" +"(expand-context/inner-declared-submodule-names" +" the-struct_111)" +"(expand-context/inner-lifts" +" the-struct_111)" +"(expand-context/inner-lift-envs" +" the-struct_111)" +"(expand-context/inner-module-lifts" +" the-struct_111)" +"(expand-context/inner-require-lifts" +" the-struct_111)" +"(expand-context/inner-to-module-lifts" +" the-struct_111)" +"(expand-context/inner-requires+provides" +" the-struct_111)" +"(expand-context/inner-observer" +" the-struct_111)" +"(expand-context/inner-for-serializable?" +" the-struct_111)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_111)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_111)))))" +"(expand-context/outer1.1" +" inner408_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_110)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_110)" +"(root-expand-context/outer-frame-id" +" the-struct_110)" +" context407_0" +"(expand-context/outer-env" +" the-struct_110)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_110)" +"(expand-context/outer-scopes" +" the-struct_110)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_110)" +"(expand-context/outer-binding-layer" +" the-struct_110)" +"(expand-context/outer-reference-records" +" the-struct_110)" +"(expand-context/outer-only-immediate?" +" the-struct_110)" +"(expand-context/outer-need-eventually-defined" +" the-struct_110)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_110)" +"(expand-context/outer-name" +" the-struct_110)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_110))))))" +"(let-values(((mb-scopes-s_0)" +"(if keep-enclosing-scope-at-phase_0" +" disarmed-s_24" +" all-scopes-s_0)))" +"(let-values(((mb-def-ctx-scopes_0)" +"(box" +" null)))" +"(let-values(((mb_0)" +"(let-values(((module-name-sym412_0)" +" module-name-sym_0)" +"((mb-scopes-s413_0)" +" mb-scopes-s_0)" +"((m-ns414_0)" +" m-ns_19)" +"((mb-ctx415_0)" +" mb-ctx_0)" +"((mb-def-ctx-scopes416_0)" +" mb-def-ctx-scopes_0)" +"((phase417_0)" +" phase_147)" +"((s418_0)" +" s_16))" +"(ensure-module-begin36.1" +" mb-ctx415_0" +" mb-def-ctx-scopes416_0" +" m-ns414_0" +" module-name-sym412_0" +" phase417_0" +" s418_0" +" mb-scopes-s413_0" +" bodys_15))))" +"(let-values(((expanded-mb_0)" +"(let-values()" +"(let-values(((mb419_0)" +" mb_0)" +"((temp420_1)" +"(accumulate-def-ctx-scopes" +" mb-ctx_0" +" mb-def-ctx-scopes_0)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" mb419_0" +" temp420_1)))))" +"(let-values(((requires_6" +" provides_13)" +"(extract-requires-and-provides" +" requires+provides_6" +" self_30" +" self_30)))" +"(let-values(((result-form_0)" +"(if(let-values(((or-part_339)" +"(expand-context-to-parsed?" +" init-ctx_0)))" +"(if or-part_339" +" or-part_339" +" always-produce-compiled?_0))" +"(parsed-module25.1" +" rebuild-s_14" +" #f" +" id:module-name229_0" +" self_30" +" requires_6" +" provides_13" +"(requires+provides-all-bindings-simple?" +" requires+provides_6)" +"(root-expand-context-encode-for-module" +" root-ctx_6" +" self_30" +" self_30)" +"(parsed-#%module-begin-body" +"(if(expanded+parsed?" +" expanded-mb_0)" +"(expanded+parsed-parsed" +" expanded-mb_0)" +" expanded-mb_0))" +"(unbox" +" compiled-module-box_0)" +" compiled-submodules_1)" +" #f)))" +"(let-values(((result-s_14)" +"(if(not" +"(expand-context-to-parsed?" +" init-ctx_0))" +"(let-values()" +"(let-values(((generic-self_0)" +"(make-generic-self-module-path-index" +" self_30)))" +"(begin" +"(imitate-generic-module-path-index!" +" self_30)" +"(let-values(((lst_215)" +"(unbox" +" mpis-to-reset_0)))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_215)))" +"((letrec-values(((for-loop_314)" +"(lambda(lst_414)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_414)" +"(let-values(((mpi_53)" +"(unsafe-car" +" lst_414))" +"((rest_243)" +"(unsafe-cdr" +" lst_414)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(imitate-generic-module-path-index!" +" mpi_53))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_314" +" rest_243)" +"(values))))" +"(values))))))" +" for-loop_314)" +" lst_215)))" +"(void)" +"(let-values(((result-s_15)" +"(let-values(((rebuild-s421_0)" +" rebuild-s_14)" +"((temp422_0)" +"(list" +" module228_0" +" id:module-name229_0" +" initial-require-s_0" +"(expanded+parsed-s" +" expanded-mb_0))))" +"(rebuild5.1" +" #f" +" #f" +" rebuild-s421_0" +" temp422_0))))" +"(let-values(((result-s_16)" +"(let-values(((result-s423_0)" +" result-s_15)" +"((self424_0)" +" self_30)" +"((generic-self425_0)" +" generic-self_0))" +"(syntax-module-path-index-shift15.1" +" #f" +" #f" +" result-s423_0" +" self424_0" +" generic-self425_0" +" #f" +" #f))))" +"(let-values(((result-s_17)" +"(attach-root-expand-context-properties" +" result-s_16" +" root-ctx_6" +" self_30" +" generic-self_0)))" +"(let-values(((result-s_18)" +"(if(requires+provides-all-bindings-simple?" +" requires+provides_6)" +"(syntax-property$1" +" result-s_17" +" 'module-body-context-simple?" +" #t)" +" result-s_17)))" +"(begin" +"(let-values(((obs_127)" +"(expand-context-observer" +" init-ctx_0)))" +"(if obs_127" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_127" +" 'rename-one" +" result-s_18)))" +"(void)))" +" result-s_18))))))))" +"(void))))" +"(if(expand-context-to-parsed?" +" init-ctx_0)" +"(let-values()" +" result-form_0)" +"(if always-produce-compiled?_0" +"(let-values()" +"(expanded+parsed1.1" +" result-s_14" +" result-form_0))" +"(let-values()" +" result-s_14))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))" +"(define-values" +"(ensure-module-begin36.1)" +"(lambda(ctx24_0 def-ctx-scopes25_0 m-ns23_0 module-name-sym21_0 phase26_2 s27_2 scopes-s22_0 bodys35_0)" +"(begin" +" 'ensure-module-begin36" +"(let-values(((bodys_18) bodys35_0))" +"(let-values(((module-name-sym_1) module-name-sym21_0))" +"(let-values(((scopes-s_0) scopes-s22_0))" +"(let-values()" +"(let-values(((ctx_110) ctx24_0))" +"(let-values(((def-ctx-scopes_9) def-ctx-scopes25_0))" +"(let-values(((phase_149) phase26_2))" +"(let-values(((s_264) s27_2))" +"(let-values()" +"(let-values(((make-mb-ctx_0)" +"(lambda()" +"(begin" +" 'make-mb-ctx" +"(let-values(((v_259) ctx_110))" +"(let-values(((the-struct_112) v_259))" +"(if(expand-context/outer? the-struct_112)" +"(let-values(((context426_0) 'module-begin)" +"((only-immediate?427_0) #t)" +"((def-ctx-scopes428_0) def-ctx-scopes_9)" +"((inner429_0)(root-expand-context/outer-inner v_259)))" +"(expand-context/outer1.1" +" inner429_0" +"(root-expand-context/outer-post-expansion-scope the-struct_112)" +"(root-expand-context/outer-use-site-scopes the-struct_112)" +"(root-expand-context/outer-frame-id the-struct_112)" +" context426_0" +"(expand-context/outer-env the-struct_112)" +"(expand-context/outer-post-expansion-scope-action the-struct_112)" +"(expand-context/outer-scopes the-struct_112)" +" def-ctx-scopes428_0" +"(expand-context/outer-binding-layer the-struct_112)" +"(expand-context/outer-reference-records the-struct_112)" +" only-immediate?427_0" +"(expand-context/outer-need-eventually-defined the-struct_112)" +"(expand-context/outer-current-introduction-scopes the-struct_112)" +"(expand-context/outer-name the-struct_112)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_112))))))))" +"(let-values(((mb_1)" +"(if(= 1(length bodys_18))" +"(let-values()" +"(begin" +"(let-values(((obs_128)(expand-context-observer ctx_110)))" +"(if obs_128" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_128 'rename-one(car bodys_18))))" +"(void)))" +"(if(eq?" +" '#%module-begin" +"(core-form-sym(syntax-disarm$1(car bodys_18)) phase_149))" +"(let-values()(car bodys_18))" +"(let-values()" +"(let-values(((partly-expanded-body_0)" +"(let-values()" +"(let-values(((temp430_0)" +"(add-enclosing-name-property" +"(car bodys_18)" +" module-name-sym_1))" +"((temp431_0)(make-mb-ctx_0)))" +"(expand7.1 #f #f #f #f temp430_0 temp431_0)))))" +"(if(eq?" +" '#%module-begin" +"(core-form-sym" +"(syntax-disarm$1 partly-expanded-body_0)" +" phase_149))" +"(let-values() partly-expanded-body_0)" +"(let-values()" +"(let-values(((temp432_0)(list partly-expanded-body_0))" +"((s433_0) s_264)" +"((scopes-s434_0) scopes-s_0)" +"((phase435_0) phase_149)" +"((module-name-sym436_0) module-name-sym_1)" +"((temp437_0)(make-mb-ctx_0))" +"((temp438_0) #f))" +"(add-module-begin47.1" +" temp438_0" +" #t" +" temp432_0" +" s433_0" +" scopes-s434_0" +" phase435_0" +" module-name-sym436_0" +" temp437_0)))))))))" +"(let-values()" +"(let-values(((bodys439_0) bodys_18)" +"((s440_0) s_264)" +"((scopes-s441_0) scopes-s_0)" +"((phase442_0) phase_149)" +"((module-name-sym443_0) module-name-sym_1)" +"((temp444_0)(make-mb-ctx_0)))" +"(add-module-begin47.1" +" #f" +" #f" +" bodys439_0" +" s440_0" +" scopes-s441_0" +" phase442_0" +" module-name-sym443_0" +" temp444_0))))))" +"(add-enclosing-name-property mb_1 module-name-sym_1)))))))))))))))" +"(define-values" +"(add-module-begin47.1)" +"(lambda(log-rename-one?39_0" +" log-rename-one?40_0" +" bodys41_0" +" s42_0" +" scopes-s43_0" +" phase44_1" +" module-name-sym45_0" +" mb-ctx46_0)" +"(begin" +" 'add-module-begin47" +"(let-values(((bodys_19) bodys41_0))" +"(let-values(((s_733) s42_0))" +"(let-values(((scopes-s_1) scopes-s43_0))" +"(let-values(((phase_150) phase44_1))" +"(let-values(((module-name-sym_2) module-name-sym45_0))" +"(let-values(((mb-ctx_1) mb-ctx46_0))" +"(let-values(((log-rename-one?_0)(if log-rename-one?40_0 log-rename-one?39_0 #t)))" +"(let-values()" +"(let-values(((disarmed-scopes-s_0)(syntax-disarm$1 scopes-s_1)))" +"(let-values(((mb-id_0)(datum->syntax$1 disarmed-scopes-s_0 '#%module-begin)))" +"(let-values((()" +"(begin" +"(if(let-values(((mb-id445_0) mb-id_0)((phase446_0) phase_150))" +"(resolve33.1 #f #f #f #f #f #f #f #f mb-id445_0 phase446_0))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"no #%module-begin binding in the module's language\"" +" s_733)))" +"(values))))" +"(let-values(((mb_2)(datum->syntax$1 disarmed-scopes-s_0(list* mb-id_0 bodys_19) s_733)))" +"(let-values((()" +"(begin" +"(let-values(((obs_129)(expand-context-observer mb-ctx_1)))" +"(if obs_129" +"(let-values()" +"(let-values()(call-expand-observe obs_129 'tag mb_2)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if log-rename-one?_0" +"(let-values()" +"(let-values(((obs_130)(expand-context-observer mb-ctx_1)))" +"(if obs_130" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_130 'rename-one mb_2)))" +"(void))))" +"(void))" +"(values))))" +"(let-values(((partly-expanded-mb_0)" +"(let-values()" +"(let-values(((temp447_0)" +"(add-enclosing-name-property mb_2 module-name-sym_2))" +"((mb-ctx448_0) mb-ctx_1))" +"(expand7.1 #f #f #f #f temp447_0 mb-ctx448_0)))))" +"(begin" +"(if(eq?" +" '#%module-begin" +"(core-form-sym(syntax-disarm$1 partly-expanded-mb_0) phase_150))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"expansion of #%module-begin is not a #%plain-module-begin form\"" +" s_733" +" partly-expanded-mb_0)))" +" partly-expanded-mb_0)))))))))))))))))))" +"(define-values" +"(add-enclosing-name-property)" +"(lambda(stx_19 module-name-sym_3)(begin(syntax-property$1 stx_19 'enclosing-module-name module-name-sym_3))))" +"(define-values" +"(make-apply-module-scopes)" +"(lambda(inside-scope_1" +" outside-scope_2" +" init-ctx_1" +" keep-enclosing-scope-at-phase_1" +" self_11" +" enclosing-self_2" +" enclosing-mod_2)" +"(begin" +"(lambda(s_734)" +"(let-values()" +"(let-values(((s-without-enclosing_0)" +"(if keep-enclosing-scope-at-phase_1" +" s_734" +"(remove-use-site-scopes" +"(remove-scopes s_734(root-expand-context-module-scopes init-ctx_1))" +" init-ctx_1))))" +"(let-values(((s-with-edges_0)" +"(add-scope(add-scope s-without-enclosing_0 outside-scope_2) inside-scope_1)))" +"(let-values(((s-with-suitable-enclosing_0)" +"(if keep-enclosing-scope-at-phase_1" +"(let-values()" +"(let-values(((s-with-edges453_0) s-with-edges_0)" +"((enclosing-self454_0) enclosing-self_2)" +"((enclosing-mod455_0) enclosing-mod_2))" +"(syntax-module-path-index-shift15.1" +" #f" +" #f" +" s-with-edges453_0" +" enclosing-self454_0" +" enclosing-mod455_0" +" #f" +" #f)))" +"(let-values() s-with-edges_0))))" +"(let-values(((s-with-suitable-enclosing449_0) s-with-suitable-enclosing_0)" +"((temp450_0)(make-generic-self-module-path-index self_11))" +"((self451_0) self_11)" +"((temp452_0)(current-code-inspector)))" +"(syntax-module-path-index-shift15.1" +" #f" +" #f" +" s-with-suitable-enclosing449_0" +" temp450_0" +" self451_0" +" temp452_0" +" #t))))))))))" +"(define-values" +"(partially-expand-bodys81.1)" +"(lambda(all-scopes-stx57_0" +" compiled-submodules61_0" +" ctx51_0" +" declared-keywords59_0" +" declared-submodule-names60_0" +" defined-syms58_0" +" frame-id54_0" +" loop64_0" +" modules-being-compiled62_0" +" mpis-to-reset63_0" +" namespace52_0" +" need-eventually-defined56_0" +" phase50_0" +" requires-and-provides55_0" +" self53_0" +" bodys80_0)" +"(begin" +" 'partially-expand-bodys81" +"(let-values(((bodys_20) bodys80_0))" +"(let-values(((phase_45) phase50_0))" +"(let-values(((partial-body-ctx_1) ctx51_0))" +"(let-values(((m-ns_20) namespace52_0))" +"(let-values(((self_31) self53_0))" +"(let-values(((frame-id_17) frame-id54_0))" +"(let-values(((requires+provides_7) requires-and-provides55_0))" +"(let-values(((need-eventually-defined_2) need-eventually-defined56_0))" +"(let-values(((all-scopes-stx_5) all-scopes-stx57_0))" +"(let-values(((defined-syms_11) defined-syms58_0))" +"(let-values(((declared-keywords_1) declared-keywords59_0))" +"(let-values(((declared-submodule-names_4) declared-submodule-names60_0))" +"(let-values(((compiled-submodules_2) compiled-submodules61_0))" +"(let-values(((modules-being-compiled_4) modules-being-compiled62_0))" +"(let-values(((mpis-to-reset_1) mpis-to-reset63_0))" +"(let-values(((pass-1-and-2-loop_1) loop64_0))" +"(let-values()" +"(begin" +"(namespace-visit-available-modules! m-ns_20 phase_45)" +"((letrec-values(((loop_128)" +"(lambda(tail?_53 bodys_21)" +"(begin" +" 'loop" +"(if(null? bodys_21)" +"(let-values()" +"(if(if tail?_53(not(zero? phase_45)) #f)" +"(let-values()" +"(begin" +"(let-values(((obs_131)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_131" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_131" +" 'module-lift-end-loop" +" '())))" +"(void)))" +" null))" +"(if tail?_53" +"(let-values()" +"(let-values(((bodys_22)" +"(append" +"(get-and-clear-end-lifts!" +"(expand-context-to-module-lifts" +" partial-body-ctx_1))" +"(get-and-clear-provide-lifts!" +"(expand-context-to-module-lifts" +" partial-body-ctx_1)))))" +"(begin" +"(let-values(((obs_132)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_132" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_132" +" 'module-lift-end-loop" +" bodys_22)))" +"(void)))" +"(if(null? bodys_22)" +"(let-values() null)" +"(let-values()" +"(loop_128" +" #t" +"(add-post-expansion-scope" +" bodys_22" +" partial-body-ctx_1)))))))" +"(let-values() null))))" +"(let-values()" +"(let-values(((rest-bodys_1)(cdr bodys_21)))" +"(let-values((()" +"(begin" +"(let-values(((obs_133)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_133" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_133" +" 'next)))" +"(void)))" +"(values))))" +"(let-values(((exp-body_7)" +"(let-values()" +"(let-values(((temp456_0)" +"(car bodys_21))" +"((partial-body-ctx457_0)" +" partial-body-ctx_1))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" temp456_0" +" partial-body-ctx457_0)))))" +"(let-values(((disarmed-exp-body_1)" +"(syntax-disarm$1 exp-body_7)))" +"(let-values(((lifted-defns_0)" +"(get-and-clear-lifts!" +"(expand-context-lifts" +" partial-body-ctx_1))))" +"(begin" +"(if(pair? lifted-defns_0)" +"(let-values()" +"(log-lifted-defns" +" partial-body-ctx_1" +" lifted-defns_0" +" exp-body_7" +" rest-bodys_1))" +"(void))" +"(let-values(((obs_134)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_134" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_134" +" 'rename-one" +" exp-body_7)))" +"(void)))" +"(let-values(((finish_2)" +"(lambda()" +"(begin" +" 'finish" +"(let-values(((tmp_65)" +"(core-form-sym" +" disarmed-exp-body_1" +" phase_45)))" +"(if(equal?" +" tmp_65" +" 'begin)" +"(let-values()" +"(let-values(((ok?_74" +" begin458_0" +" e459_0)" +"(let-values(((s_735)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_82)" +" s_735))" +"(let-values(((begin458_1" +" e459_1)" +"(let-values(((s_736)" +"(if(syntax?$1" +" s_735)" +"(syntax-e$1" +" s_735)" +" s_735)))" +"(if(pair?" +" s_736)" +"(let-values(((begin460_0)" +"(let-values(((s_737)" +"(car" +" s_736)))" +" s_737))" +"((e461_0)" +"(let-values(((s_738)" +"(cdr" +" s_736)))" +"(let-values(((s_739)" +"(if(syntax?$1" +" s_738)" +"(syntax-e$1" +" s_738)" +" s_738)))" +"(let-values(((flat-s_53)" +"(to-syntax-list.1" +" s_739)))" +"(if(not" +" flat-s_53)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_82))" +"(let-values()" +" flat-s_53)))))))" +"(values" +" begin460_0" +" e461_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_82)))))" +"(values" +" #t" +" begin458_1" +" e459_1))))))" +"(let-values(((track_1)" +"(lambda(e_88)" +"(begin" +" 'track" +"(syntax-track-origin$1" +" e_88" +" exp-body_7)))))" +"(let-values(((spliced-bodys_0)" +"(append" +"(map2" +" track_1" +" e459_0)" +" rest-bodys_1)))" +"(begin" +"(let-values(((obs_135)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_135" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_135" +" 'splice" +" spliced-bodys_0)))" +"(void)))" +"(loop_128" +" tail?_53" +" spliced-bodys_0))))))" +"(if(equal?" +" tmp_65" +" 'begin-for-syntax)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_136)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_136" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_136" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_136" +" 'prim-begin-for-syntax)" +"(call-expand-observe" +" obs_136" +" 'prepare-env))))" +"(void)))" +"(values))))" +"(let-values(((ct-m-ns_0)" +"(namespace->namespace-at-phase" +" m-ns_20" +"(add1" +" phase_45))))" +"(let-values((()" +"(begin" +"(prepare-next-phase-namespace" +" partial-body-ctx_1)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_137)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_137" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_137" +" 'phase-up)))" +"(void)))" +"(values))))" +"(let-values(((ok?_75" +" begin-for-syntax462_0" +" e463_0)" +"(let-values(((s_740)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_83)" +" s_740))" +"(let-values(((begin-for-syntax462_1" +" e463_1)" +"(let-values(((s_741)" +"(if(syntax?$1" +" s_740)" +"(syntax-e$1" +" s_740)" +" s_740)))" +"(if(pair?" +" s_741)" +"(let-values(((begin-for-syntax464_0)" +"(let-values(((s_742)" +"(car" +" s_741)))" +" s_742))" +"((e465_0)" +"(let-values(((s_743)" +"(cdr" +" s_741)))" +"(let-values(((s_744)" +"(if(syntax?$1" +" s_743)" +"(syntax-e$1" +" s_743)" +" s_743)))" +"(let-values(((flat-s_54)" +"(to-syntax-list.1" +" s_744)))" +"(if(not" +" flat-s_54)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_83))" +"(let-values()" +" flat-s_54)))))))" +"(values" +" begin-for-syntax464_0" +" e465_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_83)))))" +"(values" +" #t" +" begin-for-syntax462_1" +" e463_1))))))" +"(let-values(((nested-bodys_1)" +"(pass-1-and-2-loop_1" +" e463_0" +"(add1" +" phase_45))))" +"(begin" +"(let-values(((obs_138)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_138" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_138" +" 'next-group)))" +"(void)))" +"(namespace-run-available-modules!" +" m-ns_20" +"(add1" +" phase_45))" +"(eval-nested-bodys" +" nested-bodys_1" +"(add1" +" phase_45)" +" ct-m-ns_0" +" self_31" +" partial-body-ctx_1)" +"(namespace-visit-available-modules!" +" m-ns_20" +" phase_45)" +"(let-values(((obs_139)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_139" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_139" +" 'exit-prim" +"(let-values(((s-nested-bodys_0)" +"(reverse$1" +"(let-values(((lst_131)" +" nested-bodys_1))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_131)))" +"((letrec-values(((for-loop_160)" +"(lambda(fold-var_122" +" lst_132)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_132)" +"(let-values(((nested-body_0)" +"(unsafe-car" +" lst_132))" +"((rest_65)" +"(unsafe-cdr" +" lst_132)))" +"(let-values(((fold-var_123)" +"(let-values(((fold-var_124)" +" fold-var_122))" +"(let-values(((fold-var_125)" +"(let-values()" +"(cons" +"(let-values()" +"(extract-syntax" +" nested-body_0))" +" fold-var_124))))" +"(values" +" fold-var_125)))))" +"(if(not" +" #f)" +"(for-loop_160" +" fold-var_123" +" rest_65)" +" fold-var_123)))" +" fold-var_122)))))" +" for-loop_160)" +" null" +" lst_131))))))" +"(datum->syntax$1" +" #f" +"(cons" +" begin-for-syntax462_0" +" s-nested-bodys_0)" +" exp-body_7)))))" +"(void)))" +"(cons" +"(semi-parsed-begin-for-syntax3.1" +" exp-body_7" +" nested-bodys_1)" +"(loop_128" +" tail?_53" +" rest-bodys_1))))))))))" +"(if(equal?" +" tmp_65" +" 'define-values)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_140)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_140" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_140" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_140" +" 'prim-define-values))))" +"(void)))" +"(values))))" +"(let-values(((ok?_76" +" define-values466_0" +" id467_0" +" rhs468_0)" +"(let-values(((s_745)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_84)" +" s_745))" +"(let-values(((define-values466_1" +" id467_1" +" rhs468_1)" +"(let-values(((s_746)" +"(if(syntax?$1" +" s_745)" +"(syntax-e$1" +" s_745)" +" s_745)))" +"(if(pair?" +" s_746)" +"(let-values(((define-values469_0)" +"(let-values(((s_747)" +"(car" +" s_746)))" +" s_747))" +"((id470_0" +" rhs471_0)" +"(let-values(((s_748)" +"(cdr" +" s_746)))" +"(let-values(((s_749)" +"(if(syntax?$1" +" s_748)" +"(syntax-e$1" +" s_748)" +" s_748)))" +"(if(pair?" +" s_749)" +"(let-values(((id472_0)" +"(let-values(((s_750)" +"(car" +" s_749)))" +"(let-values(((s_526)" +"(if(syntax?$1" +" s_750)" +"(syntax-e$1" +" s_750)" +" s_750)))" +"(let-values(((flat-s_55)" +"(to-syntax-list.1" +" s_526)))" +"(if(not" +" flat-s_55)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_84))" +"(let-values()" +"(let-values(((id_144)" +"(let-values(((lst_415)" +" flat-s_55))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_415)))" +"((letrec-values(((for-loop_315)" +"(lambda(id_145" +" lst_416)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_416)" +"(let-values(((s_751)" +"(unsafe-car" +" lst_416))" +"((rest_244)" +"(unsafe-cdr" +" lst_416)))" +"(let-values(((id_146)" +"(let-values(((id_147)" +" id_145))" +"(let-values(((id_148)" +"(let-values()" +"(let-values(((id482_0)" +"(let-values()" +"(if(let-values(((or-part_393)" +"(if(syntax?$1" +" s_751)" +"(symbol?" +"(syntax-e$1" +" s_751))" +" #f)))" +"(if or-part_393" +" or-part_393" +"(symbol?" +" s_751)))" +" s_751" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_84" +" s_751)))))" +"(cons" +" id482_0" +" id_147)))))" +"(values" +" id_148)))))" +"(if(not" +" #f)" +"(for-loop_315" +" id_146" +" rest_244)" +" id_146)))" +" id_145)))))" +" for-loop_315)" +" null" +" lst_415)))))" +"(reverse$1" +" id_144))))))))" +"((rhs473_0)" +"(let-values(((s_752)" +"(cdr" +" s_749)))" +"(let-values(((s_753)" +"(if(syntax?$1" +" s_752)" +"(syntax-e$1" +" s_752)" +" s_752)))" +"(if(pair?" +" s_753)" +"(let-values(((rhs474_0)" +"(let-values(((s_754)" +"(car" +" s_753)))" +" s_754))" +"(()" +"(let-values(((s_755)" +"(cdr" +" s_753)))" +"(let-values(((s_191)" +"(if(syntax?$1" +" s_755)" +"(syntax-e$1" +" s_755)" +" s_755)))" +"(if(null?" +" s_191)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_84))))))" +"(values" +" rhs474_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_84))))))" +"(values" +" id472_0" +" rhs473_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_84))))))" +"(values" +" define-values469_0" +" id470_0" +" rhs471_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_84)))))" +"(values" +" #t" +" define-values466_1" +" id467_1" +" rhs468_1))))))" +"(let-values(((ids_40)" +"(remove-use-site-scopes" +" id467_0" +" partial-body-ctx_1)))" +"(let-values((()" +"(begin" +"(let-values(((ids475_0)" +" ids_40)" +"((phase476_0)" +" phase_45)" +"((exp-body477_0)" +" exp-body_7))" +"(check-no-duplicate-ids8.1" +" #f" +" #f" +" ids475_0" +" phase476_0" +" exp-body477_0" +" #f" +" #f))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((exp-body481_0)" +" exp-body_7))" +"(check-ids-unbound173.1" +" exp-body481_0" +" ids_40" +" phase_45" +" requires+provides_7))" +"(values))))" +"(let-values(((syms_24)" +"(let-values(((frame-id488_0)" +" frame-id_17)" +"((requires+provides489_0)" +" requires+provides_7)" +"((exp-body490_0)" +" exp-body_7))" +"(select-defined-syms-and-bind!16.1" +" #f" +" #f" +" frame-id488_0" +" exp-body490_0" +" #t" +" requires+provides489_0" +" #t" +" #f" +" #f" +" ids_40" +" defined-syms_11" +" self_31" +" phase_45" +" all-scopes-stx_5))))" +"(begin" +"(add-defined-syms!" +" requires+provides_7" +" syms_24" +" phase_45)" +"(let-values(((obs_141)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_141" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_141" +" 'exit-prim" +"(datum->syntax$1" +" #f" +"(list" +" define-values466_0" +" ids_40" +" rhs468_0)" +" exp-body_7))))" +"(void)))" +"(cons" +"(semi-parsed-define-values2.1" +" exp-body_7" +" syms_24" +" ids_40" +" rhs468_0)" +"(loop_128" +" tail?_53" +" rest-bodys_1))))))))))" +"(if(equal?" +" tmp_65" +" 'define-syntaxes)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_142)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_142" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_142" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_142" +" 'prim-define-syntaxes)" +"(call-expand-observe" +" obs_142" +" 'prepare-env))))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(prepare-next-phase-namespace" +" partial-body-ctx_1)" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_143)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_143" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_143" +" 'phase-up)))" +"(void)))" +"(values))))" +"(let-values(((ok?_77" +" define-syntaxes491_0" +" id492_0" +" rhs493_0)" +"(let-values(((s_756)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_85)" +" s_756))" +"(let-values(((define-syntaxes491_1" +" id492_1" +" rhs493_1)" +"(let-values(((s_757)" +"(if(syntax?$1" +" s_756)" +"(syntax-e$1" +" s_756)" +" s_756)))" +"(if(pair?" +" s_757)" +"(let-values(((define-syntaxes494_0)" +"(let-values(((s_758)" +"(car" +" s_757)))" +" s_758))" +"((id495_0" +" rhs496_0)" +"(let-values(((s_759)" +"(cdr" +" s_757)))" +"(let-values(((s_535)" +"(if(syntax?$1" +" s_759)" +"(syntax-e$1" +" s_759)" +" s_759)))" +"(if(pair?" +" s_535)" +"(let-values(((id497_0)" +"(let-values(((s_536)" +"(car" +" s_535)))" +"(let-values(((s_537)" +"(if(syntax?$1" +" s_536)" +"(syntax-e$1" +" s_536)" +" s_536)))" +"(let-values(((flat-s_56)" +"(to-syntax-list.1" +" s_537)))" +"(if(not" +" flat-s_56)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))" +"(let-values()" +"(let-values(((id_149)" +"(let-values(((lst_417)" +" flat-s_56))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_417)))" +"((letrec-values(((for-loop_316)" +"(lambda(id_150" +" lst_418)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_418)" +"(let-values(((s_760)" +"(unsafe-car" +" lst_418))" +"((rest_245)" +"(unsafe-cdr" +" lst_418)))" +"(let-values(((id_151)" +"(let-values(((id_152)" +" id_150))" +"(let-values(((id_153)" +"(let-values()" +"(let-values(((id507_0)" +"(let-values()" +"(if(let-values(((or-part_394)" +"(if(syntax?$1" +" s_760)" +"(symbol?" +"(syntax-e$1" +" s_760))" +" #f)))" +"(if or-part_394" +" or-part_394" +"(symbol?" +" s_760)))" +" s_760" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_85" +" s_760)))))" +"(cons" +" id507_0" +" id_152)))))" +"(values" +" id_153)))))" +"(if(not" +" #f)" +"(for-loop_316" +" id_151" +" rest_245)" +" id_151)))" +" id_150)))))" +" for-loop_316)" +" null" +" lst_417)))))" +"(reverse$1" +" id_149))))))))" +"((rhs498_0)" +"(let-values(((s_761)" +"(cdr" +" s_535)))" +"(let-values(((s_762)" +"(if(syntax?$1" +" s_761)" +"(syntax-e$1" +" s_761)" +" s_761)))" +"(if(pair?" +" s_762)" +"(let-values(((rhs499_0)" +"(let-values(((s_763)" +"(car" +" s_762)))" +" s_763))" +"(()" +"(let-values(((s_764)" +"(cdr" +" s_762)))" +"(let-values(((s_765)" +"(if(syntax?$1" +" s_764)" +"(syntax-e$1" +" s_764)" +" s_764)))" +"(if(null?" +" s_765)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))))))" +"(values" +" rhs499_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))))))" +"(values" +" id497_0" +" rhs498_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85))))))" +"(values" +" define-syntaxes494_0" +" id495_0" +" rhs496_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_85)))))" +"(values" +" #t" +" define-syntaxes491_1" +" id492_1" +" rhs493_1))))))" +"(let-values(((ids_41)" +"(remove-use-site-scopes" +" id492_0" +" partial-body-ctx_1)))" +"(let-values((()" +"(begin" +"(let-values(((ids500_0)" +" ids_41)" +"((phase501_0)" +" phase_45)" +"((exp-body502_0)" +" exp-body_7))" +"(check-no-duplicate-ids8.1" +" #f" +" #f" +" ids500_0" +" phase501_0" +" exp-body502_0" +" #f" +" #f))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((exp-body506_0)" +" exp-body_7))" +"(check-ids-unbound173.1" +" exp-body506_0" +" ids_41" +" phase_45" +" requires+provides_7))" +"(values))))" +"(let-values(((syms_25)" +"(let-values(((frame-id513_0)" +" frame-id_17)" +"((requires+provides514_0)" +" requires+provides_7)" +"((exp-body515_0)" +" exp-body_7)" +"((temp516_0)" +" #t))" +"(select-defined-syms-and-bind!16.1" +" temp516_0" +" #t" +" frame-id513_0" +" exp-body515_0" +" #t" +" requires+provides514_0" +" #t" +" #f" +" #f" +" ids_41" +" defined-syms_11" +" self_31" +" phase_45" +" all-scopes-stx_5))))" +"(let-values((()" +"(begin" +"(add-defined-syms!" +" requires+provides_7" +" syms_25" +" phase_45)" +"(values))))" +"(let-values(((exp-rhs_6" +" parsed-rhs_2" +" vals_10)" +"(let-values(((temp517_0)" +" rhs493_0)" +"((ids518_0)" +" ids_41)" +"((temp519_0)" +"(let-values(((v_260)" +" partial-body-ctx_1))" +"(let-values(((the-struct_113)" +" v_260))" +"(if(expand-context/outer?" +" the-struct_113)" +"(let-values(((need-eventually-defined521_0)" +" need-eventually-defined_2)" +"((inner522_0)" +"(let-values(((the-struct_114)" +"(root-expand-context/outer-inner" +" v_260)))" +"(if(expand-context/inner?" +" the-struct_114)" +"(let-values(((lifts523_0)" +" #f)" +"((module-lifts524_0)" +" #f)" +"((to-module-lifts525_0)" +" #f))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_114)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_114)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_114)" +"(root-expand-context/inner-defined-syms" +" the-struct_114)" +"(root-expand-context/inner-counter" +" the-struct_114)" +"(root-expand-context/inner-lift-key" +" the-struct_114)" +"(expand-context/inner-to-parsed?" +" the-struct_114)" +"(expand-context/inner-phase" +" the-struct_114)" +"(expand-context/inner-namespace" +" the-struct_114)" +"(expand-context/inner-just-once?" +" the-struct_114)" +"(expand-context/inner-module-begin-k" +" the-struct_114)" +"(expand-context/inner-allow-unbound?" +" the-struct_114)" +"(expand-context/inner-in-local-expand?" +" the-struct_114)" +"(expand-context/inner-stops" +" the-struct_114)" +"(expand-context/inner-declared-submodule-names" +" the-struct_114)" +" lifts523_0" +"(expand-context/inner-lift-envs" +" the-struct_114)" +" module-lifts524_0" +"(expand-context/inner-require-lifts" +" the-struct_114)" +" to-module-lifts525_0" +"(expand-context/inner-requires+provides" +" the-struct_114)" +"(expand-context/inner-observer" +" the-struct_114)" +"(expand-context/inner-for-serializable?" +" the-struct_114)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_114)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_114)))))" +"(expand-context/outer1.1" +" inner522_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_113)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_113)" +"(root-expand-context/outer-frame-id" +" the-struct_113)" +"(expand-context/outer-context" +" the-struct_113)" +"(expand-context/outer-env" +" the-struct_113)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_113)" +"(expand-context/outer-scopes" +" the-struct_113)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_113)" +"(expand-context/outer-binding-layer" +" the-struct_113)" +"(expand-context/outer-reference-records" +" the-struct_113)" +"(expand-context/outer-only-immediate?" +" the-struct_113)" +" need-eventually-defined521_0" +"(expand-context/outer-current-introduction-scopes" +" the-struct_113)" +"(expand-context/outer-name" +" the-struct_113)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_113)))))" +"((temp520_0)" +" #f))" +"(expand+eval-for-syntaxes-binding63.1" +" temp520_0" +" #t" +" temp517_0" +" ids518_0" +" temp519_0))))" +"(let-values((()" +"(begin" +"(let-values(((lst_419)" +" syms_25)" +"((lst_420)" +" vals_10)" +"((lst_421)" +" ids_41))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_419)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_420)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_421)))" +"((letrec-values(((for-loop_317)" +"(lambda(lst_422" +" lst_423" +" lst_424)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_422)" +"(if(pair?" +" lst_423)" +"(pair?" +" lst_424)" +" #f)" +" #f)" +"(let-values(((sym_105)" +"(unsafe-car" +" lst_422))" +"((rest_246)" +"(unsafe-cdr" +" lst_422))" +"((val_86)" +"(unsafe-car" +" lst_423))" +"((rest_247)" +"(unsafe-cdr" +" lst_423))" +"((id_154)" +"(unsafe-car" +" lst_424))" +"((rest_248)" +"(unsafe-cdr" +" lst_424)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(maybe-install-free=id-in-context!" +" val_86" +" id_154" +" phase_45" +" partial-body-ctx_1)" +"(namespace-set-transformer!" +" m-ns_20" +" phase_45" +" sym_105" +" val_86)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_317" +" rest_246" +" rest_247" +" rest_248)" +"(values))))" +"(values))))))" +" for-loop_317)" +" lst_419" +" lst_420" +" lst_421)))" +"(values))))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_144)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_144" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_144" +" 'exit-prim" +"(datum->syntax$1" +" #f" +"(list" +" define-syntaxes491_0" +" ids_41" +" exp-rhs_6)))))" +"(void)))" +"(values))))" +"(let-values(((parsed-body_0)" +"(parsed-define-syntaxes20.1" +"(keep-properties-only" +" exp-body_7)" +" ids_41" +" syms_25" +" parsed-rhs_2)))" +"(cons" +"(if(expand-context-to-parsed?" +" partial-body-ctx_1)" +" parsed-body_0" +"(expanded+parsed1.1" +"(let-values(((exp-body526_0)" +" exp-body_7)" +"((temp527_0)" +"(list" +" define-syntaxes491_0" +" ids_41" +" exp-rhs_6)))" +"(rebuild5.1" +" #f" +" #f" +" exp-body526_0" +" temp527_0))" +" parsed-body_0))" +"(loop_128" +" tail?_53" +" rest-bodys_1)))))))))))))))))" +"(if(equal?" +" tmp_65" +" '#%require)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_145)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_145" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_145" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_145" +" 'prim-require))))" +"(void)))" +"(values))))" +"(let-values(((ready-body_0)" +"(remove-use-site-scopes" +" disarmed-exp-body_1" +" partial-body-ctx_1)))" +"(let-values(((ok?_78" +" #%require528_0" +" req529_0)" +"(let-values(((s_766)" +" ready-body_0))" +"(let-values(((orig-s_86)" +" s_766))" +"(let-values(((#%require528_1" +" req529_1)" +"(let-values(((s_767)" +"(if(syntax?$1" +" s_766)" +"(syntax-e$1" +" s_766)" +" s_766)))" +"(if(pair?" +" s_767)" +"(let-values(((#%require530_0)" +"(let-values(((s_768)" +"(car" +" s_767)))" +" s_768))" +"((req531_0)" +"(let-values(((s_769)" +"(cdr" +" s_767)))" +"(let-values(((s_770)" +"(if(syntax?$1" +" s_769)" +"(syntax-e$1" +" s_769)" +" s_769)))" +"(let-values(((flat-s_57)" +"(to-syntax-list.1" +" s_770)))" +"(if(not" +" flat-s_57)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_86))" +"(let-values()" +" flat-s_57)))))))" +"(values" +" #%require530_0" +" req531_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_86)))))" +"(values" +" #t" +" #%require528_1" +" req529_1))))))" +"(begin" +"(let-values(((temp532_0)" +" req529_0)" +"((exp-body533_0)" +" exp-body_7)" +"((self534_0)" +" self_31)" +"((m-ns535_0)" +" m-ns_20)" +"((phase536_0)" +" phase_45)" +"((phase537_0)" +" phase_45)" +"((requires+provides538_0)" +" requires+provides_7)" +"((declared-submodule-names539_0)" +" declared-submodule-names_4)" +"((temp540_0)" +" 'module))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" #f" +" #f" +" declared-submodule-names539_0" +" #t" +" #f" +" #f" +" phase537_0" +" #t" +" #f" +" #f" +" self534_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp540_0" +" temp532_0" +" exp-body533_0" +" m-ns535_0" +" phase536_0" +" requires+provides538_0))" +"(let-values(((obs_146)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_146" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_146" +" 'exit-prim" +" ready-body_0)))" +"(void)))" +"(cons" +" exp-body_7" +"(loop_128" +" tail?_53" +" rest-bodys_1)))))))" +"(if(equal?" +" tmp_65" +" '#%provide)" +"(let-values()" +"(cons" +" exp-body_7" +"(loop_128" +" tail?_53" +" rest-bodys_1)))" +"(if(equal?" +" tmp_65" +" 'module)" +"(let-values()" +"(let-values(((ready-body_1)" +"(remove-use-site-scopes" +" exp-body_7" +" partial-body-ctx_1)))" +"(let-values(((submod_2)" +"(let-values(((temp544_0)" +" #f)" +"((declared-submodule-names545_0)" +" declared-submodule-names_4)" +"((mpis-to-reset546_0)" +" mpis-to-reset_1)" +"((compiled-submodules547_0)" +" compiled-submodules_2)" +"((modules-being-compiled548_0)" +" modules-being-compiled_4))" +"(expand-submodule197.1" +" compiled-submodules547_0" +" declared-submodule-names545_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp544_0" +" #f" +" #f" +" modules-being-compiled548_0" +" mpis-to-reset546_0" +" ready-body_1" +" self_31" +" partial-body-ctx_1))))" +"(cons" +" submod_2" +"(loop_128" +" tail?_53" +" rest-bodys_1)))))" +"(if(equal?" +" tmp_65" +" 'module*)" +"(let-values()" +"(begin" +"(let-values(((obs_147)" +"(expand-context-observer" +" partial-body-ctx_1)))" +"(if obs_147" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_147" +" 'enter-prim" +" exp-body_7)" +"(call-expand-observe" +" obs_147" +" 'prim-submodule*)" +"(call-expand-observe" +" obs_147" +" 'exit-prim" +" exp-body_7))))" +"(void)))" +"(cons" +" exp-body_7" +"(loop_128" +" tail?_53" +" rest-bodys_1))))" +"(if(equal?" +" tmp_65" +" '#%declare)" +"(let-values()" +"(let-values(((ok?_79" +" #%declare549_0" +" kw550_0)" +"(let-values(((s_561)" +" disarmed-exp-body_1))" +"(let-values(((orig-s_87)" +" s_561))" +"(let-values(((#%declare549_1" +" kw550_1)" +"(let-values(((s_563)" +"(if(syntax?$1" +" s_561)" +"(syntax-e$1" +" s_561)" +" s_561)))" +"(if(pair?" +" s_563)" +"(let-values(((#%declare551_0)" +"(let-values(((s_565)" +"(car" +" s_563)))" +" s_565))" +"((kw552_0)" +"(let-values(((s_566)" +"(cdr" +" s_563)))" +"(let-values(((s_567)" +"(if(syntax?$1" +" s_566)" +"(syntax-e$1" +" s_566)" +" s_566)))" +"(let-values(((flat-s_58)" +"(to-syntax-list.1" +" s_567)))" +"(if(not" +" flat-s_58)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_87))" +"(let-values()" +" flat-s_58)))))))" +"(values" +" #%declare551_0" +" kw552_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_87)))))" +"(values" +" #t" +" #%declare549_1" +" kw550_1))))))" +"(let-values((()" +"(begin" +"(let-values(((lst_425)" +" kw550_0))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_425)))" +"((letrec-values(((for-loop_318)" +"(lambda(lst_426)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_426)" +"(let-values(((kw_1)" +"(unsafe-car" +" lst_426))" +"((rest_249)" +"(unsafe-cdr" +" lst_426)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(if(keyword?" +"(syntax-e$1" +" kw_1))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"expected a keyword\"" +" exp-body_7" +" kw_1)))" +"(if(memq" +"(syntax-e$1" +" kw_1)" +" '(#:cross-phase-persistent" +" #:empty-namespace))" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"not an allowed declaration keyword\"" +" exp-body_7" +" kw_1)))" +"(if(hash-ref" +" declared-keywords_1" +"(syntax-e$1" +" kw_1)" +" #f)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"keyword declared multiple times\"" +" exp-body_7" +" kw_1))" +"(void))" +"(hash-set!" +" declared-keywords_1" +"(syntax-e$1" +" kw_1)" +" kw_1)))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_318" +" rest_249)" +"(values))))" +"(values))))))" +" for-loop_318)" +" lst_425)))" +"(values))))" +"(let-values()" +"(let-values(((parsed-body_1)" +"(parsed-#%declare22.1" +" exp-body_7)))" +"(cons" +"(if(expand-context-to-parsed?" +" partial-body-ctx_1)" +" parsed-body_1" +"(expanded+parsed1.1" +" exp-body_7" +" parsed-body_1))" +"(loop_128" +" tail?_53" +" rest-bodys_1)))))))" +"(let-values()" +"(cons" +" exp-body_7" +"(loop_128" +" tail?_53" +" rest-bodys_1)))))))))))))))))" +"(let-values(((l_84)" +"(append" +"(get-and-clear-require-lifts!" +"(expand-context-require-lifts" +" partial-body-ctx_1))" +" lifted-defns_0" +"(loop_128" +" #f" +"(add-post-expansion-scope" +"(get-and-clear-module-lifts!" +"(expand-context-module-lifts" +" partial-body-ctx_1))" +" partial-body-ctx_1)))))" +"(if(null? l_84)" +"(finish_2)" +"(append" +" l_84" +"(finish_2)))))))))))))))))" +" loop_128)" +" #t" +" bodys_20))))))))))))))))))))))" +"(define-values" +"(make-wrap-as-definition)" +"(lambda(self_32 frame-id_18 inside-scope_2 all-scopes-stx_6 defined-syms_12 requires+provides_8)" +"(begin" +"(lambda(ids_42 rhs_23 phase_151)" +"(let-values(((scoped-ids_0)" +"(reverse$1" +"(let-values(((lst_427) ids_42))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_427)))" +"((letrec-values(((for-loop_319)" +"(lambda(fold-var_363 lst_428)" +"(begin" +" 'for-loop" +"(if(pair? lst_428)" +"(let-values(((id_155)(unsafe-car lst_428))" +"((rest_250)(unsafe-cdr lst_428)))" +"(let-values(((fold-var_364)" +"(let-values(((fold-var_365) fold-var_363))" +"(let-values(((fold-var_366)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_155" +" inside-scope_2))" +" fold-var_365))))" +"(values fold-var_366)))))" +"(if(not #f)(for-loop_319 fold-var_364 rest_250) fold-var_364)))" +" fold-var_363)))))" +" for-loop_319)" +" null" +" lst_427))))))" +"(let-values(((syms_26)" +"(let-values(((frame-id558_0) frame-id_18)((requires+provides559_0) requires+provides_8))" +"(select-defined-syms-and-bind!16.1" +" #f" +" #f" +" frame-id558_0" +" #f" +" #f" +" requires+provides559_0" +" #t" +" #f" +" #f" +" scoped-ids_0" +" defined-syms_12" +" self_32" +" phase_151" +" all-scopes-stx_6))))" +"(let-values(((s_285)" +"(add-scope" +"(datum->syntax$1" +" #f" +"(list" +"(datum->syntax$1(syntax-shift-phase-level$1 core-stx phase_151) 'define-values)" +" scoped-ids_0" +" rhs_23))" +" inside-scope_2)))" +"(values scoped-ids_0(semi-parsed-define-values2.1 s_285 syms_26 scoped-ids_0 rhs_23)))))))))" +"(define-values" +"(add-post-expansion-scope)" +"(lambda(bodys_23 ctx_111)" +"(begin" +"(let-values(((sc_34)(root-expand-context-post-expansion-scope ctx_111)))" +"(if sc_34" +"(reverse$1" +"(let-values(((lst_429) bodys_23))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_429)))" +"((letrec-values(((for-loop_320)" +"(lambda(fold-var_367 lst_430)" +"(begin" +" 'for-loop" +"(if(pair? lst_430)" +"(let-values(((body_23)(unsafe-car lst_430))((rest_251)(unsafe-cdr lst_430)))" +"(let-values(((fold-var_368)" +"(let-values(((fold-var_369) fold-var_367))" +"(let-values(((fold-var_370)" +"(let-values()" +"(cons" +"(let-values()(add-scope body_23 sc_34))" +" fold-var_369))))" +"(values fold-var_370)))))" +"(if(not #f)(for-loop_320 fold-var_368 rest_251) fold-var_368)))" +" fold-var_367)))))" +" for-loop_320)" +" null" +" lst_429))))" +" bodys_23)))))" +"(define-values" +"(finish-expanding-body-expressons99.1)" +"(lambda(compiled-submodules88_0" +" ctx85_0" +" declared-submodule-names87_0" +" modules-being-compiled89_0" +" mpis-to-reset90_0" +" phase84_0" +" self86_0" +" partially-expanded-bodys98_0)" +"(begin" +" 'finish-expanding-body-expressons99" +"(let-values(((partially-expanded-bodys_1) partially-expanded-bodys98_0))" +"(let-values(((phase_152) phase84_0))" +"(let-values(((body-ctx_7) ctx85_0))" +"(let-values(((self_33) self86_0))" +"(let-values(((declared-submodule-names_5) declared-submodule-names87_0))" +"(let-values(((compiled-submodules_3) compiled-submodules88_0))" +"(let-values(((modules-being-compiled_5) modules-being-compiled89_0))" +"(let-values(((mpis-to-reset_2) mpis-to-reset90_0))" +"(let-values()" +"((letrec-values(((loop_129)" +"(lambda(tail?_54 bodys_24)" +"(begin" +" 'loop" +"(if(null? bodys_24)" +"(let-values()" +"(if(if tail?_54(not(zero? phase_152)) #f)" +"(let-values()" +"(begin" +"(let-values(((obs_148)(expand-context-observer body-ctx_7)))" +"(if obs_148" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_148" +" 'module-lift-end-loop" +" '())))" +"(void)))" +" null))" +"(if tail?_54" +"(let-values()" +"(let-values(((bodys_25)" +"(append" +"(get-and-clear-end-lifts!" +"(expand-context-to-module-lifts body-ctx_7))" +"(get-and-clear-provide-lifts!" +"(expand-context-to-module-lifts body-ctx_7)))))" +"(if(null? bodys_25)" +"(let-values()" +"(begin" +"(let-values(((obs_149)" +"(expand-context-observer body-ctx_7)))" +"(if obs_149" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_149" +" 'module-lift-end-loop" +" '())))" +"(void)))" +" null))" +"(let-values()" +"(loop_129" +" #t" +"(add-post-expansion-scope bodys_25 body-ctx_7))))))" +"(let-values() null))))" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_150)" +"(expand-context-observer body-ctx_7)))" +"(if obs_150" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_150 'next)))" +"(void)))" +"(values))))" +"(let-values(((body_24)(car bodys_24)))" +"(let-values(((rest-bodys_2)(cdr bodys_24)))" +"(let-values(((exp-body_8)" +"(if(let-values(((or-part_395)" +"(parsed? body_24)))" +"(if or-part_395" +" or-part_395" +"(let-values(((or-part_396)" +"(expanded+parsed? body_24)))" +"(if or-part_396" +" or-part_396" +"(semi-parsed-begin-for-syntax?" +" body_24)))))" +"(let-values() body_24)" +"(if(semi-parsed-define-values? body_24)" +"(let-values()" +"(let-values(((ids_43)" +"(semi-parsed-define-values-ids" +" body_24)))" +"(let-values(((rhs-ctx_2)" +"(as-named-context" +"(as-expression-context" +" body-ctx_7)" +" ids_43)))" +"(let-values(((syms_27)" +"(semi-parsed-define-values-syms" +" body_24)))" +"(let-values(((s_300)" +"(semi-parsed-define-values-s" +" body_24)))" +"(let-values(((ok?_80" +" define-values560_0" +" _561_0" +" _562_0)" +"(let-values(((s_771)" +"(syntax-disarm$1" +" s_300)))" +"(if(if(not" +"(expand-context-to-parsed?" +" rhs-ctx_2))" +" #t" +" #f)" +"(let-values(((orig-s_88)" +" s_771))" +"(let-values(((define-values560_1" +" _561_1" +" _562_1)" +"(let-values(((s_772)" +"(if(syntax?$1" +" s_771)" +"(syntax-e$1" +" s_771)" +" s_771)))" +"(if(pair?" +" s_772)" +"(let-values(((define-values563_0)" +"(let-values(((s_603)" +"(car" +" s_772)))" +" s_603))" +"((_564_0" +" _565_0)" +"(let-values(((s_773)" +"(cdr" +" s_772)))" +"(let-values(((s_774)" +"(if(syntax?$1" +" s_773)" +"(syntax-e$1" +" s_773)" +" s_773)))" +"(if(pair?" +" s_774)" +"(let-values(((_566_0)" +"(let-values(((s_606)" +"(car" +" s_774)))" +" s_606))" +"((_567_0)" +"(let-values(((s_775)" +"(cdr" +" s_774)))" +"(let-values(((s_607)" +"(if(syntax?$1" +" s_775)" +"(syntax-e$1" +" s_775)" +" s_775)))" +"(if(pair?" +" s_607)" +"(let-values(((_568_0)" +"(let-values(((s_609)" +"(car" +" s_607)))" +" s_609))" +"(()" +"(let-values(((s_776)" +"(cdr" +" s_607)))" +"(let-values(((s_777)" +"(if(syntax?$1" +" s_776)" +"(syntax-e$1" +" s_776)" +" s_776)))" +"(if(null?" +" s_777)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_88))))))" +"(values" +" _568_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_88))))))" +"(values" +" _566_0" +" _567_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_88))))))" +"(values" +" define-values563_0" +" _564_0" +" _565_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_88)))))" +"(values" +" #t" +" define-values560_1" +" _561_1" +" _562_1)))" +"(values" +" #f" +" #f" +" #f" +" #f)))))" +"(let-values(((rebuild-s_15)" +"(let-values(((temp571_0)" +" #t))" +"(keep-as-needed74.1" +" #f" +" #f" +" #f" +" #f" +" temp571_0" +" #t" +" rhs-ctx_2" +" s_300))))" +"(let-values((()" +"(begin" +"(log-defn-enter" +" body-ctx_7" +" body_24)" +"(values))))" +"(let-values(((exp-rhs_7)" +"(let-values()" +"(let-values(((temp572_0)" +"(semi-parsed-define-values-rhs" +" body_24))" +"((rhs-ctx573_0)" +" rhs-ctx_2))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" temp572_0" +" rhs-ctx573_0)))))" +"(let-values((()" +"(begin" +"(log-defn-exit" +" body-ctx_7" +" body_24" +" exp-rhs_7)" +"(values))))" +"(let-values(((comp-form_0)" +"(parsed-define-values19.1" +" rebuild-s_15" +" ids_43" +" syms_27" +"(if(expand-context-to-parsed?" +" rhs-ctx_2)" +" exp-rhs_7" +"(let-values(((exp-rhs574_0)" +" exp-rhs_7)" +"((temp575_0)" +"(as-to-parsed-context" +" rhs-ctx_2)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" exp-rhs574_0" +" temp575_0))))))" +"(if(expand-context-to-parsed?" +" rhs-ctx_2)" +" comp-form_0" +"(expanded+parsed1.1" +"(let-values(((rebuild-s576_0)" +" rebuild-s_15)" +"((temp577_0)" +"(list" +" define-values560_0" +" ids_43" +" exp-rhs_7)))" +"(rebuild5.1" +" #f" +" #f" +" rebuild-s576_0" +" temp577_0))" +" comp-form_0)))))))))))))" +"(let-values()" +"(let-values(((disarmed-body_0)" +"(syntax-disarm$1 body_24)))" +"(let-values(((tmp_66)" +"(core-form-sym" +" disarmed-body_0" +" phase_152)))" +"(if(if(equal? tmp_66 '#%require)" +" #t" +"(if(equal? tmp_66 '#%provide)" +" #t" +"(equal? tmp_66 'module*)))" +"(let-values() body_24)" +"(let-values()" +"(let-values()" +"(let-values(((exp-body_9)" +"(let-values(((body578_0)" +" body_24)" +"((temp579_0)" +"(as-expression-context" +" body-ctx_7)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" body578_0" +" temp579_0))))" +"(if(expand-context-to-parsed?" +" body-ctx_7)" +" exp-body_9" +"(expanded+parsed1.1" +" exp-body_9" +"(let-values(((exp-body580_0)" +" exp-body_9)" +"((temp581_0)" +"(as-to-parsed-context" +" body-ctx_7)))" +"(expand7.1" +" #f" +" #f" +" #f" +" #f" +" exp-body580_0" +" temp581_0)))))))))))))))" +"(let-values(((lifted-defns_1)" +"(get-and-clear-lifts!" +"(expand-context-lifts body-ctx_7))))" +"(let-values(((lifted-requires_0)" +"(get-and-clear-require-lifts!" +"(expand-context-require-lifts body-ctx_7))))" +"(let-values(((lifted-modules_0)" +"(get-and-clear-module-lifts!" +"(expand-context-module-lifts body-ctx_7))))" +"(let-values(((no-lifts?_0)" +"(if(null? lifted-defns_1)" +"(if(null? lifted-modules_0)" +"(null? lifted-requires_0)" +" #f)" +" #f)))" +"(let-values((()" +"(begin" +"(if no-lifts?_0" +"(void)" +"(let-values()" +"(let-values(((obs_151)" +"(expand-context-observer" +" body-ctx_7)))" +"(if obs_151" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_151" +" 'module-lift-loop" +"(append" +" lifted-requires_0" +"(lifted-defns-extract-syntax" +" lifted-defns_1)" +"(add-post-expansion-scope" +" lifted-modules_0" +" body-ctx_7)))))" +"(void)))))" +"(values))))" +"(let-values(((exp-lifted-modules_0)" +"(let-values(((mpis-to-reset586_0)" +" mpis-to-reset_2)" +"((declared-submodule-names587_0)" +" declared-submodule-names_5)" +"((compiled-submodules588_0)" +" compiled-submodules_3)" +"((modules-being-compiled589_0)" +" modules-being-compiled_5))" +"(expand-non-module*-submodules212.1" +" compiled-submodules588_0" +" declared-submodule-names587_0" +" modules-being-compiled589_0" +" mpis-to-reset586_0" +" lifted-modules_0" +" phase_152" +" self_33" +" body-ctx_7))))" +"(let-values(((exp-lifted-defns_0)" +"(loop_129 #f lifted-defns_1)))" +"(begin" +"(if no-lifts?_0" +"(void)" +"(let-values()" +"(let-values(((obs_152)" +"(expand-context-observer" +" body-ctx_7)))" +"(if obs_152" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_152" +" 'next)))" +"(void)))))" +"(append" +" lifted-requires_0" +" exp-lifted-defns_0" +" exp-lifted-modules_0" +"(cons" +" exp-body_8" +"(loop_129" +" tail?_54" +" rest-bodys_2)))))))))))))))))))))" +" loop_129)" +" #t" +" partially-expanded-bodys_1)))))))))))))" +"(define-values" +"(check-defined-by-now)" +"(lambda(need-eventually-defined_3 self_34 ctx_112)" +"(begin" +"(begin" +"(let-values(((ht_166) need-eventually-defined_3))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-in-hash ht_166)))" +"((letrec-values(((for-loop_321)" +"(lambda(i_193)" +"(begin" +" 'for-loop" +"(if i_193" +"(let-values(((phase_153 l_85)(hash-iterate-key+value ht_166 i_193)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(begin" +"(let-values(((lst_431) l_85))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_431)))" +"((letrec-values(((for-loop_322)" +"(lambda(lst_432)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_432)" +"(let-values(((id_156)" +"(unsafe-car" +" lst_432))" +"((rest_252)" +"(unsafe-cdr" +" lst_432)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((b_94)" +"(let-values(((id590_0)" +" id_156)" +"((phase591_0)" +" phase_153))" +"(resolve+shift30.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" id590_0" +" phase591_0))))" +"(if(if b_94" +"(if(module-binding?" +" b_94)" +"(if(eq?" +"(module-binding-sym" +" b_94)" +"(syntax-e$1" +" id_156))" +"(eq?" +"(module-binding-module" +" b_94)" +" self_34)" +" #f)" +" #f)" +" #f)" +"(void)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"reference to an unbound identifier\"" +" id_156" +" #f" +" null" +"(syntax-debug-info-string" +" id_156" +" ctx_112))))))" +"(values)))))" +"(values)))))" +"(if(not #f)" +"(for-loop_322" +" rest_252)" +"(values))))" +"(values))))))" +" for-loop_322)" +" lst_431)))" +"(void)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_321(hash-iterate-next ht_166 i_193))(values))))" +"(values))))))" +" for-loop_321)" +"(hash-iterate-first ht_166))))" +"(void)))))" +"(define-values" +"(resolve-provides115.1)" +"(lambda(ctx107_1" +" declared-submodule-names103_0" +" namespace104_0" +" phase105_0" +" requires-and-provides102_0" +" self106_0" +" expression-expanded-bodys114_0)" +"(begin" +" 'resolve-provides115" +"(let-values(((expression-expanded-bodys_1) expression-expanded-bodys114_0))" +"(let-values(((requires+provides_9) requires-and-provides102_0))" +"(let-values(((declared-submodule-names_6) declared-submodule-names103_0))" +"(let-values(((m-ns_21) namespace104_0))" +"(let-values(((phase_154) phase105_0))" +"(let-values(((self_35) self106_0))" +"(let-values(((ctx_113) ctx107_1))" +"(let-values()" +"(let-values()" +"((letrec-values(((loop_130)" +"(lambda(bodys_26 phase_155)" +"(begin" +" 'loop" +"(if(null? bodys_26)" +"(let-values() null)" +"(if(let-values(((or-part_397)(parsed?(car bodys_26))))" +"(if or-part_397 or-part_397(expanded+parsed?(car bodys_26))))" +"(let-values()" +"(cons(car bodys_26)(loop_130(cdr bodys_26) phase_155)))" +"(if(semi-parsed-begin-for-syntax?(car bodys_26))" +"(let-values()" +"(let-values(((nested-bodys_2)" +"(loop_130" +"(semi-parsed-begin-for-syntax-body(car bodys_26))" +"(add1 phase_155))))" +"(cons" +"(let-values(((the-struct_115)(car bodys_26)))" +"(if(semi-parsed-begin-for-syntax? the-struct_115)" +"(let-values(((body592_0) nested-bodys_2))" +"(semi-parsed-begin-for-syntax3.1" +"(semi-parsed-begin-for-syntax-s the-struct_115)" +" body592_0))" +"(raise-argument-error" +" 'struct-copy" +" \"semi-parsed-begin-for-syntax?\"" +" the-struct_115)))" +"(loop_130(cdr bodys_26) phase_155))))" +"(let-values()" +"(let-values(((disarmed-body_1)(syntax-disarm$1(car bodys_26))))" +"(let-values(((tmp_67)" +"(core-form-sym disarmed-body_1 phase_155)))" +"(if(equal? tmp_67 '#%provide)" +"(let-values()" +"(let-values((()" +"(begin" +"(let-values(((obs_153)" +"(expand-context-observer" +" ctx_113)))" +"(if obs_153" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe" +" obs_153" +" 'enter-prim" +"(car bodys_26))" +"(call-expand-observe" +" obs_153" +" 'prim-provide))))" +"(void)))" +"(values))))" +"(let-values(((ok?_81 #%provide593_0 spec594_0)" +"(let-values(((s_622) disarmed-body_1))" +"(let-values(((orig-s_89) s_622))" +"(let-values(((#%provide593_1" +" spec594_1)" +"(let-values(((s_625)" +"(if(syntax?$1" +" s_622)" +"(syntax-e$1" +" s_622)" +" s_622)))" +"(if(pair? s_625)" +"(let-values(((#%provide595_0)" +"(let-values(((s_778)" +"(car" +" s_625)))" +" s_778))" +"((spec596_0)" +"(let-values(((s_779)" +"(cdr" +" s_625)))" +"(let-values(((s_780)" +"(if(syntax?$1" +" s_779)" +"(syntax-e$1" +" s_779)" +" s_779)))" +"(let-values(((flat-s_59)" +"(to-syntax-list.1" +" s_780)))" +"(if(not" +" flat-s_59)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_89))" +"(let-values()" +" flat-s_59)))))))" +"(values" +" #%provide595_0" +" spec596_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_89)))))" +"(values" +" #t" +" #%provide593_1" +" spec594_1))))))" +"(let-values(((track-stxes_10 specs_2)" +"(parse-and-expand-provides!" +" spec594_0" +"(car bodys_26)" +" requires+provides_9" +" self_35" +" phase_155" +"(let-values(((v_261) ctx_113))" +"(let-values(((the-struct_116)" +" v_261))" +"(if(expand-context/outer?" +" the-struct_116)" +"(let-values(((context597_0)" +" 'top-level)" +"((inner598_0)" +"(let-values(((the-struct_117)" +"(root-expand-context/outer-inner" +" v_261)))" +"(if(expand-context/inner?" +" the-struct_117)" +"(let-values(((phase599_0)" +" phase_155)" +"((namespace600_0)" +"(namespace->namespace-at-phase" +" m-ns_21" +" phase_155))" +"((requires+provides601_0)" +" requires+provides_9)" +"((declared-submodule-names602_0)" +" declared-submodule-names_6))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_117)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_117)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_117)" +"(root-expand-context/inner-defined-syms" +" the-struct_117)" +"(root-expand-context/inner-counter" +" the-struct_117)" +"(root-expand-context/inner-lift-key" +" the-struct_117)" +"(expand-context/inner-to-parsed?" +" the-struct_117)" +" phase599_0" +" namespace600_0" +"(expand-context/inner-just-once?" +" the-struct_117)" +"(expand-context/inner-module-begin-k" +" the-struct_117)" +"(expand-context/inner-allow-unbound?" +" the-struct_117)" +"(expand-context/inner-in-local-expand?" +" the-struct_117)" +"(expand-context/inner-stops" +" the-struct_117)" +" declared-submodule-names602_0" +"(expand-context/inner-lifts" +" the-struct_117)" +"(expand-context/inner-lift-envs" +" the-struct_117)" +"(expand-context/inner-module-lifts" +" the-struct_117)" +"(expand-context/inner-require-lifts" +" the-struct_117)" +"(expand-context/inner-to-module-lifts" +" the-struct_117)" +" requires+provides601_0" +"(expand-context/inner-observer" +" the-struct_117)" +"(expand-context/inner-for-serializable?" +" the-struct_117)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_117)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_117)))))" +"(expand-context/outer1.1" +" inner598_0" +"(root-expand-context/outer-post-expansion-scope" +" the-struct_116)" +"(root-expand-context/outer-use-site-scopes" +" the-struct_116)" +"(root-expand-context/outer-frame-id" +" the-struct_116)" +" context597_0" +"(expand-context/outer-env" +" the-struct_116)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_116)" +"(expand-context/outer-scopes" +" the-struct_116)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_116)" +"(expand-context/outer-binding-layer" +" the-struct_116)" +"(expand-context/outer-reference-records" +" the-struct_116)" +"(expand-context/outer-only-immediate?" +" the-struct_116)" +"(expand-context/outer-need-eventually-defined" +" the-struct_116)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_116)" +"(expand-context/outer-name" +" the-struct_116)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_116)))))))" +"(begin" +"(let-values(((obs_154)" +"(expand-context-observer ctx_113)))" +"(if obs_154" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_154 'exit-prim)))" +"(void)))" +"(if(expand-context-to-parsed? ctx_113)" +"(let-values()" +"(loop_130(cdr bodys_26) phase_155))" +"(let-values()" +"(cons" +"(syntax-track-origin*" +" track-stxes_10" +"(let-values(((temp603_0)(car bodys_26))" +"((temp604_0)" +"(list*" +" #%provide593_0" +" specs_2)))" +"(rebuild5.1 #f #f temp603_0 temp604_0)))" +"(loop_130(cdr bodys_26) phase_155)))))))))" +"(let-values()" +"(cons" +"(car bodys_26)" +"(loop_130(cdr bodys_26) phase_155))))))))))))))" +" loop_130)" +" expression-expanded-bodys_1" +" phase_154)))))))))))))" +"(define-values" +"(declare-module-for-expansion139.1)" +"(lambda(ctx125_0" +" enclosing123_0" +" fill127_0" +" module-name-id118_0" +" modules-being-compiled126_0" +" namespace121_0" +" rebuild-s119_0" +" requires-and-provides120_0" +" root-ctx124_0" +" self122_0" +" fully-expanded-bodys-except-post-submodules138_0)" +"(begin" +" 'declare-module-for-expansion139" +"(let-values(((fully-expanded-bodys-except-post-submodules_1) fully-expanded-bodys-except-post-submodules138_0))" +"(let-values(((module-name-id_0) module-name-id118_0))" +"(let-values(((rebuild-s_16) rebuild-s119_0))" +"(let-values(((requires+provides_10) requires-and-provides120_0))" +"(let-values(((m-ns_22) namespace121_0))" +"(let-values(((self_36) self122_0))" +"(let-values(((enclosing-self_3) enclosing123_0))" +"(let-values(((root-ctx_7) root-ctx124_0))" +"(let-values(((ctx_114) ctx125_0))" +"(let-values(((modules-being-compiled_6) modules-being-compiled126_0))" +"(let-values(((compiled-module-box_1) fill127_0))" +"(let-values()" +"(let-values(((requires_7 provides_14)" +"(extract-requires-and-provides requires+provides_10 self_36 self_36)))" +"(let-values(((parsed-mod_0)" +"(parsed-module25.1" +" rebuild-s_16" +" #f" +" module-name-id_0" +" self_36" +" requires_7" +" provides_14" +"(requires+provides-all-bindings-simple? requires+provides_10)" +"(root-expand-context-encode-for-module root-ctx_7 self_36 self_36)" +"(parsed-only fully-expanded-bodys-except-post-submodules_1)" +" #f" +"(hasheq))))" +"(let-values(((module-name_2)" +"(1/module-path-index-resolve" +"(let-values(((or-part_398) enclosing-self_3))" +"(if or-part_398 or-part_398 self_36)))))" +"(let-values(((compiled-module_0)" +"(let-values(((temp606_0)" +"(let-values(((m-ns610_0) m-ns_22)" +"((enclosing-self611_0) enclosing-self_3)" +"((temp612_0)" +"(if enclosing-self_3" +"(1/resolved-module-path-name" +" module-name_2)" +" #f)))" +"(make-compile-context14.1" +" temp612_0" +" #t" +" #f" +" #f" +" enclosing-self611_0" +" #t" +" m-ns610_0" +" #t" +" #f" +" #f" +" #f" +" #f)))" +"((temp607_0)(expand-context-for-serializable? ctx_114))" +"((modules-being-compiled608_0) modules-being-compiled_6)" +"((temp609_0) #f))" +"(compile-module13.1" +" #f" +" #f" +" modules-being-compiled608_0" +" #t" +" temp609_0" +" #t" +" temp607_0" +" #t" +" #f" +" #f" +" parsed-mod_0" +" temp606_0))))" +"(let-values((()" +"(begin" +"(set-box! compiled-module-box_1 compiled-module_0)" +"(values))))" +"(let-values(((root-module-name_0)" +"(resolved-module-path-root-name module-name_2)))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" m-ns_22" +" 1/current-module-declare-name" +"(1/make-resolved-module-path root-module-name_0))" +"(let-values()" +"(let-values(((temp614_0) #f))" +"(eval-module8.1" +" #f" +" #f" +" #f" +" #f" +" temp614_0" +" #t" +" compiled-module_0)))))))))))))))))))))))))" +"(define-values" +"(attach-root-expand-context-properties)" +"(lambda(s_781 root-ctx_8 orig-self_1 new-self_2)" +"(begin" +"(let-values(((s_782)" +"(syntax-property$1 s_781 'module-body-context(root-expand-context-all-scopes-stx root-ctx_8))))" +"(let-values(((s_783)" +"(syntax-property$1" +" s_782" +" 'module-body-inside-context" +"(add-scope empty-syntax(root-expand-context-post-expansion-scope root-ctx_8)))))" +" s_783)))))" +"(define-values" +"(expand-post-submodules165.1)" +"(lambda(all-scopes-s147_0" +" compiled-submodules150_0" +" ctx152_0" +" declare-enclosing142_0" +" declared-submodule-names149_0" +" enclosing-is-cross-phase-persistent?146_0" +" modules-being-compiled151_0" +" mpis-to-reset148_0" +" phase143_0" +" requires-and-provides145_0" +" self144_0" +" fully-expanded-bodys-except-post-submodules164_0)" +"(begin" +" 'expand-post-submodules165" +"(let-values(((fully-expanded-bodys-except-post-submodules_2) fully-expanded-bodys-except-post-submodules164_0))" +"(let-values(((declare-enclosing-module_1) declare-enclosing142_0))" +"(let-values(((phase_156) phase143_0))" +"(let-values(((self_37) self144_0))" +"(let-values(((requires+provides_11) requires-and-provides145_0))" +"(let-values(((enclosing-is-cross-phase-persistent?_1) enclosing-is-cross-phase-persistent?146_0))" +"(let-values(((all-scopes-s_1) all-scopes-s147_0))" +"(let-values(((mpis-to-reset_3) mpis-to-reset148_0))" +"(let-values(((declared-submodule-names_7) declared-submodule-names149_0))" +"(let-values(((compiled-submodules_4) compiled-submodules150_0))" +"(let-values(((modules-being-compiled_7) modules-being-compiled151_0))" +"(let-values(((submod-ctx_1) ctx152_0))" +"(let-values()" +"((letrec-values(((loop_131)" +"(lambda(bodys_27 phase_157)" +"(begin" +" 'loop" +"(if(null? bodys_27)" +"(let-values() null)" +"(let-values()" +"(let-values(((body_25)(car bodys_27)))" +"(let-values(((rest-bodys_3)(cdr bodys_27)))" +"(if(semi-parsed-begin-for-syntax? body_25)" +"(let-values()" +"(let-values(((body-s_0)" +"(semi-parsed-begin-for-syntax-s" +" body_25)))" +"(let-values(((ok?_82 begin-for-syntax615_0 _616_0)" +"(let-values(((s_784)" +"(syntax-disarm$1" +" body-s_0)))" +"(let-values(((orig-s_90) s_784))" +"(let-values(((begin-for-syntax615_1" +" _616_1)" +"(let-values(((s_785)" +"(if(syntax?$1" +" s_784)" +"(syntax-e$1" +" s_784)" +" s_784)))" +"(if(pair? s_785)" +"(let-values(((begin-for-syntax617_0)" +"(let-values(((s_786)" +"(car" +" s_785)))" +" s_786))" +"((_618_0)" +"(let-values(((s_787)" +"(cdr" +" s_785)))" +"(let-values(((s_788)" +"(if(syntax?$1" +" s_787)" +"(syntax-e$1" +" s_787)" +" s_787)))" +"(let-values(((flat-s_60)" +"(to-syntax-list.1" +" s_788)))" +"(if(not" +" flat-s_60)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_90))" +"(let-values()" +" flat-s_60)))))))" +"(values" +" begin-for-syntax617_0" +" _618_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_90)))))" +"(values" +" #t" +" begin-for-syntax615_1" +" _616_1))))))" +"(let-values(((rebuild-body-s_0)" +"(let-values(((submod-ctx619_0)" +" submod-ctx_1)" +"((body-s620_0)" +" body-s_0))" +"(keep-as-needed74.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" submod-ctx619_0" +" body-s620_0))))" +"(let-values(((nested-bodys_3)" +"(loop_131" +"(semi-parsed-begin-for-syntax-body" +" body_25)" +"(add1 phase_157))))" +"(let-values(((parsed-bfs_0)" +"(parsed-begin-for-syntax21.1" +" rebuild-body-s_0" +"(parsed-only nested-bodys_3))))" +"(cons" +"(if(expand-context-to-parsed?" +" submod-ctx_1)" +" parsed-bfs_0" +"(expanded+parsed1.1" +"(let-values(((rebuild-body-s621_0)" +" rebuild-body-s_0)" +"((temp622_0)" +"(list*" +" begin-for-syntax615_0" +"(syntax-only" +" nested-bodys_3))))" +"(rebuild5.1" +" #f" +" #f" +" rebuild-body-s621_0" +" temp622_0))" +" parsed-bfs_0))" +"(loop_131 rest-bodys_3 phase_157))))))))" +"(if(let-values(((or-part_399)(parsed? body_25)))" +"(if or-part_399" +" or-part_399" +"(expanded+parsed? body_25)))" +"(let-values()" +"(cons body_25(loop_131 rest-bodys_3 phase_157)))" +"(let-values()" +"(let-values(((disarmed-body_2)" +"(syntax-disarm$1 body_25)))" +"(let-values(((tmp_68)" +"(core-form-sym" +" disarmed-body_2" +" phase_157)))" +"(if(equal? tmp_68 'module*)" +"(let-values()" +"(let-values((()" +"(begin" +"(force" +" declare-enclosing-module_1)" +"(values))))" +"(let-values(((ready-body_2)" +"(remove-use-site-scopes" +" body_25" +" submod-ctx_1)))" +"(let-values(((ok?_83" +" module*623_0" +" name624_0" +" _625_0)" +"(let-values(((s_789)" +" disarmed-body_2))" +"(if(let-values(((s_790)" +"(if(syntax?$1" +" s_789)" +"(syntax-e$1" +" s_789)" +" s_789)))" +"(if(pair? s_790)" +"(if(let-values(((s_791)" +"(car" +" s_790)))" +" #t)" +"(let-values(((s_792)" +"(cdr" +" s_790)))" +"(let-values(((s_793)" +"(if(syntax?$1" +" s_792)" +"(syntax-e$1" +" s_792)" +" s_792)))" +"(if(pair?" +" s_793)" +"(if(let-values(((s_794)" +"(car" +" s_793)))" +" #t)" +"(let-values(((s_653)" +"(cdr" +" s_793)))" +"(let-values(((s_654)" +"(if(syntax?$1" +" s_653)" +"(syntax-e$1" +" s_653)" +" s_653)))" +"(if(pair?" +" s_654)" +"(if(let-values(((s_655)" +"(car" +" s_654)))" +"(let-values(((s_656)" +"(if(syntax?$1" +" s_655)" +"(syntax-e$1" +" s_655)" +" s_655)))" +"(eq?" +" #f" +" s_656)))" +"(let-values(((s_657)" +"(cdr" +" s_654)))" +" #t)" +" #f)" +" #f)))" +" #f)" +" #f)))" +" #f)" +" #f))" +"(let-values()" +"(let-values(((module*623_1" +" name624_1" +" _625_1)" +"(let-values(((s_795)" +"(if(syntax?$1" +" s_789)" +"(syntax-e$1" +" s_789)" +" s_789)))" +"(let-values(((module*626_0)" +"(let-values(((s_796)" +"(car" +" s_795)))" +" s_796))" +"((name627_0" +" _628_0)" +"(let-values(((s_797)" +"(cdr" +" s_795)))" +"(let-values(((s_662)" +"(if(syntax?$1" +" s_797)" +"(syntax-e$1" +" s_797)" +" s_797)))" +"(let-values(((name629_0)" +"(let-values(((s_798)" +"(car" +" s_662)))" +" s_798))" +"((_630_0)" +"(let-values(((s_665)" +"(cdr" +" s_662)))" +"(let-values(((s_666)" +"(if(syntax?$1" +" s_665)" +"(syntax-e$1" +" s_665)" +" s_665)))" +"(let-values((()" +"(let-values(((s_668)" +"(car" +" s_666)))" +"(let-values(((s_669)" +"(if(syntax?$1" +" s_668)" +"(syntax-e$1" +" s_668)" +" s_668)))" +"(values))))" +"((_631_0)" +"(let-values(((s_670)" +"(cdr" +" s_666)))" +" s_670)))" +"(values" +" _631_0))))))" +"(values" +" name629_0" +" _630_0))))))" +"(values" +" module*626_0" +" name627_0" +" _628_0)))))" +"(values" +" #t" +" module*623_1" +" name624_1" +" _625_1)))" +"(values" +" #f" +" #f" +" #f" +" #f)))))" +"(let-values(((submod_3)" +"(if ok?_83" +"(let-values()" +"(let-values(((neg-phase_0)" +"(phase-" +" 0" +" phase_157)))" +"(let-values(((shifted-s_0)" +"(syntax-shift-phase-level$1" +" ready-body_2" +" neg-phase_0)))" +"(let-values(((submod_4)" +"(let-values(((temp635_0)" +" #t)" +"((neg-phase636_0)" +" neg-phase_0)" +"((all-scopes-s637_0)" +" all-scopes-s_1)" +"((requires+provides638_0)" +" requires+provides_11)" +"((enclosing-is-cross-phase-persistent?639_0)" +" enclosing-is-cross-phase-persistent?_1)" +"((mpis-to-reset640_0)" +" mpis-to-reset_3)" +"((declared-submodule-names641_0)" +" declared-submodule-names_7)" +"((compiled-submodules642_0)" +" compiled-submodules_4)" +"((modules-being-compiled643_0)" +" modules-being-compiled_7))" +"(expand-submodule197.1" +" compiled-submodules642_0" +" declared-submodule-names641_0" +" all-scopes-s637_0" +" #t" +" enclosing-is-cross-phase-persistent?639_0" +" #t" +" requires+provides638_0" +" #t" +" temp635_0" +" neg-phase636_0" +" #t" +" modules-being-compiled643_0" +" mpis-to-reset640_0" +" shifted-s_0" +" self_37" +" submod-ctx_1))))" +"(if(parsed?" +" submod_4)" +"(let-values()" +" submod_4)" +"(if(expanded+parsed?" +" submod_4)" +"(let-values()" +"(let-values(((the-struct_118)" +" submod_4))" +"(if(expanded+parsed?" +" the-struct_118)" +"(let-values(((s644_0)" +"(syntax-shift-phase-level$1" +"(expanded+parsed-s" +" submod_4)" +" phase_157)))" +"(expanded+parsed1.1" +" s644_0" +"(expanded+parsed-parsed" +" the-struct_118)))" +"(raise-argument-error" +" 'struct-copy" +" \"expanded+parsed?\"" +" the-struct_118))))" +"(let-values()" +"(syntax-shift-phase-level$1" +" submod_4" +" phase_157))))))))" +"(let-values()" +"(let-values(((temp648_0)" +" #t)" +"((mpis-to-reset649_0)" +" mpis-to-reset_3)" +"((declared-submodule-names650_0)" +" declared-submodule-names_7)" +"((compiled-submodules651_0)" +" compiled-submodules_4)" +"((modules-being-compiled652_0)" +" modules-being-compiled_7))" +"(expand-submodule197.1" +" compiled-submodules651_0" +" declared-submodule-names650_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp648_0" +" #f" +" #f" +" modules-being-compiled652_0" +" mpis-to-reset649_0" +" ready-body_2" +" self_37" +" submod-ctx_1))))))" +"(cons" +" submod_3" +"(loop_131" +" rest-bodys_3" +" phase_157)))))))" +"(let-values()" +"(cons" +" body_25" +"(loop_131" +" rest-bodys_3" +" phase_157)))))))))))))))))" +" loop_131)" +" fully-expanded-bodys-except-post-submodules_2" +" phase_156)))))))))))))))))" +"(define-values" +"(stop-at-module*?)" +"(lambda(ctx_115)" +"(begin" +"(free-id-set-member?" +"(expand-context-stops ctx_115)" +"(expand-context-phase ctx_115)" +"(syntax-shift-phase-level$1(datum->syntax$1 core-stx 'module*)(expand-context-phase ctx_115))))))" +"(define-values" +"(check-ids-unbound173.1)" +"(lambda(in168_0 ids170_0 phase171_1 requires+provides172_0)" +"(begin" +" 'check-ids-unbound173" +"(let-values(((ids_44) ids170_0))" +"(let-values(((phase_158) phase171_1))" +"(let-values(((requires+provides_12) requires+provides172_0))" +"(let-values(((s_799) in168_0))" +"(let-values()" +"(begin" +"(let-values(((lst_433) ids_44))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_433)))" +"((letrec-values(((for-loop_323)" +"(lambda(lst_434)" +"(begin" +" 'for-loop" +"(if(pair? lst_434)" +"(let-values(((id_157)(unsafe-car lst_434))" +"((rest_253)(unsafe-cdr lst_434)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((s656_0) s_799)" +"((temp657_0) 'module))" +"(check-not-defined93.1" +" #f" +" #f" +" #f" +" #f" +" s656_0" +" #f" +" #f" +" #f" +" #f" +" temp657_0" +" requires+provides_12" +" id_157" +" phase_158)))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_323 rest_253)(values))))" +"(values))))))" +" for-loop_323)" +" lst_433)))" +"(void))))))))))" +"(define-values" +"(eval-nested-bodys)" +"(lambda(bodys_28 phase_159 m-ns_23 self_38 ctx_116)" +"(begin" +"(begin" +"(let-values(((lst_435) bodys_28))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_435)))" +"((letrec-values(((for-loop_324)" +"(lambda(lst_436)" +"(begin" +" 'for-loop" +"(if(pair? lst_436)" +"(let-values(((body_26)(unsafe-car lst_436))((rest_254)(unsafe-cdr lst_436)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((p_84)" +"(if(expanded+parsed? body_26)" +"(expanded+parsed-parsed" +" body_26)" +" body_26)))" +"(if(parsed-define-values? p_84)" +"(let-values()" +"(let-values(((ids_45)" +"(parsed-define-values-ids" +" p_84)))" +"(let-values(((vals_11)" +"(eval-for-bindings" +" ids_45" +"(parsed-define-values-rhs" +" p_84)" +" phase_159" +" m-ns_23" +" ctx_116)))" +"(begin" +"(let-values(((lst_437) ids_45)" +"((lst_438)" +"(parsed-define-values-syms" +" p_84))" +"((lst_439) vals_11))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_437)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_438)))" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list lst_439)))" +"((letrec-values(((for-loop_325)" +"(lambda(lst_440" +" lst_441" +" lst_442)" +"(begin" +" 'for-loop" +"(if(if(pair?" +" lst_440)" +"(if(pair?" +" lst_441)" +"(pair?" +" lst_442)" +" #f)" +" #f)" +"(let-values(((id_158)" +"(unsafe-car" +" lst_440))" +"((rest_255)" +"(unsafe-cdr" +" lst_440))" +"((sym_106)" +"(unsafe-car" +" lst_441))" +"((rest_256)" +"(unsafe-cdr" +" lst_441))" +"((val_87)" +"(unsafe-car" +" lst_442))" +"((rest_257)" +"(unsafe-cdr" +" lst_442)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(namespace-set-variable!" +" m-ns_23" +" phase_159" +" sym_106" +" val_87))" +"(values)))))" +"(values)))))" +"(if(not" +" #f)" +"(for-loop_325" +" rest_255" +" rest_256" +" rest_257)" +"(values))))" +"(values))))))" +" for-loop_325)" +" lst_437" +" lst_438" +" lst_439)))" +"(void)))))" +"(if(let-values(((or-part_400)" +"(parsed-define-syntaxes?" +" p_84)))" +"(if or-part_400" +" or-part_400" +"(semi-parsed-begin-for-syntax?" +" p_84)))" +"(let-values()(void))" +"(if(let-values(((or-part_401)" +"(parsed-#%declare?" +" p_84)))" +"(if or-part_401" +" or-part_401" +"(syntax?$1 p_84)))" +"(let-values()(void))" +"(let-values()" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first" +" #f" +" parameterization-key)" +" current-expand-context" +" ctx_116" +" 1/current-namespace" +" m-ns_23)" +"(let-values()" +"(eval-single-top" +"(compile-single" +" p_84" +"(let-values(((m-ns658_0)" +" m-ns_23)" +"((phase659_0)" +" phase_159))" +"(make-compile-context14.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" m-ns658_0" +" #t" +" phase659_0" +" #t" +" #f" +" #f)))" +" m-ns_23)))))))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_324 rest_254)(values))))" +"(values))))))" +" for-loop_324)" +" lst_435)))" +"(void)))))" +"(define-values" +"(expand-submodule197.1)" +"(lambda(compiled-submodules183_0" +" declared-submodule-names182_0" +" enclosing-all-scopes-stx180_0" +" enclosing-all-scopes-stx189_0" +" enclosing-is-cross-phase-persistent?179_0" +" enclosing-is-cross-phase-persistent?188_0" +" enclosing-requires+provides178_0" +" enclosing-requires+provides187_0" +" is-star?176_0" +" keep-enclosing-scope-at-phase177_0" +" keep-enclosing-scope-at-phase186_0" +" modules-being-compiled184_0" +" mpis-to-reset181_0" +" s194_0" +" self195_0" +" ctx196_0)" +"(begin" +" 'expand-submodule197" +"(let-values(((s_800) s194_0))" +"(let-values(((self_39) self195_0))" +"(let-values(((ctx_117) ctx196_0))" +"(let-values(((is-star?_0) is-star?176_0))" +"(let-values(((keep-enclosing-scope-at-phase_2)" +"(if keep-enclosing-scope-at-phase186_0 keep-enclosing-scope-at-phase177_0 #f)))" +"(let-values(((enclosing-r+p_2)" +"(if enclosing-requires+provides187_0 enclosing-requires+provides178_0 #f)))" +"(let-values(((enclosing-is-cross-phase-persistent?_2)" +"(if enclosing-is-cross-phase-persistent?188_0" +" enclosing-is-cross-phase-persistent?179_0" +" #f)))" +"(let-values(((enclosing-all-scopes-stx_1)" +"(if enclosing-all-scopes-stx189_0 enclosing-all-scopes-stx180_0 #f)))" +"(let-values(((mpis-to-reset_4) mpis-to-reset181_0))" +"(let-values(((declared-submodule-names_8) declared-submodule-names182_0))" +"(let-values(((compiled-submodules_5) compiled-submodules183_0))" +"(let-values(((modules-being-compiled_8) modules-being-compiled184_0))" +"(let-values()" +"(let-values((()" +"(begin" +"(if is-star?_0" +"(void)" +"(let-values()" +"(let-values(((obs_155)(expand-context-observer ctx_117)))" +"(if obs_155" +"(let-values()" +"(let-values()" +"(begin" +"(call-expand-observe obs_155 'enter-prim s_800)" +"(call-expand-observe" +" obs_155" +"(if is-star?_0 'prim-submodule* 'prim-submodule)))))" +"(void)))))" +"(values))))" +"(let-values(((ok?_84 module660_0 name661_0 _662_0)" +"(let-values(((s_801) s_800))" +"(let-values(((orig-s_91) s_801))" +"(let-values(((module660_1 name661_1 _662_1)" +"(let-values(((s_802)" +"(if(syntax?$1 s_801)" +"(syntax-e$1 s_801)" +" s_801)))" +"(if(pair? s_802)" +"(let-values(((module663_0)" +"(let-values(((s_803)(car s_802)))" +" s_803))" +"((name664_0 _665_0)" +"(let-values(((s_804)(cdr s_802)))" +"(let-values(((s_805)" +"(if(syntax?$1" +" s_804)" +"(syntax-e$1 s_804)" +" s_804)))" +"(if(pair? s_805)" +"(let-values(((name666_0)" +"(let-values(((s_806)" +"(car" +" s_805)))" +" s_806))" +"((_667_0)" +"(let-values(((s_807)" +"(cdr" +" s_805)))" +" s_807)))" +"(values name666_0 _667_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_91))))))" +"(values module663_0 name664_0 _665_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_91)))))" +"(values #t module660_1 name661_1 _662_1))))))" +"(let-values(((name_81)(syntax-e$1 name661_0)))" +"(let-values((()" +"(begin" +"(if(hash-ref declared-submodule-names_8 name_81 #f)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"submodule already declared with the same name\"" +" s_800" +" name_81))" +"(void))" +"(values))))" +"(let-values((()" +"(begin" +"(hash-set!" +" declared-submodule-names_8" +" name_81" +"(syntax-e$1 module660_0))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_156)(expand-context-observer ctx_117)))" +"(if obs_156" +"(let-values()" +"(let-values()" +"(call-expand-observe obs_156 'enter-prim s_800)))" +"(void)))" +"(values))))" +"(let-values(((submod_5)" +"(let-values(((temp669_0)" +"(let-values(((v_262) ctx_117))" +"(let-values(((the-struct_119) v_262))" +"(if(expand-context/outer? the-struct_119)" +"(let-values(((context678_0) 'module)" +"((post-expansion-scope679_0)" +" #f)" +"((inner680_0)" +"(let-values(((the-struct_120)" +"(root-expand-context/outer-inner" +" v_262)))" +"(if(expand-context/inner?" +" the-struct_120)" +"(let-values(((stops681_0)" +" empty-free-id-set))" +"(expand-context/inner2.1" +"(root-expand-context/inner-module-scopes" +" the-struct_120)" +"(root-expand-context/inner-top-level-bind-scope" +" the-struct_120)" +"(root-expand-context/inner-all-scopes-stx" +" the-struct_120)" +"(root-expand-context/inner-defined-syms" +" the-struct_120)" +"(root-expand-context/inner-counter" +" the-struct_120)" +"(root-expand-context/inner-lift-key" +" the-struct_120)" +"(expand-context/inner-to-parsed?" +" the-struct_120)" +"(expand-context/inner-phase" +" the-struct_120)" +"(expand-context/inner-namespace" +" the-struct_120)" +"(expand-context/inner-just-once?" +" the-struct_120)" +"(expand-context/inner-module-begin-k" +" the-struct_120)" +"(expand-context/inner-allow-unbound?" +" the-struct_120)" +"(expand-context/inner-in-local-expand?" +" the-struct_120)" +" stops681_0" +"(expand-context/inner-declared-submodule-names" +" the-struct_120)" +"(expand-context/inner-lifts" +" the-struct_120)" +"(expand-context/inner-lift-envs" +" the-struct_120)" +"(expand-context/inner-module-lifts" +" the-struct_120)" +"(expand-context/inner-require-lifts" +" the-struct_120)" +"(expand-context/inner-to-module-lifts" +" the-struct_120)" +"(expand-context/inner-requires+provides" +" the-struct_120)" +"(expand-context/inner-observer" +" the-struct_120)" +"(expand-context/inner-for-serializable?" +" the-struct_120)" +"(expand-context/inner-should-not-encounter-macros?" +" the-struct_120)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/inner?\"" +" the-struct_120)))))" +"(expand-context/outer1.1" +" inner680_0" +" post-expansion-scope679_0" +"(root-expand-context/outer-use-site-scopes" +" the-struct_119)" +"(root-expand-context/outer-frame-id" +" the-struct_119)" +" context678_0" +"(expand-context/outer-env" +" the-struct_119)" +"(expand-context/outer-post-expansion-scope-action" +" the-struct_119)" +"(expand-context/outer-scopes" +" the-struct_119)" +"(expand-context/outer-def-ctx-scopes" +" the-struct_119)" +"(expand-context/outer-binding-layer" +" the-struct_119)" +"(expand-context/outer-reference-records" +" the-struct_119)" +"(expand-context/outer-only-immediate?" +" the-struct_119)" +"(expand-context/outer-need-eventually-defined" +" the-struct_119)" +"(expand-context/outer-current-introduction-scopes" +" the-struct_119)" +"(expand-context/outer-name" +" the-struct_119)))" +"(raise-argument-error" +" 'struct-copy" +" \"expand-context/outer?\"" +" the-struct_119)))))" +"((self670_0) self_39)" +"((temp671_0) #t)" +"((keep-enclosing-scope-at-phase672_0)" +" keep-enclosing-scope-at-phase_2)" +"((enclosing-all-scopes-stx673_0)" +" enclosing-all-scopes-stx_1)" +"((enclosing-r+p674_0) enclosing-r+p_2)" +"((enclosing-is-cross-phase-persistent?675_0)" +" enclosing-is-cross-phase-persistent?_2)" +"((mpis-to-reset676_0) mpis-to-reset_4)" +"((modules-being-compiled677_0)" +" modules-being-compiled_8))" +"(expand-module18.1" +" temp671_0" +" #t" +" enclosing-all-scopes-stx673_0" +" #t" +" enclosing-is-cross-phase-persistent?675_0" +" #t" +" enclosing-r+p674_0" +" #t" +" keep-enclosing-scope-at-phase672_0" +" #t" +" modules-being-compiled677_0" +" #t" +" mpis-to-reset676_0" +" #t" +" s_800" +" temp669_0" +" self670_0))))" +"(let-values((()" +"(begin" +"(let-values(((obs_157)" +"(expand-context-observer ctx_117)))" +"(if obs_157" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_157" +" 'exit-prim" +"(extract-syntax submod_5))))" +"(void)))" +"(values))))" +"(let-values(((ns_128)(expand-context-namespace ctx_117)))" +"(let-values(((module-name_3)(1/module-path-index-resolve self_39)))" +"(let-values(((root-module-name_1)" +"(resolved-module-path-root-name module-name_3)))" +"(let-values(((compiled-submodule_0)" +"(let-values(((temp682_0)" +"(if(expanded+parsed? submod_5)" +"(expanded+parsed-parsed submod_5)" +" submod_5))" +"((temp683_0)" +"(let-values(((ns688_0) ns_128)" +"((self689_0) self_39)" +"((temp690_0)" +"(1/resolved-module-path-name" +" module-name_3)))" +"(make-compile-context14.1" +" temp690_0" +" #t" +" #f" +" #f" +" self689_0" +" #t" +" ns688_0" +" #t" +" #f" +" #f" +" #f" +" #f)))" +"((temp684_0) #t)" +"((temp685_0)" +"(expand-context-for-serializable?" +" ctx_117))" +"((modules-being-compiled686_0)" +" modules-being-compiled_8)" +"((temp687_0) #f))" +"(compile-module13.1" +" temp684_0" +" #t" +" modules-being-compiled686_0" +" #t" +" temp687_0" +" #t" +" temp685_0" +" #t" +" #f" +" #f" +" temp682_0" +" temp683_0))))" +"(begin" +"(hash-set!" +" compiled-submodules_5" +" name_81" +"(cons is-star?_0 compiled-submodule_0))" +"(with-continuation-mark" +" parameterization-key" +"(extend-parameterization" +"(continuation-mark-set-first #f parameterization-key)" +" 1/current-namespace" +" ns_128" +" 1/current-module-declare-name" +"(1/make-resolved-module-path root-module-name_1))" +"(let-values()" +"(let-values(((temp692_0) #f))" +"(eval-module8.1" +" #f" +" #f" +" #f" +" #f" +" temp692_0" +" #t" +" compiled-submodule_0))))" +"(if is-star?_0" +"(void)" +"(let-values()" +"(let-values(((obs_158)" +"(expand-context-observer ctx_117)))" +"(if obs_158" +"(let-values()" +"(let-values()" +"(call-expand-observe" +" obs_158" +" 'exit-prim" +"(extract-syntax submod_5))))" +"(void)))))" +"(if(not is-star?_0)" +"(let-values() submod_5)" +"(if(expanded+parsed? submod_5)" +"(let-values()" +"(let-values(((the-struct_121) submod_5))" +"(if(expanded+parsed? the-struct_121)" +"(let-values(((parsed693_0)" +"(let-values(((the-struct_122)" +"(expanded+parsed-parsed" +" submod_5)))" +"(if(parsed-module? the-struct_122)" +"(let-values(((star?694_0) #t))" +"(parsed-module25.1" +"(parsed-s the-struct_122)" +" star?694_0" +"(parsed-module-name-id" +" the-struct_122)" +"(parsed-module-self" +" the-struct_122)" +"(parsed-module-requires" +" the-struct_122)" +"(parsed-module-provides" +" the-struct_122)" +"(parsed-module-root-ctx-simple?" +" the-struct_122)" +"(parsed-module-encoded-root-ctx" +" the-struct_122)" +"(parsed-module-body" +" the-struct_122)" +"(parsed-module-compiled-module" +" the-struct_122)" +"(parsed-module-compiled-submodules" +" the-struct_122)))" +"(raise-argument-error" +" 'struct-copy" +" \"parsed-module?\"" +" the-struct_122)))))" +"(expanded+parsed1.1" +"(expanded+parsed-s the-struct_121)" +" parsed693_0))" +"(raise-argument-error" +" 'struct-copy" +" \"expanded+parsed?\"" +" the-struct_121))))" +"(let-values()" +"(let-values(((the-struct_123) submod_5))" +"(if(parsed-module? the-struct_123)" +"(let-values(((star?695_0) #t))" +"(parsed-module25.1" +"(parsed-s the-struct_123)" +" star?695_0" +"(parsed-module-name-id the-struct_123)" +"(parsed-module-self the-struct_123)" +"(parsed-module-requires the-struct_123)" +"(parsed-module-provides the-struct_123)" +"(parsed-module-root-ctx-simple? the-struct_123)" +"(parsed-module-encoded-root-ctx the-struct_123)" +"(parsed-module-body the-struct_123)" +"(parsed-module-compiled-module the-struct_123)" +"(parsed-module-compiled-submodules" +" the-struct_123)))" +"(raise-argument-error" +" 'struct-copy" +" \"parsed-module?\"" +" the-struct_123)))))))))))))))))))))))))))))))))))" +"(define-values" +"(expand-non-module*-submodules212.1)" +"(lambda(compiled-submodules202_0" +" declared-submodule-names201_0" +" modules-being-compiled203_0" +" mpis-to-reset200_0" +" bodys208_0" +" phase209_0" +" self210_0" +" ctx211_0)" +"(begin" +" 'expand-non-module*-submodules212" +"(let-values(((bodys_29) bodys208_0))" +"(let-values(((phase_160) phase209_0))" +"(let-values(((self_40) self210_0))" +"(let-values(((ctx_118) ctx211_0))" +"(let-values(((mpis-to-reset_5) mpis-to-reset200_0))" +"(let-values(((declared-submodule-names_9) declared-submodule-names201_0))" +"(let-values(((compiled-submodules_6) compiled-submodules202_0))" +"(let-values(((modules-being-compiled_9) modules-being-compiled203_0))" +"(let-values()" +"(reverse$1" +"(let-values(((lst_443) bodys_29))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_443)))" +"((letrec-values(((for-loop_326)" +"(lambda(fold-var_371 lst_444)" +"(begin" +" 'for-loop" +"(if(pair? lst_444)" +"(let-values(((body_27)(unsafe-car lst_444))" +"((rest_258)(unsafe-cdr lst_444)))" +"(let-values(((fold-var_372)" +"(let-values(((fold-var_373) fold-var_371))" +"(let-values(((fold-var_374)" +"(let-values()" +"(cons" +"(let-values()" +"(let-values(((tmp_69)" +"(core-form-sym" +"(syntax-disarm$1" +" body_27)" +" phase_160)))" +"(if(equal? tmp_69 'module)" +"(let-values()" +"(let-values(((temp699_0)" +" #f)" +"((mpis-to-reset700_0)" +" mpis-to-reset_5)" +"((declared-submodule-names701_0)" +" declared-submodule-names_9)" +"((compiled-submodules702_0)" +" compiled-submodules_6)" +"((modules-being-compiled703_0)" +" modules-being-compiled_9))" +"(expand-submodule197.1" +" compiled-submodules702_0" +" declared-submodule-names701_0" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp699_0" +" #f" +" #f" +" modules-being-compiled703_0" +" mpis-to-reset700_0" +" body_27" +" self_40" +" ctx_118)))" +"(let-values() body_27))))" +" fold-var_373))))" +"(values fold-var_374)))))" +"(if(not #f)" +"(for-loop_326 fold-var_372 rest_258)" +" fold-var_372)))" +" fold-var_371)))))" +" for-loop_326)" +" null" +" lst_443))))))))))))))))" +"(define-values" +"(make-parse-lifted-require220.1)" +"(lambda(declared-submodule-names215_0 m-ns217_0 self218_0 requires+provides219_0)" +"(begin" +" 'make-parse-lifted-require220" +"(let-values(((m-ns_24) m-ns217_0))" +"(let-values(((self_41) self218_0))" +"(let-values(((requires+provides_13) requires+provides219_0))" +"(let-values(((declared-submodule-names_10) declared-submodule-names215_0))" +"(let-values()" +"(lambda(s_808 phase_161)" +"(let-values(((ok?_85 #%require704_0 req705_0)" +"(let-values(((s_809)(syntax-disarm$1 s_808)))" +"(let-values(((orig-s_92) s_809))" +"(let-values(((#%require704_1 req705_1)" +"(let-values(((s_810)" +"(if(syntax?$1 s_809)(syntax-e$1 s_809) s_809)))" +"(if(pair? s_810)" +"(let-values(((#%require706_0)" +"(let-values(((s_811)(car s_810))) s_811))" +"((req707_0)" +"(let-values(((s_812)(cdr s_810)))" +"(let-values(((s_813)" +"(if(syntax?$1 s_812)" +"(syntax-e$1 s_812)" +" s_812)))" +"(if(pair? s_813)" +"(let-values(((req708_0)" +"(let-values(((s_814)" +"(car s_813)))" +" s_814))" +"(()" +"(let-values(((s_815)" +"(cdr s_813)))" +"(let-values(((s_816)" +"(if(syntax?$1" +" s_815)" +"(syntax-e$1" +" s_815)" +" s_815)))" +"(if(null? s_816)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_92))))))" +"(values req708_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_92))))))" +"(values #%require706_0 req707_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_92)))))" +"(values #t #%require704_1 req705_1))))))" +"(let-values(((temp709_0)(list req705_0))" +"((s710_0) s_808)" +"((self711_0) self_41)" +"((m-ns712_0) m-ns_24)" +"((phase713_0) phase_161)" +"((phase714_0) phase_161)" +"((requires+provides715_0) requires+provides_13)" +"((declared-submodule-names716_0) declared-submodule-names_10)" +"((temp717_0) 'require))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" #f" +" #f" +" declared-submodule-names716_0" +" #t" +" #f" +" #f" +" phase714_0" +" #t" +" #f" +" #f" +" self711_0" +" #t" +" #f" +" #f" +" #f" +" #f" +" temp717_0" +" temp709_0" +" s710_0" +" m-ns712_0" +" phase713_0" +" requires+provides715_0))))))))))))" +"(define-values" +"(defn-extract-syntax)" +"(lambda(defn_0)" +"(begin" +"(datum->syntax$1" +" #f" +"(list 'define-values(semi-parsed-define-values-ids defn_0)(semi-parsed-define-values-rhs defn_0))" +"(semi-parsed-define-values-s defn_0)))))" +"(define-values" +"(lifted-defns-extract-syntax)" +"(lambda(lifted-defns_2)" +"(begin" +"(reverse$1" +"(let-values(((lst_445) lifted-defns_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_445)))" +"((letrec-values(((for-loop_327)" +"(lambda(fold-var_375 lst_446)" +"(begin" +" 'for-loop" +"(if(pair? lst_446)" +"(let-values(((lifted-defn_0)(unsafe-car lst_446))" +"((rest_259)(unsafe-cdr lst_446)))" +"(let-values(((fold-var_376)" +"(let-values(((fold-var_377) fold-var_375))" +"(let-values(((fold-var_378)" +"(let-values()" +"(cons" +"(let-values()" +"(defn-extract-syntax lifted-defn_0))" +" fold-var_377))))" +"(values fold-var_378)))))" +"(if(not #f)(for-loop_327 fold-var_376 rest_259) fold-var_376)))" +" fold-var_375)))))" +" for-loop_327)" +" null" +" lst_445)))))))" +"(define-values" +"(log-lifted-defns)" +"(lambda(partial-body-ctx_2 lifted-defns_3 exp-body_10 rest-bodys_4)" +"(begin" +"(let-values(((obs_159)(expand-context-observer partial-body-ctx_2)))" +"(if obs_159" +"(let-values()" +"(let-values(((s-lifted-defns_0)(lifted-defns-extract-syntax lifted-defns_3)))" +"(let-values((()" +"(begin" +"(call-expand-observe obs_159 'rename-list(cons exp-body_10 rest-bodys_4))" +"(values))))" +"(let-values((()(begin(call-expand-observe obs_159 'module-lift-loop s-lifted-defns_0)(values))))" +"(let-values((()" +"(begin" +"(let-values(((lst_447) s-lifted-defns_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_447)))" +"((letrec-values(((for-loop_328)" +"(lambda(lst_448)" +"(begin" +" 'for-loop" +"(if(pair? lst_448)" +"(let-values(((s-lifted-defn_0)(unsafe-car lst_448))" +"((rest_260)(unsafe-cdr lst_448)))" +"(let-values((()" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((ok?_86" +" define-values722_0" +" _723_0)" +"(let-values(((s_817)" +" s-lifted-defn_0))" +"(let-values(((orig-s_93)" +" s_817))" +"(let-values(((define-values722_1" +" _723_1)" +"(let-values(((s_818)" +"(if(syntax?$1" +" s_817)" +"(syntax-e$1" +" s_817)" +" s_817)))" +"(if(pair?" +" s_818)" +"(let-values(((define-values724_0)" +"(let-values(((s_819)" +"(car" +" s_818)))" +" s_819))" +"((_725_0)" +"(let-values(((s_820)" +"(cdr" +" s_818)))" +"(let-values(((s_821)" +"(if(syntax?$1" +" s_820)" +"(syntax-e$1" +" s_820)" +" s_820)))" +"(let-values(((flat-s_61)" +"(to-syntax-list.1" +" s_821)))" +"(if(not" +" flat-s_61)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_93))" +"(let-values()" +" flat-s_61)))))))" +"(values" +" define-values724_0" +" _725_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_93)))))" +"(values" +" #t" +" define-values722_1" +" _723_1))))))" +"(begin" +"(call-expand-observe" +" obs_159" +" 'next)" +"(call-expand-observe" +" obs_159" +" 'visit" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_159" +" 'resolve" +" define-values722_0)" +"(call-expand-observe" +" obs_159" +" 'enter-prim" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_159" +" 'prim-stop)" +"(call-expand-observe" +" obs_159" +" 'exit-prim" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_159" +" 'return" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_159" +" 'rename-one" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_159" +" 'enter-prim" +" s-lifted-defn_0)" +"(call-expand-observe" +" obs_159" +" 'prim-define-values)" +"(call-expand-observe" +" obs_159" +" 'exit-prim" +" s-lifted-defn_0))))" +"(values)))))" +"(values)))))" +"(if(not #f)(for-loop_328 rest_260)(values))))" +"(values))))))" +" for-loop_328)" +" lst_447)))" +"(values))))" +"(let-values()" +"(let-values(((ok?_87 form-id718_0 _719_0)" +"(let-values(((s_822) exp-body_10))" +"(let-values(((orig-s_94) s_822))" +"(let-values(((form-id718_1 _719_1)" +"(let-values(((s_823)" +"(if(syntax?$1 s_822)(syntax-e$1 s_822) s_822)))" +"(if(pair? s_823)" +"(let-values(((form-id720_0)" +"(let-values(((s_824)(car s_823))) s_824))" +"((_721_0)" +"(let-values(((s_825)(cdr s_823))) s_825)))" +"(values form-id720_0 _721_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_94)))))" +"(values #t form-id718_1 _719_1))))))" +"(begin" +"(call-expand-observe obs_159 'next)" +"(call-expand-observe obs_159 'visit exp-body_10)" +"(call-expand-observe obs_159 'resolve form-id718_0)" +"(call-expand-observe obs_159 'enter-prim exp-body_10)" +"(call-expand-observe obs_159 'prim-stop)" +"(call-expand-observe obs_159 'exit-prim exp-body_10)" +"(call-expand-observe obs_159 'return exp-body_10)))))))))" +"(void))))))" +"(define-values" +"(log-defn-enter)" +"(lambda(ctx_119 defn_1)" +"(begin" +"(let-values(((obs_160)(expand-context-observer ctx_119)))" +"(if obs_160" +"(let-values()" +"(let-values(((s-defn_0)(defn-extract-syntax defn_1)))" +"(let-values(((ok?_88 define-values726_0 _727_0)" +"(let-values(((s_826) s-defn_0))" +"(let-values(((orig-s_95) s_826))" +"(let-values(((define-values726_1 _727_1)" +"(let-values(((s_827)(if(syntax?$1 s_826)(syntax-e$1 s_826) s_826)))" +"(if(pair? s_827)" +"(let-values(((define-values728_0)" +"(let-values(((s_828)(car s_827))) s_828))" +"((_729_0)" +"(let-values(((s_829)(cdr s_827)))" +"(let-values(((s_830)" +"(if(syntax?$1 s_829)" +"(syntax-e$1 s_829)" +" s_829)))" +"(let-values(((flat-s_62)(to-syntax-list.1 s_830)))" +"(if(not flat-s_62)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_95))" +"(let-values() flat-s_62)))))))" +"(values define-values728_0 _729_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_95)))))" +"(values #t define-values726_1 _727_1))))))" +"(begin" +"(call-expand-observe obs_160 'visit s-defn_0)" +"(call-expand-observe obs_160 'resolve define-values726_0)" +"(call-expand-observe obs_160 'enter-prim s-defn_0)" +"(call-expand-observe obs_160 'prim-define-values)))))" +"(void))))))" +"(define-values" +"(log-defn-exit)" +"(lambda(ctx_120 defn_2 exp-rhs_8)" +"(begin" +"(let-values(((obs_161)(expand-context-observer ctx_120)))" +"(if obs_161" +"(let-values()" +"(let-values(((s-defn_1)" +"(datum->syntax$1" +" #f" +"(list 'define-values(semi-parsed-define-values-ids defn_2) exp-rhs_8)" +"(semi-parsed-define-values-s defn_2))))" +"(begin(call-expand-observe obs_161 'exit-prim s-defn_1)(call-expand-observe obs_161 'return s-defn_1))))" +"(void))))))" +"(define-values" +"(as-expand-time-top-level-bindings)" +"(lambda(ids_46 s_157 ctx_121)" +"(begin" +"(let-values(((top-level-bind-scope_6)(root-expand-context-top-level-bind-scope ctx_121)))" +"(let-values(((tl-ids_2)" +"(reverse$1" +"(let-values(((lst_6) ids_46))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_6)))" +"((letrec-values(((for-loop_98)" +"(lambda(fold-var_379 lst_80)" +"(begin" +" 'for-loop" +"(if(pair? lst_80)" +"(let-values(((id_159)(unsafe-car lst_80))" +"((rest_38)(unsafe-cdr lst_80)))" +"(let-values(((fold-var_60)" +"(let-values(((fold-var_61) fold-var_379))" +"(let-values(((fold-var_380)" +"(let-values()" +"(cons" +"(let-values()" +"(remove-use-site-scopes" +" id_159" +" ctx_121))" +" fold-var_61))))" +"(values fold-var_380)))))" +"(if(not #f)(for-loop_98 fold-var_60 rest_38) fold-var_60)))" +" fold-var_379)))))" +" for-loop_98)" +" null" +" lst_6))))))" +"(let-values((()" +"(begin" +"(let-values(((tl-ids1_0) tl-ids_2)((temp2_8)(expand-context-phase ctx_121))((s3_3) s_157))" +"(check-no-duplicate-ids8.1 #f #f tl-ids1_0 temp2_8 s3_3 #f #f))" +"(values))))" +"(let-values(((tmp-bind-ids_0)" +"(reverse$1" +"(let-values(((lst_94) tl-ids_2))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_94)))" +"((letrec-values(((for-loop_329)" +"(lambda(fold-var_217 lst_81)" +"(begin" +" 'for-loop" +"(if(pair? lst_81)" +"(let-values(((id_3)(unsafe-car lst_81))" +"((rest_261)(unsafe-cdr lst_81)))" +"(let-values(((fold-var_381)" +"(let-values(((fold-var_31) fold-var_217))" +"(let-values(((fold-var_32)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" id_3" +" top-level-bind-scope_6))" +" fold-var_31))))" +"(values fold-var_32)))))" +"(if(not #f)" +"(for-loop_329 fold-var_381 rest_261)" +" fold-var_381)))" +" fold-var_217)))))" +" for-loop_329)" +" null" +" lst_94))))))" +"(values tl-ids_2(select-defined-syms-and-bind!/ctx tmp-bind-ids_0 ctx_121)))))))))" +"(void" +"(add-core-form!*" +" 'define-values" +"(lambda(s_0 ctx_7)" +"(let-values((()" +"(begin" +"(let-values(((obs_162)(expand-context-observer ctx_7)))" +"(if obs_162" +"(let-values()(let-values()(call-expand-observe obs_162 'prim-define-values)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?(expand-context-context ctx_7) 'top-level)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not allowed in an expression position\" s_0)))" +"(values))))" +"(let-values(((disarmed-s_25)(syntax-disarm$1 s_0)))" +"(let-values(((ok?_25 define-values1_0 id2_1 rhs3_0)" +"(let-values(((s_172) s_0))" +"(let-values(((orig-s_96) s_172))" +"(let-values(((define-values1_1 id2_2 rhs3_1)" +"(let-values(((s_40)(if(syntax?$1 s_172)(syntax-e$1 s_172) s_172)))" +"(if(pair? s_40)" +"(let-values(((define-values4_0)" +"(let-values(((s_182)(car s_40))) s_182))" +"((id5_0 rhs6_0)" +"(let-values(((s_41)(cdr s_40)))" +"(let-values(((s_174)" +"(if(syntax?$1 s_41)" +"(syntax-e$1 s_41)" +" s_41)))" +"(if(pair? s_174)" +"(let-values(((id7_0)" +"(let-values(((s_161)(car s_174)))" +"(let-values(((s_5)" +"(if(syntax?$1 s_161)" +"(syntax-e$1 s_161)" +" s_161)))" +"(let-values(((flat-s_63)" +"(to-syntax-list.1" +" s_5)))" +"(if(not flat-s_63)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_96))" +"(let-values()" +"(let-values(((id_160)" +"(let-values(((lst_24)" +" flat-s_63))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_24)))" +"((letrec-values(((for-loop_241)" +"(lambda(id_161" +" lst_76)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_76)" +"(let-values(((s_183)" +"(unsafe-car" +" lst_76))" +"((rest_141)" +"(unsafe-cdr" +" lst_76)))" +"(let-values(((id_162)" +"(let-values(((id_52)" +" id_161))" +"(let-values(((id_163)" +"(let-values()" +"(let-values(((id10_0)" +"(let-values()" +"(if(let-values(((or-part_56)" +"(if(syntax?$1" +" s_183)" +"(symbol?" +"(syntax-e$1" +" s_183))" +" #f)))" +"(if or-part_56" +" or-part_56" +"(symbol?" +" s_183)))" +" s_183" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_96" +" s_183)))))" +"(cons" +" id10_0" +" id_52)))))" +"(values" +" id_163)))))" +"(if(not" +" #f)" +"(for-loop_241" +" id_162" +" rest_141)" +" id_162)))" +" id_161)))))" +" for-loop_241)" +" null" +" lst_24)))))" +"(reverse$1 id_160))))))))" +"((rhs8_0)" +"(let-values(((s_82)(cdr s_174)))" +"(let-values(((s_306)" +"(if(syntax?$1 s_82)" +"(syntax-e$1 s_82)" +" s_82)))" +"(if(pair? s_306)" +"(let-values(((rhs9_0)" +"(let-values(((s_43)" +"(car" +" s_306)))" +" s_43))" +"(()" +"(let-values(((s_307)" +"(cdr" +" s_306)))" +"(let-values(((s_35)" +"(if(syntax?$1" +" s_307)" +"(syntax-e$1" +" s_307)" +" s_307)))" +"(if(null?" +" s_35)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_96))))))" +"(values rhs9_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_96))))))" +"(values id7_0 rhs8_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_96))))))" +"(values define-values4_0 id5_0 rhs6_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_96)))))" +"(values #t define-values1_1 id2_2 rhs3_1))))))" +"(let-values(((ids_47 syms_28)(as-expand-time-top-level-bindings id2_1 s_0 ctx_7)))" +"(let-values(((exp-rhs_9)" +"(let-values(((temp11_6) rhs3_0)((temp12_8)(as-named-context ctx_7 ids_47)))" +"(expand7.1 #f #f #f #f temp11_6 temp12_8))))" +"(if(expand-context-to-parsed? ctx_7)" +"(parsed-define-values19.1 s_0 ids_47 syms_28 exp-rhs_9)" +"(let-values(((s13_0) s_0)((temp14_7)(list define-values1_0 ids_47 exp-rhs_9)))" +"(rebuild5.1 #f #f s13_0 temp14_7))))))))))))" +"(void" +"(add-core-form!*" +" 'define-syntaxes" +"(lambda(s_460 ctx_122)" +"(let-values((()" +"(begin" +"(let-values(((obs_163)(expand-context-observer ctx_122)))" +"(if obs_163" +"(let-values()(let-values()(call-expand-observe obs_163 'prim-define-syntaxes)))" +"(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(let-values(((obs_164)(expand-context-observer ctx_122)))" +"(if obs_164(let-values()(let-values()(call-expand-observe obs_164 'prepare-env)))(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?(expand-context-context ctx_122) 'top-level)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"not allowed in an expression position\" s_460)))" +"(values))))" +"(let-values(((disarmed-s_26)(syntax-disarm$1 s_460)))" +"(let-values(((ok?_89 define-syntaxes15_0 id16_2 rhs17_0)" +"(let-values(((s_831) disarmed-s_26))" +"(let-values(((orig-s_97) s_831))" +"(let-values(((define-syntaxes15_1 id16_3 rhs17_1)" +"(let-values(((s_20)(if(syntax?$1 s_831)(syntax-e$1 s_831) s_831)))" +"(if(pair? s_20)" +"(let-values(((define-syntaxes18_0)" +"(let-values(((s_23)(car s_20))) s_23))" +"((id19_0 rhs20_0)" +"(let-values(((s_431)(cdr s_20)))" +"(let-values(((s_24)" +"(if(syntax?$1 s_431)" +"(syntax-e$1 s_431)" +" s_431)))" +"(if(pair? s_24)" +"(let-values(((id21_0)" +"(let-values(((s_705)(car s_24)))" +"(let-values(((s_467)" +"(if(syntax?$1 s_705)" +"(syntax-e$1 s_705)" +" s_705)))" +"(let-values(((flat-s_64)" +"(to-syntax-list.1" +" s_467)))" +"(if(not flat-s_64)" +"(let-values()" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_97))" +"(let-values()" +"(let-values(((id_93)" +"(let-values(((lst_177)" +" flat-s_64))" +"(begin" +"(if(variable-reference-from-unsafe?" +"(#%variable-reference))" +"(void)" +"(let-values()" +"(check-list" +" lst_177)))" +"((letrec-values(((for-loop_266)" +"(lambda(id_164" +" lst_449)" +"(begin" +" 'for-loop" +"(if(pair?" +" lst_449)" +"(let-values(((s_489)" +"(unsafe-car" +" lst_449))" +"((rest_262)" +"(unsafe-cdr" +" lst_449)))" +"(let-values(((id_75)" +"(let-values(((id_95)" +" id_164))" +"(let-values(((id_165)" +"(let-values()" +"(let-values(((id24_1)" +"(let-values()" +"(if(let-values(((or-part_263)" +"(if(syntax?$1" +" s_489)" +"(symbol?" +"(syntax-e$1" +" s_489))" +" #f)))" +"(if or-part_263" +" or-part_263" +"(symbol?" +" s_489)))" +" s_489" +"(raise-syntax-error$1" +" #f" +" \"not an identifier\"" +" orig-s_97" +" s_489)))))" +"(cons" +" id24_1" +" id_95)))))" +"(values" +" id_165)))))" +"(if(not" +" #f)" +"(for-loop_266" +" id_75" +" rest_262)" +" id_75)))" +" id_164)))))" +" for-loop_266)" +" null" +" lst_177)))))" +"(reverse$1 id_93))))))))" +"((rhs22_0)" +"(let-values(((s_832)(cdr s_24)))" +"(let-values(((s_475)" +"(if(syntax?$1 s_832)" +"(syntax-e$1 s_832)" +" s_832)))" +"(if(pair? s_475)" +"(let-values(((rhs23_2)" +"(let-values(((s_490)" +"(car" +" s_475)))" +" s_490))" +"(()" +"(let-values(((s_44)" +"(cdr" +" s_475)))" +"(let-values(((s_167)" +"(if(syntax?$1" +" s_44)" +"(syntax-e$1" +" s_44)" +" s_44)))" +"(if(null?" +" s_167)" +"(values)" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_97))))))" +"(values rhs23_2))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_97))))))" +"(values id21_0 rhs22_0))" +"(raise-syntax-error$1" +" #f" +" \"bad syntax\"" +" orig-s_97))))))" +"(values define-syntaxes18_0 id19_0 rhs20_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_97)))))" +"(values #t define-syntaxes15_1 id16_3 rhs17_1))))))" +"(let-values(((ids_48 syms_29)(as-expand-time-top-level-bindings id16_2 s_460 ctx_122)))" +"(let-values(((exp-rhs_10)" +"(let-values(((temp25_8) rhs17_0)((temp26_7)(as-named-context ctx_122 ids_48)))" +"(expand-transformer47.1 #f #f #f #f #f #f #f #f #f #f #f #f temp25_8 temp26_7))))" +"(if(expand-context-to-parsed? ctx_122)" +"(parsed-define-syntaxes20.1 s_460 ids_48 syms_29 exp-rhs_10)" +"(let-values(((s27_3) s_460)((temp28_5)(list define-syntaxes15_0 ids_48 exp-rhs_10)))" +"(rebuild5.1 #f #f s27_3 temp28_5)))))))))))))" +"(void" +"(add-core-form!*" +" 'begin-for-syntax" +" (lambda (s_308 ctx_123) (raise-syntax-error$1 #f \"not allowed in an expression position\" s_308))))" +"(void" +"(add-core-form!*" +" '#%require" +"(lambda(s_45 ctx_124)" +"(let-values((()" +"(begin" +"(let-values(((obs_15)(expand-context-observer ctx_124)))" +"(if obs_15(let-values()(let-values()(call-expand-observe obs_15 'prim-require)))(void)))" +"(values))))" +"(let-values((()" +"(begin" +"(if(eq?(expand-context-context ctx_124) 'top-level)" +"(void)" +" (let-values () (raise-syntax-error$1 #f \"allowed only in a module or the top level\" s_45)))" +"(values))))" +"(let-values(((disarmed-s_27)(syntax-disarm$1 s_45)))" +"(let-values(((ok?_90 #%require29_0 req30_0)" +"(let-values(((s_833) disarmed-s_27))" +"(let-values(((orig-s_98) s_833))" +"(let-values(((#%require29_1 req30_1)" +"(let-values(((s_834)(if(syntax?$1 s_833)(syntax-e$1 s_833) s_833)))" +"(if(pair? s_834)" +"(let-values(((#%require31_0)(let-values(((s_46)(car s_834))) s_46))" +"((req32_0)" +"(let-values(((s_32)(cdr s_834)))" +"(let-values(((s_707)" +"(if(syntax?$1 s_32)" +"(syntax-e$1 s_32)" +" s_32)))" +"(let-values(((flat-s_65)(to-syntax-list.1 s_707)))" +"(if(not flat-s_65)" +"(let-values()" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_98))" +"(let-values() flat-s_65)))))))" +"(values #%require31_0 req32_0))" +" (raise-syntax-error$1 #f \"bad syntax\" orig-s_98)))))" +"(values #t #%require29_1 req30_1))))))" +"(let-values(((sc_35)(new-scope 'macro)))" +"(begin" +"(let-values(((temp33_4)" +"(reverse$1" +"(let-values(((lst_12) req30_0))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-list lst_12)))" +"((letrec-values(((for-loop_330)" +"(lambda(fold-var_382 lst_450)" +"(begin" +" 'for-loop" +"(if(pair? lst_450)" +"(let-values(((req_20)(unsafe-car lst_450))" +"((rest_263)(unsafe-cdr lst_450)))" +"(let-values(((fold-var_383)" +"(let-values(((fold-var_384) fold-var_382))" +"(let-values(((fold-var_36)" +"(let-values()" +"(cons" +"(let-values()" +"(add-scope" +" req_20" +" sc_35))" +" fold-var_384))))" +"(values fold-var_36)))))" +"(if(not #f)" +"(for-loop_330 fold-var_383 rest_263)" +" fold-var_383)))" +" fold-var_382)))))" +" for-loop_330)" +" null" +" lst_12)))))" +"((s34_0) s_45)" +"((temp35_3) #f)" +"((temp36_7)(expand-context-namespace ctx_124))" +"((temp37_5)(expand-context-phase ctx_124))" +"((temp38_3)(let-values(((temp41_5) #f))(make-requires+provides8.1 #f #f temp41_5)))" +"((temp39_8) 'require)" +"((temp40_4) #t))" +"(parse-and-perform-requires!30.1" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp40_4" +" #t" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" #f" +" temp35_3" +" #t" +" temp39_8" +" temp33_4" +" s34_0" +" temp36_7" +" temp37_5" +" temp38_3))" +"(if(expand-context-to-parsed? ctx_124)(parsed-require23.1 s_45) s_45))))))))))" +"(void" +"(add-core-form!*" +" '#%provide" +"(lambda(s_434 ctx_125)" +"(begin" +"(let-values(((obs_23)(expand-context-observer ctx_125)))" +"(if obs_23(let-values()(let-values()(call-expand-observe obs_23 'prim-provide)))(void)))" +" (raise-syntax-error$1 #f \"not allowed outside of a module body\" s_434)))))" +"(define-values(ns)(make-namespace))" +"(void" +"(begin" +"(declare-core-module! ns)" +"(let-values(((temp1_4) '#%read)((read-primitives2_0) read-primitives)((ns3_1) ns))" +"(declare-hash-based-module!41.1 ns3_1 #f #f #f #f #f #f #f #f temp1_4 read-primitives2_0))" +"(let-values(((temp4_9) '#%main)((main-primitives5_0) main-primitives)((ns6_1) ns))" +"(declare-hash-based-module!41.1 ns6_1 #f #f #f #f #f #f #f #f temp4_9 main-primitives5_0))" +"(let-values(((temp7_4) '#%utils)((utils-primitives8_0) utils-primitives)((ns9_1) ns))" +"(declare-hash-based-module!41.1 ns9_1 #f #f #f #f #f #f #f #f temp7_4 utils-primitives8_0))" +"(let-values(((temp10_7) '#%place-struct)" +"((place-struct-primitives11_0) place-struct-primitives)" +"((ns12_1) ns)" +"((temp13_3) '(dynamic-place)))" +"(declare-hash-based-module!41.1 ns12_1 #f #f temp13_3 #t #f #f #f #f temp10_7 place-struct-primitives11_0))" +"(let-values(((temp14_8) '#%boot)((boot-primitives15_0) boot-primitives)((ns16_1) ns))" +"(declare-hash-based-module!41.1 ns16_1 #f #f #f #f #f #f #f #f temp14_8 boot-primitives15_0))" +"(let-values(((linklet-primitives_0)" +"(hash-remove(hash-remove linklet-primitives 'variable-reference?) 'variable-reference-constant?)))" +"(let-values(((temp17_4) '#%linklet)" +"((linklet-primitives18_0) linklet-primitives_0)" +"((ns19_1) ns)" +"((temp20_5) #t)" +"((temp21_2) #t))" +"(declare-hash-based-module!41.1 ns19_1 temp20_5 #t #f #f #f #f temp21_2 #t temp17_4 linklet-primitives18_0)))" +"(let-values(((temp22_6) '#%expobs)((expobs-primitives23_0) expobs-primitives)((ns24_2) ns)((temp25_9) #t))" +"(declare-hash-based-module!41.1 ns24_2 #f #f #f #f temp25_9 #t #f #f temp22_6 expobs-primitives23_0))" +"(let-values(((eval27_0) 1/eval)" +"((temp28_6)" +"(let-values(((ht_66) main-primitives))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_66)))" +"((letrec-values(((for-loop_77)" +"(lambda(table_216 i_80)" +"(begin" +" 'for-loop" +"(if i_80" +"(let-values(((name_82)(hash-iterate-key ht_66 i_80)))" +"(let-values(((table_102)" +"(let-values(((table_217) table_216))" +"(let-values(((table_218)" +"(let-values()" +"(let-values(((key_67 val_88)" +"(let-values()" +"(values" +"(let-values() name_82)" +" #t))))" +"(hash-set table_217 key_67 val_88)))))" +"(values table_218)))))" +"(if(not #f)" +"(for-loop_77 table_102(hash-iterate-next ht_66 i_80))" +" table_102)))" +" table_216)))))" +" for-loop_77)" +" '#hash()" +"(hash-iterate-first ht_66)))))" +"((temp29_4)" +"(let-values(((ht_167) read-primitives))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))" +"(void)" +"(let-values()(check-in-hash-keys ht_167)))" +"((letrec-values(((for-loop_269)" +"(lambda(table_202 i_36)" +"(begin" +" 'for-loop" +"(if i_36" +"(let-values(((name_83)(hash-iterate-key ht_167 i_36)))" +"(let-values(((table_219)" +"(let-values(((table_175) table_202))" +"(let-values(((table_95)" +"(let-values()" +"(let-values(((key_95 val_89)" +"(let-values()" +"(values" +"(let-values() name_83)" +" #t))))" +"(hash-set table_175 key_95 val_89)))))" +"(values table_95)))))" +"(if(not #f)" +"(for-loop_269 table_219(hash-iterate-next ht_167 i_36))" +" table_219)))" +" table_202)))))" +" for-loop_269)" +" '#hash()" +"(hash-iterate-first ht_167))))))" +"(declare-kernel-module!8.1 eval27_0 temp28_6 temp29_4 ns))" +"(begin" +"(let-values(((lst_270) runtime-instances))" +"(begin" +"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_270)))" +"((letrec-values(((for-loop_331)" +"(lambda(lst_54)" +"(begin" +" 'for-loop" +"(if(pair? lst_54)" +"(let-values(((name_84)(unsafe-car lst_54))((rest_171)(unsafe-cdr lst_54)))" +"(let-values((()" +"(let-values()" +"(if(eq? name_84 '#%kernel)" +"(values)" +"(let-values()" +"(let-values((()" +"(let-values()" +"(begin" +"(let-values()" +"(let-values(((ns31_4) ns)" +"((temp32_1)" +"(let-values(((or-part_53)" +"(eq?" +" name_84" +" '#%foreign)))" +"(if or-part_53" +" or-part_53" +"(let-values(((or-part_21)" +"(eq?" +" name_84" +" '#%futures)))" +"(if or-part_21" +" or-part_21" +"(eq?" +" name_84" +" '#%unsafe)))))))" +"(copy-runtime-module!26.1" +" #f" +" #f" +" #f" +" #f" +" ns31_4" +" #f" +" #f" +" temp32_1" +" #t" +" #f" +" #f" +" #f" +" #f" +" name_84)))" +"(values)))))" +"(values)))))))" +"(if(not #f)(for-loop_331 rest_171)(values))))" +"(values))))))" +" for-loop_331)" +" lst_270)))" +"(void))" +"(let-values(((temp33_5) '#%builtin)" +"((temp34_4)(list* '#%place-struct '#%utils '#%boot '#%expobs '#%linklet runtime-instances))" +"((ns35_1) ns)" +"((temp36_8) #f))" +"(declare-reexporting-module!50.1 ns35_1 temp36_8 #t temp33_5 temp34_4))" +"(1/current-namespace ns)" +"(1/dynamic-require ''#%kernel 0)))" +"(define-values(datum->kernel-syntax)(lambda(s_460)(begin(1/datum->syntax core-stx s_460)))))" +; diff --git a/racket/src/racket/src/startup.rktl b/racket/src/racket/src/startup.rktl deleted file mode 100644 index 9f87baf734..0000000000 --- a/racket/src/racket/src/startup.rktl +++ /dev/null @@ -1,1688 +0,0 @@ -;; This file is converted to [c]startup.inc and evaluated by -;; Racket's scheme_basic_env(). - -;; It implements, in a non-bootstrapping way, some functions -;; needed to start up Racket --- especially to install the -;; default module-name resolver. - -;; Racket runs ((dynamic-require ''#%boot boot)) on startup. Then, -;; after configuring all startup parameters, Racket may run -;; ((dynamic-require ''#%boot seal)), and it may seal multiple -;; times. So, replace the content of this file to get a different set -;; of initial module definitions and parameter values. - -;; When using makefiles, `make startup' in [the build directory for] -;; "plt/src/racket" creates "plt/src/racket/src/cstartup.inc", and -;; `make cstartup' creates plt/src/racket/src/cstartup.inc. Both -;; require a working Racket executable. - -;; The recommend build strategy for cstartup.inc is -;; * Set USE_COMPILED_STARTUP in schminc.h to 0 -;; * Modify startup.rkt to taste -;; * Run make startup in /racket -;; * Run make in /racket -;; * Set USE_COMPILED_STARTUP in schminc.h to 1 -;; * Run make in /racket - -;; Do not use block comments (with #| and |#) in this file. The -;; script to build startup.inc can't handle them. - -;; ------------------------------------------------------ -;; Minimal syntax (no error checks!) needed for the rest - -(module #%min-stx '#%kernel - (#%require '#%paramz - (for-syntax '#%kernel)) - - (#%provide unless when - and or - cond - let let* letrec - let*-values - parameterize - define) - - (begin-for-syntax - (define-values (here-stx) (quote-syntax here))) - - (define-syntaxes (unless) - (lambda (stx) - (let-values ([(s) (syntax->list stx)]) - (datum->syntax here-stx - (list 'if (cadr s) - (void) - (cons 'begin (cddr s))))))) - - (define-syntaxes (when) - (lambda (stx) - (let-values ([(s) (syntax->list stx)]) - (datum->syntax here-stx - (list 'if (cadr s) - (cons 'begin (cddr s)) - (void)))))) - - (define-syntaxes (and) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (if (null? s) - (quote-syntax #t) - (if (null? (cdr s)) - (car s) - (datum->syntax here-stx - (list 'if (car s) (cons 'and (cdr s)) #f))))))) - - (define-syntaxes (or) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (if (null? s) - (quote-syntax #f) - (if (null? (cdr s)) - (car s) - (datum->syntax here-stx - (list 'let-values (list (list (list 'x) - (car s))) - (list 'if 'x 'x (cons 'or (cdr s)))))))))) - - (define-syntaxes (let) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (datum->syntax - here-stx - (if (symbol? (syntax-e (car s))) - (let-values ([(clauses) - (map (lambda (c) - (syntax->list c)) - (syntax->list (cadr s)))]) - (list 'letrec-values (list (list (list (car s)) - (list* 'lambda - (map car clauses) - (cddr s)))) - (cons (car s) (map cadr clauses)))) - (list* 'let-values (map (lambda (c) - (let-values ([(c) (syntax->list c)]) - (cons (list (car c)) - (cdr c)))) - (syntax->list (car s))) - (cdr s))))))) - - (define-syntaxes (letrec) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (datum->syntax - here-stx - (list* 'letrec-values (map (lambda (c) - (let-values ([(c) (syntax->list c)]) - (cons (list (car c)) - (cdr c)))) - (syntax->list (car s))) - (cdr s)))))) - - (define-syntaxes (let*) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (let-values ([(fst) (syntax->list (car s))]) - (datum->syntax - here-stx - (if (null? fst) - (list* 'let-values () (cdr s)) - (list 'let (list (car fst)) - (list* 'let* (cdr fst) (cdr s))))))))) - - (define-syntaxes (let*-values) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (let-values ([(fst) (syntax->list (car s))]) - (datum->syntax - here-stx - (if (null? fst) - (list* 'let-values () (cdr s)) - (list 'let-values (list (car fst)) - (list* 'let*-values (cdr fst) (cdr s))))))))) - - (define-syntaxes (parameterize) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (let-values ([(bindings) (apply append - (map syntax->list (syntax->list (car s))))]) - (syntax-arm - (datum->syntax - here-stx - (list 'with-continuation-mark - 'parameterization-key - (list* 'extend-parameterization - '(continuation-mark-set-first #f parameterization-key) - bindings) - (list* 'let-values () - (cdr s))))))))) - - (define-syntaxes (cond) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (if (null? s) - (quote-syntax (void)) - (datum->syntax - here-stx - (let-values ([(a) (syntax->list (car s))]) - (if (eq? '=> (syntax-e (cadr a))) - (list 'let-values (list (list '(v) (car a))) - (list* 'cond - (list 'v (list (caddr a) 'v)) - (cdr s))) - (list 'if (if (eq? (syntax-e (car a)) 'else) - #t - (car a)) - (list* 'let-values '() (cdr a)) - (cons 'cond (cdr s)))))))))) - - (define-syntaxes (define) - (lambda (stx) - (let-values ([(s) (cdr (syntax->list stx))]) - (datum->syntax - here-stx - (if (symbol? (syntax-e (car s))) - (list 'define-values (list (car s)) (cadr s)) - (let-values ([(a) (syntax-e (car s))]) - (list 'define-values (list (car a)) - (list* 'lambda (cdr a) - (cdr s)))))))))) - -;; ---------------------------------------- -;; Utilities that are eventually exported to the rest of the world -;; (along with much of '#%kernel) - -(module #%utils '#%kernel - (#%require '#%min-stx '#%paramz) - - (#%provide path-string? - normal-case-path - path-replace-extension - path-add-extension - reroot-path - find-col-file - collection-path - collection-file-path - find-library-collection-paths - find-library-collection-links - path-list-string->path-list - find-executable-path - load/use-compiled - embedded-load - call-with-default-reading-parameterization - find-main-collects - find-main-config) - - (define-values (path-string?) - (lambda (s) - (or (path? s) - (and (string? s) - (or (relative-path? s) - (absolute-path? s)))))) - - (define-values (bsbs) (string #\u5C #\u5C)) - - (define-values (normal-case-path) - (lambda (s) - (unless (or (path-for-some-system? s) - (path-string? s)) - (raise-argument-error 'normal-path-case "(or/c path-for-some-system? path-string?)" s)) - (cond - [(if (path-for-some-system? s) - (eq? (path-convention-type s) 'windows) - (eq? (system-type) 'windows)) - (let ([str (if (string? s) s (bytes->string/locale (path->bytes s)))]) - (if (regexp-match? #rx"^[\u5C][\u5C][?][\u5C]" str) - (if (string? s) - (string->path s) - s) - (let ([s (string-locale-downcase str)]) - (bytes->path - (string->bytes/locale - (regexp-replace* #rx"/" - (if (regexp-match? #rx"[/\u5C][. ]+[/\u5C]*$" s) - ;; Just "." or ".." in last path element - don't remove - s - (regexp-replace* #rx"\u5B .\u5D+([/\u5C]*)$" s "\u005C1")) - bsbs)) - 'windows))))] - [(string? s) (string->path s)] - [else s]))) - - (define-values (reroot-path) - (lambda (p root) - (unless (or (path-string? p) (path-for-some-system? p)) - (raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 0 p root)) - (unless (or (path-string? root) (path-for-some-system? root)) - (raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 1 p root)) - (define conv (if (path-for-some-system? p) - (path-convention-type p) - (system-path-convention-type))) - (unless (or (complete-path? p) - (eq? (system-path-convention-type) conv)) - (raise-arguments-error 'reroot-path - "path is not complete and not the platform's convention" - "path" p - "platform convention type" (system-path-convention-type))) - (unless (eq? (if (path-for-some-system? root) - (path-convention-type root) - (system-path-convention-type)) - conv) - (raise-arguments-error 'reroot-path - "given paths use different conventions" - "path" p - "root path" root)) - (define c-p (normal-case-path (cleanse-path (if (complete-path? p) - p - (path->complete-path p))))) - (define bstr (path->bytes c-p)) - (cond - [(eq? conv 'unix) - (if (bytes=? bstr #"/") - (if (path-for-some-system? root) - root - (string->path root)) - (build-path root (bytes->path (subbytes (path->bytes c-p) 1) conv)))] - [(eq? conv 'windows) - (build-path - root - (bytes->path - (cond - ((regexp-match? #rx"^\\\\\\\\[?]\\\\[a-z]:" bstr) - (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4 5) #"\\" (subbytes bstr 6))) - ((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr) - (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4))) - ((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr) - (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4))) - ((regexp-match? #rx"^\\\\\\\\" bstr) - (bytes-append #"UNC\\" (subbytes bstr 2))) - ((regexp-match? #rx"^[a-z]:" bstr) - (bytes-append (subbytes bstr 0 1) (subbytes bstr 2)))) - conv))]))) - - ;; ------------------------------ executable path ------------------------------ - - (define-values (find-executable-path) - (case-lambda - [(program libpath reverse?) - (unless (path-string? program) - (raise-argument-error 'find-executable-path "path-string?" program)) - (unless (or (not libpath) (and (path-string? libpath) - (relative-path? libpath))) - (raise-argument-error 'find-executable-path "(or/c #f (and/c path-string? relative-path?))" libpath)) - (letrec ([found-exec - (lambda (exec-name) - (if libpath - (let-values ([(base name isdir?) (split-path exec-name)]) - (let ([next - (lambda () - (let ([resolved (resolve-path exec-name)]) - (cond - [(equal? resolved exec-name) #f] - [(relative-path? resolved) - (found-exec (build-path base resolved))] - [else (found-exec resolved)])))]) - (or (and reverse? (next)) - (if (path? base) - (let ([lib (build-path base libpath)]) - (and (or (directory-exists? lib) - (file-exists? lib)) - lib)) - #f) - (and (not reverse?) (next))))) - exec-name))]) - (if (and (relative-path? program) - (let-values ([(base name dir?) (split-path program)]) - (eq? base 'relative))) - (let ([paths-str (environment-variables-ref (current-environment-variables) - #"PATH")] - [win-add (lambda (s) (if (eq? (system-type) 'windows) - (cons (bytes->path #".") s) - s))]) - (let loop ([paths (win-add - (if paths-str - (path-list-string->path-list (bytes->string/locale paths-str #\?) - null) - null))]) - (if (null? paths) - #f - (let* ([base (path->complete-path (car paths))] - [name (build-path base program)]) - (if (file-exists? name) - (found-exec name) - (loop (cdr paths))))))) - (let ([p (path->complete-path program)]) - (and (file-exists? p) (found-exec p)))))] - [(program libpath) (find-executable-path program libpath #f)] - [(program) (find-executable-path program #f #f)])) - - (define-values (path-list-string->path-list) - (let ((r (byte-regexp (string->bytes/utf-8 - (let ((sep (if (eq? (system-type) 'windows) - ";" - ":"))) - (format "([^~a]*)~a(.*)" sep sep))))) - (cons-path (lambda (default s l) - (let ([s (if (eq? (system-type) 'windows) - (regexp-replace* #rx#"\"" s #"") - s)]) - (if (bytes=? s #"") - (append default l) - (cons (bytes->path s) - l)))))) - (lambda (s default) - (unless (or (bytes? s) - (string? s)) - (raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s)) - (unless (and (list? default) - (andmap path? default)) - (raise-argument-error 'path-list-string->path-list "(listof path?)" default)) - (let loop ([s (if (string? s) - (string->bytes/utf-8 s) - s)]) - (let ([m (regexp-match r s)]) - (if m - (cons-path default (cadr m) (loop (caddr m))) - (cons-path default s null))))))) - - ;; ------------------------------ Reading ------------------------------ - - (define (call-with-default-reading-parameterization thunk) - (if (and (procedure? thunk) - (procedure-arity-includes? thunk 0)) - (parameterize ([read-case-sensitive #t] - [read-square-bracket-as-paren #t] - [read-curly-brace-as-paren #t] - [read-square-bracket-with-tag #f] - [read-curly-brace-with-tag #f] - [read-accept-box #t] - [read-accept-compiled #f] - [read-accept-bar-quote #t] - [read-accept-graph #t] - [read-decimal-as-inexact #t] - [read-cdot #f] - [read-accept-dot #t] - [read-accept-infix-dot #t] - [read-accept-quasiquote #t] - [read-accept-reader #f] - [read-accept-lang #t] - [current-readtable #f]) - (thunk)) - (raise-argument-error 'call-with-default-reading-parameterization - "(procedure-arity-includes/c 0)" - thunk))) - - ;; ------------------------------ Collections ------------------------------ - - (define-values (-check-relpath) - (lambda (who s) - (unless (path-string? s) - (raise-argument-error who "path-string?" s)) - (unless (relative-path? s) - (raise-arguments-error who - "invalid relative path" - "path" s)))) - - (define-values (-check-collection) - (lambda (who collection collection-path) - (-check-relpath who collection) - (for-each (lambda (p) (-check-relpath who p)) collection-path))) - - (define-values (-check-fail) - (lambda (who fail) - (unless (and (procedure? fail) - (procedure-arity-includes? fail 1)) - (raise-argument-error who "(any/c . -> . any)" fail)))) - - (define-values (collection-path) - (lambda (fail collection collection-path) - (-check-collection 'collection-path collection collection-path) - (-check-fail 'collection-path fail) - (find-col-file fail - collection collection-path - #f - #f))) - - (define-values (collection-file-path) - (lambda (fail check-compiled? file-name collection collection-path) - (-check-relpath 'collection-file-path file-name) - (-check-collection 'collection-file-path collection collection-path) - (-check-fail 'collection-file-path fail) - (find-col-file fail - collection collection-path - file-name - check-compiled?))) - - (define-values (find-main-collects) - (lambda () - ;; Recorded once and for all (per place), which helps avoid - ;; sandbox problems: - (cache-configuration - 0 - (lambda () - (exe-relative-path->complete-path (find-system-path 'collects-dir)))))) - - (define-values (find-main-config) - (lambda () - ;; Also recorded once and for all (per place): - (cache-configuration - 1 - (lambda () - (exe-relative-path->complete-path (find-system-path 'config-dir)))))) - - (define-values (get-config-table) - (lambda (d) - (let ([p (and d (build-path d "config.rktd"))]) - (or (and p - (file-exists? p) - (with-input-from-file p - (lambda () - (let ([v (call-with-default-reading-parameterization read)]) - (and (hash? v) - v))))) - #hash())))) - - (define-values (get-installation-name) - (lambda (config-table) - (hash-ref config-table - 'installation-name - (version)))) - - (define-values (coerce-to-path) - (lambda (p) - (cond - [(string? p) (collects-relative-path->complete-path (string->path p))] - [(bytes? p) (collects-relative-path->complete-path (bytes->path p))] - [(path? p) (collects-relative-path->complete-path p)] - [else p]))) - - (define-values (collects-relative-path->complete-path) - (lambda (p) - (cond - [(complete-path? p) p] - [else - (path->complete-path p (or (find-main-collects) - ;; If we get here, then something is configured wrong, - ;; and making up paths relative to the current directory - ;; is not great --- but we have to come up with some - ;; path at this point. - (current-directory)))]))) - - (define-values (exe-relative-path->complete-path) - (lambda (collects-path) - (cond - [(complete-path? collects-path) (simplify-path collects-path)] - [(absolute-path? collects-path) - ;; This happens only under Windows; add a drive - ;; specification to make the path complete - (let ([exec (path->complete-path - (find-executable-path (find-system-path 'exec-file)) - (find-system-path 'orig-dir))]) - (let-values ([(base name dir?) (split-path exec)]) - (simplify-path (path->complete-path collects-path base))))] - [else - (let ([p (find-executable-path (find-system-path 'exec-file) collects-path #t)]) - (and p (simplify-path p)))]))) - - (define-values (add-config-search) - (lambda (ht key orig-l) - (let ([l (hash-ref ht key #f)]) - (if l - (let loop ([l l]) - (cond - [(null? l) null] - [(not (car l)) (append orig-l (loop (cdr l)))] - [else (cons (coerce-to-path (car l)) (loop (cdr l)))])) - orig-l)))) - - (define-values (find-library-collection-links) - (lambda () - (let* ([ht (get-config-table (find-main-config))] - [lf (coerce-to-path - (or (hash-ref ht 'links-file #f) - (build-path (or (hash-ref ht 'share-dir #f) - (build-path 'up "share")) - "links.rktd")))]) - (append - ;; `#f' means `current-library-collection-paths': - (list #f) - ;; user-specific - (if (and (use-user-specific-search-paths) - (use-collection-link-paths)) - (list (build-path (find-system-path 'addon-dir) - (get-installation-name ht) - "links.rktd")) - null) - ;; installation-wide: - (if (use-collection-link-paths) - (add-config-search - ht - 'links-search-files - (list lf)) - null))))) - - ;; map from link-file names to cached information: - (define-values (links-cache) (make-weak-hash)) - - ;; used for low-level except abort below: - (define-values (stamp-prompt-tag) (make-continuation-prompt-tag 'stamp)) - - (define-values (file->stamp) - (lambda (path old-stamp) - ;; Using just the file's modification date almost works as a stamp, - ;; but 1-second granularity isn't fine enough. A stamp is therefore - ;; the file content paired with a filesystem-change event (where - ;; supported), and the event lets us recycle the old stamp almost - ;; always. - (cond - [(and old-stamp - (cdr old-stamp) - (not (sync/timeout 0 (cdr old-stamp)))) - old-stamp] - [else - (call-with-continuation-prompt - (lambda () - (with-continuation-mark - exception-handler-key - (lambda (exn) - (abort-current-continuation - stamp-prompt-tag - (if (exn:fail:filesystem? exn) - (lambda () #f) - (lambda () (raise exn))))) - (let ([dir-evt - (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? - (let loop ([path path]) - (let-values ([(base name dir?) (split-path path)]) - (and (path? base) - (if (directory-exists? base) - (filesystem-change-evt base (lambda () #f)) - (loop base))))))]) - (if (not (file-exists? path)) - (cons #f dir-evt) - (let ([evt (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ? - (filesystem-change-evt path (lambda () #f)))]) - (when dir-evt (filesystem-change-evt-cancel dir-evt)) - (cons - (let ([p (open-input-file path)]) - (dynamic-wind - void - (lambda () - (let ([bstr (read-bytes 8192 p)]) - (if (and (bytes? bstr) - ((bytes-length bstr) . >= . 8192)) - (apply - bytes-append - (cons - bstr - (let loop () - (let ([bstr (read-bytes 8192 p)]) - (if (eof-object? bstr) - null - (cons bstr (loop))))))) - bstr))) - (lambda () (close-input-port p)))) - evt)))))) - stamp-prompt-tag)]))) - - (define-values (no-file-stamp?) - (lambda (a) - (or (not a) - (not (car a))))) - - (define-values (get-linked-collections) - (lambda (links-path) - ;; Use/save information in `links-cache', relying on filesystem-change events - ;; or a copy of the file to detect when the cache is stale. - (call-with-escape-continuation - (lambda (esc) - (define-values (make-handler) - (lambda (ts) - (lambda (exn) - (if (exn:fail? exn) - (let ([l (current-logger)]) - (when (log-level? l 'error) - (log-message l 'error - (format - "error reading collection links file ~s: ~a" - links-path - (exn-message exn)) - (current-continuation-marks)))) - (void)) - (when ts - (hash-set! links-cache links-path (cons ts #hasheq()))) - (if (exn:fail? exn) - (esc (make-hasheq)) - ;; re-raise the exception (which is probably a break) - exn)))) - (with-continuation-mark - exception-handler-key - (make-handler #f) - (let* ([links-stamp+cache (hash-ref links-cache links-path '(#f . #hasheq()))] - [a-links-stamp (car links-stamp+cache)] - [ts (file->stamp links-path a-links-stamp)]) - (if (not (equal? ts a-links-stamp)) - (with-continuation-mark - exception-handler-key - (make-handler ts) - (call-with-default-reading-parameterization - (lambda () - (let ([v (if (no-file-stamp? ts) - null - (let ([p (open-input-file links-path 'binary)]) - (dynamic-wind - void - (lambda () - (begin0 - (read p) - (unless (eof-object? (read p)) - (error "expected a single S-expression")))) - (lambda () (close-input-port p)))))]) - (unless (and (list? v) - (andmap (lambda (p) - (and (list? p) - (or (= 2 (length p)) - (= 3 (length p))) - (or (string? (car p)) - (eq? 'root (car p)) - (eq? 'static-root (car p))) - (path-string? (cadr p)) - (or (null? (cddr p)) - (regexp? (caddr p))))) - v)) - (error "ill-formed content")) - (let ([ht (make-hasheq)] - [dir (let-values ([(base name dir?) (split-path links-path)]) - base)]) - (for-each - (lambda (p) - (when (or (null? (cddr p)) - (regexp-match? (caddr p) (version))) - (let ([dir (simplify-path - (path->complete-path (cadr p) dir))]) - (cond - [(eq? (car p) 'static-root) - ;; multi-collection, constant content: - (for-each - (lambda (sub) - (when (directory-exists? (build-path dir sub)) - (let ([k (string->symbol (path->string sub))]) - (hash-set! ht k (cons dir (hash-ref ht k null)))))) - (directory-list dir))] - [(eq? (car p) 'root) - ;; multi-collection, dynamic content: - ;; Add directory to the #f mapping, and also - ;; add to every existing table element (to keep - ;; the choices in order) - (unless (hash-ref ht #f #f) - (hash-set! ht #f null)) - (hash-for-each - ht - (lambda (k v) - (hash-set! ht k (cons dir v))))] - [else - ;; single collection: - (let ([s (string->symbol (car p))]) - (hash-set! ht s (cons (box dir) - (hash-ref ht s null))))])))) - v) - ;; reverse all lists: - (hash-for-each - ht - (lambda (k v) (hash-set! ht k (reverse v)))) - ;; save table & file content: - (hash-set! links-cache links-path (cons ts ht)) - ht))))) - (cdr links-stamp+cache)))))))) - - (define-values (normalize-collection-reference) - (lambda (collection collection-path) - ;; make sure that `collection' is a top-level collection name, - (cond - [(string? collection) - (let ([m (regexp-match-positions #rx"/+" collection)]) - (if m - (cond - [(= (caar m) (sub1 (string-length collection))) - (values (substring collection 0 (caar m)) collection-path)] - [else - (values (substring collection 0 (caar m)) - (cons (substring collection (cdar m)) - collection-path))]) - (values collection collection-path)))] - [else - (let-values ([(base name dir?) (split-path collection)]) - (if (eq? base 'relative) - (values name collection-path) - (normalize-collection-reference base (cons name collection-path))))]))) - - (define-values (find-col-file) - (lambda (fail collection collection-path file-name check-compiled?) - (let-values ([(collection collection-path) - (normalize-collection-reference collection collection-path)]) - (let ([all-paths (let ([sym (string->symbol - (if (path? collection) - (path->string collection) - collection))]) - (let loop ([l (current-library-collection-links)]) - (cond - [(null? l) null] - [(not (car l)) - ;; #f is the point where we try the old parameter: - (append - (current-library-collection-paths) - (loop (cdr l)))] - [(hash? (car l)) - ;; A hash table maps a collection-name symbol - ;; to a list of paths. We need to wrap each path - ;; in a box, because that's how the code below - ;; knows that it's a single collection's directory. - ;; A hash table can also map #f to a list of paths - ;; for directories that hold collections. - (append - (map box (hash-ref (car l) sym null)) - (hash-ref (car l) #f null) - (loop (cdr l)))] - [else - (let ([ht (get-linked-collections (car l))]) - (append - ;; Table values are lists of paths and (box path)s, - ;; where a (box path) is a collection directory - ;; (instead of a directory containing collections). - (hash-ref ht sym null) - (hash-ref ht #f null) - (loop (cdr l))))])))]) - (define-values (done) - (lambda (p) - (if file-name (build-path p file-name) p))) - (define-values (*build-path-rep) - (lambda (p c) - (if (path? p) - (build-path p c) - ;; box => from links table for c - (unbox p)))) - (define-values (*directory-exists?) - (lambda (orig p) - (if (path? orig) - (directory-exists? p) - ;; orig is box => from links table - #t))) - (define-values (to-string) (lambda (p) (if (path? p) (path->string p) p))) - (let cloop ([paths all-paths] [found-col #f]) - (if (null? paths) - (if found-col - (done found-col) - (let ([rest-coll - (if (null? collection-path) - "" - (apply - string-append - (let loop ([cp collection-path]) - (if (null? (cdr cp)) - (list (to-string (car cp))) - (list* (to-string (car cp)) "/" (loop (cdr cp)))))))]) - (define-values (filter) - (lambda (f l) - (if (null? l) - null - (if (f (car l)) - (cons (car l) (filter f (cdr l))) - (filter f (cdr l)))))) - (fail - (format "collection not found\n collection: ~s\n in collection directories:~a~a" - (if (null? collection-path) - (to-string collection) - (string-append (to-string collection) "/" rest-coll)) - (apply - string-append - (map (lambda (p) - (format "\n ~a ~a" " " p)) - (let ([len (length all-paths)] - [clen (length (current-library-collection-paths))]) - (if ((- len clen) . < . 5) - all-paths - (append (current-library-collection-paths) - (list (format "... [~a additional linked and package directories]" - (- len clen)))))))) - (if (ormap box? all-paths) - (format "\n sub-collection: ~s\n in parent directories:~a" - rest-coll - (apply - string-append - (map (lambda (p) - (format "\n ~a" (unbox p))) - (filter box? all-paths)))) - ""))))) - (let ([dir (*build-path-rep (car paths) collection)]) - (if (*directory-exists? (car paths) dir) - (let ([cpath (apply build-path dir collection-path)]) - (if (if (null? collection-path) - #t - (directory-exists? cpath)) - (if file-name - (if (or (file-exists?/maybe-compiled cpath file-name - check-compiled?) - (let ([alt-file-name - (let* ([file-name (if (path? file-name) - (path->string file-name) - file-name)] - [len (string-length file-name)]) - (and (len . >= . 4) - (string=? ".rkt" (substring file-name (- len 4))) - (string-append (substring file-name 0 (- len 4)) ".ss")))]) - (and alt-file-name - (file-exists?/maybe-compiled cpath alt-file-name - check-compiled?)))) - (done cpath) - ;; Look further for specific file, but remember - ;; first found directory - (cloop (cdr paths) (or found-col cpath))) - ;; Just looking for dir; found it: - (done cpath)) - ;; sub-collection not here; try next instance - ;; of the top-level collection - (cloop (cdr paths) found-col))) - (cloop (cdr paths) found-col))))))))) - - (define-values (file-exists?/maybe-compiled) - (lambda (dir path check-compiled?) - (or (file-exists? (build-path dir path)) - (and check-compiled? - (let ([try-path (path-add-extension path #".zo")] - [modes (use-compiled-file-paths)] - [roots (current-compiled-file-roots)]) - (ormap (lambda (d) - (ormap (lambda (mode) - (file-exists? - (let ([p (build-path dir mode try-path)]) - (cond - [(eq? d 'same) p] - [(relative-path? d) (build-path p d)] - [else (reroot-path p d)])))) - modes)) - roots)))))) - - (define-values (check-extension-call) - (lambda (s sfx who) - (unless (or (path-for-some-system? s) - (path-string? s)) - (raise-argument-error who "(or/c path-for-some-system? path-string?)" 0 s sfx)) - (unless (or (string? sfx) (bytes? sfx)) - (raise-argument-error who "(or/c string? bytes?)" 1 s sfx)) - (let-values ([(base name dir?) (split-path s)]) - (when (not base) - (raise-mismatch-error who "cannot add an extension to a root path: " s)) - (values base name)))) - - (define-values (path-adjust-extension) - (lambda (name sep rest-bytes s sfx) - (let-values ([(base name) (check-extension-call s sfx name)]) - (define bs (path-element->bytes name)) - (define finish - (lambda (i sep i2) - (bytes->path-element - (bytes-append - (subbytes bs 0 i) - sep - (rest-bytes bs i2) - (if (string? sfx) - (string->bytes/locale sfx (char->integer #\?)) - sfx)) - (if (path-for-some-system? s) - (path-convention-type s) - (system-path-convention-type))))) - (let ([new-name (letrec-values ([(loop) - (lambda (i) - (if (zero? i) - (finish (bytes-length bs) #"" (bytes-length bs)) - (let-values ([(i) (sub1 i)]) - (if (and (not (zero? i)) - (eq? (char->integer #\.) (bytes-ref bs i))) - (finish i sep (add1 i)) - (loop i)))))]) - (loop (bytes-length bs)))]) - (if (path-for-some-system? base) - (build-path base new-name) - new-name))))) - - (define-values (path-replace-extension) - (lambda (s sfx) - (path-adjust-extension 'path-replace-extension #"" (lambda (bs i) #"") s sfx))) - - (define-values (path-add-extension) - (lambda (s sfx) - (path-adjust-extension 'path-add-extension #"_" subbytes s sfx))) - - (define-values (load/use-compiled) - (lambda (f) ((current-load/use-compiled) f #f))) - - (define-values (find-library-collection-paths) - (case-lambda - [() (find-library-collection-paths null null)] - [(extra-collects-dirs) (find-library-collection-paths extra-collects-dirs null)] - [(extra-collects-dirs post-collects-dirs) - (let ([user-too? (use-user-specific-search-paths)] - [cons-if (lambda (f r) (if f (cons f r) r))] - [config-table (get-config-table (find-main-config))]) - (path-list-string->path-list - (if user-too? - (let ([c (environment-variables-ref (current-environment-variables) - #"PLTCOLLECTS")]) - (if c - (bytes->string/locale c #\?) - "")) - "") - (add-config-search - config-table - 'collects-search-dirs - (cons-if - (and user-too? - (build-path (find-system-path 'addon-dir) - (get-installation-name config-table) - "collects")) - (let loop ([l (append - extra-collects-dirs - (list (find-system-path 'collects-dir)) - post-collects-dirs)]) - (if (null? l) - null - (let* ([collects-path (car l)] - [v (exe-relative-path->complete-path collects-path)]) - (if v - (cons (simplify-path (path->complete-path v (current-directory))) - (loop (cdr l))) - (loop (cdr l))))))))))])) - - ;; used for the -k command-line argument: - (define (embedded-load start end str) - (let* ([s (if str - str - (let* ([sp (find-system-path 'exec-file)] - [exe (find-executable-path sp #f)] - [start (or (string->number start) 0)] - [end (or (string->number end) 0)]) - (with-input-from-file exe - (lambda () - (file-position (current-input-port) start) - (read-bytes (max 0 (- end start)))))))] - [p (open-input-bytes s)]) - (let loop () - (let ([e (parameterize ([read-accept-compiled #t] - [read-accept-reader #t] - [read-accept-lang #t] - [read-on-demand-source #t]) - (read p))]) - (unless (eof-object? e) - (eval e) - (loop))))))) - -;; ---------------------------------------- -;; When places are implemented by plain old threads, -;; place channels need to be shared across namespaces, -;; so `#%place-struct' is included in builtins - -(module #%place-struct '#%kernel - - (define-values (struct:TH-place-channel TH-place-channel TH-place-channel? - TH-place-channel-ref TH-place-channel-set!) - (make-struct-type 'TH-place-channel #f 2 0 #f (list (cons prop:evt (lambda (x) (TH-place-channel-ref x 0)))))) - - (define-values (TH-place-channel-in TH-place-channel-out) - (values - (lambda (x) (TH-place-channel-ref x 0)) - (lambda (x) (TH-place-channel-ref x 1)))) - - (#%provide - struct:TH-place-channel - TH-place-channel - TH-place-channel? - TH-place-channel-in - TH-place-channel-out)) - -;; ---------------------------------------- -;; Handlers to install on startup - -(module #%boot '#%kernel - (#%require '#%min-stx '#%utils '#%paramz) - - (#%provide boot seal orig-paramz) - - (define-values (dll-suffix) - (system-type 'so-suffix)) - - (define-values (default-load/use-compiled) - (let* ([resolve (lambda (s) - (if (complete-path? s) - s - (let ([d (current-load-relative-directory)]) - (if d (path->complete-path s d) s))))] - [use-seconds? (eq? (use-compiled-file-check) 'modify-seconds)] - [date-of-1 (lambda (a) - (let ([v (file-or-directory-modify-seconds a #f (lambda () #f))]) - (and v (cons a (if use-seconds? v 0)))))] - [date-of (lambda (a modes roots) - (ormap (lambda (root-dir) - (ormap - (lambda (compiled-dir) - (let ([a (a root-dir compiled-dir)]) - (date-of-1 a))) - modes)) - roots))] - [date>=? - (lambda (modes roots a bm) - (and a - (let ([am (date-of a modes roots)]) - (or (and (not bm) am) - (and am bm (>= (cdr am) (cdr bm)) am)))))] - [with-dir* (lambda (base t) - (parameterize ([current-load-relative-directory - (if (path? base) - base - (current-directory))]) - (t)))]) - (lambda (path expect-module) - (unless (path-string? path) - (raise-argument-error 'load/use-compiled "path-string?" path)) - (unless (or (not expect-module) - (symbol? expect-module) - (and (list? expect-module) - ((length expect-module) . > . 1) - (or (symbol? (car expect-module)) - (not (car expect-module))) - (andmap symbol? (cdr expect-module)))) - (raise-argument-error 'load/use-compiled "(or/c #f symbol? (cons/c (or/c #f symbol?) (non-empty-listof symbol?)))" path)) - (define name (and expect-module (current-module-declare-name))) - (define ns-hts (and name - (hash-ref -module-hash-table-table - (namespace-module-registry (current-namespace)) - #f))) - (define use-path/src (and ns-hts (hash-ref (cdr ns-hts) name #f))) - (if use-path/src - ;; Use previous decision of .zo vs. source: - (parameterize ([current-module-declare-source (cadr use-path/src)]) - (with-dir* (caddr use-path/src) - (lambda () ((current-load) (car use-path/src) expect-module)))) - ;; Check .zo vs. src dates, etc.: - (let*-values ([(orig-path) (resolve path)] - [(base orig-file dir?) (split-path path)] - [(file alt-file) (if expect-module - (let* ([b (path->bytes orig-file)] - [len (bytes-length b)]) - (cond - [(and (len . >= . 4) - (bytes=? #".rkt" (subbytes b (- len 4)))) - ;; .rkt => try .rkt then .ss - (values orig-file - (bytes->path (bytes-append (subbytes b 0 (- len 4)) #".ss")))] - [else - ;; No search path - (values orig-file #f)])) - (values orig-file #f))] - [(path) (if (eq? file orig-file) - orig-path - (build-path base file))] - [(alt-path) (and alt-file - (if (eq? alt-file orig-file) - orig-path - (build-path base alt-file)))] - [(base) (if (eq? base 'relative) 'same base)] - [(modes) (use-compiled-file-paths)] - [(roots) (current-compiled-file-roots)] - [(reroot) (lambda (p d) - (cond - [(eq? d 'same) p] - [(relative-path? d) (build-path p d)] - [else (reroot-path p d)]))]) - (let* ([main-path-d (date-of-1 path)] - [alt-path-d (and alt-path - (not main-path-d) - (date-of-1 alt-path))] - [path-d (or main-path-d alt-path-d)] - [get-so (lambda (file rep-sfx?) - (lambda (root-dir compiled-dir) - (build-path (reroot base root-dir) - compiled-dir - "native" - (system-library-subpath) - (if rep-sfx? - (path-add-extension - file - dll-suffix) - file))))] - [zo (lambda (root-dir compiled-dir) - (build-path (reroot base root-dir) - compiled-dir - (path-add-extension file #".zo")))] - [alt-zo (lambda (root-dir compiled-dir) - (build-path (reroot base root-dir) - compiled-dir - (path-add-extension alt-file #".zo")))] - [so (get-so file #t)] - [alt-so (get-so alt-file #t)] - [try-main? (or main-path-d (not alt-path-d))] - [try-alt? (and alt-file (or alt-path-d (not main-path-d)))] - [with-dir (lambda (t) (with-dir* base t))]) - (cond - [(and try-main? - (date>=? modes roots so path-d)) - => (lambda (so-d) - (parameterize ([current-module-declare-source #f]) - (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] - [(and try-alt? - (date>=? modes roots alt-so alt-path-d)) - => (lambda (so-d) - (parameterize ([current-module-declare-source alt-path]) - (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))] - [(and try-main? - (date>=? modes roots zo path-d)) - => (lambda (zo-d) - (register-zo-path name ns-hts (car zo-d) #f base) - (parameterize ([current-module-declare-source #f]) - (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] - [(and try-alt? - (date>=? modes roots alt-zo path-d)) - => (lambda (zo-d) - (register-zo-path name ns-hts (car zo-d) alt-path base) - (parameterize ([current-module-declare-source alt-path]) - (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))] - [(or (not (pair? expect-module)) - (car expect-module)) - (let ([p (if try-main? path alt-path)]) - ;; "quiet" failure when asking for a submodule: - (unless (and (pair? expect-module) - (not (file-exists? p))) - (parameterize ([current-module-declare-source (and expect-module - (not try-main?) - p)]) - (with-dir (lambda () ((current-load) p expect-module))))))]))))))) - - (define (register-zo-path name ns-hts path src-path base) - (when ns-hts - (hash-set! (cdr ns-hts) name (list path src-path base)))) - - (define-values (default-reader-guard) - (lambda (path) path)) - - (define-values (-module-hash-table-table) (make-weak-hasheq)) ; weak map from namespace to pair of module-name hts - - ;; weak map from `lib' path + corrent-library-paths to symbols: - ;; We'd like to use a weak `equal?'-based hash table here, - ;; but that's not kill-safe. Instead, we use a non-thread-safe - ;; custom hash table; a race could lose cache entries, but - ;; that's ok. - (define CACHE-N 512) - (define-values (-path-cache) (make-vector CACHE-N #f)) - (define (path-cache-get p) - (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] - [w (vector-ref -path-cache i)] - [l (and w (weak-box-value w))]) - (and l - (let ([a (assoc p l)]) - (and a (cdr a)))))) - (define (path-cache-set! p v) - (let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)] - [w (vector-ref -path-cache i)] - [l (and w (weak-box-value w))]) - (vector-set! -path-cache i (make-weak-box (cons (cons p v) (or l null)))))) - - (define-values (-loading-filename) (gensym)) - (define-values (-loading-prompt-tag) (make-continuation-prompt-tag 'module-loading)) - (define-values (-prev-relto) #f) - (define-values (-prev-relto-dir) #f) - - (define (split-relative-string s coll-mode?) - (let ([l (let loop ([s s]) - (let ([len (string-length s)]) - (let iloop ([i 0]) - (cond - [(= i len) (list s)] - [(char=? #\/ (string-ref s i)) - (cons (substring s 0 i) - (loop (substring s (add1 i))))] - [else (iloop (add1 i))]))))]) - (if coll-mode? - l - (let loop ([l l]) - (if (null? (cdr l)) - (values null (car l)) - (let-values ([(c f) (loop (cdr l))]) - (values (cons (car l) c) f))))))) - - (define (format-source-location stx) - (srcloc->string (srcloc (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx)))) - - (define-values (orig-paramz) #f) - - (define-values (standard-module-name-resolver) - (let-values () - (define-values (planet-resolver) #f) - (define-values (prep-planet-resolver!) - (lambda () - (unless planet-resolver - (with-continuation-mark - parameterization-key - orig-paramz - (set! planet-resolver (dynamic-require '(lib "planet/resolver.rkt") 'planet-module-name-resolver)))))) - (define-values (standard-module-name-resolver) - (case-lambda - [(s from-namespace) - (unless (resolved-module-path? s) - (raise-argument-error 'standard-module-name-resolver - "resolved-module-path?" - s)) - (unless (or (not from-namespace) (namespace? from-namespace)) - (raise-argument-error 'standard-module-name-resolver - "(or/c #f namespace?)" - from-namespace)) - (when planet-resolver - ;; Let planet resolver register, too: - (planet-resolver s)) - ;; Register s as loaded: - (let ([hts (or (hash-ref -module-hash-table-table - (namespace-module-registry (current-namespace)) - #f) - (let ([hts (cons (make-hasheq) (make-hasheq))]) - (hash-set! -module-hash-table-table - (namespace-module-registry (current-namespace)) - hts) - hts))]) - (hash-set! (car hts) s 'declared) - ;; If attach from another namespace, copy over source-file path, if any: - (when from-namespace - (let ([root-name (if (pair? (resolved-module-path-name s)) - (make-resolved-module-path (car (resolved-module-path-name s))) - s)] - [from-hts (hash-ref -module-hash-table-table - (namespace-module-registry from-namespace) - #f)]) - (when from-hts - (let ([use-path/src (hash-ref (cdr from-hts) root-name #f)]) - (when use-path/src - (hash-set! (cdr hts) root-name use-path/src)))))))] - [(s relto stx) ; for backward-compatibility - (log-message (current-logger) 'error - "default module name resolver called with three arguments (deprecated)" - #f) - (standard-module-name-resolver s relto stx #t)] - [(s relto stx load?) - ;; If stx is not #f, raise syntax error for ill-formed paths - (unless (module-path? s) - (if (syntax? stx) - (raise-syntax-error #f - "bad module path" - stx) - (raise-argument-error 'standard-module-name-resolver - "module-path?" - s))) - (unless (or (not relto) (resolved-module-path? relto)) - (raise-argument-error 'standard-module-name-resolver - "(or/c #f resolved-module-path?)" - relto)) - (unless (or (not stx) (syntax? stx)) - (raise-argument-error 'standard-module-name-resolver - "(or/c #f syntax?)" - stx)) - (define (flatten-sub-path base orig-l) - (let loop ([a null] [l orig-l]) - (cond - [(null? l) (if (null? a) - base - (cons base (reverse a)))] - [(equal? (car l) "..") - (if (null? a) - (error - 'standard-module-name-resolver - "too many \"..\"s in submodule path: ~.s" - (list* 'submod - (if (equal? base ".") - base - (if (path? base) - base - (list (if (symbol? base) 'quote 'file) base))) - orig-l)) - (loop (cdr a) (cdr l)))] - [else (loop (cons (car l) a) (cdr l))]))) - (cond - [(and (pair? s) (eq? (car s) 'quote)) - (make-resolved-module-path (cadr s))] - [(and (pair? s) (eq? (car s) 'submod) - (pair? (cadr s)) (eq? (caadr s) 'quote)) - (make-resolved-module-path (flatten-sub-path (cadadr s) (cddr s)))] - [(and (pair? s) (eq? (car s) 'submod) - (or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - (and relto - (let ([p (resolved-module-path-name relto)]) - (or (symbol? p) - (and (pair? p) (symbol? (car p))))))) - (define rp (resolved-module-path-name relto)) - (make-resolved-module-path (flatten-sub-path (if (pair? rp) (car rp) rp) - (let ([r (if (equal? (cadr s) "..") - (cdr s) - (cddr s))]) - (if (pair? rp) - (append (cdr rp) r) - r))))] - [(and (pair? s) (eq? (car s) 'planet)) - (prep-planet-resolver!) - (planet-resolver s relto stx load? #f orig-paramz)] - [(and (pair? s) - (eq? (car s) 'submod) - (pair? (cadr s)) - (eq? (caadr s) 'planet)) - (prep-planet-resolver!) - (planet-resolver (cadr s) relto stx load? (cddr s) orig-paramz)] - [else - (let ([get-dir (lambda () - (or (and relto - (if (eq? relto -prev-relto) - -prev-relto-dir - (let ([p (resolved-module-path-name relto)]) - (let ([p (if (pair? p) (car p) p)]) - (and (path? p) - (let-values ([(base n d?) (split-path p)]) - (set! -prev-relto relto) - (set! -prev-relto-dir base) - base)))))) - (current-load-relative-directory) - (current-directory)))] - [get-reg (lambda () - (namespace-module-registry (current-namespace)))] - [show-collection-err (lambda (msg) - (let ([msg (string-append - (or (and stx - (error-print-source-location) - (format-source-location stx)) - "standard-module-name-resolver") - ": " - (regexp-replace #rx"\n" - msg - (format "\n for module path: ~s\n" - s)))]) - (raise - (if stx - (exn:fail:syntax:missing-module - msg - (current-continuation-marks) - (list stx) - s) - (exn:fail:filesystem:missing-module - msg - (current-continuation-marks) - s)))))] - [ss->rkt (lambda (s) - (let ([len (string-length s)]) - (if (and (len . >= . 3) - ;; ".ss" - (equal? #\. (string-ref s (- len 3))) - (equal? #\s (string-ref s (- len 2))) - (equal? #\s (string-ref s (- len 1)))) - (string-append (substring s 0 (- len 3)) ".rkt") - s)))] - [path-ss->rkt (lambda (p) - (let-values ([(base name dir?) (split-path p)]) - (if (regexp-match #rx"[.]ss$" (path->bytes name)) - (path-replace-extension p #".rkt") - p)))] - [s (if (and (pair? s) (eq? 'submod (car s))) - (let ([v (cadr s)]) - (if (or (equal? v ".") - (equal? v "..")) - (if relto - ;; must have a path inside, or we wouldn't get here - (let ([p (resolved-module-path-name relto)]) - (if (pair? p) - (car p) - p)) - (error 'standard-module-name-resolver - "no base path for relative submodule path: ~.s" - s)) - v)) - s)] - [subm-path (if (and (pair? s) (eq? 'submod (car s))) - (let ([p (if (and (or (equal? (cadr s) ".") - (equal? (cadr s) "..")) - relto) - (let ([p (resolved-module-path-name relto)] - [r (if (equal? (cadr s) "..") - (cdr s) - (cddr s))]) - (if (pair? p) - (flatten-sub-path (car p) (append (cdr p) r)) - (flatten-sub-path p r))) - (flatten-sub-path "." - (if (equal? (cadr s) "..") - (cdr s) - (cddr s))))]) - ;; flattening may erase the submodule path: - (if (pair? p) - (cdr p) - #f)) - #f)]) - (let ([s-parsed - ;; Non-string result represents an error - (cond - [(symbol? s) - (or (path-cache-get (cons s (get-reg))) - (let-values ([(cols file) (split-relative-string (symbol->string s) #f)]) - (let* ([f-file (if (null? cols) - "main.rkt" - (string-append file ".rkt"))]) - (find-col-file show-collection-err - (if (null? cols) file (car cols)) - (if (null? cols) null (cdr cols)) - f-file - #t))))] - [(string? s) - (let* ([dir (get-dir)]) - (or (path-cache-get (cons s dir)) - (let-values ([(cols file) (split-relative-string s #f)]) - (if (null? cols) - (build-path dir (ss->rkt file)) - (apply build-path - dir - (append - (map (lambda (s) - (cond - [(string=? s ".") 'same] - [(string=? s "..") 'up] - [else s])) - cols) - (list (ss->rkt file))))))))] - [(path? s) - ;; Use filesystem-sensitive `simplify-path' here: - (path-ss->rkt (simplify-path (if (complete-path? s) - s - (path->complete-path s (get-dir)))))] - [(eq? (car s) 'lib) - (or (path-cache-get (cons s (get-reg))) - (let*-values ([(cols file) (split-relative-string (cadr s) #f)] - [(old-style?) (if (null? (cddr s)) - (and (null? cols) - (regexp-match? #rx"[.]" file)) - #t)]) - (let* ([f-file (if old-style? - (ss->rkt file) - (if (null? cols) - "main.rkt" - (if (regexp-match? #rx"[.]" file) - (ss->rkt file) - (string-append file ".rkt"))))]) - (let-values ([(cols) - (if old-style? - (append (if (null? (cddr s)) - '("mzlib") - (apply append - (map (lambda (p) - (split-relative-string p #t)) - (cddr s)))) - cols) - (if (null? cols) - (list file) - cols))]) - (find-col-file show-collection-err - (car cols) - (cdr cols) - f-file - #t)))))] - [(eq? (car s) 'file) - ;; Use filesystem-sensitive `simplify-path' here: - (path-ss->rkt - (simplify-path (path->complete-path (expand-user-path (cadr s)) (get-dir))))])]) - (unless (or (path? s-parsed) - (vector? s-parsed)) - (if stx - (raise-syntax-error - 'require - (format "bad module path~a" (if s-parsed - (car s-parsed) - "")) - stx) - (raise-argument-error - 'standard-module-name-resolver - "module-path?" - s))) - ;; At this point, s-parsed is a complete path (or a cached vector) - (let* ([filename (if (vector? s-parsed) - (vector-ref s-parsed 0) - (simplify-path (cleanse-path s-parsed) #f))] - [normal-filename (if (vector? s-parsed) - (vector-ref s-parsed 1) - (normal-case-path filename))]) - (let-values ([(base name dir?) (if (vector? s-parsed) - (values 'ignored (vector-ref s-parsed 2) 'ignored) - (split-path filename))]) - (let* ([no-sfx (if (vector? s-parsed) - (vector-ref s-parsed 3) - (path-replace-extension name #""))]) - (let* ([root-modname (if (vector? s-parsed) - (vector-ref s-parsed 4) - (make-resolved-module-path filename))] - [hts (or (hash-ref -module-hash-table-table - (get-reg) - #f) - (let ([hts (cons (make-hasheq) (make-hasheq))]) - (hash-set! -module-hash-table-table - (get-reg) - hts) - hts))] - [modname (if subm-path - (make-resolved-module-path - (cons (resolved-module-path-name root-modname) - subm-path)) - root-modname)]) - ;; Loaded already? - (when load? - (let ([got (hash-ref (car hts) modname #f)]) - (unless got - ;; Currently loading? - (let ([loading - (let ([tag (if (continuation-prompt-available? -loading-prompt-tag) - -loading-prompt-tag - (default-continuation-prompt-tag))]) - (continuation-mark-set-first - #f - -loading-filename - null - tag))] - [nsr (get-reg)]) - (for-each - (lambda (s) - (when (and (equal? (cdr s) normal-filename) - (eq? (car s) nsr)) - (error - 'standard-module-name-resolver - "cycle in loading\n at path: ~a\n paths:~a" - filename - (apply string-append - (let loop ([l (reverse loading)]) - (if (null? l) - '() - (list* "\n " (path->string (cdar l)) (loop (cdr l))))))))) - loading) - ((if (continuation-prompt-available? -loading-prompt-tag) - (lambda (f) (f)) - (lambda (f) (call-with-continuation-prompt f -loading-prompt-tag))) - (lambda () - (with-continuation-mark -loading-filename (cons (cons nsr normal-filename) - loading) - (parameterize ([current-module-declare-name root-modname] - [current-module-path-for-load - ;; If `s' is an absolute module path, then - ;; keep it as-is, the better to let a tool - ;; recommend how to get an unavailable module; - ;; also, propagate the source location. - ((if stx - (lambda (p) (datum->syntax #f p stx)) - values) - (cond - [(symbol? s) s] - [(and (pair? s) (eq? (car s) 'lib)) s] - [else (if (resolved-module-path? root-modname) - (let ([src (resolved-module-path-name root-modname)]) - (if (symbol? src) - (list 'quote src) - src)) - root-modname)]))]) - ((current-load/use-compiled) - filename - (let ([sym (string->symbol (path->string no-sfx))]) - (if subm-path - (if (hash-ref (car hts) root-modname #f) - ;; Root is already loaded, so only use .zo - (cons #f subm-path) - ;; Root isn't loaded, so it's ok to load form source: - (cons sym subm-path)) - sym))))))))))) - ;; If a `lib' path, cache pathname manipulations - (when (and (not (vector? s-parsed)) - load? - (or (string? s) - (symbol? s) - (and (pair? s) - (eq? (car s) 'lib)))) - (path-cache-set! (if (string? s) - (cons s (get-dir)) - (cons s (get-reg))) - (vector filename - normal-filename - name - no-sfx - root-modname))) - ;; Result is the module name: - modname))))))])])) - standard-module-name-resolver)) - - (define-values (boot) - (lambda () - (seal) - (current-module-name-resolver standard-module-name-resolver) - (current-load/use-compiled default-load/use-compiled) - (current-reader-guard default-reader-guard))) - - (define-values (seal) - (lambda () - (set! orig-paramz - (reparameterize - (continuation-mark-set-first #f parameterization-key)))))) - -;; ---------------------------------------- -;; A module that collects all the built-in modules, -;; so that it's easier to keep them attached in new -;; namespaces. - -(module #%builtin '#%kernel - (#%require '#%expobs - (only '#%foreign) ; so it's attached, but doesn't depend on any exports - (only '#%unsafe) ; ditto - (only '#%flfxnum) ; ditto - '#%boot - '#%place-struct - '#%paramz - '#%network - '#%utils - (only '#%place) - (only '#%futures) - (only '#%linklet))) diff --git a/racket/src/racket/src/string.c b/racket/src/racket/src/string.c index 2a951f382a..69b6a9c7dc 100644 --- a/racket/src/racket/src/string.c +++ b/racket/src/racket/src/string.c @@ -68,7 +68,7 @@ typedef struct Scheme_Converter { Scheme_Custodian_Reference *mref; } Scheme_Converter; -/* locals */ +Scheme_Object *scheme_system_type_proc; static Scheme_Object *make_string (int argc, Scheme_Object *argv[]); static Scheme_Object *string (int argc, Scheme_Object *argv[]); @@ -197,9 +197,9 @@ ROSYM static Scheme_Object *sys_symbol; ROSYM static Scheme_Object *link_symbol, *machine_symbol, *vm_symbol, *gc_symbol; ROSYM static Scheme_Object *so_suffix_symbol, *so_mode_symbol, *word_symbol; ROSYM static Scheme_Object *os_symbol, *fs_change_symbol, *cross_symbol; -ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol; +ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol, *cs_symbol; ROSYM static Scheme_Object *force_symbol, *infer_symbol; -ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path; +ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path, *platform_cs_path; READ_ONLY static Scheme_Object *zero_length_char_string; READ_ONLY static Scheme_Object *zero_length_byte_string; @@ -230,7 +230,7 @@ static const mzchar empty_char_string[1] = { 0 }; static const mzchar xes_char_string[2] = { 0x78787878, 0 }; void -scheme_init_string (Scheme_Env *env) +scheme_init_string (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -261,9 +261,11 @@ scheme_init_string (Scheme_Env *env) REGISTER_SO(racket_symbol); REGISTER_SO(cgc_symbol); REGISTER_SO(_3m_symbol); + REGISTER_SO(cs_symbol); racket_symbol = scheme_intern_symbol("racket"); cgc_symbol = scheme_intern_symbol("cgc"); _3m_symbol = scheme_intern_symbol("3m"); + cs_symbol = scheme_intern_symbol("cs"); REGISTER_SO(force_symbol); REGISTER_SO(infer_symbol); @@ -285,19 +287,19 @@ scheme_init_string (Scheme_Env *env) error_symbol = scheme_intern_symbol("error"); REGISTER_SO(platform_3m_path); -#ifdef UNIX_FILE_SYSTEM -# define MZ3M_SUBDIR "/3m" -#else # ifdef DOS_FILE_SYSTEM # define MZ3M_SUBDIR "\\3m" +# define MZCS_SUBDIR "\\cs" # else -# define MZ3M_SUBDIR ":3m" -# endif +# define MZ3M_SUBDIR "/3m" +# define MZCS_SUBDIR "/cs" #endif REGISTER_SO(platform_3m_path); REGISTER_SO(platform_cgc_path); + REGISTER_SO(platform_cs_path); platform_cgc_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX); platform_3m_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX MZ3M_SUBDIR); + platform_cs_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH SPLS_SUFFIX MZCS_SUBDIR); REGISTER_SO(embedding_banner); REGISTER_SO(vers_str); @@ -311,16 +313,17 @@ scheme_init_string (Scheme_Env *env) REGISTER_SO(scheme_string_p_proc); p = scheme_make_folding_prim(string_p, "string?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("string?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("string?", p, env); scheme_string_p_proc = p; - scheme_add_global_constant("make-string", + scheme_addto_prim_instance("make-string", scheme_make_immed_prim(make_string, "make-string", 1, 2), env); - scheme_add_global_constant("string", + scheme_addto_prim_instance("string", scheme_make_immed_prim(string, "string", 0, -1), @@ -328,258 +331,262 @@ scheme_init_string (Scheme_Env *env) p = scheme_make_folding_prim(string_length, "string-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - |SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("string-length", p, + |SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-length", p, env); p = scheme_make_immed_prim(scheme_checked_string_ref, "string-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("string-ref", p, env); - + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-ref", p, env); p = scheme_make_immed_prim(scheme_checked_string_set, "string-set!", 3, 3); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("string-set!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-set!", p, env); p = scheme_make_immed_prim(string_eq, "string=?", 2, -1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("string=?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("string=?", p, env); - scheme_add_global_constant("string-locale=?", + scheme_addto_prim_instance("string-locale=?", scheme_make_immed_prim(string_locale_eq, "string-locale=?", 2, -1), env); - scheme_add_global_constant("string-ci=?", + scheme_addto_prim_instance("string-ci=?", scheme_make_immed_prim(string_ci_eq, "string-ci=?", 2, -1), env); - scheme_add_global_constant("string-locale-ci=?", + scheme_addto_prim_instance("string-locale-ci=?", scheme_make_immed_prim(string_locale_ci_eq, "string-locale-ci=?", 2, -1), env); - scheme_add_global_constant("string?", + scheme_addto_prim_instance("string>?", scheme_make_immed_prim(string_gt, "string>?", 2, -1), env); - scheme_add_global_constant("string-locale>?", + scheme_addto_prim_instance("string-locale>?", scheme_make_immed_prim(string_locale_gt, "string-locale>?", 2, -1), env); - scheme_add_global_constant("string<=?", + scheme_addto_prim_instance("string<=?", scheme_make_immed_prim(string_lt_eq, "string<=?", 2, -1), env); - scheme_add_global_constant("string>=?", + scheme_addto_prim_instance("string>=?", scheme_make_immed_prim(string_gt_eq, "string>=?", 2, -1), env); - scheme_add_global_constant("string-ci?", + scheme_addto_prim_instance("string-ci>?", scheme_make_immed_prim(string_ci_gt, "string-ci>?", 2, -1), env); - scheme_add_global_constant("string-locale-ci>?", + scheme_addto_prim_instance("string-locale-ci>?", scheme_make_immed_prim(string_locale_ci_gt, "string-locale-ci>?", 2, -1), env); - scheme_add_global_constant("string-ci<=?", + scheme_addto_prim_instance("string-ci<=?", scheme_make_immed_prim(string_ci_lt_eq, "string-ci<=?", 2, -1), env); - scheme_add_global_constant("string-ci>=?", + scheme_addto_prim_instance("string-ci>=?", scheme_make_immed_prim(string_ci_gt_eq, "string-ci>=?", 2, -1), env); - scheme_add_global_constant("substring", + scheme_addto_prim_instance("substring", scheme_make_immed_prim(substring, "substring", 2, 3), env); - scheme_add_global_constant("string-append", - scheme_make_immed_prim(string_append, - "string-append", - 0, -1), - env); - scheme_add_global_constant("string->list", + + p = scheme_make_immed_prim(string_append, "string-append", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string-append", p, env); + + scheme_addto_prim_instance("string->list", scheme_make_immed_prim(string_to_list, "string->list", 1, 1), env); - scheme_add_global_constant("list->string", + scheme_addto_prim_instance("list->string", scheme_make_immed_prim(list_to_string, "list->string", 1, 1), env); - scheme_add_global_constant("string-copy", + scheme_addto_prim_instance("string-copy", scheme_make_immed_prim(string_copy, "string-copy", 1, 1), env); - scheme_add_global_constant("string-copy!", + scheme_addto_prim_instance("string-copy!", scheme_make_immed_prim(string_copy_bang, "string-copy!", 3, 5), env); - scheme_add_global_constant("string-fill!", + scheme_addto_prim_instance("string-fill!", scheme_make_immed_prim(string_fill, "string-fill!", 2, 2), env); - scheme_add_global_constant("string->immutable-string", - scheme_make_immed_prim(string_to_immutable, - "string->immutable-string", - 1, 1), - env); - scheme_add_global_constant("string-normalize-nfc", + + p = scheme_make_immed_prim(string_to_immutable, "string->immutable-string", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string->immutable-string", p, env); + + scheme_addto_prim_instance("string-normalize-nfc", scheme_make_immed_prim(string_normalize_c, "string-normalize-nfc", 1, 1), env); - scheme_add_global_constant("string-normalize-nfkc", + scheme_addto_prim_instance("string-normalize-nfkc", scheme_make_immed_prim(string_normalize_kc, "string-normalize-nfkc", 1, 1), env); - scheme_add_global_constant("string-normalize-nfd", + scheme_addto_prim_instance("string-normalize-nfd", scheme_make_immed_prim(string_normalize_d, "string-normalize-nfd", 1, 1), env); - scheme_add_global_constant("string-normalize-nfkd", + scheme_addto_prim_instance("string-normalize-nfkd", scheme_make_immed_prim(string_normalize_kd, "string-normalize-nfkd", 1, 1), env); - scheme_add_global_constant("string-upcase", + scheme_addto_prim_instance("string-upcase", scheme_make_immed_prim(string_upcase, "string-upcase", 1, 1), env); - scheme_add_global_constant("string-downcase", + scheme_addto_prim_instance("string-downcase", scheme_make_immed_prim(string_downcase, "string-downcase", 1, 1), env); - scheme_add_global_constant("string-titlecase", + scheme_addto_prim_instance("string-titlecase", scheme_make_immed_prim(string_titlecase, "string-titlecase", 1, 1), env); - scheme_add_global_constant("string-foldcase", + scheme_addto_prim_instance("string-foldcase", scheme_make_immed_prim(string_foldcase, "string-foldcase", 1, 1), env); - scheme_add_global_constant("string-locale-upcase", + scheme_addto_prim_instance("string-locale-upcase", scheme_make_immed_prim(string_locale_upcase, "string-locale-upcase", 1, 1), env); - scheme_add_global_constant("string-locale-downcase", + scheme_addto_prim_instance("string-locale-downcase", scheme_make_immed_prim(string_locale_downcase, "string-locale-downcase", 1, 1), env); - scheme_add_global_constant("current-locale", + scheme_addto_prim_instance("current-locale", scheme_register_parameter(current_locale, "current-locale", MZCONFIG_LOCALE), env); - scheme_add_global_constant("locale-string-encoding", + scheme_addto_prim_instance("locale-string-encoding", scheme_make_immed_prim(locale_string_encoding, "locale-string-encoding", 0, 0), env); - scheme_add_global_constant("system-language+country", + scheme_addto_prim_instance("system-language+country", scheme_make_immed_prim(system_language_country, "system-language+country", 0, 0), env); - scheme_add_global_constant("bytes-converter?", + scheme_addto_prim_instance("bytes-converter?", scheme_make_immed_prim(byte_converter_p, "bytes-converter?", 1, 1), env); - scheme_add_global_constant("bytes-convert", + scheme_addto_prim_instance("bytes-convert", scheme_make_prim_w_arity2(byte_string_convert, "bytes-convert", 1, 7, 3, 3), env); - scheme_add_global_constant("bytes-convert-end", + scheme_addto_prim_instance("bytes-convert-end", scheme_make_prim_w_arity2(byte_string_convert_end, "bytes-convert-end", 0, 3, 2, 2), env); - scheme_add_global_constant("bytes-open-converter", + scheme_addto_prim_instance("bytes-open-converter", scheme_make_immed_prim(byte_string_open_converter, "bytes-open-converter", 2, 2), env); - scheme_add_global_constant("bytes-close-converter", + scheme_addto_prim_instance("bytes-close-converter", scheme_make_immed_prim(byte_string_close_converter, "bytes-close-converter", 1, 1), env); - scheme_add_global_constant("format", + scheme_addto_prim_instance("format", scheme_make_noncm_prim(format, "format", 1, -1), env); - scheme_add_global_constant("printf", + scheme_addto_prim_instance("printf", scheme_make_noncm_prim(sch_printf, "printf", 1, -1), env); - scheme_add_global_constant("eprintf", + scheme_addto_prim_instance("eprintf", scheme_make_noncm_prim(sch_eprintf, "eprintf", 1, -1), env); - scheme_add_global_constant("fprintf", + scheme_addto_prim_instance("fprintf", scheme_make_noncm_prim(sch_fprintf, "fprintf", 2, -1), env); - scheme_add_global_constant("byte?", + scheme_addto_prim_instance("byte?", scheme_make_folding_prim(byte_p, "byte?", 1, 1, 1), @@ -588,142 +595,146 @@ scheme_init_string (Scheme_Env *env) REGISTER_SO(scheme_byte_string_p_proc); p = scheme_make_folding_prim(byte_string_p, "bytes?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("bytes?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("bytes?", p, env); scheme_byte_string_p_proc = p; - scheme_add_global_constant("make-bytes", + scheme_addto_prim_instance("make-bytes", scheme_make_immed_prim(make_byte_string, "make-bytes", 1, 2), env); - scheme_add_global_constant("bytes", + scheme_addto_prim_instance("bytes", scheme_make_immed_prim(byte_string, "bytes", 0, -1), env); - GLOBAL_PRIM_W_ARITY("make-shared-bytes", make_shared_byte_string, 1, 2, env); - GLOBAL_PRIM_W_ARITY("shared-bytes", shared_byte_string, 0, -1, env); + ADD_PRIM_W_ARITY("make-shared-bytes", make_shared_byte_string, 1, 2, env); + ADD_PRIM_W_ARITY("shared-bytes", shared_byte_string, 0, -1, env); p = scheme_make_folding_prim(byte_string_length, "bytes-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - |SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("bytes-length", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-length", p, env); p = scheme_make_immed_prim(scheme_checked_byte_string_ref, "bytes-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("bytes-ref", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-ref", p, env); p = scheme_make_immed_prim(scheme_checked_byte_string_set, "bytes-set!", 3, 3); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("bytes-set!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-set!", p, env); p = scheme_make_immed_prim(byte_string_eq, "bytes=?", 2, -1); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("bytes=?", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("bytes=?", p, env); - scheme_add_global_constant("bytes?", + scheme_addto_prim_instance("bytes>?", scheme_make_immed_prim(byte_string_gt, "bytes>?", 2, -1), env); - scheme_add_global_constant("subbytes", + scheme_addto_prim_instance("subbytes", scheme_make_immed_prim(byte_substring, "subbytes", 2, 3), env); - scheme_add_global_constant("bytes-append", - scheme_make_immed_prim(byte_string_append, - "bytes-append", - 0, -1), - env); - scheme_add_global_constant("bytes->list", + + p = scheme_make_immed_prim(byte_string_append, "bytes-append", 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes-append", p, env); + + scheme_addto_prim_instance("bytes->list", scheme_make_immed_prim(byte_string_to_list, "bytes->list", 1, 1), env); - scheme_add_global_constant("list->bytes", + scheme_addto_prim_instance("list->bytes", scheme_make_immed_prim(list_to_byte_string, "list->bytes", 1, 1), env); - scheme_add_global_constant("bytes-copy", + scheme_addto_prim_instance("bytes-copy", scheme_make_immed_prim(byte_string_copy, "bytes-copy", 1, 1), env); - scheme_add_global_constant("bytes-copy!", + scheme_addto_prim_instance("bytes-copy!", scheme_make_immed_prim(byte_string_copy_bang, "bytes-copy!", 3, 5), env); - scheme_add_global_constant("bytes-fill!", + scheme_addto_prim_instance("bytes-fill!", scheme_make_immed_prim(byte_string_fill, "bytes-fill!", 2, 2), env); - scheme_add_global_constant("bytes->immutable-bytes", - scheme_make_immed_prim(byte_string_to_immutable, - "bytes->immutable-bytes", - 1, 1), - env); + + p = scheme_make_immed_prim(byte_string_to_immutable, "bytes->immutable-bytes", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("bytes->immutable-bytes", p, env); p = scheme_make_immed_prim(byte_string_utf8_index, "bytes-utf-8-index", 2, 4); /* Incorrect, since the result can be #f: SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); */ - scheme_add_global_constant("bytes-utf-8-index", p, env); + scheme_addto_prim_instance("bytes-utf-8-index", p, env); p = scheme_make_immed_prim(byte_string_utf8_length, "bytes-utf-8-length", 1, 4); /* Incorrect, since the result can be #f: SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_PRODUCES_FIXNUM); */ - scheme_add_global_constant("bytes-utf-8-length", p, env); + scheme_addto_prim_instance("bytes-utf-8-length", p, env); - scheme_add_global_constant("bytes-utf-8-ref", + scheme_addto_prim_instance("bytes-utf-8-ref", scheme_make_immed_prim(byte_string_utf8_ref, "bytes-utf-8-ref", 2, 4), env); - scheme_add_global_constant("bytes->string/utf-8", + scheme_addto_prim_instance("bytes->string/utf-8", scheme_make_immed_prim(byte_string_to_char_string, "bytes->string/utf-8", 1, 4), env); - scheme_add_global_constant("bytes->string/locale", + scheme_addto_prim_instance("bytes->string/locale", scheme_make_immed_prim(byte_string_to_char_string_locale, "bytes->string/locale", 1, 4), env); - scheme_add_global_constant("bytes->string/latin-1", + scheme_addto_prim_instance("bytes->string/latin-1", scheme_make_immed_prim(byte_string_to_char_string_latin1, "bytes->string/latin-1", 1, 4), env); - scheme_add_global_constant("string->bytes/utf-8", + scheme_addto_prim_instance("string->bytes/utf-8", scheme_make_immed_prim(char_string_to_byte_string, "string->bytes/utf-8", 1, 4), env); - scheme_add_global_constant("string->bytes/locale", + scheme_addto_prim_instance("string->bytes/locale", scheme_make_immed_prim(char_string_to_byte_string_locale, "string->bytes/locale", 1, 4), env); - scheme_add_global_constant("string->bytes/latin-1", + scheme_addto_prim_instance("string->bytes/latin-1", scheme_make_immed_prim(char_string_to_byte_string_latin1, "string->bytes/latin-1", 1, 4), env); - scheme_add_global_constant("string-utf-8-length", + scheme_addto_prim_instance("string-utf-8-length", scheme_make_immed_prim(char_string_utf8_length, "string-utf-8-length", 1, 3), @@ -733,12 +744,12 @@ scheme_init_string (Scheme_Env *env) /* In principle, `version' could be foldable, but it invites more problems than it solves... */ - scheme_add_global_constant("version", + scheme_addto_prim_instance("version", scheme_make_immed_prim(version, "version", 0, 0), env); - scheme_add_global_constant("banner", + scheme_addto_prim_instance("banner", scheme_make_immed_prim(banner, "banner", 0, 0), @@ -746,43 +757,43 @@ scheme_init_string (Scheme_Env *env) /* Environment variables */ - scheme_add_global_constant("environment-variables?", + scheme_addto_prim_instance("environment-variables?", scheme_make_folding_prim(env_p, "environment-variables?", 1, 1, 1), env); - scheme_add_global_constant("current-environment-variables", + scheme_addto_prim_instance("current-environment-variables", scheme_register_parameter(current_environment_variables, "current-environment-variables", MZCONFIG_CURRENT_ENV_VARS), env); - scheme_add_global_constant("environment-variables-ref", + scheme_addto_prim_instance("environment-variables-ref", scheme_make_immed_prim(sch_getenv, "environment-variables-ref", 2, 2), env); - scheme_add_global_constant("environment-variables-set!", + scheme_addto_prim_instance("environment-variables-set!", scheme_make_prim_w_arity(sch_putenv, "environment-variables-set!", 3, 4), env); - scheme_add_global_constant("environment-variables-names", + scheme_addto_prim_instance("environment-variables-names", scheme_make_immed_prim(sch_getenv_names, "environment-variables-names", 1, 1), env); - scheme_add_global_constant("environment-variables-copy", + scheme_addto_prim_instance("environment-variables-copy", scheme_make_immed_prim(env_copy, "environment-variables-copy", 1, 1), env); - scheme_add_global_constant("make-environment-variables", + scheme_addto_prim_instance("make-environment-variables", scheme_make_immed_prim(env_make, "make-environment-variables", 0, -1), @@ -790,25 +801,26 @@ scheme_init_string (Scheme_Env *env) /* Don't make these folding, since they're platform-specific: */ - scheme_add_global_constant("system-type", - scheme_make_immed_prim(system_type, - "system-type", - 0, 1), - env); - scheme_add_global_constant("system-library-subpath", + REGISTER_SO(scheme_system_type_proc); + scheme_system_type_proc = scheme_make_immed_prim(system_type, + "system-type", + 0, 1); + scheme_addto_prim_instance("system-type", scheme_system_type_proc, env); + + scheme_addto_prim_instance("system-library-subpath", scheme_make_immed_prim(system_library_subpath, "system-library-subpath", 0, 1), env); - scheme_add_global_constant("current-command-line-arguments", + scheme_addto_prim_instance("current-command-line-arguments", scheme_register_parameter(cmdline_args, "current-command-line-arguments", MZCONFIG_CMDLINE_ARGS), env); - scheme_add_global_constant("pathvector", 1, 2); - scheme_add_global_constant("struct->vector", scheme_struct_to_vector_proc, env); + scheme_addto_prim_instance("struct->vector", scheme_struct_to_vector_proc, env); - scheme_add_global_constant("prefab-struct-key", - scheme_make_immed_prim(prefab_struct_key, - "prefab-struct-key", - 1, 1), - env); - scheme_add_global_constant("make-prefab-struct", + p = scheme_make_immed_prim(prefab_struct_key, + "prefab-struct-key", + 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); + scheme_addto_prim_instance("prefab-struct-key", p, env); + + scheme_addto_prim_instance("make-prefab-struct", scheme_make_prim_w_arity(make_prefab_struct, "make-prefab-struct", 1, -1), env); - scheme_add_global_constant("prefab-key->struct-type", + scheme_addto_prim_instance("prefab-key->struct-type", scheme_make_prim_w_arity(prefab_key_struct_type, "prefab-key->struct-type", 2, 2), env); - scheme_add_global_constant("prefab-key?", + scheme_addto_prim_instance("prefab-key?", scheme_make_folding_prim(is_prefab_key, "prefab-key?", 1, 1, 1), env); /*** Predicates ****/ - scheme_add_global_constant("struct-mutator-procedure?", + scheme_addto_prim_instance("struct-mutator-procedure?", scheme_make_immed_prim(struct_setter_p, "struct-mutator-procedure?", 1, 1), env); - scheme_add_global_constant("struct-accessor-procedure?", + scheme_addto_prim_instance("struct-accessor-procedure?", scheme_make_immed_prim(struct_getter_p, "struct-accessor-procedure?", 1, 1), env); - scheme_add_global_constant("struct-predicate-procedure?", + scheme_addto_prim_instance("struct-predicate-procedure?", scheme_make_immed_prim(struct_pred_p, "struct-predicate-procedure?", 1, 1), env); - scheme_add_global_constant("struct-constructor-procedure?", + scheme_addto_prim_instance("struct-constructor-procedure?", scheme_make_immed_prim(struct_constr_p, "struct-constructor-procedure?", 1, 1), env); - scheme_add_global_constant("struct-type-property-accessor-procedure?", + scheme_addto_prim_instance("struct-type-property-accessor-procedure?", scheme_make_immed_prim(struct_prop_getter_p, "struct-type-property-accessor-procedure?", 1, 1), env); - scheme_add_global_constant("impersonator-property-accessor-procedure?", + scheme_addto_prim_instance("impersonator-property-accessor-procedure?", scheme_make_immed_prim(chaperone_prop_getter_p, "impersonator-property-accessor-procedure?", 1, 1), @@ -755,18 +676,18 @@ scheme_init_struct (Scheme_Env *env) scheme_make_inspector_proc = scheme_make_immed_prim(make_inspector, "make-inspector", 0, 1); - scheme_add_global_constant("make-inspector", scheme_make_inspector_proc, env); - scheme_add_global_constant("make-sibling-inspector", + scheme_addto_prim_instance("make-inspector", scheme_make_inspector_proc, env); + scheme_addto_prim_instance("make-sibling-inspector", scheme_make_immed_prim(make_sibling_inspector, "make-sibling-inspector", 0, 1), env); - scheme_add_global_constant("inspector?", + scheme_addto_prim_instance("inspector?", scheme_make_folding_prim(inspector_p, "inspector?", 1, 1, 1), env); - scheme_add_global_constant("inspector-superior?", + scheme_addto_prim_instance("inspector-superior?", scheme_make_folding_prim(inspector_superior_p, "inspector-superior?", 2, 2, 1), @@ -776,32 +697,15 @@ scheme_init_struct (Scheme_Env *env) scheme_current_inspector_proc = scheme_register_parameter(current_inspector, "current-inspector", MZCONFIG_INSPECTOR); - scheme_add_global_constant("current-inspector", + scheme_addto_prim_instance("current-inspector", scheme_current_inspector_proc, env); - scheme_add_global_constant("current-code-inspector", + scheme_addto_prim_instance("current-code-inspector", scheme_register_parameter(current_code_inspector, "current-code-inspector", MZCONFIG_CODE_INSPECTOR), env); - - scheme_add_global_constant("make-special-comment", - scheme_make_immed_prim(make_special_comment, - "make-special-comment", - 1, 1), - env); - scheme_add_global_constant("special-comment-value", - scheme_make_immed_prim(special_comment_value, - "special-comment-value", - 1, 1), - env); - scheme_add_global_constant("special-comment?", - scheme_make_folding_prim(special_comment_p, - "special-comment?", - 1, 1, 1), - env); - REGISTER_SO(ellipses_symbol); ellipses_symbol = scheme_intern_symbol("..."); @@ -817,69 +721,46 @@ scheme_init_struct (Scheme_Env *env) scheme_source_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:srclocs"), guard); } - scheme_add_global_constant("prop:exn:srclocs", scheme_source_property, env); - scheme_add_global_constant("exn:srclocs?", + scheme_addto_prim_instance("prop:exn:srclocs", scheme_source_property, env); + scheme_addto_prim_instance("exn:srclocs?", scheme_make_folding_prim(exn_source_p, "exn:srclocs?", 1, 1, 1), env); - scheme_add_global_constant("exn:srclocs-accessor", + scheme_addto_prim_instance("exn:srclocs-accessor", scheme_make_folding_prim(exn_source_get, "exn:srclocs-accessor", 1, 1, 1), env); - REGISTER_SO(scheme_module_path_property); - { - guard = scheme_make_prim_w_arity(check_exn_module_path_property_value_ok, - "guard-for-prop:exn:srclocs", - 2, 2); - scheme_module_path_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:missing-module"), - guard); - } - scheme_add_global_constant("prop:exn:missing-module", scheme_module_path_property, env); - scheme_add_global_constant("exn:missing-module?", - scheme_make_folding_prim(exn_module_path_p, - "exn:missing-module?", - 1, 1, 1), - env); - scheme_add_global_constant("exn:missing-module-accessor", - scheme_make_folding_prim(exn_module_path_get, - "exn:missing-module-accessor", - 1, 1, 1), - env); + p = scheme_make_prim_w_arity(scheme_extract_checked_procedure, + "checked-procedure-check-and-extract", + 5, 5); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); + scheme_addto_prim_instance("checked-procedure-check-and-extract", p, env); - { - Scheme_Object *p; - p = scheme_make_prim_w_arity(scheme_extract_checked_procedure, - "checked-procedure-check-and-extract", - 5, 5); - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("checked-procedure-check-and-extract", p, env); - } - - scheme_add_global_constant("chaperone-struct", + scheme_addto_prim_instance("chaperone-struct", scheme_make_prim_w_arity(chaperone_struct, "chaperone-struct", 1, -1), env); - scheme_add_global_constant("impersonate-struct", + scheme_addto_prim_instance("impersonate-struct", scheme_make_prim_w_arity(impersonate_struct, "impersonate-struct", 1, -1), env); - scheme_add_global_constant("chaperone-struct-type", + scheme_addto_prim_instance("chaperone-struct-type", scheme_make_prim_w_arity(chaperone_struct_type, "chaperone-struct-type", 4, -1), env); - scheme_add_global_constant("make-impersonator-property", + scheme_addto_prim_instance("make-impersonator-property", scheme_make_prim_w_arity2(make_chaperone_property, "make-impersonator-property", 1, 1, 3, 3), env); - scheme_add_global_constant("impersonator-property?", + scheme_addto_prim_instance("impersonator-property?", scheme_make_folding_prim(chaperone_property_p, "impersonator-property?", 1, 1, 1), @@ -888,7 +769,7 @@ scheme_init_struct (Scheme_Env *env) { REGISTER_SO(scheme_app_mark_impersonator_property); scheme_app_mark_impersonator_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark")); - scheme_add_global_constant("impersonator-prop:application-mark", + scheme_addto_prim_instance("impersonator-prop:application-mark", scheme_app_mark_impersonator_property, env); } @@ -937,6 +818,13 @@ void scheme_init_struct_wait() NULL, NULL, 1); } +#if defined(MZ_GC_BACKTRACE) && defined(MZ_PRECISE_GC) +Scheme_Object *scheme_add_builtin_struct_types(Scheme_Object *accum) { + accum = scheme_make_pair(location_struct, accum); + return accum; +} +#endif + /*========================================================================*/ /* inspectors */ /*========================================================================*/ @@ -1849,10 +1737,6 @@ static int is_evt_struct(Scheme_Object *o) /* This is here so it can use check_indirect_property_value_ok */ static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } -static int is_proc_1_or_2(Scheme_Object *o) { return (SCHEME_PROCP(o) && (scheme_check_proc_arity(NULL, 1, -1, 0, &o) - || scheme_check_proc_arity(NULL, 2, -1, 0, &o))); } - - static Scheme_Object *check_object_name_property_value_ok(int argc, Scheme_Object *argv[]) /* This is the guard for prop:object-name */ @@ -2020,189 +1904,6 @@ static Scheme_Object *unary_acc(int argc, Scheme_Object **argv, Scheme_Object *s return _scheme_apply(acc, argc, argv); } -/*========================================================================*/ -/* rename and set! transformer properties */ -/*========================================================================*/ - -int scheme_is_rename_transformer(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) - return 1; - if (SCHEME_CHAPERONE_STRUCTP(o) - && scheme_struct_type_property_ref(rename_transformer_property, o)) - return 1; - return 0; -} - -int scheme_is_binding_rename_transformer(Scheme_Object *o) -{ - if (scheme_is_rename_transformer(o)) { - o = scheme_rename_transformer_id(o, NULL); - o = scheme_stx_property(o, not_free_id_symbol, NULL); - if (o && SCHEME_TRUEP(o)) - return 0; - return 1; - } - return 0; -} - -static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); } - -static int is_stx_id_or_proc_1(Scheme_Object *o) { return (is_stx_id(o) || is_proc_1(o)); } - -Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o, Scheme_Comp_Env *comp_env) -{ - Scheme_Object *a[1]; - - if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) - return SCHEME_PTR1_VAL(o); - if (SCHEME_CHAPERONE_STRUCTP(o)) { - Scheme_Object *v; - v = scheme_struct_type_property_ref(rename_transformer_property, o); - if (SCHEME_PROCP(v)) { - a[0] = o; - /* apply a continuation barrier here to prevent a capture in - * the property access */ - if (comp_env && (scheme_current_thread->current_local_env != comp_env)) { - /* Getting identifier during an expansion context */ - Scheme_Dynamic_State dyn_state; - Scheme_Env *genv = comp_env->genv; - scheme_set_dynamic_state(&dyn_state, comp_env, NULL, NULL, scheme_false, - genv, (genv->module - ? (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx) - : NULL)); - v = scheme_apply_with_dynamic_state(v, 1, a, &dyn_state); - } else { - v = scheme_apply(v, 1, a); - } - if (!is_stx_id(v)) { - scheme_contract_error("prop:rename-transformer", - "contract violation for given value", - "expected", 0, "identifier?", - "given", 1, v, - NULL); - } - } else if (SCHEME_INTP(v)) { - v = scheme_struct_ref(o, SCHEME_INT_VAL(v)); - if (!is_stx_id(v)) { - v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0); - } - } - return v; - } - return NULL; -} - -static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]) -{ - return check_indirect_property_value_ok("guard-for-prop:rename-transformer", - is_stx_id_or_proc_1, 0, - "(or/c exact-nonnegative-integer? identifier? (-> any/c identifier?))", - argc, argv); -} - -int scheme_is_set_transformer(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) - return 1; - if (SCHEME_CHAPERONE_STRUCTP(o) - && scheme_struct_type_property_ref(set_transformer_property, o)) - return 1; - return 0; -} - -Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv) -{ - scheme_wrong_syntax(NULL, NULL, argv[0], "bad syntax"); - return NULL; -} - -static Scheme_Object *chain_transformer(void *data, int argc, Scheme_Object *argv[]) -{ - Scheme_Object *a[2], *v = (Scheme_Object *)data; - a[0] = SCHEME_CAR(v); - a[1] = argv[0]; - return _scheme_tail_apply(SCHEME_CDR(v), 2, a); -} - -Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) - return SCHEME_PTR_VAL(o); - if (SCHEME_CHAPERONE_STRUCTP(o)) { - Scheme_Object *v; - v = scheme_struct_type_property_ref(set_transformer_property, o); - if (SCHEME_INTP(v)) { - v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)]; - if (!is_proc_1(v)) { - v = scheme_make_prim_w_arity(signal_bad_syntax, - "bad-syntax-set!-transformer", - 1, 1); - } - } else if (!scheme_check_proc_arity(NULL, 1, -1, 0, &v)) { - /* Must be a procedure of 2 arguments. Reduce to a procedure of 1. */ - o = scheme_make_pair(o, v); - v = scheme_make_closed_prim_w_arity(chain_transformer, (void *)o, - "set!-transformer", 1, 1); - } - return v; - } - return NULL; -} - -static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]) -{ - return check_indirect_property_value_ok("guard-for-prop:set!-transformer", - is_proc_1_or_2, 0, - "(or/c (any/c . -> . any) (any/c any/c . -> . any) exact-nonnegative-integer?)", - argc, argv); -} - -/*========================================================================*/ -/* expansion-contexts property */ -/*========================================================================*/ - -static Scheme_Object *check_expansion_contexts_property_value_ok(int argc, Scheme_Object *argv[]) -{ - Scheme_Object *v; - - v = argv[0]; - - while (SCHEME_PAIRP(v)) { - if (!scheme_is_expansion_context_symbol(SCHEME_CAR(v))) - break; - v = SCHEME_CDR(v); - } - - if (SCHEME_NULLP(v)) - return argv[0]; - - wrong_property_contract("guard-for-prop:expression-contexts", - "(lisrof (or/c 'expression 'top-level 'module 'module-begin 'definition-context)", - v); - - return NULL; -} - -int scheme_expansion_contexts_include(Scheme_Object *o, Scheme_Object *ctx) -{ - Scheme_Object *v; - - if (SCHEME_CHAPERONE_STRUCTP(o)) { - v = scheme_chaperone_struct_type_property_ref(expansion_contexts_property, o); - if (v) { - while (!SCHEME_NULLP(v)) { - if (SAME_OBJ(SCHEME_CAR(v), ctx)) - return 1; - v = SCHEME_CDR(v); - } - return 0; - } - } - - return 1; -} - /*========================================================================*/ /* checked-proc property */ /*========================================================================*/ @@ -2275,22 +1976,6 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv) return _scheme_apply(argv[2], 3, a); } -/*========================================================================*/ -/* liberal-define */ -/*========================================================================*/ - -static Scheme_Object *is_liberal_def_ctx(int argc, Scheme_Object **argv, Scheme_Object *self) -{ - Scheme_Object *prop = SCHEME_PRIM_CLOSURE_ELS(self)[0], *val; - - val = scheme_struct_type_property_ref(prop, argv[0]); - - if (!val || SCHEME_FALSEP(val)) - return scheme_false; - else - return scheme_true; -} - /*========================================================================*/ /* struct ops */ /*========================================================================*/ @@ -3732,53 +3417,72 @@ int scheme_decode_struct_shape(Scheme_Object *expected, intptr_t *_v) return 1; } -int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected) +intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *expected) { - intptr_t _v, v; + intptr_t _v, v, want_v; int i; Scheme_Struct_Type *st; - if (!scheme_decode_struct_shape(expected, &_v)) - return 0; - v = _v; + if (expected) { + if (!scheme_decode_struct_shape(expected, &_v)) + return 0; + v = _v; + } else + v = 0; if (SCHEME_STRUCT_TYPEP(e)) { st = (Scheme_Struct_Type *)e; if (st->num_slots != st->num_islots) - return (v == STRUCT_PROC_SHAPE_OTHER); - return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_STRUCT - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if (!SCHEME_PRIMP(e)) - return 0; + want_v = STRUCT_PROC_SHAPE_OTHER; + else + want_v = ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_STRUCT + | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)); + } else if (!SCHEME_PRIMP(e)) { + want_v = -1; + } else { + i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + if ((i == SCHEME_PRIM_STRUCT_TYPE_CONSTR) + || (i == SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR)) { + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + want_v = ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_CONSTR); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) { + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + want_v = (STRUCT_PROC_SHAPE_PRED + | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) { + int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]); + int parent_slots; + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + parent_slots = ((st->name_pos > 0) + ? st->parent_types[st->name_pos - 1]->num_slots + : 0); + if ((pos - parent_slots) < (31 - STRUCT_PROC_SHAPE_SHIFT)) + pos++; + else + pos = 0; /* => unknown, since simple struct info can't track it */ + want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_SETTER + | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) { + int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]); + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_GETTER + | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0)); + } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) + || (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER) + || (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) { + want_v = STRUCT_PROC_SHAPE_OTHER; + } else + want_v = -1; + } - i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); - if ((i == SCHEME_PRIM_STRUCT_TYPE_CONSTR) - || (i == SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR)) { - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_CONSTR)); - } else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) { - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == (STRUCT_PROC_SHAPE_PRED - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) { - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_SETTER - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) { - int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]); - st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - return (v == ((pos << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_GETTER - | (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0))); - } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) - || (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER) - || (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) - return (v == STRUCT_PROC_SHAPE_OTHER); - - return 0; + if (expected) + return (v == want_v); + else + return want_v; } int scheme_decode_struct_prop_shape(Scheme_Object *expected, intptr_t *_v) @@ -3790,7 +3494,7 @@ int scheme_decode_struct_prop_shape(Scheme_Object *expected, intptr_t *_v) return 0; if ((SCHEME_SYM_VAL(expected)[0] != 'p') - || (SCHEME_SYM_LEN(expected) < 4)) + || (SCHEME_SYM_LEN(expected) < 4)) return 0; for (i = 4, v = 0; SCHEME_SYM_VAL(expected)[i]; i++) { @@ -3802,30 +3506,43 @@ int scheme_decode_struct_prop_shape(Scheme_Object *expected, intptr_t *_v) return 1; } -int scheme_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected) +intptr_t scheme_get_or_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected) { - intptr_t _v, v; + intptr_t _v, v, want_v; int i; - if (!scheme_decode_struct_prop_shape(expected, &_v)) - return 0; - v = _v; + if (expected) { + if (!scheme_decode_struct_prop_shape(expected, &_v)) + return 0; + v = _v; + } else + v = 0; if (SAME_TYPE(SCHEME_TYPE(e), scheme_struct_property_type)) { if (((Scheme_Struct_Property *)e)->guard) - return (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP); - return ((v == STRUCT_PROP_PROC_SHAPE_PROP) - || (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP)); - } else if (!SCHEME_PRIMP(e)) - return 0; + want_v = STRUCT_PROP_PROC_SHAPE_GUARDED_PROP; + else { + want_v = STRUCT_PROP_PROC_SHAPE_PROP; + if (expected) + return ((v == STRUCT_PROP_PROC_SHAPE_PROP) + || (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP)); + } + } else if (!SCHEME_PRIMP(e)) { + want_v = -1; + } else { + i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + if (i == SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED) + want_v = STRUCT_PROP_PROC_SHAPE_PRED; + else if (i == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) + want_v = STRUCT_PROP_PROC_SHAPE_GETTER; + else + want_v = -1; + } - i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); - if (i == SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED) - return (v == STRUCT_PROP_PROC_SHAPE_PRED); - else if (i == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER) - return (v == STRUCT_PROP_PROC_SHAPE_GETTER); - - return 0; + if (expected) + return v == want_v; + else + return want_v; } static Scheme_Object *make_struct_field_xxor(const char *who, int getter, @@ -6141,46 +5858,6 @@ static Scheme_Object *check_date_star_fields(int argc, Scheme_Object **argv) return scheme_values(12, args); } -/*========================================================================*/ -/* special-comment struct */ -/*========================================================================*/ - -Scheme_Object *scheme_special_comment_value(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_special_comment_type)) - return ((Scheme_Small_Object *)o)->u.ptr_val; - else - return NULL; -} - -Scheme_Object *make_special_comment(int argc, Scheme_Object **argv) -{ - Scheme_Object *o; - - o = scheme_alloc_small_object(); - o->type = scheme_special_comment_type; - SCHEME_PTR_VAL(o) = argv[0]; - - return o; -} - -Scheme_Object *special_comment_value(int argc, Scheme_Object **argv) -{ - Scheme_Object *v; - - v = scheme_special_comment_value(argv[0]); - if (!v) - scheme_wrong_contract("special-comment-value", "special-comment?", 0, argc, argv); - return v; -} - -Scheme_Object *special_comment_p(int argc, Scheme_Object **argv) -{ - return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_special_comment_type) - ? scheme_true - : scheme_false); -} - /**********************************************************************/ static Scheme_Object *exn_source_p(int argc, Scheme_Object **argv) @@ -6211,34 +5888,6 @@ static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object /**********************************************************************/ -static Scheme_Object *exn_module_path_p(int argc, Scheme_Object **argv) -{ - return (scheme_struct_type_property_ref(scheme_module_path_property, argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *exn_module_path_get(int argc, Scheme_Object **argv) -{ - Scheme_Object *v; - - v = scheme_struct_type_property_ref(scheme_module_path_property, argv[0]); - if (!v) - scheme_wrong_contract("exn:missing-module-accessor", "exn:missing-module?", 0, argc, argv); - - return v; -} - -static Scheme_Object *check_exn_module_path_property_value_ok(int argc, Scheme_Object *argv[]) - /* This is the guard for prop:exn:srclocs */ -{ - scheme_check_proc_arity("guard-for-prop:exn:missing-module", 1, 0, argc, argv); - - return argv[0]; -} - -/**********************************************************************/ - static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, int argc, Scheme_Object **argv) /* (chaperone-struct v mutator/selector redirect-proc ...) */ { diff --git a/racket/src/racket/src/stypes.h b/racket/src/racket/src/stypes.h index 2416d3552d..2a9e67e896 100644 --- a/racket/src/racket/src/stypes.h +++ b/racket/src/racket/src/stypes.h @@ -16,304 +16,284 @@ enum { scheme_letrec_type, /* 11 */ scheme_let_one_type, /* 12 */ scheme_with_cont_mark_type, /* 13 */ - scheme_quote_syntax_type, /* 14 */ - scheme_define_values_type, /* 15 */ - scheme_define_syntaxes_type, /* 16 */ - scheme_begin_for_syntax_type, /* 17 */ - scheme_set_bang_type, /* 18 */ - scheme_boxenv_type, /* 19 */ - scheme_begin0_sequence_type, /* 20 */ - scheme_splice_sequence_type, /* 21 */ - scheme_require_form_type, /* 22 */ - scheme_varref_form_type, /* 23 */ - scheme_apply_values_type, /* 24 */ - scheme_with_immed_mark_type, /* 25 */ - scheme_case_lambda_sequence_type, /* 26 */ - scheme_module_type, /* 27 */ - scheme_inline_variant_type, /* 28 */ + scheme_define_values_type, /* 14 */ + scheme_set_bang_type, /* 15 */ + scheme_boxenv_type, /* 16 */ + scheme_begin0_sequence_type, /* 17 */ + scheme_varref_form_type, /* 18 */ + scheme_apply_values_type, /* 19 */ + scheme_with_immed_mark_type, /* 20 */ + scheme_case_lambda_sequence_type, /* 21 */ + scheme_inline_variant_type, /* 22 */ - _scheme_values_types_, /* 29 */ + _scheme_values_types_, /* 23 */ /* All following types are values at run time */ + scheme_linklet_type, /* 24 */ + /* Replacements for some of the above as the compiler's intermediate representation for optimization: */ - scheme_ir_local_type, /* 30 */ - scheme_ir_lambda_type, /* 31 */ - scheme_ir_let_value_type, /* 32 */ - scheme_ir_let_header_type, /* 33 */ - scheme_ir_toplevel_type, /* 34 */ - scheme_ir_quote_syntax_type, /* 35 */ + scheme_ir_local_type, /* 25 */ + scheme_ir_lambda_type, /* 26 */ + scheme_ir_let_value_type, /* 27 */ + scheme_ir_let_header_type, /* 28 */ + scheme_ir_toplevel_type, /* 29 */ scheme_quote_compilation_type, /* used while writing, only */ /* Generated in the compiler front-end, but registered in the prefix table instead of used directly as an "expression": */ - scheme_variable_type, /* 37 */ - scheme_module_variable_type, /* link replaces with scheme_variable_type */ + scheme_variable_type, /* 31 */ - _scheme_ir_values_types_, /* 39 */ + _scheme_ir_values_types_, /* 32 */ /* All of the following are literal values from the perspective of the compiler */ - /* procedure types */ - scheme_prim_type, /* 40 */ - scheme_closed_prim_type, /* 41 */ - scheme_closure_type, /* 42 */ - scheme_case_closure_type, /* 43 */ - scheme_cont_type, /* 44 */ - scheme_escaping_cont_type, /* 45 */ - scheme_proc_struct_type, /* 46 */ - scheme_native_closure_type, /* 47 */ - scheme_proc_chaperone_type, /* 48 */ + scheme_linklet_bundle_type, /* 33 */ + scheme_linklet_directory_type, /* 34 */ + scheme_instance_type, /* 35 */ - scheme_chaperone_type, /* 49 */ + /* procedure types */ + scheme_prim_type, /* 36 */ + scheme_closed_prim_type, /* 37 */ + scheme_closure_type, /* 38 */ + scheme_case_closure_type, /* 39 */ + scheme_cont_type, /* 40 */ + scheme_escaping_cont_type, /* 41 */ + scheme_proc_struct_type, /* 42 */ + scheme_native_closure_type, /* 43 */ + scheme_proc_chaperone_type, /* 44 */ + + scheme_chaperone_type, /* 45 */ /* structure type (plus one above for procs) */ - scheme_structure_type, /* 50 */ + scheme_structure_type, /* 46 */ /* number types (must be together) */ - scheme_integer_type, /* 51 */ - scheme_bignum_type, /* 52 */ - scheme_rational_type, /* 53 */ - scheme_float_type, /* 54 */ - scheme_double_type, /* 55 */ - scheme_complex_type, /* 56 */ + scheme_integer_type, /* 47 */ + scheme_bignum_type, /* 48 */ + scheme_rational_type, /* 49 */ + scheme_float_type, /* 50 */ + scheme_double_type, /* 51 */ + scheme_complex_type, /* 52 */ /* other eqv?-able values (must be with numbers) */ - scheme_char_type, /* 57 */ + scheme_char_type, /* 53 */ /* other values */ - scheme_long_double_type, /* 58 */ - scheme_char_string_type, /* 59 */ - scheme_byte_string_type, /* 60 */ - scheme_unix_path_type, /* 61 */ - scheme_windows_path_type, /* 62 */ - scheme_symbol_type, /* 63 */ - scheme_keyword_type, /* 64 */ - scheme_null_type, /* 65 */ - scheme_pair_type, /* 66 */ - scheme_mutable_pair_type, /* 67 */ - scheme_vector_type, /* 68 */ - scheme_inspector_type, /* 69 */ - scheme_input_port_type, /* 70 */ - scheme_output_port_type, /* 71 */ - scheme_eof_type, /* 72 */ - scheme_true_type, /* 73 */ - scheme_false_type, /* 74 */ - scheme_void_type, /* 75 */ - scheme_primitive_syntax_type, /* 76 */ - scheme_macro_type, /* 77 */ - scheme_box_type, /* 78 */ - scheme_thread_type, /* 79 */ - scheme_scope_type, /* 80 */ - scheme_stx_offset_type, /* 81 */ - scheme_cont_mark_set_type, /* 82 */ - scheme_sema_type, /* 83 */ - scheme_hash_table_type, /* 84 */ - scheme_hash_tree_type, /* 85 */ - scheme_eq_hash_tree_type, /* 86 */ - scheme_eqv_hash_tree_type, /* 87 */ - scheme_hash_tree_subtree_type, /* 88 */ - scheme_hash_tree_collision_type, /* 89 */ - scheme_hash_tree_indirection_type, /* 90 */ - scheme_cpointer_type, /* 91 */ - scheme_prefix_type, /* 92 */ - scheme_weak_box_type, /* 93 */ - scheme_ephemeron_type, /* 94 */ - scheme_struct_type_type, /* 95 */ - scheme_module_index_type, /* 96 */ - scheme_set_macro_type, /* 97 */ - scheme_listener_type, /* 98 */ - scheme_namespace_type, /* 99 */ - scheme_config_type, /* 100 */ - scheme_stx_type, /* 101 */ - scheme_will_executor_type, /* 102 */ - scheme_custodian_type, /* 103 */ - scheme_random_state_type, /* 104 */ - scheme_regexp_type, /* 105 */ - scheme_bucket_type, /* 106 */ - scheme_bucket_table_type, /* 107 */ - scheme_subprocess_type, /* 108 */ - scheme_compilation_top_type, /* 109 */ - scheme_wrap_chunk_type, /* 110 */ - scheme_eval_waiting_type, /* 111 */ - scheme_tail_call_waiting_type, /* 112 */ - scheme_undefined_type, /* 113 */ - scheme_struct_property_type, /* 114 */ - scheme_chaperone_property_type, /* 115 */ - scheme_multiple_values_type, /* 116 */ - scheme_placeholder_type, /* 117 */ - scheme_table_placeholder_type, /* 118 */ - scheme_scope_table_type, /* 119 */ - scheme_propagate_table_type, /* 120 */ - scheme_svector_type, /* 121 */ - scheme_resolve_prefix_type, /* 122 */ - scheme_security_guard_type, /* 123 */ - scheme_indent_type, /* 124 */ - scheme_udp_type, /* 125 */ - scheme_udp_evt_type, /* 126 */ - scheme_tcp_accept_evt_type, /* 127 */ - scheme_id_macro_type, /* 128 */ - scheme_evt_set_type, /* 129 */ - scheme_wrap_evt_type, /* 130 */ - scheme_handle_evt_type, /* 131 */ - scheme_replace_evt_type, /* 132 */ - scheme_active_replace_evt_type, /* 133 */ - scheme_nack_guard_evt_type, /* 134 */ - scheme_semaphore_repost_type, /* 135 */ - scheme_channel_type, /* 136 */ - scheme_channel_put_type, /* 137 */ - scheme_thread_resume_type, /* 138 */ - scheme_thread_suspend_type, /* 139 */ - scheme_thread_dead_type, /* 140 */ - scheme_poll_evt_type, /* 141 */ - scheme_nack_evt_type, /* 142 */ - scheme_module_registry_type, /* 143 */ - scheme_thread_set_type, /* 144 */ - scheme_string_converter_type, /* 145 */ - scheme_alarm_type, /* 146 */ - scheme_thread_recv_evt_type, /* 147 */ - scheme_thread_cell_type, /* 148 */ - scheme_channel_syncer_type, /* 149 */ - scheme_special_comment_type, /* 150 */ - scheme_write_evt_type, /* 151 */ - scheme_always_evt_type, /* 152 */ - scheme_never_evt_type, /* 153 */ - scheme_progress_evt_type, /* 154 */ - scheme_place_dead_type, /* 155 */ - scheme_already_comp_type, /* 156 */ - scheme_readtable_type, /* 157 */ - scheme_intdef_context_type, /* 158 */ - scheme_lexical_rib_type, /* 159 */ - scheme_thread_cell_values_type, /* 160 */ - scheme_global_ref_type, /* 161 */ - scheme_cont_mark_chain_type, /* 162 */ - scheme_raw_pair_type, /* 163 */ - scheme_prompt_type, /* 164 */ - scheme_prompt_tag_type, /* 165 */ - scheme_continuation_mark_key_type, /* 166 */ - scheme_expanded_syntax_type, /* 167 */ - scheme_delay_syntax_type, /* 168 */ - scheme_cust_box_type, /* 169 */ - scheme_resolved_module_path_type, /* 170 */ - scheme_module_phase_exports_type, /* 171 */ - scheme_logger_type, /* 172 */ - scheme_log_reader_type, /* 173 */ - scheme_marshal_share_type, /* 174 */ - scheme_rib_delimiter_type, /* 175 */ - scheme_noninline_proc_type, /* 176 */ - scheme_prune_context_type, /* 177 */ - scheme_future_type, /* 178 */ - scheme_flvector_type, /* 179 */ - scheme_extflvector_type, /* 180 */ - scheme_fxvector_type, /* 181 */ - scheme_place_type, /* 182 */ - scheme_place_object_type, /* 183 */ - scheme_place_async_channel_type, /* 184 */ - scheme_place_bi_channel_type, /* 185 */ - scheme_once_used_type, /* 186 */ - scheme_serialized_symbol_type, /* 187 */ - scheme_serialized_keyword_type, /* 188 */ - scheme_serialized_structure_type, /* 189 */ - scheme_fsemaphore_type, /* 190 */ - scheme_serialized_tcp_fd_type, /* 191 */ - scheme_serialized_file_fd_type, /* 192 */ - scheme_port_closed_evt_type, /* 193 */ - scheme_proc_shape_type, /* 194 */ - scheme_struct_proc_shape_type, /* 195 */ - scheme_struct_prop_proc_shape_type, /* 196 */ - scheme_phantom_bytes_type, /* 197 */ - scheme_environment_variables_type, /* 198 */ - scheme_filesystem_change_evt_type, /* 199 */ - scheme_ctype_type, /* 200 */ - scheme_plumber_type, /* 201 */ - scheme_plumber_handle_type, /* 202 */ - scheme_deferred_expr_type, /* 203 */ - scheme_will_be_lambda_type, /* 204 */ - scheme_syntax_property_preserve_type, /* 205 */ - scheme_unquoted_printing_string_type, /* 206 */ - + scheme_long_double_type, /* 54 */ + scheme_char_string_type, /* 55 */ + scheme_byte_string_type, /* 56 */ + scheme_unix_path_type, /* 57 */ + scheme_windows_path_type, /* 58 */ + scheme_symbol_type, /* 59 */ + scheme_keyword_type, /* 60 */ + scheme_null_type, /* 61 */ + scheme_pair_type, /* 62 */ + scheme_mutable_pair_type, /* 63 */ + scheme_vector_type, /* 64 */ + scheme_inspector_type, /* 65 */ + scheme_input_port_type, /* 66 */ + scheme_output_port_type, /* 67 */ + scheme_eof_type, /* 68 */ + scheme_true_type, /* 69 */ + scheme_false_type, /* 70 */ + scheme_void_type, /* 71 */ + scheme_primitive_syntax_type, /* 72 */ + scheme_macro_type, /* 73 */ + scheme_box_type, /* 74 */ + scheme_thread_type, /* 75 */ + scheme_cont_mark_set_type, /* 76 */ + scheme_sema_type, /* 77 */ + + /* hash table types (must be together for hash? + * implementation */ + scheme_hash_table_type, /* 78 */ + scheme_hash_tree_type, /* 79 */ + scheme_eq_hash_tree_type, /* 80 */ + scheme_eqv_hash_tree_type, /* 81 */ + scheme_hash_tree_subtree_type, /* 82 */ + scheme_hash_tree_collision_type, /* 83 */ + scheme_hash_tree_indirection_type, /* 84 */ + scheme_bucket_type, /* 85 */ + scheme_bucket_table_type, /* 86 */ + + scheme_cpointer_type, /* 87 */ + scheme_prefix_type, /* 88 */ + scheme_weak_box_type, /* 89 */ + scheme_ephemeron_type, /* 90 */ + scheme_struct_type_type, /* 91 */ + scheme_set_macro_type, /* 92 */ + scheme_listener_type, /* 93 */ + scheme_env_type, /* 94 */ + scheme_startup_env_type, /* 95 */ + scheme_config_type, /* 96 */ + scheme_stx_type, /* 97 */ + scheme_will_executor_type, /* 98 */ + scheme_custodian_type, /* 99 */ + scheme_random_state_type, /* 100 */ + scheme_regexp_type, /* 101 */ + scheme_subprocess_type, /* 102 */ + scheme_eval_waiting_type, /* 103 */ + scheme_tail_call_waiting_type, /* 104 */ + scheme_undefined_type, /* 105 */ + scheme_struct_property_type, /* 106 */ + scheme_chaperone_property_type, /* 107 */ + scheme_multiple_values_type, /* 108 */ + scheme_placeholder_type, /* 109 */ + scheme_table_placeholder_type, /* 110 */ + scheme_svector_type, /* 111 */ + scheme_resolve_prefix_type, /* 112 */ + scheme_security_guard_type, /* 113 */ + scheme_indent_type, /* 114 */ + scheme_udp_type, /* 115 */ + scheme_udp_evt_type, /* 116 */ + scheme_tcp_accept_evt_type, /* 117 */ + scheme_id_macro_type, /* 118 */ + scheme_evt_set_type, /* 119 */ + scheme_wrap_evt_type, /* 120 */ + scheme_handle_evt_type, /* 121 */ + scheme_replace_evt_type, /* 122 */ + scheme_active_replace_evt_type, /* 123 */ + scheme_nack_guard_evt_type, /* 124 */ + scheme_semaphore_repost_type, /* 125 */ + scheme_channel_type, /* 126 */ + scheme_channel_put_type, /* 127 */ + scheme_thread_resume_type, /* 128 */ + scheme_thread_suspend_type, /* 129 */ + scheme_thread_dead_type, /* 130 */ + scheme_poll_evt_type, /* 131 */ + scheme_nack_evt_type, /* 132 */ + scheme_thread_set_type, /* 133 */ + scheme_string_converter_type, /* 134 */ + scheme_alarm_type, /* 135 */ + scheme_thread_recv_evt_type, /* 136 */ + scheme_thread_cell_type, /* 137 */ + scheme_channel_syncer_type, /* 138 */ + scheme_write_evt_type, /* 139 */ + scheme_always_evt_type, /* 140 */ + scheme_never_evt_type, /* 141 */ + scheme_progress_evt_type, /* 142 */ + scheme_place_dead_type, /* 143 */ + scheme_already_comp_type, /* 144 */ + scheme_readtable_type, /* 145 */ + scheme_thread_cell_values_type, /* 146 */ + scheme_global_ref_type, /* 147 */ + scheme_cont_mark_chain_type, /* 148 */ + scheme_raw_pair_type, /* 149 */ + scheme_prompt_type, /* 150 */ + scheme_prompt_tag_type, /* 151 */ + scheme_continuation_mark_key_type, /* 152 */ + scheme_delay_syntax_type, /* 153 */ + scheme_cust_box_type, /* 154 */ + scheme_logger_type, /* 155 */ + scheme_log_reader_type, /* 156 */ + scheme_noninline_proc_type, /* 157 */ + scheme_future_type, /* 158 */ + scheme_flvector_type, /* 159 */ + scheme_extflvector_type, /* 160 */ + scheme_fxvector_type, /* 161 */ + scheme_place_type, /* 162 */ + scheme_place_object_type, /* 163 */ + scheme_place_async_channel_type, /* 164 */ + scheme_place_bi_channel_type, /* 165 */ + scheme_once_used_type, /* 166 */ + scheme_serialized_symbol_type, /* 167 */ + scheme_serialized_keyword_type, /* 168 */ + scheme_serialized_structure_type, /* 169 */ + scheme_fsemaphore_type, /* 170 */ + scheme_serialized_tcp_fd_type, /* 171 */ + scheme_serialized_file_fd_type, /* 172 */ + scheme_port_closed_evt_type, /* 173 */ + scheme_proc_shape_type, /* 174 */ + scheme_struct_prop_proc_shape_type, /* 175 */ + scheme_struct_proc_shape_type, /* 176 */ + scheme_phantom_bytes_type, /* 177 */ + scheme_environment_variables_type, /* 178 */ + scheme_filesystem_change_evt_type, /* 179 */ + scheme_ctype_type, /* 180 */ + scheme_plumber_type, /* 181 */ + scheme_plumber_handle_type, /* 182 */ + scheme_deferred_expr_type, /* 183 */ + scheme_unquoted_printing_string_type, /* 184 */ + scheme_will_be_lambda_type, /* 185 */ + #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 207 */ + _scheme_last_normal_type_, /* 186 */ /* The remaining tags exist for GC tracing (in non-conservative mode), but they are not needed for run-time tag tests */ - scheme_rt_weak_array, /* 208 */ + scheme_rt_weak_array, /* 187 */ - scheme_rt_comp_env, /* 209 */ - scheme_rt_constant_binding, /* 210 */ - scheme_rt_resolve_info, /* 211 */ - scheme_rt_unresolve_info, /* 212 */ - scheme_rt_optimize_info, /* 213 */ - scheme_rt_cont_mark, /* 214 */ - scheme_rt_saved_stack, /* 215 */ - scheme_rt_reply_item, /* 216 */ - scheme_rt_ir_lambda_info, /* 217 */ - scheme_rt_overflow, /* 218 */ - scheme_rt_overflow_jmp, /* 219 */ - scheme_rt_meta_cont, /* 220 */ - scheme_rt_dyn_wind_cell, /* 221 */ - scheme_rt_dyn_wind_info, /* 222 */ - scheme_rt_dyn_wind, /* 223 */ - scheme_rt_dup_check, /* 224 */ - scheme_rt_thread_memory, /* 225 */ - scheme_rt_input_file, /* 226 */ - scheme_rt_input_fd, /* 227 */ - scheme_rt_oskit_console_input, /* 228 */ - scheme_rt_tested_input_file, /* 229 */ - scheme_rt_tested_output_file, /* 230 */ - scheme_rt_indexed_string, /* 231 */ - scheme_rt_output_file, /* 232 */ - scheme_rt_load_handler_data, /* 233 */ - scheme_rt_pipe, /* 234 */ - scheme_rt_beos_process, /* 235 */ - scheme_rt_system_child, /* 236 */ - scheme_rt_tcp, /* 237 */ - scheme_rt_write_data, /* 238 */ - scheme_rt_tcp_select_info, /* 239 */ - scheme_rt_param_data, /* 240 */ - scheme_rt_will, /* 241 */ - scheme_rt_linker_name, /* 242 */ - scheme_rt_param_map, /* 243 */ - scheme_rt_finalization, /* 244 */ - scheme_rt_finalizations, /* 245 */ - scheme_rt_cpp_object, /* 246 */ - scheme_rt_cpp_array_object, /* 247 */ - scheme_rt_stack_object, /* 248 */ - scheme_rt_preallocated_object, /* 249 */ - scheme_thread_hop_type, /* 250 */ - scheme_rt_srcloc, /* 251 */ - scheme_rt_evt, /* 252 */ - scheme_rt_syncing, /* 253 */ - scheme_rt_comp_prefix, /* 254 */ - scheme_rt_user_input, /* 255 */ - scheme_rt_user_output, /* 256 */ - scheme_rt_compact_port, /* 257 */ - scheme_rt_read_special_dw, /* 258 */ - scheme_rt_regwork, /* 259 */ - scheme_rt_rx_lazy_string, /* 260 */ - scheme_rt_buf_holder, /* 261 */ - scheme_rt_parameterization, /* 262 */ - scheme_rt_print_params, /* 263 */ - scheme_rt_read_params, /* 264 */ - scheme_rt_native_code, /* 265 */ - scheme_rt_native_code_plus_case, /* 266 */ - scheme_rt_jitter_data, /* 267 */ - scheme_rt_module_exports, /* 268 */ - scheme_rt_delay_load_info, /* 269 */ - scheme_rt_marshal_info, /* 270 */ - scheme_rt_unmarshal_info, /* 271 */ - scheme_rt_runstack, /* 272 */ - scheme_rt_sfs_info, /* 273 */ - scheme_rt_validate_clearing, /* 274 */ - scheme_rt_lightweight_cont, /* 275 */ - scheme_rt_export_info, /* 276 */ - scheme_rt_cont_jmp, /* 277 */ - scheme_rt_letrec_check_frame, /* 278 */ + scheme_rt_comp_env, /* 188 */ + scheme_rt_constant_binding, /* 189 */ + scheme_rt_resolve_info, /* 190 */ + scheme_rt_unresolve_info, /* 191 */ + scheme_rt_optimize_info, /* 192 */ + scheme_rt_cont_mark, /* 193 */ + scheme_rt_saved_stack, /* 194 */ + scheme_rt_reply_item, /* 195 */ + scheme_rt_ir_lambda_info, /* 196 */ + scheme_rt_overflow, /* 197 */ + scheme_rt_overflow_jmp, /* 198 */ + scheme_rt_meta_cont, /* 199 */ + scheme_rt_dyn_wind_cell, /* 200 */ + scheme_rt_dyn_wind_info, /* 201 */ + scheme_rt_dyn_wind, /* 202 */ + scheme_rt_dup_check, /* 203 */ + scheme_rt_thread_memory, /* 204 */ + scheme_rt_input_file, /* 205 */ + scheme_rt_input_fd, /* 206 */ + scheme_rt_oskit_console_input, /* 207 */ + scheme_rt_tested_input_file, /* 208 */ + scheme_rt_tested_output_file, /* 209 */ + scheme_rt_indexed_string, /* 210 */ + scheme_rt_output_file, /* 211 */ + scheme_rt_pipe, /* 212 */ + scheme_rt_system_child, /* 213 */ + scheme_rt_tcp, /* 214 */ + scheme_rt_write_data, /* 215 */ + scheme_rt_tcp_select_info, /* 216 */ + scheme_rt_param_data, /* 217 */ + scheme_rt_will, /* 218 */ + scheme_rt_finalization, /* 219 */ + scheme_rt_finalizations, /* 220 */ + scheme_rt_cpp_object, /* 221 */ + scheme_rt_cpp_array_object, /* 222 */ + scheme_rt_stack_object, /* 223 */ + scheme_thread_hop_type, /* 224 */ + scheme_rt_srcloc, /* 225 */ + scheme_rt_evt, /* 226 */ + scheme_rt_syncing, /* 227 */ + scheme_rt_comp_prefix, /* 228 */ + scheme_rt_user_input, /* 229 */ + scheme_rt_user_output, /* 230 */ + scheme_rt_compact_port, /* 231 */ + scheme_rt_read_special_dw, /* 232 */ + scheme_rt_regwork, /* 233 */ + scheme_rt_rx_lazy_string, /* 234 */ + scheme_rt_buf_holder, /* 235 */ + scheme_rt_parameterization, /* 236 */ + scheme_rt_print_params, /* 237 */ + scheme_rt_read_params, /* 238 */ + scheme_rt_native_code, /* 239 */ + scheme_rt_native_code_plus_case, /* 240 */ + scheme_rt_jitter_data, /* 241 */ + scheme_rt_module_exports, /* 242 */ + scheme_rt_delay_load_info, /* 243 */ + scheme_rt_marshal_info, /* 244 */ + scheme_rt_unmarshal_info, /* 245 */ + scheme_rt_runstack, /* 246 */ + scheme_rt_sfs_info, /* 247 */ + scheme_rt_validate_clearing, /* 248 */ + scheme_rt_lightweight_cont, /* 249 */ + scheme_rt_export_info, /* 250 */ + scheme_rt_cont_jmp, /* 251 */ + scheme_rt_letrec_check_frame, /* 252 */ #endif _scheme_last_type_ diff --git a/racket/src/racket/src/symbol.c b/racket/src/racket/src/symbol.c index 0c60f4c184..1c60822da8 100644 --- a/racket/src/racket/src/symbol.c +++ b/racket/src/racket/src/symbol.c @@ -324,45 +324,61 @@ scheme_init_place_local_symbol_table () #endif void -scheme_init_symbol_type (Scheme_Env *env) +scheme_init_symbol_type (Scheme_Startup_Env *env) { } void -scheme_init_symbol (Scheme_Env *env) +scheme_init_symbol (Scheme_Startup_Env *env) { Scheme_Object *p; REGISTER_SO(scheme_symbol_p_proc); p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_symbol_p_proc = p; - scheme_add_global_constant("symbol?", p, env); + scheme_addto_prim_instance("symbol?", p, env); p = scheme_make_folding_prim(symbol_unreadable_p_prim, "symbol-unreadable?", 1, 1, 1); - scheme_add_global_constant("symbol-unreadable?", p, env); + scheme_addto_prim_instance("symbol-unreadable?", p, env); p = scheme_make_folding_prim(symbol_interned_p_prim, "symbol-interned?", 1, 1, 1); - scheme_add_global_constant("symbol-interned?", p, env); + scheme_addto_prim_instance("symbol-interned?", p, env); - GLOBAL_FOLDING_PRIM("symbolsymbol", string_to_symbol_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("string->uninterned-symbol", string_to_uninterned_symbol_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("string->unreadable-symbol", string_to_unreadable_symbol_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("symbol->string", symbol_to_string_prim, 1, 1, env); + ADD_FOLDING_PRIM("symbolsymbol", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string->symbol", p, env); + + ADD_IMMED_PRIM("string->uninterned-symbol", string_to_uninterned_symbol_prim, 1, 1, env); + ADD_IMMED_PRIM("string->unreadable-symbol", string_to_unreadable_symbol_prim, 1, 1, env); + + p = scheme_make_folding_prim(symbol_to_string_prim, "symbol->string", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("symbol->string", p, env); REGISTER_SO(scheme_keyword_p_proc); p = scheme_make_folding_prim(keyword_p_prim, "keyword?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); scheme_keyword_p_proc = p; - scheme_add_global_constant("keyword?", p, env); + scheme_addto_prim_instance("keyword?", p, env); - GLOBAL_FOLDING_PRIM("keywordkeyword", string_to_keyword_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("keyword->string", keyword_to_string_prim, 1, 1, env); - GLOBAL_IMMED_PRIM("gensym", gensym, 0, 1, env); + ADD_FOLDING_PRIM("keywordkeyword", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("string->keyword", p, env); + + p = scheme_make_folding_prim(keyword_to_string_prim, "keyword->string", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("keyword->string", p, env); + + ADD_IMMED_PRIM("gensym", gensym, 0, 1, env); } uintptr_t scheme_get_max_symbol_length() { @@ -680,7 +696,7 @@ const char *scheme_symbol_name_and_size(Scheme_Object *sym, uintptr_t *length, i if (cs && digit_start && !(flags & SCHEME_SNF_FOR_TS) - && (SCHEME_TRUEP(scheme_read_number(cs, clen, 0, 0, 1, 10, 0, NULL, &dz, 1, NULL, 0, 0, 0, 0, NULL)) + && (SCHEME_TRUEP(scheme_read_number(cs, clen, 0, 0, 1, 10, 0, NULL, &dz, 1)) || dz)) { /* Need quoting: */ if (pipe_quote) @@ -951,7 +967,6 @@ static Scheme_Object *gensym(int argc, Scheme_Object *argv[]) { char buffer[100], *str; Scheme_Object *r; - Scheme_Thread *p; if (argc) r = argv[0]; @@ -961,18 +976,6 @@ static Scheme_Object *gensym(int argc, Scheme_Object *argv[]) if (r && !SCHEME_SYMBOLP(r) && !SCHEME_CHAR_STRINGP(r)) scheme_wrong_contract("gensym", "(or/c symbol? string?)", 0, argc, argv); - if (!r) { - /* Generate a name using an enclosing module name during compilation, if available */ - p = scheme_current_thread; - if (p->current_local_env && p->current_local_env->genv->module) { - r = SCHEME_PTR_VAL(p->current_local_env->genv->module->modname); - if (SCHEME_PAIRP(r)) - r = SCHEME_CAR(r); - if (!SCHEME_SYMBOLP(r)) - r = NULL; - } - } - if (r) { char buf[64]; if (SCHEME_CHAR_STRINGP(r)) { diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index 0926b2671f..1ae0129ee7 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -21,36 +21,12 @@ #include "schpriv.h" #include "schmach.h" -#include "schexpobs.h" ROSYM static Scheme_Object *source_symbol; /* uninterned! */ -ROSYM static Scheme_Object *share_symbol; /* uninterned! */ -ROSYM static Scheme_Object *origin_symbol; -ROSYM static Scheme_Object *lexical_symbol; -ROSYM static Scheme_Object *protected_symbol; -ROSYM static Scheme_Object *nominal_id_symbol; - -ROSYM static Scheme_Object *module_symbol; -ROSYM static Scheme_Object *top_symbol; -ROSYM static Scheme_Object *macro_symbol; -ROSYM static Scheme_Object *local_symbol; -ROSYM static Scheme_Object *intdef_symbol; -ROSYM static Scheme_Object *use_site_symbol; - -ROSYM static Scheme_Object *name_symbol; -ROSYM static Scheme_Object *context_symbol; -ROSYM static Scheme_Object *bindings_symbol; -ROSYM static Scheme_Object *matchp_symbol; -ROSYM static Scheme_Object *cycle_symbol; -ROSYM static Scheme_Object *free_symbol; -ROSYM static Scheme_Object *fallbacks_symbol; READ_ONLY Scheme_Object *scheme_syntax_p_proc; READ_ONLY static Scheme_Hash_Tree *empty_hash_tree; -READ_ONLY static Scheme_Scope_Table *empty_scope_table; -READ_ONLY static Scheme_Scope_Table *empty_propagate_table; -READ_ONLY static Scheme_Scope_Set *empty_scope_set; ROSYM Scheme_Object *scheme_paren_shape_symbol; @@ -62,192 +38,31 @@ READ_ONLY static Scheme_Hash_Tree *curly_stx_props; READ_ONLY static Scheme_Stx_Srcloc *empty_srcloc; -typedef struct Scheme_Scope { - Scheme_Inclhash_Object iso; /* 0x1 => Scheme_Scope_With_Owner */ - mzlonglong id; /* low SCHEME_STX_SCOPE_KIND_SHIFT bits indicate kind */ - Scheme_Object *bindings; /* NULL, vector for one binding, hash table for multiple bindings, - or (rcons hash-table (rcons (cons scope-set pes-info) ... NULL)); - each hash table maps symbols to (cons scope-set binding) - or (mlist (cons scope-set binding) ...) */ -} Scheme_Scope; - -/* For a scope that is for a particular phase within a set of phase-specific scopes: */ -typedef struct Scheme_Scope_With_Owner { - Scheme_Scope m; - Scheme_Object *owner_multi_scope; - Scheme_Object *phase; -} Scheme_Scope_With_Owner; - -#define SCHEME_SCOPE_FLAGS(m) MZ_OPT_HASH_KEY(&(m)->iso) -#define SCHEME_SCOPE_HAS_OWNER(m) (SCHEME_SCOPE_FLAGS(m) & 0x1) - -#define SCHEME_SCOPE_KIND(m) (((Scheme_Scope *)(m))->id & SCHEME_STX_SCOPE_KIND_MASK) - -READ_ONLY static Scheme_Object *root_scope; - -/* For lazy propagation of scope changes: */ -typedef struct Scheme_Propagate_Table { - Scheme_Scope_Table st; /* Maps scopes to actions, instead of just holding a set of scopes; - action compositions can be collased to an action: - SCHEME_STX_ADD + SCHEME_STX_FLIP = SCHEME_STX_REMOVE, etc. */ - Scheme_Scope_Table *prev; /* points to old scope table as a shortcut; - the old table plus these actions equals - the owning object's current table */ - Scheme_Object *phase_shift; /* or (box ); latter converts only to #f */ -} Scheme_Propagate_Table; - -THREAD_LOCAL_DECL(static mzlonglong scope_counter); -THREAD_LOCAL_DECL(static Scheme_Object *last_phase_shift); -THREAD_LOCAL_DECL(static Scheme_Object *nominal_ipair_cache); -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *taint_intern_table); -THREAD_LOCAL_DECL(static struct Binding_Cache_Entry *binding_cache_table); -THREAD_LOCAL_DECL(static intptr_t binding_cache_pos); -THREAD_LOCAL_DECL(static intptr_t binding_cache_len); -THREAD_LOCAL_DECL(static Scheme_Scope_Set *recent_scope_sets[2][NUM_RECENT_SCOPE_SETS]); -THREAD_LOCAL_DECL(static int recent_scope_sets_pos[2]); - static Scheme_Object *syntax_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv); static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv); +Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); static Scheme_Object *syntax_line(int argc, Scheme_Object **argv); static Scheme_Object *syntax_col(int argc, Scheme_Object **argv); static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv); static Scheme_Object *syntax_span(int argc, Scheme_Object **argv); static Scheme_Object *syntax_src(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_tainted_p(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_property_preserved_p(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv); - -static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_trans_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_templ_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_label_eq(int argc, Scheme_Object **argv); -static Scheme_Object *free_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_trans_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_templ_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_label_binding(int argc, Scheme_Object **argv); -static Scheme_Object *free_binding_symbol(int argc, Scheme_Object **argv); -static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv); -static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_arm(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_disarm(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_rearm(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_taint(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_debug_info(int argc, Scheme_Object **argv); - -static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, int *mutate); +static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o); +static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, + Scheme_Stx *stx_src, + Scheme_Hash_Table *ht); #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -XFORM_NONGCING static int is_armed(Scheme_Object *v); -static Scheme_Object *add_taint_to_stx(Scheme_Object *o, int *mutate); - -static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *shifts, - Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at); - -static Scheme_Object *make_unmarshal_info(Scheme_Object *phase, Scheme_Object *prefix, Scheme_Object *excepts); -XFORM_NONGCING static Scheme_Object *extract_unmarshal_phase(Scheme_Object *unmarshal_info); -XFORM_NONGCING static Scheme_Object *extract_unmarshal_prefix(Scheme_Object *unmarshal_info); -static Scheme_Hash_Tree *extract_unmarshal_excepts(Scheme_Object *unmarshal_info); -static Scheme_Object *unmarshal_lookup_adjust(Scheme_Object *sym, Scheme_Object *pes); -static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pes); - -XFORM_NONGCING static int scopes_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b); -static Scheme_Object *remove_at_scope_list(Scheme_Object *l, Scheme_Object *p); -static Scheme_Object *add_to_scope_list(Scheme_Object *l, Scheme_Object *p); - -static Scheme_Object *wraps_to_datum(Scheme_Stx *stx, Scheme_Marshal_Tables *mt); -static Scheme_Object *scope_unmarshal_content(Scheme_Object *c, struct Scheme_Unmarshal_Tables *utx); - -static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes); -static void sort_vector_symbols(Scheme_Object *vec); - -static void sort_scope_array(Scheme_Object **a, intptr_t count); -static void sort_symbol_array(Scheme_Object **a, intptr_t count); -static void sort_number_array(Scheme_Object **a, intptr_t count); - -static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_scopes, - Scheme_Marshal_Tables *mt); -static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Stx *stx_src, - Scheme_Stx *stx_wraps, - Scheme_Hash_Table *ht, - int tainted); - -XFORM_NONGCING static void extract_module_binding_parts(Scheme_Object *l, - Scheme_Object *phase, - Scheme_Object **_insp_desc, - Scheme_Object **_modidx, - Scheme_Object **_exportname, - Scheme_Object **_nominal_modidx, - Scheme_Object **_mod_phase, - Scheme_Object **_nominal_name, - Scheme_Object **_src_phase, - Scheme_Object **_nominal_src_phase); - -static Scheme_Object *stx_debug_info(Scheme_Stx *stx, Scheme_Object *phase, Scheme_Object *seen, int all_bindings); - -static void init_binding_cache(void); -XFORM_NONGCING static void clear_binding_cache(void); -XFORM_NONGCING static void clear_binding_cache_for(Scheme_Object *sym); -XFORM_NONGCING static void clear_binding_cache_stx(Scheme_Stx *stx); - -static Scheme_Object *make_preserved_property_value(Scheme_Object *v); - #define CONS scheme_make_pair -#define ICONS scheme_make_pair - -/* "substx" means that we need to propagate marks to nested syntax objects */ -#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) -#define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj)))) - -#define SCHEME_INSPECTORP(obj) SAME_TYPE(scheme_inspector_type, SCHEME_TYPE(obj)) -#define SCHEME_INSPECTOR_DESCP(obj) (SCHEME_INSPECTORP(obj) || SCHEME_SYMBOLP(obj)) -#define SCHEME_MODIDXP(l) SAME_TYPE(SCHEME_TYPE(l), scheme_module_index_type) -#define SCHEME_PHASEP(a) (SCHEME_INTP(a) || SCHEME_BIGNUMP(a) || SCHEME_FALSEP(a)) - -#define SCHEME_PHASE_SHIFTP(a) (SCHEME_PHASEP(a) || (SCHEME_BOXP(a) && SCHEME_PHASEP(SCHEME_BOX_VAL(a)))) -/* #f as a phase shift is an alias for (box 0) */ - -#define SCHEME_MULTI_SCOPEP(o) SCHEME_HASHTP(o) -#define SCHEME_SCOPEP(x) (SAME_TYPE(SCHEME_TYPE(x), scheme_scope_type)) - -#define SCHEME_TL_MULTI_SCOPEP(o) (MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)o)->iso)) & 0x2) - -/* A hash tabel for a multi scope has meta information mapped from void: */ -#define MULTI_SCOPE_METAP(v) SCHEME_VOIDP(v) -#define MULTI_SCOPE_META_HASHEDP(v) SCHEME_MPAIRP(v) - -/* Represent fallback as vectors, either of size 2 (for normal scope - sets) or size 4 (for sets of propagation instructions, because adding - a fallback layer is an action): */ -#define SCHEME_FALLBACKP(o) SCHEME_VECTORP(o) -#define SCHEME_FALLBACK_QUADP(o) (SCHEME_VEC_SIZE(o) == 4) -#define SCHEME_FALLBACK_FIRST(o) (SCHEME_VEC_ELS(o)[0]) -#define SCHEME_FALLBACK_REST(o) (SCHEME_VEC_ELS(o)[1]) -#define SCHEME_FALLBACK_SCOPE(o) (SCHEME_VEC_ELS(o)[2]) -#define SCHEME_FALLBACK_PHASE(o) (SCHEME_VEC_ELS(o)[3]) - -/* Bindings of the form "everything from module" */ -#define PES_UNMARSHAL_DESCP(v) (SCHEME_VEC_SIZE(v) == 4) -#define PES_BINDINGP(v) (SCHEME_VEC_SIZE(v) == 5) XFORM_NONGCING static int prefab_p(Scheme_Object *o) { @@ -262,44 +77,17 @@ XFORM_NONGCING static int prefab_p(Scheme_Object *o) #define STX_KEY(stx) MZ_OPT_HASH_KEY(&(stx)->iso) #define MUTATE_STX_OBJ 1 -#define MUTATE_STX_SCOPE_TABLE 2 -#define MUTATE_STX_PROP_TABLE 4 - -#if 0 -int stx_alloc_obj, stx_skip_alloc_obj; -int stx_alloc_scope_table, stx_skip_alloc_scope_table; -int stx_alloc_prop_table, stx_skip_alloc_prop_table; -# define COUNT_MUTATE_ALLOCS(x) x -#else -# define COUNT_MUTATE_ALLOCS(x) /* empty */ -#endif - -/* A `taints' field is one of - - NULL => clean - - #t => tainted, and taint propagated to children, if any) - - (void) => tainted, and taint needs to be propagated to children - - => clean, but inspector needs to be proagated to children - - (list ...+) [interned] => armed; first inspector is to propagate */ #define STX_ASSERT(x) MZ_ASSERT(x) -static Scheme_Object *make_vector3(Scheme_Object *a, Scheme_Object *b, Scheme_Object *c) -{ - Scheme_Object *vec; - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = a; - SCHEME_VEC_ELS(vec)[1] = b; - SCHEME_VEC_ELS(vec)[2] = c; - - return vec; -} +#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) +#define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj)))) /*========================================================================*/ /* initialization */ /*========================================================================*/ -void scheme_init_stx(Scheme_Env *env) +void scheme_init_stx(Scheme_Startup_Env *env) { Scheme_Object *o; @@ -308,115 +96,32 @@ void scheme_init_stx(Scheme_Env *env) #endif REGISTER_SO(empty_hash_tree); - REGISTER_SO(empty_scope_table); - REGISTER_SO(empty_propagate_table); - REGISTER_SO(empty_scope_set); - empty_hash_tree = scheme_make_hash_tree(SCHEME_hashtr_eq); - empty_scope_set = (Scheme_Scope_Set *)scheme_make_hash_tree(SCHEME_hashtr_eq); - empty_scope_table = MALLOC_ONE_TAGGED(Scheme_Scope_Table); - empty_scope_table->so.type = scheme_scope_table_type; - empty_scope_table->simple_scopes = empty_scope_set; - empty_scope_table->multi_scopes = scheme_null; - empty_propagate_table = (Scheme_Scope_Table *)MALLOC_ONE_TAGGED(Scheme_Propagate_Table); - memcpy(empty_propagate_table, empty_scope_table, sizeof(Scheme_Scope_Table)); - empty_propagate_table->simple_scopes = (Scheme_Scope_Set *)empty_hash_tree; - empty_propagate_table->so.type = scheme_propagate_table_type; - ((Scheme_Propagate_Table *)empty_propagate_table)->phase_shift = scheme_make_integer(0); - ((Scheme_Propagate_Table *)empty_propagate_table)->prev = NULL; + empty_hash_tree = scheme_make_hash_tree(0); REGISTER_SO(scheme_syntax_p_proc); o = scheme_make_folding_prim(syntax_p, "syntax?", 1, 1, 1); scheme_syntax_p_proc = o; SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); - scheme_add_global_constant("syntax?", o, env); + scheme_addto_prim_instance("syntax?", o, env); - GLOBAL_FOLDING_PRIM("syntax->datum", syntax_to_datum, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("datum->syntax", datum_to_syntax, 2, 5, env); + ADD_FOLDING_PRIM("syntax->datum", syntax_to_datum, 1, 1, 1, env); + ADD_IMMED_PRIM("datum->syntax", datum_to_syntax, 2, 5, env); - GLOBAL_FOLDING_PRIM_UNARY_INLINED("syntax-e", scheme_checked_syntax_e, 1, 1, 1, env); + o = scheme_make_folding_prim(scheme_checked_syntax_e, "syntax-e", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED); + scheme_addto_prim_instance("syntax-e", o, env); - GLOBAL_FOLDING_PRIM("syntax-line" , syntax_line , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-column" , syntax_col , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-position", syntax_pos , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-span" , syntax_span , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-source" , syntax_src , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax->list" , syntax_to_list, 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-line" , syntax_line , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-column" , syntax_col , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-position", syntax_pos , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-span" , syntax_span , 1, 1, 1, env); + ADD_FOLDING_PRIM("syntax-source" , syntax_src , 1, 1, 1, env); - GLOBAL_IMMED_PRIM("syntax-original?" , syntax_original_p , 1, 1, env); - GLOBAL_IMMED_PRIM("syntax-property" , syntax_property , 2, 4, env); - GLOBAL_IMMED_PRIM("syntax-property-preserved?" , syntax_property_preserved_p, 2, 2, env); - GLOBAL_IMMED_PRIM("syntax-property-symbol-keys" , syntax_property_keys , 1, 1, env); - - GLOBAL_IMMED_PRIM("syntax-track-origin" , syntax_track_origin , 3, 3, env); - - GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env); - GLOBAL_IMMED_PRIM("syntax-shift-phase-level" , syntax_shift_phase , 2, 2, env); - - GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 4, env); - GLOBAL_IMMED_PRIM("free-identifier=?" , free_eq , 2, 4, env); - GLOBAL_IMMED_PRIM("free-transformer-identifier=?" , free_trans_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-template-identifier=?" , free_templ_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-label-identifier=?" , free_label_eq , 2, 2, env); - - GLOBAL_IMMED_PRIM("identifier-binding" , free_binding , 1, 3, env); - GLOBAL_IMMED_PRIM("identifier-transformer-binding" , free_trans_binding , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-template-binding" , free_templ_binding , 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-label-binding" , free_label_binding , 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env); - - GLOBAL_IMMED_PRIM("identifier-binding-symbol" , free_binding_symbol , 1, 2, env); - - GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env); - - GLOBAL_FOLDING_PRIM("syntax-tainted?", syntax_tainted_p, 1, 1, 1, env); - GLOBAL_IMMED_PRIM("syntax-arm" , syntax_arm , 1, 3, env); - GLOBAL_IMMED_PRIM("syntax-disarm" , syntax_disarm , 2, 2, env); - GLOBAL_IMMED_PRIM("syntax-rearm" , syntax_rearm , 2, 3, env); - GLOBAL_IMMED_PRIM("syntax-taint" , syntax_taint , 1, 1, env); - - GLOBAL_IMMED_PRIM("syntax-debug-info" , syntax_debug_info , 1, 3, env); + ADD_IMMED_PRIM("syntax-property" , syntax_property , 2, 3, env); + ADD_IMMED_PRIM("syntax-property-symbol-keys" , syntax_property_keys , 1, 1, env); REGISTER_SO(source_symbol); - REGISTER_SO(share_symbol); - REGISTER_SO(origin_symbol); - REGISTER_SO(lexical_symbol); - REGISTER_SO(protected_symbol); - REGISTER_SO(nominal_id_symbol); source_symbol = scheme_make_symbol("source"); /* not interned! */ - share_symbol = scheme_make_symbol("share"); /* not interned! */ - origin_symbol = scheme_intern_symbol("origin"); - lexical_symbol = scheme_intern_symbol("lexical"); - protected_symbol = scheme_intern_symbol("protected"); - nominal_id_symbol = scheme_intern_symbol("nominal-id"); - - REGISTER_SO(module_symbol); - REGISTER_SO(top_symbol); - REGISTER_SO(macro_symbol); - REGISTER_SO(local_symbol); - REGISTER_SO(intdef_symbol); - REGISTER_SO(use_site_symbol); - module_symbol = scheme_intern_symbol("module"); - top_symbol = scheme_intern_symbol("top"); - macro_symbol = scheme_intern_symbol("macro"); - local_symbol = scheme_intern_symbol("local"); - intdef_symbol = scheme_intern_symbol("intdef"); - use_site_symbol = scheme_intern_symbol("use-site"); - - REGISTER_SO(name_symbol); - REGISTER_SO(context_symbol); - REGISTER_SO(bindings_symbol); - REGISTER_SO(matchp_symbol); - REGISTER_SO(cycle_symbol); - REGISTER_SO(free_symbol); - REGISTER_SO(fallbacks_symbol); - name_symbol = scheme_intern_symbol("name"); - context_symbol = scheme_intern_symbol("context"); - bindings_symbol = scheme_intern_symbol("bindings"); - matchp_symbol = scheme_intern_symbol("match?"); - cycle_symbol = scheme_intern_symbol("cycle"); - free_symbol = scheme_intern_symbol("free-identifier=?"); - fallbacks_symbol = scheme_intern_symbol("fallbacks"); REGISTER_SO(empty_srcloc); empty_srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); @@ -428,17 +133,14 @@ void scheme_init_stx(Scheme_Env *env) empty_srcloc->col = -1; empty_srcloc->pos = -1; - REGISTER_SO(root_scope); - root_scope = scheme_new_scope(SCHEME_STX_MODULE_SCOPE); - REGISTER_SO(scheme_paren_shape_symbol); scheme_paren_shape_symbol = scheme_intern_symbol("paren-shape"); REGISTER_SO(scheme_paren_shape_preserve_square); - scheme_paren_shape_preserve_square = make_preserved_property_value(scheme_make_ascii_character('[')); + scheme_paren_shape_preserve_square = scheme_make_ascii_character('['); REGISTER_SO(scheme_paren_shape_preserve_curly); - scheme_paren_shape_preserve_curly = make_preserved_property_value(scheme_make_ascii_character('{')); + scheme_paren_shape_preserve_curly = scheme_make_ascii_character('{'); REGISTER_SO(scheme_source_stx_props); REGISTER_SO(square_stx_props); @@ -449,10 +151,6 @@ void scheme_init_stx(Scheme_Env *env) } void scheme_init_stx_places(int initial_main_os_thread) { - REGISTER_SO(taint_intern_table); - taint_intern_table = scheme_make_weak_equal_table(); - - init_binding_cache(); } /*========================================================================*/ @@ -466,13 +164,9 @@ Scheme_Object *scheme_make_stx(Scheme_Object *val, Scheme_Stx *stx; stx = MALLOC_ONE_TAGGED(Scheme_Stx); - stx->iso.so.type = scheme_stx_type; - STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0; + stx->so.type = scheme_stx_type; stx->val = val; stx->srcloc = srcloc; - stx->scopes = empty_scope_table; - stx->u.to_propagate = NULL; - stx->shifts = scheme_null; stx->props = props; return (Scheme_Object *)stx; @@ -482,41 +176,18 @@ Scheme_Object *clone_stx(Scheme_Object *to, GC_CAN_IGNORE int *mutate) /* the `mutate` argument tracks whether we can mutate `to` */ { Scheme_Stx *stx = (Scheme_Stx *)to; - Scheme_Object *taints, *shifts; - Scheme_Scope_Table *scopes; - Scheme_Scope_Table *to_propagate; - int armed; STX_ASSERT(SCHEME_STXP(to)); - if (mutate && (*mutate & MUTATE_STX_OBJ)) { - COUNT_MUTATE_ALLOCS(stx_skip_alloc_obj++); + if (mutate && (*mutate & MUTATE_STX_OBJ)) return to; - } - taints = stx->taints; - scopes = stx->scopes; - shifts = stx->shifts; - to_propagate = stx->u.to_propagate; - armed = (STX_KEY(stx) & STX_ARMED_FLAG); - - stx = (Scheme_Stx *)scheme_make_stx(stx->val, + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->scopes = scopes; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - stx->u.to_propagate = to_propagate; - if (armed) - STX_KEY(stx) |= STX_ARMED_FLAG; - } - stx->taints = taints; - stx->shifts = shifts; - - if (mutate) { - COUNT_MUTATE_ALLOCS(stx_alloc_obj++); + if (mutate) *mutate |= MUTATE_STX_OBJ; - } return (Scheme_Object *)stx; } @@ -541,4685 +212,6 @@ Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, return scheme_make_stx(val, srcloc, props); } -static Scheme_Object *make_preserved_property_value(Scheme_Object *v) -{ - Scheme_Object *p; - - p = scheme_alloc_small_object(); - p->type = scheme_syntax_property_preserve_type; - SCHEME_PTR_VAL(p) = v; - - return p; -} - -static Scheme_Object *merge_property_value(Scheme_Object *e1, Scheme_Object *e2) -{ - int preserve = 0; - - if (SAME_TYPE(SCHEME_TYPE(e1), scheme_syntax_property_preserve_type)) { - preserve = 1; - e1 = SCHEME_PTR_VAL(e1); - } - if (SAME_TYPE(SCHEME_TYPE(e2), scheme_syntax_property_preserve_type)) { - preserve = 1; - e2 = SCHEME_PTR_VAL(e2); - } - - e1 = ICONS(e1, e2); - - if (preserve) - e1 = make_preserved_property_value(e1); - - return e1; -} - -Scheme_Object *scheme_stx_track(Scheme_Object *naya, - Scheme_Object *old, - Scheme_Object *origin) - /* Maintain properties for an expanded expression */ -{ - Scheme_Stx *nstx = (Scheme_Stx *)naya; - Scheme_Stx *ostx = (Scheme_Stx *)old; - Scheme_Hash_Tree *ne, *oe; - Scheme_Object *e1, *key, *val; - mzlonglong i; - - STX_ASSERT(!origin || SCHEME_STX_SYMBOLP(origin)); - - if (nstx->props) - ne = nstx->props; - else - ne = empty_hash_tree; - - if (ostx->props) { - if (SAME_OBJ(ostx->props, STX_SRCTAG)) { - /* Drop 'source; will add 'origin. */ - oe = empty_hash_tree; - } else { - oe = ostx->props; - - /* Drop 'source and 'share; will add 'origin */ - oe = scheme_hash_tree_set(oe, source_symbol, NULL); - oe = scheme_hash_tree_set(oe, share_symbol, NULL); - } - } else { - /* Will add 'origin */ - oe = empty_hash_tree; - } - - e1 = scheme_hash_tree_get(oe, origin_symbol); - if (e1 && origin) - oe = scheme_hash_tree_set(oe, origin_symbol, merge_property_value(origin, e1)); - else if (origin) - oe = scheme_hash_tree_set(oe, origin_symbol, ICONS(origin, scheme_null)); - - /* Merge ne and oe */ - - if (SAME_OBJ(ne, empty_hash_tree)) - ne = oe; - else if (ne->count < oe->count) { - i = scheme_hash_tree_next(ne, -1); - while (i != -1) { - scheme_hash_tree_index(ne, i, &key, &val); - e1 = scheme_hash_tree_get(oe, key); - if (e1) - oe = scheme_hash_tree_set(oe, key, merge_property_value(val, e1)); - else - oe = scheme_hash_tree_set(oe, key, val); - i = scheme_hash_tree_next(ne, i); - } - ne = oe; - } else { - i = scheme_hash_tree_next(oe, -1); - while (i != -1) { - scheme_hash_tree_index(oe, i, &key, &val); - e1 = scheme_hash_tree_get(ne, key); - if (e1) - ne = scheme_hash_tree_set(ne, key, merge_property_value(e1, val)); - else - ne = scheme_hash_tree_set(ne, key, val); - i = scheme_hash_tree_next(oe, i); - } - } - - /* Clone nstx, keeping wraps, changing props to ne */ - nstx = (Scheme_Stx *)clone_stx((Scheme_Object *)nstx, NULL); - nstx->props = ne; - - return (Scheme_Object *)nstx; -} - -void scheme_stx_set(Scheme_Object *q_stx, Scheme_Object *val, Scheme_Object *context) -{ - clear_binding_cache_stx((Scheme_Stx *)q_stx); - - ((Scheme_Stx *)q_stx)->val = val; - - if (context) { - ((Scheme_Stx *)q_stx)->scopes = ((Scheme_Stx *)context)->scopes; - ((Scheme_Stx *)q_stx)->shifts = ((Scheme_Stx *)context)->shifts; - } else { - ((Scheme_Stx *)q_stx)->scopes = NULL; - ((Scheme_Stx *)q_stx)->shifts = NULL; - } - - ((Scheme_Stx *)q_stx)->u.to_propagate = NULL; - ((Scheme_Stx *)q_stx)->taints = NULL; -} - -/******************** scopes ********************/ - -Scheme_Object *scheme_stx_root_scope() -{ - /* The root scope is an all-phases scope used by all top-level namespaces - (and not by module namespaces): */ - return root_scope; -} - -Scheme_Object *scheme_new_scope(int kind) -{ - mzlonglong id; - Scheme_Object *m; - - if (kind == SCHEME_STX_MODULE_MULTI_SCOPE) { - m = scheme_malloc_small_tagged(sizeof(Scheme_Scope_With_Owner)); - SCHEME_SCOPE_FLAGS((Scheme_Scope *)m) |= 0x1; - } else - m = scheme_malloc_small_tagged(sizeof(Scheme_Scope)); - - ((Scheme_Scope *)m)->iso.so.type = scheme_scope_type; - id = ((++scope_counter) << SCHEME_STX_SCOPE_KIND_SHIFT) | kind; - ((Scheme_Scope *)m)->id = id; - - return m; -} - -static Scheme_Object *new_multi_scope(Scheme_Object *debug_name) -/* a multi-scope is a set of phase-specific scopes that are - always added, removed, or flipped as a group */ -{ - Scheme_Hash_Table *multi_scope; - - /* Maps a phase to a scope, where each scope is created on demand: */ - multi_scope = scheme_make_hash_table(SCHEME_hash_ptr); - - if (SCHEME_FALSEP(debug_name)) - MZ_OPT_HASH_KEY(&(multi_scope->iso)) |= 0x2; - - if (SAME_TYPE(SCHEME_TYPE(debug_name), scheme_resolved_module_path_type)) - debug_name = scheme_resolved_module_path_value(debug_name); - if (SCHEME_FALSEP(debug_name)) - debug_name = scheme_gensym(top_symbol); - - scheme_hash_set(multi_scope, scheme_void, debug_name); - - return (Scheme_Object *)multi_scope; -} - -static void repair_scope_owner(Scheme_Object *m) -{ - Scheme_Object *multi_scope; - - /* The owner scope might be missing due to broken bytecode. For - non-broken bytecode, there shouldn't be a way to reach a - scope withough going through its owner. Work around the - broken scope object by creating a new owner. */ - - multi_scope = new_multi_scope(scheme_false); - scheme_hash_set((Scheme_Hash_Table *)multi_scope, scheme_make_integer(0), m); - ((Scheme_Scope_With_Owner *)m)->owner_multi_scope = multi_scope; -} - -Scheme_Object *scheme_scope_printed_form(Scheme_Object *m) -{ - int kind = ((Scheme_Scope *)m)->id & SCHEME_STX_SCOPE_KIND_MASK; - Scheme_Object *num, *kind_sym, *vec, *name; - - num = scheme_make_integer_value_from_long_long(((Scheme_Scope *)m)->id >> SCHEME_STX_SCOPE_KIND_SHIFT); - - switch (kind) { - case SCHEME_STX_MODULE_SCOPE: - case SCHEME_STX_MODULE_MULTI_SCOPE: - if (SAME_OBJ(m, root_scope)) - kind_sym = top_symbol; - else - kind_sym = module_symbol; - break; - case SCHEME_STX_MACRO_SCOPE: - kind_sym = macro_symbol; - break; - case SCHEME_STX_LOCAL_BIND_SCOPE: - kind_sym = local_symbol; - break; - case SCHEME_STX_INTDEF_SCOPE: - kind_sym = intdef_symbol; - break; - case SCHEME_STX_USE_SITE_SCOPE: - kind_sym = use_site_symbol; - break; - default: - kind_sym = scheme_false; - break; - } - - if (SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)m)) { - Scheme_Object *multi_scope = ((Scheme_Scope_With_Owner *)m)->owner_multi_scope; - if (multi_scope) { - name = scheme_eq_hash_get((Scheme_Hash_Table *)multi_scope, scheme_void); - if (!name) name = scheme_false; - if (MULTI_SCOPE_META_HASHEDP(name)) name = SCHEME_CAR(name); - - if (SCHEME_TL_MULTI_SCOPEP(multi_scope)) - kind_sym = top_symbol; - - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[2] = name; - SCHEME_VEC_ELS(vec)[3] = ((Scheme_Scope_With_Owner *)m)->phase; - } else { - /* owner is either missing (bad bytecode) or hasn't been loaded on demand */ - vec = scheme_make_vector(2, NULL); - } - } else { - vec = scheme_make_vector(2, NULL); - } - - SCHEME_VEC_ELS(vec)[0] = num; - SCHEME_VEC_ELS(vec)[1] = kind_sym; - - return vec; -} - -#define SCHEME_SCOPE_SETP(m) SCHEME_HASHTRP((Scheme_Object *)(m)) - -XFORM_NONGCING static intptr_t scope_set_count(Scheme_Scope_Set *s) -{ - return ((Scheme_Hash_Tree *)s)->count; -} - -XFORM_NONGCING static Scheme_Object *scope_set_get(Scheme_Scope_Set *s, Scheme_Object *key) -{ - return scheme_eq_hash_tree_get((Scheme_Hash_Tree *)s, key); -} - -static Scheme_Scope_Set *scope_set_set(Scheme_Scope_Set *s, Scheme_Object *key, Scheme_Object *val) -{ - return (Scheme_Scope_Set *)scheme_hash_tree_set((Scheme_Hash_Tree *)s, key, val); -} - -XFORM_NONGCING static mzlonglong scope_set_next(Scheme_Scope_Set *s, mzlonglong pos) -{ - return scheme_hash_tree_next((Scheme_Hash_Tree *)s, pos); -} - -XFORM_NONGCING static int scope_set_index(Scheme_Scope_Set *s, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val) -{ - return scheme_hash_tree_index((Scheme_Hash_Tree *)s, pos, _key, _val); -} - -XFORM_NONGCING static int scope_subset(Scheme_Scope_Set *sa, Scheme_Scope_Set *sb) -{ - return scheme_eq_hash_tree_subset_of((Scheme_Hash_Tree *)sa, - (Scheme_Hash_Tree *)sb); -} - -static int scopes_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b) -{ - return (scope_set_count(a) == scope_set_count(b)) && scope_subset(a, b); -} - -XFORM_NONGCING static int scope_props_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b) -{ - return ((scope_set_count(a) == scope_set_count(b)) - && scheme_eq_hash_tree_subset_match_of((Scheme_Hash_Tree *)a, - (Scheme_Hash_Tree *)b)); -} - -static Scheme_Object *make_fallback_pair(Scheme_Object *a, Scheme_Object *b) -{ - a = scheme_make_vector(2, a); - SCHEME_VEC_ELS(a)[1] = b; - return a; -} - -static Scheme_Object *make_fallback_quad(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *c, Scheme_Object *d) -{ - a = scheme_make_vector(4, a); - SCHEME_VEC_ELS(a)[1] = b; - SCHEME_VEC_ELS(a)[2] = c; - SCHEME_VEC_ELS(a)[3] = d; - return a; -} - -Scheme_Object *extract_simple_scope(Scheme_Object *multi_scope, Scheme_Object *phase) -{ - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)multi_scope; - Scheme_Object *m; - - if (SCHEME_TRUEP(phase) && !SCHEME_INTP(phase)) { - /* make sure phases are interned (in case of a bignum phase, which should be very rare): */ - phase = scheme_intern_literal_number(phase); - } - - m = scheme_eq_hash_get(ht, phase); - if (!m) { - m = scheme_new_scope(SCHEME_STX_MODULE_MULTI_SCOPE); - ((Scheme_Scope_With_Owner *)m)->owner_multi_scope = (Scheme_Object *)ht; - ((Scheme_Scope_With_Owner *)m)->phase = phase; - scheme_hash_set(ht, phase, m); - - if (SCHEME_MPAIRP(scheme_hash_get(ht, scheme_void))) { - /* pair indicates loading from bytecode; - zero out id, so that ordering is based on the owner plus the phase; - this approach helps ensure determinstic ordering independent of - the time at which simple scopes are generated */ - ((Scheme_Scope *)m)->id &= SCHEME_STX_SCOPE_KIND_MASK; - } - } - - return m; -} - -static Scheme_Object *extract_simple_scope_from_shifted(Scheme_Object *multi_scope_and_phase, Scheme_Object *phase) -{ - Scheme_Object *ph; - - ph = SCHEME_CDR(multi_scope_and_phase); - if (SCHEME_FALSEP(phase)) { - if (!SCHEME_BOXP(ph)) { - /* number phase shift, so look for #f */ - ph = scheme_false; - } else { - /* phase shift of some to #f, so look for */ - ph = SCHEME_BOX_VAL(ph); - } - } else if (SCHEME_BOXP(ph)) { - /* we want a number phase, but this is shifted to #f */ - return NULL; - } else - ph = scheme_bin_minus(phase, ph); - - return extract_simple_scope(SCHEME_CAR(multi_scope_and_phase), ph); -} - -static Scheme_Scope_Set *extract_scope_set_from_scope_list(Scheme_Scope_Set *scopes, - Scheme_Object *multi_scopes, - Scheme_Object *phase) -{ - Scheme_Object *m; - - /* Combine scopes that exist at all phases with a specific scope for - each set of phase-specific scopes */ - - if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_FIRST(multi_scopes); - - for (; !SCHEME_NULLP(multi_scopes); multi_scopes= SCHEME_CDR(multi_scopes)) { - m = extract_simple_scope_from_shifted(SCHEME_CAR(multi_scopes), phase); - if (m) - scopes = scope_set_set(scopes, m, scheme_true); - } - - return scopes; -} - -static Scheme_Scope_Set *extract_scope_set(Scheme_Stx *stx, Scheme_Object *phase) -{ - Scheme_Scope_Table *st = stx->scopes; - return extract_scope_set_from_scope_list(st->simple_scopes, st->multi_scopes, phase); -} - -static Scheme_Scope_Set *adjust_scope(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode) -/* operate on a single scope within a set */ -{ - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(m), scheme_scope_type)); - - if (scope_set_get(scopes, m)) { - if ((mode == SCHEME_STX_FLIP) || (mode == SCHEME_STX_REMOVE)) - return scope_set_set(scopes, m, NULL); - else - return scopes; - } else { - if (mode == SCHEME_STX_REMOVE) - return scopes; - else - return scope_set_set(scopes, m, scheme_true); - } -} - -Scheme_Object *adjust_scope_list(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode) -/* operate on a set of phase-specific scopes within a set */ -{ - Scheme_Object *l; - - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (SAME_OBJ(m, SCHEME_CAR(SCHEME_CAR(l))) - && SAME_OBJ(phase, SCHEME_CDR(SCHEME_CAR(l)))) { - if ((mode == SCHEME_STX_ADD) || (mode == SCHEME_STX_PUSH)) - return multi_scopes; - break; - } - } - - if (mode == SCHEME_STX_PUSH) { - if (!SCHEME_NULLP(multi_scopes)) - return make_fallback_pair(scheme_make_pair(scheme_make_pair(m, phase), - (SCHEME_FALLBACKP(multi_scopes) - ? SCHEME_FALLBACK_FIRST(multi_scopes) - : multi_scopes)), - multi_scopes); - } - - if ((mode == SCHEME_STX_REMOVE) && SCHEME_NULLP(l)) - return multi_scopes; - else if ((mode == SCHEME_STX_REMOVE) - || ((mode == SCHEME_STX_FLIP && !SCHEME_NULLP(l)))) { - return remove_at_scope_list(multi_scopes, l); - } else - return add_to_scope_list(scheme_make_pair(m, phase), multi_scopes); -} - -static Scheme_Scope_Set *combine_scope(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode) -/* operate on a single scope within a set of propagation instructions */ -{ - Scheme_Object *old_mode; - - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(m), scheme_scope_type)); - - old_mode = scope_set_get(scopes, m); - - if (old_mode) { - if (SCHEME_INT_VAL(old_mode) == mode) { - if (mode == SCHEME_STX_FLIP) - return scope_set_set(scopes, m, NULL); - else - return scopes; - } else if (mode == SCHEME_STX_FLIP) { - mode = SCHEME_INT_VAL(old_mode); - mode = ((mode == SCHEME_STX_REMOVE) ? SCHEME_STX_ADD : SCHEME_STX_REMOVE); - return scope_set_set(scopes, m, scheme_make_integer(mode)); - } else - return scope_set_set(scopes, m, scheme_make_integer(mode)); - } else - return scope_set_set(scopes, m, scheme_make_integer(mode)); -} - -Scheme_Object *combine_scope_list(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode) -/* operate on a set of phase-specific scopes within a set of propagation instructions */ -{ - Scheme_Object *l; - - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) { - if ((mode == SCHEME_STX_PUSH) - && SAME_OBJ(SCHEME_FALLBACK_SCOPE(l), m) - && SAME_OBJ(SCHEME_FALLBACK_PHASE(l), phase)) - return multi_scopes; - l = SCHEME_FALLBACK_FIRST(l); - } - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (SAME_OBJ(m, SCHEME_VEC_ELS(SCHEME_CAR(l))[0]) - && SAME_OBJ(phase, SCHEME_VEC_ELS(SCHEME_CAR(l))[1])) { - int prev_mode = SCHEME_INT_VAL(SCHEME_VEC_ELS(SCHEME_CAR(l))[2]); - if (mode == SCHEME_STX_PUSH) { - if (prev_mode == SCHEME_STX_ADD) - return multi_scopes; - break; - } else if (mode == SCHEME_STX_FLIP) { - if (prev_mode == SCHEME_STX_FLIP) - return remove_at_scope_list(multi_scopes, l); - else { - if (prev_mode == SCHEME_STX_ADD) - mode = SCHEME_STX_REMOVE; - else - mode = SCHEME_STX_ADD; - multi_scopes = remove_at_scope_list(multi_scopes, l); - break; - } - } else if (mode != prev_mode) { - multi_scopes = remove_at_scope_list(multi_scopes, l); - break; - } else - return multi_scopes; - } - } - - if (mode == SCHEME_STX_PUSH) - return make_fallback_quad(scheme_null, multi_scopes, m, phase); - else - return add_to_scope_list(make_vector3(m, phase, scheme_make_integer(mode)), - multi_scopes); -} - -static Scheme_Object *reconstruct_fallback(Scheme_Object *fb, Scheme_Object *r) -/* update actions for first (maybe only) in fallback chain */ -{ - if (fb) { - if (SCHEME_FALLBACK_QUADP(fb)) - return make_fallback_quad(r, - SCHEME_FALLBACK_REST(fb), - SCHEME_FALLBACK_SCOPE(fb), - SCHEME_FALLBACK_PHASE(fb)); - else - return make_fallback_pair(r, SCHEME_FALLBACK_REST(fb)); - } else - return r; -} - -static Scheme_Object *clone_fallback_chain(Scheme_Object *fb) -{ - Scheme_Object *first = NULL, *last = NULL, *p; - - while (SCHEME_FALLBACKP(fb)) { - p = reconstruct_fallback(fb, SCHEME_FALLBACK_FIRST(fb)); - if (last) - SCHEME_FALLBACK_REST(last) = p; - else - first = p; - last = p; - fb = SCHEME_FALLBACK_REST(fb); - } - - return first; -} - -static Scheme_Object *remove_at_scope_list(Scheme_Object *l, Scheme_Object *p) -/* remove element at `p` within `l` */ -{ - Scheme_Object *fb; - Scheme_Object *r = SCHEME_CDR(p); - - if (SCHEME_FALLBACKP(l)) { - fb = l; - l = SCHEME_FALLBACK_FIRST(fb); - } else - fb = NULL; - - while (!SAME_OBJ(l, p)) { - r = scheme_make_pair(SCHEME_CAR(l), r); - l = SCHEME_CDR(l); - } - - return reconstruct_fallback(fb, r); -} - -static Scheme_Object *add_to_scope_list(Scheme_Object *p, Scheme_Object *l) -{ - if (SCHEME_FALLBACKP(l)) - return reconstruct_fallback(l, scheme_make_pair(p, SCHEME_FALLBACK_FIRST(l))); - else - return scheme_make_pair(p, l); -} - -static Scheme_Scope_Table *clone_scope_table(Scheme_Scope_Table *st, Scheme_Scope_Table *prev, - GC_CAN_IGNORE int *mutate) -/* If prev is non-NULL, then `st` is a propagate table */ -{ - Scheme_Scope_Table *st2; - - if (!prev) { - if (*mutate & MUTATE_STX_SCOPE_TABLE) { - st2 = st; - COUNT_MUTATE_ALLOCS(stx_skip_alloc_scope_table++); - } else { - st2 = MALLOC_ONE_TAGGED(Scheme_Scope_Table); - memcpy(st2, st, sizeof(Scheme_Scope_Table)); - *mutate |= MUTATE_STX_SCOPE_TABLE; - COUNT_MUTATE_ALLOCS(stx_alloc_scope_table++); - } - } else { - if (*mutate & MUTATE_STX_PROP_TABLE) { - st2 = st; - COUNT_MUTATE_ALLOCS(stx_skip_alloc_prop_table++); - } else { - st2 = (Scheme_Scope_Table *)MALLOC_ONE_TAGGED(Scheme_Propagate_Table); - memcpy(st2, st, sizeof(Scheme_Propagate_Table)); - if (SAME_OBJ(st, empty_propagate_table)) - ((Scheme_Propagate_Table *)st2)->prev = prev; - *mutate |= MUTATE_STX_PROP_TABLE; - COUNT_MUTATE_ALLOCS(stx_alloc_prop_table++); - } - } - - return st2; -} - -typedef Scheme_Scope_Set *(*do_scope_t)(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode); -typedef Scheme_Object *(do_scope_list_t)(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode); - -static Scheme_Scope_Table *do_scope_at_phase(Scheme_Scope_Table *st, Scheme_Object *m, Scheme_Object *phase, int mode, - do_scope_t do_scope, do_scope_list_t do_scope_list, Scheme_Scope_Table *prev, - GC_CAN_IGNORE int *mutate) -/* operate on a scope or set of phase specific scopes, - either on a scope set or a set of propagation instructions */ -{ - Scheme_Object *l; - Scheme_Scope_Set *scopes; - - if (SCHEME_SCOPEP(m) && SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)m)) { - if (!SCHEME_FALSEP(phase)) - phase = scheme_bin_minus(phase, ((Scheme_Scope_With_Owner *)m)->phase); - if (!((Scheme_Scope_With_Owner *)m)->owner_multi_scope) - repair_scope_owner(m); - m = ((Scheme_Scope_With_Owner *)m)->owner_multi_scope; - } - - if (SCHEME_MULTI_SCOPEP(m)) { - l = do_scope_list(st->multi_scopes, m, phase, mode); - if (SAME_OBJ(l, st->multi_scopes)) - return st; - st = clone_scope_table(st, prev, mutate); - st->multi_scopes = l; - return st; - } else { - scopes = do_scope(st->simple_scopes, m, mode); - if (SAME_OBJ(scopes, st->simple_scopes)) - return st; - st = clone_scope_table(st, prev, mutate); - st->simple_scopes = scopes; - return st; - } -} - -static Scheme_Object *stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Scope_Table *scopes; - Scheme_Scope_Table *to_propagate; - Scheme_Object *taints, *shifts; - - STX_ASSERT(SCHEME_STXP(o)); - - if (mode & SCHEME_STX_PROPONLY) { - scopes = stx->scopes; - mode -= SCHEME_STX_PROPONLY; - } else { - scopes = do_scope_at_phase(stx->scopes, m, phase, mode, adjust_scope, adjust_scope_list, NULL, mutate); - if ((stx->scopes == scopes) - && !(STX_KEY(stx) & STX_SUBSTX_FLAG)) { - return (Scheme_Object *)stx; - } - } - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - to_propagate = (stx->u.to_propagate ? stx->u.to_propagate : empty_propagate_table); - to_propagate = do_scope_at_phase(to_propagate, m, phase, mode, combine_scope, combine_scope_list, stx->scopes, mutate); - if ((stx->u.to_propagate == to_propagate) - && (stx->scopes == scopes)) - return (Scheme_Object *)stx; - } else - to_propagate = NULL; /* => clear cache */ - - if (*mutate & MUTATE_STX_OBJ) { - stx->scopes = scopes; - stx->u.to_propagate = to_propagate; - } else { - int armed = (STX_KEY(stx) & STX_ARMED_FLAG); - taints = stx->taints; - shifts = stx->shifts; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->scopes = scopes; - stx->u.to_propagate = to_propagate; - stx->taints = taints; - stx->shifts = shifts; - if (armed) - STX_KEY(stx) |= STX_ARMED_FLAG; - *mutate |= MUTATE_STX_OBJ; - } - - return (Scheme_Object *)stx; -} - -Scheme_Object *scheme_stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode) -{ - int mutate = 0; - return stx_adjust_scope(o, m, phase, mode, &mutate); -} - -Scheme_Object *scheme_stx_add_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) -{ - return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_ADD); -} - -Scheme_Object *scheme_stx_remove_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) -{ - return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_REMOVE); -} - -Scheme_Object *scheme_stx_flip_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) -{ - return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_FLIP); -} - -static Scheme_Object *stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Object *key, *val; - intptr_t i; - - STX_ASSERT(SCHEME_STXP(o)); - STX_ASSERT(SCHEME_SCOPE_SETP(scopes)); - - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - - o = stx_adjust_scope(o, key, phase, mode, mutate); - - i = scope_set_next(scopes, i); - } - - return o; -} - -Scheme_Object *scheme_stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode) -{ - int mutate = 0; - return stx_adjust_scopes(o, scopes, phase, mode, &mutate); -} - -/* For each environment frame, we need to keep track of various sets of scopes: - - bind scopes (normally 0 or 1) are created for the binding context - - use-site scopes are created for macro expansions that need them - - intdef scopes are for immediately nested internal-definition contexts; - they're treated the same as bind scopes - - frame-scopes = main-scopes - . | (vector bind-scopes use-site-scopes intdef-scopes) - bind-scopes = some-scopes - use-site-scopes = some-scopes - intdef-scopes = some-scopes - some-scopes = #f | scope | scope-set */ - -static Scheme_Object *stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, int which, Scheme_Object *phase, int mode) -{ - if (SCHEME_VECTORP(scope)) { - scope = SCHEME_VEC_ELS(scope)[which]; - } else if (which != 0) - return o; - - if (SCHEME_FALSEP(scope)) - return o; - else if (SCHEME_SCOPEP(scope)) - return scheme_stx_adjust_scope(o, scope, phase, mode); - else { - STX_ASSERT(SCHEME_SCOPE_SETP(scope)); - return scheme_stx_adjust_scopes(o, (Scheme_Scope_Set *)scope, phase, mode); - } -} - -Scheme_Object *scheme_stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) -{ - o = scheme_stx_adjust_frame_use_site_scopes(o, scope, phase, mode); - o = scheme_stx_adjust_frame_bind_scopes(o, scope, phase, mode); - return stx_adjust_frame_scopes(o, scope, 2, phase, mode); -} - -Scheme_Object *scheme_stx_adjust_frame_bind_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) -{ - return stx_adjust_frame_scopes(o, scope, 0, phase, mode); -} - -Scheme_Object *scheme_stx_adjust_frame_use_site_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) -{ - return stx_adjust_frame_scopes(o, scope, 1, phase, mode); -} - -Scheme_Object *scheme_make_frame_scopes(Scheme_Object *scope) -{ - return scope; -} - -static Scheme_Object *add_frame_scope(Scheme_Object *frame_scopes, Scheme_Object *scope, int pos) -{ - Scheme_Object *scopes; - - if (!frame_scopes) { - if (pos == 0) - return scope; - else - frame_scopes = scheme_false; - } - - if (SCHEME_VECTORP(frame_scopes)) - scopes = SCHEME_VEC_ELS(frame_scopes)[pos]; - else if (pos == 0) - scopes = frame_scopes; - else - scopes = scheme_false; - - if (SCHEME_FALSEP(scopes)) - scopes = scope; - else { - STX_ASSERT(!SCHEME_MULTI_SCOPEP(scopes)); - if (SCHEME_SCOPEP(scopes)) - scopes = (Scheme_Object *)scope_set_set(empty_scope_set, scopes, scheme_true); - scopes = (Scheme_Object *)scope_set_set((Scheme_Scope_Set *)scopes, scope, scheme_true); - } - - if (SCHEME_VECTORP(frame_scopes)) - frame_scopes = make_vector3(SCHEME_VEC_ELS(frame_scopes)[0], - SCHEME_VEC_ELS(frame_scopes)[1], - SCHEME_VEC_ELS(frame_scopes)[2]); - else - frame_scopes = make_vector3(frame_scopes, scheme_false, scheme_false); - - SCHEME_VEC_ELS(frame_scopes)[pos] = scopes; - - return frame_scopes; -} - -Scheme_Object *scheme_add_frame_use_site_scope(Scheme_Object *frame_scopes, Scheme_Object *use_site_scope) -{ - return add_frame_scope(frame_scopes, use_site_scope, 1); -} - -Scheme_Object *scheme_add_frame_intdef_scope(Scheme_Object *frame_scopes, Scheme_Object *scope) -{ - return add_frame_scope(frame_scopes, scope, 2); -} - -static Scheme_Object *add_intdef_scopes_of(Scheme_Object *scopes, Scheme_Object *keep_intdef_scopes) -{ - if (SCHEME_VECTORP(keep_intdef_scopes) - && SCHEME_TRUEP(SCHEME_VEC_ELS(keep_intdef_scopes)[2])) { - if (scopes && SCHEME_VECTORP(scopes)) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(scopes)[2])) - scheme_signal_error("internal error: cannot currently merge intdef scopes"); - return make_vector3(SCHEME_VEC_ELS(scopes)[0], - SCHEME_VEC_ELS(scopes)[1], - SCHEME_VEC_ELS(keep_intdef_scopes)[2]); - } else - return make_vector3(scopes ? scopes : scheme_false, - scheme_false, - SCHEME_VEC_ELS(keep_intdef_scopes)[2]); - } - - return scopes; -} - -int scheme_stx_has_empty_wraps(Scheme_Object *stx, Scheme_Object *phase) -{ - return (scope_set_count(extract_scope_set((Scheme_Stx *)stx, phase)) == 0); -} - -/******************** shifts ********************/ - -/* Shifts includes both phase shifts (in the sense of - `syntax-shift-phase-level`) and shifting a module reference based - on one modix (at compile time, say) to a different one (at run - time, say). A modidx kind of shift can also include an inspector - substution (e.g., a load-time inspectr to take the place of the - compile-time one) and an export registry for restoring lazily load - bulk-import bindings (for when all exports of a module are - imported, and we go find the imported module on demand). */ - -XFORM_NONGCING static int same_phase(Scheme_Object *a, Scheme_Object *b) -{ - return ((SAME_OBJ(a, b) || scheme_eqv(a, b)) - ? 1 - : 0); -} - -static Scheme_Object *add_shifts(Scheme_Object *old_shift, Scheme_Object *shift) -/* The new `shift` is allowed to be #f, but `old_shift` and the result are - normalized to `(box 0)` */ -{ - if (SCHEME_BOXP(shift) && SCHEME_FALSEP(SCHEME_BOX_VAL(shift))) { - /* (box #f) is an impossible shift, so discard */ - return NULL; - } - - if ((SCHEME_FALSEP(shift) || SCHEME_BOXP(shift)) - && SCHEME_BOXP(old_shift)) { - /* shifting some numbered phase when already shifted to #f; discard */ - return NULL; - } - - if (SCHEME_BOXP(old_shift)) { - /* numbered shift on already shifted to #f => no change */ - return old_shift; - } - - if (SCHEME_FALSEP(shift)) { - /* shift of before shifting 0 to #f => shift - to #f */ - return scheme_box(scheme_bin_minus(scheme_make_integer(0), old_shift)); - } else if (SCHEME_BOXP(shift)) { - /* shift of before shifting to #f => shift - to #f */ - if (SAME_OBJ(old_shift, scheme_make_integer(0))) - return shift; - else - return scheme_box(scheme_bin_minus(SCHEME_BOX_VAL(shift), old_shift)); - } else - return scheme_bin_plus(old_shift, shift); -} - -static Scheme_Object *shift_multi_scope(Scheme_Object *p, Scheme_Object *shift) -/* shift all phase-specific scopes in a set */ -{ - shift = add_shifts(SCHEME_CDR(p), shift); - - if (!shift) - return NULL; - - if (SAME_OBJ(shift, SCHEME_CDR(p))) - return p; - - return scheme_make_pair(SCHEME_CAR(p), shift); -} - -static Scheme_Object *shift_prop_multi_scope(Scheme_Object *p, Scheme_Object *shift) - /* shift all phase-specific scopes in a set of propagation instructions */ -{ - Scheme_Object *p2; - - shift = add_shifts(SCHEME_VEC_ELS(p)[1], shift); - if (!shift) - return NULL; - - if (SAME_OBJ(shift, SCHEME_VEC_ELS(p)[1])) - return p; - - p2 = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(p2)[0] = SCHEME_VEC_ELS(p)[0]; - SCHEME_VEC_ELS(p2)[1] = shift; - SCHEME_VEC_ELS(p2)[2] = SCHEME_VEC_ELS(p)[2]; - - return p2; -} - -typedef Scheme_Object *(shift_multi_scope_t)(Scheme_Object *p, Scheme_Object *shift); - -static Scheme_Scope_Table *shift_scope_table(Scheme_Scope_Table *st, Scheme_Object *shift, - shift_multi_scope_t shift_mm, Scheme_Scope_Table *prev, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Scope_Table *st2; - Scheme_Object *l, *key, *val, *fbs; - - if (SAME_OBJ(st, empty_scope_table)) { - STX_ASSERT(!prev); - return st; - } - - if ((SCHEME_NULLP(st->multi_scopes) - || (SCHEME_FALLBACKP(st->multi_scopes) - && SCHEME_NULLP(SCHEME_FALLBACK_FIRST(st->multi_scopes)))) - && !prev) - return st; - - st2 = clone_scope_table(st, prev, mutate); - - l = st->multi_scopes; - if (SCHEME_FALLBACKP(l)) { - l = clone_fallback_chain(l); - st2->multi_scopes = l; - fbs = l; - } else - fbs = scheme_false; - /* loop to cover all fallbacks; fbs is #f for - no fallback handling, otherwise it's always - a fallback record and the updated list goes - in first or rest */ - while (1) { - int was_fb; - if (SCHEME_FALLBACKP(l)) { - l = SCHEME_FALLBACK_FIRST(l); - was_fb = 1; - } else - was_fb = 0; - - /* Loop through one list of multi scopes: */ - val = scheme_null; - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - key = shift_mm(SCHEME_CAR(l), shift); - if (key) - val = scheme_make_pair(key, val); - } - - if (SCHEME_FALLBACKP(fbs)) { - if (was_fb) { - SCHEME_FALLBACK_FIRST(fbs) = val; - l = SCHEME_FALLBACK_REST(fbs); - if (SCHEME_FALLBACKP(l)) - fbs = l; - } else { - SCHEME_FALLBACK_REST(fbs) = val; - break; - } - } else { - st2->multi_scopes = val; - break; - } - } - - if (prev) { - /* record accumulated shift for propagation */ - shift = add_shifts(((Scheme_Propagate_Table *)st)->phase_shift, shift); - if (!shift) - shift = scheme_box(scheme_false); /* i.e., the impossible shift */ - ((Scheme_Propagate_Table *)st2)->phase_shift = shift; - } - - return st2; -} - -static Scheme_Object *shift_scopes(Scheme_Object *o, Scheme_Object *shift, int prop_only, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Scope_Table *st, *p_st; - - if (prop_only) - st = stx->scopes; - else - st = shift_scope_table(stx->scopes, shift, shift_multi_scope, NULL, mutate); - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - p_st = shift_scope_table((stx->u.to_propagate ? stx->u.to_propagate : empty_propagate_table), - shift, shift_prop_multi_scope, stx->scopes, - mutate); - else - p_st = NULL; - - if (SAME_OBJ(stx->scopes, st) - && (!(STX_KEY(stx) & STX_SUBSTX_FLAG) - || SAME_OBJ(stx->u.to_propagate, p_st))) - return (Scheme_Object *)stx; - - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); - - stx->scopes = st; - if (p_st) - stx->u.to_propagate = p_st; - - return (Scheme_Object *)stx; -} - -static Scheme_Object *do_stx_add_shift(Scheme_Object *o, Scheme_Object *shift, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *vec, *shifts; - - if (!shift) return (Scheme_Object *)stx; - - if (SCHEME_PHASE_SHIFTP(shift)) { - if (SAME_OBJ(shift, scheme_make_integer(0))) - return (Scheme_Object *)stx; - return shift_scopes((Scheme_Object *)stx, shift, 0, mutate); - } - - if (SCHEME_VECTORP(shift) - && (SCHEME_VEC_SIZE(shift) == 6) - && (SCHEME_VEC_ELS(shift)[5] != scheme_make_integer(0))) { - /* Handle phase shift by itself, first: */ - stx = (Scheme_Stx *)do_stx_add_shift((Scheme_Object *)stx, SCHEME_VEC_ELS(shift)[5], mutate); - /* strip away phase shift: */ - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(shift)[0]; - SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(shift)[1]; - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(shift)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(shift)[3]; - SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(shift)[4]; - SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(0); - shift = vec; - } - - /* Drop useless shift (identidy modidx shift and no inspector or exports): */ - if (SAME_OBJ(SCHEME_VEC_ELS(shift)[0], SCHEME_VEC_ELS(shift)[1]) - && ((SCHEME_VEC_SIZE(shift) <= 3) - || SCHEME_FALSEP(SCHEME_VEC_ELS(shift)[3])) - && ((SCHEME_VEC_SIZE(shift) <= 4) - || SCHEME_FALSEP(SCHEME_VEC_ELS(shift)[4]))) - return (Scheme_Object *)stx; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - /* Keep track of shifts that need to be propagated */ - vec = scheme_make_vector(3, NULL); - if (SCHEME_VECTORP(stx->shifts)) { - shifts = scheme_make_pair(shift, SCHEME_VEC_ELS(stx->shifts)[1]); - SCHEME_VEC_ELS(vec)[1] = shifts; - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(stx->shifts)[2]; - shifts = SCHEME_VEC_ELS(stx->shifts)[0]; - } else { - shifts = scheme_make_pair(shift, scheme_null); - SCHEME_VEC_ELS(vec)[1] = shifts; - SCHEME_VEC_ELS(vec)[2] = stx->shifts; - shifts = stx->shifts; - } - shifts = scheme_make_pair(shift, shifts); - SCHEME_VEC_ELS(vec)[0] = shifts; - shifts = vec; - } else { - /* No need to propagate, so it's a simple addition. */ - shifts = scheme_make_pair(shift, stx->shifts); - } - - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); - stx->shifts = shifts; - - if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && !stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - - return (Scheme_Object *)stx; -} - -Scheme_Object *scheme_stx_add_shift(Scheme_Object *o, Scheme_Object *shift) -{ - int mutate = 0; - return do_stx_add_shift(o, shift, &mutate); -} - -Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *l) -{ - int mutate = 0; - - for (l = scheme_reverse(l); !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - o = do_stx_add_shift(o, SCHEME_CAR(l), &mutate); - } - - return o; -} - -Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp) -{ - Scheme_Object *exr; - - if (!phase_delta) - phase_delta = scheme_make_integer(0); - - if (!new_midx) { - old_midx = scheme_false; - new_midx = scheme_false; - } - if (!src_insp_desc) - src_insp_desc = scheme_false; - if (!insp) - insp = scheme_false; - if (!export_registry) - exr = scheme_false; - else - exr = (Scheme_Object *)export_registry; - - if (new_midx || export_registry || insp) { - Scheme_Object *vec; - - vec = last_phase_shift; - - if (vec - && (SCHEME_VEC_ELS(vec)[0] == old_midx) - && (SCHEME_VEC_ELS(vec)[1] == new_midx) - && (SCHEME_VEC_ELS(vec)[2] == src_insp_desc) - && (SCHEME_VEC_ELS(vec)[3] == insp) - && (SCHEME_VEC_ELS(vec)[4] == exr) - && (SCHEME_VEC_ELS(vec)[5] == phase_delta)) { - /* use the old one */ - } else { - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = old_midx; - SCHEME_VEC_ELS(vec)[1] = new_midx; - SCHEME_VEC_ELS(vec)[2] = src_insp_desc; - SCHEME_VEC_ELS(vec)[3] = insp; - SCHEME_VEC_ELS(vec)[4] = exr; - SCHEME_VEC_ELS(vec)[5] = phase_delta; - - last_phase_shift = vec; - } - - return last_phase_shift; - } else - return NULL; -} - -static int non_source_shift(Scheme_Object *vec) -{ - return SCHEME_BOXP(SCHEME_VEC_ELS(vec)[0]); -} - -void scheme_clear_shift_cache(void) -{ - int i; - - for (i = 0; i < NUM_RECENT_SCOPE_SETS; i++) { - recent_scope_sets[0][i] = NULL; - recent_scope_sets[1][i] = NULL; - } - - last_phase_shift = NULL; - nominal_ipair_cache = NULL; - clear_binding_cache(); -} - -Scheme_Object *scheme_stx_shift(Scheme_Object *stx, - Scheme_Object *phase_delta, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp) -/* Shifts the modidx on a syntax object in a module as well as the phase of scopes. */ -{ - Scheme_Object *s; - - s = scheme_make_shift(phase_delta, old_midx, new_midx, export_registry, src_insp_desc, insp); - if (s) - stx = scheme_stx_add_shift(stx, s); - - return stx; -} - -static Scheme_Object *shifts_to_non_source(Scheme_Object *shifts) { - Scheme_Object *l, *p, *last, *first, *vec, *vec2; - int i; - - for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (!non_source_shift(SCHEME_CAR(l))) - break; - } - - if (SCHEME_NULLP(l)) - return shifts; - - last = NULL; - first = NULL; - - for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - vec = SCHEME_CAR(l); - if (!non_source_shift(vec)) { - i = SCHEME_VEC_SIZE(vec); - vec2 = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i]; - } - vec = vec2; - vec2 = scheme_box(SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = vec2; - } - - p = scheme_make_pair(vec, scheme_null); - if (!first) - first = p; - else - SCHEME_CDR(last) = p; - last = p; - } - - return first; -} - -static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object *modidx, - Scheme_Object **_insp, Scheme_Hash_Table **_export_registry) -{ -#define QUICK_SHIFT_LEN 5 - Scheme_Object *vec, *dest, *src, *insp_desc; - Scheme_Object *quick_a[QUICK_SHIFT_LEN], **a; - intptr_t i, len; - - /* Strip away propagation layer, if any: */ - if (SCHEME_VECTORP(shifts)) - shifts = SCHEME_VEC_ELS(shifts)[0]; - - if (_insp && *_insp) - insp_desc = *_insp; - else - insp_desc = scheme_false; - - /* The `shifts` list is in the reverse order that we want... */ - - len = scheme_list_length(shifts); - if (len <= QUICK_SHIFT_LEN) - a = quick_a; - else - a = MALLOC_N(Scheme_Object *, len); - - i = len; - while (!SCHEME_NULLP(shifts)) { - a[--i] = SCHEME_CAR(shifts); - shifts = SCHEME_CDR(shifts); - } - - if (_export_registry) - *_export_registry = NULL; - - for (i = 0; i < len; i++) { - vec = a[i]; - - src = SCHEME_VEC_ELS(vec)[0]; - dest = SCHEME_VEC_ELS(vec)[1]; - - if (SCHEME_BOXP(src)) - src = SCHEME_BOX_VAL(src); - - modidx = scheme_modidx_shift(modidx, src, dest); - - if (SCHEME_VEC_SIZE(vec) > 2) { - if (SCHEME_SYMBOLP(insp_desc) - && SAME_OBJ(insp_desc, SCHEME_VEC_ELS(vec)[2])) { - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[3])) - insp_desc = SCHEME_VEC_ELS(vec)[3]; - if (_export_registry - && (SCHEME_VEC_SIZE(vec) > 4) - && !SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[4])) - *_export_registry = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[4]; - } - } - } - - if (_insp && (!*_insp || !SCHEME_INSPECTORP(*_insp))) - *_insp = insp_desc; - - return modidx; -} - -static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-shift-phase-level", "syntax?", 0, argc, argv); - if (SCHEME_TRUEP(argv[1]) && !scheme_exact_p(argv[1])) - scheme_wrong_contract("syntax-shift-phase-level", "(or/c exact-integer? #f)", 0, argc, argv); - - if (SCHEME_INTP(argv[1]) && !SCHEME_INT_VAL(argv[1])) - return argv[0]; - - return scheme_stx_add_shift(argv[0], argv[1]); -} - -/******************** lazy propagation ********************/ - -#define DO_COUNT_PROPAGATES 0 -#if DO_COUNT_PROPAGATES -# define COUNT_PROPAGATES(x) x -int stx_shorts, stx_meds, stx_longs, stx_couldas; -#else -# define COUNT_PROPAGATES(x) /* empty */ -#endif - -XFORM_NONGCING static void intern_scope_set(Scheme_Scope_Table *t, int prop_table) -/* We don't realy intern, but approximate interning by checking - against a small set of recently allocated scope sets. That's good - enough to find sharing for a deeply nested sequence of `let`s from - a many-argument `or`, for example, where the interleaving of - original an macro-introduced syntax prevents the usual - child-is-same-as-parent sharing detecting from working well - enough. */ -{ - int i; - Scheme_Scope_Set *s; - - if (!t->simple_scopes || !scope_set_count(t->simple_scopes)) - return; - - for (i = 0; i < NUM_RECENT_SCOPE_SETS; i++) { - s = recent_scope_sets[prop_table][i]; - if (s) { - if (s == t->simple_scopes) - return; - if ((!prop_table && scopes_equal(s, t->simple_scopes)) - || (prop_table && scope_props_equal(s, t->simple_scopes))) { - t->simple_scopes = s; - return; - } - } - } - - recent_scope_sets[prop_table][recent_scope_sets_pos[prop_table]] = t->simple_scopes; - - recent_scope_sets_pos[prop_table] = ((recent_scope_sets_pos[prop_table] + 1) & (NUM_RECENT_SCOPE_SETS - 1)); -} - -static Scheme_Object *propagate_scope_set(Scheme_Scope_Set *props, Scheme_Object *o, - Scheme_Object *phase, int flag, - GC_CAN_IGNORE int *mutate) -{ - intptr_t i; - Scheme_Object *key, *val; - - i = scope_set_next(props, -1); - if (i != -1) { - do { - scope_set_index(props, i, &key, &val); - - STX_ASSERT(!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key)); - - o = stx_adjust_scope(o, key, phase, SCHEME_INT_VAL(val) | flag, mutate); - - i = scope_set_next(props, i); - } while (i != -1); - - intern_scope_set(((Scheme_Stx *)o)->scopes, 0); - if (STX_KEY(((Scheme_Stx *)o)) & STX_SUBSTX_FLAG - && ((Scheme_Stx *)o)->u.to_propagate) - intern_scope_set(((Scheme_Stx *)o)->u.to_propagate, 1); - } - - return o; -} - -XFORM_NONGCING static int equiv_scope_tables(Scheme_Scope_Table *a, Scheme_Scope_Table *b) -/* try to cheaply detect equivalent tables to enable shortcuts */ -{ - if (a == b) - return 1; - - if (((a->simple_scopes == b->simple_scopes) - || (!scope_set_count(a->simple_scopes) - && !scope_set_count(b->simple_scopes))) - && SAME_OBJ(a->multi_scopes, b->multi_scopes)) - return 1; - - return 0; -} - -static Scheme_Object *propagate_scopes(Scheme_Object *o, Scheme_Scope_Table *to_propagate, - Scheme_Scope_Table *parent_scopes, int flag, - GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *key, *val, *fb; - - if (!to_propagate || (to_propagate == empty_propagate_table)) - return o; - - /* Check whether the child scopes currently match the - parent's scopes before the propagated changes: */ - if (!(flag & SCHEME_STX_PROPONLY) - && equiv_scope_tables(((Scheme_Propagate_Table *)to_propagate)->prev, stx->scopes)) { - /* Yes, so we can take a shortcut: child scopes still match parent. - Does the child need to propagate, and if so, does it just - get the parent's propagation? */ - if (!(STX_KEY(stx) & STX_SUBSTX_FLAG) - || !stx->u.to_propagate - || SAME_OBJ(stx->u.to_propagate, empty_propagate_table)) { - /* Yes, child matches the parent in all relevant dimensions */ - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); - stx->scopes = parent_scopes; - *mutate -= (*mutate & MUTATE_STX_SCOPE_TABLE); - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - stx->u.to_propagate = to_propagate; - *mutate -= (*mutate & MUTATE_STX_PROP_TABLE); - } - COUNT_PROPAGATES(stx_shorts++); - return (Scheme_Object *)stx; - } else { - /* Child scopes match parent, so we don't need to reconstruct - the scope set, but we need to build a new propagation set - to augment the propagate set already here */ - flag |= SCHEME_STX_PROPONLY; - COUNT_PROPAGATES(stx_meds++); - } - } else { - COUNT_PROPAGATES(stx_longs++); - } - - val = ((Scheme_Propagate_Table *)to_propagate)->phase_shift; - if (!SAME_OBJ(val, scheme_make_integer(0))) { - o = shift_scopes(o, val, flag & SCHEME_STX_PROPONLY, mutate); - } - - o = propagate_scope_set(to_propagate->simple_scopes, o, scheme_true, flag, mutate); - - /* fallbacks here mean that we need to propagate fallback creations, - as well as propagating actions at each fallback layer: */ - - fb = to_propagate->multi_scopes; - if (SCHEME_FALLBACKP(fb)) { - /* reverse the fallback list so we can replay them in the right order: */ - key = scheme_null; - while (SCHEME_FALLBACKP(fb)) { - key = make_fallback_quad(SCHEME_FALLBACK_FIRST(fb), - key, - SCHEME_FALLBACK_SCOPE(fb), - SCHEME_FALLBACK_PHASE(fb)); - fb = SCHEME_FALLBACK_REST(fb); - } - fb = make_fallback_pair(fb, key); - } - - while (fb) { - if (SCHEME_FALLBACKP(fb)) { - if (SCHEME_FALLBACK_QUADP(fb)) { - o = stx_adjust_scope(o, SCHEME_FALLBACK_SCOPE(fb), SCHEME_FALLBACK_PHASE(fb), - SCHEME_STX_PUSH | flag, mutate); - } - key = SCHEME_FALLBACK_FIRST(fb); - } else - key = fb; - - for (; !SCHEME_NULLP(key); key = SCHEME_CDR(key)) { - val = SCHEME_CAR(key); - STX_ASSERT(SCHEME_MULTI_SCOPEP(SCHEME_VEC_ELS(val)[0])); - o = stx_adjust_scope(o, SCHEME_VEC_ELS(val)[0], SCHEME_VEC_ELS(val)[1], - SCHEME_INT_VAL(SCHEME_VEC_ELS(val)[2]) | flag, mutate); - } - - if (SCHEME_FALLBACKP(fb)) - fb = SCHEME_FALLBACK_REST(fb); - else - fb = NULL; - } - - if (flag & SCHEME_STX_PROPONLY) { - o = clone_stx(o, mutate); - ((Scheme_Stx *)o)->scopes = parent_scopes; - *mutate -= (*mutate & MUTATE_STX_SCOPE_TABLE); - } - -#if DO_COUNT_PROPAGATES - if (!(flag & SCHEME_STX_PROPONLY)) { - if (scheme_equal((Scheme_Object *)parent_scopes->simple_scopes, - (Scheme_Object *)((Scheme_Stx *)o)->scopes->simple_scopes) - && scheme_equal(parent_scopes->multi_scopes, - ((Scheme_Stx *)o)->scopes->multi_scopes)) - stx_couldas++; - } -#endif - - return o; -} - -static Scheme_Object *propagate_shifts(Scheme_Object *result, Scheme_Object *shifts, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx = (Scheme_Stx *)result; - Scheme_Object *l; - - if (SAME_OBJ(stx->shifts, SCHEME_VEC_ELS(shifts)[2])) { - result = clone_stx(result, mutate); - stx = (Scheme_Stx *)result; - - if ((STX_KEY(stx) & STX_SUBSTX_FLAG)) { - stx->shifts = shifts; - if (!stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - } else - stx->shifts = SCHEME_VEC_ELS(shifts)[0]; - return result; - } - - for (l = scheme_reverse(SCHEME_VEC_ELS(shifts)[1]); !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - result = do_stx_add_shift(result, SCHEME_CAR(l), mutate); - } - - return result; -} - -static Scheme_Object *propagate(Scheme_Object *result, - Scheme_Scope_Table *to_propagate, - Scheme_Scope_Table *parent_scopes, - Scheme_Object *shifts, - int add_taint, Scheme_Object *false_insp) -{ - int mutate = 0; - - result = propagate_scopes(result, to_propagate, parent_scopes, 0, &mutate); - - if (shifts) - result = propagate_shifts(result, shifts, &mutate); - - if (add_taint) - result = add_taint_to_stx(result, &mutate); - else if (false_insp) - result = set_false_insp(result, false_insp, &mutate); - - return result; -} - -int propagate_count; - -static Scheme_Object *raw_stx_content(Scheme_Object *o) - /* Propagates wraps and taints while getting a syntax object's content. */ -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - /* The fast-path tests are duplicated in jit.c. */ - - if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && stx->u.to_propagate) { - Scheme_Object *v = stx->val, *result; - Scheme_Scope_Table *to_propagate; - Scheme_Object *false_insp, *shifts; - int add_taint; - - to_propagate = stx->u.to_propagate; - false_insp = stx->taints; - if (false_insp && SCHEME_VOIDP(false_insp)) { - add_taint = 1; - } else { - add_taint = 0; - if (false_insp) { - if (SCHEME_PAIRP(false_insp)) - false_insp = SCHEME_CAR(false_insp); - if (!SCHEME_INSPECTORP(false_insp)) - false_insp = NULL; - } - } - - shifts = stx->shifts; - if (!SCHEME_VECTORP(stx->shifts)) - shifts = NULL; - - if (SCHEME_PAIRP(v)) { - Scheme_Object *last = NULL, *first = NULL; - - while (SCHEME_PAIRP(v)) { - Scheme_Object *p; - result = SCHEME_CAR(v); - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - p = scheme_make_pair(result, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) { - result = v; - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - if (last) - SCHEME_CDR(last) = result; - else - first = result; - } - v = first; - } else if (SCHEME_BOXP(v)) { - result = SCHEME_BOX_VAL(v); - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - v = scheme_box(result); - SCHEME_SET_BOX_IMMUTABLE(v); - } else if (SCHEME_VECTORP(v)) { - Scheme_Object *v2; - int size = SCHEME_VEC_SIZE(v), i; - - v2 = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - result = SCHEME_VEC_ELS(v)[i]; - result = propagate(result, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - SCHEME_VEC_ELS(v2)[i] = result; - } - - SCHEME_SET_VECTOR_IMMUTABLE(v2); - - v = v2; - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; - Scheme_Object *key, *val; - mzlonglong i; - - ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - val = propagate(val, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - - v = (Scheme_Object *)ht2; - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - Scheme_Object *r; - int size, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - - size = s->stype->num_slots; - for (i = 0; i < size; i++) { - r = s->slots[i]; - r = propagate(r, to_propagate, stx->scopes, - shifts, - add_taint, false_insp); - s->slots[i] = r; - } - - v = (Scheme_Object *)s; - } - - stx->u.to_propagate = NULL; - stx->val = v; - if (add_taint) { - /* if we're setting taints, we must be propagating - taints to touch; change "taints" to "propagated" or "none": */ - stx->taints = scheme_true; - } else if (false_insp) { - /* If we're propagating an inspector with no dye packs, - we're now done propagating. */ - if (!SCHEME_PAIRP(stx->taints)) - stx->taints = NULL; - } - if (shifts) - stx->shifts = SCHEME_VEC_ELS(shifts)[0]; - } - - return stx->val; -} - -Scheme_Object *scheme_stx_content(Scheme_Object *o) -/* Propagates wraps while getting a syntax object's content. */ -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - if (!(STX_KEY(stx) & STX_ARMED_FLAG) || !is_armed((Scheme_Object *)stx)) - return raw_stx_content(o); - - /* force propagation: */ - raw_stx_content(o); - - /* taint */ - o = add_taint_to_stx(o, NULL); - - /* return tainted content */ - return raw_stx_content(o); -} - -/******************** taints ********************/ - -static Scheme_Object *taint_intern(Scheme_Object *v) -{ - Scheme_Bucket *b; - - scheme_start_atomic(); - b = scheme_bucket_from_table(taint_intern_table, (const char *)v); - scheme_end_atomic_no_swap(); - if (!b->val) - b->val = scheme_true; - v = (Scheme_Object *)HT_EXTRACT_WEAK(b->key); - - return v; -} - -static int is_tainted(Scheme_Object *v) -{ - v = ((Scheme_Stx *)v)->taints; - if (!v) return 0; - if (SCHEME_VOIDP(v) || SAME_OBJ(v, scheme_true)) return 1; - return 0; -} - -static int is_clean(Scheme_Object *v) -{ - v = ((Scheme_Stx *)v)->taints; - if (!v) return 1; - if (SCHEME_INSPECTORP(v)) return 1; - return 0; -} - -static int is_armed(Scheme_Object *v) -{ - v = ((Scheme_Stx *)v)->taints; - if (!v) return 0; - if (SCHEME_PAIRP(v)) return 1; - return 0; -} - -int scheme_stx_is_tainted(Scheme_Object *v) -{ - return is_tainted(v); -} - -int scheme_stx_is_clean(Scheme_Object *v) -{ - return is_clean(v); -} - -static int has_taint_arming(Scheme_Object *l, Scheme_Object *t, Scheme_Object *false_insp) -{ - Scheme_Object *a; - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (SCHEME_FALSEP(a)) a = false_insp; - if (SAME_OBJ(a, t)) - return 1; - } - return 0; -} - -static Scheme_Object *add_taint_to_stx(Scheme_Object *o, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx; - - if (is_tainted(o)) - return o; - - o = clone_stx(o, mutate); - stx = (Scheme_Stx *)o; - stx->taints = scheme_void; /* taint to propagate */ - - /* Set to_propagate to indicate taint to propagate: */ - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (!stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - if (STX_KEY(stx) & STX_ARMED_FLAG) - STX_KEY(stx) -= STX_ARMED_FLAG; - } - - return o; -} - -static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, GC_CAN_IGNORE int *mutate) -{ - Scheme_Stx *stx; - - if (is_tainted(o)) - return o; - else if (is_armed(o)) { - if (SCHEME_TRUEP(SCHEME_CAR(((Scheme_Stx *)o)->taints))) - return o; - } else { - if (((Scheme_Stx *)o)->taints) - /* `taints' must be an inspector already */ - return o; - } - - o = clone_stx(o, mutate); - stx = (Scheme_Stx *)o; - if (stx->taints) - false_insp = taint_intern(scheme_make_pair(false_insp, SCHEME_CDR(stx->taints))); - - stx->taints = false_insp; - - /* Set lazy_prefix to indicate inspector to propagate: */ - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (!stx->u.to_propagate) - stx->u.to_propagate = empty_propagate_table; - } - - return o; -} - -static Scheme_Object *do_add_taint_armings_to_stx(Scheme_Object *o, Scheme_Object *taint_armings, int many, int need_clone) -/* If `many', `taint_armings' should be taint-interned. */ -{ - Scheme_Object *l, *taints, *new_taints, *false_insp, *alt_false_insp, *a; - Scheme_Stx *stx; - - taints = ((Scheme_Stx *)o)->taints; - if (taints) { - if (SAME_OBJ(taints, scheme_true) || SCHEME_VOIDP(taints)) - /* tainted */ - return o; - else if (SCHEME_INSPECTORP(taints)) { - false_insp = taints; - taints = NULL; - } else { - false_insp = SCHEME_CAR(taints); - taints = SCHEME_CDR(taints); - } - } else - false_insp = scheme_true; /* block future attempts to propagate a false_insp */ - - if (!taints) { - if (many) - new_taints = taint_armings; - else { - new_taints = taint_intern(scheme_make_pair(taint_armings, scheme_null)); - new_taints = taint_intern(scheme_make_pair(false_insp, new_taints)); - } - } else { - new_taints = taints; - - if (many) { - alt_false_insp = SCHEME_CAR(taint_armings); - taint_armings = SCHEME_CDR(taint_armings); - } else - alt_false_insp = scheme_false; - - for (l = taint_armings; !SCHEME_NULLP(l); ) { - a = many ? SCHEME_CAR(l) : l; - if (SCHEME_FALSEP(a)) a = alt_false_insp; - if (!has_taint_arming(new_taints, a, false_insp)) { - new_taints = taint_intern(scheme_make_pair(a, new_taints)); - } - if (many) - l = SCHEME_CDR(l); - else - l = scheme_null; - } - - if (SAME_OBJ(taints, new_taints)) - return o; - - new_taints = taint_intern(scheme_make_pair(false_insp, new_taints)); - } - - if (need_clone) - o = clone_stx(o, NULL); - stx = (Scheme_Stx *)o; - stx->taints = new_taints; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - STX_KEY(stx) |= STX_ARMED_FLAG; - - return o; -} - -static Scheme_Object *add_taint_arming_to_stx(Scheme_Object *o, Scheme_Object *taint, int need_clone) -{ - return do_add_taint_armings_to_stx(o, taint, 0, need_clone); -} - -static Scheme_Object *add_taint_armings_to_stx(Scheme_Object *o, Scheme_Object *taints, int need_clone) -{ - return do_add_taint_armings_to_stx(o, taints, 1, need_clone); -} - -Scheme_Object *scheme_stx_taint(Scheme_Object *o) -{ - return add_taint_to_stx(o, NULL); -} - -Scheme_Object *scheme_stx_taint_arm(Scheme_Object *o, Scheme_Object *insp) -{ - if (is_tainted(o)) - return o; - else - return add_taint_arming_to_stx(o, insp, 1); -} - -Scheme_Object *scheme_stx_taint_rearm(Scheme_Object *o, Scheme_Object *copy_from) -{ - if (is_tainted(o) || is_clean(copy_from)) - return o; - else if (is_tainted(copy_from)) - return add_taint_to_stx(o, NULL); - else - return add_taint_armings_to_stx(o, ((Scheme_Stx *)copy_from)->taints, 1); -} - - static int is_same_or_subinspector(Scheme_Object *sub, Scheme_Object *sup, Scheme_Object *false_insp) -{ - if (SCHEME_FALSEP(sub)) sub = false_insp; - if (SAME_OBJ(sub, sup)) return 1; - return scheme_is_subinspector(sub, sup); -} - -Scheme_Object *scheme_stx_taint_disarm(Scheme_Object *o, Scheme_Object *insp) -{ - Scheme_Object *l, *l2, *a, *taint_armings, *false_insp; - - if (is_tainted(o) || is_clean(o)) - return o; - - taint_armings = ((Scheme_Stx *)o)->taints; - false_insp = SCHEME_CAR(taint_armings); - taint_armings = SCHEME_CDR(taint_armings); - - if (insp) { - for (l = taint_armings; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (is_same_or_subinspector(a, insp, false_insp)) { - break; - } - } - if (SCHEME_NULLP(l)) - return o; - - l2 = scheme_null; - for (l = taint_armings; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (!is_same_or_subinspector(a, insp, false_insp)) { - l2 = taint_intern(scheme_make_pair(a, l2)); - } - } - } else - l2 = scheme_null; - - o = clone_stx(o, NULL); - - if (SCHEME_NULLP(l2)) { - if (SCHEME_INSPECTORP(false_insp)) - ((Scheme_Stx *)o)->taints = false_insp; - else - ((Scheme_Stx *)o)->taints = NULL; - if (STX_KEY(((Scheme_Stx *)o)) & STX_ARMED_FLAG) - STX_KEY(((Scheme_Stx *)o)) -= STX_ARMED_FLAG; - } else { - l2 = taint_intern(scheme_make_pair(false_insp, l2)); - ((Scheme_Stx *)o)->taints = l2; - } - - return o; -} - -/******************** bindings ********************/ - -XFORM_NONGCING static Scheme_Scope *extract_max_scope(Scheme_Scope_Set *scopes) -{ - intptr_t i; - Scheme_Object *key, *val; - Scheme_Scope *scope; - mzlonglong scope_id_val, id_val; - - i = scope_set_next(scopes, -1); - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - scope_id_val = scope->id; - - i = scope_set_next(scopes, i); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - - id_val = ((Scheme_Scope *)key)->id; - if (id_val > scope_id_val) { - scope = (Scheme_Scope *)key; - scope_id_val = id_val; - } - - i = scope_set_next(scopes, i); - } - - return scope; -} - -#define SCHEME_BINDING_SCOPES(p) ((Scheme_Scope_Set *)SCHEME_CAR(p)) -#define SCHEME_BINDING_VAL(p) SCHEME_CDR(p) - -#define SCHEME_VEC_BINDING_KEY(p) (SCHEME_VEC_ELS(p)[0]) -#define SCHEME_VEC_BINDING_SCOPES(p) ((Scheme_Scope_Set *)(SCHEME_VEC_ELS(p)[1])) -#define SCHEME_VEC_BINDING_VAL(p) (SCHEME_VEC_ELS(p)[2]) - -#define CONV_RETURN_UNLESS(p) if (!p) return - -static void check_for_conversion(Scheme_Object *sym, - Scheme_Scope *scope, - Scheme_Module_Phase_Exports *pt, - Scheme_Hash_Table *collapse_table, - Scheme_Hash_Tree *ht, - Scheme_Scope_Set *scopes, - Scheme_Object *phase, - Scheme_Object *bind) -/* Due to `require` macros, importing a whole module can turn into - individual imports from the module. Detect when everything that a - module exports (at a given phase) is imported as a set of bindings, - and collapse them to a bulk-import "pes". */ -{ - Scheme_Hash_Table *mht; - Scheme_Object *v, *v2, *cnt; - int i; - - mht = (Scheme_Hash_Table *)scheme_eq_hash_get(collapse_table, (Scheme_Object *)scope); - if (!mht) { - mht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(collapse_table, (Scheme_Object *)scope, (Scheme_Object *)mht); - } - - cnt = scheme_eq_hash_get(mht, (Scheme_Object *)pt); - if (!cnt) - cnt = scheme_make_integer(1); - else - cnt = scheme_bin_plus(cnt, scheme_make_integer(1)); - scheme_hash_set(mht, (Scheme_Object *)pt, cnt); - - if (bind && (SCHEME_INT_VAL(cnt) == pt->num_provides)) { - Scheme_Object *modidx, *modidx2, *insp_desc, *insp_desc2, *src_phase; - Scheme_Object *exportname, *nominal_modidx, *nominal_modidx2, *mod_phase, *nominal_name; - Scheme_Object *nominal_src_phase; - Scheme_Object *pes; - - nominal_modidx = NULL; - - extract_module_binding_parts(SCHEME_BINDING_VAL(bind), phase, - &insp_desc, - &modidx, - &exportname, - &nominal_modidx, - &mod_phase, - NULL, - NULL, - NULL); - - if (!nominal_modidx) - nominal_modidx = modidx; - - /* since we've mapped N identifiers from a source of N identifiers, - maybe we mapped all of them. */ - for (i = pt->num_provides; i--; ) { - v2 = scheme_eq_hash_tree_get(ht, pt->provides[i]); - CONV_RETURN_UNLESS(v2); - - /* For now, allow only a single binding: */ - CONV_RETURN_UNLESS(SCHEME_PAIRP(v2) - || (SCHEME_MPAIRP(v2) && SCHEME_NULLP(SCHEME_CDR(v2)))); - if (SCHEME_MPAIRP(v2)) - v2 = SCHEME_CAR(v2); - - CONV_RETURN_UNLESS(scopes_equal(scopes, SCHEME_BINDING_SCOPES(v2))); - - /* Pull apart module bindings to make sure they're consistent: */ - exportname = pt->provides[i]; - nominal_modidx2 = NULL; - mod_phase = pt->phase_index; - nominal_name = exportname; - src_phase = scheme_make_integer(0); - nominal_src_phase = NULL; - mod_phase = pt->phase_index; - - extract_module_binding_parts(SCHEME_BINDING_VAL(v2), phase, - &insp_desc2, - &modidx, - &exportname, - &nominal_modidx2, - &mod_phase, - &nominal_name, - &src_phase, - &nominal_src_phase); - - if (!nominal_modidx2) - nominal_modidx2 = modidx; - if (!nominal_src_phase) - nominal_src_phase = mod_phase; - - CONV_RETURN_UNLESS(SAME_OBJ(insp_desc2, insp_desc)); - modidx2 = (pt->provide_srcs ? pt->provide_srcs[i] : scheme_false); - if (SCHEME_FALSEP(modidx2)) - modidx2 = nominal_modidx; - else if (pt->src_modidx) - modidx2 = scheme_modidx_shift(modidx2, pt->src_modidx, nominal_modidx); - CONV_RETURN_UNLESS(scheme_equal(modidx, modidx2)); - CONV_RETURN_UNLESS(SAME_OBJ(exportname, pt->provide_src_names[i])); - CONV_RETURN_UNLESS(scheme_equal(nominal_modidx2, nominal_modidx)); - CONV_RETURN_UNLESS(scheme_eqv(mod_phase, (pt->provide_src_phases - ? scheme_make_integer(pt->provide_src_phases[i]) - : pt->phase_index))); - CONV_RETURN_UNLESS(SAME_OBJ(nominal_name, pt->provides[i])); - CONV_RETURN_UNLESS(scheme_eqv(src_phase, phase)); - CONV_RETURN_UNLESS(scheme_eqv(nominal_src_phase, pt->phase_index)); - } - - /* found a match; convert to a pes: */ - pes = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(pes)[0] = nominal_modidx; - SCHEME_VEC_ELS(pes)[1] = (Scheme_Object *)pt; - SCHEME_VEC_ELS(pes)[2] = phase; - SCHEME_VEC_ELS(pes)[3] = pt->phase_index; - SCHEME_VEC_ELS(pes)[4] = insp_desc; - - bind = scheme_make_pair((Scheme_Object *)scopes, pes); - - /* install pes: */ - v = scope->bindings; - if (!SCHEME_RPAIRP(v)) { - STX_ASSERT(SCHEME_HASHTRP(v)); - v = scheme_make_raw_pair(v, NULL); - scope->bindings = v; - } - v = scheme_make_raw_pair(bind, SCHEME_CDR(v)); - SCHEME_CDR(scope->bindings) = v; - - /* remove per-symbol bindings: */ - for (i = pt->num_provides; i--; ) { - ht = scheme_hash_tree_set(ht, pt->provides[i], NULL); - } - SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; - } -} - -static Scheme_Object *replace_matching_scopes(Scheme_Object *l, Scheme_Scope_Set *scopes) -/* Takes a list of scope--value pairs for a binding table and removes - any match to `scopes` */ -{ - Scheme_Object *p; - int c = 0; - - if (SCHEME_PAIRP(l)) { - /* only one item to check */ - if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(l))) - return NULL; - else - return l; - } - - for (p = l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { - if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(SCHEME_CAR(p)))) { - break; - } - c++; - } - - if (SCHEME_NULLP(p)) - return l; - - p = SCHEME_CDR(p); - while (c--) { - p = scheme_make_mutable_pair(SCHEME_CAR(l), p); - l = SCHEME_CDR(l); - } - - /* down to one item? */ - if (SCHEME_NULLP(SCHEME_CDR(p))) - return SCHEME_CAR(p); - - /* no items? */ - if (SCHEME_NULLP(p)) - return NULL; - - return p; -} - -static void clear_matching_bindings(Scheme_Object *pes, - Scheme_Scope_Set *scopes, - Scheme_Object *l) -/* a new bulk import needs to override any individual imports; this - should only matter for top-level interactions, since modules only - allow shadowing of the initial bulk import */ -{ - Scheme_Hash_Tree *excepts; - Scheme_Object *prefix; - Scheme_Module_Phase_Exports *pt; - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)SCHEME_CAR(l), *new_ht; - Scheme_Object *key, *val, *new_val; - intptr_t i; - - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - scheme_populate_pt_ht(pt); - } - - new_ht = ht; - - excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); - prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - - if ((ht->count < pt->ht->count) - || SCHEME_TRUEP(prefix) - || excepts) { - /* faster to scan per-symbol binding table */ - i = -1; - while ((i = scheme_hash_tree_next(ht, i)) != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - if (scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(key, pes))) { - new_val = replace_matching_scopes(val, scopes); - if (!SAME_OBJ(val, new_val)) - new_ht = scheme_hash_tree_set(new_ht, key, new_val); - } - } - } else { - /* faster to scan export table */ - for (i = pt->ht->size; i--; ) { - if (pt->ht->vals[i]) { - key = pt->ht->keys[i]; - val = scheme_eq_hash_tree_get(new_ht, key); - if (val) { - new_val = replace_matching_scopes(val, scopes); - if (!SAME_OBJ(val, new_val)) - new_ht = scheme_hash_tree_set(new_ht, key, new_val); - } - } - } - } - - if (!SAME_OBJ(new_ht, ht)) - SCHEME_CAR(l) = (Scheme_Object *)new_ht; -} - -XFORM_NONGCING static void save_old_value(Scheme_Object *mp, Scheme_Object *old_val) -{ - if (SCHEME_MPAIRP(old_val)) - SCHEME_CAR(mp) = SCHEME_CAR(old_val); - else - SCHEME_CAR(mp) = old_val; -} - -static void add_binding(Scheme_Object *sym, Scheme_Object *phase, Scheme_Scope_Set *scopes, - Scheme_Object *val, - Scheme_Module_Phase_Exports *from_pt, /* to detect collapse conversion */ - Scheme_Hash_Table *collapse_table) /* to triggere collapse detection */ -/* `val` can be a symbol (local binding), a modidx/pair/#f - (module/global binding), a shared-binding vector (i.e., a pes), or - a syntax object (for a `free-identifier=?` equivalence) to be - mutable-paired with the existing binding; the `sym` argument should - be NULL when `val` is a shared-binding vector */ - -{ - Scheme_Hash_Tree *ht; - Scheme_Scope *scope; - Scheme_Object *l, *p, *bind; - - if (scope_set_count(scopes)) { - /* We add the binding to the maximum-valued scope, because it's - likely to be in the least number of binding sets so far. */ - scope = extract_max_scope(scopes); - if (SAME_OBJ((Scheme_Object*)scope, root_scope)) - scheme_signal_error("internal error: cannot bind with only a root scope"); - } else { - scheme_signal_error("internal error: cannot bind identifier with an empty context"); - return; - } - STX_ASSERT(SCHEME_STXP(val) - || SCHEME_FALSEP(val) - || SCHEME_MODIDXP(val) - || SCHEME_PAIRP(val) - || SCHEME_VECTORP(val) - || SCHEME_SYMBOLP(val)); - - if (SCHEME_STXP(val)) - val = scheme_make_mutable_pair(scheme_false, scheme_make_pair(val, phase)); - - l = scope->bindings; - if (!l) { - if (sym) { - /* simple case: a single binding */ - STX_ASSERT(SCHEME_SYMBOLP(sym)); - bind = make_vector3(sym, (Scheme_Object *)scopes, val); - scope->bindings = bind; - clear_binding_cache_for(sym); - if (from_pt) { - /* don't convert, but record addition for potential conversion */ - check_for_conversion(sym, scope, from_pt, collapse_table, NULL, scopes, phase, NULL); - } - return; - } - ht = empty_hash_tree; - l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); - scope->bindings = l; - } else if (SCHEME_VECTORP(l)) { - /* convert simple case to more general case */ - ht = scheme_hash_tree_set(empty_hash_tree, - SCHEME_VEC_BINDING_KEY(l), - scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(l), - SCHEME_VEC_BINDING_VAL(l))); - if (sym) { - /* more complex case: table of bindings */ - scope->bindings = (Scheme_Object *)ht; - } else { - /* need most complex form */ - l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); - scope->bindings = l; - } - } else if (SCHEME_RPAIRP(l)) { - /* already in complex form */ - ht = (Scheme_Hash_Tree *)SCHEME_CAR(l); - } else { - STX_ASSERT(SCHEME_HASHTRP(l)); - ht = (Scheme_Hash_Tree *)l; - if (!sym) { - /* need most complex form */ - l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); - scope->bindings = l; - } - } - - bind = scheme_make_pair((Scheme_Object *)scopes, val); - - if (sym) { - STX_ASSERT(SCHEME_SYMBOLP(sym)); - clear_binding_cache_for(sym); - l = scheme_eq_hash_tree_get(ht, sym); - if (!l) { - ht = scheme_hash_tree_set(ht, sym, bind); - if (SCHEME_RPAIRP(scope->bindings)) - SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; - else - scope->bindings = (Scheme_Object *)ht; - } else { - if (!SCHEME_MPAIRP(l)) - l = scheme_make_mutable_pair(l, scheme_null); - for (p = l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { - if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(SCHEME_CAR(p)))) { - if (SCHEME_MPAIRP(val)) - save_old_value(val, SCHEME_BINDING_VAL(SCHEME_CAR(p))); - SCHEME_CAR(p) = bind; - break; - } - } - if (SCHEME_NULLP(p)) { - l = scheme_make_mutable_pair(bind, l); - ht = scheme_hash_tree_set(ht, sym, l); - } else if (SCHEME_NULLP(SCHEME_CDR(l))) { - ht = scheme_hash_tree_set(ht, sym, SCHEME_CAR(l)); - from_pt = NULL; /* single binding; no benefit from pes conversion */ - } - - if (SCHEME_RPAIRP(scope->bindings)) - SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; - else - scope->bindings = (Scheme_Object *)ht; - } - if (from_pt) - check_for_conversion(sym, scope, from_pt, collapse_table, ht, scopes, phase, bind); - } else { - /* Order matters: the new bindings should hide any existing bindings for the same name. */ - clear_binding_cache(); - p = scheme_make_raw_pair(bind, SCHEME_CDR(l)); - SCHEME_CDR(l) = p; - - /* Remove any matching mappings form the hash table, since it gets checked first. */ - clear_matching_bindings(val, scopes, l); - } -} - -void scheme_add_local_binding(Scheme_Object *o, Scheme_Object *phase, Scheme_Object *binding_sym) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - STX_ASSERT(SCHEME_SYMBOLP(binding_sym)); - - add_binding(stx->val, phase, extract_scope_set(stx, phase), binding_sym, NULL, NULL); -} - -static void do_add_module_binding(Scheme_Scope_Set *scopes, Scheme_Object *localname, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *exname, Scheme_Object *defn_phase, - Scheme_Object *insp_desc, - Scheme_Object *nominal_mod, Scheme_Object *nominal_ex, - Scheme_Object *src_phase, - Scheme_Object *nom_phase, - Scheme_Module_Phase_Exports *from_pt, - Scheme_Hash_Table *collapse_table) -{ - Scheme_Object *elem; - int mod_phase; - - if (SCHEME_FALSEP(modidx)) { - if (SAME_OBJ(localname, exname)) - add_binding(localname, phase, scopes, scheme_false, NULL, NULL); - else - add_binding(localname, phase, scopes, scheme_make_pair(scheme_false, exname), NULL, NULL); - return; - } - - STX_ASSERT(SCHEME_MODIDXP(modidx)); - - /* - This encoding is meant to be progressively less compact for - progressively less-common cases: - - binding ::= mod_binding - . | (cons inspector-desc mod_binding) - mod_binding ::= modidx ; mod-phase = 0 - . | (cons modidx exportname) - . | (cons modidx nominal_modidx) - . | (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) - . | (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) - nominal_modix_plus_phase ::= nominal_modix ; import-phase-level is 0, nom-phase = mod-phase - . | (cons nominal_modix import_phase_plus_nominal_phase) - import_phase_plus_nominal_phase ::= import-phase-level ; nom-phase = mod-phase - . | (cons import-phase-level nom-phase) - inspector-desc = inspector - . | symbol - */ - - mod_phase = SCHEME_INT_VAL(defn_phase); - - if (!src_phase) - src_phase = phase; - if (!nom_phase) - nom_phase = scheme_make_integer(mod_phase); - - if (SAME_OBJ(modidx, nominal_mod) - && SAME_OBJ(exname, nominal_ex) - && !mod_phase - && same_phase(src_phase, scheme_make_integer(0)) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (SAME_OBJ(localname, exname)) - elem = modidx; - else - elem = CONS(modidx, exname); - } else if (SAME_OBJ(exname, nominal_ex) - && SAME_OBJ(localname, exname) - && !mod_phase - && same_phase(src_phase, scheme_make_integer(0)) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - /* It's common that a sequence of similar mappings shows up, - e.g., '(#%kernel . mzscheme) */ - if (nominal_ipair_cache - && SAME_OBJ(SCHEME_CAR(nominal_ipair_cache), modidx) - && SAME_OBJ(SCHEME_CDR(nominal_ipair_cache), nominal_mod)) - elem = nominal_ipair_cache; - else { - elem = ICONS(modidx, nominal_mod); - nominal_ipair_cache = elem; - } - } else { - if (same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (same_phase(src_phase, scheme_make_integer(0))) - elem = nominal_mod; - else - elem = CONS(nominal_mod, src_phase); - } else { - elem = CONS(nominal_mod, CONS(src_phase, nom_phase)); - } - elem = CONS(exname, CONS(elem, nominal_ex)); - if (mod_phase) - elem = CONS(scheme_make_integer(mod_phase), elem); - elem = CONS(modidx, elem); - } - - if (!SCHEME_FALSEP(insp_desc)) - elem = CONS(insp_desc, elem); - - add_binding(localname, phase, scopes, elem, from_pt, collapse_table); -} - -void extract_module_binding_parts(Scheme_Object *l, - Scheme_Object *phase, - Scheme_Object **_insp_desc, /* required */ - Scheme_Object **_modidx, /* required */ - Scheme_Object **_exportname, /* required, maybe unset */ - Scheme_Object **_nominal_modidx, /* maybe unset */ - Scheme_Object **_mod_phase, /* required, maybe unset */ - Scheme_Object **_nominal_name, /* maybe unset */ - Scheme_Object **_src_phase, /* maybe unset */ - Scheme_Object **_nominal_src_phase) /* maybe unset */ -/* unpack an encodings created by do_add_module_binding() */ -{ - if (SCHEME_PAIRP(l) - && SCHEME_INSPECTOR_DESCP(SCHEME_CAR(l))) { - *_insp_desc = SCHEME_CAR(l); - l = SCHEME_CDR(l); - } else - *_insp_desc = scheme_false; - - if (SCHEME_MODIDXP(l)) - *_modidx = l; - else { - *_modidx = SCHEME_CAR(l); - l = SCHEME_CDR(l); - - if (SCHEME_SYMBOLP(l)) { - /* l is exportname */ - *_exportname = l; - } else if (SCHEME_MODIDXP(l)) { - /* l is nominal_modidx */ - if (_nominal_modidx) *_nominal_modidx = l; - } else { - if (SCHEME_INTP(SCHEME_CAR(l)) || SCHEME_BIGNUMP(SCHEME_CAR(l))) { - /* mod-phase before rest */ - *_mod_phase = SCHEME_CAR(l); - l = SCHEME_CDR(l); - } - - /* l is (list* exportname nominal_modidx_plus_phase nominal_exportname) */ - *_exportname = SCHEME_CAR(l); - l = SCHEME_CDR(l); - if (_nominal_name) - *_nominal_name = SCHEME_CDR(l); - l = SCHEME_CAR(l); - /* l is nominal_modidx_plus_phase */ - if (SCHEME_PAIRP(l)) { - if (_nominal_modidx) *_nominal_modidx = SCHEME_CAR(l); - l = SCHEME_CDR(l); - if (SCHEME_PAIRP(l)) { - if (_src_phase) *_src_phase = SCHEME_CAR(l); - if (_nominal_src_phase) *_nominal_src_phase = SCHEME_CDR(l); - } else { - if (_src_phase) *_src_phase = l; - if (_nominal_src_phase) *_nominal_src_phase = *_mod_phase; - } - } else { - if (_nominal_modidx) *_nominal_modidx = l; - } - } - } -} - -void scheme_add_module_binding(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *inspector, - Scheme_Object *sym, Scheme_Object *defn_phase) -{ - STX_ASSERT(SCHEME_SYMBOLP(((Scheme_Stx *)o)->val)); - - do_add_module_binding(extract_scope_set((Scheme_Stx *)o, phase), SCHEME_STX_VAL(o), phase, - modidx, sym, defn_phase, - inspector, - modidx, sym, - NULL, NULL, - NULL, NULL); -} - -void scheme_add_module_binding_w_nominal(Scheme_Object *o, Scheme_Object *phase, - Scheme_Object *modidx, Scheme_Object *defn_name, Scheme_Object *defn_phase, - Scheme_Object *inspector, - Scheme_Object *nominal_mod, Scheme_Object *nominal_name, - Scheme_Object *nominal_import_phase, - Scheme_Object *nominal_export_phase, - Scheme_Module_Phase_Exports *from_pt, - Scheme_Hash_Table *collapse_table) -{ - STX_ASSERT(SCHEME_STXP(o)); - do_add_module_binding(extract_scope_set((Scheme_Stx *)o, phase), SCHEME_STX_VAL(o), phase, - modidx, defn_name, defn_phase, - inspector, - nominal_mod, nominal_name, - nominal_import_phase, nominal_export_phase, - from_pt, collapse_table); -} - -/******************** debug-info ********************/ - -static Scheme_Object *scopes_to_printed_list(Scheme_Scope_Set *scopes) -{ - Scheme_Object *l, *val, *key; - - l = scopes_to_sorted_list(scopes); - val = scheme_null; - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - key = SCHEME_CAR(l); - val = scheme_make_pair(scheme_scope_printed_form(key), val); - } - - return val; -} - -Scheme_Object *add_bindings_info(Scheme_Object *bindings, Scheme_Object *key, Scheme_Object *l, - Scheme_Stx *stx, int all_bindings, Scheme_Object *seen) -{ - Scheme_Hash_Tree *bind_desc; - Scheme_Object *val; - - if (SCHEME_PAIRP(l)) { - l = scheme_make_mutable_pair(l, scheme_null); - } - - while (!SCHEME_NULLP(l)) { - if (all_bindings || SAME_OBJ(key, stx->val)) { - bind_desc = empty_hash_tree; - bind_desc = scheme_hash_tree_set(bind_desc, name_symbol, key); - - val = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (SCHEME_MPAIRP(val)) { - bind_desc = scheme_hash_tree_set(bind_desc, free_symbol, - stx_debug_info((Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)), - SCHEME_CDR(SCHEME_CDR(val)), - scheme_make_pair((Scheme_Object *)stx, seen), - all_bindings)); - val = SCHEME_CAR(val); - } - - if (SCHEME_SYMBOLP(val)) - bind_desc = scheme_hash_tree_set(bind_desc, local_symbol, val); - else { - if (SCHEME_PAIRP(val)) { - if (SCHEME_INSPECTOR_DESCP(SCHEME_CAR(val))) - val = SCHEME_CDR(val); - val = SCHEME_CAR(val); - } - if (SCHEME_MODIDXP(val)) - val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); - bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); - } - - bind_desc = scheme_hash_tree_set(bind_desc, context_symbol, - scopes_to_printed_list(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)))); - - bindings = scheme_make_pair((Scheme_Object *)bind_desc, bindings); - } - - l = SCHEME_CDR(l); - } - - return bindings; -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *stx_debug_info_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Stx *stx = (Scheme_Stx *)p->ku.k.p1; - Scheme_Object *phase = (Scheme_Object *)p->ku.k.p2; - Scheme_Object *seen = (Scheme_Object *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return stx_debug_info(stx, phase, seen, p->ku.k.i1); -} -#endif - -static Scheme_Object *stx_debug_info(Scheme_Stx *stx, Scheme_Object *phase, Scheme_Object *seen, int all_bindings) -{ - Scheme_Hash_Tree *desc, *bind_desc; - Scheme_Hash_Tree *ht; - Scheme_Object *key, *val, *l, *pes, *descs = scheme_null, *bindings; - intptr_t i, j; - Scheme_Scope *scope; - Scheme_Scope_Set *scopes; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *multi_scopes; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)stx; - p->ku.k.p2 = (void *)phase; - p->ku.k.p3 = (void *)seen; - p->ku.k.i1 = all_bindings; - - return scheme_handle_stack_overflow(stx_debug_info_k); - } - } -#endif - - { - int up = 0; - for (l = seen; !SCHEME_NULLP(l); l = SCHEME_CDR(l), up++) { - if (SAME_OBJ((Scheme_Object *)stx, SCHEME_CAR(l))) { - return scheme_make_pair(cycle_symbol, - scheme_make_pair(scheme_make_integer(up), - scheme_null)); - } - } - } - - multi_scopes = stx->scopes->multi_scopes; - - /* Loop for top-level fallbacks: */ - while (1) { - scopes = extract_scope_set_from_scope_list(stx->scopes->simple_scopes, multi_scopes, phase); - - desc = empty_hash_tree; - - if (SCHEME_SYMBOLP(stx->val)) - desc = scheme_hash_tree_set(desc, name_symbol, stx->val); - desc = scheme_hash_tree_set(desc, context_symbol, scopes_to_printed_list(scopes)); - - /* Describe other bindings */ - bindings = scheme_null; - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - if (scope->bindings) { - if (SCHEME_VECTORP(scope->bindings)) { - l = scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(scope->bindings), - SCHEME_VEC_BINDING_VAL(scope->bindings)); - bindings = add_bindings_info(bindings, SCHEME_VEC_BINDING_KEY(scope->bindings), l, - stx, all_bindings, seen); - l = NULL; - } else { - l = scope->bindings; - if (SCHEME_RPAIRP(l)) - ht = (Scheme_Hash_Tree *)SCHEME_CAR(scope->bindings); - else { - STX_ASSERT(SCHEME_HASHTRP(l)); - ht = (Scheme_Hash_Tree *)l; - } - - j = -1; - while ((j = scheme_hash_tree_next(ht, j)) != -1) { - scheme_hash_tree_index(ht, j, &key, &val); - bindings = add_bindings_info(bindings, key, val, stx, all_bindings, seen); - } - - l = scope->bindings; - if (SCHEME_RPAIRP(l)) - l = SCHEME_CDR(l); - else - l = NULL; - } - - while (l) { - STX_ASSERT(SCHEME_RPAIRP(l)); - - bind_desc = empty_hash_tree; - - bind_desc = scheme_hash_tree_set(bind_desc, context_symbol, - scopes_to_printed_list(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)))); - - pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - val = SCHEME_VEC_ELS(pes)[0]; - if (SCHEME_MODIDXP(val)) - val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); - bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); - - if (PES_UNMARSHAL_DESCP(pes)) { - /* unmarshal hasn't happened */ - } else { - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - if (!pt->ht) - scheme_populate_pt_ht(pt); - - if (scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, pes))) - bind_desc = scheme_hash_tree_set(bind_desc, matchp_symbol, scheme_true); - else - bind_desc = scheme_hash_tree_set(bind_desc, matchp_symbol, scheme_false); - } - - bindings = scheme_make_pair((Scheme_Object *)bind_desc, bindings); - - l = SCHEME_CDR(l); - } - } - - i = scope_set_next(scopes, i); - } - - if (!SCHEME_NULLP(bindings)) - desc = scheme_hash_tree_set(desc, bindings_symbol, scheme_reverse(bindings)); - - descs = scheme_make_pair((Scheme_Object *)desc, descs); - - if (SCHEME_FALLBACKP(multi_scopes)) { - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - } else - break; - } - - if (SCHEME_NULLP(SCHEME_CDR(descs))) - return SCHEME_CAR(descs); - else { - descs = scheme_reverse(descs); - return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)SCHEME_CAR(descs), - fallbacks_symbol, - SCHEME_CDR(descs)); - } -} - -void scheme_stx_debug_print(Scheme_Object *_stx, Scheme_Object *phase, int level) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Object *info; - - STX_ASSERT(SCHEME_STXP(_stx)); - - info = stx_debug_info(stx, phase, scheme_null, level > 1); - if (!level) { - info = scheme_hash_tree_get((Scheme_Hash_Tree *)info, context_symbol); - if (!info) info = scheme_false; - } - - printf("%s at phase %s:\n", - scheme_write_to_string(stx->val, NULL), - scheme_write_to_string(phase, NULL)); - printf(" %s\n", - scheme_write_to_string(info, NULL)); -} - -static void fprint_string(Scheme_Object *o, const char *s) -{ - (void)scheme_put_byte_string("describe", o, s, 0, strlen(s), 1); -} - -static void fprint_label_string(Scheme_Object *o, int rename_level, Scheme_Object *rename_sym, const char *s) -{ - fprint_string(o, "\n "); - if (rename_level) { - while (rename_level--) { - fprint_string(o, "="); - } - fprint_string(o, "> "); - scheme_write(rename_sym, o); - fprint_string(o, " "); - } - fprint_string(o, s); -} - -static void write_context(Scheme_Object *l, Scheme_Object *o) -{ - intptr_t col = 2, len; - char *s; - - while (!SCHEME_NULLP(l)) { - s = scheme_write_to_string(SCHEME_CAR(l), &len); - if ((col > 2) && (col + len + 1 > 80)) { - col = 2; - fprint_string(o, "\n "); - } - fprint_string(o, " "); - scheme_put_byte_string("describe", o, s, 0, len, 1); - col += len; - - l = SCHEME_CDR(l); - } -} - -static int context_matches(Scheme_Object *l1, Scheme_Object *l2) -/* Check whether the sorted list l2 is a subset of the sorted list l1 */ -{ - while (!SCHEME_NULLP(l2)) { - if (SCHEME_NULLP(l1)) - return 0; - - if (scheme_equal(SCHEME_CAR(l1), SCHEME_CAR(l2))) { - l1 = SCHEME_CDR(l1); - l2 = SCHEME_CDR(l2); - } else - l1 = SCHEME_CDR(l1); - } - - return 1; -} - -static Scheme_Object *describe_bindings(Scheme_Object *o, Scheme_Object *di, - int rename_level, Scheme_Object *rename_sym, - int always) -{ - Scheme_Object *l, *report, *val, *free_id; - Scheme_Hash_Tree *dit, *bt; - int fallback; - - fallback = 0; - while (!SCHEME_NULLP(di)) { - if (SCHEME_PAIRP(di)) - dit = (Scheme_Hash_Tree *)SCHEME_CAR(di); - else - dit = (Scheme_Hash_Tree *)di; - - l = scheme_hash_tree_get(dit, bindings_symbol); - if (l) { - report = scheme_null; - while (!SCHEME_NULLP(l)) { - bt = (Scheme_Hash_Tree *)SCHEME_CAR(l); - - val = scheme_hash_tree_get(bt, matchp_symbol); - - if ((val && SCHEME_TRUEP(val)) - || scheme_hash_tree_get(bt, name_symbol)) - report = scheme_make_pair((Scheme_Object *)bt, report); - - l = SCHEME_CDR(l); - } - - if (!SCHEME_NULLP(report) || always) { - if (!o) - o = scheme_make_byte_string_output_port(); - - fprint_label_string(o, rename_level, rename_sym, "context"); - if (fallback) { - fprint_string(o, " at layer "); - scheme_display(scheme_make_integer(fallback), o); - } - fprint_string(o, "...:\n "); - write_context(scheme_hash_tree_get(dit, context_symbol), o); - - while (!SCHEME_NULLP(report)) { - bt = (Scheme_Hash_Tree *)SCHEME_CAR(report); - - if (context_matches(scheme_hash_tree_get(dit, context_symbol), - scheme_hash_tree_get(bt, context_symbol))) - fprint_label_string(o, rename_level, rename_sym, "matching binding"); - else - fprint_label_string(o, rename_level, rename_sym, "other binding"); - if (fallback) { - fprint_string(o, " at layer "); - scheme_display(scheme_make_integer(fallback), o); - } - fprint_string(o, "...:\n "); - val = scheme_hash_tree_get(bt, module_symbol); - if (!val) { - fprint_string(o, "local "); - val = scheme_hash_tree_get(bt, local_symbol); - } - scheme_write(val, o); - fprint_string(o, "\n "); - write_context(scheme_hash_tree_get(bt, context_symbol), o); - - free_id = scheme_hash_tree_get(bt, free_symbol); - if (free_id) { - fprint_string(o, "\n free-identifier=? to "); - if (SCHEME_PAIRP(free_id) - && SAME_OBJ(SCHEME_CAR(free_id), cycle_symbol)) { - int up = SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CDR(free_id))); - if (!up) - fprint_string(o, "[cycle to self]"); - else { - fprint_string(o, "[cycle, up "); - scheme_write(scheme_make_integer(up), o); - fprint_string(o, " levels]"); - } - } else { - if (SCHEME_HASHTRP(free_id)) - val = scheme_hash_tree_get((Scheme_Hash_Tree *)free_id, name_symbol); - else - val = NULL; - if (val) { - scheme_write(val, o); - o = describe_bindings(o, free_id, rename_level + 1, val, always); - } else { - fprint_string(o, "[unknown]"); - } - } - } - - report = SCHEME_CDR(report); - } - } - } - - if (SCHEME_PAIRP(di)) - di = SCHEME_CDR(di); - else { - di = scheme_hash_tree_get(dit, fallbacks_symbol); - if (!di) - di = scheme_null; - } - fallback++; - } - - return o; -} - -char *scheme_stx_describe_context(Scheme_Object *stx, Scheme_Object *phase, int always) -{ - Scheme_Object *di, *o = NULL; - intptr_t len; - char *r; - - if (!stx) - return ""; - - di = stx_debug_info((Scheme_Stx *)stx, phase, scheme_null, 0); - - o = describe_bindings(o, di, 0, NULL, always); - - if (o) { - r = scheme_get_sized_byte_string_output(o, &len); - /* make sure error buffer is allocated large enough: */ - scheme_ensure_max_symbol_length(len); - return r; - } - else - return ""; -} - -static void add_scopes_mapped_names(Scheme_Scope_Set *scopes, Scheme_Object *shifts, Scheme_Hash_Table *mapped) -{ - int retry; - Scheme_Hash_Tree *ht; - Scheme_Object *key, *val, *l, *pes; - intptr_t i, j; - Scheme_Scope *scope; - Scheme_Scope_Set *binding_scopes; - Scheme_Module_Phase_Exports *pt; - - do { - retry = 0; - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - if (scope->bindings) { - if (SCHEME_VECTORP(scope->bindings)) { - if (scope_subset(SCHEME_VEC_BINDING_SCOPES(scope->bindings), scopes)) - scheme_hash_set(mapped, SCHEME_VEC_BINDING_KEY(scope->bindings), scheme_true); - } else { - /* Check table of symbols */ - if (SCHEME_RPAIRP(scope->bindings)) - ht = (Scheme_Hash_Tree *)SCHEME_CAR(scope->bindings); - else { - STX_ASSERT(SCHEME_HASHTRP(scope->bindings)); - ht = (Scheme_Hash_Tree *)scope->bindings; - } - j = -1; - while ((j = scheme_hash_tree_next(ht, j)) != -1) { - scheme_hash_tree_index(ht, j, &key, &val); - l = val; - if (l) { - if (SCHEME_PAIRP(l)) { - if (scope_subset(SCHEME_BINDING_SCOPES(l), scopes)) - scheme_hash_set(mapped, key, scheme_true); - } else { - while (!SCHEME_NULLP(l)) { - STX_ASSERT(SCHEME_MPAIRP(l)); - if (scope_subset(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), scopes)) { - scheme_hash_set(mapped, key, scheme_true); - break; - } - l = SCHEME_CDR(l); - } - } - } - } - } - - /* Check list of shared-binding tables */ - if (SCHEME_RPAIRP(scope->bindings)) - l = SCHEME_CDR(scope->bindings); - else - l = NULL; - while (l) { - STX_ASSERT(SCHEME_RPAIRP(l)); - binding_scopes = SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); - if (scope_subset(binding_scopes, scopes)) { - pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (PES_UNMARSHAL_DESCP(pes)) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(pes)[0])) { - unmarshal_module_context_additions(NULL, shifts, pes, binding_scopes, l); - retry = 1; - } - } else { - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - if (!pt->ht) - scheme_populate_pt_ht(pt); - for (j = pt->ht->size; j--; ) { - if (pt->ht->vals[j]) { - val = unmarshal_key_adjust(pt->ht->keys[j], pes); - if (val) - scheme_hash_set(mapped, val, scheme_true); - } - } - } - } - l = SCHEME_CDR(l); - } - } - i = scope_set_next(scopes, i); - } - } while (retry); -} - -/******************** lookup ********************/ - -static Scheme_Object *do_stx_lookup(Scheme_Stx *stx, Scheme_Scope_Set *scopes, - Scheme_Scope_Set *check_subset, - GC_CAN_IGNORE int *_exact_match, - GC_CAN_IGNORE int *_ambiguous, - GC_CAN_IGNORE Scheme_Object **_sole_result) -/* the core lookup operation: walk through an identifier's marks, - and walk through the bindings attached to each of those marks */ -{ - int j, invalid, matches = 0; - intptr_t i; - Scheme_Object *key, *val, *result_best_so_far, *l, *pes; - Scheme_Scope *scope; - Scheme_Scope_Set *binding_scopes, *best_so_far; - Scheme_Module_Phase_Exports *pt; - - do { - invalid = 0; /* to indicate retry if we unmarshal */ - best_so_far = NULL; - result_best_so_far = NULL; - - i = scope_set_next(scopes, -1); - while ((i != -1) && !invalid) { - scope_set_index(scopes, i, &key, &val); - - scope = (Scheme_Scope *)key; - if (scope->bindings) { - for (j = 0; j < 2; j++) { - l = scope->bindings; - if (!j) { - if (SCHEME_VECTORP(l)) { - if (!SAME_OBJ(SCHEME_VEC_BINDING_KEY(l), stx->val)) - l = NULL; - /* l is NULL or a vector-form binding */ - } else if (SCHEME_HASHTRP(l)) { - l = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)l, stx->val); - /* l is a pair or mlist */ - } else { - STX_ASSERT(SCHEME_RPAIRP(l)); - l = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)SCHEME_CAR(l), - stx->val); - /* l is a pair or mlist */ - } - } else { - if (SCHEME_RPAIRP(l)) - l = SCHEME_CDR(l); - else - l = NULL; - /* l is an rlist */ - } - - /* l can have many different forms; see above */ - - while (l && !SCHEME_NULLP(l) && !invalid) { - if (SCHEME_VECTORP(l)) - binding_scopes = SCHEME_VEC_BINDING_SCOPES(l); - else if (SCHEME_PAIRP(l)) - binding_scopes = SCHEME_BINDING_SCOPES(l); - else { - STX_ASSERT(SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)); - binding_scopes = SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); - } - - if (j) { - STX_ASSERT(SCHEME_RPAIRP(l)); - pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (PES_UNMARSHAL_DESCP(pes)) { - /* Not a pes; an unmarshal */ - if (SCHEME_TRUEP(SCHEME_VEC_ELS(pes)[0])) { - /* Need unmarshal --- but only if the scope set is relevant */ - if (scope_subset(binding_scopes, scopes)) { - /* unmarshal and note that we must restart */ - unmarshal_module_context_additions(stx, NULL, pes, binding_scopes, l); - invalid = 1; - /* Shouldn't encounter this on a second pass: */ - STX_ASSERT(!check_subset); - } - } - binding_scopes = NULL; - } else { - /* Check for id in pes */ - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - scheme_populate_pt_ht(pt); - } - - if (!scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, pes))) - binding_scopes = NULL; - } - } - - if (binding_scopes && scope_subset(binding_scopes, scopes)) { - if (check_subset && !scope_subset(binding_scopes, check_subset)) { - if (_ambiguous) *_ambiguous = 1; - return NULL; /* ambiguous */ - } - matches++; - if (!best_so_far - || ((scope_set_count(binding_scopes) > scope_set_count(best_so_far)) - && (!check_subset - || (scope_set_count(binding_scopes) == scope_set_count(check_subset))))) { - best_so_far = binding_scopes; - if (SCHEME_VECTORP(l)) - result_best_so_far = SCHEME_VEC_BINDING_VAL(l); - else if (SCHEME_PAIRP(l)) - result_best_so_far = SCHEME_BINDING_VAL(l); - else { - STX_ASSERT(SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)); - result_best_so_far = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - } - STX_ASSERT(SCHEME_FALSEP(result_best_so_far) - || SCHEME_MODIDXP(result_best_so_far) - || SCHEME_PAIRP(result_best_so_far) - || SCHEME_VECTORP(result_best_so_far) - || SCHEME_SYMBOLP(result_best_so_far) - || SCHEME_MPAIRP(result_best_so_far)); - if (_exact_match) *_exact_match = (scope_set_count(binding_scopes) == scope_set_count(scopes)); - } - } - - if (SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)) - l = SCHEME_CDR(l); - else - l = NULL; - } - } - } - - i = scope_set_next(scopes, i); - } - } while (invalid); - - if (!best_so_far) - return NULL; - - if (check_subset) - return result_best_so_far; - else { - if (matches == 1) - *_sole_result = result_best_so_far; - else - *_sole_result = NULL; - return (Scheme_Object *)best_so_far; - } -} - -static Scheme_Object *do_stx_lookup_nonambigious(Scheme_Stx *stx, Scheme_Object *phase, - GC_CAN_IGNORE int *_exact_match, - GC_CAN_IGNORE int *_ambiguous, - Scheme_Scope_Set **_binding_scopes) -{ - Scheme_Scope_Set *scopes, *best_set; - Scheme_Object *multi_scopes, *result; - - multi_scopes = stx->scopes->multi_scopes; - - /* Loop for top-level fallbacks: */ - while (1) { - scopes = extract_scope_set_from_scope_list(stx->scopes->simple_scopes, multi_scopes, phase); - - best_set = (Scheme_Scope_Set *)do_stx_lookup(stx, scopes, - NULL, - _exact_match, _ambiguous, - &result); - if (best_set) { - if (_binding_scopes) *_binding_scopes = best_set; - - if (!result) { - /* Find again, this time checking to ensure no ambiguity: */ - result = do_stx_lookup(stx, scopes, - best_set, - _exact_match, _ambiguous, - NULL); - } - - if (!result && SCHEME_FALLBACKP(multi_scopes)) { - if (_ambiguous) *_ambiguous = 0; - if (_exact_match) *_exact_match = 0; - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - } else - return result; - } else if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - else - return NULL; - } -} - -static Scheme_Object *apply_accumulated_shifts(Scheme_Object *result, Scheme_Object *prev_shifts, - GC_CAN_IGNORE Scheme_Object **_insp, - GC_CAN_IGNORE Scheme_Object **nominal_modidx, - Scheme_Stx *stx, Scheme_Object *orig_name, Scheme_Object *phase) -/* Adjust result to take the `free-id=?` chain into account: adjust a - `#f` result to add in the original name, or adjust a module name - for modidx shifts */ -{ - Scheme_Object *o; - - if (SCHEME_VECTORP(result)) { - if (!SCHEME_NULLP(prev_shifts) - || (SCHEME_FALSEP(SCHEME_VEC_ELS(result)[0]) - && !SAME_OBJ(stx->val, orig_name))) { - /* Clone result vector */ - o = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(o)[0] = SCHEME_VEC_ELS(result)[0]; - SCHEME_VEC_ELS(o)[1] = SCHEME_VEC_ELS(result)[1]; - SCHEME_VEC_ELS(o)[2] = SCHEME_VEC_ELS(result)[2]; - result = o; - - if (SCHEME_FALSEP(SCHEME_VEC_ELS(result)[1])) - SCHEME_VEC_ELS(result)[1] = stx->val; - - for (; !SCHEME_NULLP(prev_shifts); prev_shifts = SCHEME_CDR(prev_shifts)) { - o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), SCHEME_VEC_ELS(result)[0], _insp, NULL); - SCHEME_VEC_ELS(result)[0] = o; - if (nominal_modidx) { - o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), *nominal_modidx, NULL, NULL); - *nominal_modidx = o; - } - } - } - } else if (SCHEME_FALSEP(result) && !SAME_OBJ(stx->val, orig_name)) { - result = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(result)[0] = scheme_false; - SCHEME_VEC_ELS(result)[1] = stx->val; - SCHEME_VEC_ELS(result)[2] = phase; - } - - if (_insp && *_insp && SCHEME_SYMBOLP(*_insp)) - *_insp = scheme_false; /* wasn't shifted, for some reason */ - - return result; -} - -#define BINDING_CACHE_SIZE 32 - -typedef struct Binding_Cache_Entry { - Scheme_Stx *id; - Scheme_Object *phase; - Scheme_Object *result; - Scheme_Scope_Set *binding_scopes; - Scheme_Object *insp_desc; - Scheme_Object *free_eq; -} Binding_Cache_Entry; - -static void init_binding_cache(void) -{ - REGISTER_SO(binding_cache_table); - binding_cache_table = MALLOC_N_ATOMIC(Binding_Cache_Entry, BINDING_CACHE_SIZE); -} - -static void clear_binding_cache(void) -{ - binding_cache_len = 0; -} - -static void clear_binding_cache_for(Scheme_Object *sym) -{ - clear_binding_cache(); -} - -static void clear_binding_cache_stx(Scheme_Stx *stx) -{ - Binding_Cache_Entry *binding_cache = binding_cache_table; - int i; - - for (i = binding_cache_len; i--; ) { - if (SAME_OBJ(binding_cache[i].id, stx)) - binding_cache[i].id = NULL; - } -} - -XFORM_NONGCING static int find_in_binding_cache(Scheme_Stx *id, Scheme_Object *phase) -{ - Binding_Cache_Entry *binding_cache = binding_cache_table; - int i; - - for (i = binding_cache_len; i--; ) { - if (SAME_OBJ(binding_cache[i].id, id) - && SAME_OBJ(binding_cache[i].phase, phase)){ - return i; - } - } - - return -1; -} - -XFORM_NONGCING static void save_in_binding_cache(Scheme_Stx *id, Scheme_Object *phase, - Scheme_Object *result, - Scheme_Scope_Set *binding_scopes, Scheme_Object *insp_desc, - Scheme_Object *free_eq) -{ - Binding_Cache_Entry *binding_cache = binding_cache_table; - int i; - - if (binding_cache_len < BINDING_CACHE_SIZE) { - i = binding_cache_len++; - } else if (binding_cache_pos < binding_cache_len) { - i = binding_cache_pos; - binding_cache_pos++; - } else { - i = 0; - binding_cache_pos = 1; - } - - binding_cache[i].id = id; - binding_cache[i].phase = phase; - binding_cache[i].result = result; - binding_cache[i].binding_scopes = binding_scopes; - binding_cache[i].insp_desc = insp_desc; - binding_cache[i].free_eq = free_eq; -} - -Scheme_Object *scheme_stx_lookup_w_nominal(Scheme_Object *o, Scheme_Object *phase, - int stop_at_free_eq, - GC_CAN_IGNORE int *_exact_match, - GC_CAN_IGNORE int *_ambiguous, - GC_CAN_IGNORE Scheme_Scope_Set **_binding_scopes, - GC_CAN_IGNORE Scheme_Object **_insp, /* access-granting inspector */ - GC_CAN_IGNORE Scheme_Object **nominal_modidx, /* how it was imported */ - GC_CAN_IGNORE Scheme_Object **nominal_name, /* imported as name */ - GC_CAN_IGNORE Scheme_Object **src_phase, /* phase level of import from nominal modidx */ - GC_CAN_IGNORE Scheme_Object **nominal_src_phase) /* phase level of export from nominal modidx */ -/* Result is either a representation of a local binding (probably a symbol), - a vector of the form (vector ), or - #f */ -{ - Scheme_Stx *stx; - Scheme_Object *result, *insp_desc; - Scheme_Scope_Set *binding_scopes; - Scheme_Object *free_eq, *prev_shifts = scheme_null, *orig_name; - Scheme_Hash_Table *free_id_seen = NULL; - int cache_pos; - - STX_ASSERT(SCHEME_STXP(o)); - STX_ASSERT(nominal_name || (!src_phase && !nominal_src_phase)); - - orig_name = SCHEME_STX_VAL(o); - - while (1) { /* loop for `free-identifier=?` chains */ - stx = (Scheme_Stx *)o; - - if (_ambiguous) *_ambiguous = 0; - - if (nominal_name) - cache_pos = -1; - else - cache_pos = find_in_binding_cache(stx, phase); - - if (cache_pos >= 0) { - /* must extract from cache before a GC: */ - GC_CAN_IGNORE Binding_Cache_Entry *binding_cache = binding_cache_table; - - result = binding_cache[cache_pos].result; - binding_scopes = binding_cache[cache_pos].binding_scopes; - if (_insp) *_insp = binding_cache[cache_pos].insp_desc; - free_eq = binding_cache[cache_pos].free_eq; - - if (_binding_scopes) - *_binding_scopes = binding_scopes; - if (_exact_match) { - if (binding_scopes - && (scope_set_count(binding_scopes) == scope_set_count(extract_scope_set(stx, phase)))) - *_exact_match = 1; - else - *_exact_match = 0; - } - - if (free_eq) { - if (!stop_at_free_eq) { - o = SCHEME_CAR(free_eq); - phase = SCHEME_CDR(free_eq); - /* recur to handle `free-identifier=?` chain */ - if (!free_id_seen) - free_id_seen = scheme_make_hash_table(SCHEME_hash_ptr); - if (scheme_eq_hash_get(free_id_seen, o)) - return scheme_false; /* found a cycle */ - scheme_hash_set(free_id_seen, o, scheme_true); - prev_shifts = scheme_make_pair(stx->shifts, prev_shifts); - continue; - } else - return apply_accumulated_shifts(result, prev_shifts, _insp, NULL, - stx, orig_name, phase); - } else - return apply_accumulated_shifts(result, prev_shifts, _insp, NULL, - stx, orig_name, phase); - } - - binding_scopes = NULL; - if (_exact_match) *_exact_match = 0; - - result = do_stx_lookup_nonambigious(stx, phase, - _exact_match, _ambiguous, - &binding_scopes); - - if (_binding_scopes) *_binding_scopes = binding_scopes; - - if (!result) { - save_in_binding_cache(stx, phase, scheme_false, - NULL, NULL, NULL); - return apply_accumulated_shifts(scheme_false, scheme_null, NULL, NULL, - stx, orig_name, phase); - } - - /* - `result` can be: - - a symbol for a lexical binding, - - a pair, modidx, or #f for a module import - - a vector for a pes (shared export table from a module) - - a mutable pair of the above plus an identifier for a `free-identifier=?` link - */ - if (SCHEME_MPAIRP(result)) { - free_eq = SCHEME_CDR(result); - result = SCHEME_CAR(result); - } else - free_eq = NULL; - - if (!SCHEME_SYMBOLP(result)) { - /* Generate a result vector: (vector ) */ - Scheme_Object *l = result; - - result = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(result)[1] = stx->val; - SCHEME_VEC_ELS(result)[2] = scheme_make_integer(0); - - if (nominal_modidx) *nominal_modidx = NULL; - if (nominal_name) *nominal_name = NULL; - if (src_phase) *src_phase = NULL; - if (nominal_src_phase) *nominal_src_phase = NULL; - - if (SCHEME_FALSEP(l)) { - /* top-level bound */ - SCHEME_VEC_ELS(result)[0] = scheme_false; - /* phase of defn must be binding phase: */ - SCHEME_VEC_ELS(result)[2] = phase; - insp_desc = scheme_false; - } else if (SCHEME_MODIDXP(l)) { - SCHEME_VEC_ELS(result)[0] = l; - insp_desc = scheme_false; - } else if (SCHEME_PAIRP(l)) { - /* A list for a module import */ - Scheme_Object *modidx; - Scheme_Object *exportname = SCHEME_VEC_ELS(result)[1]; - Scheme_Object *mod_phase = SCHEME_VEC_ELS(result)[2]; - - extract_module_binding_parts(l, - SCHEME_VEC_ELS(result)[2], - &insp_desc, - &modidx, /* required */ - &exportname, /* required */ - nominal_modidx, - &mod_phase, /* required */ - nominal_name, - src_phase, - nominal_src_phase); - - SCHEME_VEC_ELS(result)[0] = modidx; - SCHEME_VEC_ELS(result)[1] = exportname; - SCHEME_VEC_ELS(result)[2] = mod_phase; - } else { - /* A vector for a pes */ - Scheme_Module_Phase_Exports *pt; - Scheme_Object *pos, *mod; - - STX_ASSERT(SCHEME_VECTORP(l)); - - pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(l)[1]; - insp_desc = SCHEME_VEC_ELS(l)[4]; - - pos = scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, l)); - - if (pt->provide_srcs) { - mod = pt->provide_srcs[SCHEME_INT_VAL(pos)]; - if (SCHEME_FALSEP(mod)) - mod = SCHEME_VEC_ELS(l)[0]; - else - mod = scheme_modidx_shift(mod, - pt->src_modidx, - SCHEME_VEC_ELS(l)[0]); - } else - mod = SCHEME_VEC_ELS(l)[0]; - - SCHEME_VEC_ELS(result)[0] = mod; - - if (nominal_modidx) - *nominal_modidx = SCHEME_VEC_ELS(l)[0]; - - SCHEME_VEC_ELS(result)[1] = pt->provide_src_names[SCHEME_INT_VAL(pos)]; - - if (nominal_name) - *nominal_name = pt->provides[SCHEME_INT_VAL(pos)]; - - if (pt->provide_src_phases) - SCHEME_VEC_ELS(result)[2] = scheme_make_integer(pt->provide_src_phases[SCHEME_INT_VAL(pos)]); - - if (src_phase) *src_phase = SCHEME_VEC_ELS(l)[2]; - if (nominal_src_phase) *nominal_src_phase = pt->phase_index; - } - - if (nominal_name && !*nominal_name) - *nominal_name = stx->val; - if (nominal_modidx && !*nominal_modidx) - *nominal_modidx = SCHEME_VEC_ELS(result)[0]; - if (src_phase && !*src_phase) - *src_phase = scheme_make_integer(0); - if (nominal_src_phase && !*nominal_src_phase) - *nominal_src_phase = SCHEME_VEC_ELS(result)[2]; - - l = apply_modidx_shifts(stx->shifts, SCHEME_VEC_ELS(result)[0], &insp_desc, NULL); - SCHEME_VEC_ELS(result)[0] = l; - - if (nominal_modidx) { - l = apply_modidx_shifts(stx->shifts, *nominal_modidx, NULL, NULL); - *nominal_modidx = l; - } - } else - insp_desc = scheme_false; - - save_in_binding_cache(stx, phase, result, - binding_scopes, insp_desc, - free_eq); - - if (_insp) *_insp = insp_desc; - - if (!free_eq || stop_at_free_eq) - return apply_accumulated_shifts(result, prev_shifts, _insp, nominal_modidx, - stx, orig_name, phase); - - /* Recur for `free-identifier=?` mapping */ - phase = SCHEME_CDR(free_eq); - o = SCHEME_CAR(free_eq); - prev_shifts = scheme_make_pair(stx->shifts, prev_shifts); - - if (!free_id_seen) - free_id_seen = scheme_make_hash_table(SCHEME_hash_ptr); - if (scheme_eq_hash_get(free_id_seen, o)) - return scheme_false; /* found a cycle */ - } -} - -Scheme_Object *scheme_stx_lookup(Scheme_Object *o, Scheme_Object *phase) -{ - return scheme_stx_lookup_w_nominal(o, phase, 0, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL); -} - -Scheme_Object *scheme_stx_lookup_stop_at_free_eq(Scheme_Object *o, Scheme_Object *phase, int *_exact_match) -{ - return scheme_stx_lookup_w_nominal(o, phase, 1, _exact_match, NULL, NULL, NULL, NULL, NULL, NULL, NULL); -} - -Scheme_Object *scheme_stx_lookup_exact(Scheme_Object *o, Scheme_Object *phase) -{ - int exact; - Scheme_Object *b; - - b = scheme_stx_lookup_w_nominal(o, phase, 1, &exact, NULL, NULL, NULL, NULL, NULL, NULL, NULL); - - if (!exact) - return scheme_false; - else - return b; -} - -void scheme_populate_pt_ht(Scheme_Module_Phase_Exports * pt) { - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - Scheme_Hash_Table *ht; - int i; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - for (i = pt->num_provides; i--; ) { - scheme_hash_set(ht, pt->provides[i], scheme_make_integer(i)); - } - pt->ht = ht; - } -} - -void scheme_add_binding_copy(Scheme_Object *o, Scheme_Object *from_o, Scheme_Object *phase) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - STX_ASSERT(SCHEME_STXP(o)); - STX_ASSERT(SCHEME_STXP(from_o)); - - /* Passing an identifier as the "value" adds to the existing binding, - instead of replacing it: */ - add_binding(stx->val, phase, extract_scope_set(stx, phase), from_o, NULL, NULL); -} - -/******************** module contexts ********************/ - -/* A module context is a convenience record to track the scopes, - inspector, etc. that are related to expanding a `module` form */ - -Scheme_Object *scheme_make_module_context(Scheme_Object *insp, - Scheme_Object *shift_or_shifts, - Scheme_Object *debug_name) -{ - Scheme_Object *vec, *bx; - Scheme_Object *body_scopes; - Scheme_Object *intro_multi_scope; - - /* The `intro_multi_scope` is the home for all bindings in a given context. - It is added to any form that emerges into a module context via - macro expansion. - In the case of top-level forms, this context is sometimes stripped away - and replaced with a new top-level context. */ - intro_multi_scope = new_multi_scope(debug_name); - body_scopes = scheme_make_pair(intro_multi_scope, scheme_null); - - /* An additional scope identifies the original module home of an - identifier (i.e., not added to things that are macro-introduced - into the module context). The root scope serves to unify all - top-level contexts. */ - if (SCHEME_FALSEP(debug_name)) - body_scopes = scheme_make_pair(root_scope, body_scopes); - else - body_scopes = scheme_make_pair(scheme_new_scope(SCHEME_STX_MODULE_SCOPE), body_scopes); - - if (!shift_or_shifts) - shift_or_shifts = scheme_null; - else if (!SCHEME_PAIRP(shift_or_shifts) && !SCHEME_NULLP(shift_or_shifts)) - shift_or_shifts = scheme_make_pair(shift_or_shifts, scheme_null); - - /* A module context consists of - - A list of scopes, multi-scopes, and (cons multi-scope phase) that - corresponds to the module body - - A phase used for extracting scopes (not a shift for the intro scope) - - An inspector - - A list of module-index shifts - - A multi-scope for binding/introduction (included in body scopes) - - A list of scopes that correspond to macro uses; - this scopes must be stripped away from a definition - */ - - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = body_scopes; - SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(0); - SCHEME_VEC_ELS(vec)[2] = insp; - SCHEME_VEC_ELS(vec)[3] = shift_or_shifts; - SCHEME_VEC_ELS(vec)[4] = intro_multi_scope; - bx = scheme_box((Scheme_Object *)empty_scope_set); - SCHEME_VEC_ELS(vec)[5] = bx; - - return vec; -} - -Scheme_Scope_Set *scheme_module_context_scopes(Scheme_Object *mc) -{ - Scheme_Object *body_scopes = SCHEME_VEC_ELS(mc)[0], *scope; - Scheme_Object *phase = SCHEME_VEC_ELS(mc)[1]; - Scheme_Scope_Set *scopes = empty_scope_set; - - while (!SCHEME_NULLP(body_scopes)) { - scope = SCHEME_CAR(body_scopes); - if (!SCHEME_SCOPEP(scope)) { - if (SCHEME_PAIRP(scope)) - scope = extract_simple_scope_from_shifted(scope, phase); - else - scope = extract_simple_scope(scope, phase); - } - if (scope) - scopes = scope_set_set(scopes, scope, scheme_true); - body_scopes = SCHEME_CDR(body_scopes); - } - - return scopes; -} - -Scheme_Object *scheme_module_context_frame_scopes(Scheme_Object *mc, Scheme_Object *keep_intdef_scopes) -{ - Scheme_Object *scopes; - - scopes = (Scheme_Object *)scheme_module_context_scopes(mc); - - if (keep_intdef_scopes) - scopes = add_intdef_scopes_of(scopes, keep_intdef_scopes); - - return scopes; -} - -void scheme_module_context_add_use_site_scope(Scheme_Object *mc, Scheme_Object *use_site_scope) -{ - Scheme_Scope_Set *use_site_scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]); - - STX_ASSERT(SCHEME_SCOPEP(use_site_scope)); - - use_site_scopes = scope_set_set(use_site_scopes, use_site_scope, scheme_true); - - SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]) = (Scheme_Object *)use_site_scopes; -} - -Scheme_Object *scheme_module_context_use_site_frame_scopes(Scheme_Object *mc) -{ - Scheme_Scope_Set *use_site_scopes; - - use_site_scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]); - if (SAME_OBJ(use_site_scopes, empty_scope_set)) - return NULL; - else - return make_vector3(scheme_false, (Scheme_Object *)use_site_scopes, scheme_false); -} - -Scheme_Object *scheme_module_context_inspector(Scheme_Object *mc) -{ - return SCHEME_VEC_ELS(mc)[2]; -} - -void scheme_module_context_add_mapped_symbols(Scheme_Object *mc, Scheme_Hash_Table *mapped) -{ - add_scopes_mapped_names(scheme_module_context_scopes(mc), - SCHEME_VEC_ELS(mc)[3], /* list of shifts */ - mapped); -} - -Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *phase) -{ - Scheme_Object *vec; - - /* Clones the module context, but with a different convenience phase */ - - if (SAME_OBJ(SCHEME_VEC_ELS(mc)[1], phase)) - return mc; - - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(mc)[0]; - SCHEME_VEC_ELS(vec)[1] = phase; - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(mc)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(mc)[3]; - SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(mc)[4]; - SCHEME_VEC_ELS(vec)[5] = SCHEME_VEC_ELS(mc)[5]; - - return vec; -} - -static Scheme_Object *adjust_module_context_except(Scheme_Object *stx, Scheme_Object *mc, Scheme_Object *skip, - int mode) -{ - Scheme_Object *body_scopes = SCHEME_VEC_ELS(mc)[0], *scope; - Scheme_Object *phase = SCHEME_VEC_ELS(mc)[1]; - - while (!SCHEME_NULLP(body_scopes)) { - scope = SCHEME_CAR(body_scopes); - if (skip && SAME_OBJ(scope, skip)) - scope = NULL; - else if (!SCHEME_SCOPEP(scope)) { - if (SCHEME_PAIRP(scope)) - scope = extract_simple_scope_from_shifted(scope, phase); - else - scope = extract_simple_scope(scope, phase); - } - if (scope) - stx = scheme_stx_adjust_scope(stx, scope, phase, mode); - body_scopes = SCHEME_CDR(body_scopes); - } - - if (mode == SCHEME_STX_ADD) - stx = scheme_stx_add_shifts(stx, SCHEME_VEC_ELS(mc)[3]); - - return stx; -} - -Scheme_Object *scheme_stx_add_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_ADD); -} - -Scheme_Object *scheme_stx_remove_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_REMOVE); -} - -Scheme_Object *scheme_stx_push_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - Scheme_Object *intro_multi_scope = SCHEME_VEC_ELS(mc)[4]; - - stx = scheme_stx_adjust_scope(stx, intro_multi_scope, scheme_make_integer(0), SCHEME_STX_PUSH); - stx = adjust_module_context_except(stx, mc, intro_multi_scope, SCHEME_STX_ADD); - - return stx; -} - -Scheme_Object *scheme_stx_push_introduce_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - Scheme_Object *intro_multi_scope = SCHEME_VEC_ELS(mc)[4]; - - return scheme_stx_adjust_scope(stx, intro_multi_scope, scheme_make_integer(0), SCHEME_STX_PUSH); -} - -Scheme_Object *scheme_stx_add_module_frame_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return scheme_stx_add_module_context(stx, mc); -} - -Scheme_Object *scheme_stx_introduce_to_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - Scheme_Object *multi_scope; - - STX_ASSERT(SCHEME_VECTORP(mc)); - - multi_scope = SCHEME_VEC_ELS(mc)[4]; - - return scheme_stx_add_scope(stx, multi_scope, scheme_make_integer(0)); -} - -Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_REMOVE); -} - -Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Scheme_Object *mc, int mode) -{ - Scheme_Scope_Set *scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]); - - return scheme_stx_adjust_scopes(stx, scopes, SCHEME_VEC_ELS(mc)[1], mode); -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *replace_scopes(Scheme_Object *stx, Scheme_Object *remove_scopes, - Scheme_Object *add_scopes, Scheme_Object *phase); - -static Scheme_Object *replace_scopes_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *stx = (Scheme_Object *)p->ku.k.p1; - Scheme_Object *remove_scopes = (Scheme_Object *)p->ku.k.p2; - Scheme_Object *add_scopes = (Scheme_Object *)p->ku.k.p3; - Scheme_Object *phase = (Scheme_Object *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - return replace_scopes(stx, remove_scopes, add_scopes, phase); -} -#endif - -static Scheme_Object *replace_scopes(Scheme_Object *stx, Scheme_Object *remove_scopes, - Scheme_Object *add_scopes, Scheme_Object *phase) -{ - Scheme_Object *sym, *sym2, *content; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)stx; - p->ku.k.p2 = (void *)remove_scopes; - p->ku.k.p3 = (void *)add_scopes; - p->ku.k.p4 = (void *)phase; - - return scheme_handle_stack_overflow(replace_scopes_k); - } - } -#endif - - if (SCHEME_STXP(stx)) { - int mutate = 0; - - scheme_stx_content(stx); - if (HAS_SUBSTX(SCHEME_STX_VAL(stx))) { - content = replace_scopes(SCHEME_STX_VAL(stx), remove_scopes, add_scopes, phase); - sym = scheme_datum_to_syntax(scheme_false, scheme_false, stx, 0, 0); - } else { - sym = stx; - content = SCHEME_STX_VAL(stx); - } - - if (SCHEME_SCOPEP(remove_scopes) || SCHEME_MULTI_SCOPEP(remove_scopes)) - sym2 = stx_adjust_scope(sym, remove_scopes, phase, SCHEME_STX_REMOVE, &mutate); - else - sym2 = stx_adjust_scopes(sym, (Scheme_Scope_Set *)remove_scopes, phase, SCHEME_STX_REMOVE, &mutate); - - if (!SAME_OBJ(sym, sym2) || !SAME_OBJ(content, SCHEME_STX_VAL(stx))) { - if (SCHEME_SCOPEP(add_scopes) || SCHEME_MULTI_SCOPEP(add_scopes)) - sym2 = stx_adjust_scope(sym2, add_scopes, phase, SCHEME_STX_ADD, &mutate); - else - sym2 = stx_adjust_scopes(sym2, (Scheme_Scope_Set *)add_scopes, phase, SCHEME_STX_ADD, &mutate); - return scheme_datum_to_syntax(content, stx, sym2, 0, 2); - } else - return stx; - } else if (SCHEME_NULLP(stx)) { - return stx; - } else if (SCHEME_PAIRP(stx)) { - sym = replace_scopes(SCHEME_CAR(stx), remove_scopes, add_scopes, phase); - sym2 = replace_scopes(SCHEME_CDR(stx), remove_scopes, add_scopes, phase); - if (SAME_OBJ(sym, SCHEME_CAR(stx)) && SAME_OBJ(sym2, SCHEME_CDR(stx))) - return stx; - else - return scheme_make_pair(sym, sym2); - } else { - scheme_signal_error("internal error: unsupported form for replace_scopes()"); - return NULL; - } -} - -Scheme_Object *scheme_stx_from_module_context_to_generic(Scheme_Object *stx, Scheme_Object *mc) -{ - /* remove the introduction scope, which should be everywhere, and - map the other scopes to the root scope */ - Scheme_Object *scopes; - stx = scheme_stx_remove_scope(stx, SCHEME_VEC_ELS(mc)[4], SCHEME_VEC_ELS(mc)[1]); - scopes = (Scheme_Object *)scheme_module_context_scopes(mc); - return replace_scopes(stx, scopes, root_scope, SCHEME_VEC_ELS(mc)[1]); -} - -Scheme_Object *scheme_stx_from_generic_to_module_context(Scheme_Object *stx, Scheme_Object *mc) -{ - /* map the root scope to the body scope, and add the introduction - scope everywhere */ - Scheme_Object *scopes; - scopes = (Scheme_Object *)scheme_module_context_scopes(mc); - stx = replace_scopes(stx, root_scope, scopes, SCHEME_VEC_ELS(mc)[1]); - return scheme_stx_introduce_to_module_context(stx, mc); -} - -void scheme_extend_module_context(Scheme_Object *mc, /* (vector ...) */ - Scheme_Object *ctx, /* binding context (as stx) or NULL */ - Scheme_Object *modidx, /* actual source module */ - Scheme_Object *localname, /* name in local context */ - Scheme_Object *exname, /* name in definition context */ - Scheme_Object *nominal_mod, /* nominal source module */ - Scheme_Object *nominal_ex, /* nominal import before local renaming */ - intptr_t mod_phase, /* phase of source defn */ - Scheme_Object *src_phase, /* nominal import phase */ - Scheme_Object *nom_phase) /* nominal export phase */ -{ - Scheme_Scope_Set *scopes; - - if (ctx) - scopes = extract_scope_set((Scheme_Stx *)ctx, SCHEME_VEC_ELS(mc)[1]); - else - scopes = scheme_module_context_scopes(mc); - - do_add_module_binding(scopes, localname, SCHEME_VEC_ELS(mc)[1], - modidx, exname, scheme_make_integer(mod_phase), - SCHEME_VEC_ELS(mc)[2], - nominal_mod, nominal_ex, - src_phase, nom_phase, - NULL, NULL); -} - -void scheme_extend_module_context_with_shared(Scheme_Object *mc, /* (vector ) or (cons ) */ - Scheme_Object *modidx, - Scheme_Module_Phase_Exports *pt, - Scheme_Object *prefix, /* a sybmol; not included in `excepts` keys */ - Scheme_Hash_Tree *excepts, /* NULL => empty */ - Scheme_Object *src_phase, /* nominal import phase */ - Scheme_Object *context, - Scheme_Object *replace_at) -/* create a bulk import */ -{ - Scheme_Object *phase, *pes, *insp_desc, *unmarshal_info; - Scheme_Scope_Set *scopes; - - if (SCHEME_VECTORP(mc)) { - phase = SCHEME_VEC_ELS(mc)[1]; - insp_desc = SCHEME_VEC_ELS(mc)[2]; - } else { - phase = SCHEME_CAR(mc); - insp_desc = SCHEME_CDR(mc); - } - - if (context) - scopes = extract_scope_set((Scheme_Stx *)context, phase); - else - scopes = scheme_module_context_scopes(mc); - - unmarshal_info = make_unmarshal_info(pt->phase_index, prefix, (Scheme_Object *)excepts); - - pes = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(pes)[0] = modidx; - SCHEME_VEC_ELS(pes)[1] = (Scheme_Object *)pt; - SCHEME_VEC_ELS(pes)[2] = src_phase; - SCHEME_VEC_ELS(pes)[3] = unmarshal_info; - SCHEME_VEC_ELS(pes)[4] = (insp_desc ? insp_desc : scheme_false); - - if (replace_at) { - SCHEME_BINDING_VAL(SCHEME_CAR(replace_at)) = pes; - } else { - add_binding(NULL, phase, scopes, pes, NULL, NULL); - } -} - -static Scheme_Object *make_unmarshal_info(Scheme_Object *phase, - Scheme_Object *prefix, - Scheme_Object *excepts) -{ - Scheme_Object *unmarshal_info; - - /* unmarshal_info = phase - . | (cons phase adjusts) - adjusts = prefix - . | (cons excepts-ht prefix) - . | excepts-list - excepts-ht = (hasheq symbol #t ... ...) - */ - unmarshal_info = prefix; - if (excepts) { - if (SCHEME_FALSEP(unmarshal_info)) - unmarshal_info = excepts; - else - unmarshal_info = scheme_make_pair(excepts, prefix); - } - if (SCHEME_FALSEP(unmarshal_info)) - unmarshal_info = phase; - else - unmarshal_info = scheme_make_pair(phase, unmarshal_info); - - return unmarshal_info; -} - -XFORM_NONGCING static Scheme_Object *extract_unmarshal_phase(Scheme_Object *unmarshal_info) -{ - if (SCHEME_PAIRP(unmarshal_info)) - return SCHEME_CAR(unmarshal_info); - else - return unmarshal_info; -} - -XFORM_NONGCING static Scheme_Object *extract_unmarshal_prefix(Scheme_Object *unmarshal_info) -{ - if (SCHEME_PAIRP(unmarshal_info)) { - unmarshal_info = SCHEME_CDR(unmarshal_info); - if (SCHEME_PAIRP(unmarshal_info)) - unmarshal_info = SCHEME_CDR(unmarshal_info); - - if (SCHEME_SYMBOLP(unmarshal_info)) - return unmarshal_info; - else - return scheme_false; - } else - return scheme_false; -} - -static Scheme_Hash_Tree *unmarshal_vector_to_excepts(Scheme_Object *unmarshal_info, - Scheme_Object *ht_target, - int ht_to_cdr) -{ - Scheme_Hash_Tree *ht = empty_hash_tree; - intptr_t i; - - for (i = SCHEME_VEC_SIZE(unmarshal_info); i--; ) { - if (SCHEME_SYMBOLP(SCHEME_VEC_ELS(unmarshal_info)[i])) - ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(unmarshal_info)[i], scheme_true); - } - - if (ht_to_cdr) - SCHEME_CDR(ht_target) = (Scheme_Object *)ht; - else - SCHEME_CAR(ht_target) = (Scheme_Object *)ht; - - return ht; -} - -static Scheme_Hash_Tree *extract_unmarshal_excepts(Scheme_Object *unmarshal_info) -{ - if (SCHEME_PAIRP(unmarshal_info)) { - Scheme_Object *ht_target = unmarshal_info; - int ht_to_cdr = 1; - - unmarshal_info = SCHEME_CDR(unmarshal_info); - if (SCHEME_PAIRP(unmarshal_info)) { - ht_target = unmarshal_info; - ht_to_cdr = 0; - unmarshal_info = SCHEME_CAR(unmarshal_info); - } - - if (SCHEME_HASHTRP(unmarshal_info)) - return (Scheme_Hash_Tree *)unmarshal_info; - else if (SCHEME_VECTORP(unmarshal_info)) { - /* Hash table was converted to a vector in a marshaled unmarshal request */ - return unmarshal_vector_to_excepts(unmarshal_info, ht_target, ht_to_cdr); - } else - return NULL; - } else - return NULL; -} - -static Scheme_Object *unmarshal_excepts_to_vector(Scheme_Object *unmarshal_info) -{ - Scheme_Hash_Tree *ht; - - ht = extract_unmarshal_excepts(unmarshal_info); - if (ht) { - intptr_t i = -1, j = 0; - Scheme_Object *vec, *key, *val; - - vec = scheme_make_vector(ht->count, NULL); - - while ((i = scheme_hash_tree_next(ht, i)) != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - SCHEME_VEC_ELS(vec)[j++] = key; - } - - sort_vector_symbols(vec); - - return make_unmarshal_info(extract_unmarshal_phase(unmarshal_info), - extract_unmarshal_prefix(unmarshal_info), - vec); - } - - return unmarshal_info; -} - -static Scheme_Object *unmarshal_lookup_adjust(Scheme_Object *sym, Scheme_Object *pes) -{ - Scheme_Hash_Tree *excepts; - Scheme_Object *prefix; - - if (!SCHEME_SYMBOLP(sym)) - return scheme_false; - - excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); - prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - - if (SCHEME_TRUEP(prefix) && !SCHEME_SYM_WEIRDP(sym)) { - int plen = SCHEME_SYM_LEN(prefix); - if (SCHEME_SYM_LEN(sym) >= plen) { - if (!scheme_strncmp(SCHEME_SYM_VAL(sym), SCHEME_SYM_VAL(prefix), plen)) { - char buf[64], *b; - int slen = SCHEME_SYM_LEN(sym) - plen; - if (slen < 64) - b = buf; - else - b = scheme_malloc_atomic(slen+1); - memcpy(b, SCHEME_SYM_VAL(sym) + plen, slen+1); - sym = scheme_intern_exact_symbol(b, slen); - } else - return scheme_false; /* so lookup will fail */ - } else - return scheme_false; - } - - if (excepts) { - if (scheme_eq_hash_tree_get(excepts, sym)) - return scheme_false; /* so lookup will fail */ - } - - return sym; -} - -static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pes) -{ - Scheme_Hash_Tree *excepts; - Scheme_Object *prefix; - - excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); - prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - - if (excepts && scheme_eq_hash_tree_get(excepts, sym)) - return NULL; - - if (SCHEME_TRUEP(prefix)) { - int plen = SCHEME_SYM_LEN(prefix); - int slen = SCHEME_SYM_LEN(sym) + plen; - char buf[64], *b; - - if (slen < 64) - b = buf; - else - b = scheme_malloc_atomic(slen+1); - memcpy(b, SCHEME_SYM_VAL(prefix), plen); - memcpy(b+plen, SCHEME_SYM_VAL(sym), SCHEME_SYM_LEN(sym)+1); - sym = scheme_intern_exact_symbol(b, slen); - } - - return sym; -} - -static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *shifts, - Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at) -{ - Scheme_Object *req_modidx, *modidx, *unmarshal_info, *context, *src_phase, *pt_phase, *bind_phase; - Scheme_Object *insp, *req_insp; - Scheme_Hash_Table *export_registry; - - req_modidx = SCHEME_VEC_ELS(vec)[0]; - insp = SCHEME_VEC_ELS(vec)[3]; - req_insp = insp; - - if (stx) - modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry); - else - modidx = apply_modidx_shifts(shifts, req_modidx, &insp, &export_registry); - - src_phase = SCHEME_VEC_ELS(vec)[1]; - unmarshal_info = SCHEME_VEC_ELS(vec)[2]; - pt_phase = extract_unmarshal_phase(unmarshal_info); - - SCHEME_VEC_ELS(vec)[0] = scheme_false; - SCHEME_VEC_ELS(vec)[1] = scheme_false; - SCHEME_VEC_ELS(vec)[2] = scheme_false; - - if (SCHEME_FALSEP(src_phase) || SCHEME_FALSEP(pt_phase)) - bind_phase = scheme_false; - else - bind_phase = scheme_bin_plus(src_phase, pt_phase); - - context = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); - context = scheme_stx_adjust_scopes(context, scopes, bind_phase, SCHEME_STX_ADD); - - scheme_do_module_context_unmarshal(modidx, req_modidx, context, - bind_phase, pt_phase, src_phase, - extract_unmarshal_prefix(unmarshal_info), - extract_unmarshal_excepts(unmarshal_info), - export_registry, insp, req_insp, - replace_at); -} - -Scheme_Object *scheme_module_context_to_stx(Scheme_Object *mc, Scheme_Object *orig_src) -{ - Scheme_Object *plain, *o, *for_intro, *vec; - - plain = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); - - if (orig_src) - o = scheme_datum_to_syntax(scheme_true, scheme_false, orig_src, 0, 0); - else - o = scheme_stx_add_module_context(plain, mc); - - /* Keep track of intro scope separately: */ - for_intro = scheme_stx_introduce_to_module_context(plain, mc); - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = o; - SCHEME_VEC_ELS(vec)[1] = for_intro; - return scheme_datum_to_syntax(vec, scheme_false, scheme_false, 0, 0); -} - -Scheme_Object *scheme_stx_to_module_context(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Object *vec, *shifts, *a, *body_scopes, *phase = scheme_make_integer(0); - Scheme_Object *intro_multi_scope = NULL; - - if (SCHEME_VECTORP(stx->val) && (SCHEME_VEC_SIZE(stx->val) >= 2)) { - (void)scheme_stx_content((Scheme_Object *)stx); /* propagate */ - intro_multi_scope = SCHEME_VEC_ELS(stx->val)[1]; - stx = (Scheme_Stx *)SCHEME_VEC_ELS(stx->val)[0]; - } - - shifts = stx->shifts; - if (SCHEME_VECTORP(shifts)) - shifts = SCHEME_VEC_ELS(shifts)[0]; - shifts = shifts_to_non_source(shifts); - - phase = scheme_make_integer(0); - - body_scopes = scheme_null; - a = stx->scopes->multi_scopes; - if (SCHEME_FALLBACKP(a)) - a = SCHEME_FALLBACK_FIRST(a); - for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) { - if (SAME_OBJ(phase, SCHEME_CDR(SCHEME_CAR(a)))) - body_scopes = scheme_make_pair(SCHEME_CAR(SCHEME_CAR(a)), body_scopes); - else - body_scopes = scheme_make_pair(SCHEME_CAR(a), body_scopes); - } - { - Scheme_Object *key, *val; - intptr_t i; - i = -1; - while ((i = scope_set_next(stx->scopes->simple_scopes, i)) != -1) { - scope_set_index(stx->scopes->simple_scopes, i, &key, &val); - body_scopes = scheme_make_pair(key, body_scopes); - } - } - - if (intro_multi_scope) { - stx = (Scheme_Stx *)intro_multi_scope; - if (!SCHEME_FALLBACKP(stx->scopes->multi_scopes) - && SCHEME_PAIRP(stx->scopes->multi_scopes)) { - intro_multi_scope = SCHEME_CAR(SCHEME_CAR(stx->scopes->multi_scopes)); - } - } - if (!intro_multi_scope) { - /* This won't happen for a well-formed representation */ - intro_multi_scope = new_multi_scope(scheme_false); - } - - vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = body_scopes; - SCHEME_VEC_ELS(vec)[1] = phase; - SCHEME_VEC_ELS(vec)[2] = scheme_false; /* not sure this is right */ - SCHEME_VEC_ELS(vec)[3] = shifts; - SCHEME_VEC_ELS(vec)[4] = intro_multi_scope; - a = scheme_box((Scheme_Object *)empty_scope_set); - SCHEME_VEC_ELS(vec)[5] = a; - - return vec; -} - -int scheme_stx_equal_module_context(Scheme_Object *other_stx, Scheme_Object *mc_or_stx) -{ - Scheme_Stx *stx; - Scheme_Object *phase; - - if (SCHEME_STXP(mc_or_stx)) { - stx = (Scheme_Stx *)mc_or_stx; - if (SCHEME_VECTORP(stx->val) && (SCHEME_VEC_SIZE(stx->val) >= 2)) - stx = (Scheme_Stx *)SCHEME_VEC_ELS(stx->val)[0]; - } else { - Scheme_Object *plain; - plain = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); - mc_or_stx = scheme_stx_add_module_context(plain, mc_or_stx); - stx = (Scheme_Stx *)mc_or_stx; - } - - phase = scheme_make_integer(0); - - return scopes_equal(extract_scope_set((Scheme_Stx *)other_stx, phase), - extract_scope_set(stx, phase)); -} - -/******************** lazy syntax-object unmarshaling ********************/ - -void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i) -{ - Scheme_Object *stx; - int c; - - stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]), - (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair)); - rp->stxes[i] = stx; - c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair)); - --c; - SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c); - if (!c) { - SCHEME_CDR(rp->delay_info_rpair) = NULL; - rp->delay_info_rpair = NULL; - } -} - -Scheme_Object *scheme_delayed_shift(Scheme_Object **o, intptr_t i) -{ - Scheme_Object *shift, *v; - Resolve_Prefix *rp; - int mutate = 0; - - shift = o[0]; - - if (!shift) return scheme_false; /* happens only with corrupted .zo! */ - - rp = (Resolve_Prefix *)o[1]; - - v = rp->stxes[i]; - - if (SCHEME_INTP(v)) { - scheme_load_delayed_syntax(rp, i); - v = rp->stxes[i]; - } - - v = do_stx_add_shift(v, shift, &mutate); - - shift = SCHEME_VEC_ELS(shift)[3]; - if (!SCHEME_FALSEP(shift)) { - /* need to propagate the inspector for dye packs, too */ - (void)set_false_insp((Scheme_Object *)v, shift, &mutate); - } - - return v; -} - -Scheme_Object *scheme_stx_force_delayed(Scheme_Object *stx) -{ - if (SCHEME_RPAIRP(stx)) - return scheme_load_delayed_code(SCHEME_INT_VAL(SCHEME_CAR(stx)), - (struct Scheme_Load_Delay *)SCHEME_CDR(stx)); - else - return stx; -} - -/*========================================================================*/ -/* stx comparison */ -/*========================================================================*/ - -int scheme_stx_could_bind(Scheme_Object *bind_id, Scheme_Object *ref_id, Scheme_Object *phase) -{ - Scheme_Stx *bind = (Scheme_Stx *)bind_id; - Scheme_Stx *ref = (Scheme_Stx *)ref_id; - - if (!SAME_OBJ(ref->val, bind->val)) - return 0; - - return scope_subset(extract_scope_set(bind, phase), - extract_scope_set(ref, phase)); -} - -int scheme_stx_free_eq3(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase) -{ - Scheme_Object *a_bind, *b_bind; - - STX_ASSERT(SCHEME_STXP(a)); - STX_ASSERT(SCHEME_STXP(b)); - - a_bind = scheme_stx_lookup(a, a_phase); - b_bind = scheme_stx_lookup(b, b_phase); - - if (SCHEME_SYMBOLP(a_bind) || SCHEME_SYMBOLP(b_bind)) { - return SAME_OBJ(a_bind, b_bind); - } - - if (SCHEME_FALSEP(a_bind) || SCHEME_FALSEP(b_bind)) { - /* A `#f` binding can be equal to a vector that starts `#f` */ - if (SCHEME_FALSEP(a_bind)) - a = SCHEME_STX_VAL(a); - else if (SCHEME_VECTORP(a_bind) - && SCHEME_FALSEP(SCHEME_VEC_ELS(a_bind)[0]) - && SAME_OBJ(SCHEME_VEC_ELS(a_bind)[2], a_phase)) { - a = SCHEME_VEC_ELS(a_bind)[1]; - a_bind = scheme_false; - } - - if (SCHEME_FALSEP(b_bind)) - b = SCHEME_STX_VAL(b); - else if (SCHEME_VECTORP(b_bind) - && SCHEME_FALSEP(SCHEME_VEC_ELS(b_bind)[0]) - && SAME_OBJ(SCHEME_VEC_ELS(b_bind)[2], b_phase)) { - b = SCHEME_VEC_ELS(b_bind)[1]; - b_bind = scheme_false; - } - - if (SCHEME_FALSEP(a_bind) && SCHEME_FALSEP(b_bind)) - return SAME_OBJ(a, b); - else - return 0; - } - - /* Comparison of names & definition phases is fast, so try that next: */ - if (!SAME_OBJ(SCHEME_VEC_ELS(a_bind)[1], SCHEME_VEC_ELS(b_bind)[1]) - || !SAME_OBJ(SCHEME_VEC_ELS(a_bind)[2], SCHEME_VEC_ELS(b_bind)[2])) { - return 0; - } - - /* Need to compare modidxs: */ - - a_bind = scheme_module_resolve(SCHEME_VEC_ELS(a_bind)[0], 0); - b_bind = scheme_module_resolve(SCHEME_VEC_ELS(b_bind)[0], 0); - - return SAME_OBJ(a_bind, b_bind); -} - -int scheme_stx_free_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) -{ - return scheme_stx_free_eq3(a, b, phase, phase); -} - -int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase) -{ - return scheme_stx_free_eq3(a, b, scheme_make_integer(phase), scheme_make_integer(phase)); -} - -int scheme_stx_free_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase) -{ - return scheme_stx_free_eq3(a, b, scheme_make_integer(0), scheme_make_integer(b_phase)); -} - -Scheme_Object *scheme_stx_get_free_eq_sym(Scheme_Object *a, Scheme_Object *phase) -{ - if (SCHEME_STXP(a)) { - a = scheme_stx_lookup(a, phase); - if (SCHEME_VECTORP(a)) - return SCHEME_VEC_ELS(a)[1]; - else - return a; - } else - return a; -} - -int scheme_stx_env_bound_eq2(Scheme_Object *_a, Scheme_Object *_b, - Scheme_Object *a_phase, Scheme_Object *b_phase) -{ - Scheme_Stx *a = (Scheme_Stx *)_a; - Scheme_Stx *b = (Scheme_Stx *)_b; - - STX_ASSERT(SCHEME_STXP(_a)); - STX_ASSERT(SCHEME_STXP(_b)); - - if (!SAME_OBJ(a->val, b->val)) - return 0; - - return scopes_equal(extract_scope_set(a, a_phase), extract_scope_set(b, b_phase)); -} - -int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) -{ - return scheme_stx_env_bound_eq2(a, b, phase, phase); -} - -Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source) -{ - /* Look for the oldest "self" modidx that has a resolution: */ - Scheme_Object *l = ((Scheme_Stx *)stx)->shifts, *a, *src; - Scheme_Hash_Table *export_registry; - - if (SCHEME_VECTORP(l)) - l = SCHEME_VEC_ELS(l)[0]; - - l = scheme_reverse(l); - - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - if (SCHEME_VECTORP(a) && !non_source_shift(a)) { - src = SCHEME_VEC_ELS(a)[1]; - - if (SCHEME_MODIDXP(src)) { - if (SCHEME_FALSEP(((Scheme_Modidx *)src)->path)) { - src = apply_modidx_shifts(((Scheme_Stx *)stx)->shifts, src, - NULL, &export_registry); - if (!SCHEME_FALSEP(((Scheme_Modidx *)src)->path) - || !SCHEME_FALSEP(((Scheme_Modidx *)src)->resolved)) { - if (resolve) { - src = scheme_module_resolve(src, 0); - if (export_registry && source) { - a = scheme_hash_get(export_registry, src); - if (a) - src = ((Scheme_Module_Exports *)a)->modsrc; - } - src = SCHEME_PTR_VAL(src); - } - return src; - } - } - } - } - - l = SCHEME_CDR(l); - } - - return scheme_false; -} - /*========================================================================*/ /* stx and lists */ /*========================================================================*/ @@ -5287,1520 +279,27 @@ int scheme_stx_proper_list_length(Scheme_Object *list) return -1; } -#ifdef DO_STACK_CHECK -static Scheme_Object *flatten_syntax_list_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *l = (Scheme_Object *)p->ku.k.p1; - int *r = (int *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return scheme_flatten_syntax_list(l, r); -} -#endif - -Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) -{ - Scheme_Object *l = lst, *lflat, *first, *last; - - /* Check whether the list ends in a null: */ - while (SCHEME_PAIRP(l)) { - l = SCHEME_CDR(l); - } - - if (SCHEME_NULLP(l)) { - /* Yes. We're done: */ - if (islist) - *islist = 1; - return lst; - } - - if (islist) - *islist = 0; - - lflat = NULL; - - /* Is it a syntax object, possibly with a list? */ - if (SCHEME_STXP(l)) { - l = scheme_stx_content(l); - if (SCHEME_NULLP(l) || SCHEME_PAIRP(l)) { - int lislist; - - lflat = NULL; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - int *r; - - r = (int *)scheme_malloc_atomic(sizeof(int)); - - p->ku.k.p1 = (void *)l; - p->ku.k.p2 = (void *)r; - - lflat = scheme_handle_stack_overflow(flatten_syntax_list_k); - - lislist = *r; - } - } -#endif - - if (!lflat) - lflat = scheme_flatten_syntax_list(l, &lislist); - - if (!lislist) { - /* Not a list. Can't flatten this one. */ - return lst; - } - } else { - /* Not a syntax list. No chance of flattening. */ - return lst; - } - } else { - /* No. No chance of flattening, then. */ - return lst; - } - - /* Need to flatten, end with lflat */ - - if (islist) - *islist = 1; - - first = last = NULL; - for (l = lst; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - Scheme_Object *p; - p = scheme_make_pair(SCHEME_CAR(l), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - if (last) - SCHEME_CDR(last) = lflat; - else - first = lflat; - - return first; -} - -/*========================================================================*/ -/* wraps->datum */ -/*========================================================================*/ - -static void sort_added_scopes(Scheme_Object *scopes, int added) -{ - Scheme_Object **a, *l; - int i; - - if (!added) - return; - - a = MALLOC_N(Scheme_Object *, added); - for (i = 0, l = scopes; i < added; i++, l = SCHEME_CDR(l)) { - a[i] = SCHEME_CAR(l); - } - - sort_scope_array(a, added); - - for (i = 0, l = scopes; i < added; i++, l = SCHEME_CDR(l)) { - SCHEME_CAR(l) = a[i]; - } -} - -static void add_reachable_scopes(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt) -{ - intptr_t i, added = 0; - Scheme_Object *key, *val; - - i = -1; - while ((i = scope_set_next(scopes, i)) != -1) { - scope_set_index(scopes, i, &key, &val); - if (!scheme_eq_hash_get(mt->reachable_scopes, key)) { - scheme_hash_set(mt->conditionally_reachable_scopes, key, NULL); - scheme_hash_set(mt->reachable_scopes, key, scheme_true); - val = scheme_make_pair(key, mt->reachable_scope_stack); - mt->reachable_scope_stack = val; - added++; - } - } - - sort_added_scopes(mt->reachable_scope_stack, added); -} - -static void add_conditional_as_reachable(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt) -{ - int added = 0; - intptr_t i; - Scheme_Object *key, *val; - - STX_ASSERT(SCHEME_SCOPE_SETP(scopes)); - - i = -1; - while ((i = scope_set_next(scopes, i)) != -1) { - scope_set_index(scopes, i, &key, &val); - if (SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key) - && scheme_eq_hash_get(mt->conditionally_reachable_scopes, key) - && !scheme_eq_hash_get(mt->reachable_scopes, key)) { - scheme_hash_set(mt->conditionally_reachable_scopes, key, NULL); - scheme_hash_set(mt->reachable_scopes, key, scheme_true); - val = scheme_make_pair(key, mt->reachable_scope_stack); - mt->reachable_scope_stack = val; - added++; - } - } - - sort_added_scopes(mt->reachable_scope_stack, added); -} - -static void add_reachable_multi_scope(Scheme_Object *ms, Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)ms; - Scheme_Scope_Set *binding_scopes = empty_scope_set; - Scheme_Object *scope; - int j; - - for (j = ht->size; j--; ) { - scope = ht->vals[j]; - if (scope) { - if (!MULTI_SCOPE_METAP(ht->keys[j])) { - if (!scheme_eq_hash_get(mt->reachable_scopes, scope) - && !scheme_eq_hash_get(mt->conditionally_reachable_scopes, scope)) { - /* This scope is reachable via its multi-scope, but it only - matters if it's reachable through a binding (otherwise it - can be re-generated later). We don't want to keep a scope - that can be re-generated, because pruning it makes - compilation more deterministic relative to other - compilations that involve a shared module. If the scope - itself has any bindings, then we count it as reachable - through a binding (which is an approxmation, because other scopes - in the binding may be unreachable, but it seems good enough for - determinism). */ - scheme_hash_set(mt->conditionally_reachable_scopes, scope, scheme_true); - if (((Scheme_Scope *)scope)->bindings) - binding_scopes = scope_set_set(binding_scopes, scope, scheme_true); - } - } - } - } - - if (!SAME_OBJ(binding_scopes, empty_scope_set)) - add_conditional_as_reachable(binding_scopes, mt); -} - -static void add_reachable_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marshal_Tables *mt) -{ - Scheme_Object *l; - - while (1) { - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - add_reachable_multi_scope(SCHEME_CAR(SCHEME_CAR(l)), mt); - } - - if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - else - break; - } -} - -static Scheme_Object *any_unreachable_scope(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt, - int check_conditionals) -{ - intptr_t i; - int saw_conditional = 0; - Scheme_Object *key, *val; - - i = -1; - while ((i = scope_set_next(scopes, i)) != -1) { - scope_set_index(scopes, i, &key, &val); - if (!scheme_eq_hash_get(mt->reachable_scopes, key)) { - if (check_conditionals && scheme_eq_hash_get(mt->conditionally_reachable_scopes, key)) - saw_conditional = 1; - else - return key; - } - } - - if (saw_conditional) { - /* since this binding is reachable, move any conditional to reachable */ - add_conditional_as_reachable(scopes, mt); - } - - return NULL; -} - -static void possiblly_reachable_free_id(Scheme_Object *val, /* mpair or stx */ - Scheme_Scope_Set *scopes, - Scheme_Marshal_Tables *mt) -{ - Scheme_Stx *free_id = (Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)); - Scheme_Object *unreachable_scope, *l; - Scheme_Hash_Table *ht; - - if (SCHEME_MPAIRP(val)) - free_id = (Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)); - else - free_id = (Scheme_Stx *)val; - - STX_ASSERT(SCHEME_STXP((Scheme_Object *)free_id)); - - unreachable_scope = any_unreachable_scope(scopes, mt, 1); - - if (!unreachable_scope) { - /* causes the free-id mapping's scopes to be reachable: */ - (void)wraps_to_datum(free_id, mt); - } else { - /* the mapping will become reachable only if `unreachable_scope` becomes reachable */ - if (!mt->pending_reachable_ids) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - mt->pending_reachable_ids = ht; - } - l = scheme_eq_hash_get(mt->pending_reachable_ids, unreachable_scope); - if (!l) l = scheme_null; - scheme_hash_set(mt->pending_reachable_ids, unreachable_scope, - scheme_make_pair(scheme_make_pair((Scheme_Object *)free_id, - (Scheme_Object *)scopes), - l)); - } -} - -static int all_symbols(Scheme_Object **a, int c) -{ - while (c--) { - if (!SCHEME_SYMBOLP(a[c])) - return 0; - } - return 1; -} - -static int all_reals(Scheme_Object **a, int c) -{ - while (c--) { - if (!SCHEME_REALP(a[c])) - return 0; - } - return 1; -} - -Scheme_Object **scheme_extract_sorted_keys(Scheme_Object *tree) -{ - intptr_t j, i, count; - Scheme_Object **a, *key; - - if (SCHEME_HASHTRP(tree)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)tree; - - count = ht->count; - if (!count) - return NULL; - - a = MALLOC_N(Scheme_Object *, count); - - j = -1; - i = 0; - while ((j = scheme_hash_tree_next(ht, j)) != -1) { - scheme_hash_tree_index(ht, j, &key, NULL); - a[i++] = key; - } - - STX_ASSERT(i == count); - } else { - Scheme_Hash_Table *t = (Scheme_Hash_Table *)tree; - - count = t->count; - - if (!count) - return NULL; - - a = MALLOC_N(Scheme_Object *, count); - j = 0; - - for (i = t->size; i--; ) { - if (t->vals[i]) { - a[j++] = t->keys[i]; - } - } - - STX_ASSERT(j == count); - } - - if (SCHEME_SYMBOLP(a[0]) && all_symbols(a, count)) - sort_symbol_array(a, count); - else if (SCHEME_SCOPEP(a[0])) - sort_scope_array(a, count); - else if (all_reals(a, count)) - sort_number_array(a, count); - else - return NULL; - - return a; -} - -void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt) -{ - Scheme_Scope *scope; - Scheme_Object *l, *val, *key, **sorted_keys, *pesl; - Scheme_Hash_Tree *ht; - intptr_t j, count; - - /* For each scope, recur on `free-identifier=?` mappings */ - while (!SCHEME_NULLP(mt->reachable_scope_stack)) { - scope = (Scheme_Scope *)SCHEME_CAR(mt->reachable_scope_stack); - mt->reachable_scope_stack = SCHEME_CDR(mt->reachable_scope_stack); - - if (scope->bindings) { - val = scope->bindings; - if (SCHEME_VECTORP(val)) { - add_conditional_as_reachable(SCHEME_VEC_BINDING_SCOPES(val), mt); - l = SCHEME_VEC_BINDING_VAL(val); - if (SCHEME_MPAIRP(l)) { - /* It's a free-id mapping: */ - possiblly_reachable_free_id(l, SCHEME_VEC_BINDING_SCOPES(val), mt); - } - } else { - if (SCHEME_RPAIRP(val)) { - ht = (Scheme_Hash_Tree *)SCHEME_CAR(val); - pesl = SCHEME_CDR(val); - } else { - STX_ASSERT(SCHEME_HASHTRP(val)); - ht = (Scheme_Hash_Tree *)val; - pesl = NULL; - } - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht); - count = ht->count; - for (j = 0; j < count; j++) { - key = sorted_keys[j]; - val = scheme_hash_tree_get(ht, key); - l = val; - if (SCHEME_PAIRP(l)) { - add_conditional_as_reachable(SCHEME_BINDING_SCOPES(l), mt); - val = SCHEME_BINDING_VAL(l); - if (SCHEME_MPAIRP(val)) { - /* It's a free-id mapping: */ - possiblly_reachable_free_id(val, SCHEME_BINDING_SCOPES(l), mt); - } - } else { - STX_ASSERT(SCHEME_MPAIRP(l)); - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - add_conditional_as_reachable(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), mt); - val = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (SCHEME_MPAIRP(val)) { - /* It's a free-id mapping: */ - possiblly_reachable_free_id(val, SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), mt); - } - } - } - } - while (pesl) { - STX_ASSERT(SCHEME_RPAIRP(pesl)); - val = SCHEME_CAR(pesl); - STX_ASSERT(SCHEME_PAIRP(val)); - add_conditional_as_reachable((Scheme_Scope_Set *)SCHEME_CAR(val), mt); - pesl = SCHEME_CDR(pesl); - } - } - } - - /* Check for any free-id mappings whose reachbility depended on `scope`: */ - if (mt->pending_reachable_ids) { - l = scheme_eq_hash_get(mt->pending_reachable_ids, (Scheme_Object *)scope); - if (l) { - scheme_hash_set(mt->pending_reachable_ids, (Scheme_Object *)scope, NULL); - while (!SCHEME_NULLP(l)) { - val = SCHEME_CAR(l); - possiblly_reachable_free_id(SCHEME_CAR(val), (Scheme_Scope_Set *)SCHEME_CDR(val), mt); - l = SCHEME_CDR(l); - } - } - } - } - - /* Adjust mapping so that each scope maps to its relative position: */ - { - int i; - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)mt->reachable_scopes); - for (j = mt->reachable_scopes->count, i = 0; j--; i++) { - STX_ASSERT(SCHEME_SCOPEP(sorted_keys[j])); - scheme_hash_set(mt->reachable_scopes, sorted_keys[j], scheme_make_integer(i)); - } - } -} - -static Scheme_Object *intern_one(Scheme_Object *v, Scheme_Hash_Table *ht) -{ - Scheme_Object *result; - - result = scheme_hash_get(ht, v); - if (!result) { - result = scheme_make_marshal_shared(v); - scheme_hash_set(ht, v, result); - } - - return result; -} - -static Scheme_Object *intern_tails(Scheme_Object *l, Scheme_Hash_Table *ht) -{ - Scheme_Object *r, *result; - - r = scheme_null; - do { - if (SCHEME_NULLP(l)) - result = scheme_null; - else - result = scheme_hash_get(ht, l); - if (!result) { - r = scheme_make_pair(SCHEME_CAR(l), r); - l = SCHEME_CDR(l); - } - } while (!result); - - while (!SCHEME_NULLP(r)) { - result = scheme_make_pair(SCHEME_CAR(r), result); - l = scheme_make_pair(SCHEME_CAR(r), l); - result = scheme_make_marshal_shared(result); - scheme_hash_set(ht, l, result); - r = SCHEME_CDR(r); - } - - return result; -} - -static Scheme_Object *intern_fallback_tails(Scheme_Object *l, Scheme_Hash_Table *ht) -{ - Scheme_Object *r, *result; - - r = scheme_null; - do { - if (!SCHEME_FALLBACKP(l)) - result = l; - else - result = scheme_hash_get(ht, l); - if (!result) { - r = scheme_make_pair(SCHEME_FALLBACK_FIRST(l), r); - l = SCHEME_FALLBACK_REST(l); - } - } while (!result); - - while (!SCHEME_NULLP(r)) { - result = make_fallback_pair(SCHEME_CAR(r), result); - l = make_fallback_pair(SCHEME_CAR(r), l); - result = scheme_make_marshal_shared(result); - scheme_hash_set(ht, l, result); - r = SCHEME_CDR(r); - } - - return result; -} - -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif -#include "../gc2/my_qsort.c" -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - -static int compare_scopes_from_multi(Scheme_Scope *a, Scheme_Scope *b) -{ - Scheme_Scope_With_Owner *ao, *bo; - - ao = (Scheme_Scope_With_Owner *)a; - bo = (Scheme_Scope_With_Owner *)b; - - if (SAME_OBJ(ao->owner_multi_scope, bo->owner_multi_scope)) { - if (SCHEME_FALSEP(ao->phase)) - return 1; - else if (SCHEME_FALSEP(bo->phase)) - return 1; - else if (scheme_bin_lt(ao->phase, bo->phase)) - return 1; - else - return -1; - } else { - Scheme_Object *na, *nb; - na = scheme_hash_get((Scheme_Hash_Table *)ao->owner_multi_scope, scheme_void); - nb = scheme_hash_get((Scheme_Hash_Table *)bo->owner_multi_scope, scheme_void); - STX_ASSERT(MULTI_SCOPE_META_HASHEDP(na)); - STX_ASSERT(MULTI_SCOPE_META_HASHEDP(nb)); - na = SCHEME_CDR(na); - nb = SCHEME_CDR(nb); - STX_ASSERT(SCHEME_REALP(na)); - STX_ASSERT(SCHEME_REALP(nb)); - if (scheme_bin_lt(na, nb)) - return 1; - else if (scheme_bin_lt(nb, na)) - return -1; - else - return 0; - } -} - -static int compare_scopes(const void *_a, const void *_b) -{ - Scheme_Scope *a = *(Scheme_Scope **)_a; - Scheme_Scope *b = *(Scheme_Scope **)_b; - - STX_ASSERT(SCHEME_SCOPEP(a)); - STX_ASSERT(SCHEME_SCOPEP(b)); - - /* Scopes for multi-scopes that were generated late are - ordered before everything else: */ - if (!(a->id >> SCHEME_STX_SCOPE_KIND_SHIFT)) { - STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(a)); - if (b->id >> SCHEME_STX_SCOPE_KIND_SHIFT) - return 1; - STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(b)); - - return compare_scopes_from_multi(a, b); - } else if (!(b->id >> SCHEME_STX_SCOPE_KIND_SHIFT)) { - STX_ASSERT(SCHEME_SCOPE_HAS_OWNER(b)); - return -1; - } - - if (a->id > b->id) - return -1; - else if (a->id < b->id) - return 1; - else - return 0; -} - -static void sort_scope_array(Scheme_Object **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_Object *), compare_scopes); -} - -static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes) -{ - Scheme_Object **a, *r, *key, *val; - intptr_t i, j = 0; - - i = scope_set_count(scopes); - a = MALLOC_N(Scheme_Object *, i); - - i = scope_set_next(scopes, -1); - while (i != -1) { - scope_set_index(scopes, i, &key, &val); - a[j++] = key; - i = scope_set_next(scopes, i); - } - - sort_scope_array(a, j); - - r = scheme_null; - for (i = j; i--; ) { - r = scheme_make_pair(a[i], r); - } - - return r; -} - -static int compare_syms(const void *_a, const void *_b) -{ - Scheme_Object *a = *(Scheme_Object **)_a; - Scheme_Object *b = *(Scheme_Object **)_b; - intptr_t l = SCHEME_SYM_LEN(a), i; - - STX_ASSERT(SCHEME_SYMBOLP(a)); - STX_ASSERT(SCHEME_SYMBOLP(b)); - - if (SCHEME_SYM_LEN(b) < l) - l = SCHEME_SYM_LEN(b); - - for (i = 0; i < l; i++) { - if (SCHEME_SYM_VAL(a)[i] != SCHEME_SYM_VAL(b)[i]) - return (SCHEME_SYM_VAL(a)[i] - SCHEME_SYM_VAL(b)[i]); - } - - return SCHEME_SYM_LEN(a) - SCHEME_SYM_LEN(b); -} - -static void sort_vector_symbols(Scheme_Object *vec) -{ - my_qsort(SCHEME_VEC_ELS(vec), SCHEME_VEC_SIZE(vec), sizeof(Scheme_Object *), compare_syms); -} - -static void sort_symbol_array(Scheme_Object **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_Object *), compare_syms); -} - -static int compare_nums(const void *_a, const void *_b) -/* also allow #fs */ -{ - Scheme_Object *a = *(Scheme_Object **)_a; - Scheme_Object *b = *(Scheme_Object **)_b; - - if (SCHEME_FALSEP(a)) - return -1; - else if (SCHEME_FALSEP(b)) - return 1; - - STX_ASSERT(SCHEME_REALP(a)); - STX_ASSERT(SCHEME_REALP(b)); - - if (scheme_bin_lt(a, b)) - return -1; - else if (scheme_bin_lt(b, a)) - return 1; - else - return 0; -} - -static void sort_number_array(Scheme_Object **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_Object *), compare_nums); -} - -static int compare_vars_at_resolve(const void *_a, const void *_b) -{ - Scheme_IR_Local *a = *(Scheme_IR_Local **)_a; - Scheme_IR_Local *b = *(Scheme_IR_Local **)_b; - return a->resolve.lex_depth - b->resolve.lex_depth; -} - -void scheme_sort_resolve_ir_local_array(Scheme_IR_Local **a, intptr_t count) -{ - my_qsort(a, count, sizeof(Scheme_IR_Local *), compare_vars_at_resolve); -} - -static Scheme_Object *drop_export_registries(Scheme_Object *shifts) -{ - Scheme_Object *l, *a, *vec, *p, *first = scheme_null, *last = NULL; - int same_insp; - - if (SCHEME_VECTORP(shifts)) - shifts = SCHEME_VEC_ELS(shifts)[0]; - - for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - same_insp = ((SCHEME_VEC_SIZE(a) <= 2) - || SAME_OBJ(SCHEME_VEC_ELS(a)[2], SCHEME_VEC_ELS(a)[3]) - || SCHEME_FALSEP(SCHEME_VEC_ELS(a)[3])); - if (!SAME_OBJ(SCHEME_VEC_ELS(a)[0], SCHEME_VEC_ELS(a)[1]) - || !same_insp) { - if (same_insp) - vec = scheme_make_vector(2, NULL); - else - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(a)[0]; - SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(a)[1]; - if (!same_insp) { - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(a)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(a)[3]; - } - - p = scheme_make_pair(vec, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - } - - return first; -} - -static void init_identity_map(Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Table *id_map; - id_map = scheme_make_hash_table(SCHEME_hash_ptr); - mt->identity_map = id_map; -} - -static int compare_phased_scopes(const void *_a, const void *_b) -{ - Scheme_Object *a = *(Scheme_Object **)_a; - Scheme_Object *b = *(Scheme_Object **)_b; - - if (SCHEME_FALSEP(a)) - return -1; - else if (SCHEME_FALSEP(b)) - return 1; - else { - STX_ASSERT(SCHEME_REALP(a)); - STX_ASSERT(SCHEME_REALP(b)); - if (scheme_bin_lt(a, b)) - return -1; - else - return 1; - } -} - -static Scheme_Object *multi_scope_to_vector(Scheme_Object *multi_scope, Scheme_Marshal_Tables *mt) -{ - Scheme_Object *vec; - Scheme_Hash_Table *scopes = (Scheme_Hash_Table *)multi_scope; - intptr_t i, j, count; - - if (!mt->identity_map) - init_identity_map(mt); - - vec = scheme_hash_get(mt->identity_map, multi_scope); - if (vec) - return vec; - - /* only keep reachable scopes: */ - count = 0; - for (i = scopes->size; i--; ) { - if (scopes->vals[i]) { - if (!MULTI_SCOPE_METAP(scopes->keys[i])) { - if (scheme_hash_get(mt->reachable_scopes, scopes->vals[i])) - count++; - } - } - } - - vec = scheme_make_vector((2 * count) + 1, scheme_void); - j = 0; - for (i = scopes->size; i--; ) { - if (scopes->vals[i]) { - if (!MULTI_SCOPE_METAP(scopes->keys[i])) { - if (scheme_hash_get(mt->reachable_scopes, scopes->vals[i])) { - SCHEME_VEC_ELS(vec)[j++] = scopes->keys[i]; /* a phase */ - SCHEME_VEC_ELS(vec)[j++] = scopes->vals[i]; /* a scope */ - } - } else { - /* debug name */ - SCHEME_VEC_ELS(vec)[2 * count] = (MULTI_SCOPE_META_HASHEDP(scopes->vals[i]) - ? SCHEME_CAR(scopes->vals[i]) - : scopes->vals[i]); - } - } - } - - my_qsort(SCHEME_VEC_ELS(vec), count, 2 * sizeof(Scheme_Object *), compare_phased_scopes); - - vec = scheme_make_marshal_shared(vec); - - scheme_hash_set(mt->identity_map, multi_scope, vec); - - return vec; -} - -static Scheme_Object *marshal_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marshal_Tables *mt, Scheme_Hash_Table *ht) -{ - Scheme_Object *l, *p, *first, *last; - Scheme_Object *fb_first = scheme_null, *fb_last = NULL; - - while (1) { - l = multi_scopes; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - first = scheme_null; - last = NULL; - - while (!SCHEME_NULLP(l)) { - p = scheme_make_pair(scheme_make_pair(multi_scope_to_vector(SCHEME_CAR(SCHEME_CAR(l)), mt), - SCHEME_CDR(SCHEME_CAR(l))), - scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - l = SCHEME_CDR(l); - } - - first = intern_tails(first, ht); - - if (SCHEME_FALLBACKP(multi_scopes)) - first = make_fallback_pair(first, scheme_false); - - if (fb_last) - SCHEME_FALLBACK_REST(fb_last) = first; - else - fb_first = first; - fb_last = first; - - if (SCHEME_FALLBACKP(multi_scopes)) - multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); - else - break; - } - - if (SCHEME_FALLBACKP(fb_first)) - fb_first = intern_fallback_tails(fb_first, ht); - - return fb_first; -} - -static Scheme_Object *wraps_to_datum(Scheme_Stx *stx, Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Table *ht; - Scheme_Object *shifts, *simples, *multi, *v, *vec; - - if (mt->pass < 0) { - /* This is the pass to discover reachable scopes. */ - add_reachable_scopes(stx->scopes->simple_scopes, mt); - add_reachable_multi_scopes(stx->scopes->multi_scopes, mt); - return scheme_void; - } - - ht = mt->intern_map; - - shifts = intern_tails(drop_export_registries(stx->shifts), ht); - simples = intern_tails(scopes_to_sorted_list(stx->scopes->simple_scopes), ht); - multi = marshal_multi_scopes(stx->scopes->multi_scopes, mt, ht); - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = shifts; - SCHEME_VEC_ELS(vec)[1] = simples; - SCHEME_VEC_ELS(vec)[2] = multi; - - v = scheme_hash_get(ht, vec); - if (!v) { - v = scheme_make_marshal_shared(vec); - scheme_hash_set(ht, vec, v); - } - - return v; -} - -static Scheme_Object *marshal_free_id_info(Scheme_Object *id_plus_phase, Scheme_Marshal_Tables *mt) -{ - Scheme_Stx *stx = (Scheme_Stx *)SCHEME_CAR(id_plus_phase); - - return scheme_make_pair(scheme_make_pair(stx->val, wraps_to_datum(stx, mt)), - SCHEME_CDR(id_plus_phase)); -} - -static Scheme_Object *marshal_bindings(Scheme_Object *l, Scheme_Marshal_Tables *mt) -/* l is a pair for one binding, or an mlist of bindings */ -{ - Scheme_Object *r, *scopes, *v; - - r = scheme_null; - - while (!SCHEME_NULLP(l)) { - if (SCHEME_PAIRP(l)) - scopes = (Scheme_Object *)SCHEME_BINDING_SCOPES(l); - else { - STX_ASSERT(SCHEME_MPAIRP(l)); - scopes = (Scheme_Object *)SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); - } - - if (!any_unreachable_scope((Scheme_Scope_Set *)scopes, mt, 0)) { - if (SCHEME_PAIRP(l)) - v = SCHEME_BINDING_VAL(l); - else - v = SCHEME_BINDING_VAL(SCHEME_CAR(l)); - if (SCHEME_MPAIRP(v)) { - /* has a `free-id=?` equivalence; the marshaled form of a scope's content - cannot contain a syntax object, so we keep just the syntax object's symbol - and scopes */ - v = scheme_make_pair(SCHEME_CAR(v), marshal_free_id_info(SCHEME_CDR(v), mt)); - v = scheme_box(v); /* a box indicates `free-id=?` info */ - } - v = intern_one(v, mt->intern_map); - scopes = intern_tails(scopes_to_sorted_list((Scheme_Scope_Set *)scopes), - mt->intern_map); - r = scheme_make_pair(intern_one(scheme_make_pair(scopes, v), mt->intern_map), r); - } - - if (SCHEME_MPAIRP(l)) - l = SCHEME_CDR(l); - else - l = scheme_null; - } - - if (!SCHEME_NULLP(r)) - r = intern_one(r, mt->intern_map); - - return r; -} - -Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, Scheme_Marshal_Tables *mt) -{ - Scheme_Hash_Tree *ht; - Scheme_Object *v, *l, *r, *l2, *tab, *scopes, *val, **sorted_keys; - intptr_t i, j; - - if (!mt->identity_map) - init_identity_map(mt); - - v = scheme_hash_get(mt->identity_map, m); - if (v) - return v; - - v = ((Scheme_Scope *)m)->bindings; - if (v) { - int count; - - if (SCHEME_VECTORP(v)) { - ht = NULL; - l2 = NULL; - count = 1; - } else { - if (SCHEME_RPAIRP(v)) { - ht = (Scheme_Hash_Tree *)SCHEME_CAR(v); - l2 = SCHEME_CDR(v); - } else { - STX_ASSERT(SCHEME_HASHTRP(v)); - ht = (Scheme_Hash_Tree *)v; - l2 = NULL; - } - count = ht->count; - } - - /* convert to a vector, pruning unreachable and adjusting - encoding of `free-identifier=?` equivalences */ - tab = scheme_make_vector(2 * count, NULL); - j = 0; - if (!ht) { - STX_ASSERT(SCHEME_VECTORP(v)); - r = marshal_bindings(scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(v), - SCHEME_VEC_BINDING_VAL(v)), - mt); - if (SCHEME_NULLP(r)) { - /* no reachable bindings */ - } else { - SCHEME_VEC_ELS(tab)[j++] = SCHEME_VEC_BINDING_KEY(v); - SCHEME_VEC_ELS(tab)[j++] = r; - } - } else { - intptr_t count = ht->count; - sorted_keys = scheme_extract_sorted_keys((Scheme_Object *)ht); - for (i = 0; i < count; i++) { - val = scheme_hash_tree_get(ht, sorted_keys[i]); - r = marshal_bindings(val, mt); - - if (SCHEME_NULLP(r)) { - /* no reachable bindings */ - } else { - STX_ASSERT(j < (2 * count)); - SCHEME_VEC_ELS(tab)[j++] = sorted_keys[i]; - SCHEME_VEC_ELS(tab)[j++] = r; - } - } - } - - if (j < SCHEME_VEC_SIZE(tab)) { - /* shrink vector: */ - r = scheme_make_vector(j, NULL); - memcpy(SCHEME_VEC_ELS(r), SCHEME_VEC_ELS(tab), j * sizeof(Scheme_Object *)); - } else - r = tab; - - /* convert scopes+pes to scope + unmarshal request */ - for (l = l2; l; l = SCHEME_CDR(l)) { - STX_ASSERT(SCHEME_RPAIRP(l)); - v = SCHEME_CDR(SCHEME_CAR(l)); - if (any_unreachable_scope((Scheme_Scope_Set *)SCHEME_CAR(SCHEME_CAR(l)), mt, 0)) { - /* drop unreachable bindings */ - v = NULL; - } else if (PES_BINDINGP(v)) { - l2 = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(l2)[0] = SCHEME_VEC_ELS(v)[0]; - SCHEME_VEC_ELS(l2)[1] = SCHEME_VEC_ELS(v)[2]; - SCHEME_VEC_ELS(l2)[3] = SCHEME_VEC_ELS(v)[4]; - v = unmarshal_excepts_to_vector(SCHEME_VEC_ELS(v)[3]); - SCHEME_VEC_ELS(l2)[2] = v; - v = l2; - } else if (PES_UNMARSHAL_DESCP(v)) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[0])) { - /* never unmarshaled, so keep it */ - } else { - /* this shouldn't happen, because it should have been - replaced on unmarshal, but discard it if we get here */ - v = NULL; - } - } else { - STX_ASSERT(0); - } - if (v) { - scopes = intern_tails(scopes_to_sorted_list((Scheme_Scope_Set *)SCHEME_CAR(SCHEME_CAR(l))), - mt->intern_map); - r = scheme_make_pair(scheme_make_pair(scopes, v), r); - } - } - - v = scheme_make_pair(scheme_make_integer(SCHEME_SCOPE_KIND(m)), r); - } else - v = scheme_make_integer(SCHEME_SCOPE_KIND(m)); - - scheme_hash_set(mt->identity_map, m, v); - - return v; -} - /*========================================================================*/ /* syntax->datum */ /*========================================================================*/ -/* This code can convert a syntax object plus its wraps to something - writeable. In that case, the result is a : - - = | ... - - = (MK (cons (cons ... )) ) - | (MK (cons ... null) ) - | (MK (cons #t ) ) - ; where has no boxes or vectors, and - ; , , and are shared in all elements - = (MK (box ) ) - = (MK (vector ...) ) - = (MK ) - ; where is not a pair, vector, or box - - where - - (MK #f 0) = (cons ) - (MK 0) = (vector ) - (MK #f ) = (vector ) - (MK ) = (vector ) - -*/ - -#define COMMON_EXTRACT_DATUM 0 -#define COMMON_EXTRACT_WRAPS 1 -#define COMMON_EXTRACT_SRCLOC 2 -#define COMMON_EXTRACT_TAINT 3 - -static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_part, int pair_ok) -{ - /* We only share wraps for things constucted with pairs and - atomic (w.r.t. syntax) values. */ - Scheme_Object *v, *wraps, *srcloc, *taint; - - if (SCHEME_PAIRP(a)) { - v = SCHEME_CAR(a); - wraps = SCHEME_CDR(a); - srcloc = scheme_false; - taint = scheme_make_integer(0); - } else if (SCHEME_VECTORP(a)) { - v = SCHEME_VEC_ELS(a)[0]; - wraps = SCHEME_VEC_ELS(a)[1]; - srcloc = SCHEME_VEC_ELS(a)[2]; - if (SCHEME_INTP(srcloc)) { /* an integer is a taint or arm value */ - taint = srcloc; - srcloc = scheme_false; - } else if (SCHEME_VEC_SIZE(a) > 3) - taint = SCHEME_VEC_ELS(a)[3]; - else - taint = scheme_make_integer(0); - } else - return NULL; - - if (SCHEME_PAIRP(v)) { - if (pair_ok && SAME_OBJ(SCHEME_CAR(v), scheme_true)) { - /* A pair with shared wraps for its elements */ - if (get_part == COMMON_EXTRACT_WRAPS) - return wraps; - else if (get_part == COMMON_EXTRACT_SRCLOC) - return srcloc; - else if (get_part == COMMON_EXTRACT_TAINT) - return taint; - else - return SCHEME_CDR(v); - } - } else if (!SCHEME_NULLP(v) && !SCHEME_BOXP(v) && !SCHEME_VECTORP(v) && !SCHEME_HASHTRP(v) && !prefab_p(v)) { - /* It's atomic. */ - if (get_part == COMMON_EXTRACT_WRAPS) - return wraps; - else if (get_part == COMMON_EXTRACT_SRCLOC) - return srcloc; - else if (get_part == COMMON_EXTRACT_TAINT) - return taint; - else - return v; - } - - return NULL; -} - -static void lift_common_wraps(Scheme_Object *l, int cnt, int tail) -{ - Scheme_Object *a; - - while (cnt--) { - a = SCHEME_CAR(l); - a = extract_for_common_wrap(a, COMMON_EXTRACT_DATUM, 1); - SCHEME_CAR(l) = a; - if (cnt) - l = SCHEME_CDR(l); - } - if (tail) { - a = SCHEME_CDR(l); - a = extract_for_common_wrap(a, COMMON_EXTRACT_DATUM, 0); - SCHEME_CDR(l) = a; - } -} - -static Scheme_Object *srcloc_path_to_string(Scheme_Object *p) -{ - Scheme_Object *base, *name, *dir_name; - int isdir; - - name = scheme_split_path(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); - if (SCHEME_PATHP(name) && SCHEME_PATHP(base)) { - dir_name = scheme_split_path(SCHEME_PATH_VAL(base), SCHEME_PATH_LEN(base), &base, &isdir, SCHEME_PLATFORM_PATH_KIND); - if (SCHEME_FALSEP(base)) { - /* Path is file at root, so just keep the whole path */ - return scheme_path_to_char_string(p); - } - if (SCHEME_PATHP(dir_name)) - name = scheme_append_strings(scheme_path_to_char_string(dir_name), - scheme_append_strings(scheme_make_utf8_string("/"), - scheme_path_to_char_string(name))); - else - name = scheme_path_to_char_string(name); - return scheme_append_strings(scheme_make_utf8_string(".../"), name); - } else if (SCHEME_PATHP(name)) - return scheme_path_to_char_string(name); - else - return scheme_false; -} - -static Scheme_Object *convert_prop_val_k(void); - -static Scheme_Object *convert_prop_val(Scheme_Object *val, Scheme_Marshal_Tables *mt, - Scheme_Unmarshal_Tables *ut, - Scheme_Hash_Tree *seen) -/* Encode or decode a property value to encode/decode syntax objects - contained in the value. In encode mode, an exception is raised if any - disallowed value is found. In decoding mode, the result is NULL - if decoding fails. */ -{ -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)val; - p->ku.k.p2 = (void *)mt; - p->ku.k.p3 = (void *)ut; - p->ku.k.p4 = (void *)seen; - - return scheme_handle_stack_overflow(convert_prop_val_k); - } - } -#endif - - if (scheme_hash_tree_get(seen, val)) { - if (mt) - scheme_raise_exn(MZEXN_FAIL, - "write: disallowed cycle within preserved syntax property\n value: %V", - val); - return NULL; - } - - if (SCHEME_PAIRP(val)) { - Scheme_Object *a, *d; - seen = scheme_hash_tree_set(seen, val, scheme_true); - a = convert_prop_val(SCHEME_CAR(val), mt, ut, seen); - d = convert_prop_val(SCHEME_CDR(val), mt, ut, seen); - if (a && d) - return CONS(a, d); - else - return NULL; - } else if (mt ? SCHEME_BOXP(val) : SCHEME_IMMUTABLE_BOXP(val)) { - Scheme_Object *c; - seen = scheme_hash_tree_set(seen, val, scheme_true); - c = convert_prop_val(SCHEME_BOX_VAL(val), mt, ut, seen); - if (c) { - c = scheme_box(c); - SCHEME_SET_IMMUTABLE(c); - return c; - } else - return NULL; - } else if (mt ? SCHEME_VECTORP(val) : SCHEME_IMMUTABLE_VECTORP(val)) { - intptr_t len = SCHEME_VEC_SIZE(val); - if (ut && (len == 2) && SCHEME_TRUEP(SCHEME_VEC_ELS(val)[0])) { - /* A vector that starts #t encodes a syntax object */ - return datum_to_syntax_inner(SCHEME_VEC_ELS(val)[1], - ut, - (Scheme_Stx *)scheme_false, - (Scheme_Stx *)scheme_false, - NULL, - 0); - } else if (len) { - int start, offset; - Scheme_Object *vec, *v; - intptr_t i; - if (mt) { - /* Encode a vector in a vectot that starts #f */ - vec = scheme_make_vector(len+1, scheme_false); - offset = 1; - start = 0; - } else { - /* Decode from a vector that starts #f */ - if (len < 1) return NULL; - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(val)[0])) return NULL; - vec = scheme_make_vector(len-1, scheme_false); - offset = -1; - start = 1; - } - seen = scheme_hash_tree_set(seen, val, scheme_true); - for (i = start; i < len; i++) { - v = convert_prop_val(SCHEME_VEC_ELS(val)[i], mt, ut, seen); - if (!v) - return NULL; - SCHEME_VEC_ELS(vec)[i+offset] = v; - } - SCHEME_SET_IMMUTABLE(vec); - return vec; - } else - return val; - } else if (prefab_p(val)) { - Scheme_Structure *s = (Scheme_Structure *)val; - Scheme_Object *a; - int size = s->stype->num_slots, i; - - seen = scheme_hash_tree_set(seen, val, scheme_true); - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - for (i = 0; i < size; i++) { - a = convert_prop_val(s->slots[i], mt, ut, seen); - if (!a) - return NULL; - s->slots[i] = a; - } - - return (Scheme_Object *)s; - } else if (SCHEME_HASHTRP(val)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)val, *ht2; - Scheme_Object *key, *tval; - mzlonglong i; - - seen = scheme_hash_tree_set(seen, val, scheme_true); - - ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &tval); - tval = convert_prop_val(tval, mt, ut, seen); - if (!tval) - return NULL; - ht2 = scheme_hash_tree_set(ht2, key, tval); - i = scheme_hash_tree_next(ht, i); - } - - return (Scheme_Object *)ht2; - } else if (SCHEME_STXP(val)) { - /* Encode a syntax object in a vectot that starts #t */ - Scheme_Object *v; - if (!mt) - return NULL; - v = syntax_to_datum_inner(val, 1, mt); - v = scheme_make_vector(2, v); - SCHEME_VEC_ELS(v)[0] = scheme_true; - return v; - } else if (SCHEME_BOOLP(val) - || SCHEME_NULLP(val) - || SCHEME_SYMBOLP(val) - || SCHEME_CHARP(val) - || SCHEME_NUMBERP(val) - || SCHEME_BYTE_STRINGP(val) - || SCHEME_CHAR_STRINGP(val) - || SAME_TYPE(SCHEME_TYPE(val), scheme_regexp_type)) { - return val; - } else { - if (mt) - scheme_raise_exn(MZEXN_FAIL, - "write: disallowed value within preserved syntax property\n value: %V", - val); - return NULL; - } -} - -static Scheme_Object *convert_prop_val_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *val = (Scheme_Object *)p->ku.k.p1; - Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p2; - Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p3; - Scheme_Hash_Tree *seen = (Scheme_Hash_Tree *)p->ku.k.p4; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - return convert_prop_val(val, mt, ut, seen); -} - -static Scheme_Object *convert_srcloc(Scheme_Stx_Srcloc *srcloc, Scheme_Hash_Tree *props, Scheme_Marshal_Tables *mt) -{ - Scheme_Object *vec, *paren, *src, *dir, *preserved_properties; - - if (props) { - paren = scheme_hash_tree_get(props, scheme_paren_shape_symbol); - if (paren && !(SAME_TYPE(SCHEME_TYPE(paren), scheme_syntax_property_preserve_type) - && SCHEME_CHARP(SCHEME_PTR_VAL(paren)))) - paren = NULL; - } else - paren = NULL; - - preserved_properties = scheme_null; - if (props) { - Scheme_Object *key, *val, **a = NULL; - intptr_t i, count = 0; - - i = scheme_hash_tree_next(props, -1); - while (i != -1) { - scheme_hash_tree_index(props, i, &key, &val); - if (SAME_TYPE(SCHEME_TYPE(val), scheme_syntax_property_preserve_type)) { - if (!paren || !SAME_OBJ(key, scheme_paren_shape_symbol)) { - if (!a) - a = MALLOC_N(Scheme_Object *, props->count); - a[count++] = key; - } - } - i = scheme_hash_tree_next(props, i); - } - - if (count) { - /* Sort to make list deterministic */ - sort_symbol_array(a, count); - for (i = count; i--; ) { - val = scheme_hash_tree_get(props, a[i]); - val = convert_prop_val(SCHEME_PTR_VAL(val), mt, NULL, empty_hash_tree); - preserved_properties = CONS(CONS(a[i], val), preserved_properties); - } - } - } - - if ((!srcloc || (SCHEME_FALSEP(srcloc->src) - && (srcloc->line < 0) - && (srcloc->col < 0) - && (srcloc->pos < 0))) - && !paren - && SCHEME_NULLP(preserved_properties)) - return scheme_false; - - if (!srcloc) - srcloc = empty_srcloc; - - src = srcloc->src; - if (SCHEME_PATHP(src)) { - /* To make paths portable and to avoid full paths, check whether the - path can be made relative (in which case it is turned into a list - of byte strings). If not, convert to a string using only the - last couple of path elements. */ - dir = scheme_get_param(scheme_current_config(), - MZCONFIG_WRITE_DIRECTORY); - if (SCHEME_TRUEP(dir)) - src = scheme_extract_relative_to(src, dir, mt->path_cache); - if (SCHEME_PATHP(src)) { - src = scheme_hash_get(mt->path_cache, scheme_box(srcloc->src)); - if (!src) { - src = srcloc_path_to_string(srcloc->src); - scheme_hash_set(mt->path_cache, scheme_box(srcloc->src), src); - } - } else { - /* use the path directly and let the printer make it relative */ - src = srcloc->src; - } - } - - vec = scheme_make_vector(((paren || !SCHEME_NULLP(preserved_properties)) - ? (SCHEME_NULLP(preserved_properties) - ? 6 - : 7) - : 5), - NULL); - SCHEME_VEC_ELS(vec)[0] = src; - SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(srcloc->line); - SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(srcloc->col); - SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(srcloc->pos); - SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(srcloc->span); - if (paren || !SCHEME_NULLP(preserved_properties)) - SCHEME_VEC_ELS(vec)[5] = (paren ? SCHEME_PTR_VAL(paren) : scheme_false); - if (!SCHEME_NULLP(preserved_properties)) - SCHEME_VEC_ELS(vec)[6] = preserved_properties; - - return intern_one(vec, mt->intern_map); -} - -static void unconvert_srcloc(Scheme_Object *srcloc_vec, Scheme_Stx *dest, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Stx_Srcloc *srcloc; - - if (!SCHEME_VECTORP(srcloc_vec) - || ((SCHEME_VEC_SIZE(srcloc_vec) != 5) - && (SCHEME_VEC_SIZE(srcloc_vec) != 6) - && (SCHEME_VEC_SIZE(srcloc_vec) != 7))) - return; - - srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); -#ifdef MZTAG_REQUIRED - srcloc->type = scheme_rt_srcloc; -#endif - srcloc->src = SCHEME_VEC_ELS(srcloc_vec)[0]; - srcloc->line = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[1]); - srcloc->col = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[2]); - srcloc->pos = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[3]); - srcloc->span = SCHEME_INT_VAL(SCHEME_VEC_ELS(srcloc_vec)[4]); - - dest->srcloc = srcloc; - - if ((SCHEME_VEC_SIZE(srcloc_vec) > 5) - && SCHEME_CHARP((SCHEME_VEC_ELS(srcloc_vec)[5]))) { - if (SCHEME_CHAR_VAL(SCHEME_VEC_ELS(srcloc_vec)[5]) == '[') - dest->props = square_stx_props; - else if (SCHEME_CHAR_VAL(SCHEME_VEC_ELS(srcloc_vec)[5]) == '{') - dest->props = curly_stx_props; - } - - if (SCHEME_VEC_SIZE(srcloc_vec) > 6) { - /* Restore preserved properties */ - Scheme_Object *l = SCHEME_VEC_ELS(srcloc_vec)[6], *p, *v; - Scheme_Hash_Tree *props; - while (SCHEME_PAIRP(l)) { - p = SCHEME_CAR(l); - if (SCHEME_PAIRP(p) - && SCHEME_SYMBOLP(SCHEME_CAR(p)) - && !SCHEME_SYM_WEIRDP(SCHEME_CAR(p))) { - v = convert_prop_val(SCHEME_CDR(p), NULL, ut, empty_hash_tree); - if (v) { - props = scheme_hash_tree_set((dest->props ? dest->props : empty_hash_tree), - SCHEME_CAR(p), - make_preserved_property_value(v)); - dest->props = props; - } - } - l = SCHEME_CDR(l); - } - } -} - #ifdef DO_STACK_CHECK static Scheme_Object *syntax_to_datum_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p3; p->ku.k.p1 = NULL; - p->ku.k.p3 = NULL; - return syntax_to_datum_inner(o, p->ku.k.i1, mt); + return syntax_to_datum_inner(o); } #endif -static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_scopes, /* non-zero => marshal; negative => implicitly tainted */ - Scheme_Marshal_Tables *mt) +static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o) +/* Recurs through `o` to find syntax objects and strip them away, or + returns `o` if no syntax objects are inside. */ { - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *v, *result, *converted_wraps = NULL; - int add_taint = 0; + Scheme_Object *v, *result; #ifdef DO_STACK_CHECK { @@ -6808,127 +307,100 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, { Scheme_Thread *p = scheme_current_thread; p->ku.k.p1 = (void *)o; - p->ku.k.i1 = with_scopes; - p->ku.k.p3 = (void *)mt; return scheme_handle_stack_overflow(syntax_to_datum_k); } } #endif SCHEME_USE_FUEL(1); - if (with_scopes) { - /* Propagate wraps: */ - scheme_stx_content((Scheme_Object *)stx); - if (with_scopes > 0) { - if (is_tainted((Scheme_Object *)stx)) { - add_taint = 1; - with_scopes = -with_scopes; - } else if (is_armed((Scheme_Object *)stx)) { - add_taint = 2; - } - } - } - - v = stx->val; + if (SCHEME_STXP(o)) + o = SCHEME_STX_VAL(o); + v = o; if (SCHEME_PAIRP(v)) { Scheme_Object *first = NULL, *last = NULL, *p; - Scheme_Object *common_wraps = NULL, *common_srcloc = NULL, *common_taint = NULL; - Scheme_Object *a, *sa, *ta; - int cnt = 0; + Scheme_Object *a; + int same = 0; while (SCHEME_PAIRP(v)) { - cnt++; + a = syntax_to_datum_inner(SCHEME_CAR(v)); - a = syntax_to_datum_inner(SCHEME_CAR(v), with_scopes, mt); - - p = CONS(a, scheme_null); + if (!first && SAME_OBJ(a, SCHEME_CAR(v))) { + same++; + v = SCHEME_CDR(v); + } else { + if (!first && (same > 0)) { + v = o; + while (same--) { + p = CONS(SCHEME_CAR(v), scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); + } + } + + p = CONS(a, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - v = SCHEME_CDR(v); - - if (with_scopes) { - sa = extract_for_common_wrap(a, COMMON_EXTRACT_SRCLOC, 1); - ta = extract_for_common_wrap(a, COMMON_EXTRACT_TAINT, 1); - a = extract_for_common_wrap(a, COMMON_EXTRACT_WRAPS, 1); - if (!common_wraps) { - if (a) { - common_wraps = a; - common_srcloc = sa; - common_taint = ta; - } else - common_wraps = scheme_false; - } else if (!a - || !SAME_OBJ(common_wraps, a) - || !SAME_OBJ(common_srcloc, sa) - || !SAME_OBJ(common_taint, ta)) - common_wraps = scheme_false; + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); } } if (!SCHEME_NULLP(v)) { - v = syntax_to_datum_inner(v, with_scopes, mt); - SCHEME_CDR(last) = v; - - if (with_scopes) { - sa = extract_for_common_wrap(v, COMMON_EXTRACT_SRCLOC, 0); - ta = extract_for_common_wrap(v, COMMON_EXTRACT_TAINT, 0); - v = extract_for_common_wrap(v, COMMON_EXTRACT_WRAPS, 0); - if (v - && SAME_OBJ(common_wraps, v) - && SAME_OBJ(common_srcloc, sa) - && SAME_OBJ(common_taint, ta)) { - converted_wraps = wraps_to_datum(stx, mt); - sa = convert_srcloc(stx->srcloc, stx->props, mt); - if (SAME_OBJ(common_wraps, converted_wraps) - && SAME_OBJ(common_srcloc, sa) - && SAME_OBJ(common_taint, scheme_make_integer(add_taint))) - lift_common_wraps(first, cnt, 1); + a = syntax_to_datum_inner(v); + if (!first && SAME_OBJ(v, a)) + return o; + else { + v = o; + while (same--) { + p = CONS(SCHEME_CAR(v), scheme_null); + if (last) + SCHEME_CDR(last) = p; else - common_wraps = scheme_false; - } else - common_wraps = scheme_false; + first = p; + last = p; + v = SCHEME_CDR(v); + } + + SCHEME_CDR(last) = a; } - - if (with_scopes && SCHEME_FALSEP(common_wraps)) { - /* v is likely a pair, and v's car might be a pair, - which means that the datum->syntax part - won't be able to detect that v is a "non-pair" - terminal. Therefore, we communicate the - length before the terminal to datum->syntax: */ - first = scheme_make_pair(scheme_make_integer(cnt), first); - } - } else if (with_scopes && SCHEME_TRUEP(common_wraps)) { - converted_wraps = wraps_to_datum(stx, mt); - sa = convert_srcloc(stx->srcloc, stx->props, mt); - if (SAME_OBJ(common_wraps, converted_wraps) - && SAME_OBJ(common_srcloc, sa) - && SAME_OBJ(common_taint, scheme_make_integer(add_taint))) - lift_common_wraps(first, cnt, 0); - else - common_wraps = scheme_false; - } - - if (with_scopes && SCHEME_TRUEP(common_wraps)) { - first = scheme_make_pair(scheme_true, first); - } + } else if (!first) + return o; result = first; } else if (SCHEME_BOXP(v)) { - v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), with_scopes, mt); + v = syntax_to_datum_inner(SCHEME_BOX_VAL(v)); + if (v == SCHEME_BOX_VAL(o)) + return o; result = scheme_box(v); SCHEME_SET_IMMUTABLE(result); } else if (SCHEME_VECTORP(v)) { - int size = SCHEME_VEC_SIZE(v), i; + int size = SCHEME_VEC_SIZE(v), i, j; Scheme_Object *r, *a; + + for (i = 0; i < size; i++) { + a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i]); + if (!SAME_OBJ(a, SCHEME_VEC_ELS(v)[i])) + break; + } + + if (i >= size) + return o; r = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], with_scopes, mt); + + for (j = 0; j < i; j++) { + SCHEME_VEC_ELS(r)[j] = SCHEME_VEC_ELS(v)[j]; + } + SCHEME_VEC_ELS(r)[i] = a; + for (i++; i < size; i++) { + a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i]); SCHEME_VEC_ELS(r)[i] = a; } @@ -6936,15 +408,37 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, SCHEME_SET_IMMUTABLE(result); } else if (SCHEME_HASHTRP(v)) { Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; - Scheme_Object *key, *val; - mzlonglong i; - - ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); - + Scheme_Object *key, *val, *val2; + mzlonglong i, j; + i = scheme_hash_tree_next(ht, -1); while (i != -1) { scheme_hash_tree_index(ht, i, &key, &val); - val = syntax_to_datum_inner(val, with_scopes, mt); + val2 = syntax_to_datum_inner(val); + if (!SAME_OBJ(val, val2)) + break; + i = scheme_hash_tree_next(ht, i); + } + if (i == -1) + return o; + + ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); + + j = scheme_hash_tree_next(ht, -1); + while (j != i) { + scheme_hash_tree_index(ht, j, &key, &val); + val = syntax_to_datum_inner(val); + ht2 = scheme_hash_tree_set(ht2, key, val); + j = scheme_hash_tree_next(ht, j); + } + + scheme_hash_tree_index(ht, i, &key, &val); + ht2 = scheme_hash_tree_set(ht2, key, val2); + + i = scheme_hash_tree_next(ht, i); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = syntax_to_datum_inner(val); ht2 = scheme_hash_tree_set(ht2, key, val); i = scheme_hash_tree_next(ht, i); } @@ -6954,10 +448,19 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, Scheme_Structure *s = (Scheme_Structure *)v; Scheme_Object *a; int size = s->stype->num_slots, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); + for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(s->slots[i], with_scopes, mt); + a = syntax_to_datum_inner(s->slots[i]); + if (!SAME_OBJ(a, s->slots[i])) + break; + } + if (i >= size) + return o; + + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); + s->slots[i] = a; + for (i++; i < size; i++) { + a = syntax_to_datum_inner(s->slots[i]); s->slots[i] = a; } @@ -6965,65 +468,12 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, } else result = v; - if (with_scopes) { - if (!converted_wraps) - converted_wraps = wraps_to_datum(stx, mt); - v = convert_srcloc(stx->srcloc, stx->props, mt); - if (SCHEME_TRUEP(v)) { - result = scheme_make_vector((add_taint ? 4 : 3), result); - SCHEME_VEC_ELS(result)[1] = converted_wraps; - SCHEME_VEC_ELS(result)[2] = v; - if (add_taint) - SCHEME_VEC_ELS(result)[3] = scheme_make_integer(add_taint); /* 1 => tainted, 2 => armed */ - } else if (add_taint) { - result = scheme_make_vector(3, result); - SCHEME_VEC_ELS(result)[1] = converted_wraps; - SCHEME_VEC_ELS(result)[2] = scheme_make_integer(add_taint); /* 1 => tainted, 2 => armed */ - } else - result = CONS(result, converted_wraps); - } - return result; } -Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes, - Scheme_Marshal_Tables *mt) +Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx) { - Scheme_Object *v; - - if (mt && (mt->pass >= 0)) - scheme_marshal_push_refs(mt); - - v = syntax_to_datum_inner(stx, with_scopes, mt); - - if (mt && (mt->pass >= 0)) { - /* A symbol+wrap combination is likely to be used multiple - times. This is a relatively minor optimization in .zo size, - since v is already fairly compact, but it also avoids - allocating extra syntax objects at load time. For consistency, - we try to reuse all combinations. */ - Scheme_Hash_Table *top_map; - Scheme_Object *key; - - top_map = mt->top_map; - if (!top_map) { - top_map = scheme_make_hash_table_equal(); - mt->top_map = top_map; - } - - key = scheme_hash_get(top_map, v); - if (key) { - scheme_marshal_pop_refs(mt, 0); - v = scheme_marshal_lookup(mt, key); - scheme_marshal_using_key(mt, key); - } else { - scheme_hash_set(top_map, stx, v); - v = scheme_marshal_wrap_set(mt, stx, v); - scheme_marshal_pop_refs(mt, 1); - } - } - - return v; + return syntax_to_datum_inner(stx); } /*========================================================================*/ @@ -7032,482 +482,27 @@ Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes, #define return_NULL return NULL -Scheme_Object *scheme_hash_get_either(Scheme_Hash_Table *ht, Scheme_Hash_Table *ht2, - Scheme_Object *key) -{ - Scheme_Object *val; - val = scheme_hash_get(ht, key); - if (val) - return val; - else if (ht2) - return scheme_hash_get(ht2, key); - else - return NULL; -} - -static void ensure_current_rns(Scheme_Unmarshal_Tables *ut) -{ - Scheme_Hash_Table *rht; - if (!ut->current_rns) { - rht = scheme_make_hash_table(SCHEME_hash_ptr); - ut->current_rns = rht; - } -} - -static void ensure_current_multi_scope_pairs(Scheme_Unmarshal_Tables *ut) -{ - Scheme_Hash_Table *rht; - if (!ut->current_multi_scope_pairs) { - rht = scheme_make_hash_table(SCHEME_hash_ptr); - ut->current_multi_scope_pairs = rht; - } -} - -Scheme_Scope_Set *list_to_scope_set(Scheme_Object *l, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Scope_Set *scopes = NULL; - Scheme_Object *r = scheme_null, *scope; - - if (scheme_proper_list_length(l) < 0) return_NULL; - - while (!SCHEME_NULLP(l)) { - if (!SCHEME_PAIRP(l)) return_NULL; - scopes = (Scheme_Scope_Set *)scheme_hash_get_either(ut->rns, ut->current_rns, l); - if (scopes) - break; - r = scheme_make_pair(l, r); - l = SCHEME_CDR(l); - } - - if (!scopes) scopes = empty_scope_set; - - while (!SCHEME_NULLP(r)) { - l = SCHEME_CAR(r); - - scope = scope_unmarshal_content(SCHEME_CAR(l), ut); - if (!scope) return_NULL; - - scopes = scope_set_set(scopes, scope, scheme_true); - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, l, (Scheme_Object *)scopes); - - r = SCHEME_CDR(r); - } - - return scopes; -} - -static Scheme_Hash_Table *vector_to_multi_scope(Scheme_Object *mht, Scheme_Unmarshal_Tables *ut) -{ - /* Convert multi-scope vector to hash table */ - intptr_t i, len; - Scheme_Hash_Table *multi_scope; - Scheme_Object *scope; - - if (!SCHEME_VECTORP(mht)) return_NULL; - - multi_scope = (Scheme_Hash_Table *)scheme_hash_get_either(ut->rns, ut->current_rns, mht); - if (multi_scope) return multi_scope; - - multi_scope = scheme_make_hash_table(SCHEME_hash_ptr); - - len = SCHEME_VEC_SIZE(mht); - if (!(len & 1)) return_NULL; - - STX_ASSERT(ut->bytecode_hash); - - multi_scope = (Scheme_Hash_Table *)new_multi_scope(SCHEME_VEC_ELS(mht)[len-1]); - scheme_hash_set(multi_scope, - scheme_void, - /* record bytecode hash for making fresh scopes for other phases: */ - scheme_make_mutable_pair(scheme_hash_get(multi_scope, scheme_void), - scheme_make_integer_value_from_long_long(ut->bytecode_hash - >> SCHEME_STX_SCOPE_KIND_SHIFT))); - len -= 1; - - /* A multi-scope can refer back to itself via free-id=? info: */ - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, mht, (Scheme_Object *)multi_scope); - - for (i = 0; i < len; i += 2) { - if (!SCHEME_PHASEP(SCHEME_VEC_ELS(mht)[i])) - return_NULL; - scope = SCHEME_VEC_ELS(mht)[i+1]; - scope = scope_unmarshal_content(scope, ut); - if (!scope) return_NULL; - if (!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)scope)) - return_NULL; - if (((Scheme_Scope_With_Owner *)scope)->owner_multi_scope) - return_NULL; - scheme_hash_set(multi_scope, SCHEME_VEC_ELS(mht)[i], scope); - ((Scheme_Scope_With_Owner *)scope)->owner_multi_scope = (Scheme_Object *)multi_scope; - ((Scheme_Scope_With_Owner *)scope)->phase = SCHEME_VEC_ELS(mht)[i]; - } - - return multi_scope; -} - -Scheme_Object *unmarshal_multi_scopes(Scheme_Object *multi_scopes, - Scheme_Unmarshal_Tables *ut) -{ - Scheme_Hash_Table *multi_scope; - Scheme_Object *l, *mm_l, *first = NULL, *last = NULL; - Scheme_Object *l_first, *l_last, *p; - - mm_l = multi_scopes; - - while (1) { - l = mm_l; - if (SCHEME_FALLBACKP(l)) - l = SCHEME_FALLBACK_FIRST(l); - - if (scheme_proper_list_length(l) < 0) return_NULL; - - l_first = scheme_null; - l_last = NULL; - for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - int stop; - - if (!SCHEME_PAIRP(l)) return_NULL; - if (!SCHEME_PAIRP(SCHEME_CAR(l))) return_NULL; - - p = scheme_hash_get_either(ut->multi_scope_pairs, ut->current_multi_scope_pairs, l); - if (!p) { - p = scheme_hash_get_either(ut->multi_scope_pairs, ut->current_multi_scope_pairs, SCHEME_CAR(l)); - if (p) { - p = scheme_make_pair(p, scheme_null); - } else { - if (SCHEME_VECTORP(SCHEME_CAR(SCHEME_CAR(l)))) { - multi_scope = vector_to_multi_scope(SCHEME_CAR(SCHEME_CAR(l)), ut); - if (!multi_scope) return_NULL; - if (!SCHEME_PHASE_SHIFTP(SCHEME_CDR(SCHEME_CAR(l)))) return_NULL; - p = scheme_make_pair((Scheme_Object *)multi_scope, - SCHEME_CDR(SCHEME_CAR(l))); - ensure_current_multi_scope_pairs(ut); - scheme_hash_set(ut->current_multi_scope_pairs, SCHEME_CAR(l), p); - } else - return_NULL; - } - ensure_current_multi_scope_pairs(ut); - scheme_hash_set(ut->current_multi_scope_pairs, SCHEME_CAR(l), p); - p = scheme_make_pair(p, scheme_null); - stop = 0; - } else - stop = 1; - - if (l_last) - SCHEME_CDR(l_last) = p; - else - l_first = p; - l_last = p; - - if (stop) - break; - else { - ensure_current_multi_scope_pairs(ut); - scheme_hash_set(ut->current_multi_scope_pairs, l, p); - } - } - - if (SCHEME_FALLBACKP(mm_l)) { - p = make_fallback_pair(l_first, scheme_null); - if (last) - SCHEME_FALLBACK_REST(last) = p; - else - first = p; - last = p; - mm_l = SCHEME_FALLBACK_REST(mm_l); - } else { - if (last) - SCHEME_FALLBACK_REST(last) = l_first; - else - first = l_first; - break; - } - } - - return first; -} - -static Scheme_Object *datum_to_wraps(Scheme_Object *w, - Scheme_Unmarshal_Tables *ut) -{ - Scheme_Scope_Table *st; - Scheme_Scope_Set *scopes; - Scheme_Object *l; - - l = scheme_hash_get_either(ut->rns, ut->current_rns, w); - if (l) { - if (!SCHEME_PAIRP(l) - || !SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_scope_table_type)) - return NULL; - return l; - } - - if (!SCHEME_VECTORP(w) - || ((SCHEME_VEC_SIZE(w) != 3) - && (SCHEME_VEC_SIZE(w) != 4))) - return_NULL; - - st = MALLOC_ONE_TAGGED(Scheme_Scope_Table); - st->so.type = scheme_scope_table_type; - - scopes = list_to_scope_set(SCHEME_VEC_ELS(w)[1], ut); - if (!scopes) return NULL; - st->simple_scopes = scopes; - - l = unmarshal_multi_scopes(SCHEME_VEC_ELS(w)[2], ut); - if (!l) return NULL; - st->multi_scopes = l; - - l = scheme_make_pair((Scheme_Object *)st, SCHEME_VEC_ELS(w)[0]); - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, w, l); - - return l; -} - -static Scheme_Object *validate_binding(Scheme_Object *p) -{ - if (SCHEME_SYMBOLP(p)) { - /* Ok: local binding */ - } else { - if (SCHEME_PAIRP(p) && SCHEME_SYMBOLP(SCHEME_CAR(p))) { - /* Inpsector descriptor ok */ - p = SCHEME_CDR(p); - } - - if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(p)) { - Scheme_Object *midx; - - midx = SCHEME_CAR(p); - if (SCHEME_TRUEP(midx) - && !SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) - return_NULL; - - if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { - /* Ok */ - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { - /* Ok */ - } else { - Scheme_Object *ap, *bp; - - ap = SCHEME_CDR(p); - if (!SCHEME_PAIRP(ap)) - return_NULL; - - /* mod-phase, maybe */ - if (SCHEME_INTP(SCHEME_CAR(ap))) { - bp = SCHEME_CDR(ap); - } else - bp = ap; - - /* exportname */ - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - - /* nominal_modidx_plus_phase */ - bp = SCHEME_CDR(bp); - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(ap)) { - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) - return_NULL; - ap = SCHEME_CDR(ap); - /* import_phase_plus_nominal_phase */ - if (SCHEME_PAIRP(ap)) { - if (!SCHEME_PHASE_SHIFTP(SCHEME_CAR(ap))) return_NULL; - if (!SCHEME_PHASE_SHIFTP(SCHEME_CDR(ap))) return_NULL; - } else if (!SCHEME_PHASE_SHIFTP(ap)) - return_NULL; - } else - return_NULL; - - /* nominal_exportname */ - ap = SCHEME_CDR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - } - } - } - - return scheme_true; -} - -static Scheme_Object *unmarshal_free_id_info(Scheme_Object *p, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Object *o, *phase; - - if (!SCHEME_PAIRP(p)) return_NULL; - phase = SCHEME_CDR(p); - p = SCHEME_CAR(p); - if (!SCHEME_PAIRP(p)) return_NULL; - o = scheme_make_stx(SCHEME_CAR(p), NULL, NULL); - p = datum_to_wraps(SCHEME_CDR(p), ut); - if (!p) return_NULL; - - ((Scheme_Stx *)o)->scopes = (Scheme_Scope_Table *)SCHEME_CAR(p); - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)o)->scopes), scheme_scope_table_type)); - ((Scheme_Stx *)o)->shifts = SCHEME_CDR(p); - - return scheme_make_pair(o, phase); -} - -Scheme_Object *scope_unmarshal_content(Scheme_Object *box, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Object *l = NULL, *l2, *r, *b, *m, *c, *free_id; - Scheme_Hash_Tree *ht; - Scheme_Scope_Set *scopes; - intptr_t i, len, relative_id; - - if (SAME_OBJ(box, root_scope)) - return root_scope; - - r = scheme_hash_get_either(ut->rns, ut->current_rns, box); - if (r) - return r; - - if (!SCHEME_BOXP(box)) return_NULL; - c = SCHEME_BOX_VAL(box); - - if (!SCHEME_PAIRP(c)) return_NULL; - - relative_id = SCHEME_INT_VAL(SCHEME_CAR(c)); - c = SCHEME_CDR(c); - - if (SCHEME_INTP(c)) { - m = scheme_new_scope(SCHEME_INT_VAL(c)); - c = NULL; - } else if (SCHEME_PAIRP(c)) { - m = scheme_new_scope(SCHEME_INT_VAL(SCHEME_CAR(c))); - c = SCHEME_CDR(c); - } else - m = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); - - ensure_current_rns(ut); - scheme_hash_set(ut->current_rns, box, m); - /* Since we've created the scope before unmarshaling its content, - cycles among scopes are ok. */ - - /* Reset the scope's id to a hash from the bytecode plus a relative - offset. The only use of a scope's id is for debugging and - ordering, and using the bytecode's hash as part of the number is - intended to make ordering deterministic even across modules, - independent of the order that modules are loaded or delay-loaded. - Hashes are not gauarnteed to be distinct or far enough apart, but - they're likely to be. */ - STX_ASSERT(ut->bytecode_hash); - ((Scheme_Scope *)m)->id = ((SCHEME_STX_SCOPE_KIND_MASK & ((Scheme_Scope*)m)->id) - | ((umzlonglong)((relative_id << SCHEME_STX_SCOPE_KIND_SHIFT) - + ut->bytecode_hash) - & (~(umzlonglong)SCHEME_STX_SCOPE_KIND_MASK))); - - if (!c) return m; - - while (SCHEME_PAIRP(c)) { - if (!SCHEME_PAIRP(SCHEME_CAR(c))) return_NULL; - scopes = list_to_scope_set(SCHEME_CAR(SCHEME_CAR(c)), ut); - l = scheme_make_raw_pair(scheme_make_pair((Scheme_Object *)scopes, - SCHEME_CDR(SCHEME_CAR(c))), - l); - c = SCHEME_CDR(c); - } - - if (!SCHEME_VECTORP(c)) return_NULL; - - len = SCHEME_VEC_SIZE(c); - if (len & 1) return_NULL; - - /* If the vector length is 2, and if the only key has a single - binding, then we could generate the compact vector form of - bindings. For now, we just build the hash table. */ - - ht = empty_hash_tree; - for (i = 0; i < len; i += 2) { - l2 = SCHEME_VEC_ELS(c)[i+1]; - r = scheme_null; - while (SCHEME_PAIRP(l2)) { - if (!SCHEME_PAIRP(SCHEME_CAR(l2))) return_NULL; - scopes = list_to_scope_set(SCHEME_CAR(SCHEME_CAR(l2)), ut); - if (!scopes) return_NULL; - - b = SCHEME_CDR(SCHEME_CAR(l2)); - if (SCHEME_BOXP(b)) { - /* has `free-id=?` info */ - b = SCHEME_BOX_VAL(b); - if (!SCHEME_PAIRP(b)) return_NULL; - free_id = unmarshal_free_id_info(SCHEME_CDR(b), ut); - if (!free_id) return_NULL; - b = SCHEME_CAR(b); - } else - free_id = NULL; - if (!validate_binding(b)) return_NULL; - - if (free_id) - b = scheme_make_mutable_pair(b, free_id); - - b = scheme_make_pair((Scheme_Object *)scopes, b); - - if (SCHEME_NULLP(r) && SCHEME_NULLP(SCHEME_CDR(l2))) { - /* leave r as a single binding */ - r = b; - } else - r = scheme_make_mutable_pair(b, r); - - l2 = SCHEME_CDR(l2); - } - - ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(c)[i], r); - } - - if (!l) - l = (Scheme_Object *)ht; - else - l = scheme_make_raw_pair((Scheme_Object *)ht, l); - - ((Scheme_Scope *)m)->bindings = l; - - return m; -} - - #ifdef DO_STACK_CHECK static Scheme_Object *datum_to_syntax_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; Scheme_Stx *stx_src = (Scheme_Stx *)p->ku.k.p2; - Scheme_Stx *stx_wraps = (Scheme_Stx *)p->ku.k.p3; - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p4; - Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p5; + Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p3; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - return datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht, (int)p->ku.k.i1); + return datum_to_syntax_inner(o, stx_src, ht); } #endif static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, Scheme_Stx *stx_src, - Scheme_Stx *stx_wraps, /* or rename table, or vectored wrap+srcloc+taint */ - Scheme_Hash_Table *ht, - int tainted) + Scheme_Hash_Table *ht) { - Scheme_Object *result, *wraps, *hashed, *srcloc_vec; - int do_not_unpack_wraps = 0, taintval = 0; + Scheme_Object *result, *hashed; if (SCHEME_STXP(o)) return o; @@ -7519,10 +514,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, Scheme_Thread *p = scheme_current_thread; p->ku.k.p1 = (void *)o; p->ku.k.p2 = (void *)stx_src; - p->ku.k.p3 = (void *)stx_wraps; - p->ku.k.p4 = (void *)ht; - p->ku.k.p5 = (void *)ut; - p->ku.k.i1 = tainted; + p->ku.k.p3 = (void *)ht; return scheme_handle_stack_overflow(datum_to_syntax_k); } } @@ -7544,42 +536,6 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, } else hashed = NULL; - srcloc_vec = scheme_false; - - if (ut && !SCHEME_VECTORP(stx_wraps)) { - if (SCHEME_VECTORP(o)) { - if (SCHEME_VEC_SIZE(o) == 4) { - srcloc_vec = SCHEME_VEC_ELS(o)[2]; - taintval = SCHEME_INT_VAL(SCHEME_VEC_ELS(o)[3]); - } else if (SCHEME_VEC_SIZE(o) == 3) { - if (SCHEME_INTP(SCHEME_VEC_ELS(o)[2])) - taintval = SCHEME_INT_VAL(SCHEME_VEC_ELS(o)[2]); - else { - srcloc_vec = SCHEME_VEC_ELS(o)[2]; - taintval = 0; - } - } else - return_NULL; - wraps = SCHEME_VEC_ELS(o)[1]; - o = SCHEME_VEC_ELS(o)[0]; - } else { - if (!SCHEME_PAIRP(o)) - return_NULL; - wraps = SCHEME_CDR(o); - o = SCHEME_CAR(o); - } - } else if (SCHEME_VECTORP(stx_wraps)) { - /* Shared wraps, to be used directly everywhere: */ - wraps = SCHEME_VEC_ELS(stx_wraps)[0]; - srcloc_vec = SCHEME_VEC_ELS(stx_wraps)[1]; - taintval = SCHEME_INT_VAL(SCHEME_VEC_ELS(stx_wraps)[2]); - do_not_unpack_wraps = 1; - } else - wraps = NULL; - - if (taintval == 1) - tainted = 1; - if (SCHEME_PAIRP(o)) { Scheme_Object *first = NULL, *last = NULL, *p; @@ -7594,29 +550,8 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, if (SCHEME_NULLP(p) || SCHEME_STXP(p)) { result = o; } else { - int cnt = -1; - Scheme_Stx *sub_stx_wraps = stx_wraps; - - if (wraps && !SCHEME_VECTORP(stx_wraps) && SAME_OBJ(SCHEME_CAR(o), scheme_true)) { - /* Resolve wraps now, and then share it with - all nested objects (as indicated by a box - for stx_wraps). */ - wraps = datum_to_wraps(wraps, ut); - if (!wraps) return_NULL; - do_not_unpack_wraps = 1; - sub_stx_wraps = (Scheme_Stx *)scheme_make_vector(3, wraps); - SCHEME_VEC_ELS((Scheme_Object *)sub_stx_wraps)[1] = srcloc_vec; - SCHEME_VEC_ELS((Scheme_Object *)sub_stx_wraps)[2] = scheme_make_integer(taintval); - o = SCHEME_CDR(o); - } else if (wraps && !SCHEME_VECTORP(stx_wraps) && SCHEME_INTP(SCHEME_CAR(o))) { - /* First element is the number of items - before a non-null terminal: */ - cnt = SCHEME_INT_VAL(SCHEME_CAR(o)); - o = SCHEME_CDR(o); - } - /* Build up a new list while converting elems */ - while (SCHEME_PAIRP(o) && cnt) { + while (SCHEME_PAIRP(o)) { Scheme_Object *a; if (ht && last) { @@ -7626,7 +561,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, } } - a = datum_to_syntax_inner(SCHEME_CAR(o), ut, stx_src, sub_stx_wraps, ht, tainted); + a = datum_to_syntax_inner(SCHEME_CAR(o), stx_src, ht); if (!a) return_NULL; p = scheme_make_pair(a, scheme_null); @@ -7637,12 +572,10 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, first = p; last = p; o = SCHEME_CDR(o); - - --cnt; } if (!first) return_NULL; if (!SCHEME_NULLP(o)) { - o = datum_to_syntax_inner(o, ut, stx_src, sub_stx_wraps, ht, tainted); + o = datum_to_syntax_inner(o, stx_src, ht); if (!o) return_NULL; SCHEME_CDR(last) = o; } @@ -7655,7 +588,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, else o = SCHEME_PTR_VAL(o); - o = datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht, tainted); + o = datum_to_syntax_inner(o, stx_src, ht); if (!o) return_NULL; result = scheme_box(o); SCHEME_SET_BOX_IMMUTABLE(result); @@ -7675,7 +608,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, a = SCHEME_VEC_ELS(o)[i]; else a = scheme_chaperone_vector_ref(oo, i); - a = datum_to_syntax_inner(a, ut, stx_src, stx_wraps, ht, tainted); + a = datum_to_syntax_inner(a, stx_src, ht); if (!a) return_NULL; SCHEME_VEC_ELS(result)[i] = a; } @@ -7698,7 +631,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, scheme_hash_tree_index(ht1, i, &key, &val); if (!SAME_OBJ((Scheme_Object *)ht1, o)) val = scheme_chaperone_hash_traversal_get(o, key, &key); - val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht, tainted); + val = datum_to_syntax_inner(val, stx_src, ht); if (!val) return NULL; ht2 = scheme_hash_tree_set(ht2, key, val); i = scheme_hash_tree_next(ht1, i); @@ -7714,63 +647,22 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, size = s->stype->num_slots; for (i = 0; i < size; i++) { - a = datum_to_syntax_inner(s->slots[i], ut, stx_src, stx_wraps, ht, tainted); + a = datum_to_syntax_inner(s->slots[i], stx_src, ht); if (!a) return NULL; s->slots[i] = a; } result = (Scheme_Object *)s; - } else { - if (!wraps) - o = scheme_read_intern(o); - result = o; - } + } else + result = scheme_read_intern(o); if (SCHEME_FALSEP((Scheme_Object *)stx_src)) result = scheme_make_stx(result, empty_srcloc, NULL); else result = scheme_make_stx(result, stx_src->srcloc, NULL); - - if (tainted) { - int mutate = MUTATE_STX_OBJ; - (void)add_taint_to_stx(result, &mutate); - } else if (taintval == 2) { - /* Arm with #f as the inspector; #f is replaced by a - specific inspector when the encloding code is instanted */ - Scheme_Object *l; - l = taint_intern(scheme_make_pair(scheme_false, scheme_null)); - l = taint_intern(scheme_make_pair(scheme_false, l)); - ((Scheme_Stx *)result)->taints = l; - } - - if (SCHEME_TRUEP(srcloc_vec)) - unconvert_srcloc(srcloc_vec, (Scheme_Stx *)result, ut); - - if (wraps) { - if (!do_not_unpack_wraps) { - wraps = datum_to_wraps(wraps, ut); - if (!wraps) - return_NULL; - } - - if (!SCHEME_PAIRP(wraps)) return_NULL; - ((Scheme_Stx *)result)->scopes = (Scheme_Scope_Table *)SCHEME_CAR(wraps); - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)result)->scopes), scheme_scope_table_type)); - ((Scheme_Stx *)result)->shifts = SCHEME_CDR(wraps); - } else if (SCHEME_FALSEP((Scheme_Object *)stx_wraps)) { - /* wraps already nulled */ - } else { - /* Note: no propagation will be needed for SUBSTX */ - ((Scheme_Stx *)result)->scopes = stx_wraps->scopes; - STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)result)->scopes), scheme_scope_table_type)); - ((Scheme_Stx *)result)->shifts = stx_wraps->shifts; - if (SCHEME_VECTORP(((Scheme_Stx *)result)->shifts)) - ((Scheme_Stx *)result)->shifts = SCHEME_VEC_ELS(((Scheme_Stx *)result)->shifts)[0]; - } - - if (hashed) { + + if (hashed) scheme_hash_set(ht, hashed, NULL); - } return result; } @@ -7789,18 +681,11 @@ static int quick_check_graph(Scheme_Object *o, int fuel) return fuel; } -static Scheme_Object *general_datum_to_syntax(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int can_graph, int copy_props) - /* If stx_wraps is a hash table, then `o' includes scopes. - If copy_props > 0, properties are copied from src. - If copy_props != 1 or 0, then taint armings are copied from src, too, - but src must not be tainted. */ +Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, + Scheme_Object *stx_src, + int flags) { - Scheme_Hash_Table *ht; - Scheme_Object *v, *code = NULL; + Scheme_Object *v; if (!SCHEME_FALSEP(stx_src) && !SCHEME_STXP(stx_src)) return o; @@ -7808,75 +693,35 @@ static Scheme_Object *general_datum_to_syntax(Scheme_Object *o, if (SCHEME_STXP(o)) return o; - if (can_graph && !quick_check_graph(o, 10)) - ht = scheme_make_hash_table(SCHEME_hash_ptr); - else - ht = NULL; + if (flags & DTS_RECUR) { + Scheme_Hash_Table *ht; - if (ut) { - /* If o is just a number, look it up in the table. */ - if (SCHEME_INTP(o)) { - int decoded; - v = scheme_unmarshal_wrap_get(ut, o, &decoded); - if (!decoded) { - code = o; - o = v; - } else - return v; + if ((flags & DTS_CAN_GRAPH) && !quick_check_graph(o, 10)) + ht = scheme_make_hash_table(SCHEME_hash_ptr); + else + ht = NULL; + + v = datum_to_syntax_inner(o, (Scheme_Stx *)stx_src, ht); + + if (!v) { + /* only happens with cycles: */ + scheme_contract_error("datum->syntax", + "cannot create syntax from cyclic datum", + "datum", 1, o, + NULL); + return NULL; } - } + } else if (SCHEME_FALSEP(stx_src)) + v = scheme_make_stx(o, empty_srcloc, NULL); + else + v = scheme_make_stx(o, ((Scheme_Stx *)stx_src)->srcloc, NULL); - v = datum_to_syntax_inner(o, - ut, - (Scheme_Stx *)stx_src, - (Scheme_Stx *)stx_wraps, - ht, - 0); - - if (!v) { - if (ut) - return_NULL; /* happens with bad wraps from a bad .zo */ - /* otherwise, only happens with cycles: */ - scheme_contract_error("datum->syntax", - "cannot create syntax from cyclic datum", - "datum", 1, o, - NULL); - return NULL; - } - - if (code) { - scheme_unmarshal_wrap_set(ut, code, v); - } - - if (copy_props > 0) + if (flags & DTS_COPY_PROPS) ((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props; - if (copy_props && (copy_props != 1)) { - if (!is_clean(stx_src)) { - if (is_tainted(stx_src)) - scheme_signal_error("internal error: cannot copy taint armings from tainted source"); - v = add_taint_armings_to_stx(v, ((Scheme_Stx *)stx_src)->taints, 0); - } - } - return v; } -Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, - Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int can_graph, int copy_props) -{ - return general_datum_to_syntax(o, NULL, stx_src, stx_wraps, can_graph, copy_props); -} - -Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, - struct Scheme_Unmarshal_Tables *ut, - int can_graph) -{ - return general_datum_to_syntax(o, ut, scheme_false, scheme_false, can_graph, 0); -} - /*========================================================================*/ /* Racket functions and helpers */ /*========================================================================*/ @@ -7891,7 +736,7 @@ static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv) if (!SCHEME_STXP(argv[0])) scheme_wrong_contract("syntax->datum", "syntax?", 0, argc, argv); - return scheme_syntax_to_datum(argv[0], 0, NULL); + return scheme_syntax_to_datum(argv[0]); } static int nonneg_exact_or_false_p(Scheme_Object *o) @@ -7911,8 +756,10 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv) Scheme_Object *src = scheme_false; Scheme_Hash_Tree *properties = NULL; + /* The first argument is accepted only for backward compatibility: */ if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0])) scheme_wrong_contract("datum->syntax", "(or/c syntax? #f)", 0, argc, argv); + if (argc > 2) { int ll; @@ -8013,17 +860,12 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv) if (SCHEME_STXP(argv[1])) return argv[1]; - src = scheme_datum_to_syntax(argv[1], src, argv[0], 1, 0); + src = scheme_datum_to_syntax(argv[1], src, DTS_CAN_GRAPH); if (properties) { ((Scheme_Stx *)src)->props = properties; } - if (!SCHEME_FALSEP(argv[0]) && !is_clean(argv[0])) { - int mutate = MUTATE_STX_OBJ; - add_taint_to_stx(src, &mutate); - } - return src; } @@ -8032,7 +874,7 @@ Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv) if (!SCHEME_STXP(argv[0])) scheme_wrong_contract("syntax-e", "syntax?", 0, argc, argv); - return scheme_stx_content(argv[0]); + return SCHEME_STX_VAL(argv[0]); } static Scheme_Object *syntax_line(int argc, Scheme_Object **argv) @@ -8055,7 +897,7 @@ static Scheme_Object *syntax_col(int argc, Scheme_Object **argv) if (!SCHEME_STXP(argv[0])) scheme_wrong_contract("syntax-column", "syntax?", 0, argc, argv); - if (stx->srcloc->col < 0) + if (stx->srcloc->col <= 0) return scheme_false; else return scheme_make_integer(stx->srcloc->col-1); @@ -8097,99 +939,16 @@ static Scheme_Object *syntax_src(int argc, Scheme_Object **argv) return stx->srcloc->src; } -static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv) -{ - Scheme_Object *l; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax->list", "syntax?", 0, argc, argv); - - l = scheme_stx_content(argv[0]); - if (SCHEME_NULLP(l)) - return scheme_null; - else if (SCHEME_PAIRP(l)) { - int islist; - l = scheme_flatten_syntax_list(l, &islist); - if (islist) - return l; - else - return scheme_false; - } else - return scheme_false; -} - -static Scheme_Object *syntax_tainted_p(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-tainted?", "syntax?", 0, argc, argv); - - return (scheme_stx_is_tainted(argv[0]) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-original?", "syntax?", 0, argc, argv); - - if (scheme_syntax_is_original(argv[0])) - return scheme_true; - else - return scheme_false; -} - -int scheme_syntax_is_original(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Object *key, *val; - intptr_t i; - - if (stx->props) { - if (!scheme_hash_tree_get(stx->props, source_symbol)) - return 0; - } else - return 0; - - /* Look for any non-original scope: */ - i = scope_set_next(stx->scopes->simple_scopes, -1); - while (i != -1) { - scope_set_index(stx->scopes->simple_scopes, i, &key, &val); - - if (SCHEME_SCOPE_KIND(key) == SCHEME_STX_MACRO_SCOPE) - return 0; - - i = scope_set_next(stx->scopes->simple_scopes, i); - } - - return 1; -} - -Scheme_Object *scheme_syntax_remove_original(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - Scheme_Hash_Tree *props = stx->props; - - if (!props) - return (Scheme_Object *)stx; - - props = scheme_hash_tree_set(props, source_symbol, NULL); - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, NULL); - stx->props = props; - - return (Scheme_Object *)stx; -} - -Scheme_Object *scheme_stx_property2(Scheme_Object *_stx, - Scheme_Object *key, - Scheme_Object *val, - int preserve) -/* `val` can be scheme_syntax_property_preserve_type already to - make it preserved, but preserve must be 0 in that case */ +Scheme_Object *scheme_stx_property(Scheme_Object *_stx, + Scheme_Object *key, + Scheme_Object *val) { Scheme_Stx *stx; Scheme_Hash_Tree *props; + if (!SCHEME_STXP(_stx)) + return scheme_false; + stx = (Scheme_Stx *)_stx; props = stx->props; @@ -8197,10 +956,6 @@ Scheme_Object *scheme_stx_property2(Scheme_Object *_stx, props = empty_hash_tree; if (val) { - if (preserve) { - MZ_ASSERT(!SAME_TYPE(SCHEME_TYPE(val), scheme_syntax_property_preserve_type)); - val = make_preserved_property_value(val); - } props = scheme_hash_tree_set(props, key, val); stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, NULL); stx->props = props; @@ -8209,60 +964,19 @@ Scheme_Object *scheme_stx_property2(Scheme_Object *_stx, val = scheme_hash_tree_get(props, key); if (!val) return scheme_false; - else if (SAME_TYPE(SCHEME_TYPE(val), scheme_syntax_property_preserve_type)) - return SCHEME_PTR_VAL(val); - else - return val; + return val; } } -Scheme_Object *scheme_stx_property(Scheme_Object *_stx, - Scheme_Object *key, - Scheme_Object *val) -{ - return scheme_stx_property2(_stx, key, val, 0); -} - - static Scheme_Object *syntax_property(int argc, Scheme_Object **argv) { if (!SCHEME_STXP(argv[0])) scheme_wrong_contract("syntax-property", "syntax?", 0, argc, argv); - if ((argc > 3) && SCHEME_TRUEP(argv[3])) { - if (!SCHEME_SYMBOLP(argv[1]) || SCHEME_SYM_WEIRDP(argv[1])) - scheme_contract_error("syntax-property", - "expected an interned symbol key for a preserved property", - "given", 1, argv[1], - NULL); - } - - return scheme_stx_property2(argv[0], - argv[1], - (argc > 2) ? argv[2] : NULL, - ((argc > 3) - ? SCHEME_TRUEP(argv[3]) - : SAME_OBJ(argv[1], scheme_paren_shape_symbol))); -} - -static Scheme_Object *syntax_property_preserved_p(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx; - Scheme_Object *v; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-property-preserved?", "syntax?", 0, argc, argv); - if (!SCHEME_SYMBOLP(argv[1]) || SCHEME_SYM_WEIRDP(argv[1])) - scheme_wrong_contract("syntax-property-preserved?", "(and/c symbol? symbol-interned?)", 1, argc, argv); - - stx = (Scheme_Stx *)argv[0]; - if (!stx->props) - return scheme_false; - - v = scheme_hash_tree_get(stx->props, argv[1]); - if (!v || !SAME_TYPE(SCHEME_TYPE(v), scheme_syntax_property_preserve_type)) - return scheme_false; - return scheme_true; + if (argc > 2) + return scheme_stx_property(argv[0], argv[1], argv[2]); + else + return scheme_stx_property(argv[0], argv[1], NULL); } static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) @@ -8292,511 +1006,6 @@ static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) return scheme_null; } -#define SCHEME_STX_IDP(o) (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))) - -static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv) -{ - Scheme_Object *result, *observer; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-track-origin", "syntax?", 0, argc, argv); - if (!SCHEME_STXP(argv[1])) - scheme_wrong_contract("syntax-track-origin", "syntax?", 1, argc, argv); - if (!SCHEME_STX_IDP(argv[2])) - scheme_wrong_contract("syntax-track-origin", "identifier?", 2, argc, argv); - - result = scheme_stx_track(argv[0], argv[1], argv[2]); - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(observer, argv[0], result); - return result; -} - -Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from) -{ - if (!SAME_OBJ(((Scheme_Stx *)from)->srcloc, empty_srcloc)) { - to = clone_stx(to, NULL); - ((Scheme_Stx *)to)->srcloc = ((Scheme_Stx *)from)->srcloc; - } - - return to; -} - -static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p) -{ - Scheme_Object *r, *delta, *taint_p, *phase; - int mode = SCHEME_STX_ADD; - - r = argv[0]; - if (argc > 1) - mode = scheme_get_introducer_mode("syntax-delta-introducer", 1, argc, argv); - - if (!SCHEME_STXP(r)) - scheme_wrong_contract("syntax-delta-introducer", "syntax?", 0, argc, argv); - - delta = SCHEME_PRIM_CLOSURE_ELS(p)[0]; - taint_p = SCHEME_PRIM_CLOSURE_ELS(p)[1]; - phase = SCHEME_PRIM_CLOSURE_ELS(p)[2]; - - r = scheme_stx_adjust_scopes(r, (Scheme_Scope_Set *)delta, phase, mode); - - if (SCHEME_TRUEP(taint_p)) - r = scheme_stx_taint(r); - - return r; -} - -static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_Object **argv, - Scheme_Object *delta, int use_shift) -{ - Scheme_Object *phase; - - if (argc > pos) { - phase = argv[pos]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_contract(who, "(or/c exact-integer? #f)", pos, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - intptr_t ph; - ph = (p->current_local_env - ? p->current_local_env->genv->phase - : (use_shift - ? p->current_phase_shift - : 0)); - phase = scheme_make_integer(ph); - - if (SCHEME_FALSEP(delta) || SCHEME_FALSEP(phase)) - phase = scheme_false; - else - phase = scheme_bin_plus(delta, phase); - } - - return phase; -} - -static Scheme_Object *syntax_debug_info(int argc, Scheme_Object **argv) -{ - Scheme_Object *phase; - int all_bindings; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-debug-info", "syntax?", 0, argc, argv); - - phase = extract_phase("syntax-debug-info", 1, argc, argv, - scheme_make_integer(0), 0); - - all_bindings = ((argc > 2) && SCHEME_TRUEP(argv[2])); - - return stx_debug_info((Scheme_Stx *)argv[0], phase, scheme_null, all_bindings); -} - -Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) -{ - Scheme_Object *a[3], *key, *val, *src; - Scheme_Object *phase; - Scheme_Scope_Set *delta, *m2; - intptr_t i; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_contract("make-syntax-delta-introducer", "identifier?", 0, argc, argv); - if (!SCHEME_STXP(argv[1]) && !SCHEME_FALSEP(argv[1])) - scheme_wrong_contract("make-syntax-delta-introducer", "(or/c syntax? #f)", 1, argc, argv); - - phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1); - - delta = extract_scope_set((Scheme_Stx *)argv[0], phase); - - src = argv[1]; - if (!SCHEME_FALSEP(src)) { - m2 = extract_scope_set((Scheme_Stx *)src, phase); - if (!scope_subset(m2, delta)) - m2 = NULL; - } else - m2 = NULL; - - if (!m2 && !SCHEME_FALSEP(src)) { - src = scheme_stx_lookup_w_nominal(argv[1], phase, 1, - NULL, NULL, &m2, - NULL, NULL, NULL, NULL, NULL); - } - - if (m2) { - i = scope_set_next(m2, -1); - while (i != -1) { - scope_set_index(m2, i, &key, &val); - if (scope_set_get(delta, key)) - delta = scope_set_set(delta, key, NULL); - - i = scope_set_next(m2, i); - } - } - - a[0] = (Scheme_Object *)delta; - if (scheme_stx_is_clean(argv[0])) - a[1] = scheme_false; - else - a[1] = scheme_true; - a[2] = phase; - - return scheme_make_prim_closure_w_arity(delta_introducer, 3, a, "delta-introducer", 1, 2); -} - -Scheme_Object *scheme_stx_binding_union(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase) -{ - Scheme_Scope_Set *current, *m2; - Scheme_Object *key, *val; - intptr_t i; - int mutate = 0; - - current = extract_scope_set((Scheme_Stx *)o, phase); - m2 = extract_scope_set((Scheme_Stx *)b, phase); - - i = scope_set_next(m2, -1); - while (i != -1) { - scope_set_index(m2, i, &key, &val); - if (!scope_set_get(current, key)) { - o = stx_adjust_scope(o, key, phase, SCHEME_STX_ADD, &mutate); - } - - i = scope_set_next(m2, i); - } - - return o; -} - -Scheme_Object *scheme_stx_binding_subtract(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase) -{ - Scheme_Scope_Set *current, *m2; - Scheme_Object *key, *val; - intptr_t i; - int mutate = 0; - - current = extract_scope_set((Scheme_Stx *)o, phase); - m2 = extract_scope_set((Scheme_Stx *)b, phase); - - i = scope_set_next(m2, -1); - while (i != -1) { - scope_set_index(m2, i, &key, &val); - if (scope_set_get(current, key)) { - o = stx_adjust_scope(o, key, phase, SCHEME_STX_REMOVE, &mutate); - } - - i = scope_set_next(m2, i); - } - - return o; -} - -static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) -{ - Scheme_Object *phase; - - if (!SCHEME_STX_IDP(argv[0])) - scheme_wrong_contract("bound-identifier=?", "identifier?", 0, argc, argv); - if (!SCHEME_STX_IDP(argv[1])) - scheme_wrong_contract("bound-identifier=?", "identifier?", 1, argc, argv); - - phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0); - - return (scheme_stx_env_bound_eq2(argv[0], argv[1], phase, phase) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *do_free_eq(const char *who, int delta, int argc, Scheme_Object **argv) -{ - Scheme_Object *phase, *phase2; - int v; - - if (!SCHEME_STX_IDP(argv[0])) - scheme_wrong_contract(who, "identifier?", 0, argc, argv); - if (!SCHEME_STX_IDP(argv[1])) - scheme_wrong_contract(who, "identifier?", 1, argc, argv); - - phase = extract_phase(who, 2, argc, argv, - ((delta == MZ_LABEL_PHASE) - ? scheme_false - : scheme_make_integer(delta)), - 0); - if (argc > 3) - phase2 = extract_phase(who, 3, argc, argv, phase, 0); - else - phase2 = phase; - - v = scheme_stx_free_eq3(argv[0], argv[1], phase, phase2); - - return (v - ? scheme_true - : scheme_false); -} - -static Scheme_Object *free_eq(int argc, Scheme_Object **argv) -{ - return do_free_eq("free-identifier=?", 0, argc, argv); -} - -static Scheme_Object *free_trans_eq(int argc, Scheme_Object **argv) -{ - return do_free_eq("free-transformer-identifier=?", 1, argc, argv); -} - -static Scheme_Object *free_templ_eq(int argc, Scheme_Object **argv) -{ - return do_free_eq("free-template-identifier=?", -1, argc, argv); -} - -static Scheme_Object *free_label_eq(int argc, Scheme_Object **argv) -{ - return do_free_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv); -} - -static Scheme_Object *do_free_binding(char *name, int argc, Scheme_Object **argv, - Scheme_Object *dphase, int get_symbol) -{ - Scheme_Object *a, *m, *nom_mod, *nom_a, *phase; - Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase; - int top_level_as_symbol = 0; - - a = argv[0]; - - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_contract(name, "identifier?", 0, argc, argv); - - phase = extract_phase(name, 1, argc, argv, dphase, 1); - - if (argc > 1) { - phase = argv[1]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_contract(name, "(or/c exact-integer? #f)", 1, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - phase = scheme_make_integer(p->current_local_env - ? p->current_local_env->genv->phase - : p->current_phase_shift); - if (SCHEME_FALSEP(dphase) || SCHEME_FALSEP(phase)) - phase = scheme_false; - else - phase = scheme_bin_plus(dphase, phase); - } - - if (argc > 2) - top_level_as_symbol = SCHEME_TRUEP(argv[2]); - - m = scheme_stx_lookup_w_nominal(a, phase, 0, - NULL, NULL, NULL, NULL, - &nom_mod, &nom_a, - &src_phase_index, - &nominal_src_phase); - - if (get_symbol) { - if (SCHEME_VECTORP(m)) - return SCHEME_VEC_ELS(m)[1]; - else - return SCHEME_STX_VAL(a); - } - - if (SCHEME_FALSEP(m)) - return scheme_false; - else if (SCHEME_SYMBOLP(m)) - return lexical_symbol; - else { - a = SCHEME_VEC_ELS(m)[1]; - mod_phase = SCHEME_VEC_ELS(m)[2]; - m = SCHEME_VEC_ELS(m)[0]; - - if (SCHEME_FALSEP(m)) { - if (top_level_as_symbol) - return CONS(a, scheme_null); - else - return scheme_false; - } - - return CONS(m, CONS(a, CONS(nom_mod, - CONS(nom_a, - CONS(mod_phase, - CONS(src_phase_index, - CONS(nominal_src_phase, - scheme_null))))))); - } -} - -static Scheme_Object *free_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-binding", argc, argv, scheme_make_integer(0), 0); -} - -static Scheme_Object *free_trans_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1), 0); -} - -static Scheme_Object *free_templ_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1), 0); -} - -static Scheme_Object *free_label_binding(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-label-binding", argc, argv, scheme_false, 0); -} - -static Scheme_Object *free_binding_symbol(int argc, Scheme_Object **argv) -{ - return do_free_binding("identifier-binding-symbol", argc, argv, scheme_make_integer(0), 1); -} - -static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv) -{ - Scheme_Object *a = argv[0], *l; - - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_contract("identifier-prune-lexical-context", "identifier?", 0, argc, argv); - - if (argc > 1) { - l = argv[1]; - while (SCHEME_PAIRP(l)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(l))) - break; - l = SCHEME_CDR(l); - } - if (!SCHEME_NULLP(l)) - scheme_wrong_contract("identifier-prune-lexical-context", "(listof symbol?)", 1, argc, argv); - l = argv[1]; - } else { - l = scheme_make_pair(SCHEME_STX_VAL(a), scheme_null); - } - - /* FIXME: implement pruning */ - - return a; -} - -static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - Scheme_Object *shifts; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_STX_SYMBOLP(argv[0])) - scheme_wrong_contract("identifier-prune-to-source-module", "identifier?", 0, argc, argv); - - shifts = stx->shifts; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->shifts = shifts; - - return (Scheme_Object *)stx; -} - -static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv) -{ - int source = 0; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-source-module", "syntax?", 0, argc, argv); - - if ((argc > 1) && SCHEME_TRUEP(argv[1])) - source = 1; - - return scheme_stx_source_module(argv[0], source, source); -} - -/**********************************************************************/ - -static Scheme_Object *syntax_arm(int argc, Scheme_Object **argv) -{ - Scheme_Object *insp; - int use_mode; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-arm", "syntax?", 0, argc, argv); - if ((argc > 1) && !SCHEME_FALSEP(argv[1])) { - if (!SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_inspector_type)) - scheme_wrong_contract("syntax-arm", "(or/c inspector? #f)", 1, argc, argv); - insp = argv[1]; - } else - insp = scheme_false; - - use_mode = ((argc > 2) && SCHEME_TRUEP(argv[2])); - - return scheme_syntax_taint_arm(argv[0], insp, use_mode); -} - -static Scheme_Object *syntax_disarm(int argc, Scheme_Object **argv) -{ - Scheme_Object *insp; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-disarm", "syntax?", 0, argc, argv); - if (argc > 1) { - if (SCHEME_TRUEP(argv[1]) && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_inspector_type)) - scheme_wrong_contract("syntax-disarm", "(or/c inspector? #f)", 1, argc, argv); - insp = argv[1]; - } else - insp = scheme_false; - - return scheme_syntax_taint_disarm(argv[0], insp); -} - -static Scheme_Object *syntax_rearm(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-rearm", "syntax?", 0, argc, argv); - if (!SCHEME_STXP(argv[1])) - scheme_wrong_contract("syntax-rearm", "syntax?", 1, argc, argv); - - if ((argc > 2) && SCHEME_TRUEP(argv[2])) - return scheme_syntax_taint_rearm(argv[0], argv[1]); - else - return scheme_stx_taint_rearm(argv[0], argv[1]); -} - -static Scheme_Object *syntax_taint(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_contract("syntax-taint", "syntax?", 0, argc, argv); - - return add_taint_to_stx(argv[0], NULL); - -} - -/**********************************************************************/ -/* Debugging */ -/**********************************************************************/ - -Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) -{ - Scheme_Object *vec, *v; - - if (SCHEME_PAIRP(stx)) { - return scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(stx), ht), - scheme_explode_syntax(SCHEME_CDR(stx), ht)); - } - if (SCHEME_NULLP(stx)) - return scheme_null; - - vec = scheme_hash_get(ht, stx); - if (vec) - return vec; - - vec = scheme_make_vector(3, NULL); - scheme_hash_set(ht, stx, vec); - - v = ((Scheme_Stx *)stx)->val; - if (SCHEME_PAIRP(v)) { - v = scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(v), ht), - scheme_explode_syntax(SCHEME_CDR(v), ht)); - } - SCHEME_VEC_ELS(vec)[0] = v; - - v = ((Scheme_Stx *)stx)->taints; - SCHEME_VEC_ELS(vec)[1] = (v ? v : scheme_null); - SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)((Scheme_Stx *)stx)->scopes; - - return vec; -} - /**********************************************************************/ #ifdef MZ_PRECISE_GC @@ -8808,9 +1017,6 @@ START_XFORM_SKIP; static void register_traversers(void) { GC_REG_TRAV(scheme_rt_srcloc, mark_srcloc); - GC_REG_TRAV(scheme_scope_type, mark_scope); - GC_REG_TRAV(scheme_scope_table_type, mark_scope_table); - GC_REG_TRAV(scheme_propagate_table_type, mark_propagate_table); } END_XFORM_SKIP; diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 32c9331231..8c86181796 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -89,6 +89,8 @@ extern int scheme_jit_malloced; # define scheme_jit_malloced 0 #endif +SHARED_OK int scheme_init_load_on_demand = 1; + /*========================================================================*/ /* local variables and prototypes */ /*========================================================================*/ @@ -131,9 +133,6 @@ THREAD_LOCAL_DECL(static int num_major_garbage_collections); THREAD_LOCAL_DECL(static int num_minor_garbage_collections); #endif -SHARED_OK static int init_load_on_demand = 1; -SHARED_OK static int compiled_file_check = SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS; - #ifdef RUNSTACK_IS_GLOBAL THREAD_LOCAL_DECL(Scheme_Object **scheme_current_runstack_start); THREAD_LOCAL_DECL(Scheme_Object **scheme_current_runstack); @@ -201,8 +200,6 @@ ROSYM static Scheme_Object *client_symbol, *server_symbol; ROSYM static Scheme_Object *major_symbol, *minor_symbol, *incremental_symbol; ROSYM static Scheme_Object *cumulative_symbol; -ROSYM static Scheme_Object *initial_compiled_file_check_symbol; - THREAD_LOCAL_DECL(static int do_atomic = 0); THREAD_LOCAL_DECL(static int missed_context_switch = 0); THREAD_LOCAL_DECL(static int have_activity = 0); @@ -356,9 +353,6 @@ static Scheme_Object *plumber_remove_flush(int argc, Scheme_Object *argv[]); static Scheme_Object *plumber_flush_p(int argc, Scheme_Object *argv[]); static Scheme_Object *current_plumber(int argc, Scheme_Object *argv[]); -static Scheme_Object *current_namespace(int argc, Scheme_Object *args[]); -static Scheme_Object *namespace_p(int argc, Scheme_Object *args[]); - static Scheme_Object *parameter_p(int argc, Scheme_Object *args[]); static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object *args[]); static Scheme_Object *make_parameter(int argc, Scheme_Object *args[]); @@ -488,7 +482,7 @@ SHARED_OK Scheme_Object *initial_cmdline_vec; /* initialization */ /*========================================================================*/ -void scheme_init_thread(Scheme_Env *env) +void scheme_init_thread(Scheme_Startup_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); @@ -520,26 +514,24 @@ void scheme_init_thread(Scheme_Env *env) REGISTER_SO(cumulative_symbol); cumulative_symbol = scheme_intern_symbol("cumulative"); - GLOBAL_PRIM_W_ARITY("dump-memory-stats" , scheme_dump_gc_stats, 0, -1, env); - GLOBAL_PRIM_W_ARITY("vector-set-performance-stats!", current_stats , 1, 2, env); + ADD_PRIM_W_ARITY("dump-memory-stats" , scheme_dump_gc_stats, 0, -1, env); + ADD_PRIM_W_ARITY("vector-set-performance-stats!", current_stats , 1, 2, env); - GLOBAL_PRIM_W_ARITY("make-empty-namespace", scheme_make_namespace, 0, 0, env); - - GLOBAL_PRIM_W_ARITY("thread" , sch_thread , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread/suspend-to-kill", sch_thread_nokill , 1, 1, env); - GLOBAL_PRIM_W_ARITY("sleep" , sch_sleep , 0, 1, env); - GLOBAL_FOLDING_PRIM("thread?" , thread_p , 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-running?" , thread_running_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-dead?" , thread_dead_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-wait" , thread_wait , 1, 1, env); - GLOBAL_PRIM_W_ARITY("current-thread" , sch_current , 0, 0, env); - GLOBAL_PRIM_W_ARITY("kill-thread" , kill_thread , 1, 1, env); - GLOBAL_PRIM_W_ARITY("break-thread" , break_thread , 1, 2, env); - GLOBAL_PRIM_W_ARITY("thread-suspend" , thread_suspend , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-resume" , thread_resume , 1, 2, env); - GLOBAL_PRIM_W_ARITY("thread-resume-evt" , make_thread_resume , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-suspend-evt" , make_thread_suspend, 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-dead-evt" , make_thread_dead , 1, 1, env); + ADD_PRIM_W_ARITY("thread" , sch_thread , 1, 1, env); + ADD_PRIM_W_ARITY("thread/suspend-to-kill", sch_thread_nokill , 1, 1, env); + ADD_PRIM_W_ARITY("sleep" , sch_sleep , 0, 1, env); + ADD_FOLDING_PRIM("thread?" , thread_p , 1, 1, 1, env); + ADD_PRIM_W_ARITY("thread-running?" , thread_running_p , 1, 1, env); + ADD_PRIM_W_ARITY("thread-dead?" , thread_dead_p , 1, 1, env); + ADD_PRIM_W_ARITY("thread-wait" , thread_wait , 1, 1, env); + ADD_PRIM_W_ARITY("current-thread" , sch_current , 0, 0, env); + ADD_PRIM_W_ARITY("kill-thread" , kill_thread , 1, 1, env); + ADD_PRIM_W_ARITY("break-thread" , break_thread , 1, 2, env); + ADD_PRIM_W_ARITY("thread-suspend" , thread_suspend , 1, 1, env); + ADD_PRIM_W_ARITY("thread-resume" , thread_resume , 1, 2, env); + ADD_PRIM_W_ARITY("thread-resume-evt" , make_thread_resume , 1, 1, env); + ADD_PRIM_W_ARITY("thread-suspend-evt" , make_thread_suspend, 1, 1, env); + ADD_PRIM_W_ARITY("thread-dead-evt" , make_thread_dead , 1, 1, env); register_thread_sync(); scheme_add_evt(scheme_thread_suspend_type, (Scheme_Ready_Fun)resume_suspend_ready, NULL, NULL, 1); @@ -548,134 +540,131 @@ void scheme_init_thread(Scheme_Env *env) scheme_add_evt(scheme_cust_box_type, cust_box_ready, NULL, NULL, 0); - GLOBAL_PARAMETER("current-custodian" , current_custodian , MZCONFIG_CUSTODIAN, env); - GLOBAL_PRIM_W_ARITY("make-custodian" , make_custodian , 0, 1, env); - GLOBAL_FOLDING_PRIM("custodian?" , custodian_p , 1, 1, 1 , env); - GLOBAL_PRIM_W_ARITY("custodian-shutdown-all", custodian_close_all , 1, 1, env); - GLOBAL_PRIM_W_ARITY("custodian-shut-down?" , custodian_shut_down_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("custodian-managed-list", custodian_to_list , 2, 2, env); - GLOBAL_PRIM_W_ARITY("make-custodian-box" , make_custodian_box , 2, 2, env); - GLOBAL_PRIM_W_ARITY("custodian-box-value" , custodian_box_value , 1, 1, env); - GLOBAL_FOLDING_PRIM("custodian-box?" , custodian_box_p , 1, 1, 1 , env); - GLOBAL_PRIM_W_ARITY("call-in-nested-thread" , call_as_nested_thread, 1, 2, env); + ADD_PARAMETER("current-custodian" , current_custodian , MZCONFIG_CUSTODIAN, env); + ADD_PRIM_W_ARITY("make-custodian" , make_custodian , 0, 1, env); + ADD_FOLDING_PRIM("custodian?" , custodian_p , 1, 1, 1 , env); + ADD_PRIM_W_ARITY("custodian-shutdown-all", custodian_close_all , 1, 1, env); + ADD_PRIM_W_ARITY("custodian-shut-down?" , custodian_shut_down_p, 1, 1, env); + ADD_PRIM_W_ARITY("custodian-managed-list", custodian_to_list , 2, 2, env); + ADD_PRIM_W_ARITY("make-custodian-box" , make_custodian_box , 2, 2, env); + ADD_PRIM_W_ARITY("custodian-box-value" , custodian_box_value , 1, 1, env); + ADD_FOLDING_PRIM("custodian-box?" , custodian_box_p , 1, 1, 1 , env); + ADD_PRIM_W_ARITY("call-in-nested-thread" , call_as_nested_thread, 1, 2, env); - GLOBAL_PARAMETER("current-plumber" , current_plumber , MZCONFIG_PLUMBER, env); - GLOBAL_PRIM_W_ARITY("make-plumber" , make_plumber , 0, 0, env); - GLOBAL_FOLDING_PRIM("plumber?" , plumber_p , 1, 1, 1 , env); - GLOBAL_PRIM_W_ARITY("plumber-flush-all" , plumber_flush_all , 1, 1, env); - GLOBAL_PRIM_W_ARITY("plumber-add-flush!" , plumber_add_flush , 2, 3, env); - GLOBAL_PRIM_W_ARITY("plumber-flush-handle-remove!" , plumber_remove_flush, 1, 1, env); - GLOBAL_PRIM_W_ARITY("plumber-flush-handle?" , plumber_flush_p , 1, 1, env); + ADD_PARAMETER("current-plumber" , current_plumber , MZCONFIG_PLUMBER, env); + ADD_PRIM_W_ARITY("make-plumber" , make_plumber , 0, 0, env); + ADD_FOLDING_PRIM("plumber?" , plumber_p , 1, 1, 1 , env); + ADD_PRIM_W_ARITY("plumber-flush-all" , plumber_flush_all , 1, 1, env); + ADD_PRIM_W_ARITY("plumber-add-flush!" , plumber_add_flush , 2, 3, env); + ADD_PRIM_W_ARITY("plumber-flush-handle-remove!" , plumber_remove_flush, 1, 1, env); + ADD_PRIM_W_ARITY("plumber-flush-handle?" , plumber_flush_p , 1, 1, env); - GLOBAL_PARAMETER("current-namespace" , current_namespace, MZCONFIG_ENV, env); - GLOBAL_PRIM_W_ARITY("namespace?" , namespace_p , 1, 1, env); + ADD_PRIM_W_ARITY("security-guard?" , security_guard_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-security-guard", make_security_guard, 3, 4, env); + ADD_PARAMETER("current-security-guard", current_security_guard, MZCONFIG_SECURITY_GUARD, env); - GLOBAL_PRIM_W_ARITY("security-guard?" , security_guard_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-security-guard", make_security_guard, 3, 4, env); - GLOBAL_PARAMETER("current-security-guard", current_security_guard, MZCONFIG_SECURITY_GUARD, env); + ADD_PRIM_W_ARITY("thread-group?" , thread_set_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-thread-group", make_thread_set, 0, 1, env); + ADD_PARAMETER("current-thread-group", current_thread_set, MZCONFIG_THREAD_SET, env); - GLOBAL_PRIM_W_ARITY("thread-group?" , thread_set_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-thread-group", make_thread_set, 0, 1, env); - GLOBAL_PARAMETER("current-thread-group", current_thread_set, MZCONFIG_THREAD_SET, env); + ADD_PRIM_W_ARITY("parameter?" , parameter_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-parameter" , make_parameter , 1, 2, env); + ADD_PRIM_W_ARITY("make-derived-parameter", make_derived_parameter, 3, 3, env); + ADD_PRIM_W_ARITY("parameter-procedure=?" , parameter_procedure_eq, 2, 2, env); + ADD_PRIM_W_ARITY("parameterization?" , parameterization_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("parameter?" , parameter_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-parameter" , make_parameter , 1, 2, env); - GLOBAL_PRIM_W_ARITY("make-derived-parameter", make_derived_parameter, 3, 3, env); - GLOBAL_PRIM_W_ARITY("parameter-procedure=?" , parameter_procedure_eq, 2, 2, env); - GLOBAL_PRIM_W_ARITY("parameterization?" , parameterization_p , 1, 1, env); + ADD_PRIM_W_ARITY("thread-cell?" , thread_cell_p , 1, 1, env); + ADD_PRIM_W_ARITY("make-thread-cell" , make_thread_cell , 1, 2, env); + ADD_PRIM_W_ARITY("thread-cell-ref" , thread_cell_get , 1, 1, env); + ADD_PRIM_W_ARITY("thread-cell-set!" , thread_cell_set , 2, 2, env); + ADD_PRIM_W_ARITY("current-preserved-thread-cell-values", thread_cell_values, 0, 1, env); + ADD_FOLDING_PRIM("thread-cell-values?" , is_thread_cell_values, 1, 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-cell?" , thread_cell_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-thread-cell" , make_thread_cell , 1, 2, env); - GLOBAL_PRIM_W_ARITY("thread-cell-ref" , thread_cell_get , 1, 1, env); - GLOBAL_PRIM_W_ARITY("thread-cell-set!" , thread_cell_set , 2, 2, env); - GLOBAL_PRIM_W_ARITY("current-preserved-thread-cell-values", thread_cell_values, 0, 1, env); - GLOBAL_FOLDING_PRIM("thread-cell-values?" , is_thread_cell_values, 1, 1, 1, env); - - GLOBAL_PRIM_W_ARITY("make-will-executor", make_will_executor, 0, 0, env); - GLOBAL_PRIM_W_ARITY("will-executor?" , will_executor_p , 1, 1, env); - GLOBAL_PRIM_W_ARITY("will-register" , register_will , 3, 3, env); - GLOBAL_PRIM_W_ARITY("will-try-execute" , will_executor_try , 1, 1, env); - GLOBAL_PRIM_W_ARITY("will-execute" , will_executor_go , 1, 1, env); + ADD_PRIM_W_ARITY("make-will-executor", make_will_executor, 0, 0, env); + ADD_PRIM_W_ARITY("will-executor?" , will_executor_p , 1, 1, env); + ADD_PRIM_W_ARITY("will-register" , register_will , 3, 3, env); + ADD_PRIM_W_ARITY("will-try-execute" , will_executor_try , 1, 2, env); + ADD_PRIM_W_ARITY("will-execute" , will_executor_go , 1, 1, env); scheme_add_evt_through_sema(scheme_will_executor_type, will_executor_sema, NULL); - GLOBAL_PRIM_W_ARITY("collect-garbage" , collect_garbage , 0, 1, env); - GLOBAL_PRIM_W_ARITY("current-memory-use" , current_memory_use , 0, 1, env); + ADD_PRIM_W_ARITY("collect-garbage" , collect_garbage , 0, 1, env); + ADD_PRIM_W_ARITY("current-memory-use" , current_memory_use , 0, 1, env); - GLOBAL_PRIM_W_ARITY("custodian-require-memory" , custodian_require_mem, 3, 3, env); - GLOBAL_PRIM_W_ARITY("custodian-limit-memory" , custodian_limit_mem , 2, 3, env); - GLOBAL_PRIM_W_ARITY("custodian-memory-accounting-available?", custodian_can_mem , 0, 0, env); + ADD_PRIM_W_ARITY("custodian-require-memory" , custodian_require_mem, 3, 3, env); + ADD_PRIM_W_ARITY("custodian-limit-memory" , custodian_limit_mem , 2, 3, env); + ADD_PRIM_W_ARITY("custodian-memory-accounting-available?", custodian_can_mem , 0, 0, env); - GLOBAL_FOLDING_PRIM("evt?" , evt_p , 1, 1 , 1, env); - GLOBAL_PRIM_W_ARITY2("sync" , sch_sync , 0, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("sync/timeout" , sch_sync_timeout , 1, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("sync/enable-break" , sch_sync_enable_break , 0, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY2("sync/timeout/enable-break", sch_sync_timeout_enable_break, 1, -1, 0, -1, env); - GLOBAL_PRIM_W_ARITY("choice-evt" , evts_to_evt , 0, -1, env); + ADD_FOLDING_PRIM("evt?" , evt_p , 1, 1 , 1, env); + ADD_PRIM_W_ARITY2("sync" , sch_sync , 0, -1, 0, -1, env); + ADD_PRIM_W_ARITY2("sync/timeout" , sch_sync_timeout , 1, -1, 0, -1, env); + ADD_PRIM_W_ARITY2("sync/enable-break" , sch_sync_enable_break , 0, -1, 0, -1, env); + ADD_PRIM_W_ARITY2("sync/timeout/enable-break", sch_sync_timeout_enable_break, 1, -1, 0, -1, env); + ADD_PRIM_W_ARITY("choice-evt" , evts_to_evt , 0, -1, env); - GLOBAL_PARAMETER("current-thread-initial-stack-size", current_thread_initial_stack_size, MZCONFIG_THREAD_INIT_STACK_SIZE, env); + ADD_PARAMETER("current-thread-initial-stack-size", current_thread_initial_stack_size, MZCONFIG_THREAD_INIT_STACK_SIZE, env); - GLOBAL_PRIM_W_ARITY("phantom-bytes?", phantom_bytes_p, 1, 1, env); - GLOBAL_PRIM_W_ARITY("make-phantom-bytes", make_phantom_bytes, 1, 1, env); - GLOBAL_PRIM_W_ARITY("set-phantom-bytes!", set_phantom_bytes, 2, 2, env); + ADD_PRIM_W_ARITY("phantom-bytes?", phantom_bytes_p, 1, 1, env); + ADD_PRIM_W_ARITY("make-phantom-bytes", make_phantom_bytes, 1, 1, env); + ADD_PRIM_W_ARITY("set-phantom-bytes!", set_phantom_bytes, 2, 2, env); } void -scheme_init_unsafe_thread (Scheme_Env *env) +scheme_init_unsafe_thread (Scheme_Startup_Env *env) { - scheme_add_global_constant("unsafe-start-atomic", + scheme_addto_prim_instance("unsafe-start-atomic", scheme_make_prim_w_arity(unsafe_start_atomic, "unsafe-start-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-end-atomic", + scheme_addto_prim_instance("unsafe-end-atomic", scheme_make_prim_w_arity(unsafe_end_atomic, "unsafe-end-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-start-breakable-atomic", + scheme_addto_prim_instance("unsafe-start-breakable-atomic", scheme_make_prim_w_arity(unsafe_start_breakable_atomic, "unsafe-start-breakable-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-end-breakable-atomic", + scheme_addto_prim_instance("unsafe-end-breakable-atomic", scheme_make_prim_w_arity(unsafe_end_breakable_atomic, "unsafe-end-breakable-atomic", 0, 0), env); - scheme_add_global_constant("unsafe-in-atomic?", + scheme_addto_prim_instance("unsafe-in-atomic?", scheme_make_prim_w_arity(unsafe_in_atomic_p, "unsafe-in-atomic?", 0, 0), env); - GLOBAL_PRIM_W_ARITY("unsafe-thread-at-root", unsafe_thread_at_root, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-thread-at-root", unsafe_thread_at_root, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-make-custodian-at-root", unsafe_make_custodian_at_root, 0, 0, env); - GLOBAL_PRIM_W_ARITY("unsafe-custodian-register", unsafe_custodian_register, 5, 5, env); - GLOBAL_PRIM_W_ARITY("unsafe-custodian-unregister", unsafe_custodian_unregister, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-make-custodian-at-root", unsafe_make_custodian_at_root, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-custodian-register", unsafe_custodian_register, 5, 5, env); + ADD_PRIM_W_ARITY("unsafe-custodian-unregister", unsafe_custodian_unregister, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-register-process-global", unsafe_register_process_global, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-get-place-table", unsafe_get_place_table, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-register-process-global", unsafe_register_process_global, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-get-place-table", unsafe_get_place_table, 0, 0, env); - GLOBAL_PRIM_W_ARITY("unsafe-set-on-atomic-timeout!", unsafe_set_on_atomic_timeout, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-set-on-atomic-timeout!", unsafe_set_on_atomic_timeout, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-make-security-guard-at-root", unsafe_make_security_guard_at_root, 0, 3, env); + ADD_PRIM_W_ARITY("unsafe-make-security-guard-at-root", unsafe_make_security_guard_at_root, 0, 3, env); - scheme_add_global_constant("unsafe-poller", scheme_unsafe_poller_proc, env); - GLOBAL_PRIM_W_ARITY("unsafe-poll-ctx-fd-wakeup", unsafe_poll_ctx_fd_wakeup, 3, 3, env); - GLOBAL_PRIM_W_ARITY("unsafe-poll-ctx-eventmask-wakeup", unsafe_poll_ctx_eventmask_wakeup, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-poll-ctx-milliseconds-wakeup", unsafe_poll_ctx_time_wakeup, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-signal-received", unsafe_signal_received, 0, 0, env); - GLOBAL_PRIM_W_ARITY("unsafe-set-sleep-in-thread!", unsafe_set_sleep_in_thread, 2, 2, env); + scheme_addto_prim_instance("unsafe-poller", scheme_unsafe_poller_proc, env); + ADD_PRIM_W_ARITY("unsafe-poll-ctx-fd-wakeup", unsafe_poll_ctx_fd_wakeup, 3, 3, env); + ADD_PRIM_W_ARITY("unsafe-poll-ctx-eventmask-wakeup", unsafe_poll_ctx_eventmask_wakeup, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-poll-ctx-milliseconds-wakeup", unsafe_poll_ctx_time_wakeup, 2, 2, env); + ADD_PRIM_W_ARITY("unsafe-signal-received", unsafe_signal_received, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-set-sleep-in-thread!", unsafe_set_sleep_in_thread, 2, 2, env); - GLOBAL_PRIM_W_ARITY("unsafe-os-thread-enabled?", unsafe_os_thread_enabled_p, 0, 0, env); - GLOBAL_PRIM_W_ARITY("unsafe-call-in-os-thread", unsafe_call_in_os_thread, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-make-os-semaphore", unsafe_make_os_semaphore, 0, 0, env); - GLOBAL_PRIM_W_ARITY("unsafe-os-semaphore-wait", unsafe_os_semaphore_wait, 1, 1, env); - GLOBAL_PRIM_W_ARITY("unsafe-os-semaphore-post", unsafe_os_semaphore_post, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-os-thread-enabled?", unsafe_os_thread_enabled_p, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-call-in-os-thread", unsafe_call_in_os_thread, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-make-os-semaphore", unsafe_make_os_semaphore, 0, 0, env); + ADD_PRIM_W_ARITY("unsafe-os-semaphore-wait", unsafe_os_semaphore_wait, 1, 1, env); + ADD_PRIM_W_ARITY("unsafe-os-semaphore-post", unsafe_os_semaphore_post, 1, 1, env); } void scheme_init_thread_places(void) { @@ -698,11 +687,6 @@ void scheme_init_inspector() { instances. */ } -void scheme_set_compiled_file_check(int c) -{ - compiled_file_check = c; -} - Scheme_Object *scheme_get_current_inspector() XFORM_SKIP_PROC { @@ -730,39 +714,25 @@ void scheme_init_parameterization() scheme_break_enabled_key = scheme_make_symbol("break-on?"); } -void scheme_init_param_symbol() +void scheme_init_paramz(Scheme_Startup_Env *env) { - REGISTER_SO(initial_compiled_file_check_symbol); - if (compiled_file_check == SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS) - initial_compiled_file_check_symbol = scheme_intern_symbol("modify-seconds"); - else - initial_compiled_file_check_symbol = scheme_intern_symbol("exists"); -} - -void scheme_init_paramz(Scheme_Env *env) -{ - Scheme_Object *v; - Scheme_Env *newenv; - - v = scheme_intern_symbol("#%paramz"); - newenv = scheme_primitive_module(v, env); + scheme_switch_prim_instance(env, "#%paramz"); - scheme_add_global_constant("exception-handler-key", scheme_exn_handler_key , newenv); - scheme_add_global_constant("parameterization-key" , scheme_parameterization_key, newenv); - scheme_add_global_constant("break-enabled-key" , scheme_break_enabled_key , newenv); + scheme_addto_prim_instance("exception-handler-key", scheme_exn_handler_key , env); + scheme_addto_prim_instance("parameterization-key" , scheme_parameterization_key, env); + scheme_addto_prim_instance("break-enabled-key" , scheme_break_enabled_key , env); - GLOBAL_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, newenv); - GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv); - GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv); + ADD_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, env); + ADD_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, env); + ADD_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, env); - GLOBAL_PRIM_W_ARITY("cache-configuration" , cache_configuration, 2, 2, newenv); + ADD_PRIM_W_ARITY("cache-configuration" , cache_configuration, 2, 2, env); - GLOBAL_PRIM_W_ARITY("security-guard-check-file", security_guard_check_file, 3, 3, newenv); - GLOBAL_PRIM_W_ARITY("security-guard-check-file-link", security_guard_check_file_link, 3, 3, newenv); - GLOBAL_PRIM_W_ARITY("security-guard-check-network", security_guard_check_network, 4, 4, newenv); + ADD_PRIM_W_ARITY("security-guard-check-file", security_guard_check_file, 3, 3, env); + ADD_PRIM_W_ARITY("security-guard-check-file-link", security_guard_check_file_link, 3, 3, env); + ADD_PRIM_W_ARITY("security-guard-check-network", security_guard_check_network, 4, 4, env); - scheme_finish_primitive_module(newenv); - scheme_protect_primitive_provide(newenv, NULL); + scheme_restore_prim_instance(env); } static Scheme_Object *collect_garbage(int argc, Scheme_Object *argv[]) @@ -2508,8 +2478,6 @@ static Scheme_Thread *make_thread(Scheme_Config *config, process->block_needs_wakeup = NULL; process->sleep_end = 0; - process->current_local_env = NULL; - process->external_break = 0; process->ran_some = 1; @@ -7534,6 +7502,9 @@ Scheme_Object *scheme_get_thread_param(Scheme_Config *c, Scheme_Thread_Cell_Tabl Scheme_Object *scheme_get_param(Scheme_Config *c, int pos) { + if (pos == MZCONFIG_ENV) + return (Scheme_Object *)scheme_get_current_namespace_as_env(); + return scheme_get_thread_param(c, scheme_current_thread->cell_values, pos); } @@ -7544,6 +7515,11 @@ void scheme_set_thread_param(Scheme_Config *c, Scheme_Thread_Cell_Table *cells, void scheme_set_param(Scheme_Config *c, int pos, Scheme_Object *o) { + if (pos == MZCONFIG_ENV) { + scheme_set_current_namespace_as_env((Scheme_Env *)o); + return; + } + scheme_thread_cell_set(find_param_cell(c, scheme_make_integer(pos), 1), scheme_current_thread->cell_values, o); } @@ -7876,19 +7852,10 @@ static void make_initial_config(Scheme_Thread *p) p->init_config = config; - init_param(cells, paramz, MZCONFIG_READTABLE, scheme_make_default_readtable()); - - init_param(cells, paramz, MZCONFIG_CAN_READ_GRAPH, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_COMPILED, scheme_false); - init_param(cells, paramz, MZCONFIG_CAN_READ_BOX, scheme_true); + init_param(cells, paramz, MZCONFIG_CASE_SENS, (scheme_case_sensitive ? scheme_true : scheme_false)); init_param(cells, paramz, MZCONFIG_CAN_READ_PIPE_QUOTE, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_DOT, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_INFIX_DOT, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_QUASI, scheme_true); - init_param(cells, paramz, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true); - init_param(cells, paramz, MZCONFIG_CAN_READ_READER, scheme_false); - init_param(cells, paramz, MZCONFIG_CAN_READ_LANG, scheme_true); - init_param(cells, paramz, MZCONFIG_LOAD_DELAY_ENABLED, init_load_on_demand ? scheme_true : scheme_false); + + init_param(cells, paramz, MZCONFIG_LOAD_DELAY_ENABLED, scheme_init_load_on_demand ? scheme_true : scheme_false); init_param(cells, paramz, MZCONFIG_DELAY_LOAD_INFO, scheme_false); init_param(cells, paramz, MZCONFIG_PRINT_GRAPH, scheme_false); @@ -7913,16 +7880,6 @@ static void make_initial_config(Scheme_Thread *p) init_param(cells, paramz, MZCONFIG_LOCALE, s); } - init_param(cells, paramz, MZCONFIG_CASE_SENS, (scheme_case_sensitive ? scheme_true : scheme_false)); - init_param(cells, paramz, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, (scheme_square_brackets_are_parens - ? scheme_true : scheme_false)); - init_param(cells, paramz, MZCONFIG_CURLY_BRACES_ARE_PARENS, (scheme_curly_braces_are_parens - ? scheme_true : scheme_false)); - - init_param(cells, paramz, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, scheme_false); - init_param(cells, paramz, MZCONFIG_CURLY_BRACES_ARE_TAGGED, scheme_false); - init_param(cells, paramz, MZCONFIG_READ_CDOT, scheme_false); - init_param(cells, paramz, MZCONFIG_ERROR_PRINT_WIDTH, scheme_make_integer(256)); init_param(cells, paramz, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, scheme_make_integer(16)); init_param(cells, paramz, MZCONFIG_ERROR_PRINT_SRCLOC, scheme_true); @@ -7943,11 +7900,6 @@ static void make_initial_config(Scheme_Thread *p) ? scheme_true : scheme_false)); - init_param(cells, paramz, MZCONFIG_COLLECTION_PATHS, scheme_null); - init_param(cells, paramz, MZCONFIG_COLLECTION_LINKS, scheme_null); - - init_param(cells, paramz, MZCONFIG_USE_COMPILED_FILE_CHECK, initial_compiled_file_check_symbol); - { Scheme_Security_Guard *sg; @@ -7999,23 +7951,6 @@ static void make_initial_config(Scheme_Thread *p) rs = scheme_make_random_state(scheme_get_milliseconds()); init_param(cells, paramz, MZCONFIG_SCHEDULER_RANDOM_STATE, rs); } - - { - Scheme_Object *eh; - eh = scheme_make_prim_w_arity2(scheme_default_eval_handler, - "default-eval-handler", - 1, 1, - 0, -1); - init_param(cells, paramz, MZCONFIG_EVAL_HANDLER, eh); - } - - { - Scheme_Object *eh; - eh = scheme_make_prim_w_arity(scheme_default_compile_handler, - "default-compile-handler", - 2, 2); - init_param(cells, paramz, MZCONFIG_COMPILE_HANDLER, eh); - } { Scheme_Object *ph; @@ -8093,7 +8028,7 @@ Scheme_Config *scheme_minimal_config(void) void scheme_set_startup_load_on_demand(int on) { - init_load_on_demand = on; + scheme_init_load_on_demand = on; } Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which) @@ -8308,7 +8243,7 @@ static Scheme_Object *set_phantom_bytes(int argc, Scheme_Object *argv[]) } /*========================================================================*/ -/* namespaces */ +/* environment */ /*========================================================================*/ Scheme_Env *scheme_get_env(Scheme_Config *c) @@ -8323,37 +8258,6 @@ Scheme_Env *scheme_get_env(Scheme_Config *c) return (Scheme_Env *)o; } -Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[]) -{ - Scheme_Env *genv, *env; - intptr_t phase; - - genv = scheme_get_env(NULL); - env = scheme_make_empty_env(); - - for (phase = genv->phase; phase--; ) { - scheme_prepare_exp_env(env); - env = env->exp_env; - } - - return (Scheme_Object *)env; -} - -static Scheme_Object *namespace_p(int argc, Scheme_Object **argv) -{ - return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_namespace_type)) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *current_namespace(int argc, Scheme_Object *argv[]) -{ - return scheme_param_config2("current-namespace", - scheme_make_integer(MZCONFIG_ENV), - argc, argv, - -1, namespace_p, "namespace?", 0); -} - /*========================================================================*/ /* security guards */ /*========================================================================*/ @@ -8727,6 +8631,8 @@ static Scheme_Object *will_executor_try(int argc, Scheme_Object **argv) if (scheme_wait_sema(w->sema, 1)) return do_next_will(w); + else if (argc > 1) + return argv[1]; else return scheme_false; } @@ -9172,8 +9078,6 @@ static void get_ready_for_GC() scheme_zero_unneeded_rands(scheme_current_thread); - scheme_clear_modidx_cache(); - scheme_clear_shift_cache(); scheme_clear_prompt_cache(); scheme_clear_rx_buffers(); scheme_clear_bignum_cache(); @@ -9410,7 +9314,7 @@ static void log_peak_memory_use() Scheme_Logger *logger; if (max_gc_pre_used_bytes > 0) { logger = scheme_get_gc_logger(); - if (logger && scheme_log_level_p(logger, SCHEME_LOG_DEBUG)) { + if (logger && scheme_log_level_p(logger, SCHEME_LOG_INFO)) { char buf[256], nums[128], *num, *numt, *num2; intptr_t buflen, allocated_bytes; #ifdef MZ_PRECISE_GC @@ -9433,7 +9337,7 @@ static void log_peak_memory_use() num_minor_garbage_collections, num2); buflen = strlen(buf); - scheme_log_message(logger, SCHEME_LOG_DEBUG, buf, buflen, scheme_false); + scheme_log_message(logger, SCHEME_LOG_INFO, buf, buflen, scheme_false); /* Setting to a negative value ensures that we log the peak only once: */ max_gc_pre_used_bytes = -1; } diff --git a/racket/src/racket/src/type.c b/racket/src/racket/src/type.c index 47c63edef4..780199aa65 100644 --- a/racket/src/racket/src/type.c +++ b/racket/src/racket/src/type.c @@ -28,8 +28,6 @@ /* types should all be registered before invoking places */ -SHARED_OK Scheme_Type_Reader *scheme_type_readers; -SHARED_OK Scheme_Type_Writer *scheme_type_writers; SHARED_OK Scheme_Equal_Proc *scheme_type_equals; SHARED_OK Scheme_Primary_Hash_Proc *scheme_type_hash1s; SHARED_OK Scheme_Secondary_Hash_Proc *scheme_type_hash2s; @@ -56,8 +54,6 @@ static void init_type_arrays() #endif REGISTER_SO(type_names); - REGISTER_SO(scheme_type_readers); - REGISTER_SO(scheme_type_writers); REGISTER_SO(scheme_type_equals); REGISTER_SO(scheme_type_hash1s); REGISTER_SO(scheme_type_hash2s); @@ -67,19 +63,12 @@ static void init_type_arrays() type_names = RAW_MALLOC_N(char *, allocmax); memset(type_names, 0, allocmax * sizeof(char *)); - scheme_type_readers = RAW_MALLOC_N(Scheme_Type_Reader, allocmax); - n = allocmax * sizeof(Scheme_Type_Reader); - memset(scheme_type_readers, 0, n); #ifdef MEMORY_COUNTING_ON scheme_type_table_count += n; scheme_misc_count += (allocmax * sizeof(char *)); #endif - scheme_type_writers = RAW_MALLOC_N(Scheme_Type_Writer, allocmax); - n = allocmax * sizeof(Scheme_Type_Writer); - memset(scheme_type_writers, 0, n); - #ifdef MEMORY_COUNTING_ON scheme_type_table_count += n; #endif @@ -112,7 +101,6 @@ scheme_init_type () set_name(scheme_local_unbox_type, ""); set_name(scheme_variable_type, ""); set_name(scheme_toplevel_type, ""); - set_name(scheme_module_variable_type, ""); set_name(scheme_application_type, ""); set_name(scheme_application2_type, ""); set_name(scheme_application3_type, ""); @@ -121,18 +109,12 @@ scheme_init_type () set_name(scheme_branch_type, ""); set_name(scheme_sequence_type, ""); set_name(scheme_with_cont_mark_type, ""); - set_name(scheme_quote_syntax_type, ""); set_name(scheme_define_values_type, ""); - set_name(scheme_define_syntaxes_type, ""); - set_name(scheme_begin_for_syntax_type, ""); set_name(scheme_begin0_sequence_type, ""); - set_name(scheme_splice_sequence_type, ""); - set_name(scheme_module_type, ""); set_name(scheme_inline_variant_type, ""); set_name(scheme_set_bang_type, ""); set_name(scheme_boxenv_type, ""); - set_name(scheme_require_form_type, ""); set_name(scheme_varref_form_type, ""); set_name(scheme_apply_values_type, ""); set_name(scheme_with_immed_mark_type, ""); @@ -144,11 +126,15 @@ scheme_init_type () set_name(scheme_ir_let_value_type, ""); set_name(scheme_ir_let_header_type, ""); set_name(scheme_ir_toplevel_type, ""); - set_name(scheme_ir_quote_syntax_type, ""); set_name(scheme_letrec_type, ""); set_name(scheme_let_one_type, ""); set_name(scheme_quote_compilation_type, ""); + set_name(scheme_linklet_type, ""); + set_name(scheme_instance_type, ""); + set_name(scheme_linklet_directory_type, ""); + set_name(scheme_linklet_bundle_type, ""); + set_name(scheme_eval_waiting_type, ""); set_name(scheme_void_type, ""); set_name(scheme_prim_type, ""); @@ -206,7 +192,6 @@ scheme_init_type () set_name(scheme_hash_tree_subtree_type, ""); set_name(scheme_hash_tree_collision_type, ""); set_name(scheme_bucket_table_type, ""); - set_name(scheme_module_registry_type, ""); set_name(scheme_case_closure_type, ""); set_name(scheme_placeholder_type, ""); set_name(scheme_table_placeholder_type, ""); @@ -218,21 +203,15 @@ scheme_init_type () set_name(scheme_listener_type, ""); set_name(scheme_tcp_accept_evt_type, ""); set_name(scheme_filesystem_change_evt_type, ""); - set_name(scheme_namespace_type, ""); + set_name(scheme_env_type, ""); set_name(scheme_config_type, ""); set_name(scheme_will_executor_type, ""); set_name(scheme_random_state_type, ""); set_name(scheme_regexp_type, ""); - set_name(scheme_scope_table_type, ""); - set_name(scheme_propagate_table_type, ""); - set_name(scheme_scope_type, ""); set_name(scheme_bucket_type, ""); set_name(scheme_prefix_type, ""); - set_name(scheme_resolve_prefix_type, ""); set_name(scheme_readtable_type, ""); - set_name(scheme_compilation_top_type, ""); - set_name(scheme_svector_type, ""); set_name(scheme_custodian_type, ""); @@ -244,20 +223,12 @@ scheme_init_type () set_name(scheme_inspector_type, ""); - set_name(scheme_stx_type, ""); - set_name(scheme_stx_offset_type, ""); - set_name(scheme_expanded_syntax_type, ""); - set_name(scheme_set_macro_type, ""); - set_name(scheme_id_macro_type, ""); - - set_name(scheme_module_index_type, ""); + set_name(scheme_stx_type, ""); set_name(scheme_subprocess_type, ""); set_name(scheme_cpointer_type, ""); - set_name(scheme_wrap_chunk_type, ""); - set_name(scheme_security_guard_type, ""); set_name(scheme_indent_type, ""); @@ -296,17 +267,10 @@ scheme_init_type () set_name(scheme_channel_syncer_type, ""); - set_name(scheme_special_comment_type, ""); - set_name(scheme_global_ref_type, ""); set_name(scheme_delay_syntax_type, ""); - set_name(scheme_intdef_context_type, ""); - set_name(scheme_lexical_rib_type, ""); - - set_name(scheme_already_comp_type, ""); - set_name(scheme_logger_type, ""); set_name(scheme_log_reader_type, ""); @@ -321,19 +285,20 @@ scheme_init_type () set_name(scheme_place_bi_channel_type, ""); set_name(scheme_place_dead_type, ""); - set_name(scheme_resolved_module_path_type, ""); - set_name(scheme_phantom_bytes_type, ""); set_name(scheme_environment_variables_type, ""); + set_name(scheme_prompt_type, ""); + set_name(scheme_startup_env_type, ""); + set_name(scheme_ctype_type, ""); + set_name(scheme_unquoted_printing_string_type, ""); -#ifdef MZ_GC_BACKTRACE +#ifdef MZ_PRECISE_GC set_name(scheme_rt_runstack, ""); set_name(scheme_rt_meta_cont, ""); set_name(scheme_rt_weak_array, ""); - set_name(scheme_syntax_property_preserve_type, ""); set_name(scheme_rt_resolve_info, ""); set_name(scheme_rt_unresolve_info, ""); set_name(scheme_rt_optimize_info, ""); @@ -347,8 +312,29 @@ scheme_init_type () set_name(scheme_rt_native_code_plus_case, ""); set_name(scheme_rt_sfs_info, ""); set_name(scheme_rt_letrec_check_frame, ""); - set_name(scheme_rt_module_exports, ""); - set_name(scheme_rt_export_info, ""); + set_name(scheme_rt_saved_stack, ""); + set_name(scheme_rt_overflow_jmp, ""); + set_name(scheme_rt_dyn_wind, ""); + set_name(scheme_rt_dyn_wind_info, ""); + set_name(scheme_rt_dyn_wind_cell, ""); + set_name(scheme_rt_input_fd, ""); + set_name(scheme_rt_pipe, ""); + set_name(scheme_rt_param_data, ""); + set_name(scheme_rt_will, ""); + set_name(scheme_rt_finalization, ""); + set_name(scheme_rt_finalizations, ""); + set_name(scheme_thread_hop_type, ""); + set_name(scheme_rt_evt, ""); + set_name(scheme_rt_syncing, ""); + set_name(scheme_rt_user_input, ""); + set_name(scheme_rt_user_output, ""); + set_name(scheme_rt_compact_port, ""); + set_name(scheme_rt_rx_lazy_string, ""); + set_name(scheme_rt_parameterization, ""); + set_name(scheme_rt_delay_load_info, ""); + set_name(scheme_rt_validate_clearing, ""); + set_name(scheme_rt_print_params, ""); + set_name(scheme_rt_comp_env, ""); #endif } @@ -376,18 +362,6 @@ Scheme_Type scheme_make_type(const char *name) free(type_names); type_names = (char **)naya; - naya = malloc(n = allocmax * sizeof(Scheme_Type_Reader)); - memset(naya, 0, n); - memcpy(naya, scheme_type_readers, maxtype * sizeof(Scheme_Type_Reader)); - free(scheme_type_readers); - scheme_type_readers = (Scheme_Type_Reader *)naya; - - naya = malloc(n = allocmax * sizeof(Scheme_Type_Writer)); - memset(naya, 0, n); - memcpy(naya, scheme_type_writers, maxtype * sizeof(Scheme_Type_Writer)); - free(scheme_type_writers); - scheme_type_writers = (Scheme_Type_Writer *)naya; - naya = malloc(n = allocmax * sizeof(Scheme_Equal_Proc)); memset(naya, 0, n); memcpy(naya, scheme_type_equals, maxtype * sizeof(Scheme_Equal_Proc)); @@ -407,8 +381,6 @@ Scheme_Type scheme_make_type(const char *name) scheme_type_hash2s = (Scheme_Secondary_Hash_Proc *)naya; #ifdef MEMORY_COUNTING_ON - scheme_type_table_count += 20 * (sizeof(Scheme_Type_Reader) - + sizeof(Scheme_Type_Writer)); scheme_misc_count += (20 * sizeof(char *)); #endif } @@ -446,23 +418,6 @@ char *scheme_get_type_name(Scheme_Type t) return s ? s : "???"; } -void scheme_install_type_reader(Scheme_Type t, Scheme_Type_Reader f) -{ - if (t < 0 || t >= maxtype) - return; - - scheme_type_readers[t] = f; -} - -void scheme_install_type_writer(Scheme_Type t, Scheme_Type_Writer f) -{ - if (t < 0 || t >= maxtype) - return; - - scheme_type_writers[t] = f; -} - - void scheme_set_type_equality(Scheme_Type t, Scheme_Equal_Proc f, Scheme_Primary_Hash_Proc hash1, @@ -588,41 +543,35 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_letrec_type, letrec); GC_REG_TRAV(scheme_let_one_type, let_one); GC_REG_TRAV(scheme_with_cont_mark_type, with_cont_mark); - GC_REG_TRAV(scheme_quote_syntax_type, quotesyntax_obj); - GC_REG_TRAV(scheme_module_variable_type, module_var); GC_REG_TRAV(scheme_define_values_type, vector_obj); - GC_REG_TRAV(scheme_define_syntaxes_type, vector_obj); - GC_REG_TRAV(scheme_begin_for_syntax_type, vector_obj); GC_REG_TRAV(scheme_varref_form_type, twoptr_obj); GC_REG_TRAV(scheme_apply_values_type, twoptr_obj); GC_REG_TRAV(scheme_with_immed_mark_type, with_cont_mark); GC_REG_TRAV(scheme_boxenv_type, twoptr_obj); GC_REG_TRAV(scheme_case_lambda_sequence_type, case_closure); GC_REG_TRAV(scheme_begin0_sequence_type, seq_rec); - GC_REG_TRAV(scheme_splice_sequence_type, seq_rec); GC_REG_TRAV(scheme_set_bang_type, set_bang); - GC_REG_TRAV(scheme_module_type, module_val); - GC_REG_TRAV(scheme_rt_export_info, exp_info_val); - GC_REG_TRAV(scheme_require_form_type, twoptr_obj); GC_REG_TRAV(scheme_inline_variant_type, vector_obj); GC_REG_TRAV(_scheme_values_types_, bad_trav); GC_REG_TRAV(scheme_ir_lambda_type, unclosed_proc); GC_REG_TRAV(scheme_ir_local_type, ir_local); + GC_REG_TRAV(scheme_ir_toplevel_type, ir_toplevel); GC_REG_TRAV(scheme_ir_let_value_type, ir_let_value); GC_REG_TRAV(scheme_ir_let_header_type, let_header); - GC_REG_TRAV(scheme_ir_toplevel_type, toplevel_obj); - GC_REG_TRAV(scheme_ir_quote_syntax_type, local_obj); GC_REG_TRAV(scheme_quote_compilation_type, small_object); + GC_REG_TRAV(scheme_linklet_type, linklet_val); + GC_REG_TRAV(scheme_instance_type, instance_val); + GC_REG_TRAV(scheme_linklet_directory_type, small_object); + GC_REG_TRAV(scheme_linklet_bundle_type, small_object); + GC_REG_TRAV(_scheme_ir_values_types_, bad_trav); GC_REG_TRAV(scheme_prefix_type, prefix_val); - GC_REG_TRAV(scheme_resolve_prefix_type, resolve_prefix_val); - GC_REG_TRAV(scheme_rt_comp_prefix, comp_prefix_val); GC_REG_TRAV(scheme_prim_type, prim_proc); GC_REG_TRAV(scheme_closed_prim_type, closed_prim_proc); @@ -675,8 +624,6 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_true_type, small_atomic_obj); GC_REG_TRAV(scheme_false_type, small_atomic_obj); GC_REG_TRAV(scheme_void_type, small_atomic_obj); - GC_REG_TRAV(scheme_primitive_syntax_type, syntax_compiler); - GC_REG_TRAV(scheme_macro_type, small_object); GC_REG_TRAV(scheme_box_type, small_object); GC_REG_TRAV(scheme_thread_type, thread_val); GC_REG_TRAV(scheme_prompt_type, prompt_val); @@ -692,13 +639,10 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_thread_dead_type, small_object); GC_REG_TRAV(scheme_hash_table_type, hash_table_val); GC_REG_TRAV(scheme_bucket_table_type, bucket_table_val); - GC_REG_TRAV(scheme_module_registry_type, module_reg_val); - GC_REG_TRAV(scheme_namespace_type, namespace_val); + GC_REG_TRAV(scheme_env_type, env_val); + GC_REG_TRAV(scheme_startup_env_type, startup_env_val); GC_REG_TRAV(scheme_random_state_type, random_state_val); - GC_REG_TRAV(scheme_compilation_top_type, compilation_top_val); - GC_REG_TRAV(scheme_intdef_context_type, twoptr_obj); - GC_REG_TRAV(scheme_eval_waiting_type, bad_trav); GC_REG_TRAV(scheme_tail_call_waiting_type, bad_trav); GC_REG_TRAV(scheme_undefined_type, small_atomic_obj); @@ -707,15 +651,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_svector_type, svector_val); - GC_REG_TRAV(scheme_set_macro_type, small_object); - GC_REG_TRAV(scheme_id_macro_type, twoptr_obj); - GC_REG_TRAV(scheme_stx_type, stx_val); - GC_REG_TRAV(scheme_stx_offset_type, stx_off_val); - GC_REG_TRAV(scheme_expanded_syntax_type, twoptr_obj); - GC_REG_TRAV(scheme_rt_module_exports, module_exports_val); - GC_REG_TRAV(scheme_module_phase_exports_type, module_phase_exports_val); - GC_REG_TRAV(scheme_module_index_type, modidx_val); GC_REG_TRAV(scheme_security_guard_type, guard_val); @@ -732,12 +668,8 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_tcp_accept_evt_type, twoptr_obj); - GC_REG_TRAV(scheme_special_comment_type, small_object); - GC_REG_TRAV(scheme_progress_evt_type, twoptr_obj); - GC_REG_TRAV(scheme_already_comp_type, iptr_obj); - GC_REG_TRAV(scheme_will_be_lambda_type, iptr_obj); GC_REG_TRAV(scheme_thread_cell_values_type, small_object); @@ -745,25 +677,19 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_global_ref_type, twoptr_obj); GC_REG_TRAV(scheme_delay_syntax_type, small_object); - GC_REG_TRAV(scheme_marshal_share_type, small_object); - - GC_REG_TRAV(scheme_resolved_module_path_type, small_object); GC_REG_TRAV(scheme_logger_type, mark_logger); GC_REG_TRAV(scheme_log_reader_type, mark_log_reader); GC_REG_TRAV(scheme_rt_runstack, runstack_val); - GC_REG_TRAV(scheme_rib_delimiter_type, small_object); GC_REG_TRAV(scheme_noninline_proc_type, small_object); - GC_REG_TRAV(scheme_prune_context_type, small_object); GC_REG_TRAV(scheme_proc_shape_type, small_atomic_obj); GC_REG_TRAV(scheme_struct_proc_shape_type, struct_proc_shape); GC_REG_TRAV(scheme_struct_prop_proc_shape_type, small_atomic_obj); GC_REG_TRAV(scheme_environment_variables_type, small_object); - GC_REG_TRAV(scheme_syntax_property_preserve_type, small_object); GC_REG_TRAV(scheme_plumber_handle_type, twoptr_obj); diff --git a/racket/src/racket/src/unwind/libunwind.c b/racket/src/racket/src/unwind/libunwind.c index a454e6e40f..dc975d78fc 100644 --- a/racket/src/racket/src/unwind/libunwind.c +++ b/racket/src/racket/src/unwind/libunwind.c @@ -3142,7 +3142,7 @@ tdep_uc_addr (unw_context_t *uc, int reg) return addr; } -int dwarf_to_unw_regnum(reg) +int dwarf_to_unw_regnum(int reg) { #ifdef UNW_ARM return (((reg) < 16) ? (reg) : 0); diff --git a/racket/src/racket/src/validate.c b/racket/src/racket/src/validate.c index 0bb74c41bf..a6afc79ae1 100644 --- a/racket/src/racket/src/validate.c +++ b/racket/src/racket/src/validate.c @@ -37,7 +37,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, struct Validate_Clearing *vc, @@ -47,7 +47,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, static int validate_rator_wants_box(Scheme_Object *app_rator, int pos, int hope, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map); + int num_toplevels, int num_lifts, void *tl_use_map); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -143,117 +143,76 @@ static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int shape, i scheme_make_integer(shape)); } -static int phaseless_expr(Scheme_Object *expr) -{ - /* A precise check is a little tricky, since compiler optimizations - might change the original program beyond easily recognition of - the syntactic pattern that defines "phaseless". For now, let - anything through; the result can be weird if state somehow leakes - through a "phaseless" module, but I don't think it can be unsafe - from the run-time system's perspective. */ - return 1; -} - -void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, - int depth, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - Scheme_Object **toplevels, - int code_vec) -/* code_vec == 2 => check that phasesless is ok */ +void scheme_validate_linklet(Mz_CPort *port, Scheme_Linklet *linklet) { char *stack; - int delta; + int depth, delta, num_toplevels, i, j, pos; + int cnt, tl_timestamp = 1; struct Validate_Clearing *vc; Validate_TLS tls; mzshort *tl_state; Scheme_Hash_Table **_st_ht = NULL; - Scheme_Object *form; + Scheme_Object *form, *shape; - depth += ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); + depth = linklet->max_let_depth + 1; /* +1 is for prefix */ stack = scheme_malloc_atomic(depth); memset(stack, VALID_NOT, depth); - if (num_toplevels || num_stxes || num_lifts) { - stack[depth - 1] = VALID_TOPLEVELS; - } - delta = depth - ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); + stack[depth - 1] = VALID_TOPLEVELS; + delta = depth - 1; - tls = MALLOC_N(mzshort*, num_lifts); + tls = MALLOC_N(mzshort*, linklet->num_lifts); _st_ht = MALLOC_N(Scheme_Hash_Table*, 1); - - if (code_vec) { - int i; - tl_state = MALLOC_N_ATOMIC(mzshort, num_toplevels); - memset(tl_state, 0, sizeof(mzshort) * num_toplevels); - for (i = 0; i < num_toplevels; i++) { - if (SAME_TYPE(SCHEME_TYPE(toplevels[i]), scheme_module_variable_type)) { - int mv_flags = SCHEME_MODVAR_FLAGS(toplevels[i]); - if (mv_flags & SCHEME_MODVAR_CONST) { + + num_toplevels = SCHEME_LINKLET_PREFIX_PREFIX + linklet->num_total_imports + SCHEME_VEC_SIZE(linklet->defns); + + tl_state = MALLOC_N_ATOMIC(mzshort, num_toplevels); + memset(tl_state, 0, sizeof(mzshort) * num_toplevels); + + if (linklet->need_instance_access) + tl_state[0] = 1; + + pos = SCHEME_LINKLET_PREFIX_PREFIX; + for (i = 0; i < SCHEME_VEC_SIZE(linklet->importss); i++) { + for (j = 0; j < SCHEME_VEC_SIZE(SCHEME_VEC_ELS(linklet->importss)[i]); j++, pos++) { + shape = (linklet->import_shapes ? SCHEME_VEC_ELS(linklet->import_shapes)[pos-SCHEME_LINKLET_PREFIX_PREFIX] : scheme_false); + if (SCHEME_TRUEP(shape)) { + if (SAME_OBJ(shape, scheme_void)) + tl_state[pos] = SCHEME_TOPLEVEL_FIXED; + else { intptr_t k; - tl_state[i] = SCHEME_TOPLEVEL_CONST; - if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k)) - add_struct_mapping(_st_ht, i, k, 0); - else if (scheme_decode_struct_prop_shape(((Module_Variable *)toplevels[i])->shape, &k)) - add_struct_mapping(_st_ht, i, k, 1); - } else if (mv_flags & SCHEME_MODVAR_FIXED) - tl_state[i] = SCHEME_TOPLEVEL_FIXED; - else - tl_state[i] = SCHEME_TOPLEVEL_READY; - } - if (0) { - if (i < num_toplevels) { - if (SCHEME_SYMBOLP(toplevels[i])) - printf("%d is %s\n", i, SCHEME_SYM_VAL(toplevels[i])); - if (SAME_TYPE(SCHEME_TYPE(toplevels[i]), scheme_module_variable_type)) - printf("%d is imported %s (%d)\n", i, - SCHEME_SYM_VAL(((Module_Variable *)toplevels[i])->sym), - SCHEME_MODVAR_FLAGS(toplevels[i]) & 0x3); + tl_state[pos] = SCHEME_TOPLEVEL_CONST; + if (scheme_decode_struct_shape(shape, &k)) + add_struct_mapping(_st_ht, pos, k, 0); + else if (scheme_decode_struct_prop_shape(shape, &k)) + add_struct_mapping(_st_ht, pos, k, 1); } - } + } else + tl_state[pos] = SCHEME_TOPLEVEL_READY; } - } else { - tl_state = NULL; } vc = make_clearing_stack(); - if (code_vec) { - int i, cnt, tl_timestamp = 1; - cnt = SCHEME_VEC_SIZE(code); - for (i = 0; i < cnt; i++) { - form = SCHEME_VEC_ELS(code)[i]; - if (code_vec == 2) { - if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { - if (!phaseless_expr(SCHEME_VEC_ELS(form)[0])) - scheme_ill_formed_code(port); - } else - scheme_ill_formed_code(port); - } - reset_clearing(vc); - if (!validate_expr(port, form, - stack, tls, - depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - NULL, 0, 0, - vc, 1, 0, NULL, -1, _st_ht)) { - tl_timestamp++; - if (0) { - printf("increment to %d for %d %p\n", tl_timestamp, - SCHEME_TYPE(SCHEME_VEC_ELS(code)[i]), - SCHEME_VEC_ELS(code)[i]); - } + cnt = SCHEME_VEC_SIZE(linklet->bodies); + for (i = 0; i < cnt; i++) { + form = SCHEME_VEC_ELS(linklet->bodies)[i]; + reset_clearing(vc); + if (!validate_expr(port, form, + stack, tls, + depth, delta, delta, + num_toplevels, linklet->num_lifts, NULL, + tl_state, tl_timestamp, + NULL, 0, 0, + vc, 1, 0, NULL, -1, _st_ht)) { + tl_timestamp++; + if (0) { + printf("increment to %d for %d %p\n", tl_timestamp, + SCHEME_TYPE(SCHEME_VEC_ELS(linklet->bodies)[i]), + SCHEME_VEC_ELS(linklet->bodies)[i]); } } - } else { - validate_expr(port, code, - stack, tls, - depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, 0, - NULL, 0, 0, - vc, 1, 0, NULL, -1, NULL); } } @@ -279,7 +238,7 @@ static int validate_join_seq(int r1, int r2) static int validate_toplevel(Scheme_Object *expr, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int skip_refs_check) { @@ -288,7 +247,7 @@ static int validate_toplevel(Scheme_Object *expr, Mz_CPort *port, return validate_expr(port, expr, stack, tls, depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, skip_refs_check ? 1 : 0, 0, make_clearing_stack(), 0, 0, NULL, 1, NULL); @@ -297,7 +256,7 @@ static int validate_toplevel(Scheme_Object *expr, Mz_CPort *port, static int define_values_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -319,7 +278,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, for (i = 1; i < size; i++) { validate_toplevel(SCHEME_VEC_ELS(data)[i], port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, NULL, tl_timestamp, 1); } @@ -327,12 +286,12 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, if (only_var) { int pos; pos = SCHEME_TOPLEVEL_POS(only_var); - if (pos >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + if (pos >= (num_toplevels - num_lifts)) { /* It's a lift. Check whether it needs to take reference arguments and/or install reference info. */ Scheme_Object *app_rator; Scheme_Lambda *data = NULL; - int tp = pos - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); + int tp = pos - (num_toplevels - num_lifts); mzshort *a, *new_a = NULL; /* Make sure that no one has tried to register information. */ @@ -398,7 +357,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, int is; is = validate_rator_wants_box(val, i, a[i + 1] == 2, - tls, num_toplevels, num_stxes, num_lifts, tl_use_map); + tls, num_toplevels, num_lifts, tl_use_map); if ((is && (a[i + 1] == 1)) || (!is && (a[i + 1] == 2))) scheme_ill_formed_code(port); @@ -412,8 +371,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, if (scheme_is_simple_make_struct_type(val, size-1, CHECK_STRUCT_TYPE_RESOLVED, NULL, &stinfo, NULL, - NULL, NULL, (_st_ht ? *_st_ht : NULL), - NULL, 0, NULL, NULL, NULL, 5)) { + NULL, (_st_ht ? *_st_ht : NULL), + NULL, 0, NULL, NULL, 5)) { /* This set of bindings is constant across invocations, but if `uses_super', we need to increment tl_timestamp for subtype-defining `struct' sequences. */ @@ -425,8 +384,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, has_guard = 0; if (scheme_is_simple_make_struct_type_property(val, size-1, CHECK_STRUCT_TYPE_RESOLVED, &has_guard, - NULL, NULL, (_st_ht ? *_st_ht : NULL), - NULL, 0, NULL, NULL, 5)) { + NULL, (_st_ht ? *_st_ht : NULL), + NULL, 0, NULL, 5)) { is_struct_prop = 1; } else { is_struct_prop = 0; @@ -434,7 +393,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, result = validate_expr(port, val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp + ((is_struct && stinfo.uses_super) ? 1 : 0), NULL, !!only_var, 0, vc, 0, 0, NULL, size-1, _st_ht); @@ -485,7 +444,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, int ts = (tl_timestamp + (result ? 0 : 1)); if (tl_state) { int p = SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[i]); - if (p < num_toplevels) { + if (p < (num_toplevels - num_lifts)) { int s = -tl_state[p]; int expected_flags = s & SCHEME_TOPLEVEL_FLAGS_MASK; int this_flags = flags; @@ -503,8 +462,9 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, `(define x x)' with `x' claimed as constant. The `tl_timestamp++' before checking a closure body allows things like `(define x (lambda () x))'. */ - && ((s >> 2) <= ts))) + && ((s >> 2) <= ts))) { scheme_ill_formed_code(port); + } tl_state[p] = (ts << 2) | this_flags; } } @@ -516,7 +476,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, static int set_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -528,11 +488,11 @@ static int set_validate(Scheme_Object *data, Mz_CPort *port, int r1, r2; r1 = validate_expr(port, sb->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); r2 = validate_toplevel(sb->var, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, 0); @@ -542,28 +502,42 @@ static int set_validate(Scheme_Object *data, Mz_CPort *port, static void ref_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, struct Validate_Clearing *vc, int tailpos, Scheme_Hash_Tree *procs) { - validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - 0); - if (!SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) - validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + tl_timestamp++; /* allows (define x (#%variable-reference x)) */ + + if (!SCHEME_FALSEP(SCHEME_PTR1_VAL(data))) + validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, 0); + + if (!SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) { + /* must reference */ + int p; + data = SCHEME_PTR2_VAL(data); + if (!SAME_TYPE(scheme_toplevel_type, SCHEME_TYPE(data))) + scheme_ill_formed_code(port); + p = SCHEME_TOPLEVEL_POS(data); + if (p != 0) + scheme_ill_formed_code(port); + + validate_toplevel(data, port, stack, tls, depth, delta, + num_toplevels, num_lifts, tl_use_map, + tl_state, tl_timestamp, + 0); + } } static int apply_values_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -579,12 +553,12 @@ static int apply_values_validate(Scheme_Object *data, Mz_CPort *port, r1 = validate_expr(port, f, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); r2 = validate_expr(port, e, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, -1, _st_ht); @@ -594,7 +568,7 @@ static int apply_values_validate(Scheme_Object *data, Mz_CPort *port, static void inline_variant_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -609,19 +583,19 @@ static void inline_variant_validate(Scheme_Object *data, Mz_CPort *port, validate_expr(port, f1, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); validate_expr(port, f2, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); } static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -642,7 +616,7 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac && !SAME_TYPE(SCHEME_TYPE(e), scheme_closure_type)) scheme_ill_formed_code(port); validate_expr(port, e, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); } @@ -662,7 +636,7 @@ static void validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int d static int bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -674,7 +648,7 @@ static int bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, validate_boxenv(SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)), port, stack, depth, delta, letlimit); return validate_expr(port, SCHEME_PTR2_VAL(data), stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, result_ignored, vc, tailpos, 0, procs, expected_results, _st_ht); } @@ -682,7 +656,7 @@ static int bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, static int begin0_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, @@ -701,7 +675,7 @@ static int begin0_validate(Scheme_Object *data, Mz_CPort *port, for (i = 0; i < seq->count; i++) { r = validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, i > 0, vc, 0, 0, procs, (i > 0) ? -1 : expected_results, _st_ht); @@ -711,92 +685,6 @@ static int begin0_validate(Scheme_Object *data, Mz_CPort *port, return result; } -static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int for_stx) -{ - Resolve_Prefix *rp; - Scheme_Object *name, *val, *base_stack_depth, *dummy; - int sdepth; - - if (!SAME_TYPE(SCHEME_TYPE(data), (for_stx ? scheme_begin_for_syntax_type : scheme_define_syntaxes_type)) - || (SCHEME_VEC_SIZE(data) < 4)) - scheme_ill_formed_code(port); - - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(data)[1]; - base_stack_depth = SCHEME_VEC_ELS(data)[2]; - sdepth = SCHEME_INT_VAL(base_stack_depth); - - if (!SAME_TYPE(rp->so.type, scheme_resolve_prefix_type) - || (sdepth < 0)) - scheme_ill_formed_code(port); - - dummy = SCHEME_VEC_ELS(data)[3]; - - if (!for_stx) { - int i, size; - size = SCHEME_VEC_SIZE(data); - for (i = 4; i < size; i++) { - name = SCHEME_VEC_ELS(data)[i]; - if (!SCHEME_SYMBOLP(name)) { - scheme_ill_formed_code(port); - } - } - } - - validate_toplevel(dummy, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - 0); - - if (!for_stx) { - scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, - NULL, NULL, 0); - } else { - val = SCHEME_VEC_ELS(data)[0]; - while (SCHEME_PAIRP(val)) { - scheme_validate_code(port, SCHEME_CAR(val), sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, - NULL, NULL, 0); - val = SCHEME_CDR(val); - } - if (!SCHEME_NULLP(val)) - scheme_ill_formed_code(port); - } -} - -static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, 0); -} - -static void begin_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp,1); -} - /*========================================================================*/ /* expressions */ /*========================================================================*/ @@ -825,7 +713,7 @@ static Scheme_Object *validate_k(void) r = validate_expr(port, expr, stack, tls, args[0], args[1], args[2], - args[3], args[4], args[5], tl_use_map, + args[3], args[5], tl_use_map, tl_state, args[10], app_rator, args[6], args[7], vc, args[8], args[9], procs, args[11], @@ -840,7 +728,7 @@ static Scheme_Object *validate_k(void) int validate_rator_wants_box(Scheme_Object *app_rator, int pos, int hope, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map) + int num_toplevels, int num_lifts, void *tl_use_map) { Scheme_Lambda *data = NULL; Scheme_Type ty; @@ -857,7 +745,7 @@ int validate_rator_wants_box(Scheme_Object *app_rator, int pos, int p; p = SCHEME_TOPLEVEL_POS(app_rator); while (1) { - if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + if (p >= (num_toplevels - num_lifts)) { /* It's a lift. Check that the lift is defined, and that it doesn't want reference arguments. */ mzshort *a; /* 0x1 => no ref args, @@ -866,7 +754,7 @@ int validate_rator_wants_box(Scheme_Object *app_rator, int pos, ptr with 0 => another top-level */ int tp; - tp = (p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0))); + tp = (p - (num_toplevels - num_lifts)); if (tp >= num_lifts) return 0; @@ -942,7 +830,7 @@ static int argument_to_arity_error(Scheme_Object *app_rator, int proc_with_refs_ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, char *closure_stack, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, int self_pos_in_closure, Scheme_Hash_Tree *procs, Scheme_Hash_Table **_st_ht) @@ -1018,7 +906,7 @@ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, } validate_expr(port, data->body, new_stack, tls, sz, sz, base, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 1, 0, procs, -1, _st_ht); } @@ -1033,7 +921,7 @@ static Scheme_Hash_Tree *as_nonempty_procs(Scheme_Hash_Tree *procs) static void validate_lambda(Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, Scheme_Object *app_rator, int proc_with_refs_ok, int self_pos, Scheme_Hash_Tree *procs, @@ -1138,7 +1026,7 @@ static void validate_lambda(Mz_CPort *port, Scheme_Object *expr, SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)closure_stack; SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)tls; SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(num_toplevels); - SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(num_stxes); + SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(0); /* not used anymore */ SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(num_lifts); SCHEME_VEC_ELS(vec)[6] = scheme_make_integer(self_pos_in_closure); SCHEME_VEC_ELS(vec)[7] = new_procs ? (Scheme_Object *)new_procs : scheme_false; @@ -1149,7 +1037,7 @@ static void validate_lambda(Mz_CPort *port, Scheme_Object *expr, SCHEME_CAR(data->body) = vec; } else scheme_validate_closure(port, expr, closure_stack, tls, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, self_pos_in_closure, new_procs, _st_ht); } @@ -1171,73 +1059,6 @@ static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct V } } -static void module_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - Scheme_Module *m; - int i, j, cnt, let_depth; - Resolve_Prefix *rp; - Scheme_Object *e; - - m = (Scheme_Module *)data; - - if (!SCHEME_MODNAMEP(m->modname)) - scheme_ill_formed_code(port); - - if (m->phaseless && m->prefix->num_stxes) - scheme_ill_formed_code(port); - - if (m->max_let_depth < 0) - scheme_ill_formed_code(port); - - validate_toplevel(m->dummy, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - 0); - - scheme_validate_code(port, m->bodies[0], m->max_let_depth, - m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts, - NULL, m->prefix->toplevels, - (m->phaseless ? 2 : 1)); - - /* validate exp-time code */ - for (j = m->num_phases; j-- > 1; ) { - cnt = SCHEME_VEC_SIZE(m->bodies[j]); - for (i = 0; i < cnt; i++) { - if (m->phaseless) scheme_ill_formed_code(port); - - e = SCHEME_VEC_ELS(m->bodies[j])[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - e = SCHEME_VEC_ELS(e)[1]; - - scheme_validate_code(port, e, let_depth, - rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, NULL, - 0); - } - } -} - -static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, - mzshort *tl_state, mzshort tl_timestamp, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ -} - static void no_typed(int need_local_type, Mz_CPort *port) { if (need_local_type) scheme_ill_formed_code(port); @@ -1295,7 +1116,7 @@ static int is_functional_nonfailing_rator(Scheme_Object *rator, int num_args, in static int validate_expr(Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int num_toplevels, int num_lifts, void *tl_use_map, mzshort *tl_state, mzshort tl_timestamp, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, @@ -1330,7 +1151,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, args[1] = letlimit; args[2] = delta; args[3] = num_toplevels; - args[4] = num_stxes; + args[4] = 0; /* not used anymore */ args[5] = num_lifts; args[6] = proc_with_refs_ok; args[7] = result_ignored; @@ -1360,7 +1181,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, if (did_one) { if (app_rator) { if (validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, - tls, num_toplevels, num_stxes, num_lifts, + tls, num_toplevels, num_lifts, tl_use_map)) scheme_ill_formed_code(port); app_rator = NULL; @@ -1383,31 +1204,29 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, if ((c < 0) || (p < 0) || (d < 0) || (d >= depth) || (stack[d] != VALID_TOPLEVELS) - || (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0))) - || ((p >= num_toplevels) && (p < num_toplevels + num_stxes + (num_stxes ? 1 : 0)))) + || (p >= num_toplevels)) scheme_ill_formed_code(port); if (tl_use_map) { - int p2 = ((p < num_toplevels) - ? p - : (p - num_stxes)); - if (num_stxes && (p >= num_toplevels) && (p < (num_toplevels + num_stxes + 1))) - scheme_ill_formed_code(port); if ((uintptr_t)tl_use_map & 0x1) { - if (p2 > 31) + if (p > 31) scheme_ill_formed_code(port); - if (!((uintptr_t)tl_use_map & ((unsigned int)1 << (p2 + 1)))) + if (!((uintptr_t)tl_use_map & ((unsigned int)1 << (p + 1)))) scheme_ill_formed_code(port); } else { - if (p2 >= (*(int *)tl_use_map * 32)) + if (p >= (*(int *)tl_use_map * 32)) scheme_ill_formed_code(port); - if (!(((int *)tl_use_map)[1 + (p2 / 32)] & ((unsigned int)1 << (p2 & 31)))) + if (!(((int *)tl_use_map)[1 + (p / 32)] & ((unsigned int)1 << (p & 31)))) scheme_ill_formed_code(port); } } if ((flags > SCHEME_TOPLEVEL_UNKNOWN) && tl_state && (p < num_toplevels)) { - if (tl_state[p] <= 0) { + if (p < SCHEME_LINKLET_PREFIX_PREFIX) { + /* instance-access toplevel available? */ + if (!tl_state[p]) + scheme_ill_formed_code(port); + } else if (tl_state[p] <= 0) { /* record expectation */ int s = -tl_state[p]; int new_flags; @@ -1429,12 +1248,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, if ((proc_with_refs_ok != 1) && !argument_to_arity_error(app_rator, proc_with_refs_ok)) { - if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + if (p >= (num_toplevels - num_lifts)) { /* It's a lift. Check that the lift is defined, and that it doesn't want reference arguments. */ int tp; mzshort *a; - tp = p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); + tp = p - (num_toplevels - num_lifts); a = tls[tp]; if (a) { if (a == (mzshort *)0x1) { @@ -1490,7 +1309,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, } else if ((proc_with_refs_ok >= 2) && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR)) && validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 1, - tls, num_toplevels, num_stxes, num_lifts, + tls, num_toplevels, num_lifts, tl_use_map)) { /* It's ok - the function wants us to pass it a box, and we did. */ @@ -1572,7 +1391,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, for (i = 0; i < n; i++) { r = validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(result, r); @@ -1600,12 +1419,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, stack[delta] = VALID_NOT; r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 1, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); r = validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app->rator, 2, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); @@ -1641,17 +1460,17 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, stack[delta+1] = VALID_NOT; r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 1, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); r = validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app->rator, 2, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); r = validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app->rator, 3, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); @@ -1674,7 +1493,6 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, } break; case scheme_sequence_type: - case scheme_splice_sequence_type: { Scheme_Sequence *seq = (Scheme_Sequence *)expr; int cnt; @@ -1687,7 +1505,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, for (i = 0; i < cnt - 1; i++) { r = validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 1, vc, 0, 0, procs, -1, _st_ht); result = validate_join_seq(result, r); @@ -1704,7 +1522,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, b = (Scheme_Branch_Rec *)expr; r = validate_expr(port, b->test, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join(r, result); @@ -1716,7 +1534,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, vc_pos = vc->stackpos; vc_ncpos = vc->ncstackpos; r = validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, result_ignored, vc, tailpos, need_local_type, procs, expected_results, _st_ht); @@ -1759,12 +1577,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, int r; r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join_seq(result, r); r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join_seq(result, r); @@ -1773,44 +1591,11 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, goto top; } break; - case scheme_quote_syntax_type: - { - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)expr; - int c = qs->depth; - int i = qs->position; - int p = qs->midpoint; - int d = c + delta; - - no_typed(need_local_type, port); - - if ((c < 0) || (p < 0) || (d < 0) || (d >= depth) - || (stack[d] != VALID_TOPLEVELS) - || (p != num_toplevels) - || (i >= num_stxes)) - scheme_ill_formed_code(port); - - if (tl_use_map) { - if ((uintptr_t)tl_use_map & 0x1) { - if (p > 31) - scheme_ill_formed_code(port); - if (!((uintptr_t)tl_use_map & ((unsigned int)1 << (p + 1)))) - scheme_ill_formed_code(port); - } else { - if (p >= (*(int *)tl_use_map * 32)) - scheme_ill_formed_code(port); - if (!(((int *)tl_use_map)[1 + (p / 32)] & ((unsigned int)1 << (p & 31)))) - scheme_ill_formed_code(port); - } - } - - result = validate_join_const(result, expected_results); - } - break; case scheme_lambda_type: { no_typed(need_local_type, port); validate_lambda(port, expr, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, app_rator, proc_with_refs_ok, -1, procs, _st_ht); @@ -1823,7 +1608,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, int q, p, c, i, r; r = validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, lv->count, _st_ht); result = validate_join_seq(r, result); @@ -1920,7 +1705,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, for (i = 0; i < c; i++) { validate_lambda(port, l->procs[i], stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 1, i, procs, _st_ht); } @@ -1940,7 +1725,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, stack[delta] = VALID_UNINIT; r = validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, SCHEME_LET_ONE_TYPE(lo), procs, 1, _st_ht); @@ -1968,30 +1753,16 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, no_typed(need_local_type, port); result = validate_join_seq(result, define_values_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht)); break; - case scheme_define_syntaxes_type: - no_typed(need_local_type, port); - define_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - break; - case scheme_begin_for_syntax_type: - no_typed(need_local_type, port); - begin_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - break; case scheme_set_bang_type: no_typed(need_local_type, port); result = validate_join_seq(result, set_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht)); break; @@ -1999,7 +1770,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, no_typed(need_local_type, port); result = validate_join_seq(result, bangboxenv_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht, expected_results)); break; @@ -2007,21 +1778,14 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, no_typed(need_local_type, port); result = validate_join_seq(result, begin0_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht, expected_results)); break; - case scheme_require_form_type: - no_typed(need_local_type, port); - top_level_require_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - break; case scheme_varref_form_type: no_typed(need_local_type, port); ref_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs); result = validate_join_const(result, expected_results); @@ -2029,7 +1793,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, case scheme_apply_values_type: no_typed(need_local_type, port); apply_values_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht); result = validate_join(0, result); @@ -2042,14 +1806,14 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, no_typed(need_local_type, port); r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); result = validate_join_seq(r, result); r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); @@ -2067,23 +1831,15 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, case scheme_case_lambda_sequence_type: no_typed(need_local_type, port); case_lambda_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht); result = validate_join_const(result, expected_results); break; - case scheme_module_type: - no_typed(need_local_type, port); - module_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs); - result = validate_join(0, result); - break; case scheme_inline_variant_type: no_typed(need_local_type, port); inline_variant_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs, _st_ht); result = validate_join_const(result, expected_results); @@ -2119,7 +1875,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, seq = (Scheme_Case_Lambda *)expr; for (i = 0; i < seq->count; i++) { validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, + num_toplevels, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, 0, procs, 1, _st_ht); } @@ -2139,7 +1895,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, if (app_rator) if (validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, - tls, num_toplevels, num_stxes, num_lifts, tl_use_map)) + tls, num_toplevels, num_lifts, tl_use_map)) scheme_ill_formed_code(port); if (vc_merge) { diff --git a/racket/src/racket/src/vector.c b/racket/src/racket/src/vector.c index ef89019bd1..35e4a8ff66 100644 --- a/racket/src/racket/src/vector.c +++ b/racket/src/racket/src/vector.c @@ -31,20 +31,35 @@ READ_ONLY Scheme_Object *scheme_vector_proc; READ_ONLY Scheme_Object *scheme_vector_p_proc; READ_ONLY Scheme_Object *scheme_make_vector_proc; READ_ONLY Scheme_Object *scheme_vector_immutable_proc; +READ_ONLY Scheme_Object *scheme_vector_length_proc; +READ_ONLY Scheme_Object *scheme_vector_star_length_proc; READ_ONLY Scheme_Object *scheme_vector_ref_proc; +READ_ONLY Scheme_Object *scheme_vector_star_ref_proc; READ_ONLY Scheme_Object *scheme_vector_set_proc; +READ_ONLY Scheme_Object *scheme_vector_star_set_proc; +READ_ONLY Scheme_Object *scheme_vector_cas_proc; READ_ONLY Scheme_Object *scheme_list_to_vector_proc; READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_vector_star_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_vector_star_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_vector_star_set_proc; READ_ONLY Scheme_Object *scheme_unsafe_string_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_string_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_string_set_proc; READ_ONLY Scheme_Object *scheme_unsafe_byte_string_length_proc; +READ_ONLY Scheme_Object *scheme_unsafe_bytes_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_bytes_set_proc; READ_ONLY Scheme_Object *scheme_unsafe_struct_ref_proc; READ_ONLY Scheme_Object *scheme_unsafe_struct_star_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_struct_set_proc; +READ_ONLY Scheme_Object *scheme_unsafe_struct_star_set_proc; /* locals */ static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]); static Scheme_Object *vector (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_immutable (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_length (int argc, Scheme_Object *argv[]); +static Scheme_Object *vector_star_length (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_to_list (int argc, Scheme_Object *argv[]); static Scheme_Object *list_to_vector (int argc, Scheme_Object *argv[]); static Scheme_Object *vector_fill (int argc, Scheme_Object *argv[]); @@ -78,22 +93,24 @@ static Scheme_Object *unsafe_bytes_ref (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[]); void -scheme_init_vector (Scheme_Env *env) +scheme_init_vector (Scheme_Startup_Env *env) { Scheme_Object *p; REGISTER_SO(scheme_vector_p_proc); p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("vector?", p, env); + | SCHEME_PRIM_IS_OMITABLE + | SCHEME_PRIM_PRODUCES_BOOL); + scheme_addto_prim_instance("vector?", p, env); scheme_vector_p_proc = p; REGISTER_SO(scheme_make_vector_proc); p = scheme_make_immed_prim(scheme_checked_make_vector, "make-vector", 1, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("make-vector", p, env); + | SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("make-vector", p, env); scheme_make_vector_proc = p; REGISTER_SO(scheme_vector_proc); @@ -103,7 +120,7 @@ scheme_init_vector (Scheme_Env *env) | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant("vector", p, env); + scheme_addto_prim_instance("vector", p, env); REGISTER_SO(scheme_vector_immutable_proc); p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1); @@ -112,89 +129,120 @@ scheme_init_vector (Scheme_Env *env) | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED | SCHEME_PRIM_IS_OMITABLE_ALLOCATION); - scheme_add_global_constant("vector-immutable", p, env); + scheme_addto_prim_instance("vector-immutable", p, env); + + REGISTER_SO(scheme_vector_length_proc); p = scheme_make_folding_prim(vector_length, "vector-length", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("vector-length", p, env); + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector-length", p, env); + scheme_vector_length_proc = p; + + REGISTER_SO(scheme_vector_star_length_proc); + p = scheme_make_folding_prim(vector_star_length, "vector*-length", 1, 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_PRODUCES_FIXNUM + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector*-length", p, env); + scheme_vector_star_length_proc = p; REGISTER_SO(scheme_vector_ref_proc); p = scheme_make_noncm_prim(scheme_checked_vector_ref, "vector-ref", 2, 2); scheme_vector_ref_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED); - scheme_add_global_constant("vector-ref", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector-ref", p, env); + + REGISTER_SO(scheme_vector_star_ref_proc); + p = scheme_make_noncm_prim(scheme_checked_vector_star_ref, + "vector*-ref", + 2, 2); + scheme_vector_star_ref_proc = p; + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector*-ref", p, env); REGISTER_SO(scheme_vector_set_proc); p = scheme_make_noncm_prim(scheme_checked_vector_set, "vector-set!", 3, 3); scheme_vector_set_proc = p; - SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("vector-set!", p, env); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector-set!", p, env); + REGISTER_SO(scheme_vector_star_set_proc); + p = scheme_make_noncm_prim(scheme_checked_vector_star_set, + "vector*-set!", + 3, 3); + scheme_vector_star_set_proc = p; + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector*-set!", p, env); + + REGISTER_SO(scheme_vector_cas_proc); p = scheme_make_noncm_prim(scheme_checked_vector_cas, "vector-cas!", 4, 4); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("vector-cas!", p, env); + scheme_addto_prim_instance("vector-cas!", p, env); + scheme_vector_cas_proc = p; - scheme_add_global_constant("vector->list", - scheme_make_immed_prim(vector_to_list, - "vector->list", - 1, 1), - env); + p = scheme_make_immed_prim(vector_to_list, "vector->list", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED + | SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector->list", p, env); REGISTER_SO(scheme_list_to_vector_proc); - p = scheme_make_immed_prim(list_to_vector, - "list->vector", - 1, 1); + p = scheme_make_immed_prim(list_to_vector, "list->vector", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); scheme_list_to_vector_proc = p; - scheme_add_global_constant("list->vector", p, env); + scheme_addto_prim_instance("list->vector", p, env); - scheme_add_global_constant("vector-fill!", + scheme_addto_prim_instance("vector-fill!", scheme_make_immed_prim(vector_fill, "vector-fill!", 2, 2), env); - scheme_add_global_constant("vector-copy!", + scheme_addto_prim_instance("vector-copy!", scheme_make_immed_prim(vector_copy_bang, "vector-copy!", 3, 5), env); - scheme_add_global_constant("vector->immutable-vector", - scheme_make_immed_prim(vector_to_immutable, - "vector->immutable-vector", - 1, 1), - env); - scheme_add_global_constant("vector->values", - scheme_make_prim_w_arity2(vector_to_values, - "vector->values", - 1, 3, - 0, -1), - env); - scheme_add_global_constant("chaperone-vector", + p = scheme_make_immed_prim(vector_to_immutable, "vector->immutable-vector", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector->immutable-vector", p, env); + + p = scheme_make_prim_w_arity2(vector_to_values, "vector->values", + 1, 3, + 0, -1); + SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT); + scheme_addto_prim_instance("vector->values", p, env); + + scheme_addto_prim_instance("chaperone-vector", scheme_make_prim_w_arity(chaperone_vector, "chaperone-vector", 3, -1), env); - scheme_add_global_constant("chaperone-vector*", + scheme_addto_prim_instance("chaperone-vector*", scheme_make_prim_w_arity(chaperone_vector_star, "chaperone-vector*", 3, -1), env); - scheme_add_global_constant("impersonate-vector", + scheme_addto_prim_instance("impersonate-vector", scheme_make_prim_w_arity(impersonate_vector, "impersonate-vector", 3, -1), env); - scheme_add_global_constant("impersonate-vector*", + scheme_addto_prim_instance("impersonate-vector*", scheme_make_prim_w_arity(impersonate_vector_star, "impersonate-vector*", 3, -1), @@ -202,7 +250,7 @@ scheme_init_vector (Scheme_Env *env) } void -scheme_init_unsafe_vector (Scheme_Env *env) +scheme_init_unsafe_vector (Scheme_Startup_Env *env) { Scheme_Object *p; @@ -211,38 +259,44 @@ scheme_init_unsafe_vector (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-vector-length", p, env); + scheme_addto_prim_instance("unsafe-vector-length", p, env); scheme_unsafe_vector_length_proc = p; + REGISTER_SO(scheme_unsafe_vector_star_length_proc); p = scheme_make_immed_prim(unsafe_vector_star_len, "unsafe-vector*-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-vector*-length", p, env); + scheme_addto_prim_instance("unsafe-vector*-length", p, env); + scheme_unsafe_vector_star_length_proc = p; p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-vector-ref", p, env); + scheme_addto_prim_instance("unsafe-vector-ref", p, env); + REGISTER_SO(scheme_unsafe_vector_star_ref_proc); p = scheme_make_immed_prim(unsafe_vector_star_ref, "unsafe-vector*-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-vector*-ref", p, env); + scheme_addto_prim_instance("unsafe-vector*-ref", p, env); + scheme_unsafe_vector_star_ref_proc = p; p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-vector-set!", p, env); + scheme_addto_prim_instance("unsafe-vector-set!", p, env); + REGISTER_SO(scheme_unsafe_vector_star_set_proc); p = scheme_make_immed_prim(unsafe_vector_star_set, "unsafe-vector*-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-vector*-set!", p, env); + scheme_addto_prim_instance("unsafe-vector*-set!", p, env); + scheme_unsafe_vector_star_set_proc = p; p = scheme_make_immed_prim(unsafe_vector_star_cas, "unsafe-vector*-cas!", 4, 4); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-vector*-cas!", p, env); + scheme_addto_prim_instance("unsafe-vector*-cas!", p, env); REGISTER_SO(scheme_unsafe_struct_ref_proc); p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2); @@ -250,7 +304,7 @@ scheme_init_unsafe_vector (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-struct-ref", p, env); + scheme_addto_prim_instance("unsafe-struct-ref", p, env); REGISTER_SO(scheme_unsafe_struct_ref_proc); p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2); @@ -258,64 +312,76 @@ scheme_init_unsafe_vector (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-struct*-ref", p, env); + scheme_addto_prim_instance("unsafe-struct*-ref", p, env); + REGISTER_SO(scheme_unsafe_struct_set_proc); p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3); + scheme_unsafe_struct_set_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-struct-set!", p, env); + scheme_addto_prim_instance("unsafe-struct-set!", p, env); + REGISTER_SO(scheme_unsafe_struct_star_set_proc); p = scheme_make_immed_prim(unsafe_struct_star_set, "unsafe-struct*-set!", 3, 3); + scheme_unsafe_struct_star_set_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-struct*-set!", p, env); + scheme_addto_prim_instance("unsafe-struct*-set!", p, env); p = scheme_make_immed_prim(unsafe_struct_star_cas, "unsafe-struct*-cas!", 4, 4); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-struct*-cas!", p, env); + scheme_addto_prim_instance("unsafe-struct*-cas!", p, env); REGISTER_SO(scheme_unsafe_string_length_proc); p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-string-length", p, env); + scheme_addto_prim_instance("unsafe-string-length", p, env); scheme_unsafe_string_length_proc = p; + REGISTER_SO(scheme_unsafe_string_ref_proc); p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); - scheme_add_global_constant("unsafe-string-ref", p, env); + scheme_addto_prim_instance("unsafe-string-ref", p, env); + scheme_unsafe_string_ref_proc = p; + REGISTER_SO(scheme_unsafe_string_set_proc); p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-string-set!", p, env); + scheme_addto_prim_instance("unsafe-string-set!", p, env); + scheme_unsafe_string_set_proc = p; REGISTER_SO(scheme_unsafe_byte_string_length_proc); p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-bytes-length", p, env); + scheme_addto_prim_instance("unsafe-bytes-length", p, env); scheme_unsafe_byte_string_length_proc = p; + REGISTER_SO(scheme_unsafe_bytes_ref_proc); p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_add_global_constant("unsafe-bytes-ref", p, env); + scheme_addto_prim_instance("unsafe-bytes-ref", p, env); + scheme_unsafe_bytes_ref_proc = p; + REGISTER_SO(scheme_unsafe_bytes_set_proc); p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED); - scheme_add_global_constant("unsafe-bytes-set!", p, env); + scheme_addto_prim_instance("unsafe-bytes-set!", p, env); + scheme_unsafe_bytes_set_proc = p; - scheme_add_global_constant("unsafe-impersonate-vector", + scheme_addto_prim_instance("unsafe-impersonate-vector", scheme_make_prim_w_arity(unsafe_impersonate_vector, "unsafe-impersonate-vector", 2, -1), env); - scheme_add_global_constant("unsafe-chaperone-vector", + scheme_addto_prim_instance("unsafe-chaperone-vector", scheme_make_prim_w_arity(unsafe_chaperone_vector, "unsafe-chaperone-vector", 2, -1), @@ -439,6 +505,24 @@ Scheme_Object *scheme_vector_length(Scheme_Object *v) return vector_length(1, a); } +static Scheme_Object * +vector_star_length (int argc, Scheme_Object *argv[]) +{ + Scheme_Object *vec = argv[0]; + + if (!SCHEME_VECTORP(vec)) + scheme_wrong_contract("vector*-length", "(and/c vector? (not/c impersonator?))", 0, argc, argv); + + return scheme_make_integer(SCHEME_VEC_SIZE(vec)); +} + +Scheme_Object *scheme_vector_star_length(Scheme_Object *v) +{ + Scheme_Object *a[1]; + a[0] = v; + return vector_star_length(1, a); +} + void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *which, Scheme_Object *vec, intptr_t bottom, intptr_t len) { @@ -622,6 +706,26 @@ void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v) } } +Scheme_Object * +scheme_checked_vector_star_ref (int argc, Scheme_Object *argv[]) +{ + intptr_t i, len; + Scheme_Object *vec; + + vec = argv[0]; + if (!SCHEME_VECTORP(vec)) + scheme_wrong_contract("vector*-ref", "(and/c vector? (not impersonator?))", 0, argc, argv); + + len = SCHEME_VEC_SIZE(vec); + + i = scheme_extract_index("vector*-ref", 1, argc, argv, len, 0); + + if (i >= len) + return bad_index("vector*-ref", "", argv[1], argv[0], 0); + + return (SCHEME_VEC_ELS(vec))[i]; +} + Scheme_Object * scheme_checked_vector_set(int argc, Scheme_Object *argv[]) { @@ -649,6 +753,30 @@ scheme_checked_vector_set(int argc, Scheme_Object *argv[]) return scheme_void; } +Scheme_Object * +scheme_checked_vector_star_set(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *vec = argv[0]; + intptr_t i, len; + + if (SCHEME_CHAPERONEP(vec)) + vec = SCHEME_CHAPERONE_VAL(vec); + + if (!SCHEME_MUTABLE_VECTORP(vec)) + scheme_wrong_contract("vector*-set!", "(and/c vector? (not/c immutable?) (not/c impersonator?))", 0, argc, argv); + + len = SCHEME_VEC_SIZE(vec); + + i = scheme_extract_index("vector*-set!", 1, argc, argv, len, 0); + + if (i >= len) + return bad_index("vector*-set!", "", argv[1], argv[0], 0); + + SCHEME_VEC_ELS(vec)[i] = argv[2]; + + return scheme_void; +} + Scheme_Object * scheme_checked_vector_cas(int argc, Scheme_Object *argv[]) { diff --git a/racket/src/regexp/Makefile b/racket/src/regexp/Makefile new file mode 100644 index 0000000000..61a5c7f435 --- /dev/null +++ b/racket/src/regexp/Makefile @@ -0,0 +1,38 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion, and declaring "collect.rkt" pure works +# around a limitation of the flattener: +IGNORE = ++knot read - ++pure ../../collects/racket/private/collect.rkt + +regexp-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) regexp-src-generate + +GENERATE_ARGS = -t main.rkt \ + --check-depends $(BUILDDIR)compiled/regexp-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/regexp-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/regexp.rktl $(BUILDDIR)compiled/regexp.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/regexp.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +regexp-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(GENERATE_ARGS) + +demo: + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +# Writes the extracted, compiled, decompiled expander to compiled/regexp.rkt +decompile: + $(RACO) make ../expander/bootstrap-run.rkt + $(RACKET) $(RKT_ARGS) ../expander/bootstrap-run.rkt -t main.rkt -c compiled/cache-src $(IGNORE) -s -x -D -o compiled/regexp.rkt + +.PHONY: regexp-src regexp-src-generate demo decompile diff --git a/racket/src/regexp/README.txt b/racket/src/regexp/README.txt new file mode 100644 index 0000000000..728571d7e8 --- /dev/null +++ b/racket/src/regexp/README.txt @@ -0,0 +1,3 @@ +This regexp implementation can be run in a host Racket with `make +demo`, but it's meant to be compiled for use in Racket on Chez Scheme; +see "../cs/README.txt". diff --git a/racket/src/regexp/analyze/anchor.rkt b/racket/src/regexp/analyze/anchor.rkt new file mode 100644 index 0000000000..4f561a7c96 --- /dev/null +++ b/racket/src/regexp/analyze/anchor.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require "../parse/ast.rkt") + +(provide anchored?) + +;; Determine whether a regexp definitely can only match at the start +;; of input. (A converative `#f` is ok.) + +(define (anchored? rx) + (cond + [(eq? rx rx:start) #t] + [(rx:sequence? rx) + (let loop ([rxs (rx:sequence-rxs rx)]) + (cond + [(null? rxs) #f] + [(rx:lookahead? (car rxs)) (loop (cdr rxs))] + [(rx:lookbehind? (car rxs)) (loop (cdr rxs))] + [else (anchored? (car rxs))]))] + [(rx:alts? rx) + (and (anchored? (rx:alts-rx1 rx)) + (anchored? (rx:alts-rx2 rx)))] + [(rx:conditional? rx) + (and (anchored? (rx:conditional-rx1 rx)) + (anchored? (rx:conditional-rx2 rx)))] + [(rx:group? rx) + (anchored? (rx:group-rx rx))] + [(rx:cut? rx) + (anchored? (rx:cut-rx rx))] + [else #f])) diff --git a/racket/src/regexp/analyze/convert.rkt b/racket/src/regexp/analyze/convert.rkt new file mode 100644 index 0000000000..dc6d72a868 --- /dev/null +++ b/racket/src/regexp/analyze/convert.rkt @@ -0,0 +1,179 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt") + +;; Convert a string regexp to a byte-string regexp + +(provide convert) + +(define (convert rx) + (cond + [(eq? rx rx:any) + (rx:unicode-categories null #f)] + [(exact-integer? rx) + (cond + [(< rx 128) rx] + [else (string->bytes/utf-8 (string (integer->char rx)))])] + [(rx:range? rx) + (define range (rx:range-range rx)) + (if (range-within? range 0 127) + rx + (range->alts range))] + [(bytes? rx) (convert (bytes->string/latin-1 rx))] + [(string? rx) (string->bytes/utf-8 rx)] + [(rx:alts? rx) + (rx-alts (convert (rx:alts-rx1 rx)) + (convert (rx:alts-rx2 rx)) + 255)] + [(rx:sequence? rx) + (struct-copy rx:sequence rx + [rxs (for/list ([rx (in-list (rx:sequence-rxs rx))]) + (convert rx))])] + [(rx:group? rx) + (struct-copy rx:group rx + [rx (convert (rx:group-rx rx))])] + [(rx:repeat? rx) + (struct-copy rx:repeat rx + [rx (convert (rx:repeat-rx rx))])] + [(rx:maybe? rx) + (struct-copy rx:maybe rx + [rx (convert (rx:maybe-rx rx))])] + [(rx:conditional? rx) + (struct-copy rx:conditional rx + [tst (convert (rx:conditional-tst rx))] + [rx1 (convert (rx:conditional-rx1 rx))] + [rx2 (convert (rx:conditional-rx2 rx))])] + [(rx:lookahead? rx) + (struct-copy rx:lookahead rx + [rx (convert (rx:lookahead-rx rx))])] + [(rx:lookbehind? rx) + (struct-copy rx:lookbehind rx + [rx (convert (rx:lookbehind-rx rx))])] + [(rx:cut? rx) + (struct-copy rx:cut rx + [rx (convert (rx:cut-rx rx))])] + [else rx])) + +(define (range->alts args) + (define l (range->list args)) + (let loop ([l l]) + (cond + [(null? l) rx:never] + [else + (let ([start (caar l)] + [end (cdar l)]) + ;; If this range spans different-sized encodings, split it up + (define seg-end + (cond + [(start . <= . 127) 127] + [(start . <= . #x7FF) #x7FF] + [(start . <= . #xFFFF) #xFFFF] + [(start . <= . #x1FFFFF) #x1FFFFF])) + (cond + [(end . > . seg-end) + (loop (cons (cons start seg-end) + (cons (cons (add1 seg-end) end) + (cdr l))))] + [(end . <= . 127) + (rx-alts (rx-range (range-add-span empty-range start end) 255) + (loop (cdr l)) + 255)] + [else + (rx-alts (bytes-range (string->bytes/utf-8 (string (integer->char start))) + (string->bytes/utf-8 (string (integer->char end)))) + (loop (cdr l)) + 255)]))]))) + +(define (bytes-range start-str end-str) + ;; The `start-str` argument and `end-str` arguments must be the same + ;; length. + (cond + [(equal? start-str end-str) + start-str] + [(= 1 (bytes-length start-str)) + (rx-range (range-add-span empty-range (bytes-ref start-str 0) (bytes-ref end-str 0)) + 255)] + [else + ;; We a range that's has structly more than one value. + ;; + ;; At this point, the situation is much like creating a regexp to + ;; match decimal digits. If we wanted to match the range 28 to 75 + ;; (inclusive), we'd need three parts: + ;; + ;; 2[8-9]|[3-6][0-9]|7[0-5] + ;; + ;; It gets more complex with three digits, say + ;; 128 to 715: + ;; + ;; 12[8-9]|1[3-6][0-9]|[2-6][0-9][0-9]|7[0-0][0-9]|71[0-5] + ;; + ;; but you get the idea. Note that rx:any takes the place of + ;; [0-9]. + (define common (let loop ([i 0]) + (cond + [(= (bytes-ref start-str i) (bytes-ref end-str i)) + (loop (add1 i))] + [else i]))) + + ;; Assert: common must be less than the full string length. + ;; Let `common-str` be the common prefix. + (define common-str (if (zero? common) + #"" + (subbytes start-str 0 common))) + (define n (bytes-ref start-str common)) + (define m (bytes-ref end-str common)) + + ;; Now we have something like nxxxx to mxxxx where n < m. + ;; Find p such that p >= n and p0000 >= nxxxx, and + ;; find q such that q0000 <= mxxxx. + + ;; If the xxxxs in nxxxx are 0, then p is n, + ;; otherwise it's n + 1. + (define p (if (zero-tail? start-str (add1 common)) + n + (add1 n))) + + ;; If the xxxxs in mxxxx are 0, then q is m, + ;; otherwise it's m - 1. + (define q (if (zero-tail? end-str (add1 common)) + m + (sub1 m))) + + (define tail-len (sub1 (- (bytes-length start-str) common))) + + ;; Fill out [nxxxx, nFFFF] + (define n-to-p + (rx-sequence (list n + (bytes-range (subbytes start-str (add1 common)) + (vector-ref FFFF-tails tail-len))))) + + ;; Fill out [m0000, mxxxx] + (define m-and-up + (rx-sequence (list m + (bytes-range (vector-ref 0000-tails tail-len) + (subbytes end-str (add1 common)))))) + + ;; Fill out [p0000,qFFFF] + (define p-through-q + (if (= (add1 p) q) + rx:never + (rx-sequence (cons + (rx-range (range-add-span empty-range p q) 255) + (for/list ([i (in-range tail-len)]) rx:any))))) + + ;; Combine the common prefix with the three filled-out ranges: + (rx-sequence (list (if (= 1 (bytes-length common-str)) + (bytes-ref common-str 0) + common-str) + (rx-alts n-to-p + (rx-alts p-through-q + m-and-up + 255) + 255)))])) + +(define FFFF-tails '#(#"" #"\xFF" #"\xFF\xFF" #"\xFF\xFF\xFF" #"\xFF\xFF\xFF\xFF")) +(define 0000-tails '#(#"" #"\x00" #"\x00\x00" #"\x00\x00\x00" #"\x00\x00\x00\x00")) + +(define (zero-tail? bstr i) + (for/and ([c (in-bytes bstr i)]) + (= c 0))) diff --git a/racket/src/regexp/analyze/must-string.rkt b/racket/src/regexp/analyze/must-string.rkt new file mode 100644 index 0000000000..4d8a010424 --- /dev/null +++ b/racket/src/regexp/analyze/must-string.rkt @@ -0,0 +1,120 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt") + +(provide get-must-string) + +;; If there's something expensive in the regexp, look for a string or +;; sequence of ranges that must be in the input, which is useful as a +;; pre-check for matching. A sequence of ranges is useful for +;; detecting a case-insensitive string match. + +(define (get-must-string rx) + (and (something-expensive? rx) + (choose (must-string rx) + (must-range rx)))) + +;; A short byte string is more likely effective +;; than a long range sequence: +(define (choose bstr seq) + (cond + [(not seq) bstr] + [(not bstr) (compile-range-sequence seq)] + [((bytes-length bstr) . >= . (quotient (length seq) 2)) bstr] + [else (compile-range-sequence seq)])) + +(define (something-expensive? rx) + (cond + [(or (rx:alts? rx) (rx:repeat? rx)) #t] + [(rx:maybe? rx) + (something-expensive? (rx:maybe-rx rx))] + [(rx:sequence? rx) + (for/or ([rx (in-list (rx:sequence-rxs rx))]) + (something-expensive? rx))] + [(rx:conditional? rx) + (or (something-expensive? (rx:conditional-rx1 rx)) + (something-expensive? (rx:conditional-rx2 rx)))] + [(rx:group? rx) + (something-expensive? (rx:group-rx rx))] + [(rx:cut? rx) + (something-expensive? (rx:cut-rx rx))] + [(rx:lookahead? rx) + (something-expensive? (rx:lookahead-rx rx))] + [(rx:lookbehind? rx) + (something-expensive? (rx:lookbehind-rx rx))] + [else #f])) + +(define (must-string rx) + (cond + [(bytes? rx) rx] + [(integer? rx) (bytes rx)] + [(rx:sequence? rx) + (for/fold ([bstr #f]) ([rx (in-list (rx:sequence-rxs rx))]) + (define bstr1 (must-string rx)) + (cond + [(not bstr) bstr1] + [(not bstr1) bstr] + [((bytes-length bstr) . > . (bytes-length bstr1)) + ;; Prefer longer byte string: + bstr] + [else bstr1]))] + [(rx:repeat? rx) + (and (positive? (rx:repeat-min rx)) + (must-string (rx:repeat-rx rx)))] + [(rx:group? rx) + (must-string (rx:group-rx rx))] + [(rx:cut? rx) + (must-string (rx:cut-rx rx))] + [(rx:lookahead? rx) + (and (rx:lookahead-match? rx) + (must-string (rx:lookahead-rx rx)))] + [(rx:lookbehind? rx) + (and (rx:lookbehind-match? rx) + (must-string (rx:lookbehind-rx rx)))] + [else #f])) + +(define (must-range rx) + (cond + [(bytes? rx) (bytes->list rx)] + [(integer? rx) (list rx)] + [(rx:range? rx) (list (rx:range-range rx))] + [(rx:sequence? rx) + ;; combine consecutive strings and ranges + (let loop ([seq null] [l (rx:sequence-rxs rx)]) + (cond + [(null? l) (and (pair? seq) (reverse seq))] + [(bytes? (car l)) + (loop (append (reverse (bytes->list (car l))) seq) + (cdr l))] + [(rx:range? (car l)) + (loop (cons (rx:range-range (car l)) + seq) + (cdr l))] + [(null? seq) (loop null (cdr l))] + [else + (define rest-seq (loop null (cdr l))) + (cond + [(and rest-seq + ((length rest-seq) . > . (length seq))) + rest-seq] + [else (reverse seq)])]))] + [(rx:repeat? rx) + (and (positive? (rx:repeat-min rx)) + (must-range (rx:repeat-rx rx)))] + [(rx:group? rx) + (must-range (rx:group-rx rx))] + [(rx:cut? rx) + (must-range (rx:cut-rx rx))] + [(rx:lookahead? rx) + (and (rx:lookahead-match? rx) + (must-range (rx:lookahead-rx rx)))] + [(rx:lookbehind? rx) + (and (rx:lookbehind-match? rx) + (must-range (rx:lookbehind-rx rx)))] + [else #f])) + +(define (compile-range-sequence seq) + (for/list ([r (in-list seq)]) + (if (exact-integer? r) + (compile-range (range-add empty-range r)) + (compile-range r)))) diff --git a/racket/src/regexp/analyze/start-range.rkt b/racket/src/regexp/analyze/start-range.rkt new file mode 100644 index 0000000000..a15d22ea5d --- /dev/null +++ b/racket/src/regexp/analyze/start-range.rkt @@ -0,0 +1,59 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt") + +(provide get-start-range) + +;; Returns a compiled range for bytes that must appear at the start, +;; or #f if no such set is known +(define (get-start-range rx) + (define r (start-range rx)) + (and r (compile-range r))) + +(define (start-range rx) + (cond + [(integer? rx) (range-add empty-range rx)] + [(bytes? rx) (range-add empty-range (bytes-ref rx 0))] + [(rx:sequence? rx) + (let loop ([l (rx:sequence-rxs rx)]) + (cond + [(null? l) #f] + [else + (define rx (car l)) + (cond + [(zero-sized? rx) + ;; Zero-sized element, so look at rest + (loop (cdr l))] + [else + (start-range rx)])]))] + [(rx:alts? rx) + (union (start-range (rx:alts-rx1 rx)) + (start-range (rx:alts-rx2 rx)))] + [(rx:conditional? rx) + (union (start-range (rx:conditional-rx1 rx)) + (start-range (rx:conditional-rx2 rx)))] + [(rx:group? rx) + (start-range (rx:group-rx rx))] + [(rx:cut? rx) + (start-range (rx:cut-rx rx))] + [(rx:repeat? rx) + (and (positive? (rx:repeat-min rx)) + (start-range (rx:repeat-rx rx)))] + [(rx:range? rx) (rx:range-range rx)] + [else #f])) + +(define (zero-sized? rx) + (or (eq? rx rx:empty) + (eq? rx rx:start) + (eq? rx rx:line-start) + (eq? rx rx:word-boundary) + (eq? rx rx:not-word-boundary) + (rx:lookahead? rx) + (rx:lookbehind? rx) + (and (rx:group? rx) + (zero-sized? (rx:group-rx rx))) + (and (rx:cut? rx) + (zero-sized? (rx:cut-rx rx))))) + +(define (union a b) + (and a b (range-union a b))) diff --git a/racket/src/regexp/analyze/validate.rkt b/racket/src/regexp/analyze/validate.rkt new file mode 100644 index 0000000000..4e8973bb21 --- /dev/null +++ b/racket/src/regexp/analyze/validate.rkt @@ -0,0 +1,118 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt" + "../common/error.rkt") + +(provide validate) + +;; Returns max-lookbehind or reports an error +(define (validate rx num-groups) + (define group-sizes #hasheqv()) + (define depends-sizes #hasheqv()) + (define must-sizes #hasheqv()) + (define (might-be-empty-error) + (regexp-error "`*`, `+`, or `{...}` operand could be empty")) + (define-values (min-len max-len max-lookbehind) + (let validate ([rx rx]) + (cond + [(eq? rx rx:never) + (values 1 1 0)] + [(or (eq? rx rx:any) + (exact-integer? rx) + (rx:range? rx)) + (values 1 1 0)] + [(bytes? rx) + (define len (bytes-length rx)) + (values len len 0)] + [(or (eq? rx rx:empty) + (eq? rx rx:end) + (eq? rx rx:line-end)) + (values 0 0 0)] + [(or (eq? rx rx:start) + (eq? rx rx:line-start)) + (values 0 0 1)] + [(or (eq? rx rx:word-boundary) + (eq? rx rx:not-word-boundary)) + (values 0 0 1)] + [(rx:alts? rx) + (define-values (min1 max1 lb1) (validate (rx:alts-rx1 rx))) + (define-values (min2 max2 lb2) (validate (rx:alts-rx2 rx))) + (values (min min1 min2) (max max1 max2) (max lb1 lb2))] + [(rx:sequence? rx) + (for/fold ([min-len 0] [max-len 0] [max-lb 0]) ([rx (in-list (rx:sequence-rxs rx))]) + (define-values (min1 max1 lb1) (validate rx)) + (values (+ min-len min1) (+ max-len max1) (max max-lb lb1)))] + [(rx:group? rx) + (define-values (min1 max1 lb1) (validate (rx:group-rx rx))) + (set! group-sizes (hash-set group-sizes (rx:group-number rx) min1)) + (values min1 max1 lb1)] + [(rx:repeat? rx) + (define old-depends-sizes depends-sizes) + (set! depends-sizes #hasheqv()) + (define-values (min1 max1 lb1) (validate (rx:repeat-rx rx))) + (when (zero? min1) + (might-be-empty-error)) + (set! must-sizes (merge-depends-sizes must-sizes depends-sizes)) + (set! depends-sizes (merge-depends-sizes old-depends-sizes depends-sizes)) + (values (* min1 (rx:repeat-min rx)) + (* max1 (rx:repeat-max rx)) + lb1)] + [(rx:maybe? rx) + (define-values (min1 max1 lb1) (validate (rx:maybe-rx rx))) + (values 0 max1 lb1)] + [(rx:conditional? rx) + (define-values (min0 max0 lb0) (validate (rx:conditional-tst rx))) + (define-values (min1 max1 lb1) (validate (rx:conditional-rx1 rx))) + (define-values (min2 max2 lb2) (validate (rx:conditional-rx2 rx))) + (values (min min1 min2) (max max1 max2) (max lb0 lb1 lb2))] + [(rx:lookahead? rx) + (define-values (min1 max1 lb1) (validate (rx:lookahead-rx rx))) + (values 0 0 lb1)] + [(rx:lookbehind? rx) + (define-values (min1 max1 lb1) (validate (rx:lookbehind-rx rx))) + (when (= +inf.0 max1) + (regexp-error "lookbehind pattern does not match a bounded length")) + (set-rx:lookbehind-lb-min! rx min1) + (set-rx:lookbehind-lb-max! rx max1) + (values 0 0 (max max1 lb1))] + [(rx:cut? rx) + (validate (rx:cut-rx rx))] + [(rx:reference? rx) + (define n (rx:reference-n rx)) + (unless (n . <= . num-groups) + (regexp-error "backreference number is larger than the highest-numbered cluster")) + (define min-size (hash-ref group-sizes n #f)) + (cond + [min-size + ;; known minimum: + (values min-size +inf.0 0)] + [else + ;; assume at least one, but check: + (set! depends-sizes (hash-set depends-sizes (sub1 n) #t)) + (values 1 +inf.0 0)])] + [(rx:unicode-categories? rx) + (values 1 4 0)] + [else (error 'validate "internal error: ~s" rx)]))) + (for ([n (in-hash-keys must-sizes)]) + (unless (positive? (hash-ref group-sizes n 0)) + (might-be-empty-error))) + max-lookbehind) + +(define (merge-depends-sizes ht1 ht2) + (cond + [(zero? (hash-count ht1)) ht2] + [((hash-count ht2) . < . (hash-count ht1)) + (merge-depends-sizes ht2 ht1)] + [else + (for/fold ([ht2 ht2]) ([k (in-hash-keys ht1)]) + (hash-set ht2 k #t))])) + +(define (range-utf-8-encoding-lengths range) + (for/fold ([min1 4] [max1 0]) ([seg (in-list '((0 127 1) + (128 #x7FF 2) + (#x800 #xFFFF 3) + (#x10000 #x10FFFF 4)))]) + (if (range-overlaps? range (car seg) (cadr seg)) + (values (min min1 (caddr seg)) + (max max1 (caddr seg))) + (values min1 max1)))) diff --git a/racket/src/regexp/common/error.rkt b/racket/src/regexp/common/error.rkt new file mode 100644 index 0000000000..fef7a3ae1f --- /dev/null +++ b/racket/src/regexp/common/error.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(provide regexp-error + regexp-error-tag) + +(define regexp-error-tag (make-continuation-prompt-tag 'regexp-error)) + +(define (regexp-error fmt . args) + (abort-current-continuation regexp-error-tag (apply format fmt args))) diff --git a/racket/src/regexp/common/range.rkt b/racket/src/regexp/common/range.rkt new file mode 100644 index 0000000000..09e8e680ae --- /dev/null +++ b/racket/src/regexp/common/range.rkt @@ -0,0 +1,123 @@ +#lang racket/base + +;; Represent a range as a list of `(cons start end)` +;; pairs, where `start` and `end` are inclusive. + +(provide empty-range + range-invert + range-add + range-union + range-add-span + range-in? + range-singleton + range-includes? + range-overlaps? + range-within? + range->list + + compile-range + rng-in?) + +(define empty-range null) + +(define (range-invert r limit-c) + (let loop ([r r] [start 0]) + (cond + [(null? r) + (cond + [(start . > . limit-c) null] + [else (list (cons start limit-c))])] + [(= start (caar r)) + (loop (cdr r) (add1 (cdar r)))] + [else + (cons (cons start (sub1 (caar r))) + (loop (cdr r) (add1 (cdar r))))]))) + +(define (range-in? r v) + (for/or ([p (in-list r)]) + (and (v . >= . (car p)) + (v . <= . (cdr p))))) + +(define (range-add r v) + (cond + [(not v) r] + [(range-in? r v) r] + [else (range-union r (list (cons v v)))])) + +(define (range-union r1 r2) + (cond + [(null? r1) r2] + [(null? r2) r1] + [((caar r1) . <= . (caar r2)) + (cond + [((add1 (cdar r1)) . >= . (caar r2)) + ;; First elements overlap or are contiguous + (cond + [((cdar r1) . <= . (cdar r2)) + ;; First of second extends further + (range-union (cons (cons (caar r1) (cdar r2)) + (cdr r2)) + (cdr r1))] + [else + ;; First of first subsumes first of second + (range-union r1 (cdr r2))])] + [else + ;; First of first is wholly before first of second + (cons (car r1) + (range-union (cdr r1) r2))])] + [else + ;; First of second starts earlier, so change places + (range-union r2 r1)])) + +(define (range-add-span range from-c to-c) + (range-union range (list (cons from-c to-c)))) + +(define (range-singleton range) + (and (pair? range) + (null? (cdr range)) + (= (caar range) (cdar range)) + (caar range))) + +(define (range-includes? range low hi) + (cond + [(null? range) null] + [(low . > . (cdar range)) (range-includes? (cdr range) low hi)] + [else + (and (low . >= . (caar range)) + (hi . <= . (cdar range)))])) + +(define (range-within? range low hi) + (cond + [(null? range) #t] + [((caar range) . < . low) #f] + [((cdar range) . > . hi) #f] + [else (range-within? (cdr range) low hi)])) + +(define (range-overlaps? range low hi) + (cond + [(null? range) null] + [(low . > . (cdar range)) (range-overlaps? (cdr range) low hi)] + [else + (or (and (low . >= . (caar range)) + (low . <= . (cdar range))) + (and (hi . >= . (caar range)) + (hi . <= . (cdar range))))])) + +(define (range->list range) + range) + +;; ---------------------------------------- + +(define rngs (make-weak-hash)) + +(define (compile-range range) + (or (hash-ref rngs range #f) + (let ([rng (make-bytes 256 0)]) + (for* ([p (in-list range)] + [i (in-range (car p) (add1 (cdr p)))]) + (bytes-set! rng i 1)) + (hash-set! rngs range rng) + rng))) + +(define (rng-in? rng v) + (eq? 1 (bytes-ref rng v))) diff --git a/racket/src/regexp/demo.rkt b/racket/src/regexp/demo.rkt new file mode 100644 index 0000000000..9b9e23ab91 --- /dev/null +++ b/racket/src/regexp/demo.rkt @@ -0,0 +1,178 @@ +#lang racket/base +(require (prefix-in rx: "main.rkt")) + +(define-syntax-rule (test expr v) + (let ([b expr]) + (unless (equal? b v) + (error 'test "failed: ~s => ~s" 'expr b)))) + +(test (rx:regexp-match "" (open-input-string "123") 4) + #f) +(test (rx:regexp-match-peek "" (open-input-string "123") 4) + #f) + +(for* ([succeed? '(#f #t)] + [char '(#\x #\u3BB)]) + (for ([N '(1 100 1000 1023 1024 10000)]) + (for ([M (list 0 (quotient N 2))]) + (define o (open-output-bytes)) + (log-error "N = ~a, M = ~a" N M) + (void (rx:regexp-match-positions "y" + (string-append + (make-string N char) + (if succeed? "y" "")) + M + (+ N (if succeed? 1 0)) + o)) + (test (string-length (get-output-string o)) (- N M))))) + +;; Test bounded byte consumption on failure: +(let ([is (open-input-string "barfoo")]) + (test (list (rx:regexp-match "^foo" is 0 3) (read-char is)) '(#f #\f))) +(let ([is (open-input-string "barfoo")]) + (test (list (rx:regexp-match "foo" is 0 3) (read-char is)) '(#f #\f))) + +;; ---------------------------------------- + +(define (check rx in N [M (max 1 (quotient N 10))]) + (define c-start (current-inexact-milliseconds)) + (define orig-rx + (if (bytes? rx) + (for/fold ([r #f]) ([i (in-range M)]) + (byte-pregexp rx)) + (for/fold ([r #f]) ([i (in-range M)]) + (pregexp rx)))) + (define c-after-orig (current-inexact-milliseconds)) + (define new-rx + (if (bytes? rx) + (for/fold ([r #f]) ([i (in-range M)]) + (rx:byte-pregexp rx)) + (for/fold ([r #f]) ([i (in-range M)]) + (rx:pregexp rx)))) + (define c-after-new (current-inexact-milliseconds)) + + (define orig-v (regexp-match orig-rx in)) + (define new-v (rx:regexp-match new-rx in)) + (unless (equal? orig-v new-v) + (error 'check + "failed\n pattern: ~s\n input: ~s\n expected: ~s\n got: ~s" + rx in orig-v new-v)) + + (define start (current-inexact-milliseconds)) + (for/fold ([r #f]) ([i (in-range N)]) + (regexp-match? orig-rx in)) + (define after-orig (current-inexact-milliseconds)) + (for/fold ([r #f]) ([i (in-range N)]) + (rx:regexp-match? new-rx in)) + (define after-new (current-inexact-milliseconds)) + + (define orig-c-msec (- c-after-orig c-start)) + (define new-c-msec (- c-after-new c-after-orig)) + (define orig-msec (- after-orig start)) + (define new-msec (- after-new after-orig)) + + (unless (= N 1) + (parameterize ([error-print-width 64]) + (printf "regex: ~.s\non: ~.s\n" rx in)) + + (define (~n n) + (car (regexp-match #px"^[0-9]*[.]?[0-9]{0,2}" (format "~a" n)))) + + (printf " compile: ~a (~a vs. ~a) / ~a iterations\n" + (~n (/ new-c-msec orig-c-msec)) + (~n orig-c-msec) + (~n new-c-msec) + M) + (printf " interp: ~a (~a vs. ~a) / ~a iterations\n" + (~n (/ new-msec orig-msec)) + (~n orig-msec) + (~n new-msec) + N))) + +;; ---------------------------------------- + +(check #"(?m:^aa$a.)" + #"abaac\nac\naa\nacacaaacd" + 1) + +(check #"\\sa." + #"cat apple" + 1) + +(check "(?>a*)a" + "aaa" + 1) + +(check "(?:a|b)y(\\1)" + "ayb" + 1) + +(check "!.!" + #"!\x80!" + 1) + +(check #"\\P{Ll}" + #"aB" + 1) + +(check #".*" + #"abaacacaaacacaaacd" + 100000) + +(check #"ab(?:a*c)*d" + #"abaacacaaacacaaacd" + 100000) + +(check #"ab(?:a*?c)*d" + #"abaacacaaacacaaacd" + 100000) + +(check #"ab(?:[ab]*c)*d" + #"abaacacaaacacaaacd" + 100000) + +(define ipv6-hex "[0-9a-fA-F:]*:[0-9a-fA-F:]*") + +(define url-s + (string-append + "^" + "(?:" ; / scheme-colon-opt + "([^:/?#]*)" ; | #1 = scheme-opt + ":)?" ; \ + "(?://" ; / slash-slash-authority-opt + "(?:" ; | / user-at-opt + "([^/?#@]*)" ; | | #2 = user-opt + "@)?" ; | \ + "(?:" ; + "(?:\\[" ; | / #3 = ipv6-host-opt + "(" ipv6-hex ")" ; | | hex-addresses + "\\])|" ; | \ + "([^/?#:]*)" ; | #4 = host-opt + ")?" ; + "(?::" ; | / colon-port-opt + "([0-9]*)" ; | | #5 = port-opt + ")?" ; | \ + ")?" ; \ + "([^?#]*)" ; #6 = path + "(?:\\?" ; / question-query-opt + "([^#]*)" ; | #7 = query-opt + ")?" ; \ + "(?:#" ; / hash-fragment-opt + "(.*)" ; | #8 = fragment-opt + ")?" ; \ + "$")) + +(define rlo "https://racket-lang.org:80x/people.html?check=ok#end") + +(check (string->bytes/utf-8 url-s) + (string->bytes/utf-8 rlo) + 100000) + +(check url-s + rlo + 10000) + +;; all of the work is looking for a must-string +(check #"a*b" + (make-bytes 1024 (char->integer #\a)) + 100000) diff --git a/racket/src/regexp/main.rkt b/racket/src/regexp/main.rkt new file mode 100644 index 0000000000..2bda4a5f1a --- /dev/null +++ b/racket/src/regexp/main.rkt @@ -0,0 +1,171 @@ +#lang racket/base +(require "../common/check.rkt" + "match/regexp.rkt" + "match/main.rkt" + "replace/main.rkt") + +(provide regexp + byte-regexp + pregexp + byte-pregexp + + regexp-match + regexp-match/end + regexp-match-positions + regexp-match-positions/end + regexp-match? + regexp-match-peek + regexp-match-peek-positions + regexp-match-peek-positions/end + regexp-match-peek-immediate + regexp-match-peek-positions-immediate + regexp-match-peek-positions-immediate/end + regexp-replace + regexp-replace* + + regexp? + byte-regexp? + pregexp? + byte-pregexp? + + regexp-max-lookbehind) + +(define/who (regexp p [handler #f]) + (check who string? p) + (make-regexp who p #f #f handler)) + +(define/who (byte-regexp p [handler #f]) + (check who bytes? p) + (make-regexp who p #f #t handler)) + +(define/who (pregexp p [handler #f]) + (check who string? p) + (make-regexp 'pregexp p #t #f handler)) + +(define/who (byte-pregexp p [handler #f]) + (check who bytes? p) + (make-regexp 'byte-pregexp p #t #t handler)) + +(define/who (regexp-max-lookbehind rx) + (check who + #:test (or (regexp? rx) (byte-regexp? rx)) + #:contract "(or regexp? byte-regexp?)" + rx) + (rx:regexp-max-lookbehind rx)) + +;; ---------------------------------------- + +;; For especially simple and common cases, reduce the overhead created +;; by the general case by checking for simple cases and using a faster, +;; specific driver. + +(define no-prefix #"") + +(define (fast-bytes? rx in start-pos end-pos out prefix) + (and (byte-regexp? rx) + (bytes? in) + (exact-nonnegative-integer? start-pos) + (let ([len (bytes-length in)]) + (and (start-pos . <= . len) + (or (not end-pos) + (and (exact-nonnegative-integer? end-pos) + (end-pos . <= . len) + (end-pos . >= . start-pos))))) + (not out) + (eq? prefix no-prefix))) + +(define (fast-string? rx in start-pos end-pos out prefix) + (and (regexp? rx) + (string? in) + (exact-nonnegative-integer? start-pos) + (let ([len (string-length in)]) + (and (len . < . FAST-STRING-LEN) + (start-pos . <= . len) + (or (not end-pos) + (and (exact-nonnegative-integer? end-pos) + (end-pos . <= . len) + (end-pos . >= . start-pos))))) + (not out) + (eq? prefix no-prefix))) + +(define/who (regexp-match? rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix]) + (cond + [(fast-bytes? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match?/bytes rx in start-pos end-pos)] + [(fast-string? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match?/string rx in start-pos end-pos)] + [else + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode '?)])) + +(define/who (regexp-match-positions rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix]) + (cond + [(fast-bytes? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match-positions/bytes rx in start-pos end-pos)] + [(fast-string? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match-positions/string rx in start-pos end-pos)] + [else + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'positions)])) + +(define/who (regexp-match rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix]) + (cond + [(fast-bytes? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match/bytes rx in start-pos end-pos)] + [(fast-string? rx in start-pos end-pos out prefix) + (fast-drive-regexp-match/string rx in start-pos end-pos)] + [else + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'strings)])) + +(define/who (regexp-match-positions/end rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'positions + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) + +(define/who (regexp-match/end rx in [start-pos 0] [end-pos #f] [out #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos out prefix + #:mode 'strings + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) + +(define/who (regexp-match-peek rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t + #:progress-evt progress-evt + #:mode 'strings)) + +(define/who (regexp-match-peek-immediate rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t #:immediate-only? #t + #:progress-evt progress-evt + #:mode 'strings)) + +(define/who (regexp-match-peek-positions rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t + #:progress-evt progress-evt + #:mode 'positions)) + +(define/who (regexp-match-peek-positions/end rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t + #:progress-evt progress-evt + #:mode 'positions + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) + +(define/who (regexp-match-peek-positions-immediate rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t #:immediate-only? #t + #:progress-evt progress-evt + #:mode 'positions)) + +(define/who (regexp-match-peek-positions-immediate/end rx in [start-pos 0] [end-pos #f] [progress-evt #f] [prefix no-prefix] [end-bytes-count 1]) + (drive-regexp-match who rx in start-pos end-pos #f prefix + #:peek? #t #:immediate-only? #t + #:progress-evt progress-evt + #:mode 'positions + #:end-bytes? #t + #:end-bytes-count end-bytes-count)) diff --git a/racket/src/regexp/match/compile.rkt b/racket/src/regexp/match/compile.rkt new file mode 100644 index 0000000000..80bea33785 --- /dev/null +++ b/racket/src/regexp/match/compile.rkt @@ -0,0 +1,183 @@ +#lang racket/base +(require "../parse/ast.rkt" + "../common/range.rkt" + "match.rkt") + +;; Compile to a Spencer-style interpretation of a regular expression, +;; where sequences are implemented by record chaining. Backtracking +;; is implemented by a stack of of success continuations as needed. + +;; Spenser's implementation in C dispatches on records, but we compile +;; to closures, instead. A function like `byte-matcher` allocates a +;; closure to implement byte matching. Matcher-creation functions +;; usually take a closure to use as the next step, so the closure tree +;; is built bottom-up. + +(provide compile) + +(define (compile rx) + (let compile ([rx rx] [next-m done-m]) + (define-syntax-rule (mode-cond + #:tail tail + #:general general) + (cond + [(eq? next-m done-m) tail] + [else general])) + (cond + [(exact-integer? rx) + (mode-cond + #:tail (byte-tail-matcher rx) + #:general (byte-matcher rx next-m))] + [(bytes? rx) + (define len (bytes-length rx)) + (mode-cond + #:tail (bytes-tail-matcher rx len) + #:general (bytes-matcher rx len next-m))] + [(eq? rx rx:empty) + next-m] + [(eq? rx rx:never) + (never-matcher)] + [(eq? rx rx:any) + (mode-cond + #:tail (any-tail-matcher) + #:general (any-matcher next-m))] + [(rx:range? rx) + (define rng (compile-range (rx:range-range rx))) + (mode-cond + #:tail (range-tail-matcher rng) + #:general (range-matcher rng next-m))] + [(eq? rx rx:start) + (start-matcher next-m)] + [(eq? rx rx:end) + (end-matcher next-m)] + [(eq? rx rx:line-start) + (line-start-matcher next-m)] + [(eq? rx rx:line-end) + (line-end-matcher next-m)] + [(eq? rx rx:word-boundary) + (word-boundary-matcher next-m)] + [(eq? rx rx:not-word-boundary) + (not-word-boundary-matcher next-m)] + [(rx:sequence? rx) + (define rxs (rx:sequence-rxs rx)) + (let loop ([rxs rxs]) + (cond + [(null? rxs) next-m] + [else + (define rest-node (loop (cdr rxs))) + (compile (car rxs) rest-node)]))] + [(rx:alts? rx) + (alts-matcher (compile (rx:alts-rx1 rx) next-m) + (compile (rx:alts-rx2 rx) next-m))] + [(rx:maybe? rx) + (if (rx:maybe-non-greedy? rx) + (alts-matcher next-m + (compile (rx:maybe-rx rx) next-m)) + (alts-matcher (compile (rx:maybe-rx rx) next-m) + next-m))] + [(rx:repeat? rx) + (define actual-r-rx (rx:repeat-rx rx)) + ;; As a special case, handle in non-lazy `repeat` a group around + ;; a simple pattern: + (define r-rx (if (and (rx:group? actual-r-rx) + (not (rx:repeat-non-greedy? rx)) + (not (needs-backtrack? (rx:group-rx actual-r-rx)))) + (rx:group-rx actual-r-rx) + actual-r-rx)) + (define simple? (not (needs-backtrack? r-rx))) + (define group-n (and simple? + (rx:group? actual-r-rx) + (rx:group-number actual-r-rx))) + (define min (rx:repeat-min rx)) + (define max (let ([n (rx:repeat-max rx)]) + (if (= n +inf.0) #f n))) + (define r-m* (compile*/maybe r-rx min max)) + (cond + [(and r-m* + (not (rx:repeat-non-greedy? rx))) + (repeat-simple-many-matcher r-m* min max group-n next-m)] + [else + (define r-m (compile r-rx (if simple? done-m continue-m))) + (cond + [(rx:repeat-non-greedy? rx) + (if simple? + (lazy-repeat-simple-matcher r-m min max next-m) + (lazy-repeat-matcher r-m min max next-m))] + [else + (if simple? + (repeat-simple-matcher r-m min max group-n next-m) + (repeat-matcher r-m min max next-m))])])] + [(rx:group? rx) + (define n (rx:group-number rx)) + (define m (compile (rx:group-rx rx) (group-set-matcher n next-m))) + (group-push-matcher n m)] + [(rx:reference? rx) + (define n (rx:reference-n rx)) + (cond + [(zero? n) + (never-matcher)] + [(rx:reference-case-sensitive? rx) + (reference-matcher (sub1 n) next-m)] + [else + (reference-matcher/case-insensitive (sub1 n) next-m)])] + [(rx:cut? rx) + (cut-matcher (compile (rx:cut-rx rx) done-m) + (rx:cut-n-start rx) + (rx:cut-num-n rx) + next-m)] + [(rx:conditional? rx) + (define tst (rx:conditional-tst rx)) + (define m1 (compile (rx:conditional-rx1 rx) next-m)) + (define m2 (compile (rx:conditional-rx2 rx) next-m)) + (cond + [(rx:reference? tst) + (define n (sub1 (rx:reference-n tst))) + (conditional/reference-matcher n m1 m2)] + [else + (conditional/look-matcher (compile tst done-m) m1 m2 + (rx:conditional-n-start rx) + (rx:conditional-num-n rx))])] + [(rx:lookahead? rx) + (lookahead-matcher (rx:lookahead-match? rx) + (compile (rx:lookahead-rx rx) done-m) + (rx:lookahead-n-start rx) + (rx:lookahead-num-n rx) + next-m)] + [(rx:lookbehind? rx) + (lookbehind-matcher (rx:lookbehind-match? rx) + (rx:lookbehind-lb-min rx) + (rx:lookbehind-lb-max rx) + (compile (rx:lookbehind-rx rx) limit-m) + (rx:lookbehind-n-start rx) + (rx:lookbehind-num-n rx) + next-m)] + [(rx:unicode-categories? rx) + (unicode-categories-matcher (rx:unicode-categories-symlist rx) + (rx:unicode-categories-match? rx) + next-m)] + [else (error 'compile/bt "internal error: unrecognized ~s" rx)]))) + +;; Compile a matcher repeater, if possible; the result is +;; the repeating matcher and the (consistent) length of each match +(define (compile*/maybe rx min max) + (cond + [(exact-integer? rx) + (byte-matcher* rx max)] + [(bytes? rx) + (bytes-matcher* rx max)] + [(eq? rx rx:any) + (any-matcher* max)] + [(rx:range? rx) + (range-matcher* (compile-range (rx:range-range rx)) max)] + [else + #f])) + +;; Determine the length of the prefix of `l` that needs backtracking: +(define (count-backtrack-prefix l) + (let loop ([l l] [total 0] [non-bt 0]) + (cond + [(null? l) (- total non-bt)] + [(needs-backtrack? (car l)) + (loop (cdr l) (add1 total) 0)] + [else + (loop (cdr l) (add1 total) (add1 non-bt))]))) diff --git a/racket/src/regexp/match/extract.rkt b/racket/src/regexp/match/extract.rkt new file mode 100644 index 0000000000..b7f5a1333d --- /dev/null +++ b/racket/src/regexp/match/extract.rkt @@ -0,0 +1,65 @@ +#lang racket/base + +;; Helpers to extract position, bytes, and string results from a match +;; result. + +(provide byte-positions->byte-positions + byte-positions->bytess + + byte-positions->string-positions + byte-positions->strings + + add-end-bytes) + +(define (byte-positions->byte-positions ms-pos me-pos state + #:delta [delta 0]) + (cond + [(not state) + (list (cons (+ ms-pos delta) (+ me-pos delta)))] + [(zero? delta) + (cons (cons ms-pos me-pos) (vector->list state))] + [else + (cons (cons (+ ms-pos delta) (+ me-pos delta)) + (for/list ([p (in-vector state)]) + (and p + (cons (+ (car p) delta) + (+ (cdr p) delta)))))])) + +(define (byte-positions->bytess in ms-pos me-pos state + #:delta [delta 0]) + (cons (subbytes in (+ ms-pos delta) (+ me-pos delta)) + (if state + (for/list ([p (in-vector state)]) + (and p + (subbytes in (+ (car p) delta) (+ (cdr p) delta)))) + null))) + +(define (byte-positions->string-positions bstr-in ms-pos me-pos state + #:start-offset start-offset + #:start-pos [start-pos 0]) + (define (string-offset pos) + (+ start-offset (bytes-utf-8-length bstr-in #\? start-pos pos))) + (cons (cons (string-offset ms-pos) (string-offset me-pos)) + (if state + (for/list ([p (in-vector state)]) + (and p + (cons (string-offset (car p)) + (string-offset (cdr p))))) + null))) + +(define (byte-positions->strings bstr-in ms-pos me-pos state + #:delta [delta 0]) + (cons (bytes->string/utf-8 bstr-in #\? (+ ms-pos delta) (+ me-pos delta)) + (if state + (for/list ([p (in-vector state)]) + (and p + (bytes->string/utf-8 bstr-in #\? (+ (car p) delta) (+ delta (cdr p))))) + null))) + +;; For functions like `regexp-match/end`: +(define (add-end-bytes results end-bytes-count bstr me-pos) + (if end-bytes-count + (values results + (and results + (subbytes bstr (max 0 (- me-pos end-bytes-count)) me-pos))) + results)) diff --git a/racket/src/regexp/match/interp.rkt b/racket/src/regexp/match/interp.rkt new file mode 100644 index 0000000000..d27ff560d5 --- /dev/null +++ b/racket/src/regexp/match/interp.rkt @@ -0,0 +1,17 @@ +#lang racket/base + +(provide interp) + +;; Compilation produces a matcher function; see "match.rkt" +(define (interp m ; the compiled matcher function + s ; input bytes or lazy-bytes + pos ; starting seach position, can be > `start`, must be < `limit` + start ; input start in the sense of `^`; don't read before this + limit/end ; don't read past `limit`; `end` corresponds to `$` and can be < `limit` + state) ; vector where group position-pair matches are installed + ;; The search `pos` can be greater than `start` due to prefix bytes + ;; passed to `regexp-match`. + ;; The search `limit` and `end` start out the same, but `limit` + ;; can be less than `end` for a lookbehind match. + (m s pos start limit/end limit/end state null)) + diff --git a/racket/src/regexp/match/lazy-bytes.rkt b/racket/src/regexp/match/lazy-bytes.rkt new file mode 100644 index 0000000000..e5432c60dd --- /dev/null +++ b/racket/src/regexp/match/lazy-bytes.rkt @@ -0,0 +1,124 @@ +#lang racket/base + +;; A compiled matcher accepts a byte string or a `lazy-bytes` object, +;; where the later is used to pull bytes on demand from a port or a +;; long character string. + +(provide make-lazy-bytes + lazy-bytes-before-end? + lazy-bytes-ref + lazy-bytes-bstr + lazy-bytes-failed? + lazy-bytes-discarded-count + lazy-bytes-advance!) + +(struct lazy-bytes ([bstr #:mutable] ; buffered bytes + [end #:mutable] ; number of available bytes --- plus discarded bytes + in ; input port + skip-amt ; offset into the port; 0 if `(not peek?)` + prefix-len ; length of prefix (not from port) + peek? ; peeking mode + immediate-only? ; non-blocking mode; implies `peek?` + progress-evt ; stop peeking if ready + out ; output hold discarded bytes; implies `(not peek?)` + max-lookbehind ; bytes before current counter to preserve, if `out` + [failed? #:mutable] ; set to #t if `progress-evt` fires or read blocks + [discarded-count #:mutable])) ; bytes discarded, if not `peek?` + +(define (make-lazy-bytes in skip-amt prefix + peek? immediate-only? progress-evt + out max-lookbehind) + (define len (bytes-length prefix)) + (lazy-bytes prefix len in skip-amt len + peek? immediate-only? progress-evt + out max-lookbehind + #f 0)) + +(define (lazy-bytes-before-end? s pos end) + (and (or (not (exact-integer? end)) + (pos . < . end)) + (cond + [(pos . < . (lazy-bytes-end s)) + #t] + [else + (and (get-more-bytes! s) + (lazy-bytes-before-end? s pos end))]))) + +(define (lazy-bytes-ref s pos) + ;; Assume a preceding `lazy-bytes-before-end?` call, so + ;; we have the byte + (bytes-ref (lazy-bytes-bstr s) (- pos (lazy-bytes-discarded-count s)))) + +(define (lazy-bytes-advance! s given-pos force?) + ;; If we advance far enough and not peeking, + ;; then flush unneeded bytes... + ;; The promise is that we won't ask for bytes before + ;; `pos` minus the `max-lookbehind` + (define pos (min given-pos (lazy-bytes-end s))) + (when force? + (lazy-bytes-before-end? s pos 'eof)) + (when (and (lazy-bytes? s) + (not (lazy-bytes-peek? s))) + (define discarded-count (lazy-bytes-discarded-count s)) + (define unneeded (- pos + discarded-count + (lazy-bytes-max-lookbehind s))) + (when (or force? (unneeded . > . 4096)) + (define amt (if force? + (- pos (lazy-bytes-discarded-count s)) + 4096)) + (define bstr (lazy-bytes-bstr s)) + (define out (lazy-bytes-out s)) + (when out + ;; Discard bytes to `out` + (define prefix-len (lazy-bytes-prefix-len s)) + (write-bytes bstr + out + ;; Skip over bytes that are part of the prefix: + (cond + [(discarded-count . > . prefix-len) 0] + [else (min amt (- prefix-len discarded-count))]) + ;; To amount to discard: + amt)) + (bytes-copy! bstr 0 bstr amt (- (lazy-bytes-end s) discarded-count)) + (set-lazy-bytes-discarded-count! s (+ amt discarded-count))))) + +;; ---------------------------------------- + +;; Result reports whether new bytes were read +(define (get-more-bytes! s) + (cond + [(lazy-bytes? s) + (define discarded-count (lazy-bytes-discarded-count s)) + (define len (- (lazy-bytes-end s) discarded-count)) + (define bstr (lazy-bytes-bstr s)) + (cond + [(lazy-bytes-failed? s) #f] + [(len . < . (bytes-length bstr)) + ;; Room in current byte string + (define n ((if (lazy-bytes-immediate-only? s) + peek-bytes-avail!* + peek-bytes-avail!) + bstr + (+ (- len (lazy-bytes-prefix-len s)) + (lazy-bytes-skip-amt s) + discarded-count) + (lazy-bytes-progress-evt s) + (lazy-bytes-in s) + len)) + (cond + [(eof-object? n) #f] + [(zero? n) + ;; would block or progress evt became ready + (set-lazy-bytes-failed?! s #t) + #f] + [else + (set-lazy-bytes-end! s (+ n len discarded-count)) + #t])] + [else + ;; We're going to need a bigger byte string + (define bstr2 (make-bytes (max 32 (* 2 (bytes-length bstr))))) + (bytes-copy! bstr2 0 bstr 0 len) + (set-lazy-bytes-bstr! s bstr2) + (get-more-bytes! s)])] + [else #f])) diff --git a/racket/src/regexp/match/main.rkt b/racket/src/regexp/match/main.rkt new file mode 100644 index 0000000000..b0f0f446e0 --- /dev/null +++ b/racket/src/regexp/match/main.rkt @@ -0,0 +1,381 @@ +#lang racket/base +(require "regexp.rkt" + "lazy-bytes.rkt" + "port.rkt" + "compile.rkt" + "extract.rkt" + "search.rkt") + +;; Drives a regexp matcher on a byte string, character string, or port + +(provide drive-regexp-match + + fast-drive-regexp-match?/bytes + fast-drive-regexp-match?/string + fast-drive-regexp-match-positions/bytes + fast-drive-regexp-match-positions/string + fast-drive-regexp-match/bytes + fast-drive-regexp-match/string + + FAST-STRING-LEN) + +;; ---------------------------------------- +;; Start with some (repetative) functions for the most common cases to +;; keep the overhead low for reaching these cases. + +(define FAST-STRING-LEN 64) + +(define (fast-drive-regexp-match?/bytes rx in start-pos end-pos) + (define state (and (rx:regexp-references? rx) + (make-vector (rx:regexp-num-groups rx) #f))) + (define-values (ms-pos me-pos) + (search-match rx in start-pos start-pos (or end-pos (bytes-length in)) state)) + (and ms-pos #t)) + +(define (fast-drive-regexp-match?/string rx in-str start-offset end-offset) + (define state (and (rx:regexp-references? rx) + (make-vector (rx:regexp-num-groups rx) #f))) + (define in (string->bytes/utf-8 in-str 0 start-offset (or end-offset (string-length in-str)))) + (define-values (ms-pos me-pos) + (search-match rx in 0 0 (bytes-length in) state)) + (and ms-pos #t)) + +(define (fast-drive-regexp-match-positions/bytes rx in start-pos end-pos) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in start-pos start-pos (or end-pos (bytes-length in)) state)) + (and ms-pos + (if state + (cons (cons ms-pos me-pos) (vector->list state)) + (list (cons ms-pos me-pos))))) + +(define (fast-drive-regexp-match-positions/string rx in-str start-offset end-offset) + (define in (string->bytes/utf-8 in-str 0 start-offset (or end-offset (string-length in-str)))) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in 0 0 (bytes-length in) state)) + (define (string-offset pos) + (+ start-offset (bytes-utf-8-length in #\? 0 pos))) + (and ms-pos + (cons (cons (string-offset ms-pos) (string-offset me-pos)) + (if state + (for/list ([p (in-vector state)]) + (and p + (cons (string-offset (car p)) + (string-offset (cdr p))))) + null)))) + +(define (fast-drive-regexp-match/bytes rx in start-pos end-pos) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in start-pos start-pos (or end-pos (bytes-length in)) state)) + (and ms-pos + (cons (subbytes in ms-pos me-pos) + (if state + (for/list ([p (in-vector state)]) + (and p + (subbytes in (car p) (cdr p)))) + null)))) + +(define (fast-drive-regexp-match/string rx in-str start-offset end-offset) + (define in (string->bytes/utf-8 in-str 0 start-offset (or end-offset (string-length in-str)))) + (define state (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f)))) + (define-values (ms-pos me-pos) + (search-match rx in 0 0 (bytes-length in) state)) + (and ms-pos + (cons (bytes->string/utf-8 in #\? ms-pos me-pos) + (if state + (for/list ([p (in-vector state)]) + (and p + (bytes->string/utf-8 in #\? (car p) (cdr p)))) + null)))) + +;; ---------------------------------------- +;; The general case + +;; An "offset" refers to a position in a byte string (in bytes) string +;; (in characters), or port (in bytes). A "pos" always refers to a +;; position in bytes --- so, a "pos" is normalized to UTF-8 bytes in +;; the case of a string. + +(define (drive-regexp-match who orig-rx orig-in orig-start-offset orig-end-offset out prefix + #:search-offset [search-offset orig-start-offset] + #:mode mode + #:in-port-ok? [in-port-ok? #t] + #:in-path-ok? [in-path-ok? #t] + #:peek? [peek? #f] #:immediate-only? [immediate-only? #f] + #:progress-evt [progress-evt #f] + #:end-bytes? [end-bytes? #f] + #:end-bytes-count [end-bytes-count #f]) + + (define rx (cond + [(rx:regexp? orig-rx) orig-rx] + [(string? orig-rx) (make-regexp who orig-rx #f #f #f)] + [(bytes? orig-rx) (make-regexp who orig-rx #f #t #f)] + [else (raise-argument-error who "(or/c regexp? byte-regexp? string? bytes?)" orig-rx)])) + (define in (if (and in-path-ok? (path? orig-in)) + (if (rx:regexp-bytes? rx) + (path->bytes orig-in) + (path->string orig-in)) + orig-in)) + (unless (or (and (bytes? in) (not peek?)) + (and (string? in) (not peek?)) + (and in-port-ok? (input-port? in))) + (raise-argument-error who + (cond + [peek? "input-port?"] + [in-port-ok? "(or/c bytes? string? input-port? path?)"] + [in-path-ok? "(or/c bytes? string? path?)"] + [else "(or/c bytes? string?)"]) + orig-in)) + + (define start-offset (cond + [orig-start-offset + (unless (exact-nonnegative-integer? orig-start-offset) + (raise-argument-error who "exact-nonnegative-integer?" orig-start-offset)) + (check-range who "starting index" in orig-start-offset 0) + orig-start-offset] + [else 0])) + (define end-offset (cond + [orig-end-offset + (unless (exact-nonnegative-integer? orig-end-offset) + (raise-argument-error who "(or/c #f exact-nonnegative-integer?)" orig-end-offset)) + (check-range who "ending index" in orig-end-offset start-offset) + orig-end-offset] + [(bytes? in) (bytes-length in)] + [(string? in) (string-length in)] + [else 'eof])) + + (unless (or (not out) (output-port? out)) + (raise-argument-error who "(or/c #f output-port?)" out)) + + (unless (bytes? prefix) + (raise-argument-error who "bytes?" prefix)) + + (when end-bytes? + (unless (exact-nonnegative-integer? end-bytes-count) + (raise-argument-error who "exact-nonnegative-integer?" end-bytes-count))) + + (define state (and (or (not (eq? mode '?)) + (rx:regexp-references? rx)) + (let ([n (rx:regexp-num-groups rx)]) + (and (positive? n) + (make-vector n #f))))) + + ;; Separate cases for bytes, strings, and port. + ;; There's an annoying level of duplication here, but + ;; there are lots of little differences in each case. + (cond + + ;; Bytes input, no provided prefix: ---------------------------------------- + [(and (bytes? in) + (not out) + (equal? #"" prefix)) + (define start-pos start-offset) + (define search-pos search-offset) + (define end-pos end-offset) + + ;; Search for a match: + (define-values (ms-pos me-pos) (search-match rx in search-pos start-pos end-pos state)) + + ;; Maybe write skipped bytes: + (when out + (write-bytes in out 0 (or ms-pos end-pos))) + + ;; Return match results: + (case (and ms-pos mode) + [(#f) (add-end-bytes #f end-bytes-count #f #f)] + [(?) #t] + [(positions) + (define positions (byte-positions->byte-positions ms-pos me-pos state)) + (add-end-bytes positions end-bytes-count in me-pos)] + [(strings) + (define bytess (byte-positions->bytess in ms-pos me-pos state)) + (add-end-bytes bytess end-bytes-count in me-pos)])] + + ;; Sufficiently small string input, no provided prefix: -------------------- + [(and (string? in) + (not out) + (equal? #"" prefix) + ((- end-offset start-offset) . < . FAST-STRING-LEN)) + ;; `bstr-in` includes only the characters fom `start-offset` to + ;; `end-offset`, so the starting offset (in characters) + ;; corresponds to a 0 position (in bytes): + (define bstr-in (string->bytes/utf-8 in 0 start-offset end-offset)) + (define search-pos (if (= start-offset search-offset) + 0 + (string-utf-8-length in start-offset search-offset))) + (define end-pos (bytes-length bstr-in)) + + ;; Search for a match: + (define-values (ms-pos me-pos) (search-match rx bstr-in search-pos 0 end-pos state)) + + ;; Maybe write skipped bytes: + (when out + (write-string in out 0 start-offset) + (write-bytes bstr-in out 0 (or ms-pos end-pos))) + + ;; Return match results: + (case (and ms-pos mode) + [(#f) (add-end-bytes #f end-bytes-count #f #f)] + [(?) #t] + [(positions) + ;; If pattern is bytes-based, then results will be bytes-based: + (define positions + (cond + [(rx:regexp-bytes? rx) + (define delta (string-utf-8-length in 0 start-offset)) + (byte-positions->byte-positions ms-pos me-pos state #:delta delta)] + [else + (byte-positions->string-positions bstr-in ms-pos me-pos state + #:start-offset start-offset)])) + (add-end-bytes positions end-bytes-count bstr-in me-pos)] + [(strings) + ;; If pattern is bytes-based, then results will be bytes instead of strings: + (define bytes/strings + (cond + [(rx:regexp-bytes? rx) + (byte-positions->bytess bstr-in ms-pos me-pos state)] + [else + (byte-positions->strings bstr-in ms-pos me-pos state)])) + (add-end-bytes bytes/strings end-bytes-count bstr-in me-pos)])] + + ;; Port input, long string input, and/or provided prefix: -------------------- + [else + (define prefix-len (bytes-length prefix)) + ;; The lazy-bytes record will include the prefix, + ;; and it won't include bytes/characters before + ;; `start-offset`: + (define start-pos prefix-len) + (define search-pos (if (= start-offset search-offset) + start-pos + (+ start-pos + (cond + [(string? in) (string-utf-8-length in start-offset search-offset)] + [else (- search-offset start-offset)])))) + (define port-in + (cond + [(bytes? in) (open-input-bytes/no-copy in start-offset end-offset)] + [(string? in) (open-input-string/lazy in start-offset end-offset)] + [else in])) + (define any-bytes-left? + (cond + [(and (input-port? in) + (positive? start-offset)) + (cond + [peek? + ;; Make sure we can skip over `start-offset` bytes: + (not (eof-object? (peek-byte port-in (sub1 start-offset))))] + [else + ;; discard skipped bytes: + (copy-port-bytes port-in #f start-offset)])] + [else #t])) + ;; Create a lazy string from the port: + (define lb-in (make-lazy-bytes port-in (if peek? start-offset 0) prefix + peek? immediate-only? progress-evt + out (rx:regexp-max-lookbehind rx))) + (define end-pos (if (eq? 'eof end-offset) + 'eof + (+ start-pos + (cond + [(string? in) (string-utf-8-length in start-offset end-offset)] + [else (- end-offset start-offset)])))) + + ;; Search for a match: + (define-values (ms-pos me-pos) + (if any-bytes-left? + (search-match rx lb-in search-pos 0 end-pos state) + ;; Couldn't skip past `start-offset` bytes for an input port: + (values #f #f))) + + ;; To write and consume skipped bytes, but we'll do this only + ;; after we've extracted match information from the lazy byte + ;; string: + (define (write/consume-skipped) + (when (not peek?) + (cond + [ms-pos + (when (or out (input-port? in)) + ;; Flush bytes before match: + (lazy-bytes-advance! lb-in ms-pos #t) + ;; Consume bytes that correspond to match: + (copy-port-bytes port-in #f me-pos))] + [(eq? end-pos 'eof) + ;; copy all remaining bytes from input to output + (copy-port-bytes port-in out #f)] + [else + (when (or out (input-port? in)) + (lazy-bytes-advance! lb-in end-pos #t))]))) + + (begin0 + + ;; Return match results: + (case (and ms-pos + (not (lazy-bytes-failed? lb-in)) + mode) + [(#f) + (when (and (not peek?) + any-bytes-left? + (input-port? in)) + ;; Consume non-matching bytes + (copy-port-bytes port-in out (if (eq? 'eof end-offset) #f end-offset))) + (add-end-bytes #f end-bytes-count #f #f)] + [(?) #t] + [(positions) + ;; Result positions correspond to the port after `start-offset`, + ;; but with the prefix bytes (= `start-pos`) + (define bstr (lazy-bytes-bstr lb-in)) + (define positions + (cond + [(or (not (string? in)) + (rx:regexp-bytes? rx)) + (define delta (- start-offset start-pos)) + (byte-positions->byte-positions ms-pos me-pos state #:delta delta)] + [else + (byte-positions->string-positions bstr ms-pos me-pos state + #:start-pos start-pos + #:start-offset start-offset)])) + (add-end-bytes positions end-bytes-count bstr me-pos)] + [(strings) + ;; The byte string may be shifted by discarded bytes, if not + ;; in `peek?` mode + (define bstr (lazy-bytes-bstr lb-in)) + (define delta (lazy-bytes-discarded-count lb-in)) + (define bytes/strings + (cond + [(or (not (string? in)) + (rx:regexp-bytes? rx)) + (byte-positions->bytess bstr ms-pos me-pos state #:delta delta)] + [else + (byte-positions->strings bstr ms-pos me-pos state #:delta delta)])) + (add-end-bytes bytes/strings end-bytes-count bstr me-pos)]) + + ;; Now, write and consume port content: + (write/consume-skipped))])) + +;; ------------------------------------------------------- +;; Range-checking arguments to `regexp-match` and company: + +(define (check-range who what in pos start-pos) + (define len (cond + [(bytes? in) (bytes-length in)] + [(string? in) (string-length in)] + [else +inf.0])) + (unless (pos . >= . start-pos) + (raise-arguments-error who + (format "~a is smaller than starting index" what) + what pos + "starting index" start-pos)) + (unless (pos . <= . len) + (raise-arguments-error who + (format "~a is out of range" what) + what pos))) + diff --git a/racket/src/regexp/match/match.rkt b/racket/src/regexp/match/match.rkt new file mode 100644 index 0000000000..e77444d220 --- /dev/null +++ b/racket/src/regexp/match/match.rkt @@ -0,0 +1,585 @@ +#lang racket/base +(require "../common/range.rkt" + "lazy-bytes.rkt" + "utf-8.rkt") + +;; An AST is converted to a pile of matcher closures by "compile.rkt". + +;; See "interp.rkt" for the matcher protocol. + +(provide done-m + continue-m + limit-m + + byte-tail-matcher + byte-matcher + byte-matcher* + + bytes-tail-matcher + bytes-matcher + bytes-matcher* + + never-matcher + + any-tail-matcher + any-matcher + any-matcher* + + range-tail-matcher + range-matcher + range-matcher* + + start-matcher + end-matcher + line-start-matcher + line-end-matcher + word-boundary-matcher + not-word-boundary-matcher + + alts-matcher + + repeat-matcher + repeat-simple-many-matcher + repeat-simple-matcher + lazy-repeat-matcher + lazy-repeat-simple-matcher + + group-push-matcher + group-set-matcher + + reference-matcher + reference-matcher/case-insensitive + + cut-matcher + conditional/reference-matcher + conditional/look-matcher + lookahead-matcher + lookbehind-matcher + + unicode-categories-matcher) + +;; ---------------------------------------- + +(define done-m (lambda (s pos start limit end state stack) + pos)) +(define continue-m (lambda (s pos start limit end state stack) + ((car stack) pos))) +(define limit-m (lambda (s pos start limit end state stack) + (= pos limit))) + + +;; ---------------------------------------- + +(define-syntax-rule (define-general+tail (general-matcher tail-matcher arg ... next-m) + (lambda (s pos start limit end) + tst + next-pos)) + (begin + ;; General mode when `next-m` is not just `done-m`: + (define (general-matcher arg ... next-m) + (lambda (s pos start limit end state stack) + (and tst + (next-m s next-pos start limit end state stack)))) + ;; Tail mode when `next-m` is `done-m`: + (define (tail-matcher arg ...) + (lambda (s pos start limit end state stack) + (and tst + next-pos))))) + +;; An iterator performs a single match as many times as possible, up +;; to a specified max number of times, and it returns the position +;; and the number of items; this mode is used only when each match +;; has a fixed size +(define-syntax-rule (define-iterate (op-matcher* arg ...) + outer-defn ... + (lambda (s pos2 start limit end state) + inner-defn ... + #:size size + #:s-test s-tst + #:ls-test ls-tst)) + (define (op-matcher* arg ... max) + outer-defn ... + (lambda (s pos start limit end state) + inner-defn ... + (if (bytes? s) + (let ([limit (if max + (min limit (+ pos (* size max))) + limit)]) + (let loop ([pos2 pos] [n 0]) + (define pos3 (+ pos2 size)) + (cond + [(or (pos3 . > . limit) + (not s-tst)) + (values pos2 n size)] + [else (loop pos3 (add1 n))]))) + (let ([limit (and max (+ pos (* size max)))]) + (let loop ([pos2 pos] [n 0]) + (cond + [(or (and limit ((+ pos2 size) . > . limit)) + (not (lazy-bytes-before-end? s (+ pos2 (sub1 size)) limit)) + (not ls-tst)) + (values pos2 n size)] + [else + (loop (+ pos2 size) (add1 n))]))))))) + +;; When a simple repeat argument is wrapped as a group, `add-repeated-group` +;; is used in the repeating loop to set the group to the last span produced +;; by an iterator +(define-syntax-rule (add-repeated-group group-n-expr state-expr pos-expr n-expr back-amt + group-revert ; bound to an unwind thunk + body ...) ; duplicated in two `cond` branches + (let ([group-n group-n-expr] + [state state-expr] + [n n-expr] + [pos pos-expr]) + (cond + [(and group-n state) + (define old-span (vector-ref state group-n)) + (vector-set! state group-n (if (zero? n) + #f + (cons (- pos back-amt) pos))) + (define (group-revert) (vector-set! state group-n old-span)) + body ...] + [else + (define (group-revert) (void)) + body ...]))) + +;; ---------------------------------------- +;; Single-byte matching + +(define-general+tail (byte-matcher byte-tail-matcher b next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (and (pos . < . limit) + (= b (bytes-ref s pos))) + (and (lazy-bytes-before-end? s pos limit) + (= b (lazy-bytes-ref s pos)))) + (add1 pos))) + +(define-iterate (byte-matcher* b) + (lambda (s pos start limit end state) + #:size 1 + #:s-test (= b (bytes-ref s pos)) + #:ls-test (= b (lazy-bytes-ref s pos)))) + +;; ---------------------------------------- +;; Byte-string matching + +(define-general+tail (bytes-matcher bytes-tail-matcher bstr len next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (and ((+ pos len) . <= . limit) + (for/and ([c1 (in-bytes bstr 0 len)] + [c2 (in-bytes s pos (+ pos len))]) + (= c1 c2))) + (and (lazy-bytes-before-end? s (sub1 (+ pos len)) limit) + (for/and ([c1 (in-bytes bstr 0 len)] + [i (in-naturals pos)]) + (define c2 (lazy-bytes-ref s i)) + (= c1 c2)))) + (+ pos len))) + +(define-iterate (bytes-matcher* bstr) + (define len (bytes-length bstr)) + (lambda (s pos start limit end state) + #:size len + #:s-test (for/and ([c1 (in-bytes bstr 0 len)] + [c2 (in-bytes s pos (+ pos len))]) + (= c1 c2)) + #:ls-test (for/and ([c1 (in-bytes bstr 0 len)] + [i (in-naturals pos)]) + (define c2 (lazy-bytes-ref s i)) + (= c1 c2)))) + +;; ---------------------------------------- +;; An always-fail pattern + +(define (never-matcher) + (lambda (s pos start limit end state stack) + #f)) + +;; ---------------------------------------- +;; Match any byte + +(define-general+tail (any-matcher any-tail-matcher next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (pos . < . limit) + (lazy-bytes-before-end? s pos limit)) + (add1 pos))) + +(define (any-matcher* max-repeat) + (lambda (s pos start limit end state) + (cond + [(bytes? s) + (define n (if max-repeat + (min max-repeat (- limit pos)) + (- limit pos))) + (values (+ pos n) n 1)] + [else + ;; Search for end position + (let grow-loop ([size 1]) + (define n (if max-repeat (min size max-repeat) size)) + (define pos2 (+ pos n)) + (cond + [(and (lazy-bytes-before-end? s (sub1 pos2) limit) + (or (not max-repeat) (n . < . max-repeat))) + (grow-loop (* size 2))] + [else + (let search-loop ([min pos] [too-high (add1 pos2)]) + (define mid (quotient (+ min too-high) 2)) + (cond + [(= mid min) + (values mid (- mid pos) 1)] + [(lazy-bytes-before-end? s (sub1 mid) limit) + (search-loop mid too-high)] + [else + (search-loop min mid)]))]))]))) + +;; ---------------------------------------- +;; Match any byte in a set + +(define-general+tail (range-matcher range-tail-matcher rng next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (and (pos . < . limit) + (rng-in? rng (bytes-ref s pos))) + (and (lazy-bytes-before-end? s pos limit) + (rng-in? rng (lazy-bytes-ref s pos)))) + (add1 pos))) + +(define-iterate (range-matcher* rng) + (lambda (s pos start limit end state) + #:size 1 + #:s-test (rng-in? rng (bytes-ref s pos)) + #:ls-test (rng-in? rng (lazy-bytes-ref s pos)))) + +;; ---------------------------------------- +;; Matches that don't consume any characters, +;; such as end-of-string or word-boundary + +(define-syntax-rule (define-zero-width (op-matcher arg ... next-m) + (lambda (s pos start limit end) + tst)) + (define (op-matcher arg ... next-m) + (lambda (s pos start limit end state stack) + (and tst + (next-m s pos start limit end state stack))))) + +(define-zero-width (start-matcher next-m) + (lambda (s pos start limit end) + (= pos start))) + +(define-zero-width (end-matcher next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (= pos end) + (not (lazy-bytes-before-end? s pos end))))) + +(define-zero-width (line-start-matcher next-m) + (lambda (s pos start limit end) + (or (= pos start) + (= (char->integer #\newline) + (if (bytes? s) + (bytes-ref s (sub1 pos)) + (lazy-bytes-ref s (sub1 pos))))))) + +(define-zero-width (line-end-matcher next-m) + (lambda (s pos start limit end) + (if (bytes? s) + (or (= pos end) + (= (char->integer #\newline) (bytes-ref s pos))) + (or (not (lazy-bytes-before-end? s pos end)) + (= (char->integer #\newline) + (lazy-bytes-ref s pos)))))) + +(define-zero-width (word-boundary-matcher next-m) + (lambda (s pos start limit end) + (word-boundary? s pos start limit end))) + +(define-zero-width (not-word-boundary-matcher next-m) + (lambda (s pos start limit end) + (not (word-boundary? s pos start limit end)))) + +(define (word-boundary? s pos start limit end) + (not (eq? (or (= pos start) + (not (word-byte? (if (bytes? s) + (bytes-ref s (sub1 pos)) + (lazy-bytes-ref s (sub1 pos)))))) + (or (if (bytes? s) + (= pos end) + (not (lazy-bytes-before-end? s pos end))) + (not (word-byte? (if (bytes? s) + (bytes-ref s pos) + (lazy-bytes-ref s pos)))))))) + +(define (word-byte? c) + (or (and (c . >= . (char->integer #\0)) (c . <= . (char->integer #\9))) + (and (c . >= . (char->integer #\a)) (c . <= . (char->integer #\z))) + (and (c . >= . (char->integer #\A)) (c . <= . (char->integer #\Z))) + (= c (char->integer #\_)))) + +;; ---------------------------------------- +;; Alternatives + +(define (alts-matcher m1 m2) + (lambda (s pos start limit end state stack) + (or (m1 s pos start limit end state stack) + (m2 s pos start limit end state stack)))) + +;; ---------------------------------------- +;; Repeats, greedy (normal) and non-greedy, +;; in various optimized forms + +(define (repeat-matcher r-m min max next-m) + ;; The tail of `r-m` is set to `continue-m` instead + ;; of `done-m`, so we can supply a success continuation + ;; by pushing it onto the stack + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0]) + (cond + [(n . < . min) + (define new-stack (cons (lambda (pos) + (rloop pos (add1 n))) + stack)) + (r-m s pos start limit end state new-stack)] + [(and max (= n max)) (next-m s pos start limit end state stack)] + [else + (define new-stack (cons (lambda (pos) + (rloop pos (add1 n))) + stack)) + (or (r-m s pos start limit end state new-stack) + (next-m s pos start limit end state stack))])))) + +(define r-stack (list (lambda (pos) pos))) + +(define (repeat-simple-matcher r-m min max group-n next-m) + ;; The `r-m` matcher doesn't need backtracking, so + ;; we don't need to push a success continuation onto + ;; the stack + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0] [back-amt 0]) + (define pos2 + (and (or (not max) (n . < . max)) + (r-m s pos start limit end state r-stack))) + (if pos2 + (rloop pos2 (add1 n) (- pos2 pos)) + (let bloop ([pos pos] [n n]) + (cond + [(n . < . min) #f] + [else + (add-repeated-group + group-n state pos n back-amt group-revert + (or (next-m s pos start limit end state stack) + (begin + (group-revert) + (bloop (- pos back-amt) (sub1 n)))))])))))) + +(define (repeat-simple-many-matcher r-m* min max group-n next-m) + ;; Instead of `r-m`, we have a `r-m*` that finds as many matches as + ;; possible (up to max) in one go + (lambda (s pos start limit end state stack) + (define-values (pos2 n back-amt) (r-m* s pos start limit end state)) + (let bloop ([pos pos2] [n n]) + (cond + [(n . < . min) #f] + [else + (add-repeated-group + group-n state pos n back-amt group-revert + (or (next-m s pos start limit end state stack) + (begin + (group-revert) + (bloop (- pos back-amt) (sub1 n)))))])))) + +(define (lazy-repeat-matcher r-m min max next-m) + ;; Like `repeat-matcher`: the tail of `r-m` is set to `continue-m` + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0] [min min]) + (cond + [(n . < . min) + (define new-stack (cons (lambda (pos) + (rloop pos (add1 n) min)) + stack)) + (r-m s pos start limit end state new-stack)] + [(and max (= n max)) + (next-m s pos start limit end state stack)] + [else + (or (next-m s pos start limit end state stack) + (rloop pos n (add1 min)))])))) + +(define (lazy-repeat-simple-matcher r-m min max next-m) + ;; Like `repeat-simple-matcher`: no backtracking in `r-m` + (lambda (s pos start limit end state stack) + (let rloop ([pos pos] [n 0] [min min]) + (cond + [(n . < . min) + (define pos2 (r-m s pos start limit end state stack)) + (and pos2 + (rloop pos2 (add1 n) min))] + [(and max (= n max)) + (next-m s pos start limit end state stack)] + [else + (or (next-m s pos start limit end state stack) + (rloop pos n (add1 min)))])))) + +;; ---------------------------------------- +;; Recording and referencing group matches + +(define (group-push-matcher n next-m) + (lambda (s pos start limit end state stack) + (define new-stack (cons (cons pos (and state (vector-ref state n))) + stack)) + (next-m s pos start limit end state new-stack))) + +(define (group-set-matcher n next-m) + (lambda (s pos start limit end state stack) + (define old-pos+span (car stack)) + (define old-span (cdr old-pos+span)) + (when state + (vector-set! state n (cons (car old-pos+span) pos))) + (or (next-m s pos start limit end state (cdr stack)) + (begin + (when state (vector-set! state n old-span)) + #f)))) + +(define-syntax-rule (define-reference-matcher reference-matcher chyte=?) + (define (reference-matcher n next-m) + (lambda (s pos start limit end state stack) + (define p (vector-ref state n)) + (cond + [(not p) #f] + [else + (define len (- (cdr p) (car p))) + (define matches? + (if (bytes? s) + (and ((+ pos len) . <= . limit) + (for/and ([c1 (in-bytes s (car p) (cdr p))] + [c2 (in-bytes s pos (+ pos len))]) + (chyte=? c1 c2))) + (and (lazy-bytes-before-end? s (sub1 (+ pos len)) limit) + (for/and ([j (in-range (car p) (cdr p))] + [i (in-naturals pos)]) + (define c1 (lazy-bytes-ref s j)) + (define c2 (lazy-bytes-ref s i)) + (chyte=? c1 c2))))) + (and matches? + (next-m s (+ pos len) start limit end state stack))])))) + +(define-reference-matcher reference-matcher =) + +(define-reference-matcher reference-matcher/case-insensitive + (lambda (c1 c2) (= (chyte-to-lower c1) (chyte-to-lower c2)))) + +(define (chyte-to-lower c) + (if (and (c . >= . (char->integer #\A)) (c . <= . (char->integer #\Z))) + (+ c (- (char->integer #\a) (char->integer #\A))) + c)) + +;; ---------------------------------------- +;; Lookahead, lookbehind, conditionals, and cut + +(define (lookahead-matcher match? sub-m n-start num-n next-m) + (lambda (s pos start limit end state stack) + (define old-state (save-groups state n-start num-n)) + (define pos2 (sub-m s pos start limit end state null)) + (cond + [match? + (and pos2 + (or (next-m s pos start limit end state stack) + (restore-groups state old-state n-start num-n)))] + [pos2 + (restore-groups state old-state n-start num-n)] + [else + (next-m s pos start limit end state stack)]))) + +(define (lookbehind-matcher match? lb-min lb-max sub-m n-start num-n next-m) + (lambda (s pos start limit end state stack) + (define lb-min-pos (max start (- pos lb-max))) + (let loop ([lb-pos (- pos lb-min)]) + (cond + [(lb-pos . < . lb-min-pos) + (if match? + #f + (next-m s pos start limit end state stack))] + [else + (define old-state (save-groups state n-start num-n)) + (define pos2 (sub-m s lb-pos start pos end state null)) + (cond + [match? + (if pos2 + (or (next-m s pos start limit end state stack) + (restore-groups state old-state n-start num-n)) + (loop (sub1 lb-pos)))] + [pos2 + (restore-groups state old-state n-start num-n)] + [else + (next-m s pos start limit end state stack)])])))) + +(define (conditional/reference-matcher n m1 m2) + (lambda (s pos start limit end state stack) + (if (vector-ref state n) + (m1 s pos start limit end state stack) + (m2 s pos start limit end state stack)))) + +(define (conditional/look-matcher tst-m m1 m2 n-start num-n) + (lambda (s pos start limit end state stack) + (define old-state (save-groups state n-start num-n)) + (or (if (tst-m s pos start limit end state null) + (m1 s pos start limit end state stack) + (m2 s pos start limit end state stack)) + (restore-groups state old-state n-start num-n)))) + +(define (cut-matcher sub-m n-start num-n next-m) + (lambda (s pos start limit end state stack) + (define old-state (save-groups state n-start num-n)) + (define pos2 (sub-m s pos start limit end state null)) + (and pos2 + (or (next-m s pos2 start limit end state stack) + (restore-groups state old-state n-start num-n))))) + + +(define (save-groups state n-start num-n) + (cond + [(zero? num-n) #f] + [(not state) #f] + [else + (define vec (make-vector num-n)) + (vector-copy! vec 0 state n-start (+ n-start num-n)) + vec])) + +(define (restore-groups state old-state n-start num-n) + (when old-state + (vector-copy! state n-start old-state)) + #f) + +;; ---------------------------------------- +;; Unicode characters in UTF-8 encoding + +(define (unicode-categories-matcher cats match? next-m) + (lambda (s pos start limit end state stack) + (let loop ([pos pos] [accum null]) + (define b + (if (bytes? s) + (and (pos . < . limit) + (bytes-ref s pos)) + (and (lazy-bytes-before-end? s pos limit) + (lazy-bytes-ref s pos)))) + (cond + [(not b) #f] + [else + (define c (bytes->char/utf-8 b accum)) + (cond + [(char? c) + (if (eq? match? + (let ([c-cat (char-general-category c)]) + (if (list? cats) + (for/or ([cat (in-list cats)]) + (eq? cat c-cat)) + (eq? cats c-cat)))) + (next-m s (add1 pos) start limit end state stack) + #f)] + [(eq? c 'fail) + #f] + [else + ;; c must be 'continue + (loop (add1 pos) (cons b accum))])])))) diff --git a/racket/src/regexp/match/port.rkt b/racket/src/regexp/match/port.rkt new file mode 100644 index 0000000000..3ee7dfbfe5 --- /dev/null +++ b/racket/src/regexp/match/port.rkt @@ -0,0 +1,99 @@ +#lang racket/base + +(provide copy-port-bytes + open-input-bytes/no-copy + open-input-string/lazy) + +;; Copy up to `n` bytes from `in` to `out`, where +;; #f for `n` means copy to end-of-file +(define (copy-port-bytes in out n) + (define bstr (make-bytes (min 4096 (or n 4096)))) + (define (copy got expect) + (cond + [(eof-object? got) #f] + [else + (when out + (write-bytes bstr out 0 got)) + (or (and (not n) + (positive? got)) + (and n + (= got expect)))])) + (let loop ([n n]) + (if (and n (n . < . 4096)) + (copy (read-bytes! bstr in 0 n) n) + (and (copy (read-bytes! bstr in) 4096) + (loop (and n (- n 4096))))))) + +;; Similar to `open-input-bytes`, but never copies the +;; argument, and more efficienyl handles a start and +;; end range +(define (open-input-bytes/no-copy bstr pos end) + (define (fill! dest-bstr skip) + (define pos+skip (+ pos skip)) + (cond + [(pos+skip . >= . end) eof] + [else + (define len (min (bytes-length dest-bstr) + (- end pos+skip))) + (bytes-copy! dest-bstr 0 bstr pos+skip (+ pos+skip len)) + len])) + (make-input-port + 'bytes + (lambda (dest-bstr) + (define len (fill! dest-bstr 0)) + (unless (eof-object? len) + (set! pos (+ len pos))) + len) + (lambda (dest-bstr skip evt) + (fill! dest-bstr skip)) + void)) + +;; Similar to `open-input-string`, but lazily decodes +;; a range of the string +(define (open-input-string/lazy str pos end) + (define bstr (make-bytes 64)) + (define bstr-pos 0) + (define bstr-end 0) + (define (fill! dest-bstr skip) + (define bstr-pos+skip (+ bstr-pos skip)) + (when (bstr-pos+skip . >= . bstr-end) + ;; Try to decode more + (decode-more! (add1 bstr-pos+skip))) + (cond + [(bstr-pos+skip . >= . bstr-end) eof] + [else + (define len (min (bytes-length dest-bstr) + (- bstr-end bstr-pos+skip))) + (bytes-copy! dest-bstr 0 bstr bstr-pos+skip (+ bstr-pos+skip len)) + len])) + (define (decode-more! target-pos) + (cond + [(= pos end) (void)] + [else + (define len (min 64 (- end pos))) + ;; We could use the decoder interface here to + ;; avoid byte-string allocations, but we expect + ;; that savings to be in the noise: + (define new-bstr + (string->bytes/utf-8 str 0 pos (+ pos len))) + (set! pos (+ len pos)) + (define new-len (bytes-length new-bstr)) + (when ((- (bytes-length bstr) bstr-end) . < . new-len) + (define bstr2 (make-bytes (max (* (bytes-length bstr) 2) + (+ bstr-end new-len)))) + (bytes-copy! bstr2 0 bstr 0 bstr-end) + (set! bstr bstr2)) + (bytes-copy! bstr bstr-end new-bstr) + (set! bstr-end (+ bstr-end new-len)) + (when (bstr-end . < . target-pos) + (decode-more! target-pos))])) + (make-input-port + 'string + (lambda (dest-bstr) + (define len (fill! dest-bstr 0)) + (unless (eof-object? len) + (set! bstr-pos (+ bstr-pos len))) + len) + (lambda (dest-bstr skip evt) + (fill! dest-bstr skip)) + void)) diff --git a/racket/src/regexp/match/regexp.rkt b/racket/src/regexp/match/regexp.rkt new file mode 100644 index 0000000000..5f91c6a7d5 --- /dev/null +++ b/racket/src/regexp/match/regexp.rkt @@ -0,0 +1,80 @@ +#lang racket/base +(require "../common/error.rkt" + "../parse/main.rkt" + "../analyze/validate.rkt" + "../analyze/convert.rkt" + "../analyze/anchor.rkt" + "../analyze/must-string.rkt" + "../analyze/start-range.rkt" + "compile.rkt") + +(provide (struct-out rx:regexp) + make-regexp + regexp? + byte-regexp? + pregexp? + byte-pregexp?) + +(struct rx:regexp (bytes? ; a bytes matcher (as opposed to string matcher)? + px? ; a pregexp (as opposed to pregexp)? + source ; original source string/bytes, but made immutable + matcher ; compiled matcher function; see "compile.rkt" + num-groups ; number of `(...)` groups for reporting submatches + references? ; any backreferences in the pattern? + max-lookbehind ; max lookbehnd + anchored? ; starts with `^`? + must-string ; shortcut: a byte string that must appear in a match + start-range) ; shortcut: a range that must match the initial byte + #:reflection-name 'regexp + #:property prop:custom-write (lambda (rx port mode) + (write-bytes (if (rx:regexp-px? rx) + #"#px" + #"#rx") + port) + (write (rx:regexp-source rx) port)) + #:property prop:object-name (struct-field-index source) + #:property prop:equal+hash (list + (lambda (a b eql?) + (equal? (rx:regexp-source a) (rx:regexp-source b))) + (lambda (a hc) + (hc (rx:regexp-source a))) + (lambda (a hc) + (hc (rx:regexp-source a))))) + +(define (make-regexp who orig-p px? as-bytes? handler) + (call-with-continuation-prompt + (lambda () + (define p (if (bytes? orig-p) + (bytes->immutable-bytes orig-p) + (string->immutable-string orig-p))) + (define-values (raw-rx num-groups references?) (parse p #:px? px?)) + (define rx (if as-bytes? raw-rx (convert raw-rx))) + (define max-lookbehind (validate rx num-groups)) + (define matcher (compile rx)) + (rx:regexp as-bytes? px? p + matcher num-groups references? max-lookbehind + (anchored? rx) (get-must-string rx) + (get-start-range rx))) + regexp-error-tag + (lambda (str) + (if handler + (handler str) + (raise-arguments-error who str "pattern" orig-p))))) + +(define (regexp? v) + (and (rx:regexp? v) + (not (rx:regexp-bytes? v)))) + +(define (byte-regexp? v) + (and (rx:regexp? v) + (rx:regexp-bytes? v))) + +(define (pregexp? v) + (and (rx:regexp? v) + (not (rx:regexp-bytes? v)) + (rx:regexp-px? v))) + +(define (byte-pregexp? v) + (and (rx:regexp? v) + (rx:regexp-bytes? v) + (rx:regexp-px? v))) diff --git a/racket/src/regexp/match/search.rkt b/racket/src/regexp/match/search.rkt new file mode 100644 index 0000000000..bc9c44330d --- /dev/null +++ b/racket/src/regexp/match/search.rkt @@ -0,0 +1,91 @@ +#lang racket/base +(require "../common/range.rkt" + "regexp.rkt" + "lazy-bytes.rkt" + "interp.rkt" + "../analyze/must-string.rkt") + +(provide search-match) + +;; ------------------------------------------------------------ +;; The driver iterates through the input (unless the pattern is +;; anchored) to find a match + +(define (search-match rx in pos start-pos end-pos state) + (define must-string (rx:regexp-must-string rx)) + (cond + [(not (check-must-string must-string in pos end-pos)) + (values #f #f)] + [else + (define matcher (rx:regexp-matcher rx)) + (define anchored? (rx:regexp-anchored? rx)) + (define start-range (rx:regexp-start-range rx)) + (let loop ([pos pos]) + (cond + [(and anchored? (not (= pos start-pos))) + (values #f #f)] + [(and start-range + (if (bytes? in) + (= pos end-pos) + (not (lazy-bytes-before-end? in pos end-pos)))) + (values #f #f)] + [(and start-range + (not (check-start-range start-range in pos end-pos))) + (loop (add1 pos))] + [else + (define pos2 (interp matcher in pos start-pos end-pos state)) + (cond + [pos2 (values pos pos2)] + [start-range (loop (add1 pos))] + [(if (bytes? in) + (pos . < . end-pos) + (lazy-bytes-before-end? in pos end-pos)) + (define pos2 (add1 pos)) + (unless (bytes? in) + (lazy-bytes-advance! in pos2 #f)) + (loop pos2)] + [else (values #f #f)])]))])) + +;; ------------------------------------------------------------------ +;; Checking for a must string (before iterating though the input) can +;; speed up a match failure by avoiding backtracking: + +(define (check-must-string must-string in pos end-pos) + (cond + [(not must-string) #t] + [(not (bytes? in)) #t] + [(bytes? must-string) + (cond + [(= 1 (bytes-length must-string)) + ;; Check for a single byte + (define mc (bytes-ref must-string 0)) + (for/or ([c (in-bytes in pos end-pos)]) + (= c mc))] + [else + ;; Check for a byte string + (define mc1 (bytes-ref must-string 0)) + (for/or ([i (in-range pos (- end-pos (sub1 (bytes-length must-string))))]) + (and (= mc1 (bytes-ref in i)) + (for/and ([c (in-bytes in (add1 i))] + [mc (in-bytes must-string 1)]) + (= c mc))))])] + [else + ;; Check against a sequence of ranges + (for/or ([i (in-range pos (- end-pos (sub1 (length must-string))))]) + (let loop ([i i] [l must-string]) + (cond + [(null? l) #t] + [else + (define e (car l)) + (and (rng-in? e (bytes-ref in i)) + (loop (add1 i) (cdr l)))])))])) + +;; ------------------------------------------------------------------ +;; Checking for a startup byte can speed up a match failure by +;; avoiding the general pattern checker: + +(define (check-start-range start-range in pos end-pos) + (rng-in? start-range + (if (bytes? in) + (bytes-ref in pos) + (lazy-bytes-ref in pos)))) diff --git a/racket/src/regexp/match/utf-8.rkt b/racket/src/regexp/match/utf-8.rkt new file mode 100644 index 0000000000..4f5b7c4177 --- /dev/null +++ b/racket/src/regexp/match/utf-8.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(provide bytes->char/utf-8) + +;; Given a byte and a list of accumulated bytes, +;; return a char, 'fail, or 'continue +(define (bytes->char/utf-8 last-b accum) + (cond + [(last-b . < . 128) + (cond + [(null? accum) (integer->char last-b)] + [else 'fail])] + [(continue-byte? last-b) + ;; A byte that continues + (cond + [(null? accum) 'fail] + [(two-byte-prefix? (car accum)) + (integer->char* + #x80 + (+ (arithmetic-shift (bitwise-and #b11111 (car accum)) 6) + (continue-value last-b)))] + [(three-byte-prefix? (car accum)) + 'continue] + [(four-byte-prefix? (car accum)) + 'continue] + [(and (pair? (cdr accum)) + (three-byte-prefix? (cadr accum))) + (integer->char* + #x800 + (+ (arithmetic-shift (bitwise-and #b1111 (cadr accum)) 12) + (arithmetic-shift (continue-value (car accum)) 6) + (continue-value last-b)))] + [(and (pair? (cdr accum)) + (four-byte-prefix? (cadr accum))) + 'continue] + [(and (pair? (cdr accum)) + (pair? (cddr accum)) + (four-byte-prefix? (caddr accum))) + (integer->char* + #x10000 + (+ (arithmetic-shift (bitwise-and #b1111 (caddr accum)) 18) + (arithmetic-shift (continue-value (cadr accum)) 12) + (arithmetic-shift (continue-value (car accum)) 6) + (continue-value last-b)))] + [else 'fail])] + [(and (or (two-byte-prefix? last-b) + (three-byte-prefix? last-b) + (four-byte-prefix? last-b)) + (null? accum)) + 'continue] + [else 'fail])) + +;; Guard against invalid encodings: +(define (integer->char* lower-bound n) + (if (or (n . < . lower-bound) + (n . > . #x10FFFF) + (and (n . >= . #xD800) + (n . <= . #xDFFF))) + 'fail + (integer->char n))) + +(define (continue-byte? b) + (= (bitwise-and b #b11000000) #b10000000)) +(define (continue-value b) + (bitwise-and b #b00111111)) + +(define (two-byte-prefix? b) + (= (bitwise-and b #b11100000) #b11000000)) +(define (three-byte-prefix? b) + (= (bitwise-and b #b11110000) #b11100000)) +(define (four-byte-prefix? b) + (= (bitwise-and b #b11111000) #b11110000)) diff --git a/racket/src/regexp/parse/ast.rkt b/racket/src/regexp/parse/ast.rkt new file mode 100644 index 0000000000..1b200dfc30 --- /dev/null +++ b/racket/src/regexp/parse/ast.rkt @@ -0,0 +1,156 @@ +#lang racket/base +(require "../common/range.rkt") + +(provide (all-defined-out)) + +(define rx:never 'never) +(define rx:empty 'empty) +(define rx:any 'any) +(define rx:start 'start) +(define rx:end 'end) +(define rx:line-start 'line-start) +(define rx:line-end 'line-end) +(define rx:word-boundary 'word-boundary) +(define rx:not-word-boundary 'not-word-boundary) + +;; exact integer : match single byte or char +;; byte string : match content sequence +;; string : match content sequence + +(struct rx:alts (rx1 rx2) #:transparent) +(struct rx:sequence (rxs needs-backtrack?) #:transparent) +(struct rx:group (rx number) #:transparent) +(struct rx:repeat (rx min max non-greedy?) #:transparent) +(struct rx:maybe (rx non-greedy?) #:transparent) ; special case in size validation +(struct rx:conditional (tst rx1 rx2 n-start num-n needs-backtrack?) #:transparent) +(struct rx:lookahead (rx match? n-start num-n) #:transparent) +(struct rx:lookbehind (rx match? [lb-min #:mutable] [lb-max #:mutable] ; min & max set by `validate` + n-start num-n) + #:transparent) +(struct rx:cut (rx n-start num-n needs-backtrack?) #:transparent) +(struct rx:reference (n case-sensitive?) #:transparent) +(struct rx:range (range) #:transparent) +(struct rx:unicode-categories (symlist match?) #:transparent) + +;; We need to backtrack for `rx` if it has alternatives; +;; we also count as backtracking anything complex enough +;; to match different numbers of elements in an immediate +;; repetition +(define (needs-backtrack? rx) + (cond + [(rx:alts? rx) #t] + [(rx:sequence? rx) (rx:sequence-needs-backtrack? rx)] + [(rx:group? rx) #t] ; to unwind success mappings + [(rx:repeat? rx) #t] + [(rx:maybe? rx) #t] + [(rx:conditional? rx) (rx:conditional-needs-backtrack? rx)] + [(rx:cut? rx) (rx:cut-needs-backtrack? rx)] ; doesn't actually backtrack, but count varies + [(rx:unicode-categories? rx) #t] + [else #f])) + +(define (rx-range range limit-c) + (cond + [(range-singleton range) => (lambda (c) c)] + [(range-includes? range 0 limit-c) rx:any] + [else (rx:range range)])) + +(define (rx-sequence l) + (cond + [(null? l) rx:empty] + [(null? (cdr l)) (car l)] + [else + (define merged-l (merge-adjacent l)) + (cond + [(null? (cdr merged-l)) (car merged-l)] + [else (rx:sequence merged-l (ormap needs-backtrack? merged-l))])])) + +(define (merge-adjacent l) + ;; `mode` tracks whether `accum` has byte or char strings, + ;; where a #f `mode` means that `accum` is empty + (let loop ([mode #f] [accum null] [l l]) + (cond + [(and (pair? l) + (rx:sequence? (car l))) + ;; Flatten nested sequences + (loop mode accum (append (rx:sequence-rxs (car l)) (cdr l)))] + [(and (pair? l) + (or (eq? rx:empty (car l)) + (equal? "" (car l)) + (equal? #"" (car l)))) + ;; Drop empty element + (loop mode accum (cdr l))] + [(or (null? l) + (not (case mode + [(byte) (or (byte? (car l)) + (bytes? (car l)))] + [(char) (or (integer? (car l)) + (string? (car l)))] + [else #t]))) + ;; Compatible subsequence ended + (cond + [(null? accum) + ;; Must be of `l`, with nothing in accumulator + null] + [(null? (cdr accum)) + ;; Subsequence is just one element after all + (cons (car accum) (loop #f null l))] + [else + ;; Combine elements in `accum` + (cons (case mode + [(byte) (apply bytes-append + (for/list ([a (in-list (reverse accum))]) + (cond + [(byte? a) (bytes a)] + [else a])))] + [(char) (apply string-append + (for/list ([a (in-list (reverse accum))]) + (cond + [(integer? a) (string (integer->char a))] + [else a])))] + [else (error "internal error")]) + (loop #f null l))])] + [mode + ;; Continue in same mode + (loop mode (cons (car l) accum) (cdr l))] + [(or (byte? (car l)) + (bytes? (car l))) + ;; Start byte mode + (loop 'byte (list (car l)) (cdr l))] + [(or (integer? (car l)) + (string? (car l))) + ;; Start character mode + (loop 'char (list (car l)) (cdr l))] + [else + ;; No combination possible + (cons (car l) (loop #f null (cdr l)))]))) + +(define (rx-alts rx1 rx2 limit-c) + (cond + [(eq? rx:never rx1) rx2] + [(eq? rx:never rx2) rx1] + [(and (rx:range? rx1) (rx:range? rx2)) + (rx-range (range-union (rx:range-range rx1) + (rx:range-range rx2)) + limit-c)] + [(and (rx:range? rx1) (rx:alts? rx2) (rx:range? (rx:alts-rx1 rx2))) + (rx-alts (rx-alts rx1 (rx:alts-rx1 rx2) limit-c) + (rx:alts-rx2 rx2) + limit-c)] + [(and (rx:range? rx1) (integer? rx2)) + (rx-range (range-add (rx:range-range rx1) rx2) limit-c)] + [(and (rx:range? rx2) (integer? rx1)) + (rx-alts rx2 rx1 limit-c)] + [(and (integer? rx1) (integer? rx2)) + (rx-range (range-add (range-add empty-range rx1) rx2) limit-c)] + [else + (rx:alts rx1 rx2)])) + +(define (rx-group rx n) + (rx:group rx n)) + +(define (rx-cut rx n-start num-n) + (rx:cut rx n-start num-n (needs-backtrack? rx))) + +(define (rx-conditional tst pces1 pces2 n-start num-n) + (rx:conditional tst pces1 pces2 n-start num-n (or (needs-backtrack? pces1) + (needs-backtrack? pces2)))) diff --git a/racket/src/regexp/parse/case.rkt b/racket/src/regexp/parse/case.rkt new file mode 100644 index 0000000000..82f9058b4c --- /dev/null +++ b/racket/src/regexp/parse/case.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require "../common/range.rkt" + "config.rkt") + +;; Add case-insensitive mappins as specified by `config` +(provide range-add* + range-add-span*) + +(define (range-add* range c config) + (cond + [(not c) range] + [else + (define range2 (range-add range c)) + (cond + [(parse-config-case-sensitive? config) range2] + [else + (define range3 (range-add range2 (char->integer (char-upcase (integer->char c))))) + (define range4 (range-add range3 (char->integer (char-foldcase (integer->char c))))) + (range-add range4 (char->integer (char-downcase (integer->char c))))])])) + +(define (range-add-span* range from-c to-c config) + (cond + [(parse-config-case-sensitive? config) + (range-add-span range from-c to-c)] + [else + (for/fold ([range range]) ([c (in-range from-c (add1 to-c))]) + (range-add* range c config))])) diff --git a/racket/src/regexp/parse/chyte-case.rkt b/racket/src/regexp/parse/chyte-case.rkt new file mode 100644 index 0000000000..d336394a37 --- /dev/null +++ b/racket/src/regexp/parse/chyte-case.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require "chyte.rkt") + +;; Dispatch on chytes with character patterns + +(provide chyte-case + chyte-case/eos) + +(define-syntax-rule (chyte-case c clause ...) + (case (integer->char c) + clause ...)) + +(define-syntax-rule (chyte-case/eos s-expr pos-expr clause ...) + (let ([pos pos-expr] + [s s-expr]) + (case (if (= pos (chytes-length s)) 'eos (chytes-ref/char s pos)) + clause ...))) diff --git a/racket/src/regexp/parse/chyte.rkt b/racket/src/regexp/parse/chyte.rkt new file mode 100644 index 0000000000..9d6570854e --- /dev/null +++ b/racket/src/regexp/parse/chyte.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require (for-syntax racket/base)) + +;; A "chytes" is a string or byte string, and a "chyte" +;; is represented as an integer. + +(provide chyte + chytes-length + chytes-ref + chytes-ref/char + chytes-limit) + +(define-syntax (chyte stx) + (syntax-case stx () + [(_ ch) + (char? (syntax-e #'ch)) + #`(quote #,(char->integer (syntax-e #'ch)))])) + +(define (chytes-length s) + (if (bytes? s) + (bytes-length s) + (string-length s))) + +(define (chytes-ref s i) + (if (bytes? s) + (bytes-ref s i) + (char->integer (string-ref s i)))) + +(define (chytes-ref/char s i) + (if (bytes? s) + (integer->char (bytes-ref s i)) + (string-ref s i))) + +(define (chytes-limit s) + (if (bytes? s) + 255 + #x10FFFF)) diff --git a/racket/src/regexp/parse/class.rkt b/racket/src/regexp/parse/class.rkt new file mode 100644 index 0000000000..2a7dfca04b --- /dev/null +++ b/racket/src/regexp/parse/class.rkt @@ -0,0 +1,122 @@ +#lang racket/base +(require "chyte.rkt" + "chyte-case.rkt" + "../common/range.rkt") + +(provide parse-class + parse-posix-char-class) + +;; returns (values success? range pos) +(define (parse-class s pos config) + ;; We know there's at least one character + (define (success v) (values #t v (add1 pos))) + (chyte-case + (chytes-ref s pos) + [(#\d) (success (range:d))] + [(#\D) (success (range-invert (range:d) (chytes-limit s)))] + [(#\w) (success (range:w))] + [(#\W) (success (range-invert (range:w) (chytes-limit s)))] + [(#\s) (success (range:s))] + [(#\S) (success (range-invert (range:s) (chytes-limit s)))] + [else (values #f #f #f)])) + +(define (range:d) + (range-add-span empty-range (chyte #\0) (chyte #\9))) + +(define (range:w) + (range-add + (range-add-span + (range-add-span + (range:d) + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z)) + (chyte #\_))) + +(define (range:s) + (let* ([r (range-add empty-range (chyte #\space))] + [r (range-add r (chyte #\tab))] + [r (range-add r (chyte #\newline))] + [r (range-add r (chyte #\page))] + [r (range-add r (chyte #\return))]) + r)) + +;; ---------------------------------------- + +;; Returns (values success? range position) +(define (parse-posix-char-class s pos) + (chyte-case/eos + s pos + [(#\:) + (define class + (let loop ([accum null] [pos (add1 pos)]) + (cond + [(= pos (chytes-length s)) #f] + [else + (define c (chytes-ref s pos)) + (cond + [(and (c . >= . (chyte #\a)) (c . <= . (chyte #\z))) + (loop (cons c accum) (add1 pos))] + [(and (= c (chyte #\:)) + ((add1 pos) . < . (chytes-length s)) + (= (chytes-ref s (add1 pos)) (chyte #\]))) + (list->bytes (reverse accum))] + [else #f])]))) + (define range + (case class + [(#"alpha") (range-add-span + (range-add-span + empty-range + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z))] + [(#"upper") (range-add-span + empty-range + (chyte #\A) (chyte #\Z))] + [(#"lower") (range-add-span + empty-range + (chyte #\a) (chyte #\z))] + [(#"digit") (range-add-span + empty-range + (chyte #\0) (chyte #\9))] + [(#"xdigit") (range-add-span + (range-add-span + (range-add-span + empty-range + (chyte #\0) (chyte #\9)) + (chyte #\a) (chyte #\f)) + (chyte #\A) (chyte #\F))] + [(#"alnum") (range-add-span + (range-add-span + (range-add-span + empty-range + (chyte #\0) (chyte #\9)) + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z))] + [(#"word") (range-add + (range-add-span + (range-add-span + empty-range + (chyte #\a) (chyte #\z)) + (chyte #\A) (chyte #\Z)) + (chyte #\_))] + [(#"blank") (range-add + (range-add empty-range (chyte #\space)) + (chyte #\tab))] + [(#"space") (range:s)] + [(#"graph" #"print") + (define range + (for/fold ([range empty-range]) ([i (in-range 0 128)]) + (if (char-graphic? (integer->char i)) + (range-add range i) + range))) + (if (equal? class #"print") + (range-add + (range-add range (chyte #\space)) + (chyte #\tab)) + range)] + [(#"cntrl") (range-add-span empty-range 0 31)] + [(#"ascii") (range-add-span empty-range 0 127)] + [else #f])) + (if range + (values #t range (+ pos 3 (bytes-length class))) + (values #f #f #f))] + [else (values #f #f #f)])) diff --git a/racket/src/regexp/parse/config.rkt b/racket/src/regexp/parse/config.rkt new file mode 100644 index 0000000000..1d234ea795 --- /dev/null +++ b/racket/src/regexp/parse/config.rkt @@ -0,0 +1,43 @@ +#lang racket/base + +(provide (struct-out parse-config) + make-parse-config + config-case-sensitive + config-multi-line + config-group-number + config-group-number+1) + +(struct parse-config (who + px? + case-sensitive? + multi-line? + group-number-box + references?-box + error-handler?)) + +(define (make-parse-config #:who [who 'regexp] + #:px? [px? #f] + #:error-handler? [error-handler? #f]) + (parse-config who + px? + #t ; case-sensitive? + #f ; multi-line? + (box 0) ; group-number-box + (box #f) ; references?-box + error-handler?)) + +(define (config-case-sensitive config cs?) + (struct-copy parse-config config + [case-sensitive? cs?])) + +(define (config-multi-line config mm?) + (struct-copy parse-config config + [multi-line? mm?])) + +(define (config-group-number config) + (unbox (parse-config-group-number-box config))) + +(define (config-group-number+1 config) + (define b (parse-config-group-number-box config)) + (set-box! b (add1 (unbox b))) + config) diff --git a/racket/src/regexp/parse/error.rkt b/racket/src/regexp/parse/error.rkt new file mode 100644 index 0000000000..7e9edb84f3 --- /dev/null +++ b/racket/src/regexp/parse/error.rkt @@ -0,0 +1,7 @@ +#lang racket/base +(require "../common/error.rkt") + +(provide parse-error) + +(define (parse-error s pos config fmt . args) + (apply regexp-error fmt args)) diff --git a/racket/src/regexp/parse/main.rkt b/racket/src/regexp/parse/main.rkt new file mode 100644 index 0000000000..3e8f122108 --- /dev/null +++ b/racket/src/regexp/parse/main.rkt @@ -0,0 +1,391 @@ +#lang racket/base +(require "chyte.rkt" + "chyte-case.rkt" + "ast.rkt" + "config.rkt" + "error.rkt" + "../common/range.rkt" + "class.rkt" + "unicode.rkt" + "range.rkt" + "case.rkt") + +(provide parse) + +(define (parse p #:px? [px? #f]) + (define config (make-parse-config #:px? px?)) + (define-values (rx pos) (parse-regexp p 0 config)) + (values rx + (config-group-number config) + (unbox (parse-config-references?-box config)))) + +;; Returns (values rx position) +(define (parse-regexp s pos config #:parse-regexp [parse-regexp (lambda (s pos config) + (parse-regexp s pos config))]) + (define-values (rxs pos2) (parse-pces s pos config)) + (chyte-case/eos + s pos2 + [(#\|) + (define-values (rx pos3) (parse-regexp s (add1 pos2) config)) + (values (rx-alts (rx-sequence rxs) rx (chytes-limit s)) pos3)] + [else + (values (rx-sequence rxs) pos2)])) + +(define (parse-regexp/maybe-empty s pos config) + (chyte-case/eos + s pos + [(#\)) + (values rx:empty pos)] + [else + (parse-regexp s pos config #:parse-regexp parse-regexp/maybe-empty)])) + +;; Returns (values list-of-rx position) +(define (parse-pces s pos config) + (cond + [(= pos (chytes-length s)) + (values null pos)] + [else + (define-values (rx pos2) (parse-pce s pos config)) + (chyte-case/eos + s pos2 + [(eos) + (values (list rx) pos2)] + [(#\| #\)) + (values (list rx) pos2)] + [else + (define-values (rxs pos3) (parse-pces s pos2 config)) + (values (cons rx rxs) pos3)])])) + +;; Returns (values rx position) +(define (parse-pce s pos config) + (define-values (rx pos2) (parse-atom s pos config)) + (chyte-case/eos + s pos2 + [(#\*) + (define-values (non-greedy? pos3) (parse-non-greedy s (add1 pos2) config)) + (values (rx:repeat rx 0 +inf.0 non-greedy?) pos3)] + [(#\+) + (define-values (non-greedy? pos3) (parse-non-greedy s (add1 pos2) config)) + (values (rx:repeat rx 1 +inf.0 non-greedy?) pos3)] + [(#\?) + (define-values (non-greedy? pos3) (parse-non-greedy s (add1 pos2) config)) + (values (rx:maybe rx non-greedy?) pos3)] + [(#\{) + (cond + [(parse-config-px? config) + (define-values (n1 pos3) (parse-integer 0 s (add1 pos2) config)) + (chyte-case/eos + s pos3 + [(#\,) + (define-values (n2 pos4) (parse-integer 0 s (add1 pos3) config)) + (chyte-case/eos + s pos4 + [(#\}) + (define n2* (if (= pos4 (add1 pos3)) +inf.0 n2)) + (define-values (non-greedy? pos5) (parse-non-greedy s (add1 pos4) config)) + (values (rx:repeat rx n1 n2* non-greedy?) pos5)] + [else + (parse-error s pos3 config "expected digit or `}` to end repetition specification started with `{`")])] + [(#\}) + (define-values (non-greedy? pos4) (parse-non-greedy s (add1 pos3) config)) + (values (rx:repeat rx n1 n1 non-greedy?) pos4)] + [else + (parse-error s pos3 config "expected digit, `,`, or `}' for repetition specification started with `{`")])] + [else + (values rx pos2)])] + [else + (values rx pos2)])) + +(define (parse-non-greedy s pos config) + (chyte-case/eos + s pos + [(#\?) + (values #t (check-not-nested s (add1 pos) config))] + [else + (values #f (check-not-nested s pos config))])) + +(define (check-not-nested s pos config) + (chyte-case/eos + s pos + [(#\? #\* #\+) + (parse-error s pos config + "nested `~a` in patten" + (integer->char (chytes-ref s pos)))] + [(#\{) + (when (parse-config-px? config) + (parse-error s pos config + "nested `{` in pattern"))]) + pos) + +;; Returns (values rx position) +(define (parse-atom s pos config) + ;; Assumes at least one character + (chyte-case + (chytes-ref s pos) + [(#\|) + (values rx:empty pos)] + [(#\() + (parse-parenthesized-atom s (add1 pos) config)] + [(#\[) + (define-values (range pos2) (parse-range/not s (add1 pos) config)) + (values (rx-range range (chytes-limit s)) pos2)] + [(#\.) + (define rx (if (parse-config-multi-line? config) + (rx-range (range-invert (range-add empty-range (chyte #\newline)) + (chytes-limit s)) + (chytes-limit s)) + rx:any)) + (values rx (add1 pos))] + [(#\^) + (values (if (parse-config-multi-line? config) rx:line-start rx:start) + (add1 pos))] + [(#\$) + (values (if (parse-config-multi-line? config) rx:line-end rx:end) + (add1 pos))] + [else + ;; Literal or (for px mode) `\` character class + (parse-literal s pos config)])) + +;; Returns (values rx position) +(define (parse-parenthesized-atom s pos config) + (chyte-case/eos + s pos + [(eos) + (missing-closing-error s pos config)] + [(#\?) + (define pos2 (add1 pos)) + (chyte-case/eos + s pos2 + [(eos) + (bad-?-sequence-error s pos2 config)] + [(#\>) + (define pre-num-groups (config-group-number config)) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2) config)) + (define post-num-groups (config-group-number config)) + (values (rx-cut rx pre-num-groups (- post-num-groups pre-num-groups)) + (check-close-paren s pos3 config))] + [(#\() + (parse-conditional s (add1 pos2) config)] + [(#\i #\s #\m #\- #\:) + (define-values (config2 pos3) (parse-mode s pos2 config)) + (chyte-case/eos + s pos3 + [(#\:) + (define-values (rx pos4) (parse-regexp/maybe-empty s (add1 pos3) config2)) + (values rx (check-close-paren s pos4 config2))] + [else + (parse-error s pos3 config2 (string-append + "expected `:` or another mode after `(?` and a mode sequence;\n" + " a mode is `i`, `-i`, `m`, `-m`, `s`, or `-s`"))])] + [else + (parse-look s pos2 config)])] + [else + (define group-number (config-group-number config)) + (define-values (rx pos2) (parse-regexp/maybe-empty s pos (config-group-number+1 config))) + (values (rx-group rx group-number) + (check-close-paren s pos2 config))])) + +;; Returns (values rx position) +(define (parse-look s pos2 config) + ;; known that one character is available + (define pre-num-groups (config-group-number config)) + (define (span-num-groups) (- (config-group-number config) pre-num-groups)) + (chyte-case + (chytes-ref s pos2) + [(#\=) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2) config)) + (values (rx:lookahead rx #t pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [(#\!) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2) config)) + (values (rx:lookahead rx #f pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [(#\<) + (define pos2+ (add1 pos2)) + (chyte-case/eos + s pos2+ + [(eos) + (bad-?-sequence-error s pos2+ config)] + [(#\=) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2+) config)) + (values (rx:lookbehind rx #t 0 0 pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [(#\!) + (define-values (rx pos3) (parse-regexp/maybe-empty s (add1 pos2+) config)) + (values (rx:lookbehind rx #f 0 0 pre-num-groups (span-num-groups)) + (check-close-paren s pos3 config))] + [else + (bad-?-sequence-error s pos2+ config)])] + [else + (bad-?-sequence-error s pos2 config)])) + +;; Returns (values rx position) +(define (parse-conditional s pos config) + (define tst-pre-num-groups (config-group-number config)) + (define-values (tst pos2) (parse-test s pos config)) + (define tst-span-num-groups (- (config-group-number config) tst-pre-num-groups)) + (define-values (pces pos3) (parse-pces s pos2 config)) + (chyte-case/eos + s pos3 + [(eos) + (missing-closing-error s pos3 config)] + [(#\|) + (define-values (pces2 pos4) (parse-pces s (add1 pos3) config)) + (chyte-case/eos + s pos4 + [(eos) + (missing-closing-error s pos4 config)] + [(#\)) + (values (rx-conditional tst (rx-sequence pces) (rx-sequence pces2) + tst-pre-num-groups tst-span-num-groups) + (add1 pos4))] + [else + (parse-error s pos4 config "expected `)` to close `(?(...)...` after second branch")])] + [(#\)) + (values (rx-conditional tst (rx-sequence pces) rx:empty + tst-pre-num-groups tst-span-num-groups) + (add1 pos3))])) + +;; Returns (values rx position) +(define (parse-test s pos config) + (chyte-case/eos + s pos + [(eos) + (missing-closing-error s pos config)] + [(#\?) + (parse-look s (add1 pos) config)] + [else + (define c (chytes-ref s pos)) + (cond + [(and (>= c (chyte #\0)) (<= c (chyte #\9))) + (set-box! (parse-config-references?-box config) #t) + (define-values (n pos3) (parse-integer 0 s pos config)) + (unless (and (pos3 . < . (chytes-length s)) + (= (chytes-ref s pos3) (chyte #\)))) + (parse-error s pos3 config "expected `)` after `(?(` followed by digits")) + (values (rx:reference n #f) (add1 pos3))] + [else + (parse-error s pos config "expected `(?=`, `(?!`, `(?<`, or digit after `(?(`")])])) + +;; Returns (values n position) +(define (parse-integer n s pos config) + (cond + [(= pos (chytes-length s)) + (values n pos)] + [else + (define c (chytes-ref s pos)) + (cond + [(and (>= c (chyte #\0)) (<= c (chyte #\9))) + (define n2 (+ (* n 10) (- c (chyte #\0)))) + (parse-integer n2 s (add1 pos) config)] + [else + (values n pos)])])) + +;; Returns (values rx position) +(define (parse-literal s pos config) + ;; Assumes at least one character; + ;; we don't get here for `(`, `[`, `.`, `^`, `$`, or `|` + (define c (chytes-ref s pos)) + (chyte-case + c + [(#\* #\+ #\?) + (parse-error s pos config "`~a` follows nothing in pattern" (integer->char c))] + [(#\{) + (cond + [(parse-config-px? config) + (parse-error s pos config "`{` follows nothing in pattern")] + [else (values c (add1 pos))])] + [(#\\) + ;; escaped character + (parse-backslash-literal s (add1 pos) config)] + [(#\)) + (parse-error s pos config "unmatched `)` in pattern")] + [(#\] #\}) + (cond + [(parse-config-px? config) + (parse-error s pos config "unmatched `~a` in pattern" (integer->char c))] + [else (values c (add1 pos))])] + [else + (cond + [(parse-config-case-sensitive? config) + (values c (add1 pos))] + [else + ;; case-insensitive char match + (values (rx-range (range-add* empty-range c config) (chytes-limit s)) + (add1 pos))])])) + +(define (parse-backslash-literal s pos2 config) + (cond + [(= pos2 (chytes-length s)) + ;; An "expected character after `\`" error would make more sense, + ;; but the old expander produced a match against the nul character + (values (chyte #\u0) pos2)] + [else + (define c2 (chytes-ref s pos2)) + (cond + [(and (parse-config-px? config) + (and (>= c2 (chyte #\0)) (<= c2 (chyte #\9)))) + (set-box! (parse-config-references?-box config) #t) + (define-values (n pos3) (parse-integer 0 s pos2 config)) + (values (rx:reference n (parse-config-case-sensitive? config)) pos3)] + [(and (parse-config-px? config) + (or (and (>= c2 (chyte #\a)) (<= c2 (chyte #\z))) + (and (>= c2 (chyte #\A)) (<= c2 (chyte #\Z))))) + (chyte-case + c2 + [(#\p #\P) + (parse-unicode-categories c2 s (add1 pos2) config)] + [(#\b) + (values rx:word-boundary (add1 pos2))] + [(#\B) + (values rx:not-word-boundary (add1 pos2))] + [else + (define-values (success? range pos3) (parse-class s pos2 config)) + (if success? + (values (rx-range range (chytes-limit s)) pos3) + (parse-error s pos2 config "illegal alphabetic escape"))])] + [else + (values c2 (add1 pos2))])])) + +;; Returns (values config position) +(define (parse-mode s pos config) + (chyte-case/eos + s pos + [(eos) + (values config pos)] + [(#\i) + (parse-mode s (add1 pos) (config-case-sensitive config #f))] + [(#\s) + (parse-mode s (add1 pos) (config-multi-line config #f))] + [(#\m) + (parse-mode s (add1 pos) (config-multi-line config #t))] + [(#\-) + (define pos2 (add1 pos)) + (chyte-case/eos + s pos2 + [(eos) + (values config pos)] + [(#\i) + (parse-mode s (add1 pos2) (config-case-sensitive config #t))] + [(#\s) + (parse-mode s (add1 pos2) (config-multi-line config #t))] + [(#\m) + (parse-mode s (add1 pos2) (config-multi-line config #f))] + [else + (values config pos)])] + [else + (values config pos)])) + + +(define (check-close-paren s pos config) + (unless (and (pos . < . (chytes-length s)) + (= (chyte #\)) (chytes-ref s pos))) + (parse-error s pos config "expected a closing `)`")) + (add1 pos)) + +(define (missing-closing-error s pos config) + (parse-error s pos config "missing closing parenthesis in pattern")) + +(define (bad-?-sequence-error s pos config) + (parse-error s pos config + "expected `:`, `=`, `!`, `<=`, `= . (chyte #\a)) (c . <= . (chyte #\z))) + (and (c . >= . (chyte #\A)) (c . <= . (chyte #\Z)))) + (cond + [must-span-from + (parse-error s pos config "misplaced hyphen within square brackets in pattern")] + [else + (define-values (success? range1 pos3) (parse-class s pos2 config)) + (unless success? + (parse-error s pos3 config "illegal alphabetic escape")) + (define range2 (range-union range1 (range-add* range span-from config))) + (parse-range-rest range2 s (add1 pos2) config)])] + [else + (parse-range-rest/span c range s (add1 pos2) config + #:span-from span-from + #:must-span-from must-span-from)])])] + [else + (parse-range-rest/span (chyte #\\) range s (add1 pos) config + #:span-from span-from + #:must-span-from must-span-from)])] + [(#\[) + (define-values (success? range1 pos2) + (cond + [(and (parse-config-px? config) + (not must-span-from)) + (parse-posix-char-class s (add1 pos))] + [else + (values #f #f #f)])) + (cond + [success? + (define range2 (range-union range1 (range-add* range span-from config))) + (parse-range-rest range2 s pos2 config)] + [else + (parse-range-rest/span (chyte #\[) range s (add1 pos) config + #:span-from span-from + #:must-span-from must-span-from)])] + [else + (parse-range-rest/span (chytes-ref s pos) range s (add1 pos) config + #:span-from span-from + #:must-span-from must-span-from)])) + +(define (parse-range-rest/span c range s pos config + #:span-from span-from + #:must-span-from must-span-from) + (cond + [must-span-from + (cond + [(must-span-from . > . c) + (parse-error s pos config "invalid range within square brackets in pattern")] + [else + (parse-range-rest (range-add-span* range must-span-from c config) s pos config)])] + [else + (parse-range-rest (range-add* range span-from config) s pos config + #:span-from c)])) + +(define (missing-square-closing-error s pos config) + (parse-error s pos config "missing closing square bracket in pattern")) + +(define (misplaced-hyphen-error s pos config) + (parse-error s pos config "misplaced hyphen within square brackets in pattern")) diff --git a/racket/src/regexp/parse/unicode.rkt b/racket/src/regexp/parse/unicode.rkt new file mode 100644 index 0000000000..9ad2d6354c --- /dev/null +++ b/racket/src/regexp/parse/unicode.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require "chyte.rkt" + "chyte-case.rkt" + "ast.rkt" + "config.rkt" + "error.rkt") + +(provide parse-unicode-categories) + +(define (parse-unicode-categories p-c s pos config) + (chyte-case/eos + s pos + [(#\{) + (define-values (l pos2) + (let loop ([accum null] [pos (add1 pos)]) + (chyte-case/eos + s pos + [(eos) + (parse-error s pos config + "missing `}` to close `\\~a{`" + (integer->char p-c))] + [(#\}) (values (reverse accum) (add1 pos))] + [else + (loop (cons (chytes-ref s pos) accum) (add1 pos))]))) + (define categories + (case (list->bytes l) + [(#"Ll") 'll] + [(#"Lu") 'lu] + [(#"Lt") 'lt] + [(#"Lm") 'lm] + [(#"L&") '(ll lu lt lm)] + [(#"Lo") 'lo] + [(#"L") '(ll lu lt lm lo)] + [(#"Nd") 'nd] + [(#"Nl") 'nl] + [(#"No") 'no] + [(#"N") '(nd nl no)] + [(#"Ps") 'ps] + [(#"Pe") 'pe] + [(#"Pi") 'pi] + [(#"Pf") 'pf] + [(#"Pc") 'pc] + [(#"Pd") 'pd] + [(#"Po") 'po] + [(#"P") '(ps pe pi pf pc pd po)] + [(#"Mn") 'mn] + [(#"Mc") 'mc] + [(#"Me") 'me] + [(#"M") '(mn mc me)] + [(#"Sc") 'sc] + [(#"Sk") 'sk] + [(#"Sm") 'sm] + [(#"So") 'so] + [(#"S") '(sc sk sm so)] + [(#"Zl") 'zl] + [(#"Zp") 'zp] + [(#"Zs") 'zs] + [(#"Z") '(zl zp zs)] + [(#"Cc") 'cc] + [(#"Cf") 'cf] + [(#"Cs") 'cs] + [(#"Cn") 'cn] + [(#"Co") 'co] + [(#"C") '(cc cf cs cn so)] + [(#".") #t] + [else (parse-error s pos2 config + "unrecognized property name in `\\~a{}`: `~a`" + (integer->char p-c) + (list->string (map integer->char l)))])) + (values (rx:unicode-categories categories (= p-c (char->integer #\p))) + pos2)] + [else + (parse-error s pos config + "expected `{` after `\\~a`" + (integer->char p-c))])) diff --git a/racket/src/regexp/replace/chyte.rkt b/racket/src/regexp/replace/chyte.rkt new file mode 100644 index 0000000000..a5001b87b0 --- /dev/null +++ b/racket/src/regexp/replace/chyte.rkt @@ -0,0 +1,42 @@ +#lang racket/base + +(provide chytes-ref + subchytes + chytes-append + chytes? + chytes-length) + +(define (chytes-ref s pos) + (if (bytes? s) + (bytes-ref s pos) + (char->integer (string-ref s pos)))) + +(define (subchytes s a [b #f]) + (if (bytes? s) + (subbytes s a (or b (bytes-length s))) + (substring s a (or b (string-length s))))) + +(define chytes-append + (case-lambda + [(a) a] + [(a b) (if (bytes? a) + (bytes-append a b) + (string-append a b))] + [(a b c) (if (bytes? a) + (bytes-append a b c) + (string-append a b c))] + [(a . l) (if (bytes? a) + (apply bytes-append a l) + (apply string-append a l))])) + +(define (chytes? ex v) + (if (bytes? ex) + (bytes? v) + (string? v))) + +(define (chytes-length s) + (if (bytes? s) + (bytes-length s) + (string-length s))) + + diff --git a/racket/src/regexp/replace/main.rkt b/racket/src/regexp/replace/main.rkt new file mode 100644 index 0000000000..7cb91de523 --- /dev/null +++ b/racket/src/regexp/replace/main.rkt @@ -0,0 +1,140 @@ +#lang racket/base +(require "../match/regexp.rkt" + "../match/main.rkt" + "chyte.rkt") + +(provide regexp-replace + regexp-replace*) + +(define (regexp-replace rx orig-in insert [prefix #""]) + (do-regexp-replace 'regexp-replace rx orig-in insert prefix #f)) + +(define (regexp-replace* rx orig-in insert [prefix #""]) + (do-regexp-replace 'regexp-replace* rx orig-in insert prefix #t)) + +(define (do-regexp-replace who rx-in orig-in insert prefix all?) + (define string-mode? + (and (or (string? rx-in) (regexp? rx-in)) + (string? orig-in))) + (define in (if (and (not string-mode?) + (string? orig-in)) + (string->bytes/utf-8 orig-in) + orig-in)) + + (when (or string-mode? + (and (or (bytes? rx-in) (byte-regexp? rx-in)) + (or (string? orig-in) (bytes? orig-in)))) + (unless (or (string? insert) + (bytes? insert) + (procedure? insert)) + (raise-argument-error who "(or/c string? bytes? procedure?)" insert))) + + (when string-mode? + (when (bytes? insert) + (raise-arguments-error who + "cannot replace a string with a byte string" + "byte string" insert))) + + (define rx (cond + [(string? rx-in) (make-regexp who rx-in #f #f #f)] + [(bytes? rx-in) (make-regexp who rx-in #f #t #f)] + [else rx-in])) + + (define ins (if (and (not string-mode?) + (string? insert)) + (string->bytes/utf-8 insert) + insert)) + + (let loop ([search-pos 0]) + (define poss + (drive-regexp-match who rx in 0 #:search-offset search-pos #f #f prefix + #:in-port-ok? #f + #:in-path-ok? #f + #:mode 'positions)) + + (define (recur) + (define pos (cdar poss)) + (cond + [(= pos search-pos) + (if (= search-pos (chytes-length in)) + (subchytes in 0 0) + (chytes-append (subchytes in search-pos (add1 search-pos)) + (loop (add1 search-pos))))] + [else (loop (cdar poss))])) + + (cond + [(not poss) (cond + [(zero? search-pos) in] + [else (subchytes in search-pos)])] + [else + (chytes-append (subchytes in search-pos (caar poss)) + (replacements who in poss ins) + (if all? + (recur) + (subchytes in (cdar poss))))]))) + +;; ---------------------------------------- + +(define (replacements who in poss insert) + (cond + [(procedure? insert) + (define a (apply insert + (for/list ([pos (in-list poss)]) + (subchytes in (car pos) (cdr pos))))) + (unless (chytes? in a) + (raise-result-error who (if (bytes? in) "bytes?" "string?") a)) + a] + + [else + (define count (length poss)) + + (define (get-chytes n) + (cond + [(n . < . count) + (define pos (list-ref poss n)) + (subchytes in (car pos) (cdr pos))] + [else (subchytes in 0 0)])) + + (define (cons-chytes since pos l) + (if (= since pos) + l + (cons (subchytes insert since pos) l))) + + (define len (chytes-length insert)) + (apply (if (bytes? insert) + bytes-append + string-append) + (let loop ([pos 0] [since 0]) + (cond + [(= pos len) + (cons-chytes since pos null)] + [(= (char->integer #\&) (chytes-ref insert pos)) + (cons-chytes since pos + (cons (get-chytes 0) + (loop (add1 pos) (add1 pos))))] + [(= (char->integer #\\) (chytes-ref insert pos)) + (cons-chytes + since pos + (let ([c (and ((add1 pos) . < . len) + (chytes-ref insert (add1 pos)))]) + (cond + [(or (eq? c (char->integer #\&)) + (eq? c (char->integer #\\))) + (loop (+ pos 2) (add1 pos))] + [(eq? c (char->integer #\$)) + (loop (+ pos 2) (+ pos 2))] + [else + (let d-loop ([pos (add1 pos)] [accum 0]) + (cond + [(= pos len) + (list (get-chytes accum))] + [else + (define c (chytes-ref insert pos)) + (if (and (>= c (char->integer #\0)) + (<= c (char->integer #\9))) + (d-loop (add1 pos) (+ (* accum 10) + (- c (char->integer #\0)))) + (cons (get-chytes accum) + (loop pos pos)))]))])))] + [else + (loop (add1 pos) since)])))])) diff --git a/racket/src/rktio/Makefile.in b/racket/src/rktio/Makefile.in index 53ee91789a..b17becca96 100644 --- a/racket/src/rktio/Makefile.in +++ b/racket/src/rktio/Makefile.in @@ -136,6 +136,24 @@ clean: # ---------------------------------------- +# To rebuild the S-expression form of "rktio.h" + +rktio-rktl rktio-inc rktio-def: + $(MAKE) $(srcdir)/rktio.rktl + $(MAKE) $(srcdir)/rktio.inc + $(MAKE) $(srcdir)/rktio.def + +$(srcdir)/rktio.rktl: $(srcdir)/rktio.h $(srcdir)/parse.rkt + $(RACKET) $(srcdir)/parse.rkt -o $(srcdir)/rktio.rktl $(srcdir)/rktio.h + +$(srcdir)/rktio.inc: $(srcdir)/rktio.h $(srcdir)/parse.rkt + $(RACKET) $(srcdir)/parse.rkt -c -o $(srcdir)/rktio.inc $(srcdir)/rktio.h + +$(srcdir)/rktio.def: $(srcdir)/rktio.h $(srcdir)/parse.rkt + $(RACKET) $(srcdir)/parse.rkt -d -o $(srcdir)/rktio.def $(srcdir)/rktio.h + +# ---------------------------------------- + @HIDE_NOT_STANDALONE@librktio: $(MAKE) librktio.@LIBSFX@ @@ -148,7 +166,3 @@ install-shared-object: $(MAKE) librktio.@LIBSFX@ mkdir -p "$(DESTDIR)$(libdir)/" $(ICP_LIB) librktio.@LIBSFX@ "$(DESTDIR)$(libdir)/librktio.@LIBSFX@" - -# Builds an S-expression form of "rktio.h" -rktio.rktl: $(srcdir)/rktio.h $(srcdir)/parse.rkt - $(RACKET) $(srcdir)/parse.rkt -o rktio.rktl $(srcdir)/rktio.h diff --git a/racket/src/rktio/parse.rkt b/racket/src/rktio/parse.rkt index 38911e24f2..a322bdc3ec 100644 --- a/racket/src/rktio/parse.rkt +++ b/racket/src/rktio/parse.rkt @@ -28,12 +28,18 @@ ;; | (*ref ) ; transparent argument, can be represented by a byte string (define output-file #f) +(define c-mode? #f) +(define .def-mode? #f) (define input-file (command-line #:once-each [("-o") file "Write output to " (set! output-file file)] + [("-c") "Generate foreign-symbol registration" + (set! c-mode? #t)] + [("-d") "Generate .def file" + (set! .def-mode? #t)] #:args (file) file)) @@ -46,7 +52,7 @@ OPEN CLOSE COPEN CCLOSE SEMI COMMA STAR LSHIFT EQUAL __RKTIO_H__ EXTERN EXTERN/NOERR EXTERN/STEP EXTERN/ERR DEFINE TYPEDEF ENUM STRUCT VOID UNSIGNED SHORT INT - CONST NULLABLE)) + CONST NULLABLE BLOCKING)) (define lex (lexer-src-pos @@ -75,6 +81,7 @@ ["RKTIO_EXTERN_STEP" 'EXTERN/STEP] ["RKTIO_EXTERN_ERR" 'EXTERN/ERR] ["RKTIO_NULLABLE" 'NULLABLE] + ["RKTIO_BLOCKING" 'BLOCKING] [(:seq (:or #\_ (:/ #\A #\Z #\a #\z)) (:* (:or #\_ (:/ #\A #\Z #\a #\z #\0 #\9)))) (token-ID (string->symbol lexeme))] @@ -109,6 +116,7 @@ [(DEFINE EXTERN/STEP EXTERN) #f] [(DEFINE EXTERN/ERR OPEN ID CLOSE EXTERN) #f] [(DEFINE NULLABLE) #f] + [(DEFINE BLOCKING) #f] [(STRUCT ID SEMI) #f] [(TYPEDEF SEMI) (if (eq? $2 $3) @@ -118,15 +126,17 @@ (if (eq? $2 $5) `(define-struct-type ,$2 ,$4) (error 'parse "typedef struct names don't match at ~s" $5))] - [( OPEN SEMI) - (let ([r-type (shift-stars $3 $2)] - [id (unstar $3)]) - `(,@(adjust-errno $1 r-type id) ,r-type ,id ,$5))] + [( OPEN SEMI) + (let ([r-type (shift-stars $4 $3)] + [id (unstar $4)]) + `(,@(adjust-errno $1 r-type id) ,$2 ,r-type ,id ,$6))] [(ENUM COPEN SEMI) `(begin . ,(enum-definitions $3))]) ( [(EXTERN) 'define-function/errno] [(EXTERN/STEP) 'define-function/errno+step] [(EXTERN/NOERR) 'define-function] [(EXTERN/ERR OPEN ID CLOSE) `(define-function/errno ,$3)]) + ( [(BLOCKING) '(blocking)] + [() '()]) ( [(VOID CLOSE) null] [() $1]) ( [( CLOSE) `((,(shift-stars $2 $1) ,(unstar $2)))] @@ -264,11 +274,11 @@ (define (update-types e) (match e - [`(,def ,ret ,name ,args) - `(,def ,(update-type ret) ,name + [`(,def ,flags ,ret ,name ,args) + `(,def ,flags ,(update-type ret) ,name ,(map (lambda (a) (update-bind a #:as-argument? #t)) args))] - [`(,def ,err-val ,ret ,name ,args) - `(,def ,err-val ,(update-type ret) ,name + [`(,def ,err-val ,flags ,ret ,name ,args) + `(,def ,err-val ,flags ,(update-type ret) ,name ,(map (lambda (a) (update-bind a #:as-argument? #t)) args))] [else e])) @@ -286,16 +296,41 @@ (filter (lambda (e) (not (or (constant-defn? e) (type-defn? e)))) unsorted-content)))) +(define (function-definition? e) + (and (pair? e) + (or (eq? 'define-function (car e)) + (eq? 'define-function/errno (car e)) + (eq? 'define-function/errno+step (car e))))) + (define (show-content) - (printf "(begin\n") - (for ([e (in-list content)] - #:when e) - (pretty-write e)) - (printf ")\n")) + (cond + [c-mode? + (for ([e (in-list content)] + #:when (function-definition? e)) + (define n (list-ref e (- (length e) 2))) + (printf "Sforeign_symbol(~s, (void *)~a);\n" (symbol->string n) n))] + [.def-mode? + (for ([e (in-list content)] + #:when (function-definition? e)) + (define n (list-ref e (- (length e) 2))) + (printf "~a\n" n))] + [else + (printf "(begin\n") + (for ([e (in-list content)] + #:when e) + (pretty-write e)) + (printf ")\n")])) (if output-file (with-output-to-file output-file #:exists 'truncate - (lambda () (show-content))) + (lambda () + (cond + [c-mode? + (printf "/* Extracted from rktio.h by rktio/parse.rkt */\n")] + [.def-mode? + (printf "EXPORTS\n")] + [else + (printf ";; Extracted from rktio.h by rktio/parse.rkt\n")]) + (show-content))) (show-content)) - diff --git a/racket/src/rktio/rktio.def b/racket/src/rktio/rktio.def new file mode 100644 index 0000000000..ed1ae4ff47 --- /dev/null +++ b/racket/src/rktio/rktio.def @@ -0,0 +1,192 @@ +EXPORTS +rktio_init +rktio_destroy +rktio_free +rktio_set_dll_path +rktio_get_dll_path +rktio_system_fd +rktio_fd_system_fd +rktio_fd_is_regular_file +rktio_fd_is_directory +rktio_fd_is_socket +rktio_fd_is_udp +rktio_fd_is_terminal +rktio_fd_is_text_converted +rktio_fd_modes +rktio_open +rktio_close +rktio_close_noerr +rktio_dup +rktio_forget +rktio_std_fd +rktio_read +rktio_write +rktio_read_converted +rktio_read_in +rktio_write_in +rktio_buffered_byte_count +rktio_poll_read_ready +rktio_poll_write_ready +rktio_poll_write_flushed +rktio_file_lock_try +rktio_file_unlock +rktio_set_file_position +rktio_get_file_position +rktio_set_file_size +rktio_make_pipe +rktio_start_addrinfo_lookup +rktio_get_ipv4_family +rktio_poll_addrinfo_lookup_ready +rktio_addrinfo_lookup_get +rktio_addrinfo_lookup_stop +rktio_addrinfo_free +rktio_listen +rktio_listen_stop +rktio_poll_accept_ready +rktio_accept +rktio_start_connect +rktio_connect_finish +rktio_connect_stop +rktio_poll_connect_ready +rktio_connect_trying +rktio_socket_shutdown +rktio_udp_open +rktio_udp_disconnect +rktio_udp_bind +rktio_udp_connect +rktio_udp_sendto +rktio_udp_sendto_in +rktio_udp_recvfrom +rktio_udp_recvfrom_in +rktio_udp_get_multicast_loopback +rktio_udp_set_multicast_loopback +rktio_udp_get_multicast_ttl +rktio_udp_set_multicast_ttl +rktio_udp_multicast_interface +rktio_udp_set_multicast_interface +rktio_udp_change_multicast_group +rktio_socket_address +rktio_socket_peer_address +rktio_listener_address +rktio_is_ok_envvar_name +rktio_are_envvar_names_case_insensitive +rktio_getenv +rktio_setenv +rktio_envvars +rktio_empty_envvars +rktio_envvars_copy +rktio_envvars_free +rktio_envvars_get +rktio_envvars_set +rktio_envvars_count +rktio_envvars_name_ref +rktio_envvars_value_ref +rktio_process +rktio_process_allowed_flags +rktio_process_pid +rktio_process_kill +rktio_process_interrupt +rktio_process_forget +rktio_poll_process_done +rktio_process_status +rktio_reap_processes +rktio_fs_change_properties +rktio_fs_change +rktio_fs_change_forget +rktio_poll_fs_change_ready +rktio_make_poll_set +rktio_poll_set_forget +rktio_poll_add +rktio_poll_add_accept +rktio_poll_add_connect +rktio_poll_add_addrinfo_lookup +rktio_poll_add_process +rktio_poll_add_fs_change +rktio_poll_set_add_nosleep +rktio_poll_set_add_handle +rktio_poll_set_add_eventmask +rkio_reset_sleep_backoff +rktio_ltps_open +rktio_ltps_close +rktio_ltps_add +rktio_ltps_handle_set_data +rktio_ltps_handle_get_data +rktio_ltps_remove_all +rktio_ltps_poll +rktio_ltps_get_signaled_handle +rktio_ltps_handle_set_auto +rktio_sleep +rktio_start_sleep +rktio_end_sleep +rktio_file_exists +rktio_directory_exists +rktio_link_exists +rktio_is_regular_file +rktio_delete_file +rktio_rename_file +rktio_get_current_directory +rktio_set_current_directory +rktio_make_directory +rktio_delete_directory +rktio_readlink +rktio_make_link +rktio_file_size +rktio_get_file_modify_seconds +rktio_set_file_modify_seconds +rktio_fd_identity +rktio_path_identity +rktio_get_file_or_directory_permissions +rktio_set_file_or_directory_permissions +rktio_directory_list_start +rktio_directory_list_step +rktio_directory_list_stop +rktio_filesystem_roots +rktio_copy_file_start +rktio_copy_file_is_done +rktio_copy_file_step +rktio_copy_file_finish_permissions +rktio_copy_file_stop +rktio_system_path +rktio_expand_user_tilde +rktio_get_signal_handle +rktio_signal_received_at +rktio_signal_received +rktio_wait_until_signal_received +rktio_flush_signals_received +rktio_install_os_signal_handler +rktio_poll_os_signal +rktio_get_milliseconds +rktio_get_inexact_milliseconds +rktio_get_process_milliseconds +rktio_get_process_children_milliseconds +rktio_get_seconds +rktio_seconds_to_date +rktio_shell_execute +rktio_path_to_wide_path +rktio_wide_path_to_path +rktio_syslog +rktio_convert_properties +rktio_converter_open +rktio_converter_close +rktio_convert +rktio_convert_in +rktio_locale_recase +rktio_recase_utf16 +rktio_locale_strcoll +rktio_strcoll_utf16 +rktio_locale_encoding +rktio_set_locale +rktio_push_c_numeric_locale +rktio_pop_c_numeric_locale +rktio_system_language_country +rktio_dll_open +rktio_dll_find_object +rktio_dll_get_error +rktio_get_last_error_kind +rktio_get_last_error +rktio_get_last_error_step +rktio_set_last_error +rktio_set_last_error_step +rktio_remap_last_error +rktio_get_last_error_string +rktio_get_error_string diff --git a/racket/src/rktio/rktio.h b/racket/src/rktio/rktio.h index 0b9ad14b4a..c30cac1a33 100644 --- a/racket/src/rktio/rktio.h +++ b/racket/src/rktio/rktio.h @@ -88,6 +88,7 @@ Thread and signal conventions: #define RKTIO_EXTERN_STEP RKTIO_EXTERN #define RKTIO_NULLABLE /* empty */ +#define RKTIO_BLOCKING /* empty */ /*************************************************/ /* Initialization and general datatypes */ @@ -736,7 +737,7 @@ enum { RKTIO_LTPS_HANDLE_FREE }; -RKTIO_EXTERN void rktio_sleep(rktio_t *rktio, float nsecs, rktio_poll_set_t *fds, rktio_ltps_t *lt); +RKTIO_EXTERN RKTIO_BLOCKING void rktio_sleep(rktio_t *rktio, float nsecs, rktio_poll_set_t *fds, rktio_ltps_t *lt); /* Waits up to `nsecs` seconds (or forever if `nsecs` is 0), until something registered with `fds` or `lt` is ready, or until there's some other activity that sometimes causes an early wakeup. */ diff --git a/racket/src/rktio/rktio.inc b/racket/src/rktio/rktio.inc new file mode 100644 index 0000000000..f1a1ea9326 --- /dev/null +++ b/racket/src/rktio/rktio.inc @@ -0,0 +1,192 @@ +/* Extracted from rktio.h by rktio/parse.rkt */ +Sforeign_symbol("rktio_init", (void *)rktio_init); +Sforeign_symbol("rktio_destroy", (void *)rktio_destroy); +Sforeign_symbol("rktio_free", (void *)rktio_free); +Sforeign_symbol("rktio_set_dll_path", (void *)rktio_set_dll_path); +Sforeign_symbol("rktio_get_dll_path", (void *)rktio_get_dll_path); +Sforeign_symbol("rktio_system_fd", (void *)rktio_system_fd); +Sforeign_symbol("rktio_fd_system_fd", (void *)rktio_fd_system_fd); +Sforeign_symbol("rktio_fd_is_regular_file", (void *)rktio_fd_is_regular_file); +Sforeign_symbol("rktio_fd_is_directory", (void *)rktio_fd_is_directory); +Sforeign_symbol("rktio_fd_is_socket", (void *)rktio_fd_is_socket); +Sforeign_symbol("rktio_fd_is_udp", (void *)rktio_fd_is_udp); +Sforeign_symbol("rktio_fd_is_terminal", (void *)rktio_fd_is_terminal); +Sforeign_symbol("rktio_fd_is_text_converted", (void *)rktio_fd_is_text_converted); +Sforeign_symbol("rktio_fd_modes", (void *)rktio_fd_modes); +Sforeign_symbol("rktio_open", (void *)rktio_open); +Sforeign_symbol("rktio_close", (void *)rktio_close); +Sforeign_symbol("rktio_close_noerr", (void *)rktio_close_noerr); +Sforeign_symbol("rktio_dup", (void *)rktio_dup); +Sforeign_symbol("rktio_forget", (void *)rktio_forget); +Sforeign_symbol("rktio_std_fd", (void *)rktio_std_fd); +Sforeign_symbol("rktio_read", (void *)rktio_read); +Sforeign_symbol("rktio_write", (void *)rktio_write); +Sforeign_symbol("rktio_read_converted", (void *)rktio_read_converted); +Sforeign_symbol("rktio_read_in", (void *)rktio_read_in); +Sforeign_symbol("rktio_write_in", (void *)rktio_write_in); +Sforeign_symbol("rktio_buffered_byte_count", (void *)rktio_buffered_byte_count); +Sforeign_symbol("rktio_poll_read_ready", (void *)rktio_poll_read_ready); +Sforeign_symbol("rktio_poll_write_ready", (void *)rktio_poll_write_ready); +Sforeign_symbol("rktio_poll_write_flushed", (void *)rktio_poll_write_flushed); +Sforeign_symbol("rktio_file_lock_try", (void *)rktio_file_lock_try); +Sforeign_symbol("rktio_file_unlock", (void *)rktio_file_unlock); +Sforeign_symbol("rktio_set_file_position", (void *)rktio_set_file_position); +Sforeign_symbol("rktio_get_file_position", (void *)rktio_get_file_position); +Sforeign_symbol("rktio_set_file_size", (void *)rktio_set_file_size); +Sforeign_symbol("rktio_make_pipe", (void *)rktio_make_pipe); +Sforeign_symbol("rktio_start_addrinfo_lookup", (void *)rktio_start_addrinfo_lookup); +Sforeign_symbol("rktio_get_ipv4_family", (void *)rktio_get_ipv4_family); +Sforeign_symbol("rktio_poll_addrinfo_lookup_ready", (void *)rktio_poll_addrinfo_lookup_ready); +Sforeign_symbol("rktio_addrinfo_lookup_get", (void *)rktio_addrinfo_lookup_get); +Sforeign_symbol("rktio_addrinfo_lookup_stop", (void *)rktio_addrinfo_lookup_stop); +Sforeign_symbol("rktio_addrinfo_free", (void *)rktio_addrinfo_free); +Sforeign_symbol("rktio_listen", (void *)rktio_listen); +Sforeign_symbol("rktio_listen_stop", (void *)rktio_listen_stop); +Sforeign_symbol("rktio_poll_accept_ready", (void *)rktio_poll_accept_ready); +Sforeign_symbol("rktio_accept", (void *)rktio_accept); +Sforeign_symbol("rktio_start_connect", (void *)rktio_start_connect); +Sforeign_symbol("rktio_connect_finish", (void *)rktio_connect_finish); +Sforeign_symbol("rktio_connect_stop", (void *)rktio_connect_stop); +Sforeign_symbol("rktio_poll_connect_ready", (void *)rktio_poll_connect_ready); +Sforeign_symbol("rktio_connect_trying", (void *)rktio_connect_trying); +Sforeign_symbol("rktio_socket_shutdown", (void *)rktio_socket_shutdown); +Sforeign_symbol("rktio_udp_open", (void *)rktio_udp_open); +Sforeign_symbol("rktio_udp_disconnect", (void *)rktio_udp_disconnect); +Sforeign_symbol("rktio_udp_bind", (void *)rktio_udp_bind); +Sforeign_symbol("rktio_udp_connect", (void *)rktio_udp_connect); +Sforeign_symbol("rktio_udp_sendto", (void *)rktio_udp_sendto); +Sforeign_symbol("rktio_udp_sendto_in", (void *)rktio_udp_sendto_in); +Sforeign_symbol("rktio_udp_recvfrom", (void *)rktio_udp_recvfrom); +Sforeign_symbol("rktio_udp_recvfrom_in", (void *)rktio_udp_recvfrom_in); +Sforeign_symbol("rktio_udp_get_multicast_loopback", (void *)rktio_udp_get_multicast_loopback); +Sforeign_symbol("rktio_udp_set_multicast_loopback", (void *)rktio_udp_set_multicast_loopback); +Sforeign_symbol("rktio_udp_get_multicast_ttl", (void *)rktio_udp_get_multicast_ttl); +Sforeign_symbol("rktio_udp_set_multicast_ttl", (void *)rktio_udp_set_multicast_ttl); +Sforeign_symbol("rktio_udp_multicast_interface", (void *)rktio_udp_multicast_interface); +Sforeign_symbol("rktio_udp_set_multicast_interface", (void *)rktio_udp_set_multicast_interface); +Sforeign_symbol("rktio_udp_change_multicast_group", (void *)rktio_udp_change_multicast_group); +Sforeign_symbol("rktio_socket_address", (void *)rktio_socket_address); +Sforeign_symbol("rktio_socket_peer_address", (void *)rktio_socket_peer_address); +Sforeign_symbol("rktio_listener_address", (void *)rktio_listener_address); +Sforeign_symbol("rktio_is_ok_envvar_name", (void *)rktio_is_ok_envvar_name); +Sforeign_symbol("rktio_are_envvar_names_case_insensitive", (void *)rktio_are_envvar_names_case_insensitive); +Sforeign_symbol("rktio_getenv", (void *)rktio_getenv); +Sforeign_symbol("rktio_setenv", (void *)rktio_setenv); +Sforeign_symbol("rktio_envvars", (void *)rktio_envvars); +Sforeign_symbol("rktio_empty_envvars", (void *)rktio_empty_envvars); +Sforeign_symbol("rktio_envvars_copy", (void *)rktio_envvars_copy); +Sforeign_symbol("rktio_envvars_free", (void *)rktio_envvars_free); +Sforeign_symbol("rktio_envvars_get", (void *)rktio_envvars_get); +Sforeign_symbol("rktio_envvars_set", (void *)rktio_envvars_set); +Sforeign_symbol("rktio_envvars_count", (void *)rktio_envvars_count); +Sforeign_symbol("rktio_envvars_name_ref", (void *)rktio_envvars_name_ref); +Sforeign_symbol("rktio_envvars_value_ref", (void *)rktio_envvars_value_ref); +Sforeign_symbol("rktio_process", (void *)rktio_process); +Sforeign_symbol("rktio_process_allowed_flags", (void *)rktio_process_allowed_flags); +Sforeign_symbol("rktio_process_pid", (void *)rktio_process_pid); +Sforeign_symbol("rktio_process_kill", (void *)rktio_process_kill); +Sforeign_symbol("rktio_process_interrupt", (void *)rktio_process_interrupt); +Sforeign_symbol("rktio_process_forget", (void *)rktio_process_forget); +Sforeign_symbol("rktio_poll_process_done", (void *)rktio_poll_process_done); +Sforeign_symbol("rktio_process_status", (void *)rktio_process_status); +Sforeign_symbol("rktio_reap_processes", (void *)rktio_reap_processes); +Sforeign_symbol("rktio_fs_change_properties", (void *)rktio_fs_change_properties); +Sforeign_symbol("rktio_fs_change", (void *)rktio_fs_change); +Sforeign_symbol("rktio_fs_change_forget", (void *)rktio_fs_change_forget); +Sforeign_symbol("rktio_poll_fs_change_ready", (void *)rktio_poll_fs_change_ready); +Sforeign_symbol("rktio_make_poll_set", (void *)rktio_make_poll_set); +Sforeign_symbol("rktio_poll_set_forget", (void *)rktio_poll_set_forget); +Sforeign_symbol("rktio_poll_add", (void *)rktio_poll_add); +Sforeign_symbol("rktio_poll_add_accept", (void *)rktio_poll_add_accept); +Sforeign_symbol("rktio_poll_add_connect", (void *)rktio_poll_add_connect); +Sforeign_symbol("rktio_poll_add_addrinfo_lookup", (void *)rktio_poll_add_addrinfo_lookup); +Sforeign_symbol("rktio_poll_add_process", (void *)rktio_poll_add_process); +Sforeign_symbol("rktio_poll_add_fs_change", (void *)rktio_poll_add_fs_change); +Sforeign_symbol("rktio_poll_set_add_nosleep", (void *)rktio_poll_set_add_nosleep); +Sforeign_symbol("rktio_poll_set_add_handle", (void *)rktio_poll_set_add_handle); +Sforeign_symbol("rktio_poll_set_add_eventmask", (void *)rktio_poll_set_add_eventmask); +Sforeign_symbol("rkio_reset_sleep_backoff", (void *)rkio_reset_sleep_backoff); +Sforeign_symbol("rktio_ltps_open", (void *)rktio_ltps_open); +Sforeign_symbol("rktio_ltps_close", (void *)rktio_ltps_close); +Sforeign_symbol("rktio_ltps_add", (void *)rktio_ltps_add); +Sforeign_symbol("rktio_ltps_handle_set_data", (void *)rktio_ltps_handle_set_data); +Sforeign_symbol("rktio_ltps_handle_get_data", (void *)rktio_ltps_handle_get_data); +Sforeign_symbol("rktio_ltps_remove_all", (void *)rktio_ltps_remove_all); +Sforeign_symbol("rktio_ltps_poll", (void *)rktio_ltps_poll); +Sforeign_symbol("rktio_ltps_get_signaled_handle", (void *)rktio_ltps_get_signaled_handle); +Sforeign_symbol("rktio_ltps_handle_set_auto", (void *)rktio_ltps_handle_set_auto); +Sforeign_symbol("rktio_sleep", (void *)rktio_sleep); +Sforeign_symbol("rktio_start_sleep", (void *)rktio_start_sleep); +Sforeign_symbol("rktio_end_sleep", (void *)rktio_end_sleep); +Sforeign_symbol("rktio_file_exists", (void *)rktio_file_exists); +Sforeign_symbol("rktio_directory_exists", (void *)rktio_directory_exists); +Sforeign_symbol("rktio_link_exists", (void *)rktio_link_exists); +Sforeign_symbol("rktio_is_regular_file", (void *)rktio_is_regular_file); +Sforeign_symbol("rktio_delete_file", (void *)rktio_delete_file); +Sforeign_symbol("rktio_rename_file", (void *)rktio_rename_file); +Sforeign_symbol("rktio_get_current_directory", (void *)rktio_get_current_directory); +Sforeign_symbol("rktio_set_current_directory", (void *)rktio_set_current_directory); +Sforeign_symbol("rktio_make_directory", (void *)rktio_make_directory); +Sforeign_symbol("rktio_delete_directory", (void *)rktio_delete_directory); +Sforeign_symbol("rktio_readlink", (void *)rktio_readlink); +Sforeign_symbol("rktio_make_link", (void *)rktio_make_link); +Sforeign_symbol("rktio_file_size", (void *)rktio_file_size); +Sforeign_symbol("rktio_get_file_modify_seconds", (void *)rktio_get_file_modify_seconds); +Sforeign_symbol("rktio_set_file_modify_seconds", (void *)rktio_set_file_modify_seconds); +Sforeign_symbol("rktio_fd_identity", (void *)rktio_fd_identity); +Sforeign_symbol("rktio_path_identity", (void *)rktio_path_identity); +Sforeign_symbol("rktio_get_file_or_directory_permissions", (void *)rktio_get_file_or_directory_permissions); +Sforeign_symbol("rktio_set_file_or_directory_permissions", (void *)rktio_set_file_or_directory_permissions); +Sforeign_symbol("rktio_directory_list_start", (void *)rktio_directory_list_start); +Sforeign_symbol("rktio_directory_list_step", (void *)rktio_directory_list_step); +Sforeign_symbol("rktio_directory_list_stop", (void *)rktio_directory_list_stop); +Sforeign_symbol("rktio_filesystem_roots", (void *)rktio_filesystem_roots); +Sforeign_symbol("rktio_copy_file_start", (void *)rktio_copy_file_start); +Sforeign_symbol("rktio_copy_file_is_done", (void *)rktio_copy_file_is_done); +Sforeign_symbol("rktio_copy_file_step", (void *)rktio_copy_file_step); +Sforeign_symbol("rktio_copy_file_finish_permissions", (void *)rktio_copy_file_finish_permissions); +Sforeign_symbol("rktio_copy_file_stop", (void *)rktio_copy_file_stop); +Sforeign_symbol("rktio_system_path", (void *)rktio_system_path); +Sforeign_symbol("rktio_expand_user_tilde", (void *)rktio_expand_user_tilde); +Sforeign_symbol("rktio_get_signal_handle", (void *)rktio_get_signal_handle); +Sforeign_symbol("rktio_signal_received_at", (void *)rktio_signal_received_at); +Sforeign_symbol("rktio_signal_received", (void *)rktio_signal_received); +Sforeign_symbol("rktio_wait_until_signal_received", (void *)rktio_wait_until_signal_received); +Sforeign_symbol("rktio_flush_signals_received", (void *)rktio_flush_signals_received); +Sforeign_symbol("rktio_install_os_signal_handler", (void *)rktio_install_os_signal_handler); +Sforeign_symbol("rktio_poll_os_signal", (void *)rktio_poll_os_signal); +Sforeign_symbol("rktio_get_milliseconds", (void *)rktio_get_milliseconds); +Sforeign_symbol("rktio_get_inexact_milliseconds", (void *)rktio_get_inexact_milliseconds); +Sforeign_symbol("rktio_get_process_milliseconds", (void *)rktio_get_process_milliseconds); +Sforeign_symbol("rktio_get_process_children_milliseconds", (void *)rktio_get_process_children_milliseconds); +Sforeign_symbol("rktio_get_seconds", (void *)rktio_get_seconds); +Sforeign_symbol("rktio_seconds_to_date", (void *)rktio_seconds_to_date); +Sforeign_symbol("rktio_shell_execute", (void *)rktio_shell_execute); +Sforeign_symbol("rktio_path_to_wide_path", (void *)rktio_path_to_wide_path); +Sforeign_symbol("rktio_wide_path_to_path", (void *)rktio_wide_path_to_path); +Sforeign_symbol("rktio_syslog", (void *)rktio_syslog); +Sforeign_symbol("rktio_convert_properties", (void *)rktio_convert_properties); +Sforeign_symbol("rktio_converter_open", (void *)rktio_converter_open); +Sforeign_symbol("rktio_converter_close", (void *)rktio_converter_close); +Sforeign_symbol("rktio_convert", (void *)rktio_convert); +Sforeign_symbol("rktio_convert_in", (void *)rktio_convert_in); +Sforeign_symbol("rktio_locale_recase", (void *)rktio_locale_recase); +Sforeign_symbol("rktio_recase_utf16", (void *)rktio_recase_utf16); +Sforeign_symbol("rktio_locale_strcoll", (void *)rktio_locale_strcoll); +Sforeign_symbol("rktio_strcoll_utf16", (void *)rktio_strcoll_utf16); +Sforeign_symbol("rktio_locale_encoding", (void *)rktio_locale_encoding); +Sforeign_symbol("rktio_set_locale", (void *)rktio_set_locale); +Sforeign_symbol("rktio_push_c_numeric_locale", (void *)rktio_push_c_numeric_locale); +Sforeign_symbol("rktio_pop_c_numeric_locale", (void *)rktio_pop_c_numeric_locale); +Sforeign_symbol("rktio_system_language_country", (void *)rktio_system_language_country); +Sforeign_symbol("rktio_dll_open", (void *)rktio_dll_open); +Sforeign_symbol("rktio_dll_find_object", (void *)rktio_dll_find_object); +Sforeign_symbol("rktio_dll_get_error", (void *)rktio_dll_get_error); +Sforeign_symbol("rktio_get_last_error_kind", (void *)rktio_get_last_error_kind); +Sforeign_symbol("rktio_get_last_error", (void *)rktio_get_last_error); +Sforeign_symbol("rktio_get_last_error_step", (void *)rktio_get_last_error_step); +Sforeign_symbol("rktio_set_last_error", (void *)rktio_set_last_error); +Sforeign_symbol("rktio_set_last_error_step", (void *)rktio_set_last_error_step); +Sforeign_symbol("rktio_remap_last_error", (void *)rktio_remap_last_error); +Sforeign_symbol("rktio_get_last_error_string", (void *)rktio_get_last_error_string); +Sforeign_symbol("rktio_get_error_string", (void *)rktio_get_error_string); diff --git a/racket/src/rktio/rktio.rktl b/racket/src/rktio/rktio.rktl new file mode 100644 index 0000000000..923057e140 --- /dev/null +++ b/racket/src/rktio/rktio.rktl @@ -0,0 +1,1323 @@ +;; Extracted from rktio.h by rktio/parse.rkt +(begin +(define-constant RKTIO_OPEN_READ (<< 1 0)) +(define-constant RKTIO_OPEN_WRITE (<< 1 1)) +(define-constant RKTIO_OPEN_TEXT (<< 1 2)) +(define-constant RKTIO_OPEN_TRUNCATE (<< 1 3)) +(define-constant RKTIO_OPEN_APPEND (<< 1 4)) +(define-constant RKTIO_OPEN_MUST_EXIST (<< 1 5)) +(define-constant RKTIO_OPEN_CAN_EXIST (<< 1 6)) +(define-constant RKTIO_OPEN_SOCKET (<< 1 7)) +(define-constant RKTIO_OPEN_UDP (<< 1 8)) +(define-constant RKTIO_OPEN_REGFILE (<< 1 9)) +(define-constant RKTIO_OPEN_NOT_REGFILE (<< 1 10)) +(define-constant RKTIO_OPEN_DIR (<< 1 11)) +(define-constant RKTIO_OPEN_NOT_DIR (<< 1 12)) +(define-constant RKTIO_OPEN_INIT (<< 1 13)) +(define-constant RKTIO_OPEN_OWN (<< 1 14)) +(define-constant RKTIO_STDIN 0) +(define-constant RKTIO_STDOUT 1) +(define-constant RKTIO_STDERR 2) +(define-constant RKTIO_READ_EOF -1) +(define-constant RKTIO_READ_ERROR -2) +(define-constant RKTIO_WRITE_ERROR -2) +(define-constant RKTIO_POLL_NOT_READY 0) +(define-constant RKTIO_POLL_READY 1) +(define-constant RKTIO_POLL_ERROR -2) +(define-constant RKTIO_LOCK_ERROR -2) +(define-constant RKTIO_LOCK_ACQUIRED 1) +(define-constant RKTIO_LOCK_NOT_ACQUIRED 0) +(define-constant RKTIO_POSITION_FROM_START 0) +(define-constant RKTIO_POSITION_FROM_END 1) +(define-constant RKTIO_NO_INHERIT_INPUT (<< 1 0)) +(define-constant RKTIO_NO_INHERIT_OUTPUT (<< 1 1)) +(define-constant RKTIO_FAMILY_ANY -1) +(define-constant RKTIO_SHUTDOWN_READ 0) +(define-constant RKTIO_SHUTDOWN_WRITE 1) +(define-constant RKTIO_PROP_ERROR -2) +(define-constant RKTIO_ADD_MEMBERSHIP 0) +(define-constant RKTIO_DROP_MEMBERSHIP 1) +(define-constant RKTIO_PROCESS_NEW_GROUP (<< 1 0)) +(define-constant RKTIO_PROCESS_STDOUT_AS_STDERR (<< 1 1)) +(define-constant RKTIO_PROCESS_WINDOWS_EXACT_CMDLINE (<< 1 2)) +(define-constant RKTIO_PROCESS_WINDOWS_CHAIN_TERMINATION (<< 1 3)) +(define-constant RKTIO_PROCESS_ERROR -2) +(define-constant RKTIO_PROCESS_DONE 1) +(define-constant RKTIO_PROCESS_RUNNING 0) +(define-constant RKTIO_FS_CHANGE_SUPPORTED (<< 1 0)) +(define-constant RKTIO_FS_CHANGE_SCALABLE (<< 1 1)) +(define-constant RKTIO_FS_CHANGE_LOW_LATENCY (<< 1 2)) +(define-constant RKTIO_FS_CHANGE_FILE_LEVEL (<< 1 3)) +(define-constant RKTIO_FS_CHANGE_NEED_LTPS (<< 1 4)) +(define-constant RKTIO_POLL_READ RKTIO_OPEN_READ) +(define-constant RKTIO_POLL_WRITE RKTIO_OPEN_WRITE) +(define-constant RKTIO_POLL_FLUSH (<< RKTIO_OPEN_WRITE 2)) +(define-constant RKTIO_LTPS_CREATE_READ 1) +(define-constant RKTIO_LTPS_CREATE_WRITE 2) +(define-constant RKTIO_LTPS_CHECK_READ 3) +(define-constant RKTIO_LTPS_CHECK_WRITE 4) +(define-constant RKTIO_LTPS_REMOVE 5) +(define-constant RKTIO_LTPS_CREATE_VNODE 6) +(define-constant RKTIO_LTPS_CHECK_VNODE 7) +(define-constant RKTIO_LTPS_REMOVE_VNODE 8) +(define-constant RKTIO_LTPS_HANDLE_NONE 0) +(define-constant RKTIO_LTPS_HANDLE_ZERO 1) +(define-constant RKTIO_LTPS_HANDLE_FREE 2) +(define-constant RKTIO_PERMISSION_READ 4) +(define-constant RKTIO_PERMISSION_WRITE 2) +(define-constant RKTIO_PERMISSION_EXEC 1) +(define-constant RKTIO_PERMISSION_ERROR -1) +(define-constant RKTIO_COPY_STEP_UNKNOWN 0) +(define-constant RKTIO_COPY_STEP_OPEN_SRC 1) +(define-constant RKTIO_COPY_STEP_OPEN_DEST 2) +(define-constant RKTIO_COPY_STEP_READ_SRC_DATA 3) +(define-constant RKTIO_COPY_STEP_WRITE_DEST_DATA 4) +(define-constant RKTIO_COPY_STEP_READ_SRC_METADATA 5) +(define-constant RKTIO_COPY_STEP_WRITE_DEST_METADATA 6) +(define-constant RKTIO_PATH_SYS_DIR 0) +(define-constant RKTIO_PATH_TEMP_DIR 1) +(define-constant RKTIO_PATH_PREF_DIR 2) +(define-constant RKTIO_PATH_PREF_FILE 3) +(define-constant RKTIO_PATH_ADDON_DIR 4) +(define-constant RKTIO_PATH_HOME_DIR 5) +(define-constant RKTIO_PATH_DESK_DIR 6) +(define-constant RKTIO_PATH_DOC_DIR 7) +(define-constant RKTIO_PATH_INIT_DIR 8) +(define-constant RKTIO_PATH_INIT_FILE 9) +(define-constant RKTIO_OS_SIGNAL_NONE -1) +(define-constant RKTIO_OS_SIGNAL_INT 0) +(define-constant RKTIO_OS_SIGNAL_TERM 1) +(define-constant RKTIO_OS_SIGNAL_HUP 2) +(define-constant RKTIO_NUM_OS_SIGNALS 3) +(define-constant RKTIO_SW_HIDE 0) +(define-constant RKTIO_SW_MAXIMIZE 1) +(define-constant RKTIO_SW_MINIMIZE 2) +(define-constant RKTIO_SW_RESTORE 3) +(define-constant RKTIO_SW_SHOW 4) +(define-constant RKTIO_SW_SHOWDEFAULT 5) +(define-constant RKTIO_SW_SHOWMAXIMIZED 6) +(define-constant RKTIO_SW_SHOWMINIMIZED 7) +(define-constant RKTIO_SW_SHOWMINNOACTIVE 8) +(define-constant RKTIO_SW_SHOWNA 9) +(define-constant RKTIO_SW_SHOWNOACTIVATE 10) +(define-constant RKTIO_SW_SHOWNORMAL 11) +(define-constant RKTIO_LOG_FATAL 1) +(define-constant RKTIO_LOG_ERROR 2) +(define-constant RKTIO_LOG_WARNING 3) +(define-constant RKTIO_LOG_INFO 4) +(define-constant RKTIO_LOG_DEBUG 5) +(define-constant RKTIO_CONVERTER_SUPPORTED (<< 1 0)) +(define-constant RKTIO_CONVERT_STRCOLL_UTF16 (<< 1 1)) +(define-constant RKTIO_CONVERT_RECASE_UTF16 (<< 1 2)) +(define-constant RKTIO_CONVERT_ERROR -1) +(define-constant RKTIO_ERROR_KIND_POSIX 0) +(define-constant RKTIO_ERROR_KIND_WINDOWS 1) +(define-constant RKTIO_ERROR_KIND_GAI 2) +(define-constant RKTIO_ERROR_KIND_RACKET 3) +(define-constant RKTIO_ERROR_UNSUPPORTED 1) +(define-constant RKTIO_ERROR_INVALID_PATH 2) +(define-constant RKTIO_ERROR_DOES_NOT_EXIST 3) +(define-constant RKTIO_ERROR_EXISTS 4) +(define-constant RKTIO_ERROR_ACCESS_DENIED 5) +(define-constant RKTIO_ERROR_LINK_FAILED 6) +(define-constant RKTIO_ERROR_NOT_A_LINK 7) +(define-constant RKTIO_ERROR_BAD_PERMISSION 8) +(define-constant RKTIO_ERROR_IS_A_DIRECTORY 9) +(define-constant RKTIO_ERROR_NOT_A_DIRECTORY 10) +(define-constant RKTIO_ERROR_UNSUPPORTED_TEXT_MODE 11) +(define-constant RKTIO_ERROR_CANNOT_FILE_POSITION 12) +(define-constant RKTIO_ERROR_NO_TILDE 13) +(define-constant RKTIO_ERROR_ILL_FORMED_USER 14) +(define-constant RKTIO_ERROR_UNKNOWN_USER 15) +(define-constant RKTIO_ERROR_INIT_FAILED 16) +(define-constant RKTIO_ERROR_LTPS_NOT_FOUND 17) +(define-constant RKTIO_ERROR_LTPS_REMOVED 18) +(define-constant RKTIO_ERROR_CONNECT_TRYING_NEXT 19) +(define-constant RKTIO_ERROR_ACCEPT_NOT_READY 20) +(define-constant RKTIO_ERROR_HOST_AND_PORT_BOTH_UNSPECIFIED 21) +(define-constant RKTIO_ERROR_INFO_TRY_AGAIN 22) +(define-constant RKTIO_ERROR_TRY_AGAIN 23) +(define-constant RKTIO_ERROR_TRY_AGAIN_WITH_IPV4 24) +(define-constant RKTIO_ERROR_TIME_OUT_OF_RANGE 25) +(define-constant RKTIO_ERROR_NO_SUCH_ENVVAR 26) +(define-constant RKTIO_ERROR_SHELL_EXECUTE_FAILED 27) +(define-constant RKTIO_ERROR_CONVERT_NOT_ENOUGH_SPACE 28) +(define-constant RKTIO_ERROR_CONVERT_BAD_SEQUENCE 29) +(define-constant RKTIO_ERROR_CONVERT_PREMATURE_END 30) +(define-constant RKTIO_ERROR_CONVERT_OTHER 31) +(define-constant RKTIO_ERROR_DLL 32) +(define-type rktio_ok_t int) +(define-type rktio_tri_t int) +(define-type rktio_bool_t int) +(define-type rktio_char16_t unsigned-short) +(define-type rktio_const_string_t (*ref char)) +(define-type rktio_filesize_t rktio_int64_t) +(define-struct-type + rktio_length_and_addrinfo_t + ((intptr_t len) ((ref (ref char)) address))) +(define-struct-type + rktio_process_result_t + (((ref rktio_process_t) process) + ((ref rktio_fd_t) stdin_fd) + ((ref rktio_fd_t) stdout_fd) + ((ref rktio_fd_t) stderr_fd))) +(define-struct-type rktio_status_t ((rktio_bool_t running) (int result))) +(define-type rktio_timestamp_t intptr_t) +(define-struct-type + rktio_identity_t + ((uintptr_t a) + (uintptr_t b) + (uintptr_t c) + (int a_bits) + (int b_bits) + (int c_bits))) +(define-struct-type + rktio_date_t + ((int nanosecond) + (int second) + (int minute) + (int hour) + (int day) + (int month) + (intptr_t year) + (int day_of_week) + (int day_of_year) + (int is_dst) + (int zone_offset) + ((ref char) zone_name))) +(define-struct-type + rktio_convert_result_t + ((intptr_t in_consumed) (intptr_t out_produced) (intptr_t converted))) +(define-function () (ref rktio_t) rktio_init ()) +(define-function () void rktio_destroy (((ref rktio_t) rktio))) +(define-function () void rktio_free (((ref void) p))) +(define-function () void rktio_set_dll_path (((*ref rktio_char16_t) p))) +(define-function/errno + NULL + () + (ref rktio_char16_t) + rktio_get_dll_path + (((*ref rktio_char16_t) p))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_system_fd + (((ref rktio_t) rktio) (intptr_t system_fd) (int modes))) +(define-function + () + intptr_t + rktio_fd_system_fd + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_regular_file + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_directory + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_socket + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_udp + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_terminal + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + rktio_bool_t + rktio_fd_is_text_converted + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + int + rktio_fd_modes + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_open + (((ref rktio_t) rktio) (rktio_const_string_t src) (int modes))) +(define-function/errno + #f + () + rktio_ok_t + rktio_close + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function + () + void + rktio_close_noerr + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_dup + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function + () + void + rktio_forget + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_std_fd + (((ref rktio_t) rktio) (int which))) +(define-function/errno + RKTIO_READ_ERROR + () + intptr_t + rktio_read + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_write + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + RKTIO_READ_ERROR + () + intptr_t + rktio_read_converted + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t len) + ((*ref char) is_converted))) +(define-function/errno + RKTIO_READ_ERROR + () + intptr_t + rktio_read_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_write_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) fd) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function + () + intptr_t + rktio_buffered_byte_count + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_read_ready + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_write_ready + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_write_flushed + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + RKTIO_LOCK_ERROR + () + rktio_tri_t + rktio_file_lock_try + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (rktio_bool_t excl))) +(define-function/errno + #f + () + rktio_ok_t + rktio_file_unlock + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_position + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + (rktio_filesize_t pos) + (int whence))) +(define-function/errno + NULL + () + (ref rktio_filesize_t) + rktio_get_file_position + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_size + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (rktio_filesize_t sz))) +(define-function/errno + NULL + () + (ref (ref rktio_fd_t)) + rktio_make_pipe + (((ref rktio_t) rktio) (int flags))) +(define-function/errno + NULL + () + (ref rktio_addrinfo_lookup_t) + rktio_start_addrinfo_lookup + (((ref rktio_t) rktio) + (rktio_const_string_t hostname) + (int portno) + (int family) + (rktio_bool_t passive) + (rktio_bool_t tcp))) +(define-function () int rktio_get_ipv4_family (((ref rktio_t) rktio))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_addrinfo_lookup_ready + (((ref rktio_t) rktio) ((ref rktio_addrinfo_lookup_t) lookup))) +(define-function/errno + NULL + () + (ref rktio_addrinfo_t) + rktio_addrinfo_lookup_get + (((ref rktio_t) rktio) ((ref rktio_addrinfo_lookup_t) lookup))) +(define-function + () + void + rktio_addrinfo_lookup_stop + (((ref rktio_t) rktio) ((ref rktio_addrinfo_lookup_t) lookup))) +(define-function + () + void + rktio_addrinfo_free + (((ref rktio_t) rktio) ((ref rktio_addrinfo_t) a))) +(define-function/errno + NULL + () + (ref rktio_listener_t) + rktio_listen + (((ref rktio_t) rktio) + ((ref rktio_addrinfo_t) local) + (int backlog) + (rktio_bool_t reuse))) +(define-function + () + void + rktio_listen_stop + (((ref rktio_t) rktio) ((ref rktio_listener_t) l))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_accept_ready + (((ref rktio_t) rktio) ((ref rktio_listener_t) listener))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_accept + (((ref rktio_t) rktio) ((ref rktio_listener_t) listener))) +(define-function/errno + NULL + () + (ref rktio_connect_t) + rktio_start_connect + (((ref rktio_t) rktio) + ((ref rktio_addrinfo_t) remote) + ((ref (nullable rktio_addrinfo_t)) local))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_connect_finish + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function + () + void + rktio_connect_stop + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_connect_ready + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_connect_trying + (((ref rktio_t) rktio) ((ref rktio_connect_t) conn))) +(define-function/errno + #f + () + rktio_ok_t + rktio_socket_shutdown + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (int mode))) +(define-function/errno + NULL + () + (ref rktio_fd_t) + rktio_udp_open + (((ref rktio_t) rktio) ((ref (nullable rktio_addrinfo_t)) addr) (int family))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_disconnect + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_bind + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref rktio_addrinfo_t) addr) + (rktio_bool_t reuse))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_connect + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) ((ref rktio_addrinfo_t) addr))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_udp_sendto + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref (nullable rktio_addrinfo_t)) addr) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + RKTIO_WRITE_ERROR + () + intptr_t + rktio_udp_sendto_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref (nullable rktio_addrinfo_t)) addr) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function/errno + NULL + () + (ref rktio_length_and_addrinfo_t) + rktio_udp_recvfrom + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((*ref char) buffer) + (intptr_t len))) +(define-function/errno + NULL + () + (ref rktio_length_and_addrinfo_t) + rktio_udp_recvfrom_in + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((*ref char) buffer) + (intptr_t start) + (intptr_t end))) +(define-function/errno + RKTIO_PROP_ERROR + () + rktio_tri_t + rktio_udp_get_multicast_loopback + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_set_multicast_loopback + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (rktio_bool_t on))) +(define-function/errno + RKTIO_PROP_ERROR + () + rktio_tri_t + rktio_udp_get_multicast_ttl + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_set_multicast_ttl + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd) (int ttl_val))) +(define-function/errno + NULL + () + (ref char) + rktio_udp_multicast_interface + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_set_multicast_interface + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref (nullable rktio_addrinfo_t)) addr))) +(define-function/errno + #f + () + rktio_ok_t + rktio_udp_change_multicast_group + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref rktio_addrinfo_t) group_addr) + ((ref (nullable rktio_addrinfo_t)) intf_addr) + (int action))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_socket_address + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_socket_peer_address + (((ref rktio_t) rktio) ((ref rktio_fd_t) rfd))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_listener_address + (((ref rktio_t) rktio) ((ref rktio_listener_t) lnr))) +(define-function + () + rktio_bool_t + rktio_is_ok_envvar_name + (((ref rktio_t) rktio) (rktio_const_string_t name))) +(define-function + () + rktio_bool_t + rktio_are_envvar_names_case_insensitive + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref char) + rktio_getenv + (((ref rktio_t) rktio) (rktio_const_string_t name))) +(define-function/errno + #f + () + rktio_ok_t + rktio_setenv + (((ref rktio_t) rktio) + (rktio_const_string_t name) + (rktio_const_string_t val))) +(define-function/errno + NULL + () + (ref rktio_envvars_t) + rktio_envvars + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_envvars_t) + rktio_empty_envvars + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_envvars_t) + rktio_envvars_copy + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars))) +(define-function + () + void + rktio_envvars_free + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars))) +(define-function/errno + NULL + () + (ref char) + rktio_envvars_get + (((ref rktio_t) rktio) + ((ref rktio_envvars_t) envvars) + (rktio_const_string_t name))) +(define-function + () + void + rktio_envvars_set + (((ref rktio_t) rktio) + ((ref rktio_envvars_t) envvars) + (rktio_const_string_t name) + (rktio_const_string_t value))) +(define-function + () + intptr_t + rktio_envvars_count + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars))) +(define-function/errno + NULL + () + (ref char) + rktio_envvars_name_ref + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars) (intptr_t i))) +(define-function/errno + NULL + () + (ref char) + rktio_envvars_value_ref + (((ref rktio_t) rktio) ((ref rktio_envvars_t) envvars) (intptr_t i))) +(define-function/errno + NULL + () + (ref rktio_process_result_t) + rktio_process + (((ref rktio_t) rktio) + (rktio_const_string_t command) + (int argc) + ((*ref rktio_const_string_t) argv) + ((ref (nullable rktio_fd_t)) stdout_fd) + ((ref (nullable rktio_fd_t)) stdin_fd) + ((ref (nullable rktio_fd_t)) stderr_fd) + ((ref (nullable rktio_process_t)) group_proc) + (rktio_const_string_t current_directory) + ((ref rktio_envvars_t) envvars) + (int flags))) +(define-function () int rktio_process_allowed_flags (((ref rktio_t) rktio))) +(define-function + () + int + rktio_process_pid + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + #f + () + rktio_ok_t + rktio_process_kill + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + #f + () + rktio_ok_t + rktio_process_interrupt + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function + () + void + rktio_process_forget + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + RKTIO_PROCESS_ERROR + () + rktio_tri_t + rktio_poll_process_done + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function/errno + NULL + () + (ref rktio_status_t) + rktio_process_status + (((ref rktio_t) rktio) ((ref rktio_process_t) sp))) +(define-function () void rktio_reap_processes (((ref rktio_t) rktio))) +(define-function () int rktio_fs_change_properties (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_fs_change_t) + rktio_fs_change + (((ref rktio_t) rktio) (rktio_const_string_t path) ((ref rktio_ltps_t) ltps))) +(define-function + () + void + rktio_fs_change_forget + (((ref rktio_t) rktio) ((ref rktio_fs_change_t) fc))) +(define-function/errno + RKTIO_POLL_ERROR + () + rktio_tri_t + rktio_poll_fs_change_ready + (((ref rktio_t) rktio) ((ref rktio_fs_change_t) fc))) +(define-function/errno + NULL + () + (ref rktio_poll_set_t) + rktio_make_poll_set + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_poll_set_forget + (((ref rktio_t) rktio) ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add + (((ref rktio_t) rktio) + ((ref rktio_fd_t) rfd) + ((ref rktio_poll_set_t) fds) + (int modes))) +(define-function + () + void + rktio_poll_add_accept + (((ref rktio_t) rktio) + ((ref rktio_listener_t) listener) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_connect + (((ref rktio_t) rktio) + ((ref rktio_connect_t) conn) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_addrinfo_lookup + (((ref rktio_t) rktio) + ((ref rktio_addrinfo_lookup_t) lookup) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_process + (((ref rktio_t) rktio) + ((ref rktio_process_t) sp) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_add_fs_change + (((ref rktio_t) rktio) + ((ref rktio_fs_change_t) fc) + ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_set_add_nosleep + (((ref rktio_t) rktio) ((ref rktio_poll_set_t) fds))) +(define-function + () + void + rktio_poll_set_add_handle + (((ref rktio_t) rktio) + (intptr_t h) + ((ref rktio_poll_set_t) fds) + (int repost))) +(define-function + () + void + rktio_poll_set_add_eventmask + (((ref rktio_t) rktio) ((ref rktio_poll_set_t) fds) (int mask))) +(define-function () void rkio_reset_sleep_backoff (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_ltps_t) + rktio_ltps_open + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_ltps_close + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function/errno + NULL + () + (ref rktio_ltps_handle_t) + rktio_ltps_add + (((ref rktio_t) rktio) + ((ref rktio_ltps_t) lt) + ((ref rktio_fd_t) rfd) + (int mode))) +(define-function + () + void + rktio_ltps_handle_set_data + (((ref rktio_t) rktio) ((ref rktio_ltps_handle_t) h) ((ref void) data))) +(define-function + () + (ref void) + rktio_ltps_handle_get_data + (((ref rktio_t) rktio) ((ref rktio_ltps_handle_t) h))) +(define-function + () + void + rktio_ltps_remove_all + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function/errno + #f + () + rktio_ok_t + rktio_ltps_poll + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function/errno + NULL + () + (ref rktio_ltps_handle_t) + rktio_ltps_get_signaled_handle + (((ref rktio_t) rktio) ((ref rktio_ltps_t) lt))) +(define-function + () + void + rktio_ltps_handle_set_auto + (((ref rktio_t) rktio) ((ref rktio_ltps_handle_t) lth) (int auto_mode))) +(define-function + (blocking) + void + rktio_sleep + (((ref rktio_t) rktio) + (float nsecs) + ((ref rktio_poll_set_t) fds) + ((ref rktio_ltps_t) lt))) +(define-function/errno + #f + () + rktio_ok_t + rktio_start_sleep + (((ref rktio_t) rktio) + (float nsecs) + ((ref rktio_poll_set_t) fds) + ((ref rktio_ltps_t) lt) + (int woke_fd))) +(define-function () void rktio_end_sleep (((ref rktio_t) rktio))) +(define-function + () + rktio_bool_t + rktio_file_exists + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function + () + rktio_bool_t + rktio_directory_exists + (((ref rktio_t) rktio) (rktio_const_string_t dirname))) +(define-function + () + rktio_bool_t + rktio_link_exists + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function + () + rktio_bool_t + rktio_is_regular_file + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function/errno + #f + () + rktio_ok_t + rktio_delete_file + (((ref rktio_t) rktio) + (rktio_const_string_t fn) + (rktio_bool_t enable_write_on_fail))) +(define-function/errno + #f + () + rktio_ok_t + rktio_rename_file + (((ref rktio_t) rktio) + (rktio_const_string_t dest) + (rktio_const_string_t src) + (rktio_bool_t exists_ok))) +(define-function/errno + NULL + () + (ref char) + rktio_get_current_directory + (((ref rktio_t) rktio))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_current_directory + (((ref rktio_t) rktio) (rktio_const_string_t path))) +(define-function/errno + #f + () + rktio_ok_t + rktio_make_directory + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function/errno + #f + () + rktio_ok_t + rktio_delete_directory + (((ref rktio_t) rktio) + (rktio_const_string_t filename) + (rktio_const_string_t current_directory) + (rktio_bool_t enable_write_on_fail))) +(define-function/errno + NULL + () + (ref char) + rktio_readlink + (((ref rktio_t) rktio) (rktio_const_string_t fullfilename))) +(define-function/errno + #f + () + rktio_ok_t + rktio_make_link + (((ref rktio_t) rktio) + (rktio_const_string_t src) + (rktio_const_string_t dest) + (rktio_bool_t dest_is_directory))) +(define-function/errno + NULL + () + (ref rktio_filesize_t) + rktio_file_size + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function/errno + NULL + () + (ref rktio_timestamp_t) + rktio_get_file_modify_seconds + (((ref rktio_t) rktio) (rktio_const_string_t file))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_modify_seconds + (((ref rktio_t) rktio) (rktio_const_string_t file) (rktio_timestamp_t secs))) +(define-function/errno + NULL + () + (ref rktio_identity_t) + rktio_fd_identity + (((ref rktio_t) rktio) ((ref rktio_fd_t) fd))) +(define-function/errno + NULL + () + (ref rktio_identity_t) + rktio_path_identity + (((ref rktio_t) rktio) + (rktio_const_string_t path) + (rktio_bool_t follow_links))) +(define-function/errno + RKTIO_PERMISSION_ERROR + () + int + rktio_get_file_or_directory_permissions + (((ref rktio_t) rktio) + (rktio_const_string_t filename) + (rktio_bool_t all_bits))) +(define-function/errno + #f + () + rktio_ok_t + rktio_set_file_or_directory_permissions + (((ref rktio_t) rktio) (rktio_const_string_t filename) (int new_bits))) +(define-function/errno + NULL + () + (ref rktio_directory_list_t) + rktio_directory_list_start + (((ref rktio_t) rktio) (rktio_const_string_t dirname))) +(define-function/errno + NULL + () + (ref char) + rktio_directory_list_step + (((ref rktio_t) rktio) ((ref rktio_directory_list_t) dl))) +(define-function + () + void + rktio_directory_list_stop + (((ref rktio_t) rktio) ((ref rktio_directory_list_t) dl))) +(define-function/errno + NULL + () + (ref (ref char)) + rktio_filesystem_roots + (((ref rktio_t) rktio))) +(define-function/errno+step + NULL + () + (ref rktio_file_copy_t) + rktio_copy_file_start + (((ref rktio_t) rktio) + (rktio_const_string_t dest) + (rktio_const_string_t src) + (rktio_bool_t exists_ok))) +(define-function + () + rktio_bool_t + rktio_copy_file_is_done + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function/errno+step + #f + () + rktio_ok_t + rktio_copy_file_step + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function/errno+step + #f + () + rktio_ok_t + rktio_copy_file_finish_permissions + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function + () + void + rktio_copy_file_stop + (((ref rktio_t) rktio) ((ref rktio_file_copy_t) fc))) +(define-function/errno + NULL + () + (ref char) + rktio_system_path + (((ref rktio_t) rktio) (int which))) +(define-function/errno + NULL + () + (ref char) + rktio_expand_user_tilde + (((ref rktio_t) rktio) (rktio_const_string_t filename))) +(define-function + () + (ref rktio_signal_handle_t) + rktio_get_signal_handle + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_signal_received_at + (((ref rktio_signal_handle_t) h))) +(define-function () void rktio_signal_received (((ref rktio_t) rktio))) +(define-function + () + void + rktio_wait_until_signal_received + (((ref rktio_t) rktio))) +(define-function () void rktio_flush_signals_received (((ref rktio_t) rktio))) +(define-function + () + void + rktio_install_os_signal_handler + (((ref rktio_t) rktio))) +(define-function () int rktio_poll_os_signal (((ref rktio_t) rktio))) +(define-function () intptr_t rktio_get_milliseconds ()) +(define-function () double rktio_get_inexact_milliseconds ()) +(define-function + () + intptr_t + rktio_get_process_milliseconds + (((ref rktio_t) rktio))) +(define-function + () + intptr_t + rktio_get_process_children_milliseconds + (((ref rktio_t) rktio))) +(define-function + () + rktio_timestamp_t + rktio_get_seconds + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_date_t) + rktio_seconds_to_date + (((ref rktio_t) rktio) + (rktio_timestamp_t seconds) + (int nanoseconds) + (int get_gmt))) +(define-function/errno + #f + () + rktio_ok_t + rktio_shell_execute + (((ref rktio_t) rktio) + (rktio_const_string_t verb) + (rktio_const_string_t target) + (rktio_const_string_t arg) + (rktio_const_string_t dir) + (int show_mode))) +(define-function/errno + NULL + () + (ref rktio_char16_t) + rktio_path_to_wide_path + (((ref rktio_t) rktio) (rktio_const_string_t p))) +(define-function + () + (ref char) + rktio_wide_path_to_path + (((ref rktio_t) rktio) ((*ref rktio_char16_t) wp))) +(define-function/errno + #f + () + rktio_ok_t + rktio_syslog + (((ref rktio_t) rktio) + (int level) + (rktio_const_string_t name) + (rktio_const_string_t msg) + (rktio_const_string_t exec_name))) +(define-function () int rktio_convert_properties (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_converter_t) + rktio_converter_open + (((ref rktio_t) rktio) + (rktio_const_string_t to_enc) + (rktio_const_string_t from_enc))) +(define-function + () + void + rktio_converter_close + (((ref rktio_t) rktio) ((ref rktio_converter_t) cvt))) +(define-function/errno + RKTIO_CONVERT_ERROR + () + intptr_t + rktio_convert + (((ref rktio_t) rktio) + ((ref rktio_converter_t) cvt) + ((*ref (ref char)) in) + ((*ref intptr_t) in_left) + ((*ref (ref char)) out) + ((*ref intptr_t) out_left))) +(define-function/errno + NULL + () + (ref rktio_convert_result_t) + rktio_convert_in + (((ref rktio_t) rktio) + ((ref rktio_converter_t) cvt) + ((*ref char) in) + (intptr_t in_start) + (intptr_t in_end) + ((*ref char) out) + (intptr_t out_start) + (intptr_t out_end))) +(define-function + () + (ref char) + rktio_locale_recase + (((ref rktio_t) rktio) (rktio_bool_t to_up) (rktio_const_string_t in))) +(define-function + () + (ref rktio_char16_t) + rktio_recase_utf16 + (((ref rktio_t) rktio) + (rktio_bool_t to_up) + ((*ref rktio_char16_t) s1) + (intptr_t len) + ((*ref intptr_t) olen))) +(define-function + () + int + rktio_locale_strcoll + (((ref rktio_t) rktio) (rktio_const_string_t s1) (rktio_const_string_t s2))) +(define-function + () + int + rktio_strcoll_utf16 + (((ref rktio_t) rktio) + ((*ref rktio_char16_t) s1) + (intptr_t l1) + ((*ref rktio_char16_t) s2) + (intptr_t l2) + (rktio_bool_t cvt_case))) +(define-function/errno + NULL + () + (ref char) + rktio_locale_encoding + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_set_locale + (((ref rktio_t) rktio) (rktio_const_string_t name))) +(define-function + () + (ref char) + rktio_push_c_numeric_locale + (((ref rktio_t) rktio))) +(define-function + () + void + rktio_pop_c_numeric_locale + (((ref rktio_t) rktio) ((*ref char) prev))) +(define-function/errno + NULL + () + (ref char) + rktio_system_language_country + (((ref rktio_t) rktio))) +(define-function/errno + NULL + () + (ref rktio_dll_t) + rktio_dll_open + (((ref rktio_t) rktio) (rktio_const_string_t name) (rktio_bool_t as_global))) +(define-function/errno + NULL + () + (ref void) + rktio_dll_find_object + (((ref rktio_t) rktio) ((ref rktio_dll_t) dll) (rktio_const_string_t name))) +(define-function/errno + NULL + () + (ref char) + rktio_dll_get_error + (((ref rktio_t) rktio))) +(define-function () int rktio_get_last_error_kind (((ref rktio_t) rktio))) +(define-function () int rktio_get_last_error (((ref rktio_t) rktio))) +(define-function () int rktio_get_last_error_step (((ref rktio_t) rktio))) +(define-function + () + void + rktio_set_last_error + (((ref rktio_t) rktio) (int kind) (int errid))) +(define-function + () + void + rktio_set_last_error_step + (((ref rktio_t) rktio) (int step))) +(define-function () void rktio_remap_last_error (((ref rktio_t) rktio))) +(define-function + () + (ref char) + rktio_get_last_error_string + (((ref rktio_t) rktio))) +(define-function + () + (ref char) + rktio_get_error_string + (((ref rktio_t) rktio) (int kind) (int errid))) +) diff --git a/racket/src/rktio/rktio_convert.c b/racket/src/rktio/rktio_convert.c index fd6c3a9296..2defb2da85 100644 --- a/racket/src/rktio/rktio_convert.c +++ b/racket/src/rktio/rktio_convert.c @@ -261,7 +261,7 @@ static char *nl_langinfo_dup() int len, j; char *enc; i++; - len = scheme_char_strlen(current_locale_name) - i; + len = strlen(current_locale_name) - i; enc = malloc(2 + len + 1); /* Check whether the encoding is numeric, in which case diff --git a/racket/src/rktio/rktio_fd.c b/racket/src/rktio/rktio_fd.c index 8e359aee09..685163402a 100644 --- a/racket/src/rktio/rktio_fd.c +++ b/racket/src/rktio/rktio_fd.c @@ -39,6 +39,7 @@ struct rktio_fd_t { struct Win_FD_Input_Thread *th; /* input mode */ struct Win_FD_Output_Thread *oth; /* output mode */ int unblocked; /* whether non-blocking mode is installed */ + int write_limit; /* non-0 => max on amount to try writing */ char *buffer; /* shared with reading thread */ int has_pending_byte; /* for text-mode input, may be dropped by a following lf */ int pending_byte; /* for text-mode input, either a CR waiting to decode, or byte that didn't fit */ @@ -1167,7 +1168,7 @@ intptr_t rktio_write(rktio_t *rktio, rktio_fd_t *rfd, const char *buffer, intptr if (rktio_fd_is_regular_file(rktio, rfd) || rktio_fd_is_terminal(rktio, rfd)) { /* Regular files never block, so this code looks like the Unix - code. */ + code. */ /* If we try to write too much at once, the result is ERROR_NOT_ENOUGH_MEMORY (as opposed to a partial write). */ @@ -1235,7 +1236,6 @@ intptr_t rktio_write(rktio_t *rktio, rktio_fd_t *rfd, const char *buffer, intptr if (nonblocking) { /* Unless we're still trying to flush old data, write to the pipe and have the other thread start flushing it. */ - DWORD nonblock = PIPE_NOWAIT; int flushed; if (rfd->oth) { @@ -1267,13 +1267,34 @@ intptr_t rktio_write(rktio_t *rktio, rktio_fd_t *rfd, const char *buffer, intptr write fails. (Yuck.) */ while (1) { if (!rfd->unblocked) { + DWORD nonblock = PIPE_NOWAIT; ok = SetNamedPipeHandleState((HANDLE)rfd->fd, &nonblock, NULL, NULL); if (ok) rfd->unblocked = 1; - else + else { errsaved = GetLastError(); + if (errsaved == ERROR_INVALID_FUNCTION) { + /* The handle (not a pipe?) doesn't support non-blocking mode. But + since we only try to write when the pipe is flushed, we can just + keep each request under the buffer size. */ + DWORD bufsz; + if (GetNamedPipeInfo((HANDLE)rfd->fd, NULL, &bufsz, NULL, NULL) + && (bufsz > 0)) + rfd->write_limit = bufsz; + else { + /* 256 should be small enough? */ + rfd->write_limit = 256; + } + rfd->unblocked = 1; + ok = 1; + } + } } else ok = 1; + + if (rfd->write_limit && (towrite > rfd->write_limit)) + towrite = rfd->write_limit; + if (ok) { ok = WriteFile((HANDLE)rfd->fd, buffer, towrite, &winwrote, NULL); if (!ok) @@ -1477,6 +1498,7 @@ static void deinit_write_fd(rktio_t *rktio, rktio_fd_t *rfd, int full_close) csi(rfd->oth->thread); } CloseHandle(rfd->oth->thread); + printf("done\n"); fflush(); rfd->oth->done = 1; ReleaseSemaphore(rfd->oth->work_sema, 1, NULL); @@ -1535,9 +1557,9 @@ static long WINAPI WindowsFDWriter(Win_FD_Output_Thread *oth) err_no = 0; WaitForSingleObject(oth->lock_sema, INFINITE); - if (!ok) + if (!ok) { oth->err_no = err_no; - else { + } else { oth->buflen -= wrote; if (oth->buflen) memmove(oth->buffer, oth->buffer + wrote, oth->buflen); @@ -1563,6 +1585,7 @@ static long WINAPI WindowsFDWriter(Win_FD_Output_Thread *oth) static void WindowsFDOCleanup(Win_FD_Output_Thread *oth, int close_mode) { + printf("clean up %p\n", oth); fflush(NULL); CloseHandle(oth->lock_sema); CloseHandle(oth->work_sema); diff --git a/racket/src/schemify/Makefile b/racket/src/schemify/Makefile new file mode 100644 index 0000000000..1e6b46317b --- /dev/null +++ b/racket/src/schemify/Makefile @@ -0,0 +1,48 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion. Make annotation references direct to +# improve performance. Declaring "collect.rkt" pure works around a +# limitation of the flattener. +IGNORE = ++knot read - ++direct kernel ++pure ../../collects/racket/private/collect.rkt + +schemify-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) schemify-src-generate + +known-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) known-src-generate + + +S_GENERATE_ARGS = -t main.rkt \ + --check-depends $(BUILDDIR)compiled/schemify-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/schemify-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/schemify.rktl $(BUILDDIR)compiled/schemify.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/schemify.rktl + +schemify-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(S_GENERATE_ARGS) + + +K_GENERATE_ARGS = -t known.rkt \ + --check-depends $(BUILDDIR)compiled/known-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/known-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/known.rktl $(BUILDDIR)compiled/known.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/known.rktl + + +known-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(K_GENERATE_ARGS) + +.PHONY: schemify-src schemify-src-generate known-src known-src-generate diff --git a/racket/src/schemify/README.txt b/racket/src/schemify/README.txt new file mode 100644 index 0000000000..4e63243da1 --- /dev/null +++ b/racket/src/schemify/README.txt @@ -0,0 +1,6 @@ +The "schemify" compiler takes a linklet and converts it to a `lambda`. +Converting a linklet with schemify is a step to compiling it either +via Chez Scheme or (via the "cify" compiler) to C code to embed in the +Racket virtual machine. + +See "../cs/README.txt" for more information. diff --git a/racket/src/schemify/equal.rkt b/racket/src/schemify/equal.rkt new file mode 100644 index 0000000000..767d4fdb65 --- /dev/null +++ b/racket/src/schemify/equal.rkt @@ -0,0 +1,39 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt") + +;; Since a Racket `equal?` will shadow the host Scheme's `equal?`, +;; its optimizer won't be able to reduce `equal?` to `eq?` or `eqv?` +;; with obvious arguments. So, we perform that conversion in schemify. + +(provide equal-implies-eq? + equal-implies-eqv?) + +(define (equal-implies-eq? e) + (match e + [`(quote ,val) + (let ([val (unwrap val)]) + (or (symbol? val) + (keyword? val) + (boolean-or-fixnum? val)))] + [`,val + (let ([val (unwrap val)]) + ;; Booleans and numbers don't have to be quuted + (boolean-or-fixnum? val))])) + +(define (boolean-or-fixnum? val) + (boolean? val) + (and (integer? val) + (exact? val) + ;; Always fixnum? Conversatively... + (<= (- (expt 2 16)) val (expt 2 16)))) + +(define (equal-implies-eqv? e) + (match e + [`(quote ,val) + (let ([val (unwrap val)]) + (or (number? val) + (char? val)))] + [`,val + (let ([val (unwrap val)]) + (number? val))])) diff --git a/racket/src/schemify/export.rkt b/racket/src/schemify/export.rkt new file mode 100644 index 0000000000..82151009d1 --- /dev/null +++ b/racket/src/schemify/export.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(provide (struct-out export)) + +(struct export (id ext-id)) diff --git a/racket/src/schemify/find-definition.rkt b/racket/src/schemify/find-definition.rkt new file mode 100644 index 0000000000..f21cead806 --- /dev/null +++ b/racket/src/schemify/find-definition.rkt @@ -0,0 +1,94 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "struct-type-info.rkt" + "optimize.rkt" + "infer-known.rkt") + +(provide find-definitions) + +;; Record top-level functions and structure types, and returns +;; (values knowns struct-type-info-or-#f) +(define (find-definitions v prim-knowns knowns imports mutated optimize?) + (match v + [`(define-values (,id) ,orig-rhs) + (define rhs (if optimize? + (optimize orig-rhs prim-knowns knowns imports mutated) + orig-rhs)) + (values + (let ([k (infer-known rhs v #t id knowns prim-knowns imports mutated)]) + (if k + (hash-set knowns (unwrap id) k) + knowns)) + #f)] + [`(define-values (,struct:s ,make-s ,s? ,acc/muts ...) ; pattern from `struct` or `define-struct` + (let-values (((,struct: ,make ,? ,-ref ,-set!) ,rhs)) + (values ,struct:2 + ,make2 + ,?2 + ,make-acc/muts ...))) + (define info (and (wrap-eq? struct: struct:2) + (wrap-eq? make make2) + (wrap-eq? ? ?2) + (make-struct-type-info rhs prim-knowns knowns imports mutated))) + (cond + [info + (define type (gensym (symbol->string (unwrap make-s)))) + (let* ([knowns (hash-set knowns + (unwrap make-s) + (if (struct-type-info-pure-constructor? info) + (known-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type) + a-known-constant))] + [knowns (hash-set knowns + (unwrap s?) + (known-predicate 2 type))] + [knowns + (for/fold ([knowns knowns]) ([id (in-list acc/muts)] + [maker (in-list make-acc/muts)]) + (cond + [(wrap-eq? (wrap-car maker) -ref) + (hash-set knowns (unwrap id) (known-accessor 2 type))] + [else + (hash-set knowns (unwrap id) (known-mutator 4 type))]))]) + (values (hash-set knowns (unwrap struct:s) (known-struct-type type + (struct-type-info-field-count info) + (struct-type-info-pure-constructor? info))) + info))] + [else (values knowns #f)])] + [`(define-values (,struct:s ,make-s ,s? ,s-ref ,s-set!) ,rhs) ; direct use of `make-struct-type` + (define info (make-struct-type-info rhs prim-knowns knowns imports mutated)) + (cond + [info + (define type (gensym (symbol->string (unwrap make-s)))) + (values + (let* ([knowns (hash-set knowns + (unwrap make-s) + (if (struct-type-info-pure-constructor? info) + (known-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type) + a-known-constant))] + [knowns (hash-set knowns + (unwrap s?) + (known-predicate 2 type))]) + ;; For now, we don't try to track the position-consuming accessor or mutator + (hash-set knowns (unwrap struct:s) (known-struct-type type + (struct-type-info-field-count info) + (struct-type-info-pure-constructor? info)))) + info)] + [else (values knowns #f)])] + [`(define-values (,prop:s ,s? ,s-ref) + (make-struct-type-property ,_ . ,rest)) + (define type (gensym (symbol->string prop:s))) + (values + (let* ([knowns (hash-set knowns (unwrap s-ref) (known-accessor 2 type))] + [knowns (hash-set knowns (unwrap s?) (known-predicate 2 type))]) + ;; Check whether the property type has an immediate (or no) guard: + (cond + [(or (null? (unwrap rest)) + (and (not (wrap-car rest)) + (null? (unwrap (wrap-cdr rest))))) + (hash-set knowns (unwrap prop:s) (known-struct-type-property/immediate-guard))] + [else knowns])) + #f)] + [`,_ (values knowns #f)])) diff --git a/racket/src/schemify/find-known.rkt b/racket/src/schemify/find-known.rkt new file mode 100644 index 0000000000..01fb5fd480 --- /dev/null +++ b/racket/src/schemify/find-known.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(require "wrap.rkt" + "import.rkt" + "known.rkt" + "mutated-state.rkt") + +(provide find-known) + +(define (find-known key prim-knowns knowns imports mutated) + (cond + [(hash-ref prim-knowns key #f) + => (lambda (k) k)] + [(hash-ref-either knowns imports key) + => (lambda (k) + (and (simple-mutated-state? (hash-ref mutated key #f)) + (if (known-copy? k) + (find-known (unwrap (known-copy-id k)) prim-knowns knowns imports mutated) + k)))] + [else #f])) diff --git a/racket/src/schemify/import.rkt b/racket/src/schemify/import.rkt new file mode 100644 index 0000000000..fce0d0f9db --- /dev/null +++ b/racket/src/schemify/import.rkt @@ -0,0 +1,105 @@ +#lang racket/base +(provide (struct-out import) + (struct-out import-group) + + import-group-lookup-ready? + + import-group-lookup + import-lookup + + hash-ref-either + + make-add-import!) + +(struct import (grp id int-id ext-id)) +(struct import-group (index + key + [knowns/proc #:mutable] ; starts as a procedure to get table + [converter #:mutable] ; converts table entries to `known`s (i.e., lazy conversion) + [import-keys #:mutable] ; vector of imports, used for inlining + [imports #:mutable])) ; starts as declared imports, but inlining can grow + +(define (import-group-knowns grp) + (define knowns/proc (import-group-knowns/proc grp)) + (cond + [(procedure? knowns/proc) + (define-values (knowns converter import-keys) (knowns/proc (import-group-key grp))) + (define knowns-or-empty (or knowns (hasheq))) + (set-import-group-knowns/proc! grp knowns-or-empty) + (set-import-group-converter! grp converter) + (set-import-group-import-keys! grp import-keys) + knowns-or-empty] + [else knowns/proc])) + +(define (import-group-lookup-ready? grp) + (define knowns/proc (import-group-knowns/proc grp)) + (not (procedure? knowns/proc))) + +(define (import-group-lookup g id) + (define v (hash-ref (import-group-knowns g) id #f)) + (if v + (let ([converter (import-group-converter g)]) + (if converter + (converter v) + v)) + v)) + +(define (import-lookup im) + (import-group-lookup (import-grp im) (import-ext-id im))) + +(define (hash-ref-either knowns imports key) + (or (hash-ref knowns key #f) + (let ([im (hash-ref imports key #f)]) + (and im + (import-lookup im))))) + +(define (make-add-import! imports grps get-import-knowns add-group!) + (define next-index (length grps)) + (lambda (im ext-id index) + ;; The `im` argument represents an import into the current + ;; linklet. Let L be the linklet for that import. Map `ext-id` as + ;; either defined in L (if `index` is #f) or imported into L from + ;; its `index`th group to a new name in the current module, + ;; potentially adding an import or import group to the current module. + (define grp (import-grp im)) + (cond + [index + (import-group-knowns grp) ; force thunk + (define import-keys (import-group-import-keys grp)) + (define key (and import-keys (vector-ref import-keys index))) + (and key ; no key available => can't inline + (let ([from-grp (find-or-add-import-group! grps key + get-import-knowns + add-group! + next-index + (lambda () (set! next-index (add1 next-index))))]) + (and from-grp + (find-or-add-import-from-group! from-grp ext-id imports))))] + [else + (find-or-add-import-from-group! grp ext-id imports)]))) + +(define (find-or-add-import-from-group! grp ext-id imports) + (or (for/or ([im (in-list (import-group-imports grp))]) + (and (eq? ext-id (import-ext-id im)) + (import-int-id im))) + ;; `ext-id` from the group is not currently imported; add it as an import + (let ([id (gensym ext-id)] + [int-id (gensym ext-id)]) + (define im (import grp id int-id ext-id)) + (set-import-group-imports! grp (cons im (import-group-imports grp))) + (hash-set! imports int-id im) + int-id))) + +(define (find-or-add-import-group! grps key get-import-knowns add-group! next-index inc-index!) + (or (for/or ([grp (in-list grps)]) + (and (eq? key (import-group-key grp)) + grp)) + ;; The current linklet doesn't currently import from the linklet + ;; that supplies an identifier to be inlined; add the linklet + ;; as a new import group + (let ([grp (import-group next-index key + get-import-knowns #f #f + '())]) + (inc-index!) + (add-group! grp) + grp))) diff --git a/racket/src/schemify/infer-known.rkt b/racket/src/schemify/infer-known.rkt new file mode 100644 index 0000000000..ae6a44377c --- /dev/null +++ b/racket/src/schemify/infer-known.rkt @@ -0,0 +1,115 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "simple.rkt" + "pthread-parameter.rkt" + "literal.rkt" + "inline.rkt" + "mutated-state.rkt") + +(provide infer-known + lambda?) + +;; For definitions, it's useful to infer `a-known-constant` to reflect +;; that the variable will get a value without referencing anything +;; too early. +(define (infer-known rhs defn rec? id knowns prim-knowns imports mutated) + (cond + [(lambda? rhs) + (define-values (lam inlinable?) (extract-lambda rhs)) + (define arity-mask (lambda-arity-mask lam)) + (if (and inlinable? + (or (can-inline? lam) + (wrap-property defn 'compiler-hint:cross-module-inline))) + (known-procedure/can-inline arity-mask lam) + (known-procedure arity-mask))] + [(and (literal? rhs) + (not (hash-ref mutated (unwrap id) #f))) + (known-literal (unwrap-literal rhs))] + [(and (symbol? (unwrap rhs)) + (not (hash-ref mutated (unwrap id) #f))) + (define u-rhs (unwrap rhs)) + (cond + [(hash-ref prim-knowns u-rhs #f) + => (lambda (known) (known-copy u-rhs))] + [(not (simple-mutated-state? (hash-ref mutated u-rhs #f))) + ;; referenced variable is mutated, but not necessarily the target + (and defn a-known-constant)] + [(hash-ref-either knowns imports u-rhs) + => (lambda (known) + (cond + [(known-procedure/can-inline/need-imports? known) + ;; can't just return `known`, since that loses the connection to the import; + ;; the `inline-clone` function specially handles an identifier as the + ;; expression to inline + (known-procedure/can-inline (known-procedure-arity-mask known) + rhs)] + [(or (known-procedure/can-inline? known) + (known-literal? known)) + known] + [(not defn) + (known-copy rhs)] + [else known]))] + [defn a-known-constant] + [else (known-copy rhs)])] + [(pthread-parameter? rhs prim-knowns knowns mutated) + (known-procedure 3)] + [(and defn + (simple? rhs prim-knowns knowns imports mutated)) + a-known-constant] + [else #f])) + +;; ---------------------------------------- + +;; Recognize forms that produce plain procedures +(define (lambda? v #:simple? [simple? #f]) + (match v + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`(let-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs)) + (lambda? body))] + [`(letrec-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs)) + (lambda? body))] + [`(let-values ,_ ,body) (and (not simple?) (lambda? body))] + [`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))] + [`(begin ,body) (lambda? body)] + [`(values ,body) (lambda? body)] + [`,_ #f])) + +;; Recognize forms that produce plain procedures +(define (extract-lambda v) + (match v + [`(lambda . ,_) (values v #t)] + [`(case-lambda . ,_) (values v #t)] + [`(let-values ([(,id) ,rhs]) ,body) + (if (wrap-eq? id body) + (extract-lambda rhs) + (extract-lambda* body))] + [`(letrec-values ([(,id) ,rhs]) ,body) + (if (wrap-eq? id body) + (extract-lambda rhs) + (extract-lambda* body))] + [`(let-values ,_ ,body) (extract-lambda* body)] + [`(letrec-values ,_ ,body) (extract-lambda* body)] + [`(begin ,body) (extract-lambda body)] + [`(values ,body) (extract-lambda body)])) + +(define (extract-lambda* v) + (define-values (lam inlinable?) (extract-lambda v)) + (values lam #f)) + +(define (lambda-arity-mask v) + (match v + [`(lambda ,args . ,_) (args-arity-mask args)] + [`(case-lambda [,argss . ,_] ...) + (for/fold ([mask 0]) ([args (in-list argss)]) + (bitwise-ior mask (args-arity-mask args)))])) + +(define (args-arity-mask args) + (cond + [(wrap-null? args) 1] + [(wrap-pair? args) + (arithmetic-shift (args-arity-mask (wrap-cdr args)) 1)] + [else -1])) diff --git a/racket/src/schemify/inline.rkt b/racket/src/schemify/inline.rkt new file mode 100644 index 0000000000..8bfe5d2d6c --- /dev/null +++ b/racket/src/schemify/inline.rkt @@ -0,0 +1,279 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "export.rkt") + +(provide init-inline-fuel + can-inline? + inline-clone + known-inline->export-known) + +(define inline-base 3) +(define inline-factor 3) +(define init-inline-fuel 8) + +(define (can-inline? v) + (match v + [`(lambda ,args . ,bodys) + (smaller-than? bodys (+ inline-base (* inline-factor (args-size args))))] + [`(case-lambda [,argss . ,bodyss] ...) + (for/and ([args (in-list argss)] + [bodys (in-list bodyss)]) + (smaller-than? bodys (+ inline-base (* inline-factor (args-size args)))))] + [`,_ #f])) + +(define (args-size args) + (cond + [(wrap-pair? args) (+ 1 (args-size (wrap-cdr args)))] + [else 1])) + +(define (smaller-than? v size) + (positive? + (let loop ([v v] [size size]) + (cond + [(zero? size) 0] + [(wrap-pair? v) + (loop (wrap-cdr v) (loop (wrap-car v) size))] + [else (sub1 size)])))) + +;; ---------------------------------------- + +;; All binding identifiers in a clone must be fresh to stay consistent +;; with the unique-variable invariant of expanded/schemified form. + +(define (inline-clone k im add-import! mutated imports reannotate) + (define env (if (known-procedure/can-inline/need-imports? k) + ;; The `needed->env` setup can fail if a needed + ;; import cannot be made available: + (needed->env (known-procedure/can-inline/need-imports-needed k) + add-import! + im) + '())) + (and + env + (match (known-procedure/can-inline-expr k) + [`(lambda ,args . ,bodys) + (define-values (new-args new-env) (clone-args args env mutated)) + `(lambda ,new-args . ,(clone-body bodys new-env mutated reannotate))] + [`(case-lambda [,argss . ,bodyss] ...) + `(case-lambda ,@(for/list ([args (in-list argss)] + [bodys (in-list bodyss)]) + (define-values (new-args new-env) (clone-args args env mutated)) + `[,new-args . ,(clone-body bodys new-env mutated reannotate)]))] + [`,id + ;; We expect `id` to refer to an imported variable, where inlining the + ;; imported variable will need to pull from there + (cond + [(hash-ref imports (unwrap id) #f) + => (lambda (im) + (define i-k (import-lookup im)) + (and (known-procedure/can-inline? i-k) + (inline-clone i-k im add-import! mutated imports reannotate)))] + [else #f])]))) + +;; Build a mapping from ids in the expr to imports into the current +;; linklet, where `add-import!` arranges for the import to exist as +;; needed and if possible. The result is #f if some import cannot be +;; made available. +(define (needed->env needed add-import! im) + (for/fold ([env '()]) ([need (in-list needed)]) + (and env + (let ([id (add-import! im (cadr need) (cddr need))]) + (and id + (cons (cons (car need) id) env)))))) + +(define (clone-args args base-env mutated) + (define env + (let loop ([args args]) + (cond + [(wrap-null? args) base-env] + [(wrap-pair? args) + (define u (unwrap (wrap-car args))) + (define g (gensym u)) + (define m (hash-ref mutated u #f)) + (when m + (hash-set! mutated g m)) + (cons (cons u g) + (loop (wrap-cdr args)))] + [else + (define u (unwrap args)) + (list (cons u (gensym u)))]))) + (values (let loop ([args args] [env env]) + (cond + [(wrap-null? args) '()] + [(wrap-pair? args) + (define u (unwrap (wrap-car args))) + (cons (cdr (car env)) + (loop (wrap-cdr args) (cdr env)))] + [else + (cdr (car env))])) + env)) + +(define (clone-body l env mutated reannotate) + (for/list ([e (in-wrap-list l)]) + (clone-expr e env mutated reannotate))) + +(define (clone-let v env mutated reannotate) + (match v + [`(,let-id ([,idss ,rhss] ...) ,bodys ...) + (define-values (rev-new-idss new-env) + (for/fold ([rev-new-idss null] [env env]) ([ids (in-list idss)]) + (define-values (new-ids new-env) (clone-args ids env mutated)) + (values (cons new-ids rev-new-idss) new-env))) + `(,let-id ,(for/list ([ids (in-list (reverse rev-new-idss))] + [rhs (in-list rhss)]) + `[,ids ,(clone-expr rhs new-env mutated reannotate)]) + . ,(clone-body bodys new-env mutated reannotate))])) + +(define (clone-expr v env mutated reannotate) + (reannotate + v + (match v + [`(lambda ,args . ,bodys) + `(lambda ,args . ,(clone-body bodys env mutated reannotate))] + [`(case-lambda [,argss . ,bodyss] ...) + `(case-lambda ,@(for/list ([args (in-list argss)] + [bodys (in-list bodyss)]) + `[,args . ,(clone-body bodys env mutated reannotate)]))] + [`(quote ,_) v] + [`(let-values . ,_) (clone-let v env mutated reannotate)] + [`(letrec-values . ,_) (clone-let v env mutated reannotate)] + [`(if ,tst ,thn ,els) + `(if ,(clone-expr tst env mutated reannotate) + ,(clone-expr thn env mutated reannotate) + ,(clone-expr els env mutated reannotate))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(clone-expr key env mutated reannotate) + ,(clone-expr val env mutated reannotate) + ,(clone-expr body env mutated reannotate))] + [`(begin ,exps ...) + `(begin . ,(clone-body exps env mutated reannotate))] + [`(begin0 ,exps ...) + `(begin0 . ,(clone-body exps env mutated reannotate))] + [`(set! ,id ,rhs) + `(set! ,id ,(clone-expr rhs env mutated reannotate))] + [`(#%variable-reference) v] + [`(#%variable-reference ,id) + `(#%variable-reference ,(clone-expr id env mutated reannotate))] + [`(,rator . ,_) + (clone-body v env mutated reannotate)] + [`,_ + (let ([u-v (unwrap v)]) + (cond + [(symbol? u-v) + (lookup env u-v v)] + [else v]))]))) + +(define (lookup env sym default) + (cond + [(null? env) default] + [(eq? (caar env) sym) + (cdar env)] + [else (lookup (cdr env) sym default)])) + +;; ---------------------------------------- + +(define (known-inline->export-known k prim-knowns imports exports) + (cond + [(known-procedure/can-inline? k) + (define needed + (needed-imports (known-procedure/can-inline-expr k) prim-knowns imports exports '() '#hasheq())) + (cond + [(not needed) (known-procedure (known-procedure-arity-mask k))] + [(hash-empty? needed) k] + [else + (known-procedure/can-inline/need-imports + (known-procedure-arity-mask k) + (known-procedure/can-inline-expr k) + (for/list ([(k v) (in-hash needed)]) + (cons k v)))])] + [else k])) + +(define (needed-imports v prim-knowns imports exports env needed) + (and + needed + (match v + [`(lambda ,args . ,bodys) + (body-needed-imports bodys prim-knowns imports exports (add-args env args) needed)] + [`(case-lambda [,argss . ,bodyss] ...) + (for/fold ([needed needed]) ([args (in-list argss)] + [bodys (in-list bodyss)]) + (body-needed-imports bodys prim-knowns imports exports (add-args env args) needed))] + [`(quote ,_) needed] + [`(let-values . ,_) (let-needed-imports v prim-knowns imports exports env needed)] + [`(letrec-values . ,_) (let-needed-imports v prim-knowns imports exports env needed)] + [`(if ,tst ,thn ,els) + (needed-imports tst prim-knowns imports exports env + (needed-imports thn prim-knowns imports exports env + (needed-imports els prim-knowns imports exports env + needed)))] + [`(with-continuation-mark ,key ,val ,body) + (needed-imports key prim-knowns imports exports env + (needed-imports val prim-knowns imports exports env + (needed-imports body prim-knowns imports exports env + needed)))] + [`(begin ,exps ...) + (body-needed-imports exps prim-knowns imports exports env needed)] + [`(begin0 ,exps ...) + (body-needed-imports exps prim-knowns imports exports env needed)] + [`(set! ,id ,rhs) + (define u (unwrap id)) + (cond + [(hash-ref exports id #f) + ;; Cannot inline assignment to an exported variable + #f] + [else + (needed-imports id prim-knowns imports exports env + (needed-imports rhs prim-knowns imports exports env + needed))])] + [`(#%variable-reference . ,_) + ;; Cannot inline a variable reference + #f] + [`(,rator . ,_) + (body-needed-imports v prim-knowns imports exports env needed)] + [`,_ + (let ([u-v (unwrap v)]) + (cond + [(symbol? u-v) + (cond + [(or (memq u-v env) + (hash-ref prim-knowns u-v #f) + (hash-ref needed u-v #f)) + needed] + [(hash-ref exports u-v #f) + => (lambda (ex) + (hash-set needed u-v (cons (export-ext-id ex) #f)))] + [(hash-ref imports u-v #f) + => (lambda (im) + (hash-set needed u-v (cons (import-ext-id im) + (import-group-index (import-grp im)))))] + [else + ;; Free variable (possibly defined but not exported) => cannot inline + #f])] + [else needed]))]))) + +(define (body-needed-imports l prim-knowns imports exports env needed) + (for/fold ([needed needed]) ([e (in-wrap-list l)]) + (needed-imports e prim-knowns imports exports env needed))) + +(define (let-needed-imports v prim-knowns imports exports env needed) + (match v + [`(,let-id ([,idss ,rhss] ...) ,bodys ...) + (define new-env (for*/fold ([env env]) ([ids (in-list idss)] + [id (in-list ids)]) + (cons (unwrap id) env))) + (body-needed-imports bodys prim-knowns imports exports new-env + (for/fold ([needed needed]) ([rhs (in-list rhss)]) + (needed-imports rhs prim-knowns imports exports new-env + needed)))])) + +(define (add-args env args) + (cond + [(wrap-null? args) env] + [(wrap-pair? args) + (add-args (cons (unwrap (wrap-car args)) env) + (wrap-cdr args))] + [else + (cons (unwrap args) env)])) diff --git a/racket/src/schemify/interp-match.rkt b/racket/src/schemify/interp-match.rkt new file mode 100644 index 0000000000..e502c6855e --- /dev/null +++ b/racket/src/schemify/interp-match.rkt @@ -0,0 +1,41 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/unsafe/ops) + +;; All patterns for an interpreter matcher are vectors, +;; and each vector element is an unquote or a symbol +;; to match literally. + +(provide interp-match) + +(define-syntax interp-match + (syntax-rules () + [(_ e) + (let ([v e]) + (error 'interp-match "no matching clause"))] + [(_ e [pat . rhs] . clauses) + (let ([v e]) + (if (matches? v pat) + (let-vars v pat . rhs) + (interp-match v . clauses)))])) + +(define-syntax (matches? stx) + (syntax-case stx () + [(_ v #(elem ...)) + #`(and #,@(for/list ([e (in-list (syntax->list #'(elem ...)))] + [i (in-naturals)]) + (syntax-case e (unquote) + [,id #'#t] + [s #`(eq? 's (unsafe-vector*-ref v #,i))])))])) + +(define-syntax (let-vars stx) + (syntax-case stx () + [(_ v #(elem ...) . body) + #`(let #,(for/list ([e (in-list (syntax->list #'(elem ...)))] + [i (in-naturals)] + #:when (syntax-case e (unquote) + [,id #t] + [_ #f])) + (syntax-case e (unquote) + [,id #`[id (unsafe-vector*-ref v #,i)]])) + . body)])) diff --git a/racket/src/schemify/interpret.rkt b/racket/src/schemify/interpret.rkt new file mode 100644 index 0000000000..dcd6cb2441 --- /dev/null +++ b/racket/src/schemify/interpret.rkt @@ -0,0 +1,480 @@ +#lang racket/base +(require racket/unsafe/undefined + racket/unsafe/ops + "match.rkt" + "wrap.rkt" + "interp-match.rkt") + +;; Interpreter for the output of "jitify". This little interpreter is +;; useful to avoid going through a more heavyweight `eval` or +;; `interpret`, mainly because we don't need to go through a macro +;; expander. Also, because it's tailored to the shape of a linklet +;; outer layer, it can implement that layer more efficiently and +;; compactly. + +(provide interpretable-jitified-linklet + interpret-linklet) + +(struct indirect (stack element)) +(struct indirect-checked indirect ()) + +(define (interpretable-jitified-linklet linklet-e strip-annotations) + ;; Return a compiled linklet in two parts: a vector expression for + ;; constants to be run once, and a expression for the linklet body. + ;; A compiled expression uses a list as a stack for local variables, + ;; where the coldest element is is a vector of constants, and the + ;; 1th slot is a vector of linklet arguments for imports and + ;; exports, and the 2nd slot is a vector for top-level variables. We + ;; don't have to worry about continuations, because linklet bodies + ;; are constrained. + ;; + ;; Bindings in the environment are represented as positions that + ;; count from the coldest end of the stack; that position relative + ;; to the hottest end can be computed from the current stack depth. + + (define (stack->pos stack-depth i) + (- stack-depth i 1)) + + (define (start linklet-e) + (match linklet-e + [`(lambda . ,_) + ;; No constants: + (define-values (compiled-body num-body-vars) + (compile-linklet-body linklet-e '#hasheq() 0)) + (vector #f + num-body-vars + compiled-body)] + [`(let* ,bindings ,body) + (let loop ([bindings bindings] [pos 0] [env '#hasheq()] [accum '()]) + (cond + [(null? bindings) + (define-values (compiled-body num-body-vars) + (compile-linklet-body body env 1)) + (vector (list->vector (reverse accum)) + num-body-vars + compiled-body)] + [else + (let ([binding (car bindings)]) + (loop (cdr bindings) + (add1 pos) + (hash-set env (car binding) (indirect 0 pos)) + (cons (compile-expr (cadr binding) env 1) + accum)))]))])) + + (define (compile-linklet-body v env stack-depth) + (match v + [`(lambda ,args . ,body) + (define args-env + (for/fold ([env env]) ([arg (in-list args)] + [i (in-naturals)]) + (hash-set env arg (indirect stack-depth i)))) + (define body-vars-index (add1 stack-depth)) + (define-values (body-env num-body-vars) + (for/fold ([env args-env] [num-body-vars 0]) ([e (in-wrap-list body)]) + (let loop ([e e] [env env] [num-body-vars num-body-vars]) + (match e + [`(define ,id . ,_) + (values (hash-set env (unwrap id) (indirect body-vars-index num-body-vars)) + (add1 num-body-vars))] + [`(define-values ,ids . ,_) + (for/fold ([env env] [num-body-vars num-body-vars]) ([id (in-wrap-list ids)]) + (values (hash-set env (unwrap id) (indirect body-vars-index num-body-vars)) + (add1 num-body-vars)))] + [`(begin . ,body) + (for/fold ([env env] [num-body-vars num-body-vars]) ([e (in-wrap-list body)]) + (loop e env num-body-vars))] + [`,_ (values env num-body-vars)])))) + (values (compile-top-body body body-env (+ 2 stack-depth)) + num-body-vars)])) + + ;; Like `compile-body`, but flatten top-level `begin`s + (define (compile-top-body body env stack-depth) + (define bs (let loop ([body body]) + (match body + [`() '()] + [`((begin ,subs ...) . ,rest) + (loop (append subs rest))] + [`(,e . ,rest) + (cons (compile-expr e env stack-depth) + (loop rest))]))) + (cond + [(null? bs) '#(void)] + [(and (pair? bs) (null? (cdr bs))) + (car bs)] + [else + (list->vector (cons 'begin bs))])) + + (define (compile-body body env stack-depth) + (match body + [`(,e) (compile-expr e env stack-depth)] + [`,_ + (list->vector + (cons 'begin + (for/list ([e (in-wrap-list body)]) + (compile-expr e env stack-depth))))])) + + (define (compile-expr e env stack-depth) + (match e + [`(lambda ,ids . ,body) + (define-values (body-env count rest?) + (args->env ids env stack-depth)) + (vector 'lambda (count->mask count rest?) (compile-body body body-env (+ stack-depth count)))] + [`(case-lambda [,idss . ,bodys] ...) + (define lams (for/list ([ids (in-list idss)] + [body (in-list bodys)]) + (compile-expr `(lambda ,ids . ,body) env stack-depth))) + (define mask (for/fold ([mask 0]) ([lam (in-list lams)]) + (bitwise-ior mask (interp-match lam [#(lambda ,mask) mask])))) + (list->vector (list* 'case-lambda mask lams))] + [`(let ([,ids ,rhss] ...) . ,body) + (define len (length ids)) + (define body-env + (for/fold ([env env]) ([id (in-list ids)] + [i (in-naturals)]) + (hash-set env (unwrap id) (+ stack-depth i)))) + (vector 'let + (for/vector #:length len ([rhs (in-list rhss)]) + (compile-expr rhs env stack-depth)) + (compile-body body body-env (+ stack-depth len)))] + [`(letrec . ,_) (compile-letrec e env stack-depth)] + [`(letrec* . ,_) (compile-letrec e env stack-depth)] + [`(begin . ,vs) + (compile-body vs env stack-depth)] + [`(begin0 ,e . ,vs) + (vector 'begin0 (compile-expr e env stack-depth) (compile-body vs env stack-depth))] + [`(pariah ,e) + (compile-expr e env stack-depth)] + [`(if ,tst ,thn ,els) + (vector 'if + (compile-expr tst env stack-depth) + (compile-expr thn env stack-depth) + (compile-expr els env stack-depth))] + [`(with-continuation-mark ,key ,val ,body) + (vector 'wcm + (compile-expr key env stack-depth) + (compile-expr val env stack-depth) + (compile-expr body env stack-depth))] + [`(quote ,v) + (let ([v (strip-annotations v)]) + ;; Protect with `quote` any value that looks like an + ;; interpreter instruction: + (if (or (vector? v) + (pair? v) + (symbol? v) + (number? v)) + (vector 'quote v) + v))] + [`(set! ,id ,rhs) + (compile-assignment id rhs env stack-depth)] + [`(define ,id ,rhs) + (compile-assignment id rhs env stack-depth)] + [`(define-values ,ids ,rhs) + (define gen-ids (for/list ([id (in-list ids)]) + (gensym id))) + (compile-expr `(call-with-values (lambda () ,rhs) + (lambda ,gen-ids + ,@(if (null? ids) + '((void)) + (for/list ([id (in-list ids)] + [gen-id (in-list gen-ids)]) + `(set! ,id ,gen-id))))) + env + stack-depth)] + [`(call-with-values ,proc1 (lambda ,ids . ,body)) + (compile-expr `(call-with-values ,proc1 (case-lambda + [,ids . ,body])) + env + stack-depth)] + [`(call-with-values (lambda () . ,body) (case-lambda [,idss . ,bodys] ...)) + (vector 'cwv + (compile-body body env stack-depth) + (for/list ([ids (in-list idss)] + [body (in-list bodys)]) + (define-values (new-env count rest?) + (args->env ids env stack-depth)) + (vector (count->mask count rest?) + (compile-body body new-env (+ stack-depth count)))))] + [`(variable-set! ,dest-id ,e ',constance) + (define dest-var (hash-ref env (unwrap dest-id))) + (vector 'set-variable! + (stack->pos stack-depth (indirect-stack dest-var)) (indirect-element dest-var) + (compile-expr e env stack-depth) + constance)] + [`(variable-ref ,id) + (define var (hash-ref env (unwrap id))) + (vector 'ref-variable/checked (stack->pos stack-depth (indirect-stack var)) (indirect-element var))] + [`(variable-ref/no-check ,id) + (define var (hash-ref env (unwrap id))) + (vector 'ref-variable (stack->pos stack-depth (indirect-stack var)) (indirect-element var))] + [`(#%app ,_ ...) (compile-apply (wrap-cdr e) env stack-depth)] + [`(,rator ,_ ...) (compile-apply e env stack-depth)] + [`,id + (define u (unwrap id)) + (define var (hash-ref env u #f)) + (cond + [(not var) + (if (number? u) + (vector 'quote u) + u)] + [(indirect? var) + (define pos (stack->pos stack-depth (indirect-stack var))) + (define elem (indirect-element var)) + (if (indirect-checked? var) + (vector 'ref-indirect/checked pos elem u) + (cons pos elem))] + [else + (stack->pos stack-depth var)])])) + + (define (compile-letrec e env stack-depth) + (match e + [`(,_ ([,ids ,rhss] ...) . ,body) + (define (make-env indirect) + (for/fold ([env env]) ([id (in-list ids)] + [i (in-naturals)]) + (hash-set env (unwrap id) (indirect stack-depth i)))) + (define rhs-env (make-env indirect-checked)) + (define body-env (make-env indirect)) + (define body-stack-depth (add1 stack-depth)) + (vector 'letrec + (for/vector #:length (length ids) ([rhs (in-list rhss)]) + (compile-expr rhs rhs-env body-stack-depth)) + (compile-body body body-env body-stack-depth))])) + + (define (compile-apply es env stack-depth) + (list->vector (cons 'app + (for/list ([e (in-wrap-list es)]) + (compile-expr e env stack-depth))))) + + (define (compile-assignment id rhs env stack-depth) + (define compiled-rhs (compile-expr rhs env stack-depth)) + (define u (unwrap id)) + (define var (hash-ref env u)) + (cond + [(indirect? var) + (define s (stack->pos stack-depth (indirect-stack var))) + (define e (indirect-element var)) + (if (indirect-checked? var) + (vector 'set!-indirect/checked s e compiled-rhs u) + (vector 'set!-indirect s e compiled-rhs))] + [else (error 'compile "unexpected set!")])) + + (define (args->env ids env stack-depth) + (let loop ([ids ids] [env env] [count 0]) + (cond + [(wrap-null? ids) (values env count #f)] + [(wrap-pair? ids) (loop (wrap-cdr ids) + (hash-set env (unwrap (wrap-car ids)) (+ stack-depth count)) + (add1 count))] + [else + (values (hash-set env (unwrap ids) (+ stack-depth count)) + (add1 count) + #t)]))) + + (start linklet-e)) + +;; ---------------------------------------- + +(define (interpret-linklet b primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure) + (interp-match + b + [#(,consts ,num-body-vars ,b) + (let ([consts (and consts + (let ([vec (make-vector (vector-length consts))]) + (define stack (list vec)) + (for ([b (in-vector consts)] + [i (in-naturals)]) + (vector-set! vec i (interpret-expr b stack primitives void void void void)) + vec) + vec))]) + (lambda args + (define body-vec (make-vector num-body-vars unsafe-undefined)) + (define base-stack (if consts (list consts) null)) + (define stack (list* body-vec (list->vector args) base-stack)) + (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure)))])) + +(define (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set! + make-arity-wrapper-procedure) + (define (interpret b stack) + (cond + [(integer? b) (list-ref stack b)] + [(pair? b) (vector-ref (list-ref stack (car b)) (cdr b))] + [(symbol? b) (hash-ref primitives b)] + [(vector? b) + (interp-match + b + [#(app ,rator-b) + (define len (vector-length b)) + (define rator (interpret rator-b stack)) + (cond + [(eq? len 2) + (rator)] + [(eq? len 3) + (rator + (interpret (unsafe-vector*-ref b 2) stack))] + [(eq? len 4) + (rator + (interpret (unsafe-vector*-ref b 2) stack) + (interpret (unsafe-vector*-ref b 3) stack))] + [else + (apply (interpret rator-b stack) + (for/list ([b (in-vector b 2)]) + (interpret b stack)))])] + [#(quote ,v) v] + [#(ref-indirect/checked ,s ,e ,name) + (define v (vector-ref (list-ref stack s) e)) + (check-not-unsafe-undefined v name)] + [#(ref-variable ,s ,e) + (variable-ref/no-check (vector-ref (list-ref stack s) e))] + [#(ref-variable/checked ,s ,e) + (variable-ref (vector-ref (list-ref stack s) e))] + [#(let ,rhss ,b) + (define len (vector-length rhss)) + (let loop ([i 0] [new-stack stack]) + (if (= i len) + (interpret b new-stack) + (loop (add1 i) (cons (interpret (unsafe-vector*-ref rhss i) stack) + new-stack))))] + [#(letrec ,rhss ,b) + (define len (vector-length rhss)) + (define frame-vec (make-vector len unsafe-undefined)) + (define new-stack (cons frame-vec stack)) + (let loop ([i 0]) + (if (= i len) + (interpret b new-stack) + (begin + (vector-set! frame-vec i (interpret (vector-ref rhss i) new-stack)) + (loop (add1 i)))))] + [#(begin) + (define last (sub1 (vector-length b))) + (let loop ([i 1]) + (if (= i last) + (interpret (unsafe-vector*-ref b i) stack) + (begin + (interpret (unsafe-vector*-ref b i) stack) + (loop (add1 i)))))] + [#(begin0 ,b0) + (define last (sub1 (unsafe-vector-length b))) + (begin0 + (interpret b0 stack) + (let loop ([i 2]) + (interpret (unsafe-vector*-ref b i) stack) + (unless (= i last) + (loop (add1 i)))))] + [#(if ,tst ,thn ,els) + (if (interpret tst stack) + (interpret thn stack) + (interpret els stack))] + [#(wcm ,key ,val ,body) + (with-continuation-mark + (interpret key stack) + (interpret val stack) + (interpret body stack))] + [#(cwv ,b ,clauses) + (define vs (call-with-values (lambda () (interpret b stack)) list)) + (define len (length vs)) + (let loop ([clauses clauses]) + (cond + [(null? clauses) (error 'call-with-values "arity error")] + [else + (interp-match + (car clauses) + [#(,mask ,b) + (if (matching-argument-count? mask len) + (interpret b (push-stack stack vs mask)) + (loop (cdr clauses)))])]))] + [#(lambda ,mask ,b) + (make-arity-wrapper-procedure + (lambda args + (if (matching-argument-count? mask (length args)) + (interpret b (push-stack stack args mask)) + (error "arity error"))) + mask + #f)] + [#(case-lambda ,mask) + (define n (vector-length b)) + (make-arity-wrapper-procedure + (lambda args + (define len (length args)) + (let loop ([i 2]) + (cond + [(= i n) (error "arity error")] + [else + (interp-match + (unsafe-vector*-ref b i) + [#(lambda ,mask ,b) + (if (matching-argument-count? mask len) + (interpret b (push-stack stack args mask)) + (loop (add1 i)))])]))) + mask + #f)] + [#(set-variable! ,s ,e ,b ,c) + (variable-set! (vector-ref (list-ref stack s) e) + (interpret b stack) + c)] + [#(set!-indirect ,s ,e ,b) + (unsafe-vector*-set! (list-ref stack s) e (interpret b stack))] + [#(set!-indirect/checked ,s ,e ,b ,name) + (define v (interpret b stack)) + (define vec (list-ref stack s)) + (check-not-unsafe-undefined/assign (unsafe-vector*-ref vec e) name) + (unsafe-vector*-set! vec e v)])] + [else b])) + + (define (matching-argument-count? mask len) + (bitwise-bit-set? mask len)) + + (interpret b stack)) + +;; mask has a single bit set or all bits above some bit +(define (push-stack stack vals mask) + (define rest? (negative? mask)) + (define count (if rest? + (integer-length mask) + (sub1 (integer-length mask)))) + (let loop ([stack stack] [vals vals] [count (if rest? (sub1 count) count)]) + (cond + [(zero? count) + (if rest? (cons vals stack) stack)] + [else + (loop (cons (car vals) stack) (cdr vals) (sub1 count))]))) + +(define (count->mask count rest?) + (arithmetic-shift (if rest? -1 1) count)) + +;; ---------------------------------------- + +(module+ main + (define primitives (hash 'list list + 'vector vector + 'add1 add1 + 'values values + 'continuation-mark-set-first continuation-mark-set-first)) + (define b + (interpretable-jitified-linklet '(let* ([s "string"]) + (lambda (x two-box) + (define other 5) + (begin + (define f (lambda (y) + (vector x y))) + (define g (case-lambda + [() no] + [ys + (vector x ys)]))) + (define-values (one two) (values 100 200)) + (variable-set! two-box two 'constant) + (letrec ([ok 'ok]) + (set! other (call-with-values (lambda () (values 71 (begin0 88 ok))) + (lambda (v q) (list q v)))) + (with-continuation-mark + 'x 'cm/x + (list (if s s #f) x ok other + (f 'vec) (g 'also-vec 'more) + one two (variable-ref two-box) + (continuation-mark-set-first #f 'x 'no)))))) + values)) + (define l (interpret-linklet b primitives unbox unbox (lambda (b v c) + (set-box! b v)) + (lambda (proc mask name) proc))) + (l 'the-x (box #f))) diff --git a/racket/src/schemify/jitify.rkt b/racket/src/schemify/jitify.rkt new file mode 100644 index 0000000000..316b4827a6 --- /dev/null +++ b/racket/src/schemify/jitify.rkt @@ -0,0 +1,771 @@ +#lang racket/base +(require "match.rkt" + "wrap.rkt") + +;; Convert `lambda`s to make them fully closed, which is compatible +;; with JIT compilation of the `lambda` or separate ahead-of-time +;; compilation (as opposed to compiling a whole linklet). + +;; If `convert-size-threashold` is #f, then every `lambda` is +;; converted. If it's a number, then only `lambda`s smaller than the +;; threshold are converted, and and no `lambda` within a converted +;; `lambda` is converted. So, supplying a numerical threshold is +;; useful for drawing a boundary between compiled and non-compiled +;; code, as opposed to a true JIT setup. + +;; An environment maps a variables that needs to be passed into the +;; closed code: +;; +;; * id -> '#:direct --- ready by the time it's needed and immutable +;; +;; * id -> expression --- rewrite access to expression +;; +;; * id -> `(self ,m) --- a reference to the enclosing function; can +;; use directly in rator position, otherwise +;; use m + +(provide jitify-schemified-linklet) + +(define (jitify-schemified-linklet v + need-extract? + convert-size-threshold ; #f or a number; see above + extractable-annotation + reannotate) + + ;; Constucts a closed `lambda` form as wrapped with + ;; `extractable-annotaton` and generates an application of + ;; `extract[-closed]-id` to the wrapped form. + (define (make-jit-on-call free-vars argss v name env) + (define ids (for/list ([id (in-hash-keys free-vars)]) + id)) + (define (extract-id m id) + (match m + [`(variable-ref ,var) var] + [`(unbox ,var) var] + [`(unbox/check-undefined ,var ,_) var] + [`(self ,m ,orig-id) orig-id] + [`(self ,m) (extract-id m id)] + [`,_ id])) + (define captures (hash-keys + ;; `extract-id` for different `id`s can produce the + ;; same `id`, so hash and then convert to a list + (for/hash ([id (in-list ids)]) + (values (extract-id (hash-ref env id) id) #t)))) + (define jitted-proc + (or (match (and name + (hash-ref free-vars (unwrap name) #f) + (hash-ref env (unwrap name) #f)) + [`(self ,m ,orig-name) + (cond + [(eq? orig-name name) + (define self-id (extract-id m name)) + `(let ([,self-id ,orig-name]) + (letrec ([,name ,v]) + ,name))] + [else #f])] + [`,_ #f]) + (match (and name + (hash-ref env (unwrap name) #f)) + [`(self . ,_) + ;; Might have a direct self-call, so use `letrec`: + `(letrec ([,name ,v]) + ,name)] + [`,_ #f]) + (cond + [name + ;; No direct self-reference, but encourage the compiler + ;; to name the procedure: + `(let ([,name ,v]) + ,name)] + [else v]))) + (define arity-mask (argss->arity-mask argss)) + (cond + [(null? captures) + (let ([e (extractable-annotation jitted-proc arity-mask name)]) + (if need-extract? + `(jitified-extract-closed ',e) + `',e))] + [else + (let ([e (extractable-annotation `(lambda ,captures + ,jitted-proc) + arity-mask + name)]) + (if need-extract? + `((jitified-extract ',e) . ,captures) + `(',e . ,captures)))])) + + ;; ---------------------------------------- + + (define (top) + ;; Match outer shape of a linklet produced by `schemify-linklet` + ;; and lift in the linklet body: + (let loop ([v v] [env #hasheq()]) + (match v + [`(lambda ,args . ,body) + (define new-body (jitify-schemified-body body (plain-add-args env args))) + (if (for/and ([old (in-list body)] + [new (in-list new-body)]) + (eq? old new)) + v + (reannotate v `(lambda ,args . ,new-body)))] + [`(let* ,bindings ,body) + (define new-body (loop body (add-bindings env bindings))) + (if (eq? body new-body) + v + (reannotate v `(let* ,bindings ,new-body)))]))) + + (define (jitify-schemified-body body env) + (define top-env + (for/fold ([env env]) ([v (in-list body)]) + (let loop ([v v] [env env]) + (match v + [`(variable-set! ,var-id ,id . ,_) + (hash-set env (unwrap id) `(variable-ref ,(unwrap var-id)))] + [`(define ,_ (begin (variable-set! ,var-id ,id . ,_) (void))) + (hash-set env (unwrap id) `(variable-ref ,(unwrap var-id)))] + [`(define ,id ,rhs) (plain-add-args env id)] + [`(define-values ,ids ,rhs) (plain-add-args env ids)] + [`(begin . ,vs) + (for/fold ([env env]) ([v (in-wrap-list vs)]) + (loop v env))] + [`,_ env])))) + (let loop ([body body]) + (for/list ([v (in-list body)]) + (match v + [`(variable-set! ,var-id ,id . ,_) v] + [`(define ,_ (begin (variable-set! ,var-id ,id . ,_) (void))) v] + [`(define ,id ,rhs) + ;; If there's a direct reference to `id` in `rhs`, then + ;; `id` must not be mutable + (define self-env (add-self top-env #hasheq() id)) + (reannotate v `(define ,id ,(jitify-top-expr rhs self-env id)))] + [`(define-values ,ids ,rhs) + (reannotate v `(define-values ,ids ,(jitify-top-expr rhs top-env #f)))] + [`(begin . ,vs) + (reannotate v `(begin . ,(loop vs)))] + [`,_ (jitify-top-expr v top-env #f)])))) + + (define (jitify-top-expr v env name) + ;; The `mutables` table doesn't track shadowing on the assumption + ;; that local variable names are sufficiently distinguished to prevent + ;; one mutable variable from polluting another in a different scope + (define mutables (find-mutable #hasheq() v #hasheq())) + (define convert-mode (init-convert-mode v)) + (define-values (new-v free) (jitify-expr v env mutables #hasheq() convert-mode name #f)) + new-v) + + ;; The `name` argument is a name to be given to the expresison `v` + ;; if it's a function. It also corresponds to a name that can be + ;; called directly, as long as it's mapped in `env` to a '(self ...) + ;; value. + ;; The `in-name` argument is the current self `name` that is in effect + ;; for the current expression. It might be mapped to '(self ...) + ;; and need to be unmapped for a more nested function. + (define (jitify-expr v env mutables free convert-mode name in-name) + (match v + [`(lambda ,args . ,body) + (define convert? (convert-mode-convert-lambda? convert-mode v)) + (define body-convert-mode (convert-mode-lambda-body-mode convert-mode convert?)) + (define self-env (if convert? + (activate-self (deactivate-self env in-name) name) + env)) + (define body-env (add-args self-env args mutables body-convert-mode)) + (define body-in-name (if convert? (or name '#:anonymous) in-name)) + (define-values (new-body lam-body-free) + (jitify-body body body-env mutables #hasheq() body-convert-mode #f body-in-name)) + (define lam-free (remove-args lam-body-free args)) + (define new-v (reannotate v `(lambda ,args . ,(mutable-box-bindings args mutables body-convert-mode + new-body)))) + (values (if (not convert?) + new-v + (make-jit-on-call lam-free (list args) new-v name self-env)) + (union-free free lam-free))] + [`(case-lambda [,argss . ,bodys] ...) + (define convert? (convert-mode-convert-lambda? convert-mode v)) + (define body-convert-mode (convert-mode-lambda-body-mode convert-mode convert?)) + (define self-env (if convert? + (activate-self (deactivate-self env in-name) name) + env)) + (define body-in-name (if convert? (or name '#:anonymous) in-name)) + (define-values (rev-new-bodys lam-free) + (for/fold ([rev-new-bodys '()] [lam-free #hasheq()]) ([args (in-list argss)] + [body (in-list bodys)]) + (define body-env (add-args self-env args mutables body-convert-mode)) + (define-values (new-body lam-body-free) + (jitify-body body body-env mutables #hasheq() body-convert-mode #f body-in-name)) + (values (cons new-body rev-new-bodys) + (union-free (remove-args lam-body-free args) + lam-free)))) + (define new-v (reannotate v + `(case-lambda + ,@(for/list ([args (in-list argss)] + [body (in-list (reverse rev-new-bodys))]) + `[,args . ,(mutable-box-bindings args mutables body-convert-mode + body)])))) + (values (if (not convert?) + new-v + (make-jit-on-call lam-free argss new-v name self-env)) + (union-free free lam-free))] + [`(let . ,_) (jitify-let v env mutables free convert-mode name in-name)] + [`(letrec . ,_) (jitify-let v env mutables free convert-mode name in-name)] + [`(letrec* . ,_) (jitify-let v env mutables free convert-mode name in-name)] + [`(begin . ,vs) + (define-values (new-body new-free) (jitify-body vs env mutables free convert-mode name in-name)) + (values (reannotate v `(begin . ,new-body)) + new-free)] + [`(begin0 ,v0 . ,vs) + (define-values (new-v0 v0-free) + (jitify-expr v0 env mutables free (convert-mode-non-tail convert-mode) name in-name)) + (define-values (new-body new-free) + (jitify-body vs env mutables v0-free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v `(begin0 ,new-v0 . ,new-body)) + new-free)] + [`(pariah ,e) + (define-values (new-e new-free) (jitify-expr e env mutables free convert-mode name in-name)) + (values (reannotate v `(pariah ,new-e)) + new-free)] + [`(if ,tst ,thn ,els) + (define sub-convert-mode (convert-mode-non-tail convert-mode)) + (define-values (new-tst new-free/tst) (jitify-expr tst env mutables free sub-convert-mode #f in-name)) + (define-values (new-thn new-free/thn) (jitify-expr thn env mutables new-free/tst convert-mode name in-name)) + (define-values (new-els new-free/els) (jitify-expr els env mutables new-free/thn convert-mode name in-name)) + (values (reannotate v `(if ,new-tst ,new-thn ,new-els)) + new-free/els)] + [`(with-continuation-mark ,key ,val ,body) + (define sub-convert-mode (convert-mode-non-tail convert-mode)) + (define-values (new-key new-free/key) (jitify-expr key env mutables free sub-convert-mode #f in-name)) + (define-values (new-val new-free/val) (jitify-expr val env mutables new-free/key sub-convert-mode #f in-name)) + (define-values (new-body new-free/body) (jitify-expr body env mutables new-free/val convert-mode name in-name)) + (values (reannotate v `(with-continuation-mark ,new-key ,new-val ,new-body)) + new-free/body)] + [`(quote ,_) (values v free)] + [`(set! ,var ,rhs) + (define-values (new-rhs new-free) (jitify-expr rhs env mutables free (convert-mode-non-tail convert-mode) var in-name)) + (define id (unwrap var)) + (define dest (hash-ref env id #f)) + (cond + [(and (not in-name) + (match dest + [`(variable-ref ,_) #t] + [`,_ #f])) + ;; Not under lambda: don't rewrite references to definitions + (values `(set! ,var ,new-rhs) + new-free)] + [else + (define newer-free (if dest + (hash-set new-free id dest) + new-free)) + (define new-v + (match (hash-ref env id '#:direct) + [`#:direct (reannotate v `(set! ,var ,new-rhs))] + [`(self ,m . ,_) (error 'set! "[internal error] self-referenceable ~s" id)] + [`(variable-ref ,var-id) (reannotate v `(variable-set! ,var-id ,new-rhs '#f))] + [`(unbox ,box-id) (reannotate v `(set-box! ,box-id ,new-rhs))] + [`(unbox/check-undefined ,box-id ,_) (reannotate v `(set-box!/check-undefined ,box-id ,new-rhs ',var))])) + (values new-v newer-free)])] + [`(call-with-values ,proc1 ,proc2) + (define proc-convert-mode (convert-mode-called convert-mode)) + (define-values (new-proc1 new-free1) (jitify-expr proc1 env mutables free proc-convert-mode #f in-name)) + (define-values (new-proc2 new-free2) (jitify-expr proc2 env mutables new-free1 proc-convert-mode #f in-name)) + (define call-with-values-id (if (and (lambda? new-proc1) (lambda? new-proc2)) + 'call-with-values + '#%call-with-values)) + (values (reannotate v `(,call-with-values-id ,new-proc1 ,new-proc2)) + new-free2)] + [`(#%app ,_ ...) + (define-values (new-vs new-free) + (jitify-body (wrap-cdr v) env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v `(#%app . ,new-vs)) + new-free)] + [`(,rator ,_ ...) + (define u (unwrap rator)) + (match (and (symbol? u) (hash-ref env u #f)) + [`(self ,_ ,orig-id) + ;; Keep self call as direct + (define-values (new-vs new-free) + (jitify-body (wrap-cdr v) env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v `(,rator . ,new-vs)) + new-free)] + [`,x + (define-values (new-vs new-free) + (jitify-body v env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (values (reannotate v new-vs) + new-free)])] + [`,var + (define id (unwrap var)) + (define dest (hash-ref env id #f)) + (cond + [(and (not in-name) + (match dest + [`(variable-ref ,_) #t] + [`,_ #f])) + ;; Not under lambda: don't rewrite references to definitions + (values var free)] + [else + (define new-var + (match dest + [`#f var] + [`#:direct var] + [`(self ,u . ,_) (reannotate v u)] + [`,u (reannotate v u)])) + (define new-free + (if dest + (hash-set free id dest) + free)) + (values new-var + new-free)])])) + + (define (lambda? v) + (match v + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`,_ #f])) + + (define (jitify-body vs env mutables free convert-mode name in-name) + (let loop ([vs vs] [free free]) + (cond + [(wrap-null? vs) (values null free)] + [(wrap-null? (wrap-cdr vs)) + (define-values (new-v new-free) + (jitify-expr (wrap-car vs) env mutables free convert-mode name in-name)) + (values (list new-v) new-free)] + [else + (define-values (new-v new-free) + (jitify-expr (wrap-car vs) env mutables free (convert-mode-non-tail convert-mode) #f in-name)) + (define-values (new-rest newer-free) + (loop (wrap-cdr vs) new-free)) + (values (cons new-v new-rest) + newer-free)]))) + + (define (jitify-let v env mutables free convert-mode name in-name) + (match v + [`(,let-form ([,ids ,rhss] ...) . ,body) + (define rec? + (and (case (unwrap let-form) + [(letrec letrec*) #t] + [else #f]) + ;; Use simpler `let` code if we're not responsible for boxing: + (convert-mode-box-mutables? convert-mode))) + (define rhs-convert-mode (convert-mode-non-tail convert-mode)) + (define rhs-env (if rec? + (add-args/unbox env ids mutables + (lambda (var) #t) + (not (for/and ([rhs (in-list rhss)]) + (lambda? rhs))) + convert-mode) + env)) + (define-values (rev-new-rhss rhs-free) + (for/fold ([rev-new-rhss '()] [free #hasheq()]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (define self-env + (if rec? + (add-self rhs-env mutables id) + rhs-env)) + (define-values (new-rhs rhs-free) + (jitify-expr rhs self-env mutables free rhs-convert-mode id in-name)) + (values (cons new-rhs rev-new-rhss) rhs-free))) + (define local-env + (add-args/unbox env ids mutables + (lambda (var) (and rec? (hash-ref rhs-free var #f))) + #f + convert-mode)) + (define-values (new-body new-free) + (jitify-body body local-env mutables (union-free free rhs-free) convert-mode name in-name)) + (define new-v + (cond + [(not rec?) + ;; Wrap boxes around rhs results as needed: + `(,let-form ,(for/list ([id (in-list ids)] + [new-rhs (in-list (reverse rev-new-rhss))]) + `[,id ,(if (and (convert-mode-box-mutables? convert-mode) + (hash-ref mutables (unwrap id) #f)) + `(box ,new-rhs) + new-rhs)]) + . ,new-body)] + [else + ;; Allocate boxes first, then fill in + `(let ,(for*/list ([id (in-list ids)] + #:when (hash-ref rhs-free (unwrap id) #f)) + `[,id (box unsafe-undefined)]) + ;; Using nested `let`s to force left-to-right + ,(for/fold ([body (body->expr new-body)]) ([id (in-list (reverse ids))] + [new-rhs (in-list rev-new-rhss)]) + `(let (,(cond + [(hash-ref rhs-free (unwrap id) #f) + `[,(gensym 'ignored) (set-box! ,id ,new-rhs)]] + [(hash-ref mutables (unwrap id) #f) + `[,id (box ,new-rhs)]] + [else `[,id ,new-rhs]])) + ,body)))])) + (values (reannotate v new-v) + (remove-args new-free ids))])) + + (define (mutable-box-bindings args mutables convert-mode body) + (cond + [(convert-mode-box-mutables? convert-mode) + (define bindings + (let loop ([args args]) + (cond + [(wrap-null? args) null] + [(wrap-pair? args) + (define id (wrap-car args)) + (define var (unwrap id)) + (define rest (loop (wrap-cdr args))) + (if (hash-ref mutables var #f) + (cons `[,id (box ,id)] rest) + rest)] + [else (loop (list args))]))) + (if (null? bindings) + body + `((let ,bindings . ,body)))] + [else body])) + + ;; ---------------------------------------- + + ;; When mutables and convert mode are not relevant: + (define (plain-add-args env args) + (define (add-one id) + (hash-set env (unwrap id) '#:direct)) + (match args + [`(,id . ,args) + (plain-add-args (add-one id) args)] + [`() env] + [`,id (add-one id)])) + + ;; Add a binding to an environment, record whether it needs + ;; to be unboxed on reference: + (define (add-args env args mutables convert-mode) + (define (add-one id) + (define u (unwrap id)) + (define val (if (and (convert-mode-box-mutables? convert-mode) + (hash-ref mutables u #f)) + `(unbox ,id) + '#:direct)) + (hash-set env u val)) + (match args + [`(,id . ,args) + (add-args (add-one id) args mutables convert-mode)] + [`() env] + [`,id (add-one id)])) + + ;; Further generalization of `add-args` to add undefined-checking + ;; variant of unbox: + (define (add-args/unbox env args mutables var-rec? maybe-undefined? convert-mode) + (define (add-one id) + (define var (unwrap id)) + (cond + [maybe-undefined? (hash-set env var `(unbox/check-undefined ,id ',id))] + [(not (or (var-rec? var) (and (convert-mode-box-mutables? convert-mode) + (hash-ref mutables var #f)))) + (hash-set env var '#:direct)] + [else (hash-set env var `(unbox ,id))])) + (match args + [`(,id . ,args) + (add-args/unbox (add-one id) args mutables var-rec? maybe-undefined? convert-mode)] + [`() env] + [`,id (add-one id)])) + + (define (remove-args env args) + (match args + [`(,id . ,args) + (remove-args (hash-remove env (unwrap id)) args)] + [`() env] + [`,id (hash-remove env (unwrap id))])) + + (define (add-bindings env bindings) + (match bindings + [`([,ids ,_] ...) + (for/fold ([env env]) ([id (in-list ids)]) + (plain-add-args env id))])) + + (define (add-self env mutables name) + (define u (unwrap name)) + (cond + [(hash-ref mutables u #f) + env] + [else + (hash-set env u `(self ,(hash-ref env u '#:direct)))])) + + ;; Adjust an environment to indicate that `name` in an application + ;; position is a self-call, which helps preserves the visiblilty of + ;; loops to a later compiler + (define (activate-self env name) + (cond + [name + (define (genself) (gensym 'self)) + (define u (unwrap name)) + (define new-m + (match (hash-ref env u #f) + [`(self #:direct) + `(self ,(genself) ,name)] + [`(self (variable-ref ,orig-id)) + `(self (variable-ref ,orig-id) ,orig-id)] + [`(self (unbox ,orig-id)) + `(self (unbox ,(genself)) ,orig-id)] + [`(self (unbox/check-undefined ,orig-id ,sym)) + `(self (unbox/check-undefined ,(genself) ,sym) ,orig-id)] + [`,_ #f])) + (if new-m + (hash-set env u new-m) + env)] + [else env])) + + ;; Adjust an environment to indicate that applying `name` is no + ;; longer a self call + (define (deactivate-self env name) + (cond + [name + (define u (unwrap name)) + (match (hash-ref env u #f) + [`(self ,m ,_) (hash-set env u m)] + [`,_ env])] + [else env])) + + ;; ---------------------------------------- + + (define (argss->arity-mask argss) + (for/fold ([mask 0]) ([args (in-list argss)]) + (bitwise-ior mask + (let loop ([args args] [count 0]) + (cond + [(wrap-null? args) (arithmetic-shift 1 count)] + [(wrap-pair? args) (loop (wrap-cdr args) (add1 count))] + [else (bitwise-xor -1 (sub1 (arithmetic-shift 1 count)))]))))) + + (define (de-dot args) + (cond + [(wrap-pair? args) (cons (wrap-car args) + (de-dot (wrap-cdr args)))] + [else (list args)])) + + (define (union-free a b) + (cond + [((hash-count b) . < . (hash-count a)) (union-free b a)] + [else + (for/fold ([b b]) ([(k v) (in-hash a)]) + (hash-set b k v))])) + + (define (body->expr body) + (cond + [(and (wrap-pair? body) (wrap-null? (wrap-cdr body))) + (wrap-car body)] + [else `(begin . ,body)])) + + ;; ---------------------------------------- + + (define (find-mutable env v accum) + (match v + [`(lambda ,args . ,body) + (body-find-mutable (plain-add-args env args) body accum)] + [`(case-lambda [,argss . ,bodys] ...) + (for/fold ([accum accum]) ([args (in-list argss)] + [body (in-list bodys)]) + (body-find-mutable (plain-add-args env args) body accum))] + [`(let . ,_) (find-mutable-in-let env v accum)] + [`(letrec . ,_) (find-mutable-in-let env v accum)] + [`(letrec* . ,_) (find-mutable-in-let env v accum)] + [`(begin . ,vs) (body-find-mutable env vs accum)] + [`(begin0 . ,vs) (body-find-mutable env vs accum)] + [`(if ,tst ,thn ,els) + (find-mutable env tst + (find-mutable env thn + (find-mutable env els accum)))] + [`(with-continuation-mark ,key ,val ,body) + (find-mutable env key + (find-mutable env val + (find-mutable env body accum)))] + [`(quote ,_) accum] + [`(set! ,var ,rhs) + (define id (unwrap var)) + (find-mutable env rhs (if (hash-ref env id #f) + (hash-set accum id #t) + accum))] + [`(,_ ...) (body-find-mutable env v accum)] + [`,_ accum])) + + (define (body-find-mutable env body accum) + (for/fold ([accum accum]) ([v (in-wrap-list body)]) + (find-mutable env v accum))) + + (define (find-mutable-in-let env v accum) + (match v + [`(,let-form ([,ids ,rhss] ...) . ,body) + (define local-env + (for/fold ([env env]) ([id (in-list ids)]) + (plain-add-args env id))) + (define rhs-env + (case (unwrap let-form) + [(letrec letrec* letrec*-values) local-env] + [else env])) + (body-find-mutable local-env + body + (for/fold ([accum accum]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (find-mutable rhs-env rhs accum)))])) + + ;; ---------------------------------------- + ;; Convert mode + ;; + ;; If there's no size threshold for conversion, then convert mode is + ;; simply 'called or 'not-called. + ;; + ;; If there's a size threshold, then a convert mode is a + ;; `convert-mode` instance. + + (struct convert-mode (sizes called? no-more-conversions?)) + + (define (init-convert-mode v) + (cond + [convert-size-threshold + (convert-mode (record-sizes v) #f #f)] + [else 'not-called])) + + (define (convert-mode-convert-lambda? cm v) + (cond + [(eq? cm 'called) #f] + [(eq? cm 'not-called) #t] + [(convert-mode-called? cm) #f] + [(convert-mode-no-more-conversions? cm) #f] + [((hash-ref (convert-mode-sizes cm) v) . >= . convert-size-threshold) #f] + [else #t])) + + (define (convert-mode-lambda-body-mode cm convert?) + (cond + [(convert-mode? cm) + (if convert? + (convert-mode 'not-needed #f #t) + (convert-mode-non-tail cm))] + [else 'not-called])) + + (define (convert-mode-non-tail cm) + (cond + [(convert-mode? cm) + (struct-copy convert-mode cm + [called? #f])] + [else 'not-called])) + + (define (convert-mode-called cm) + (cond + [(convert-mode? cm) + (struct-copy convert-mode cm + [called? #t])] + [else 'called])) + + (define (convert-mode-box-mutables? cm) + (cond + [(convert-mode? cm) + (not (convert-mode-no-more-conversions? cm))] + [else #t])) + + ;; ---------------------------------------- + + (define (record-sizes v) + (let ([sizes (make-hasheq)]) + (record-sizes! v sizes) + sizes)) + + (define (record-size! v sizes size) + (hash-set! sizes v size) + size) + + (define (record-sizes! v sizes) + (match v + [`(lambda ,args . ,body) + (record-size! v sizes (body-record-sizes! body sizes))] + [`(case-lambda [,_ . ,bodys] ...) + (define new-size + (for/sum ([body (in-list bodys)]) + (body-record-sizes! body sizes))) + (record-size! v sizes new-size)] + [`(let . ,_) (record-sizes-in-let! v sizes)] + [`(letrec . ,_) (record-sizes-in-let! v sizes)] + [`(letrec* . ,_) (record-sizes-in-let! v sizes)] + [`(begin . ,vs) (add1 (body-record-sizes! vs sizes))] + [`(begin0 . ,vs) (add1 (body-record-sizes! vs sizes))] + [`(if ,tst ,thn ,els) + (+ 1 + (record-sizes! tst sizes) + (record-sizes! thn sizes) + (record-sizes! els sizes))] + [`(with-continuation-mark ,key ,val ,body) + (+ 1 + (record-sizes! key sizes) + (record-sizes! val sizes) + (record-sizes! body sizes))] + [`(quote ,_) 1] + [`(set! ,_ ,rhs) + (add1 (record-sizes! rhs sizes))] + [`(,_ ...) (body-record-sizes! v sizes)] + [`,_ 1])) + + (define (body-record-sizes! body sizes) + (for/sum ([v (in-wrap-list body)]) + (record-sizes! v sizes))) + + (define (record-sizes-in-let! v sizes) + (match v + [`(,let-form ([,_ ,rhss] ...) . ,body) + (+ 1 + (for/sum ([rhs (in-list rhss)]) + (record-sizes! rhs sizes)) + (body-record-sizes! body sizes))])) + + ;; ---------------------------------------- + + (top)) + +;; ============================================================ + +(module+ main + (require racket/pretty) + (pretty-print + (jitify-schemified-linklet (values ; datum->correlated + '(lambda (iv xv do-immediate) + (define top (letrec ([odd (lambda (x) (even x))] + [even (lambda (x) (odd x))] + [selfx (lambda (x) (selfx x))] + [selfy (lambda (x) (vector (selfy x) selfy))]) + (odd 5))) + (define top-selfx (lambda (x) (top-selfx x))) + (variable-set! top-selfx-var top-selfx 'const) + (define top-selfy (lambda (x) (vector (top-selfy x) top-selfy))) + (variable-set! top-selfy-var top-selfy 'const) + (call-with-values (lambda (x) (x (lambda (w) (w)))) + (lambda (z w) 10)) + (call-with-values (lambda (x) (x (lambda (w) (w)))) + (letrec ([selfz (lambda (z) (selfz (selfz z)))]) + (lambda (z w) (selfz w)))) + (call-with-values (lambda (x) (x (lambda (w) (w)))) + void) + (define y (letrec ([f (lambda (x) (f (cons x x)))] + [g (lambda (q) (set! f g) (f q))]) + (list (lambda (f) (list x))))) + (define x (lambda (j) j)) + (define x2 (lambda () (letrec ([other (lambda () (other iv))]) + other))) + (define whatever (begin (variable-set! xv x 'const) (void))) + (define end (letrec ([w (lambda (x) (let ([proc (lambda (x) x)]) + (proc q)))] + [q q]) + (lambda (j) (set! q j)))) + (define topz (letrec ([helper (lambda (x) + (helper (topz x)))]) + (lambda (y) (helper y)))) + (variable-set! topz-var topz 'const) + (do-immediate topz) + (define sets-arg (lambda (x) + (values (lambda () (set! x (add1 x))) + (lambda () x)))) + (letrec ([outer + (lambda (x) + (letrec ([inner + (lambda (y) + (outer y))]) + (inner x)))]) + (outer 5)) + (lambda () (let ([x 5]) (set! x 6) x)))) + #t + #f ; size threshold + vector + (lambda (v u) u) + values))) diff --git a/racket/src/schemify/known.rkt b/racket/src/schemify/known.rkt new file mode 100644 index 0000000000..6bc9ce78bf --- /dev/null +++ b/racket/src/schemify/known.rkt @@ -0,0 +1,63 @@ +#lang racket/base + +;; Ths module uses `#:omit-define-syntaxes` and doesn't use +;; `struct-out` so that none of the exports are syntax bindings. + +(provide known-constant known-constant? + known-consistent known-consistent? + known-copy? known-copy known-copy-id + known-literal known-literal? known-literal-expr + known-procedure known-procedure? known-procedure-arity-mask + known-procedure/can-inline known-procedure/can-inline? known-procedure/can-inline-expr + known-procedure/can-inline/need-imports known-procedure/can-inline/need-imports? + known-procedure/can-inline/need-imports-needed + known-procedure/succeeds known-procedure/succeeds? + known-struct-type known-struct-type? known-struct-type-type + known-struct-type-field-count known-struct-type-pure-constructor? + known-constructor known-constructor? known-constructor-type + known-predicate known-predicate? known-predicate-type + known-accessor known-accessor? known-accessor-type + known-mutator known-mutator? known-mutator-type + known-struct-type-property/immediate-guard known-struct-type-property/immediate-guard? + a-known-constant + a-known-consistent) + +;; reflects an immutable variable, but nothing is known about the +;; variable's value +(struct known-constant () #:prefab #:omit-define-syntaxes) + +;; the value at run time always has the same "shape", such as always being +;; a procedure of 1 argument, always being a structure type, or always +;; being a predicate for a structure type +(struct known-consistent () #:prefab #:omit-define-syntaxes #:super struct:known-constant) + +;; copy propagation --- use for local bindings or copies of primitives, only +(struct known-copy (id) #:prefab #:omit-define-syntaxes #:super struct:known-constant) + +;; literal for constant propagation: +(struct known-literal (expr) #:prefab #:omit-define-syntaxes #:super struct:known-consistent) + +;; procedure with arity mark; the procedure has to be a procedure from the host +;; Scheme's perspective --- not an applicable struct or chaperoned procedure, which +;; means that parameters don't count +(struct known-procedure (arity-mask) #:prefab #:omit-define-syntaxes #:super struct:known-consistent) + +(struct known-procedure/can-inline (expr) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) +(struct known-procedure/can-inline/need-imports (needed) ; (list (cons (cons <#f-or-index>)) ...) + #:prefab #:omit-define-syntaxes #:super struct:known-procedure/can-inline) + +;; procedure that succeeds for all arguments and is functional so that it can be reordered +(struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure) + +(struct known-struct-type (type field-count pure-constructor?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent) + +;; procedures with a known connection to a structure type: +(struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) +(struct known-predicate (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) +(struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) +(struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure) + +(struct known-struct-type-property/immediate-guard () #:prefab #:omit-define-syntaxes) + +(define a-known-constant (known-constant)) +(define a-known-consistent (known-consistent)) diff --git a/racket/src/schemify/left-to-right.rkt b/racket/src/schemify/left-to-right.rkt new file mode 100644 index 0000000000..24c7a6a856 --- /dev/null +++ b/racket/src/schemify/left-to-right.rkt @@ -0,0 +1,127 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "simple.rkt") + +(provide left-to-right/let + left-to-right/let-values + left-to-right/app + + make-let-values) + +;; Convert a `let` to nested lets to enforce order; we +;; rely on the fact that the Racket expander generates +;; expressions that have no shadowing (and introduce +;; shadowing here) +(define (left-to-right/let ids rhss bodys + prim-knowns knowns imports mutated) + (cond + [(null? (cdr ids)) + `(let ([,(car ids) ,(car rhss)]) . ,bodys)] + [else + (let loop ([ids ids] [rhss rhss] [all-simple? #t] [binds null]) + (cond + [(null? (cdr rhss)) + (define id (car ids)) + (define rhs (car rhss)) + (if (and all-simple? + (simple? rhs prim-knowns knowns imports mutated)) + `(let ([,id ,rhs]) + . ,bodys) + `(let ([,id ,rhs]) + (let ,binds ; <- allocate ids after all `rhs`s are evaluated + . ,bodys)))] + [else + (define id (car ids)) + (define rhs (car rhss)) + `(let ([,id ,rhs]) + ,(loop (cdr ids) + (cdr rhss) + (and all-simple? + (simple? rhs prim-knowns knowns imports mutated)) + (cons `[,id ,id] binds)))]))])) + +;; Convert a `let-values` to nested `let-values`es to +;; enforce order +(define (left-to-right/let-values idss rhss bodys mutated for-cify?) + (cond + [(null? (cdr idss)) + (define e (if (null? (cdr bodys)) + (car bodys) + `(begin . ,bodys))) + (make-let-values (car idss) (car rhss) e for-cify?)] + [else + (let loop ([idss idss] [rhss rhss] [binds null]) + (cond + [(null? (cdr rhss)) + (make-let-values + (car idss) (car rhss) + `(let ,binds + . ,bodys) + for-cify?)] + [else + (define ids (car idss)) + (make-let-values + ids + (car rhss) + (loop (cdr idss) (cdr rhss) (append (for/list ([id (in-wrap-list ids)]) + `[,id ,id]) + binds)) + for-cify?)]))])) + +;; Convert an application to enforce left-to-right +;; evaluation order +(define (left-to-right/app rator rands plain-app? for-cify? + prim-knowns knowns imports mutated) + (cond + [for-cify? (cons rator rands)] + [else + (let loop ([l (cons rator rands)] [accum null] [pending-non-simple #f] [pending-id #f]) + (cond + [(null? l) + (let ([app + (cond + [pending-non-simple + ;; Since the last non-simple was followed only by simples, + ;; we don't need that variable + (let loop ([accum accum] [rev-accum null]) + (cond + [(null? accum) rev-accum] + [(eq? (car accum) pending-id) + (loop (cdr accum) (cons pending-non-simple rev-accum))] + [else + (loop (cdr accum) (cons (car accum) rev-accum))]))] + [else (reverse accum)])]) + (if plain-app? + app + `(|#%app| . ,app)))] + [(simple? (car l) prim-knowns knowns imports mutated) + (loop (cdr l) (cons (car l) accum) pending-non-simple pending-id)] + [pending-non-simple + `(let ([,pending-id ,pending-non-simple]) + ,(loop l accum #f #f))] + [else + (define g (gensym "app_")) + (loop (cdr l) (cons g accum) (car l) g)]))])) + +;; ---------------------------------------- + +(define (make-let-values ids rhs body for-cify?) + (cond + [(and (pair? ids) (null? (cdr ids))) + `(let ([,(car ids) ,rhs]) ,body)] + [else + (match (and (null? ids) rhs) + [`(begin ,rhs (values)) + `(begin ,rhs ,body)] + [`,_ + (cond + [for-cify? + ;; No checking + `(call-with-values (lambda () ,rhs) + (lambda ,ids ,body))] + [else + `(call-with-values (lambda () ,rhs) + (case-lambda + [,ids ,body] + [args (raise-binding-result-arity-error ',ids args)]))])])])) diff --git a/racket/src/schemify/let.rkt b/racket/src/schemify/let.rkt new file mode 100644 index 0000000000..ab5c8b2e41 --- /dev/null +++ b/racket/src/schemify/let.rkt @@ -0,0 +1,8 @@ +#lang racket/base + +(provide make-let*) + +(define (make-let* bindings body) + (if (null? bindings) + body + `(let* ,bindings ,body))) diff --git a/racket/src/schemify/letrec.rkt b/racket/src/schemify/letrec.rkt new file mode 100644 index 0000000000..9871822592 --- /dev/null +++ b/racket/src/schemify/letrec.rkt @@ -0,0 +1,26 @@ +#lang racket/base +(require "wrap.rkt" + "infer-known.rkt") + +(provide letrec-splitable-values-binding? + letrec-split-values-binding) + +;; Detect binding of lambdas that were probably generated from an +;; R[56]RS program + +(define (letrec-splitable-values-binding? idss rhss) + (and (pair? idss) + (null? (cdr idss)) + (wrap-pair? (car rhss)) + (eq? 'values (wrap-car (car rhss))) + (= (length (wrap-cdr (car rhss))) + (length (car idss))) + (for/and ([rhs (in-list (wrap-cdr (car rhss)))]) + (lambda? rhs #:simple? #t)))) + +(define (letrec-split-values-binding idss rhss bodys) + `(letrec-values ,(for/list ([id (in-list (car idss))] + [rhs (in-list (wrap-cdr (car rhss)))]) + `[(,id) ,rhs]) + . ,bodys)) + diff --git a/racket/src/schemify/lift.rkt b/racket/src/schemify/lift.rkt new file mode 100644 index 0000000000..d4a550b9bd --- /dev/null +++ b/racket/src/schemify/lift.rkt @@ -0,0 +1,701 @@ +#lang racket/base +(require "match.rkt" + "wrap.rkt") + +;; Reduces closure allocation by lifting bindings that are only used +;; in calls that have the right number of arguments. + +;; The output uses `letrec` to bind lifted and closed functions, while +;; `letrec*` is still used for any other recursive binding. + +(provide lift-in-schemified-linklet + lift-in-schemified-body) + +;; An identifier registered in `lifts` is one of +;; +;; * `liftable` - a function binding that is (so far) only referenced +;; in an application position with a correct number of +;; arguments, so each call can supply the free +;; variables of the function and the closure +;; allocation (if any) can be lifted to the top level +;; +;; * `indirected` - a variable that is `set!`ed, which means that it can't be +;; replaced by an argument if it appears as a free +;; variable in a liftable function; instead, the +;; argument must be a box +;; +;; There's nothing analogous to `mutator` and `var-ref` for +;; synthesized accessors, because they're relevant only for the second +;; pass and recorded in an `indirected`. +;; +;; An identifier registered in `locals` maps to either 'ready or 'early, +;; where 'early is used during the right-hand side of a letrec that is +;; not all `lambda`s. + +(struct liftable (expr ; a `lambda` or `case-lambda` RHS of the binding + [frees #:mutable] ; set of variables free in `expr`, plus any lifted bindings + [binds #:mutable])) ; set of variables bound in `expr` + +(struct indirected ([check? #:mutable])) + +(struct mutator (orig)) ; `orig` maps back to the original identifier +(struct var-ref (orig)) ; ditto + +;; As we traverse expressions, we thread through free- and +;; bound-variable sets +(define empty-frees+binds (cons #hasheq() #hasheq())) + +(define (lift-in-schemified-linklet v reannotate) + ;; Match outer shape of a linklet produced by `schemify-linklet` + ;; and lift in the linklet body: + (let loop ([v v]) + (match v + [`(lambda ,args . ,body) + (define new-body (lift-in-schemified-body body reannotate)) + (if (for/and ([old (in-list body)] + [new (in-list new-body)]) + (eq? old new)) + v + `(lambda ,args . ,new-body))] + [`(let* ,bindings ,body) + (define new-body (loop body)) + (if (eq? body new-body) + v + `(let* ,bindings ,new-body))]))) + +(define (lift-in-schemified-body body reannotate) + (for/list ([v (in-list body)]) + (lift-in-schemified v reannotate))) + +(define (lift-in-schemified v reannotate) + ;; Quick pre-check: do any lifts appear to be possible? + (define (lift-in? v) + (match v + [`(define ,_ ,rhs) + (lift-in-expr? rhs)] + [`(define-values ,_ ,rhs) + (lift-in-expr? rhs)] + [`(begin . ,vs) + (for/or ([v (in-wrap-list vs)]) + (lift-in? v))] + [`,_ (lift-in-expr? v)])) + + (define (lift-in-expr? v) + (match v + [`(lambda ,_ . ,body) + (lift?/seq body)] + [`(case-lambda [,_ . ,bodys] ...) + (for/or ([body (in-list bodys)]) + (lift?/seq body))] + [`(let . ,_) (lift-in-let? v)] + [`(letrec . ,_) (lift-in-let? v)] + [`(letrec* . ,_) (lift-in-let? v)] + [`(let-values . ,_) (error 'internal-error "unexpected let-values")] + [`(letrec-values . ,_) (error 'internal-error "unexpected letrec-values")] + [`(begin . ,vs) + (for/or ([v (in-wrap-list vs)]) + (lift-in-expr? v))] + [`(if ,tst ,thn ,els) + (or (lift-in-expr? tst) (lift-in-expr? thn) (lift-in-expr? els))] + [`(with-continuation-mark ,key ,val ,body) + (or (lift-in-expr? key) (lift-in-expr? val) (lift-in-expr? body))] + [`(quote ,_) #f] + [`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")] + [`(set! ,_ ,rhs) + (lift-in-expr? rhs)] + [`(,_ ...) + (lift-in-seq? v)] + [`,_ #f])) + + (define (lift-in-let? v) + (match v + [`(,_ ([,_ ,rhss] ...) . ,body) + (or (for/or ([rhs (in-list rhss)]) + (lift-in-expr? rhs)) + (lift-in-seq? body))])) + + (define (lift-in-seq? vs) + (for/or ([v (in-wrap-list vs)]) + (lift-in-expr? v))) + + ;; Under a `lambda`; any local bindings to functions? + (define (lift? v) + (match v + [`(let . ,_) (lift?/let v)] + [`(letrec . ,_) (lift?/let v)] + [`(letrec* . ,_) (lift?/let v)] + [`(let-values . ,_) (lift?/let v)] + [`(letrec-values . ,_) (lift?/let v)] + [`(lambda ,_ . ,body) (lift?/seq body)] + [`(case-lambda [,_ . ,bodys] ...) + (for/or ([body (in-list bodys)]) + (lift?/seq body))] + [`(begin . ,vs) (lift?/seq vs)] + [`(begin0 . ,vs) (lift?/seq vs)] + [`(quote . ,_) #f] + [`(if ,tst ,thn ,els) + (or (lift? tst) (lift? thn) (lift? els))] + [`(with-continuation-mark ,key ,val ,body) + (or (lift? key) (lift? val) (lift? body))] + [`(set! ,_ ,rhs) (lift? rhs)] + [`(#%variable-reference) #f] + [`(#%variable-reference ,id) #f] + [`(,rator . ,rands) + (or (lift? rator) (lift?/seq rands))] + [`,_ #f])) + + (define (lift?/let v) + (match v + [`(,_ ([,_ ,rhss] ...) . ,body) + (or (for/or ([rhs (in-list rhss)]) + (or (lambda? rhs) + (lift? rhs))) + (lift?/seq body))])) + + (define (lift?/seq vs) + (for/or ([v (in-wrap-list vs)]) + (lift? v))) + + ;; ---------------------------------------- + + ;; Look for a `lambda` to lift out of: + (define (lift-in v) + (match v + [`(define ,id ,rhs) + (reannotate v `(define ,id ,(lift-in-expr rhs)))] + [`(define-values ,ids ,rhs) + (reannotate v `(define-values ,ids ,(lift-in-expr rhs)))] + [`(begin ,vs ...) + (reannotate v `(begin ,@(for/list ([v (in-wrap-list vs)]) + (lift-in v))))] + [`,_ (lift-in-expr v)])) + + ;; Look for a `lambda` to lift out of: + (define (lift-in-expr v) + (match v + [`(lambda ,args . ,body) + (define lifts (make-hasheq)) + (define locals (add-args args #hasheq())) + (define frees+binds/ignored (compute-seq-lifts! body empty-frees+binds lifts locals)) + (let ([lifts (if (zero? (hash-count lifts)) + lifts + (close-and-convert-lifts lifts))]) + (cond + [(zero? (hash-count lifts)) v] + [else + `(letrec ,(extract-lifted-bindings lifts) + ,(reannotate v `(lambda ,args . ,(convert-lifted-calls-in-seq/box-mutated body args lifts #hasheq()))))]))] + [`(case-lambda [,argss . ,bodys] ...) + ;; Lift each clause separately, then splice results: + (let ([lams (for/list ([args (in-list argss)] + [body (in-list bodys)]) + (lift-in-expr `(lambda ,args . ,body)))]) + (reannotate + v + (let loop ([lams lams] [clauses null] [bindings null]) + (cond + [(null? lams) + (if (null? bindings) + `(case-lambda ,@(reverse clauses)) + `(letrec ,bindings ,(loop null clauses null)))] + [else + (match (car lams) + [`(letrec ,new-bindings ,lam) + (loop (cons lam (cdr lams)) clauses (append (unwrap-list new-bindings) bindings))] + [`(lambda ,args . ,body) + (loop (cdr lams) (cons `[,args . ,body] clauses) bindings)])]))))] + [`(let . ,_) (lift-in-let v)] + [`(letrec . ,_) (lift-in-let v)] + [`(letrec* . ,_) (lift-in-let v)] + [`(let-values . ,_) (error 'internal-error "unexpected let-values")] + [`(letrec-values . ,_) (error 'internal-error "unexpected letrec-values")] + [`(begin . ,vs) + (reannotate v `(begin ,@(for/list ([v (in-wrap-list vs)]) + (lift-in-expr v))))] + [`(if ,tst ,thn ,els) + (reannotate v `(if ,(lift-in-expr tst) + ,(lift-in-expr thn) + ,(lift-in-expr els)))] + [`(with-continuation-mark ,key ,val ,body) + (reannotate v `(with-continuation-mark ,(lift-in-expr key) + ,(lift-in-expr val) + ,(lift-in-expr body)))] + [`(quote ,_) v] + [`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")] + [`(set! ,id ,rhs) + (reannotate v `(set! ,id ,(lift-in-expr rhs)))] + [`(,_ ...) + (lift-in-seq v)] + [`,_ v])) + + (define (lift-in-let v) + (match v + [`(,let-id ([,ids ,rhss] ...) . ,body) + (reannotate v `(,let-id + ,(for/list ([id (in-list ids)] + [rhs (in-list rhss)]) + `[,id ,(lift-in-expr rhs)]) + . ,(lift-in-seq body)))])) + + (define (lift-in-seq vs) + (reannotate vs (for/list ([v (in-wrap-list vs)]) + (lift-in-expr v)))) + + ;; ---------------------------------------- + ;; Pass 1: figure out which bindings can be lifted, and also record + ;; information about mutated and `#%variable-reference` variables. + ;; We only care about local variables within a top-level `lambda` or + ;; `case-lambda` form. + + ;; Returns a set of free variables and a set of bound variables + ;; (paired together) while potentially mutating `lifts` + (define (compute-lifts! v frees+binds lifts locals) + (match v + [`(let ([,ids ,rhss] ...) . ,body) + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (when (lambda? rhs) + ;; RHS is a candidate for lifting + (hash-set! lifts (unwrap id) (liftable rhs #f #f)))) + (let* ([frees+binds (compute-rhs-lifts! ids rhss frees+binds lifts locals)] + [frees+binds (compute-seq-lifts! body frees+binds lifts (add-args ids locals))]) + (remove-frees/add-binds ids frees+binds lifts))] + [`(letrec . ,_) + (compute-letrec-lifts! v frees+binds lifts locals)] + [`(letrec* . ,_) + (compute-letrec-lifts! v frees+binds lifts locals)] + [`((letrec ([,id ,rhs]) ,rator) ,rands ...) + (compute-lifts! `(letrec ([,id ,rhs]) (,rator . ,rands)) frees+binds lifts locals)] + [`((letrec* ([,id ,rhs]) ,rator) ,rands ...) + (compute-lifts! `(letrec ([,id ,rhs]) (,rator . ,rands)) frees+binds lifts locals)] + [`(lambda ,args . ,body) + (let ([frees+binds (compute-seq-lifts! body frees+binds lifts (add-args args locals))]) + (remove-frees/add-binds args frees+binds lifts))] + [`(case-lambda [,argss . ,bodys] ...) + (for/fold ([frees+binds frees+binds]) ([args (in-list argss)] + [body (in-list bodys)]) + (let ([frees+binds (compute-seq-lifts! body frees+binds lifts (add-args args locals))]) + (remove-frees/add-binds args frees+binds lifts)))] + [`(begin . ,vs) + (compute-seq-lifts! vs frees+binds lifts locals)] + [`(begin0 . ,vs) + (compute-seq-lifts! vs frees+binds lifts locals)] + [`(quote . ,_) frees+binds] + [`(if ,tst ,thn ,els) + (let* ([frees+binds (compute-lifts! tst frees+binds lifts locals)] + [frees+binds (compute-lifts! thn frees+binds lifts locals)] + [frees+binds (compute-lifts! els frees+binds lifts locals)]) + frees+binds)] + [`(with-continuation-mark ,key ,val ,body) + (let* ([frees+binds (compute-lifts! key frees+binds lifts locals)] + [frees+binds (compute-lifts! val frees+binds lifts locals)] + [frees+binds (compute-lifts! body frees+binds lifts locals)]) + frees+binds)] + [`(set! ,id ,rhs) + (define var (unwrap id)) + (let ([frees+binds (cond + [(hash-ref locals var #f) + => (lambda (status) + (lookup-indirected-variable lifts var (eq? status 'early)) + (add-free frees+binds var))] + [else frees+binds])]) + (compute-lifts! rhs frees+binds lifts locals))] + [`(#%variable-reference . ,_) + (error 'internal-error "lift: unexpected variable reference")] + [`(,rator . ,rands) + (define f (unwrap rator)) + (let ([frees+binds + (cond + [(symbol? f) + (let ([proc (hash-ref lifts f #f)]) + (when (liftable? proc) + (unless (consistent-argument-count? (liftable-expr proc) (length (unwrap-list rands))) + (hash-remove! lifts f)))) + ;; Don't recur on `rator`, because we don't want + ;; to mark `f` as unliftable + (if (hash-ref locals f #f) + (add-free frees+binds f) + frees+binds)] + [else + (compute-lifts! rator frees+binds lifts locals)])]) + (compute-seq-lifts! rands frees+binds lifts locals))] + [`,_ + (define x (unwrap v)) + (cond + [(or (string? x) (bytes? x) (boolean? x) (number? x)) + frees+binds] + [else + (unless (symbol? x) + (error 'lift-in-schemified + "unrecognized expression form: ~e" + v)) + ;; If this identifier is mapped to a liftable, then + ;; the function is not liftable after all, since + ;; the reference isn't in an application position + (let ([proc (hash-ref lifts x #f)]) + (when (liftable? proc) + (hash-remove! lifts x))) + (let ([loc-status (hash-ref locals x #f)]) + (cond + [loc-status + (let ([frees+binds (add-free frees+binds x)]) + (cond + [(eq? loc-status 'early) + (lookup-indirected-variable lifts x #t) + (add-free frees+binds x)] + [else frees+binds]))] + [else frees+binds]))])])) + + ;; Like `compute-lifts!`, but for a sequence of expressions + (define (compute-seq-lifts! vs frees+binds lifts locals) + (for/fold ([frees+binds frees+binds]) ([v (in-wrap-list vs)]) + (compute-lifts! v frees+binds lifts locals))) + + ;; Similar to `compute-seq-lifts!`, but installs free-variable + ;; information in the `lifts` table for each identifier in `ids`: + (define (compute-rhs-lifts! ids rhss frees+binds lifts locals) + (for/fold ([frees+binds frees+binds]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (let ([rhs-frees+binds (compute-lifts! rhs empty-frees+binds lifts locals)] + [f (unwrap id)]) + (let ([proc (hash-ref lifts f #f)]) + (when (liftable? proc) + (set-liftable-frees! proc (car rhs-frees+binds)) + (set-liftable-binds! proc (cdr rhs-frees+binds)))) + (cons (union (car rhs-frees+binds) (car frees+binds)) + (union (cdr rhs-frees+binds) (cdr frees+binds)))))) + + ;; Handle a letrec[*] form + (define (compute-letrec-lifts! v frees+binds lifts locals) + (match v + [`(,_ ([,ids ,rhss] ...) . ,body) + (define all-lambda? + (for/and ([rhs (in-list rhss)]) + (lambda? rhs))) + (when all-lambda? + ;; Each RHS is a candidate for lifting + (for ([id (in-list ids)] + [rhs (in-list rhss)]) + (hash-set! lifts (unwrap id) (liftable rhs #f #f)))) + (let* ([rhs-locals (add-args ids locals (if all-lambda? 'ready 'early))] + [frees+binds (compute-rhs-lifts! ids rhss frees+binds lifts rhs-locals)] + [locals (if all-lambda? + rhs-locals + (add-args ids locals))] + [frees+binds (compute-seq-lifts! body frees+binds lifts locals)]) + (remove-frees/add-binds ids frees+binds lifts))])) + + ;; ---------------------------------------- + ;; Bridge between pass 1 and 2: transitive closure of free variables + + ;; Close a liftable's free variables over other variables needed by + ;; other lifted functions that it calls. Also, clear `mutated` and + ;; `var-ref` information from `lifts` in the returned table. + (define (close-and-convert-lifts lifts) + (define new-lifts (make-hash)) + ;; Copy over `liftable`s: + (for ([(f info) (in-hash lifts)]) + (when (liftable? info) + (hash-set! new-lifts f info))) + ;; Compute the closure of free-variable sets, where a function + ;; to be lifted calls another function to be lifted, and also + ;; re-register mutators and variable references that are + ;; used. + (for ([proc (in-list (hash-values new-lifts))]) + (define frees (liftable-frees proc)) + (define binds (liftable-binds proc)) + (define closed-frees + (let loop ([frees frees] [todo (hash-keys frees)]) + (cond + [(null? todo) frees] + [else + (define v (car todo)) + (define info (hash-ref lifts v #f)) + (cond + [(liftable? info) + ;; A liftable function called by ths liftable function, + ;; so we'll need to be able to supply all of its free + ;; variables + (define v-binds (liftable-binds info)) + (let v-loop ([v-frees (hash-keys (liftable-frees info))] + [frees frees] + [todo (cdr todo)]) + (if (null? v-frees) + (loop frees todo) + (let ([g (car v-frees)]) + (cond + [(or (hash-ref frees g #f) ; avoid cycles + (hash-ref binds g #f) ; don't add if bound in this function + (hash-ref v-binds g #f)) ; don't add if local to `v` + (v-loop (cdr v-frees) frees todo)] + [else + (v-loop (cdr v-frees) + (hash-set frees g #t) + (cons g todo))]))))] + [(indirected? info) + ;; Preserve recording of this variable as boxed + (hash-set! new-lifts v info) + (loop frees (cdr todo))] + [else + ;; Normal variable: + (loop frees (cdr todo))])]))) + (set-liftable-frees! proc closed-frees)) + ;; Remove references to lifted from free-variable sets, and also + ;; convert free-variable sets to lists for consistent ordering: + (for ([proc (in-hash-values new-lifts)] + #:when (liftable? proc)) + (set-liftable-frees! proc (sort (for/list ([f (in-hash-keys (liftable-frees proc))] + #:unless (liftable? (hash-ref lifts f #f))) + f) + symbol (lambda (proc) + (reannotate v `(,rator ,@(liftable-frees proc) . ,rands)))] + [else + (reannotate v `(,(convert rator) . ,rands))]))] + [`,_ + (define var (unwrap v)) + (define info (and (symbol? var) + (hash-ref lifts var #f))) + (cond + [(indirected? info) + (reannotate v (if (indirected-check? info) + `(unbox/check-undefined ,v ',v) + `(unbox ,v)))] + [else v])]))) + + (define (convert-lifted-calls-in-seq vs lifts frees) + (reannotate vs (for/list ([v (in-wrap-list vs)]) + (convert-lifted-calls-in-expr v lifts frees)))) + + (define (convert-lifted-calls-in-let v lifts frees) + (match v + [`(,let-id ([,ids ,rhss] ...) . ,body) + (define bindings + (for/list ([id (in-list ids)] + [rhs (in-list rhss)] + #:unless (liftable? (hash-ref lifts (unwrap id) #f))) + `[,id ,(let ([rhs (convert-lifted-calls-in-expr rhs lifts frees)]) + (if (indirected? (hash-ref lifts (unwrap id) #f)) + `(box ,rhs) + rhs))])) + (define new-body + (convert-lifted-calls-in-seq body lifts frees)) + (reannotate + v + (rebuild-let let-id bindings new-body))])) + + (define (convert-lifted-calls-in-letrec v lifts frees) + (match v + [`(,let-id ([,ids ,rhss] ...) . ,body) + (define pre-bindings + (for/list ([id (in-list ids)] + [rhs (in-list rhss)] + #:when (indirected? (hash-ref lifts (unwrap id) #f))) + `[,id (box unsafe-undefined)])) + (define bindings + (for/list ([id (in-list ids)] + [rhs (in-list rhss)] + #:unless (liftable? (hash-ref lifts (unwrap id) #f))) + (define new-rhs (convert-lifted-calls-in-expr rhs lifts frees)) + (cond + [(indirected? (hash-ref lifts (unwrap id) #f)) + `[,(gensym) (set-box! ,id ,new-rhs)]] + [else `[,id ,new-rhs]]))) + (define new-bindings + (if (null? bindings) + pre-bindings + (append pre-bindings bindings))) + (define new-body + (convert-lifted-calls-in-seq body lifts frees)) + (reannotate + v + (rebuild-let let-id new-bindings new-body))])) + + (define (convert-lifted-calls-in-seq/box-mutated vs ids lifts frees) + (let loop ([ids ids]) + (cond + [(wrap-null? ids) + (convert-lifted-calls-in-seq vs lifts frees)] + [(wrap-pair? ids) + (define id (wrap-car ids)) + (if (indirected? (hash-ref lifts (unwrap id) #f)) + `((let ([,id (box ,id)]) + . ,(loop (wrap-cdr ids)))) + (loop (wrap-cdr ids)))] + [else (loop (list ids))]))) + + ;; Create bindings for lifted functions, adding new arguments + ;; as the functions are lifted + (define (extract-lifted-bindings lifts) + (for/list ([(f proc) (in-hash lifts)] + #:when (liftable? proc)) + (let* ([new-args (liftable-frees proc)] + [frees (for/hash ([arg (in-list new-args)]) + (values arg #t))] + [rhs (liftable-expr proc)]) + `[,f ,(match rhs + [`(lambda ,args . ,body) + (let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees)]) + (reannotate rhs `(lambda ,(append new-args args) . ,body)))] + [`(case-lambda [,argss . ,bodys] ...) + (reannotate rhs `(case-lambda + ,@(for/list ([args (in-list argss)] + [body (in-list bodys)]) + (let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees)]) + `[,(append new-args args) . ,body]))))])]))) + + + ;; ---------------------------------------- + ;; Helpers + + (define (lambda? v) + (match v + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`,_ #f])) + + (define (consistent-argument-count? proc n) + (define (consistent? args n) + (let loop ([args args] [n n]) + (cond + [(negative? n) #f] + [(wrap-null? args) (zero? n)] + [(wrap-pair? args) + (loop (wrap-cdr args) (sub1 n))] + [else #t]))) + (match proc + [`(lambda ,args . ,_) + (consistent? args n)] + [`(case-lambda [,argss . ,_] ...) + (for/or ([args (in-list argss)]) + (consistent? args n))] + [`,_ #f])) + + ;; Find or create an `indirected` record for a variable + (define (lookup-indirected-variable lifts var need-check?) + (define ind (hash-ref lifts var #f)) + (or (and (indirected? ind) + (begin + (when need-check? + (set-indirected-check?! ind #t)) + ind)) + (let ([ind (indirected need-check?)]) + (hash-set! lifts var ind) + ind))) + + ;; Add a group of arguments (a list or improper list) to a set + (define (add-args args s [mode 'ready]) + (let loop ([args args] [s s]) + (cond + [(wrap-null? args) s] + [(wrap-pair? args) + (loop (wrap-cdr args) + (hash-set s (unwrap (wrap-car args)) mode))] + [else (hash-set s (unwrap args) mode)]))) + + ;; Add a free variable + (define (add-free frees+binds var) + (cons (hash-set (car frees+binds) var #t) + (cdr frees+binds))) + + ;; Remove a group of arguments (a list or improper list) from a set + ;; as the variable go out of scope, including any associated mutator + ;; and variable-reference variables, but keep variables for lifted + ;; functions + (define (remove-frees/add-binds args frees+binds lifts) + (define (remove-free/add-bind frees+binds arg) + (define info (hash-ref lifts arg #f)) + (cond + [(liftable? info) + ;; Since `arg` will be lifted to the top, it + ;; stays in our local set of free variables, + ;; but also add it to binds so that callers + ;; will know that they don't need to chain + (cons (car frees+binds) + (hash-set (cdr frees+binds) arg #t))] + [else (cons (hash-remove (car frees+binds) arg) + (hash-set (cdr frees+binds) arg #t))])) + (let loop ([args args] [frees+binds frees+binds]) + (cond + [(wrap-null? args) frees+binds] + [(wrap-pair? args) + (loop (wrap-cdr args) + (remove-free/add-bind frees+binds (unwrap (wrap-car args))))] + [else (remove-free/add-bind frees+binds (unwrap args))]))) + + ;; Set union + (define (union s1 s2) + (cond + [((hash-count s1) . > . (hash-count s2)) + (union s2 s1)] + [else + (for/fold ([s2 s2]) ([k (in-hash-keys s1)]) + (hash-set s2 k #t))])) + + (define (rebuild-let let-id bindings body) + (cond + [(not (null? bindings)) + `(,let-id ,bindings . ,body)] + [(and (pair? body) (null? (cdr body))) + (car body)] + [else `(begin . ,body)])) + + ;; ---------------------------------------- + ;; Go + + (if (lift-in? v) + (lift-in v) + v)) diff --git a/racket/src/schemify/literal.rkt b/racket/src/schemify/literal.rkt new file mode 100644 index 0000000000..e3448c30dd --- /dev/null +++ b/racket/src/schemify/literal.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(require "wrap.rkt") + +(provide literal? + unwrap-literal) + +(define (literal? v) + (define u (unwrap v)) + (or (number? u) + (boolean? u) + (and (pair? u) + (eq? (unwrap (car u)) 'quote) + (let ([u (unwrap (wrap-car (cdr u)))]) + (or (symbol? u) + (null? u)))))) + +;; Unwrap a literal so that it can be serialized +(define (unwrap-literal v) + (define u (unwrap v)) + (if (pair? u) + `',(unwrap (wrap-car (cdr u))) + u)) diff --git a/racket/src/schemify/main.rkt b/racket/src/schemify/main.rkt new file mode 100644 index 0000000000..5316b8fda7 --- /dev/null +++ b/racket/src/schemify/main.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(require "schemify.rkt" + "known.rkt" + "lift.rkt" + "jitify.rkt" + "interpret.rkt" + "size.rkt") + +(provide schemify-linklet + schemify-body + + (all-from-out "known.rkt") + + lift-in-schemified-linklet + lift-in-schemified-body + + jitify-schemified-linklet + + interpretable-jitified-linklet + interpret-linklet + + linklet-bigger-than?) diff --git a/racket/src/schemify/match.rkt b/racket/src/schemify/match.rkt new file mode 100644 index 0000000000..2214e35f2e --- /dev/null +++ b/racket/src/schemify/match.rkt @@ -0,0 +1,142 @@ +#lang racket/base +(require (for-syntax racket/base) + "wrap.rkt") + +;; One more time, still yet another pattern matching library again... +(provide match) + +(define-for-syntax (extract-pattern-variables pattern) + (syntax-case pattern (unquote ?) + [(unquote (? pred?)) + null] + [(unquote bind-id) + (if (free-identifier=? #'bind-id #'_) + null + (list #'bind-id))] + [(p1 . p2) (append (extract-pattern-variables #'p1) + (extract-pattern-variables #'p2))] + [else null])) + +(define-for-syntax (check-one id pattern head-id) + (define (check-one/expr e pattern) + (syntax-case pattern (unquote) + [(unquote bind-id) #`#t] + [_ #`(let ([a #,e]) + #,(check-one #'a pattern #f))])) + (syntax-case pattern (unquote ?) + [(unquote (? pred?)) + #`(pred? #,id)] + [(unquote bind-id) #`#t] + [(pat ellipses) + (and (identifier? #'ellipses) + (free-identifier=? #'ellipses (quote-syntax ...))) + (if (syntax-case #'pat (unquote) + [(unquote bind-id) #t] + [_ #f]) + #`(wrap-list? #,id) + #`(and (wrap-list? #,id) + (for/and ([v (in-wrap-list #,id)]) + #,(check-one #'v #'pat #f))))] + [(m-id . p2) + (and head-id (identifier? #'m-id)) + #`(and (eq? 'm-id #,head-id) + #,(check-one/expr #`(cdr (unwrap #,id)) #'p2))] + [(p1 . p2) + #`(let ([p (unwrap #,id)]) + (and (pair? p) + #,(check-one/expr #'(car p) #'p1) + #,(check-one/expr #'(cdr p) #'p2)))] + [_ + (if (or (identifier? pattern) + (let ([v (syntax-e pattern)]) + (or (keyword? v) + (boolean? v) + (null? v)))) + #`(wrap-eq? (quote #,pattern) #,id) + #`(wrap-equal? (quote #,pattern) #,id))])) + +(define-for-syntax (extract-one id pattern) + (syntax-case pattern (unquote ?) + [(unquote (? pred?)) + #`(values)] + [(unquote bind-id) + (if (free-identifier=? #'bind-id #'_) + #'(values) + id)] + [(pat ellipses) + (and (identifier? #'ellipses) + (free-identifier=? #'ellipses (quote-syntax ...))) + (syntax-case #'pat (unquote) + [(unquote bind-id) + (if (free-identifier=? #'bind-id #'_) + #'(values) + #`(unwrap-list #,id))] + [_ + (with-syntax ([pat-ids (extract-pattern-variables #'pat)]) + #`(for/lists pat-ids ([v (in-wrap-list #,id)]) + #,(extract-one #'v #'pat)))])] + [(p1 . p2) + (let ([ids1 (extract-pattern-variables #'p1)] + [ids2 (extract-pattern-variables #'p2)]) + (cond + [(and (null? ids1) (null? ids2)) + #'(values)] + [(null? ids1) + #`(let ([d (cdr (unwrap #,id))]) + #,(extract-one #'d #'p2))] + [(null? ids2) + #`(let ([a (car (unwrap #,id))]) + #,(extract-one #'a #'p1))] + [else + #`(let ([p (unwrap #,id)]) + (let-values ([#,ids1 (let ([a (car p)]) + #,(extract-one #'a #'p1))] + [#,ids2 (let ([d (cdr p)]) + #,(extract-one #'d #'p2))]) + (values #,@ids1 #,@ids2)))]))] + [_ + #'(values)])) + +(define-for-syntax (extract-guard body) + (syntax-case body () + [(#:guard guard-expr . body) + #'guard-expr] + [_ #f])) + +(define-for-syntax (remove-guard body) + (syntax-case body () + [(#:guard guard-expr . body) + #'body] + [_ body])) + +(define-syntax (match stx) + (syntax-case stx (quasiquote) + [(_ expr [`pattern body0 body ...] ...) + #`(let ([v expr]) + #,(let ([patterns (syntax->list #'(pattern ...))]) + (define (build-matches head-id) + (let loop ([patterns patterns] + [bodys (syntax->list #'((body0 body ...) ...))]) + (cond + [(null? patterns) + #'(error 'match "failed ~e" v)] + [else + (define ids (extract-pattern-variables (car patterns))) + (define match? (check-one #'v (car patterns) head-id)) + (define guard (extract-guard (car bodys))) + #`(if #,(if guard + #`(and #,match? #,guard) + match?) + (let-values ([#,ids #,(extract-one #'v (car patterns))]) + . #,(remove-guard (car bodys))) + #,(loop (cdr patterns) (cdr bodys)))]))) + ;; If the first pattern is `( ....)`, then + ;; extract the input head symbol, because we're + ;; likely to want to check it for many pattern cases + (syntax-case (and (pair? patterns) (car patterns)) () + [(id . _) + (identifier? #'id) + #`(let ([hd (let ([p (unwrap v)]) + (and (pair? p) (unwrap (car p))))]) + #,(build-matches #'hd))] + [_ (build-matches #f)])))])) diff --git a/racket/src/schemify/mutated-state.rkt b/racket/src/schemify/mutated-state.rkt new file mode 100644 index 0000000000..b5ab47c0dd --- /dev/null +++ b/racket/src/schemify/mutated-state.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; During the `mutated-in-body` pass, an identifier is mapped to one +;; of the following: +;; +;; * 'set!ed - the identifier is `set!`ed +;; +;; * 'too-early - the identifier may be referenced before it is +;; defined +;; +;; * 'not-ready - the identifier's value is not yet ready, so a +;; reference transitions to 'too-early +;; +;; * 'undefined - the identifier is "exported" from the linklet, but +;; not defined +;; +;; * a thunk - the identifier is defined, where evaluation of the +;; definition is side-efect-free; force the thunk on a +;; first use, since anything referenced by the thunk +;; might be first used at that point +;; +;; * #f (not mapped) - defined and never `set!`ed +;; +;; By the end of the `mutated-in-body` pass, only 'set!ed, 'too-early, +;; 'not-ready (for exported but not defined) and #f are possible for +;; identifiers that are reachable by evaluation. + +(provide delayed-mutated-state? + simple-mutated-state? + not-ready-mutated-state? + via-variable-mutated-state? + set!ed-mutated-state?) + +(define (delayed-mutated-state? v) (procedure? v)) + +(define (simple-mutated-state? v) + (or (not v) + (delayed-mutated-state? v))) + +(define (not-ready-mutated-state? v) + (eq? v 'not-ready)) + +;; When referecing an exported identifier, we need to consistently go +;; through a `variable` record when it can be `set!`ed. We don't need +;; to go through a `variable` record if the identifier might simply be +;; used too early, because the host Scheme takes care of that issue. +(define (via-variable-mutated-state? v) + (or (eq? v 'set!ed) + (eq? v 'undefined))) + +;; At the end of a linklet, known-value information is reliable unless +;; the identifier is mutated +(define (set!ed-mutated-state? v) + (eq? v 'set!ed)) diff --git a/racket/src/schemify/mutated.rkt b/racket/src/schemify/mutated.rkt new file mode 100644 index 0000000000..22b87998b4 --- /dev/null +++ b/racket/src/schemify/mutated.rkt @@ -0,0 +1,191 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "simple.rkt" + "find-definition.rkt" + "struct-type-info.rkt" + "mutated-state.rkt" + "find-known.rkt" + "letrec.rkt") + +(provide mutated-in-body) + +;; See "mutated-state.rkt" for information on the content of the +;; `mutated` table. + +;; We don't have to worry about errors or escapes that prevent the +;; definition of an identifier, because that will abort the enclosing +;; linklet. + +(define (mutated-in-body l exports prim-knowns knowns imports) + ;; Find all `set!`ed variables, and also record all bindings + ;; that might be used too early + (define mutated (make-hasheq)) + ;; Defined names start out as 'not-ready; start with `exports`, + ;; because anything exported but not defined is implicitly in an + ;; undefined state and must be accessed through a `variable`: + (for ([id (in-hash-keys exports)]) + (hash-set! mutated id 'undefined)) + ;; Find all defined variables: + (for ([form (in-list l)]) + (match form + [`(define-values (,ids ...) ,rhs) + (for ([id (in-list ids)]) + (hash-set! mutated (unwrap id) 'not-ready))] + [`,_ (void)])) + ;; Walk through the body: + (for/fold ([prev-knowns knowns]) ([form (in-list l)]) + ;; Accumulate known-binding information in this pass, because it's + ;; helpful to know which variables are bound to constructors. + ;; Note that we may tentatively classify a binding as a constructor + ;; before discovering that its mutated via `set!`, but any use of + ;; that information is correct, because it dynamically precedes + ;; the `set!` + (define-values (knowns info) + (find-definitions form prim-knowns prev-knowns imports mutated #f)) + (match form + [`(define-values (,ids ...) ,rhs) + (cond + [info + ;; Look just at the "rest" part: + (for ([e (in-list (struct-type-info-rest info))] + [pos (in-naturals)]) + (unless (and (= pos struct-type-info-rest-properties-list-pos) + (pure-properties-list? e prim-knowns knowns imports mutated)) + (find-mutated! e ids prim-knowns knowns imports mutated)))] + [else + (find-mutated! rhs ids prim-knowns knowns imports mutated)]) + ;; For any among `ids` that didn't get a delay and wasn't used + ;; too early, the variable is now ready, so remove from + ;; `mutated`: + (for ([id (in-list ids)]) + (when (eq? 'not-ready (hash-ref mutated (unwrap id) #f)) + (hash-remove! mutated id)))] + [`,_ + (find-mutated! form #f prim-knowns knowns imports mutated)]) + knowns) + ;; For definitions that are not yet used, force delays: + (for ([form (in-list l)]) + (match form + [`(define-values (,ids ...) ,rhs) + (for ([id (in-list ids)]) + (let ([id (unwrap id)]) + (define state (hash-ref mutated id #f)) + (when (delayed-mutated-state? state) + (hash-remove! mutated id) + (state))))] + [`,_ (void)])) + ;; Everything else in `mutated` is either 'set!ed, 'too-early, + ;; 'undefined, or unreachable: + mutated) + +;; Schemify `let-values` to `let`, etc., and +;; reorganize struct bindings. +(define (find-mutated! v ids prim-knowns knowns imports mutated) + (define (delay! ids thunk) + (define done? #f) + (define force (lambda () (unless done? + (set! done? #t) + (thunk)))) + (for ([id (in-list ids)]) + (let ([id (unwrap id)]) + (define m (hash-ref mutated id 'not-ready)) + (if (eq? 'not-ready m) + (hash-set! mutated id force) + (force))))) + (let find-mutated! ([v v] [ids ids]) + (define (find-mutated!* l ids) + (let loop ([l l]) + (cond + [(null? l) (void)] + [(null? (cdr l)) (find-mutated! (car l) ids)] + [else (find-mutated! (car l) #f) (loop (cdr l))]))) + (match v + [`(lambda ,formals ,body ...) + (if ids + (delay! ids (lambda () (find-mutated!* body #f))) + (find-mutated!* body #f))] + [`(case-lambda [,formalss ,bodys ...] ...) + (if ids + (delay! ids (lambda () (for ([body (in-list bodys)]) (find-mutated!* body #f)))) + (for ([body (in-list bodys)]) (find-mutated!* body #f)))] + [`(quote ,_) (void)] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + (for ([ids (in-list idss)] + [rhs (in-list rhss)]) + ;; an `id` in `ids` can't be referenced too early, + ;; but it might usefully be delayed + (find-mutated! rhs ids)) + (find-mutated!* bodys ids)] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + (cond + [(letrec-splitable-values-binding? idss rhss) + (find-mutated! (letrec-split-values-binding idss rhss bodys) ids)] + [else + (for* ([ids (in-list idss)] + [id (in-wrap-list ids)]) + (hash-set! mutated (unwrap id) 'not-ready)) + (for ([ids (in-list idss)] + [rhs (in-list rhss)]) + (find-mutated! rhs (unwrap-list ids)) + ;; Each `id` in `ids` is now ready (but might also hold a delay): + (for ([id (in-wrap-list ids)]) + (let ([id (unwrap id)]) + (when (eq? 'not-ready (hash-ref mutated id)) + (hash-remove! mutated id))))) + (find-mutated!* bodys ids)])] + [`(if ,tst ,thn ,els) + (find-mutated! tst #f) + (find-mutated! thn #f) + (find-mutated! els #f)] + [`(with-continuation-mark ,key ,val ,body) + (find-mutated! key #f) + (find-mutated! val #f) + (find-mutated! body ids)] + [`(begin ,exps ...) + (find-mutated!* exps ids)] + [`(begin0 ,exp ,exps ...) + (find-mutated! exp ids) + (find-mutated!* exps #f)] + [`(set! ,id ,rhs) + (let ([id (unwrap id)]) + (define old-state (hash-ref mutated id #f)) + (hash-set! mutated id 'set!ed) + (when (delayed-mutated-state? old-state) + (old-state))) + (find-mutated! rhs #f)] + [`(#%variable-reference . ,_) (void)] + [`(,rator ,exps ...) + (cond + [(and ids + (let ([rator (unwrap rator)]) + (and (symbol? rator) + (let ([v (find-known rator prim-knowns knowns imports mutated)]) + (and (known-constructor? v) + (bitwise-bit-set? (known-procedure-arity-mask v) (length exps)))) + (for/and ([exp (in-list exps)]) + (simple? exp prim-knowns knowns imports mutated))))) + ;; Can delay construction + (delay! ids (lambda () (find-mutated!* exps #f)))] + [else + (find-mutated! rator #f) + (find-mutated!* exps #f)])] + [`,_ + (let ([v (unwrap v)]) + (when (symbol? v) + (define state (hash-ref mutated v #f)) + (cond + [(not-ready-mutated-state? state) + (hash-set! mutated v 'too-early)] + [(delayed-mutated-state? state) + (cond + [ids + ;; Chain delays + (delay! ids (lambda () + (hash-remove! mutated v) + (state)))] + [else + (hash-remove! mutated v) + (state)])])))]))) diff --git a/racket/src/schemify/optimize.rkt b/racket/src/schemify/optimize.rkt new file mode 100644 index 0000000000..1cc4c7c6c0 --- /dev/null +++ b/racket/src/schemify/optimize.rkt @@ -0,0 +1,56 @@ +#lang racket/base +(require "match.rkt" + "wrap.rkt" + "import.rkt" + "known.rkt" + "find-known.rkt" + "mutated-state.rkt" + "literal.rkt") + +(provide optimize) + +;; Perform shallow optimizations. The `schemify` pass calls `optimize` +;; on each schemified form, which means that subexpressions of the +;; immediate expression have already been optimized. + +(define (optimize v prim-knowns knowns imports mutated) + (match v + [`(if ,t ,e1 ,e2) + (if (literal? t) + (if (unwrap t) e1 e2) + v)] + [`(procedure? ,e) + (define u (unwrap e)) + (cond + [(symbol? u) + (define k (find-known u prim-knowns knowns imports mutated)) + (if (known-procedure? k) + '#t + v)] + [else v])] + [`(procedure-arity-includes? ,e ,n) + (define u (unwrap e)) + (define u-n (unwrap n)) + (cond + [(and (symbol? u) + (exact-integer? n)) + (define k (find-known u prim-knowns knowns imports mutated)) + (if (and (known-procedure? k) + (bitwise-bit-set? (known-procedure-arity-mask k) u-n)) + '#t + v)] + [else v])] + [`,_ + (define u (unwrap v)) + (cond + [(symbol? u) + (define k (hash-ref-either knowns imports u)) + (cond + [(and (known-literal? k) + (simple-mutated-state? (hash-ref mutated u #f))) + (known-literal-expr k)] + ;; Note: we can't do `known-copy?` here, because a copy of + ;; an imported or exported name will need to be schemified + ;; to a different name + [else v])] + [else v])])) diff --git a/racket/src/schemify/pthread-parameter.rkt b/racket/src/schemify/pthread-parameter.rkt new file mode 100644 index 0000000000..30e6e92648 --- /dev/null +++ b/racket/src/schemify/pthread-parameter.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require "wrap.rkt" + "known.rkt") + +(provide pthread-parameter?) + +(define (pthread-parameter? v prim-knowns knowns mutated) + (and (wrap-pair? v) + (wrap-pair? (wrap-cdr v)) + (wrap-null? (wrap-cdr (wrap-cdr v))) + (let ([u-rator (unwrap (wrap-car v))]) + (or (eq? u-rator 'make-pthread-parameter) + (and (symbol? u-rator) + (let ([k (hash-ref knowns u-rator #f)]) + (and (known-copy? k) + (eq? 'make-pthread-parameter (known-copy-id k))))))))) diff --git a/racket/src/schemify/quoted.rkt b/racket/src/schemify/quoted.rkt new file mode 100644 index 0000000000..142d4c9fe1 --- /dev/null +++ b/racket/src/schemify/quoted.rkt @@ -0,0 +1,31 @@ +#lang racket/base +(require racket/extflonum) + +(provide lift-quoted?) + +;; Check whether a quoted value needs to be lifted to run-time construction +(define (lift-quoted? q for-cify?) + (cond + [for-cify? + (not (or (and (exact-integer? q) + ;; always a fixnum: + (<= (- (expt 2 29)) q (expt 2 29))) + (boolean? q) + (null? q) + (void? q)))] + [(impersonator? q) #t] ; i.e., strip impersonators when serializaing + [(path? q) #t] + [(regexp? q) #t] + [(byte-regexp? q) #t] + [(keyword? q) #t] + [(hash? q) #t] + [(string? q) #t] + [(bytes? q) #t] + [(pair? q) (or (lift-quoted? (car q) for-cify?) + (lift-quoted? (cdr q) for-cify?))] + [(vector? q) (for/or ([e (in-vector q)]) + (lift-quoted? e for-cify?))] + [(box? q) (lift-quoted? (unbox q) for-cify?)] + [(prefab-struct-key q) #t] + [(extflonum? q) #t] + [else #f])) diff --git a/racket/src/schemify/schemify-demo.rkt b/racket/src/schemify/schemify-demo.rkt new file mode 100644 index 0000000000..5cba40774e --- /dev/null +++ b/racket/src/schemify/schemify-demo.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require racket/pretty + "schemify.rkt" + "known.rkt") + +(define prim-knowns + ;; Register primitives + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require 'racket/unsafe/ops) + (namespace-require 'racket/flonum) + (namespace-require 'racket/fixnum)) + (for/hasheq ([s (in-list (namespace-mapped-symbols ns))] + #:when (with-handlers ([exn:fail? (lambda (x) #f)]) + (procedure? (eval s ns)))) + (values s a-known-procedure)))) + +(define (wrap-everywhere p) + (cond + [(pair? p) + (datum->syntax #f (cons (wrap-everywhere (car p)) + (wrap-everywhere (cdr p))))] + [else + (datum->syntax #f p)])) + +(define-values (schemified importss-abi exports-info) + (schemify-linklet `(linklet + () + (x ,#'y [,#'z ,#'ext-z]) + . + ,(map + wrap-everywhere + '((define-values (struct:s make-s s? s-ref s-set!) + (make-struct-type 's #f 2 0 #f)) + (define-values (y) (make-s (lambda () x) 5)) + (define-values (x) (lambda () y)) + (x) + (letrec-values ([(loop) (lambda () (loop))]) (loop)) + (let-values ([(a) 1] [(b) 2]) (list a b)) + (let-values ([(a b) (values 1 2)]) (list a b)) + (define-values (done) (z))))) + #; + (call-with-input-file "regexp.rktl" read) + (lambda (old-v new-v) + (if (syntax? old-v) + (datum->syntax #f new-v old-v) + new-v)) + (lambda (old-v) (syntax->datum (datum->syntax #f old-v))) + prim-knowns + (lambda args #hasheq()))) + +(pretty-print schemified) +(pretty-print exports-info) + diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt new file mode 100644 index 0000000000..4da38cbe6a --- /dev/null +++ b/racket/src/schemify/schemify.rkt @@ -0,0 +1,602 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "export.rkt" + "struct-type-info.rkt" + "simple.rkt" + "find-definition.rkt" + "mutated.rkt" + "mutated-state.rkt" + "left-to-right.rkt" + "serialize.rkt" + "let.rkt" + "equal.rkt" + "optimize.rkt" + "find-known.rkt" + "infer-known.rkt" + "inline.rkt" + "letrec.rkt") + +(provide schemify-linklet + schemify-body) + +;; Convert a linklet to a Scheme `lambda`, dealing with several +;; issues: +;; +;; - imports and exports are represented by `variable` objects that +;; are passed to the function; to avoid obscuring the program to +;; the optimizer, though, refer to the definitions of exported +;; variables instead of going through the `variable`, whenever +;; possible, and accept values instead of `variable`s for constant +;; imports; +;; +;; - wrap expressions in a sequence of definitions plus expressions +;; so that the result body is a sequence of definitions followed +;; by a single expression; +;; +;; - convert function calls and `let` forms to enforce left-to-right +;; evaluation; +;; +;; - convert function calls to support applicable structs, using +;; `#%app` whenever a call might go through something other than a +;; plain function; +;; +;; - convert `make-struct-type` bindings to a pattern that Chez can +;; recognize; +;; +;; - optimize away `variable-reference-constant?` uses, which is +;; important to make keyword-argument function calls work directly +;; without keywords; +;; +;; - simplify `define-values` and `let-values` to `define` and +;; `let`, when possible, and generally avoid `let-values`. + +;; The given linklet can have parts wrapped as annotations. When +;; called from the Racket expander, those annotation will be +;; "correlated" objects that just support source locations. + +;; Returns (values schemified-linklet import-abi export-info) +;; An import ABI is a list of list of booleans, parallel to the +;; linklet imports, where #t to means that a value is expected, and #f +;; means that a variable (which boxes a value) is expected +(define (schemify-linklet lk serializable? for-jitify? allow-set!-undefined? unsafe-mode? + reannotate prim-knowns get-import-knowns import-keys) + (define (im-int-id id) (unwrap (if (pair? id) (cadr id) id))) + (define (im-ext-id id) (unwrap (if (pair? id) (car id) id))) + (define (ex-int-id id) (unwrap (if (pair? id) (car id) id))) + (define (ex-ext-id id) (unwrap (if (pair? id) (cadr id) id))) + ;; Assume no wraps unless the level of an id or expression + (match lk + [`(linklet ,im-idss ,ex-ids . ,bodys) + ;; For imports, map symbols to gensymed `variable` argument names, + ;; keeping `import` records in groups: + (define grps + (for/list ([im-ids (in-list im-idss)] + [index (in-naturals)]) + ;; An import key from `import-keys` lets us get cross-module + ;; information on demand + (import-group index (and import-keys (vector-ref import-keys index)) + get-import-knowns #f #f + '()))) + ;; Record import information in both the `imports` table and within + ;; the import-group record + (define imports + (let ([imports (make-hasheq)]) + (for ([im-ids (in-list im-idss)] + [grp (in-list grps)]) + (set-import-group-imports! + grp + (for/list ([im-id (in-list im-ids)]) + (define id (im-int-id im-id)) + (define ext-id (im-ext-id im-id)) + (define im (import grp (gensym (symbol->string id)) id ext-id)) + (hash-set! imports id im) + im))) + imports)) + ;; Inlining can add new import groups or add imports to an existing group + (define new-grps '()) + (define add-import! + (make-add-import! imports + grps + get-import-knowns + (lambda (new-grp) (set! new-grps (cons new-grp new-grps))))) + ;; For exports, too, map symbols to gensymed `variable` argument names + (define exports + (for/fold ([exports (hasheq)]) ([ex-id (in-list ex-ids)]) + (define id (ex-int-id ex-id)) + (hash-set exports id (export (gensym (symbol->string id)) (ex-ext-id ex-id))))) + ;; Lift any quoted constants that can't be serialized + (define-values (bodys/constants-lifted lifted-constants) + (if serializable? + (convert-for-serialize bodys #f) + (values bodys null))) + ;; Schemify the body, collecting information about defined names: + (define-values (new-body defn-info mutated) + (schemify-body* bodys/constants-lifted reannotate prim-knowns imports exports + for-jitify? allow-set!-undefined? add-import! #f unsafe-mode?)) + (define all-grps (append grps (reverse new-grps))) + (values + ;; Build `lambda` with schemified body: + (make-let* + lifted-constants + `(lambda (instance-variable-reference + ,@(for*/list ([grp (in-list all-grps)] + [im (in-list (import-group-imports grp))]) + (import-id im)) + ,@(for/list ([ex-id (in-list ex-ids)]) + (export-id (hash-ref exports (ex-int-id ex-id))))) + ,@new-body)) + ;; Imports (external names), possibly extended via inlining: + (for/list ([grp (in-list all-grps)]) + (for/list ([im (in-list (import-group-imports grp))]) + (import-ext-id im))) + ;; Exports (external names): + (for/list ([ex-id (in-list ex-ids)]) + (ex-ext-id ex-id)) + ;; Import keys --- revised if we added any import groups + (if (null? new-grps) + import-keys + (for/vector #:length (length all-grps) ([grp (in-list all-grps)]) + (import-group-key grp))) + ;; Import ABI: request values for constants, `variable`s otherwise + (for/list ([grp (in-list all-grps)]) + (define im-ready? (import-group-lookup-ready? grp)) + (for/list ([im (in-list (import-group-imports grp))]) + (and im-ready? + (known-constant? (import-group-lookup grp (import-ext-id im)))))) + ;; Convert internal to external identifiers + (for/fold ([knowns (hasheq)]) ([ex-id (in-list ex-ids)]) + (define id (ex-int-id ex-id)) + (define v (known-inline->export-known (hash-ref defn-info id #f) + prim-knowns imports exports)) + (cond + [(and v + (not (set!ed-mutated-state? (hash-ref mutated id #f)))) + (define ext-id (ex-ext-id ex-id)) + (hash-set knowns ext-id v)] + [else knowns])))])) + +;; ---------------------------------------- + +(define (schemify-body l reannotate prim-knowns imports exports for-cify? unsafe-mode?) + (define-values (new-body defn-info mutated) + (schemify-body* l reannotate prim-knowns imports exports + #f #f (lambda (im ext-id index) #f) + for-cify? unsafe-mode?)) + new-body) + +(define (schemify-body* l reannotate prim-knowns imports exports + for-jitify? allow-set!-undefined? add-import! + for-cify? unsafe-mode?) + ;; Various conversion steps need information about mutated variables, + ;; where "mutated" here includes visible implicit mutation, such as + ;; a variable that might be used before it is defined: + (define mutated (mutated-in-body l exports prim-knowns (hasheq) imports)) + ;; Make another pass to gather known-binding information: + (define knowns + (for/fold ([knowns (hasheq)]) ([form (in-list l)]) + (define-values (new-knowns info) + (find-definitions form prim-knowns knowns imports mutated #t)) + new-knowns)) + ;; While schemifying, add calls to install exported values in to the + ;; corresponding exported `variable` records, but delay those + ;; installs to the end, if possible + (define schemified + (let loop ([l l] [accum-exprs null] [accum-ids null]) + (cond + [(null? l) + (define set-vars + (for/list ([id (in-list accum-ids)] + #:when (hash-ref exports id #f)) + (make-set-variable id exports knowns mutated))) + (cond + [(null? set-vars) + (cond + [(null? accum-exprs) '((void))] + [else (reverse accum-exprs)])] + [else (append (reverse accum-exprs) + set-vars)])] + [else + (define form (car l)) + (define schemified (schemify form reannotate + prim-knowns knowns mutated imports exports + allow-set!-undefined? + add-import! + for-cify? + unsafe-mode?)) + (match form + [`(define-values ,ids ,_) + (append + (if (or for-jitify? for-cify?) + (reverse accum-exprs) + (make-expr-defns accum-exprs)) + (cons + schemified + (let id-loop ([ids ids] [accum-exprs null] [accum-ids accum-ids]) + (cond + [(wrap-null? ids) (loop (wrap-cdr l) accum-exprs accum-ids)] + [(or (or for-jitify? for-cify?) + (via-variable-mutated-state? (hash-ref mutated (unwrap (wrap-car ids)) #f))) + (define id (unwrap (wrap-car ids))) + (cond + [(hash-ref exports id #f) + (id-loop (wrap-cdr ids) + (cons (make-set-variable id exports knowns mutated) + accum-exprs) + accum-ids)] + [else + (id-loop (wrap-cdr ids) accum-exprs accum-ids)])] + [else + (id-loop (wrap-cdr ids) accum-exprs (cons (unwrap (wrap-car ids)) accum-ids))]))))] + [`,_ + (loop (wrap-cdr l) (cons schemified accum-exprs) accum-ids)])]))) + ;; Return both schemified and known-binding information, where + ;; the later is used for cross-linklet optimization + (values schemified knowns mutated)) + +(define (make-set-variable id exports knowns mutated) + (define int-id (unwrap id)) + (define ex (hash-ref exports int-id)) + `(variable-set! ,(export-id ex) ,id ',(variable-constance int-id knowns mutated))) + +(define (make-expr-defns accum-exprs) + (for/list ([expr (in-list (reverse accum-exprs))]) + `(define ,(gensym) (begin ,expr (void))))) + +(define (variable-constance id knowns mutated) + (cond + [(set!ed-mutated-state? (hash-ref mutated id #f)) + #f] + [(known-consistent? (hash-ref knowns id #f)) + 'consistent] + [else + 'constant])) + +;; ---------------------------------------- + +;; Schemify `let-values` to `let`, etc., and +;; reorganize struct bindings. +(define (schemify v reannotate prim-knowns knowns mutated imports exports allow-set!-undefined? add-import! + for-cify? unsafe-mode?) + (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [v v]) + (let schemify ([v v]) + (define s-v + (reannotate + v + (match v + [`(lambda ,formals ,body ...) + `(lambda ,formals ,@(map schemify body))] + [`(case-lambda [,formalss ,bodys ...] ...) + `(case-lambda ,@(for/list ([formals (in-list formalss)] + [body (in-list bodys)]) + `[,formals ,@(map schemify body)]))] + [`(define-values (,struct:s ,make-s ,s? ,acc/muts ...) + (let-values (((,struct: ,make ,?1 ,-ref ,-set!) ,mk)) + (values ,struct:2 + ,make2 + ,?2 + ,make-acc/muts ...))) + #:guard (not for-cify?) + ;; Convert a `make-struct-type` binding into a + ;; set of bindings that Chez's cp0 recognizes, + ;; and push the struct-specific extra work into + ;; `struct-type-install-properties!` + (define sti (and (wrap-eq? struct: struct:2) + (wrap-eq? make make2) + (wrap-eq? ?1 ?2) + (make-struct-type-info mk prim-knowns knowns imports mutated))) + (cond + [(and sti + ;; make sure `struct:` isn't used too early, since we're + ;; reordering it's definition with respect to some arguments + ;; of `make-struct-type`: + (simple-mutated-state? (hash-ref mutated (unwrap struct:) #f))) + (define can-impersonate? (not (struct-type-info-authentic? sti))) + (define raw-s? (if can-impersonate? (gensym s?) s?)) + `(begin + (define ,struct:s (make-record-type-descriptor ',(struct-type-info-name sti) + ,(schemify (struct-type-info-parent sti)) + ,(if (not (struct-type-info-prefab-immutables sti)) + #f + `(structure-type-lookup-prefab-uid + ',(struct-type-info-name sti) + ,(schemify (struct-type-info-parent sti)) + ,(struct-type-info-immediate-field-count sti) + 0 #f + ',(struct-type-info-prefab-immutables sti))) + #f + #f + ',(for/vector ([i (in-range (struct-type-info-immediate-field-count sti))]) + `(mutable ,(string->symbol (format "f~a" i)))))) + ,@(if (null? (struct-type-info-rest sti)) + null + `((define ,(gensym) + (struct-type-install-properties! ,struct:s + ',(struct-type-info-name sti) + ,(struct-type-info-immediate-field-count sti) + 0 + ,(schemify (struct-type-info-parent sti)) + ,@(map schemify (struct-type-info-rest sti)))))) + (define ,make-s ,(let ([ctr `(record-constructor + (make-record-constructor-descriptor ,struct:s #f #f))]) + (if (struct-type-info-pure-constructor? sti) + ctr + `(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti))))) + (define ,raw-s? (record-predicate ,struct:s)) + ,@(if can-impersonate? + `((define ,s? (lambda (v) (if (,raw-s? v) #t (pariah (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))) + null) + ,@(for/list ([acc/mut (in-list acc/muts)] + [make-acc/mut (in-list make-acc/muts)]) + (define raw-acc/mut (if can-impersonate? (gensym acc/mut) acc/mut)) + (match make-acc/mut + [`(make-struct-field-accessor ,(? (lambda (v) (wrap-eq? v -ref))) ,pos ,_) + (define raw-def `(define ,raw-acc/mut (record-accessor ,struct:s ,pos))) + (if can-impersonate? + `(begin + ,raw-def + (define ,acc/mut + (lambda (s) (if (,raw-s? s) + (,raw-acc/mut s) + (pariah (impersonate-ref ,raw-acc/mut ,struct:s ,pos s)))))) + raw-def)] + [`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ,_) + (define raw-def `(define ,raw-acc/mut (record-mutator ,struct:s ,pos))) + (define abs-pos (+ pos (- (struct-type-info-field-count sti) + (struct-type-info-immediate-field-count sti)))) + (if can-impersonate? + `(begin + ,raw-def + (define ,acc/mut + (lambda (s v) (if (,raw-s? s) + (,raw-acc/mut s v) + (pariah (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v)))))) + raw-def)] + [`,_ (error "oops")])) + (define ,(gensym) + (begin + (register-struct-constructor! ,make-s) + (register-struct-predicate! ,s?) + ,@(for/list ([acc/mut (in-list acc/muts)] + [make-acc/mut (in-list make-acc/muts)]) + (match make-acc/mut + [`(make-struct-field-accessor ,_ ,pos ,_) + `(register-struct-field-accessor! ,acc/mut ,struct:s ,pos)] + [`(make-struct-field-mutator ,_ ,pos ,_) + `(register-struct-field-mutator! ,acc/mut ,struct:s ,pos)] + [`,_ (error "oops")])) + (void))))] + [else + (match v + [`(,_ ,ids ,rhs) + `(define-values ,ids ,(schemify rhs))])])] + [`(define-values (,id) ,rhs) + `(define ,id ,(schemify rhs))] + [`(define-values ,ids ,rhs) + `(define-values ,ids ,(schemify rhs))] + [`(quote ,_) v] + [`(let-values () ,body) + (schemify body)] + [`(let-values () ,bodys ...) + (schemify `(begin . ,bodys))] + [`(let-values ([(,ids) ,rhss] ...) ,bodys ...) + (define new-knowns + (for/fold ([knowns knowns]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (define k (infer-known rhs #f #f id knowns prim-knowns imports mutated)) + (if k + (hash-set knowns (unwrap id) k) + knowns))) + (left-to-right/let ids + (for/list ([rhs (in-list rhss)]) + (schemify rhs)) + (for/list ([body (in-list bodys)]) + (schemify/knowns new-knowns inline-fuel body)) + prim-knowns knowns imports mutated)] + [`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...) + `(begin ,@(map schemify rhss) ,@(map schemify bodys))] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + (left-to-right/let-values idss + (for/list ([rhs (in-list rhss)]) + (schemify rhs)) + (map schemify bodys) + mutated + for-cify?)] + [`(letrec-values () ,bodys ...) + (schemify `(begin . ,bodys))] + [`(letrec-values ([() (values)]) ,bodys ...) + (schemify `(begin . ,bodys))] + [`(letrec-values ([(,id) (values ,rhs)]) ,bodys ...) + ;; special case of splitable values: + (schemify `(letrec-values ([(,id) ,rhs]) . ,bodys))] + [`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...) + (define new-knowns + (for/fold ([knowns knowns]) ([id (in-list ids)] + [rhs (in-list rhss)]) + (define k (infer-known rhs #f #t id knowns prim-knowns imports mutated)) + (if k + (hash-set knowns (unwrap id) k) + knowns))) + `(letrec* ,(for/list ([id (in-list ids)] + [rhs (in-list rhss)]) + `[,id ,(schemify/knowns new-knowns inline-fuel rhs)]) + ,@(for/list ([body (in-list bodys)]) + (schemify/knowns new-knowns inline-fuel body)))] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + (cond + [(letrec-splitable-values-binding? idss rhss) + (schemify + (letrec-split-values-binding idss rhss bodys))] + [else + ;; Convert + ;; (letrec*-values ([(id ...) rhs] ...) ....) + ;; to + ;; (letrec* ([vec (call-with-values rhs vector)] + ;; [id (vector-ref vec 0)] + ;; ... ...) + ;; ....) + `(letrec* ,(apply + append + (for/list ([ids (in-wrap-list idss)] + [rhs (in-list rhss)]) + (let ([rhs (schemify rhs)]) + (cond + [(null? ids) + `([,(gensym "lr") + ,(make-let-values null rhs '(void) for-cify?)])] + [(and (pair? ids) (null? (cdr ids))) + `([,(car ids) ,rhs])] + [else + (define lr (gensym "lr")) + `([,lr ,(make-let-values ids rhs `(vector . ,ids) for-cify?)] + ,@(for/list ([id (in-list ids)] + [pos (in-naturals)]) + `[,id (unsafe-vector*-ref ,lr ,pos)]))])))) + ,@(map schemify bodys))])] + [`(if ,tst ,thn ,els) + `(if ,(schemify tst) ,(schemify thn) ,(schemify els))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(schemify key) ,(schemify val) ,(schemify body))] + [`(begin ,exp) + (schemify exp)] + [`(begin ,exps ...) + `(begin . ,(map schemify exps))] + [`(begin0 ,exps ...) + `(begin0 . ,(map schemify exps))] + [`(set! ,id ,rhs) + (define int-id (unwrap id)) + (define ex (hash-ref exports int-id #f)) + (if ex + `(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,(schemify rhs) '#f) + `(set! ,id ,(schemify rhs)))] + [`(variable-reference-constant? (#%variable-reference ,id)) + (let ([id (unwrap id)]) + (and (not (hash-ref mutated id #f)) + (let ([im (hash-ref imports id #f)]) + (or (not im) + (known-constant? (import-lookup im))))))] + [`(variable-reference-from-unsafe? (#%variable-reference)) + unsafe-mode?] + [`(#%variable-reference) + 'instance-variable-reference] + [`(#%variable-reference ,id) + (define u (unwrap id)) + (define v (or (let ([ex (hash-ref exports u #f)]) + (and ex (export-id ex))) + (let ([im (hash-ref imports u #f)]) + (and im (import-id im))))) + (if v + `(make-instance-variable-reference + instance-variable-reference + ,v) + `(make-instance-variable-reference + instance-variable-reference + ',(if (hash-ref mutated u #f) + 'mutable + 'immutable)))] + [`(equal? ,exp1 ,exp2) + (let ([exp1 (schemify exp1)] + [exp2 (schemify exp2)]) + (cond + [(or (equal-implies-eq? exp1) (equal-implies-eq? exp2)) + `(eq? ,exp1 ,exp2)] + [(or (equal-implies-eqv? exp1) (equal-implies-eqv? exp2)) + `(eqv? ,exp1 ,exp2)] + [else + (left-to-right/app 'equal? + (list exp1 exp2) + #t for-cify? + prim-knowns knowns imports mutated)]))] + [`(call-with-values ,generator ,receiver) + (cond + [(and (lambda? generator) + (lambda? receiver)) + `(call-with-values ,(schemify generator) ,(schemify receiver))] + [else + (left-to-right/app (if for-cify? 'call-with-values '#%call-with-values) + (list (schemify generator) (schemify receiver)) + #t for-cify? + prim-knowns knowns imports mutated)])] + [`((letrec-values ,binds ,rator) ,rands ...) + (schemify `(letrec-values ,binds (,rator . ,rands)))] + [`(,rator ,exps ...) + (define (left-left-lambda-convert rator inline-fuel) + (match rator + [`(lambda ,formal-args ,bodys ...) + ;; Try to line up `formal-args` with `exps` + (let loop ([formal-args formal-args] [args exps] [binds '()]) + (cond + [(wrap-null? formal-args) + (and (wrap-null? args) + (schemify/knowns knowns + inline-fuel + `(let-values ,(reverse binds) . ,bodys)))] + [(null? args) #f] + [(not (wrap-pair? formal-args)) #f] + [else + (loop (wrap-cdr formal-args) + (wrap-cdr args) + (cons (list (list (wrap-car formal-args)) + (wrap-car args)) + binds))]))] + [`(case-lambda [,formal-args ,bodys ...] . ,rest) + (or (left-left-lambda-convert `(lambda ,formal-args . ,bodys) inline-fuel) + (left-left-lambda-convert `(case-lambda . ,rest) inline-fuel))] + [`,_ #f])) + (define (inline-rator) + (define u-rator (unwrap rator)) + (and (symbol? u-rator) + (let ([k (find-known u-rator prim-knowns knowns imports mutated)]) + (and (known-procedure/can-inline? k) + (left-left-lambda-convert + (inline-clone k (hash-ref imports u-rator #f) add-import! mutated imports reannotate) + (sub1 inline-fuel)))))) + (or (left-left-lambda-convert rator inline-fuel) + (and (positive? inline-fuel) + (inline-rator)) + (let ([s-rator (schemify rator)] + [args (map schemify exps)] + [u-rator (unwrap rator)]) + (let ([plain-app? + (or (known-procedure? (find-known u-rator prim-knowns knowns imports mutated)) + (lambda? rator))]) + (left-to-right/app s-rator + args + plain-app? for-cify? + prim-knowns knowns imports mutated))))] + [`,_ + (let ([u-v (unwrap v)]) + (cond + [(not (symbol? u-v)) + v] + [(and (via-variable-mutated-state? (hash-ref mutated u-v #f)) + (hash-ref exports u-v #f)) + => (lambda (ex) `(variable-ref ,(export-id ex)))] + [(hash-ref imports u-v #f) + => (lambda (im) + (define k (import-lookup im)) + (if (known-constant? k) + ;; Not boxed: + (cond + [(known-literal? k) + ;; We'd normally leave this to `optimize`, but + ;; need to handle it here before generating a + ;; reference to the renamed identifier + (known-literal-expr k)] + [else + (import-id im)]) + ;; Will be boxed, but won't be undefined (because the + ;; module system won't link to an instance whose + ;; definitions didn't complete): + `(variable-ref/no-check ,(import-id im))))] + [(hash-ref knowns u-v #f) + => (lambda (k) + (cond + [(and (known-copy? k) + (simple-mutated-state? (hash-ref mutated u-v #f))) + (schemify (known-copy-id k))] + [else v]))] + [else v]))]))) + (optimize s-v prim-knowns knowns imports mutated)))) diff --git a/racket/src/schemify/serialize.rkt b/racket/src/schemify/serialize.rkt new file mode 100644 index 0000000000..d154cb30e7 --- /dev/null +++ b/racket/src/schemify/serialize.rkt @@ -0,0 +1,206 @@ +#lang racket/base +(require racket/extflonum + "match.rkt" + "quoted.rkt") + +(provide convert-for-serialize) + +;; Some quoted Racket values cannot be serialized and deserialized +;; automatically by Scheme: keywords (because they need to be interned +;; when reading code), strings and byte strings (ditto), regexps +;; (because they contain function pointers), etc. +;; +;; For those kinds of values, lift a construction of the quoted value +;; out and replace the use of a quoted value with a variable +;; reference. This lifting can interefere with optimizations, so only +;; lift as a last resort. + +(define (convert-for-serialize bodys for-cify?) + (define lifted-eq-constants (make-hasheq)) + (define lifted-equal-constants (make-hash)) + (define lift-bindings null) + (define lifts-count 0) + (define (add-lifted rhs) + ;; FIXME: make sure these `id`s don't collide with anything + (define id (string->symbol (format "q:~a" lifts-count))) + (set! lifts-count (add1 lifts-count)) + (set! lift-bindings (cons (list id rhs) lift-bindings)) + id) + (define new-bodys + (for/list ([v (in-list bodys)]) + (cond + [(convert-any? v for-cify?) + (define (convert v) + (match v + [`(quote ,q) + (cond + [(lift-quoted? q for-cify?) + (make-construct q add-lifted lifted-eq-constants lifted-equal-constants for-cify?)] + [else v])] + [`(lambda ,formals ,body ...) + `(lambda ,formals ,@(convert-function-body body))] + [`(case-lambda [,formalss ,bodys ...] ...) + `(case-lambda ,@(for/list ([formals (in-list formalss)] + [body (in-list bodys)]) + `[,formals ,@(convert-function-body body)]))] + [`(define-values ,ids ,rhs) + `(define-values ,ids ,(convert rhs))] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + `(let-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(convert rhs)]) + ,@(convert-body bodys))] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + `(letrec-values ,(for/list ([ids (in-list idss)] + [rhs (in-list rhss)]) + `[,ids ,(convert rhs)]) + ,@(convert-body bodys))] + [`(if ,tst ,thn ,els) + `(if ,(convert tst) ,(convert thn) ,(convert els))] + [`(with-continuation-mark ,key ,val ,body) + `(with-continuation-mark ,(convert key) ,(convert val) ,(convert body))] + [`(begin ,exps ...) + `(begin . ,(convert-body exps))] + [`(begin0 ,exps ...) + `(begin0 . ,(convert-body exps))] + [`(set! ,id ,rhs) + `(set! ,id ,(convert rhs))] + [`(#%variable-reference) v] + [`(#%variable-reference ,_) v] + [`(,rator ,exps ...) + `(,(convert rator) ,@(convert-body exps))] + [`,_ + (cond + [(and for-cify? + (not (symbol? v)) + (lift-quoted? v for-cify?)) + (convert `(quote ,v))] + [else v])])) + (define (convert-body body) + (for/list ([e (in-list body)]) + (convert e))) + (define (convert-function-body body) + (if for-cify? + ;; Detect the function-name pattern and avoid + ;; mangling it: + (match body + [`((begin (quote ,name) ,body . ,bodys)) + `((begin (quote ,name) ,@(convert-body (cons body bodys))))] + [`,_ (convert-body body)]) + (convert-body body))) + (convert v)] + [else v]))) + (values new-bodys + (reverse lift-bindings))) + +;; v is a form or a list of forms +(define (convert-any? v for-cify?) + (let convert-any? ([v v]) + (match v + [`(quote ,q) (lift-quoted? q for-cify?)] + [`(lambda ,formals ,body ...) + (convert-any? body)] + [`(case-lambda [,formalss ,bodys ...] ...) + (convert-any? bodys)] + [`(define-values ,ids ,rhs) + (convert-any? rhs)] + [`(let-values ([,idss ,rhss] ...) ,bodys ...) + (or (convert-any? rhss) + (convert-any? bodys))] + [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) + (or (convert-any? rhss) + (convert-any? bodys))] + [`(if ,tst ,thn ,els) + (or (convert-any? tst) + (convert-any? thn) + (convert-any? els))] + [`(with-continuation-mark ,key ,val ,body) + (or (convert-any? key) + (convert-any? val) + (convert-any? body))] + [`(begin ,exps ...) + (convert-any? exps)] + [`(begin0 ,exps ...) + (convert-any? exps)] + [`(set! ,id ,rhs) + (convert-any? rhs)] + [`(#%variable-reference) #f] + [`(#%variable-reference ,_) #f] + [`(,exps ...) + (for/or ([exp (in-list exps)]) + (convert-any? exp))] + [`,_ (and for-cify? + (not (symbol? v)) + (lift-quoted? v for-cify?))]))) + +;; Construct an expression to be lifted +(define (make-construct q add-lifted lifted-eq-constants lifted-equal-constants for-cify?) + (define (quote? e) (and (pair? e) (eq? 'quote (car e)))) + (let make-construct ([q q]) + (define lifted-constants (if (or (string? q) (bytes? q)) + lifted-equal-constants + lifted-eq-constants)) + (cond + [(hash-ref lifted-constants q #f) + => (lambda (id) id)] + [else + (define rhs + (cond + [(path? q) `(bytes->path ,(path->bytes q) + ',(path-convention-type q))] + [(regexp? q) + `(,(if (pregexp? q) 'pregexp 'regexp) ,(object-name q))] + [(byte-regexp? q) + `(,(if (byte-pregexp? q) 'byte-pregexp 'byte-regexp) ,(object-name q))] + [(keyword? q) + `(string->keyword ,(keyword->string q))] + [(hash? q) + `(,(cond + [(hash-eq? q) 'hasheq] + [(hash-eqv? q) 'hasheqv] + [else 'hash]) + ,@(apply append + (for/list ([(k v) (in-hash q)]) + (list (make-construct k) + (make-construct v)))))] + [(string? q) `(datum-intern-literal ,q)] + [(bytes? q) `(datum-intern-literal ,q)] + [(pair? q) + (if (list? q) + (let ([args (map make-construct q)]) + (if (andmap quote? args) + `(quote ,q) + `(list ,@(map make-construct q)))) + (let ([a (make-construct (car q))] + [d (make-construct (cdr q))]) + (if (and (quote? a) (quote? d)) + `(quote ,q) + `(cons ,a ,d))))] + [(vector? q) + (let ([args (map make-construct (vector->list q))]) + (if (and (andmap quote? args) + (not (impersonator? q))) + `(quote ,q) + `(vector ,@args)))] + [(box? q) + (let ([arg (make-construct (unbox q))]) + (if (and (quote? arg) + (not (impersonator? q))) + `(quote ,q) + `(box ,arg)))] + [(prefab-struct-key q) + => (lambda (key) + `(make-prefab-struct ',key ,@(map make-construct + (cdr (vector->list (struct->vector q))))))] + [(extflonum? q) + `(string->number ,(format "~a" q) 10 'read)] + [else `(quote ,q)])) + (cond + [(and (quote? rhs) + (or (not for-cify?) + (not (lift-quoted? (cadr rhs) #t)))) + rhs] + [else + (define id (add-lifted rhs)) + (hash-set! lifted-constants q id) + id])]))) diff --git a/racket/src/schemify/simple.rkt b/racket/src/schemify/simple.rkt new file mode 100644 index 0000000000..8930ac85cb --- /dev/null +++ b/racket/src/schemify/simple.rkt @@ -0,0 +1,54 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "mutated-state.rkt") + +(provide simple?) + +;; Check whether an expression is simple in the sense that its order +;; of evaluation isn't detectable. This function receives both +;; schemified and non-schemified expressions. +(define (simple? e prim-knowns knowns imports mutated) + (let simple? ([e e]) + (match e + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`(quote . ,_) #t] + [`(#%variable-reference . ,_) #t] + [`(let-values ([,_ ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(let ([,_ ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(letrec-values ([(,idss ...) ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(letrec* ([,ids ,rhss] ...) ,body) + (and (for/and ([rhs (in-list rhss)]) + (simple? rhs)) + (simple? body))] + [`(,proc . ,args) + (let ([proc (unwrap proc)]) + (and (symbol? proc) + (let ([v (or (hash-ref-either knowns imports proc) + (hash-ref prim-knowns proc #f))]) + (and (known-procedure/succeeds? v) + (bitwise-bit-set? (known-procedure-arity-mask v) (length args)))) + (simple-mutated-state? (hash-ref mutated proc #f)) + (for/and ([arg (in-list args)]) + (simple? arg))))] + [`,_ + (let ([e (unwrap e)]) + (or (and (symbol? e) + (simple-mutated-state? (hash-ref mutated e #f))) + (integer? e) + (boolean? e) + (string? e) + (bytes? e) + (regexp? e)))]))) diff --git a/racket/src/schemify/size.rkt b/racket/src/schemify/size.rkt new file mode 100644 index 0000000000..e26a7e6f8f --- /dev/null +++ b/racket/src/schemify/size.rkt @@ -0,0 +1,76 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "quoted.rkt") + +;; The `linklet-bigger-than?` function is practically an S-expression +;; counter, but it parses expressions properly so it can stop at +;; `quote`. + +(provide linklet-bigger-than?) + +(define (linklet-bigger-than? e size serializable?) + + (define (leftover-size e size) + (cond + [(size . <= . 0) 0] + [else + (match e + [`(begin . ,body) + (body-leftover-size body (sub1 size))] + [`(define-values ,_ ,rhs) + (leftover-size rhs (sub1 size))] + [`(lambda ,_ . ,body) + (body-leftover-size body (sub1 size))] + [`(case-lambda [,_ . ,bodys] ...) + (body-leftover-size bodys (sub1 size))] + [`(let-values ([,_ ,rhss] ...) + . ,body) + (body-leftover-size (cons rhss body) (sub1 size))] + [`(letrec-values ([,_ ,rhss] ...) + . ,body) + (body-leftover-size (cons rhss body) (sub1 size))] + [`(if ,tst ,thn ,els) + (leftover-size els (leftover-size thn (leftover-size tst (sub1 size))))] + [`(with-continuation-mark ,key ,val ,body) + (leftover-size body (leftover-size val (leftover-size key (sub1 size))))] + [`(begin0 . ,body) + (body-leftover-size body (sub1 size))] + [`(quote ,v) (if (and serializable? + (lift-quoted? v #f)) + ;; pessimistically assume that full + ;; strcuture must be lifted for + ;; serialization: + (s-expr-leftover-size v size) + (sub1 size))] + [`(set! ,id ,rhs) (leftover-size rhs (sub1 size))] + [`(#%variable-reference . ,_) (sub1 size)] + [`(,_ . ,_) (body-leftover-size e size)] + [`,_ (sub1 size)])])) + + (define (body-leftover-size body size) + (for/fold ([size size]) ([e (in-wrap-list body)] + #:break (size . <= . 0)) + (leftover-size e size))) + + (define (s-expr-leftover-size v size) + (cond + [(size . <= . 0) 0] + [(pair? v) (s-expr-leftover-size + (cdr v) + (s-expr-leftover-size (car v) (sub1 size)))] + [(box? v) (s-expr-leftover-size (unbox v) (sub1 size))] + [(vector? v) (for/fold ([size (sub1 size)]) ([v (in-vector v)] + #:break (size . <= . 0)) + (s-expr-leftover-size v size))] + [(prefab-struct-key v) + (s-expr-leftover-size (struct->vector v) size)] + [(hash? v) + (for/fold ([size (sub1 size)]) ([(k v) (in-hash v)] + #:break (size . <= . 0)) + (s-expr-leftover-size v (s-expr-leftover-size k size)))] + [else (sub1 size)])) + + (match e + [`(linklet ,_ ,_ . ,body) + ((body-leftover-size body size) . <= . 0)])) diff --git a/racket/src/schemify/struct-type-info.rkt b/racket/src/schemify/struct-type-info.rkt new file mode 100644 index 0000000000..421820ac5d --- /dev/null +++ b/racket/src/schemify/struct-type-info.rkt @@ -0,0 +1,120 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "known.rkt" + "import.rkt" + "mutated-state.rkt" + "simple.rkt" + "find-known.rkt") + +(provide (struct-out struct-type-info) + struct-type-info-rest-properties-list-pos + make-struct-type-info + pure-properties-list?) + +(struct struct-type-info (name parent + immediate-field-count + field-count + pure-constructor? + authentic? + prefab-immutables ; #f or immutable expression to be quoted + rest)) ; argument expressions after auto-field value +(define struct-type-info-rest-properties-list-pos 0) + +;; Parse `make-struct-type` forms, returning a `struct-type-info` +;; if the parse succeed: +(define (make-struct-type-info v prim-knowns knowns imports mutated) + (match v + [`(make-struct-type (quote ,name) ,parent ,fields 0 #f . ,rest) + ;; Note: auto-field count must be zero, because a non-zero count involves + ;; an arity-reduced procedure + (let ([u-name (unwrap name)] + [u-parent (let ([u-parent (unwrap parent)]) + (or (extract-struct-typed-from-checked u-parent) + u-parent))]) + (and (symbol? u-name) + (or (not u-parent) + (known-struct-type? + (find-known u-parent prim-knowns knowns imports mutated))) + (exact-nonnegative-integer? fields) + (let ([prefab-imms + ;; The inspector argument needs to be missing or duplicable, + ;; and if it's not known to produce a value other than 'prefab, + ;; the list of immutables must be duplicable: + (match rest + [`() 'non-prefab] + [`(,_) 'non-prefab] + [`(,_ #f . ,_) 'non-prefab] + [`(,_ (current-inspector) . ,_) 'non-prefab] + [`(,_ 'prefab ,_ ',immutables . ,_) immutables] + [`(,_ 'prefab ,_) '()] + [`(,_ 'prefab) '()] + [`,_ #f])] + [parent-sti (and u-parent (find-known u-parent prim-knowns knowns imports mutated))]) + (define (includes-property? name) + (and (pair? rest) + (match (car rest) + [`(list (cons ,props ,vals) ...) + (for/or ([prop (in-list props)]) + (eq? (unwrap prop) name))] + [`,_ #f]))) + (and prefab-imms + (struct-type-info name + parent + fields + (+ fields (if u-parent + (known-struct-type-field-count parent-sti) + 0)) + ;; no guard & no prop:chaperone-unsafe-undefined => pure constructor + (and (or (not u-parent) + (known-struct-type-pure-constructor? parent-sti)) + (or ((length rest) . < . 5) + (not (unwrap (list-ref rest 4)))) + (not (includes-property? 'prop:chaperone-unsafe-undefined))) + (includes-property? 'prop:authentic) + (if (eq? prefab-imms 'non-prefab) + #f + prefab-imms) + rest)))))] + [`(let-values () ,body) + (make-struct-type-info body prim-knowns knowns imports mutated)] + [`,_ #f])) + +;; Check whether `e` has the shape of a property list that uses only +;; properties where the property doesn't have a guard or won't invoke +;; a guarded procedure +(define (pure-properties-list? e prim-knowns knowns imports mutated) + (match e + [`(list (cons ,props ,vals) ...) + (for/and ([prop (in-list props)] + [val (in-list vals)]) + (let ([u-prop (unwrap prop)]) + (and (symbol? u-prop) + (or (known-struct-type-property/immediate-guard? + (find-known u-prop prim-knowns knowns imports mutated))) + (simple? val prim-knowns knowns imports mutated))))] + [`null #t] + [`'() #t] + [`,_ #f])) + +;; Recognide +;; (let (( )) +;; (if (struct-type? +;; ....)) +;; and return . This happens when `#:parent` +;; is used in `struct` instead of specifying a parent +;; name next to the struct name. +(define (extract-struct-typed-from-checked e) + (match e + [`(let-values ([(,tmp1) ,id]) + (if (struct-type? ,tmp2) + ,tmp3 + ,_)) + (define u-tmp1 (unwrap tmp1)) + (and (eq? u-tmp1 (unwrap tmp2)) + (eq? u-tmp1 (unwrap tmp3)) + (let ([u (unwrap id)]) + (and (symbol? u) + u)))] + [`,_ #f])) diff --git a/racket/src/schemify/wrap.rkt b/racket/src/schemify/wrap.rkt new file mode 100644 index 0000000000..870e3aa744 --- /dev/null +++ b/racket/src/schemify/wrap.rkt @@ -0,0 +1,97 @@ +#lang racket/base +(require racket/private/primitive-table + (for-syntax racket/base)) + +(provide unwrap unwrap-list + wrap-pair? wrap-null? wrap-car wrap-cdr wrap-list? + wrap-eq? wrap-equal? + in-wrap-list + wrap-property) + +(import-from-primitive-table + #%kernel + [syntax? correlated?] + [syntax-e correlated-e] + [syntax-property correlated-property]) + +(define (unwrap v) + (if (correlated? v) + (correlated-e v) + v)) + +(define (unwrap-list v) + (cond + [(null? v) null] + [(pair? v) + (let ([r (unwrap-list (cdr v))]) + (if (eq? r (cdr v)) + v + (cons (car v) r)))] + [(correlated? v) (unwrap-list (correlated-e v))] + [else v])) + +(define (wrap-car v) + (if (correlated? v) + (car (correlated-e v)) + (car v))) + +(define (wrap-cdr v) + (if (correlated? v) + (cdr (correlated-e v)) + (cdr v))) + +(define (wrap-pair? v) + (pair? (unwrap v))) + +(define (wrap-null? v) + (null? (unwrap v))) + +(define (wrap-list? v) + (cond + [(null? v) #t] + [(correlated? v) (wrap-list? (correlated-e v))] + [(pair? v) (wrap-list? (cdr v))] + [else #f])) + +(define (wrap-eq? a b) + (eq? (unwrap a) (unwrap b))) + +(define (wrap-equal? a b) + (let ([b (unwrap b)]) + (or (and (not (pair? a)) + (equal? a b)) + (and (pair? a) + (pair? b) + (wrap-equal? (car a) (car b)) + (wrap-equal? (car a) (car b)))))) + +(define (wrap-property a key) + (and (correlated? a) + (correlated-property a key))) + +(define-sequence-syntax in-wrap-list + (lambda (stx) (raise-argument-error "allowed only in `for` forms" stx)) + (lambda (stx) + (syntax-case stx () + [[(id) (_ lst-expr)] + (for-clause-syntax-protect + #'[(id) + (:do-in + ;;outer bindings + ([(lst) lst-expr]) + ;; outer check + (void) + ;; loop bindings + ([lst lst]) + ;; pos check + (not (wrap-null? lst)) + ;; inner bindings + ([(id) (if (wrap-pair? lst) (wrap-car lst) lst)] + [(rest) (if (wrap-pair? lst) (wrap-cdr lst) null)]) + ;; pre guard + #t + ;; post guard + #t + ;; loop args + (rest))])] + [_ #f]))) diff --git a/racket/src/setup-go.rkt b/racket/src/setup-go.rkt new file mode 100644 index 0000000000..39fe9006bd --- /dev/null +++ b/racket/src/setup-go.rkt @@ -0,0 +1,108 @@ +#lang racket/base +(require compiler/depend + ;; This dependency on `compiler/private/cm-minimal` + ;; ensure that it's compiled so that the next use + ;; of "setup-go.rkt" doesn't have to start from source + compiler/private/cm-minimal) + +;; This module is loaded via `setup/main` with a `--boot` argument +;; that selects this module and sets the compile-file root directory +;; to be within the build directory. +;; +;; Overall arguments: +;; +;; --boot +;; +;; ... +;; +;; where is the file to load (bootstrapping as needed), and +;; the s are made the command-line argument for . The +;; is the output file that generates. The +;; is written as makefile rule for , where +;; a "$" is added to the front of if it's parenthesized. +;; +;; If is `--tag`, then specifies a tag to +;; get stripped form , there the target file is immediately after +;; the tag. In that case, the dependency file name is formed by using +;; just the file name of the target, replacing the suffix with ".d". +;; +;; The point of going through `setup/main` is that the Racket module +;; gets compiled as needed, so that it doesn't have to be loaded from +;; source every time. At the same time `setup/main` detects when files +;; need to be recompiled, either becuase the underlying Racket's +;; version changed or because a dependency changed. + +(provide go) + +(define (go orig-compile-file-paths) + (define SETUP-ARGS 6) + (define prog-args (list-tail (vector->list (current-command-line-arguments)) SETUP-ARGS)) + (define target-file-spec (vector-ref (current-command-line-arguments) 3)) + (define target-tag (and (equal? target-file-spec "--tag") + (vector-ref (current-command-line-arguments) 4))) + (define target-file (if target-tag + (let loop ([l prog-args]) + (cond + [(or (null? l) (null? (cdr l))) + (error 'setup-go "could not find target")] + [(equal? (car l) target-tag) (cadr l)] + [else (loop (cdr l))])) + target-file-spec)) + (define make-dep-file (if target-tag + (let-values ([(base name dir?) (split-path target-file)]) + (path-replace-suffix name #".d")) + (vector-ref (current-command-line-arguments) 4))) + (define mod-file (simplify-path (path->complete-path (vector-ref (current-command-line-arguments) 5)))) + (parameterize ([current-command-line-arguments + ;; Discard `--boot` through arguments to this + ;; module, and also strip `target-tag` (if any). + (list->vector (let loop ([l prog-args]) + (cond + [(null? l) '()] + [(equal? (car l) target-tag) (cdr l)] + [else (cons (car l) (loop (cdr l)))])))]) + ;; In case multiple xforms run in parallel, use a lock file so + ;; that only one is building. + (define lock-file (build-path (car (current-compiled-file-roots)) "SETUP-LOCK")) + (define lock-port (open-output-file #:exists 'truncate/replace lock-file)) + (let loop ([n 0]) + (when (= n 3) + (printf "Waiting on lock: ~a" lock-file)) + (unless (port-try-file-lock? lock-port 'exclusive) + (sleep 0.1) + (loop (add1 n)))) + + (with-handlers ([exn? (lambda (exn) + ;; On any execption, try to delete the target file + (with-handlers ([exn:fail:filesystem? + (lambda (exn) (log-error "~s" exn))]) + (when (file-exists? target-file) + (delete-file target-file))) + (raise exn))]) + (dynamic-wind + void + (lambda () + ;; Load the requested module, but don't instantiate: + (dynamic-require mod-file (void))) + (lambda () + (port-file-unlock lock-port))) + + ;; Record dependencies (before running `mod-file`, in case + ;; it mangles parameters) + (define deps (cons mod-file + (module-recorded-dependencies mod-file))) + (define (quote-if-space s) + ;; We're not handling arbitrary paths, but at least support spaces + (if (regexp-match? #rx" " s) (format "\"~a\"" s) s)) + (call-with-output-file make-dep-file + #:exists 'truncate + (lambda (o) + (fprintf o "~a: " (if (regexp-match? #rx"^[(].*[)]$" target-file) + (string-append "$" target-file) + (quote-if-space target-file))) + (for ([dep (in-list deps)]) + (fprintf o " \\\n ~a" (quote-if-space dep))) + (newline o))) + + ;; Now that the lock is released, instantiate: + (dynamic-require mod-file #f)))) diff --git a/racket/src/start/README.txt b/racket/src/start/README.txt new file mode 100644 index 0000000000..75967a26d5 --- /dev/null +++ b/racket/src/start/README.txt @@ -0,0 +1,4 @@ +This directory constaint source programs and fragments for wrapper +executables used to start/embed Racket. The programs and fragments are +used both for the traditional Racket virtual machine and Racket on +Chez Scheme. diff --git a/racket/src/start/config.inc b/racket/src/start/config.inc new file mode 100644 index 0000000000..d59010dcfb --- /dev/null +++ b/racket/src/start/config.inc @@ -0,0 +1,458 @@ +/* This code fragment embeds strings in an executable that can be + updated with various Racket exe-manipulation tools. */ + +#pragma GCC diagnostic ignored "-Wwrite-strings" + +char * volatile scheme_cmdline_exe_hack = (char *) + ("[Replace me for EXE hack " + " ]"); + +#if defined(MZ_CHEZ_SCHEME) +# define GC_PRECISION_TYPE "s" +#elif defined(MZ_PRECISE_GC) +# define GC_PRECISION_TYPE "3" +#else +# define GC_PRECISION_TYPE "c" +#endif +char * volatile scheme_binary_type_hack = "bINARy tYPe:" INITIAL_BIN_TYPE GC_PRECISION_TYPE; +/* The format of bINARy tYPe is e?[zr]i[3cs]. + e indicates a starter executable + z/r indicates Racket or GRacket + i indicates ??? + 3/c/s indicates 3m or CGC or Chez Scheme */ + +#ifndef INITIAL_COLLECTS_DIRECTORY +# ifdef DOS_FILE_SYSTEM +# define INITIAL_COLLECTS_DIRECTORY "collects" +# else +# define INITIAL_COLLECTS_DIRECTORY "../collects" +# endif +#endif + +char * volatile scheme_coldir = "coLLECTs dIRECTORy:" /* <- this tag stays, so we can find it again */ + INITIAL_COLLECTS_DIRECTORY + "\0\0" /* <- 1st nul terminates path, 2nd terminates path list */ + /* Pad with at least 1024 bytes: */ + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************"; +static int _coldir_offset = 19; /* Skip permanent tag */ + +#ifndef INITIAL_CONFIG_DIRECTORY +# ifdef DOS_FILE_SYSTEM +# define INITIAL_CONFIG_DIRECTORY "etc" +# else +# define INITIAL_CONFIG_DIRECTORY "../etc" +# endif +#endif + +char * volatile scheme_configdir = "coNFIg dIRECTORy:" /* <- this tag stays, so we can find it again */ + INITIAL_CONFIG_DIRECTORY + "\0" + /* Pad with at least 1024 bytes: */ + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************" + "****************************************************************"; +static int _configdir_offset = 17; /* Skip permanent tag */ + +#ifndef MZ_XFORM +# define GC_CAN_IGNORE /**/ +#endif + +#ifndef MZ_PRECISE_GC +# define XFORM_OK_PLUS + +#endif + +#ifdef OS_X +# include +# include +# include +#endif + +#ifdef DOS_FILE_SYSTEM +# include + +#ifndef DLL_RELATIVE_PATH +# define DLL_RELATIVE_PATH L"lib" +#endif +#include "delayed.inc" + +static wchar_t *extract_dlldir() +{ + if (_dlldir[_dlldir_offset] != '<') + return _dlldir + _dlldir_offset; + else + return NULL; +} + +# ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +# endif +#endif + +#ifdef OS_X +static long get_segment_offset() +{ +# if defined(__x86_64__) || defined(__arm64__) + const struct segment_command_64 *seg; +# else + const struct segment_command *seg; +#endif + seg = getsegbyname("__PLTSCHEME"); + if (seg) + return seg->fileoff; + else + return 0; +} +#endif + +#ifdef DOS_FILE_SYSTEM +wchar_t *get_self_executable_path() +{ + wchar_t *path; + DWORD r, sz = 1024; + + while (1) { + path = (wchar_t *)malloc(sz * sizeof(wchar_t)); + r = GetModuleFileNameW(NULL, path, sz); + if ((r == sz) + && (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) { + free(path); + sz = 2 * sz; + } else + break; + } + + return path; +} + +static DWORD find_by_id(HANDLE fd, DWORD rsrcs, DWORD pos, int id) +{ + DWORD got, val; + WORD name_count, id_count; + + SetFilePointer(fd, pos + 12, 0, FILE_BEGIN); + ReadFile(fd, &name_count, 2, &got, NULL); + ReadFile(fd, &id_count, 2, &got, NULL); + + pos += 16 + (name_count * 8); + while (id_count--) { + ReadFile(fd, &val, 4, &got, NULL); + if (val == id) { + ReadFile(fd, &val, 4, &got, NULL); + return rsrcs + (val & 0x7FFFFFF); + } else { + ReadFile(fd, &val, 4, &got, NULL); + } + } + + return 0; +} + +static long get_segment_offset() +{ + /* Find the resource of type 257 */ + wchar_t *path; + HANDLE fd; + + path = get_self_executable_path(); + fd = CreateFileW(path, GENERIC_READ, + FILE_SHARE_READ | FILE_SHARE_WRITE, + NULL, + OPEN_EXISTING, + 0, + NULL); + free(path); + + if (fd == INVALID_HANDLE_VALUE) + return 0; + else { + DWORD val, got, sec_pos, virtual_addr, rsrcs, pos; + WORD num_sections, head_size; + char name[8]; + + SetFilePointer(fd, 60, 0, FILE_BEGIN); + ReadFile(fd, &val, 4, &got, NULL); + SetFilePointer(fd, val+4+2, 0, FILE_BEGIN); /* Skip "PE\0\0" tag and machine */ + ReadFile(fd, &num_sections, 2, &got, NULL); + SetFilePointer(fd, 12, 0, FILE_CURRENT); /* time stamp + symbol table */ + ReadFile(fd, &head_size, 2, &got, NULL); + + sec_pos = val+4+20+head_size; + while (num_sections--) { + SetFilePointer(fd, sec_pos, 0, FILE_BEGIN); + ReadFile(fd, &name, 8, &got, NULL); + if ((name[0] == '.') + && (name[1] == 'r') + && (name[2] == 's') + && (name[3] == 'r') + && (name[4] == 'c') + && (name[5] == 0)) { + SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip virtual size */ + ReadFile(fd, &virtual_addr, 4, &got, NULL); + SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip file size */ + ReadFile(fd, &rsrcs, 4, &got, NULL); + SetFilePointer(fd, rsrcs, 0, FILE_BEGIN); + + /* We're at the resource table; step through 3 layers */ + pos = find_by_id(fd, rsrcs, rsrcs, 257); + if (pos) { + pos = find_by_id(fd, rsrcs, pos, 1); + if (pos) { + pos = find_by_id(fd, rsrcs, pos, 1033); + + if (pos) { + /* pos is the reource data entry */ + SetFilePointer(fd, pos, 0, FILE_BEGIN); + ReadFile(fd, &val, 4, &got, NULL); + pos = val - virtual_addr + rsrcs; + + CloseHandle(fd); + + return pos; + } + } + } + + break; + } + sec_pos += 40; + } + + /* something went wrong */ + CloseHandle(fd); + return 0; + } +} +#endif + +static void extract_built_in_arguments(char **_prog, char **_sprog, int *_argc, char ***_argv) +{ + GC_CAN_IGNORE char *prog = *_prog; + GC_CAN_IGNORE char *sprog = *_sprog; + +#ifdef DOS_FILE_SYSTEM + { + /* For consistency, strip trailing spaces and dots, and make sure the .exe + extension is present. */ + int l = strlen(prog); + if ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { + char *s; + while ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) { + l--; + } + s = (char *)malloc(l + 1); + memcpy(s, prog, l); + s[l] = 0; + prog = s; + } + if (l <= 4 + || (prog[l - 4] != '.') + || (tolower(((unsigned char *)prog)[l - 3]) != 'e') + || (tolower(((unsigned char *)prog)[l - 2]) != 'x') + || (tolower(((unsigned char *)prog)[l - 1]) != 'e')) { + char *s; + s = (char *)malloc(l + 4 + 1); + memcpy(s, prog, l); + memcpy(s + l, ".exe", 5); + prog = s; + } + } +#endif + + /* If scheme_cmdline_exe_hack is changed, then we extract built-in + arguments. */ + if (scheme_cmdline_exe_hack[0] != '[') { + int argc = *_argc; + GC_CAN_IGNORE char **argv = *_argv; + int n, i; + long d; + GC_CAN_IGNORE unsigned char *p; + GC_CAN_IGNORE unsigned char *orig_p; + char **argv2; + + p = NULL; +#ifdef DOS_FILE_SYSTEM + if ((scheme_cmdline_exe_hack[0] == '?') + || (scheme_cmdline_exe_hack[0] == '*')) { + /* This is how we make launchers in Windows. The cmdline is + added as a resource of type 257. The long integer at + scheme_cmdline_exe_hack[4] says where the command line starts + with the source, and scheme_cmdline_exe_hack[8] says how long + the cmdline string is. It might be relative to the + executable. */ + HANDLE fd; + wchar_t *path; + + path = get_self_executable_path(); + fd = CreateFileW(path, GENERIC_READ, + FILE_SHARE_READ | FILE_SHARE_WRITE, + NULL, + OPEN_EXISTING, + 0, + NULL); + if (fd == INVALID_HANDLE_VALUE) + p = (unsigned char *)"\0\0\0"; + else { + long start, len; + DWORD got; + start = *(long *)&scheme_cmdline_exe_hack[4]; + len = *(long *)&scheme_cmdline_exe_hack[8]; + start += get_segment_offset(); + p = (unsigned char *)malloc(len); + SetFilePointer(fd, start, 0, FILE_BEGIN); + ReadFile(fd, p, len, &got, NULL); + CloseHandle(fd); + if (got != len) + p = (unsigned char *)"\0\0\0"; + else if (scheme_cmdline_exe_hack[0] == '*') { + /* "*" means that the first item is argv[0] replacement: */ + sprog = prog; + prog = (char *)p + 4; + + if ((prog[0] == '\\') + || ((((prog[0] >= 'a') && (prog[0] <= 'z')) + || ((prog[0] >= 'A') && (prog[0] <= 'Z'))) + && (prog[1] == ':'))) { + /* Absolute path */ + } else { + /* Make it absolute, relative to this executable */ + int plen = strlen(prog); + int mlen, len; + char *s2, *p2; + + /* UTF-8 encode path: */ + for (len = 0; path[len]; len++) { } + mlen = scheme_utf8_encode((unsigned int *)path, 0, len, + NULL, 0, + 1 /* UTF-16 */); + p2 = (char *)malloc(mlen + 1); + mlen = scheme_utf8_encode((unsigned int *)path, 0, len, + (unsigned char *)p2, 0, + 1 /* UTF-16 */); + + while (mlen && (p2[mlen - 1] != '\\')) { + mlen--; + } + s2 = (char *)malloc(mlen + plen + 1); + memcpy(s2, p2, mlen); + memcpy(s2 + mlen, prog, plen + 1); + prog = s2; + } + + p += (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24) + + 4); + } + } + free(path); + } +#endif +#if defined(OS_X) + if (scheme_cmdline_exe_hack[0] == '?') { + long fileoff, cmdoff, cmdlen; + int fd; + fileoff = get_segment_offset(); + + p = (unsigned char *)scheme_cmdline_exe_hack + 4; + cmdoff = (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24)); + cmdlen = (p[4] + + (((long)p[5]) << 8) + + (((long)p[6]) << 16) + + (((long)p[7]) << 24)); + p = malloc(cmdlen); + + fd = open(_dyld_get_image_name(0), O_RDONLY); + lseek(fd, fileoff + cmdoff, 0); + read(fd, p, cmdlen); + close(fd); + } +#endif + + if (!p) + p = (unsigned char *)scheme_cmdline_exe_hack + 1; + + /* Command line is encoded as a sequence of pascal-style strings; + we use four whole bytes for the length, though, little-endian. */ + + orig_p = p; + + n = 0; + while (p[0] || p[1] || p[2] || p[3]) { + n++; + p += (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24) + + 4); + } + + argv2 = (char **)malloc(sizeof(char *) * (argc + n)); + p = orig_p; + for (i = 0; i < n; i++) { + d = (p[0] + + (((long)p[1]) << 8) + + (((long)p[2]) << 16) + + (((long)p[3]) << 24)); + argv2[i] = (char *)p + 4; + p += d + 4; + } + for (; i < n + argc; i++) { + argv2[i] = argv[i - n]; + } + argv = argv2; + argc += n; + + + *_argc = argc; + *_argv = argv; + } + + *_prog = prog; + *_sprog = sprog; +} + +static char *extract_coldir() +{ + return scheme_coldir + _coldir_offset; +} + +static char *extract_configdir() +{ + return scheme_configdir XFORM_OK_PLUS _configdir_offset; +} + +#if !defined(OS_X) && !defined(DOS_FILE_SYSTEM) +# define NO_GET_SEGMENT_OFFSET +#endif diff --git a/racket/src/racket/delayed.inc b/racket/src/start/delayed.inc similarity index 98% rename from racket/src/racket/delayed.inc rename to racket/src/start/delayed.inc index 551e4d4f93..ef81e30fba 100644 --- a/racket/src/racket/delayed.inc +++ b/racket/src/start/delayed.inc @@ -1,4 +1,6 @@ +/* Extra configuration and support for Windows */ + # ifdef MZ_PRECISE_GC # define DLL_3M_SUFFIX "3m" # else diff --git a/racket/src/start/gui_filter.inc b/racket/src/start/gui_filter.inc new file mode 100644 index 0000000000..334ac0988b --- /dev/null +++ b/racket/src/start/gui_filter.inc @@ -0,0 +1,117 @@ +/* + Defines + void pre_filter_cmdline_arguments(int *argc, char ***argv) + and may use + void scheme_register_process_global(const char *key, void *v); +*/ + +#if !defined(MZ_XFORM) && !defined(XFORM_SKIP_PROC) +# define XFORM_SKIP_PROC /**/ +#endif + +/***********************************************************************/ +/* X11 flag handling */ +/***********************************************************************/ + +#ifdef wx_xt + +typedef struct { + char *flag; + int arg_count; +} X_flag_entry; + +#define SINGLE_INSTANCE "-singleInstance" + +X_flag_entry X_flags[] = { + { "-display", 1 }, + { "-geometry", 1 }, + { "-bg", 1 }, + { "-background", 1 }, + { "-fg", 1 }, + { "-foreground", 1 }, + { "-fn", 1 }, + { "-font", 1 }, + { "-iconic", 0 }, + { "-name", 1 }, + { "-rv", 0 }, + { "-reverse", 0 }, + { "+rv", 0 }, + { "-selectionTimeout", 1 }, + { "-synchronous", 0 }, + { "-title", 1 }, + { "-xnllanguage", 1 }, + { "-xrm", 1 }, + { SINGLE_INSTANCE, 0}, + { NULL, 0 } +}; + +static int filter_x_readable(char **argv, int argc) + XFORM_SKIP_PROC +{ + int pos = 1, i; + + while (pos < argc) { + for (i = 0; X_flags[i].flag; i++) { + if (!strcmp(X_flags[i].flag, argv[pos])) + break; + } + + if (!X_flags[i].flag) + return pos; + else { + int newpos = pos + X_flags[i].arg_count + 1; + if (newpos > argc) { + printf("%s: X Window System flag \"%s\" expects %d arguments, %d provided\n", + argv[0], argv[pos], X_flags[i].arg_count, argc - pos - 1); + exit(-1); + } + pos = newpos; + } + } + + return pos; +} + +static void pre_filter_cmdline_arguments(int *argc, char ***argv) + XFORM_SKIP_PROC +{ + int pos; + char **naya; + + pos = filter_x_readable(*argv, *argc); + if (pos > 1) { + scheme_register_process_global("PLT_X11_ARGUMENT_COUNT", (void *)(intptr_t)pos); + scheme_register_process_global("PLT_X11_ARGUMENTS", *argv); + naya = malloc((*argc - (pos - 1)) * sizeof(char *)); + memcpy(naya, *argv + (pos - 1), (*argc - (pos - 1)) * sizeof(char *)); + naya[0] = (*argv)[0]; + *argv = naya; + *argc -= (pos - 1); + } +} + +#endif + +/***********************************************************************/ +/* Mac OS X flag handling */ +/***********************************************************************/ + +#ifdef wx_mac + +static void pre_filter_cmdline_arguments(int *argc, char ***argv) + XFORM_SKIP_PROC +{ + if ((*argc > 1) && !strncmp((*argv)[1], "-psn_", 5)) { + /* Finder adds "-psn_" when you double-click on the application. + Drop it. */ + char **new_argv; + new_argv = (char **)malloc(((*argc) - 1) * sizeof(char *)); + new_argv[0] = (*argv)[0]; + memcpy(new_argv + 1, (*argv) + 2, ((*argc) - 2) * sizeof(char *)); + (*argc)--; + *argv = new_argv; + } + scheme_register_process_global("PLT_IS_FOREGROUND_APP", (void *)(intptr_t)0x1); +} + +#endif diff --git a/racket/src/racket/dynsrc/start.c b/racket/src/start/start.c similarity index 100% rename from racket/src/racket/dynsrc/start.c rename to racket/src/start/start.c diff --git a/racket/src/racket/dynsrc/starter-sh b/racket/src/start/starter-sh similarity index 100% rename from racket/src/racket/dynsrc/starter-sh rename to racket/src/start/starter-sh diff --git a/racket/src/racket/dynsrc/ustart.c b/racket/src/start/ustart.c similarity index 100% rename from racket/src/racket/dynsrc/ustart.c rename to racket/src/start/ustart.c diff --git a/racket/src/thread/Makefile b/racket/src/thread/Makefile new file mode 100644 index 0000000000..06f95d9f79 --- /dev/null +++ b/racket/src/thread/Makefile @@ -0,0 +1,33 @@ +# This makefile can be used directly or driven by other makefiles. +# See "../expander/Makefile" for more notes. + +RACKET = ../../bin/racket +RACO = $(RACKET) -N raco -l- raco + +# Ignoring functions from `#%read` works beause they won't appear in +# the simplified expansion, and declaring "collect.rkt" pure works +# around a limitation of the flattener: +IGNORE = ++knot read - ++direct pthread ++pure ../../collects/racket/private/collect.rkt + +thread-src: + $(RACO) make ../expander/bootstrap-run.rkt + $(MAKE) thread-src-generate + +GENERATE_ARGS = -t main.rkt --submod main \ + --check-depends $(BUILDDIR)compiled/thread-dep.rktd \ + ++depend-module ../expander/bootstrap-run.rkt \ + --depends $(BUILDDIR)compiled/thread-dep.rktd \ + --makefile-depends $(DEPENDSDIR)compiled/thread.rktl $(BUILDDIR)compiled/thread.d \ + -c $(BUILDDIR)compiled/cache-src \ + -k ../.. $(IGNORE) -s -x \ + -o $(BUILDDIR)compiled/thread.rktl + +# This target can be used with a `RACKET` that builds via `-l- setup --chain ...` +thread-src-generate: + $(RACKET) ../expander/bootstrap-run.rkt $(GENERATE_ARGS) + +demo: + $(RACO) make demo.rkt + $(RACKET) demo.rkt + +.PHONY: thread-src thread-src-generate demo diff --git a/racket/src/thread/README.txt b/racket/src/thread/README.txt new file mode 100644 index 0000000000..7d3c793e51 --- /dev/null +++ b/racket/src/thread/README.txt @@ -0,0 +1,8 @@ +This thread implementation can be run in a host Racket with `make +demo`, but it's meant to be compiled for use in Racket on Chez Scheme; +see "../cs/README.txt". + +Core engine support must be provided by a more primitive layer. The +more primitive layer must also provide `break-enabled-key` and special +handling for looking up a mark with that key so that an egine-specific +default thread cell is produced. diff --git a/racket/src/thread/alarm.rkt b/racket/src/thread/alarm.rkt new file mode 100644 index 0000000000..4d90362669 --- /dev/null +++ b/racket/src/thread/alarm.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(require "check.rkt" + "evt.rkt" + "schedule-info.rkt") + +(provide (rename-out [create-alarm-evt alarm-evt])) + +(struct alarm-evt (msecs) + #:property + prop:evt + (poller (lambda (e ctx) + (define msecs (alarm-evt-msecs e)) + (if ((current-inexact-milliseconds) . >= . msecs) + (values (list e) #f) + (begin + (schedule-info-add-timeout-at! (poll-ctx-sched-info ctx) + msecs) + (values #f e)))))) + +(define/who (create-alarm-evt msecs) + (check who real? msecs) + (alarm-evt msecs)) diff --git a/racket/src/thread/api.rkt b/racket/src/thread/api.rkt new file mode 100644 index 0000000000..c634eb6f69 --- /dev/null +++ b/racket/src/thread/api.rkt @@ -0,0 +1,118 @@ +#lang racket/base +(require "check.rkt" + (rename-in "semaphore.rkt" + [semaphore-peek-evt raw:semaphore-peek-evt]) + (rename-in "evt.rkt" + [wrap-evt raw:wrap-evt] + [handle-evt raw:handle-evt] + [handle-evt? raw:handle-evt?] + [poll-guard-evt raw:poll-guard-evt] + [choice-evt raw:choice-evt]) + (only-in "sync.rkt" + sync/enable-break)) + +(provide wrap-evt + handle-evt + handle-evt? + guard-evt + poll-guard-evt + nack-guard-evt + choice-evt + semaphore-peek-evt + semaphore-wait/enable-break + call-with-semaphore + call-with-semaphore/enable-break) + +(define/who (choice-evt . args) + (for ([arg (in-list args)]) + (check who evt? arg)) + (raw:choice-evt args)) + +(define/who (wrap-evt evt proc) + (check who evt? evt) + (check who procedure? proc) + (raw:wrap-evt evt proc)) + +(define/who (handle-evt evt proc) + (check who evt? evt) + (check who procedure? proc) + (raw:handle-evt evt proc)) + +(define/who (handle-evt? evt) + (check who evt? evt) + (let loop ([evt evt]) + (or (raw:handle-evt? evt) + (and (choice-evt? evt) + (for/or ([evt (in-list (choice-evt-evts evt))]) + (loop evt)))))) + +(define/who (guard-evt proc) + (check who (procedure-arity-includes/c 0) proc) + (raw:poll-guard-evt (lambda (poll?) (proc)))) + +(define/who (poll-guard-evt proc) + (check who(procedure-arity-includes/c 1) proc) + (raw:poll-guard-evt proc)) + +(define/who (nack-guard-evt proc) + (check who (procedure-arity-includes/c 1) proc) + (raw:poll-guard-evt + (lambda (poll?) + (define s (make-semaphore)) + ;; Return control-state-evt to register + ;; the nack semaphore before exposing it to + ;; the `proc` callback: + (control-state-evt + (raw:poll-guard-evt + (lambda (poll?) + (define v (proc (wrap-evt (raw:semaphore-peek-evt s) void))) + (if (evt? v) + v + (wrap-evt always-evt (lambda () v))))) + void + (lambda () (semaphore-post s)) + void)))) + +(define/who (semaphore-peek-evt s) + (check who semaphore? s) + (raw:semaphore-peek-evt s)) + +(define/who (semaphore-wait/enable-break s) + (check who semaphore? s) + (sync/enable-break s) + (void)) + +;; ---------------------------------------- + +(define (do-call-with-semaphore who s proc try-fail args #:enable-break? [enable-break? #f]) + (check who semaphore? s) + (check who procedure? proc) + (check who (procedure-arity-includes/c 0) #:or-false try-fail) + (define breaks-on? (or enable-break? + (break-enabled))) + (define results #t) ; transitions to list of results unless semaphore-try fails + (dynamic-wind + (lambda () + (if try-fail + (set! results (semaphore-try-wait? s)) + (if breaks-on? + (semaphore-wait/enable-break s) + (semaphore-wait s)))) + (lambda () + (when results + (call-with-continuation-barrier + (lambda () + (set! results + (call-with-values (lambda () (apply proc args)) list)))))) + (lambda () + (when results + (semaphore-post s)))) + (if results + (apply values results) + (try-fail))) + +(define (call-with-semaphore s proc [try-fail #f] . args) + (do-call-with-semaphore 'call-with-semaphore s proc try-fail args)) + +(define (call-with-semaphore/enable-break s proc [try-fail #f] . args) + (do-call-with-semaphore 'call-with-semaphore/enable-break s proc try-fail args #:enable-break? #t)) diff --git a/racket/src/thread/atomic.rkt b/racket/src/thread/atomic.rkt new file mode 100644 index 0000000000..8fe77e4f49 --- /dev/null +++ b/racket/src/thread/atomic.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require "engine.rkt" + "internal-error.rkt" + "debug.rkt") + +(provide atomically + current-atomic + + start-atomic + end-atomic + + start-atomic/no-interrupts + end-atomic/no-interrupts + + set-end-atomic-callback! + + start-implicit-atomic-mode + end-implicit-atomic-mode + assert-atomic-mode) + +;; This definition is specially recognized for Racket on +;; Chez Scheme and converted to use a virtual register: +(define current-atomic (make-pthread-parameter 0)) + +(define-syntax-rule (atomically expr ...) + (begin + (start-atomic) + (begin0 + (let () expr ...) + (end-atomic)))) + +(define (start-atomic) + (current-atomic (add1 (current-atomic)))) + +(define (end-atomic) + (define n (sub1 (current-atomic))) + (cond + [(and end-atomic-callback + (zero? n)) + (define cb end-atomic-callback) + (set! end-atomic-callback #f) + (current-atomic n) + (cb)] + [else + (current-atomic n)])) + +(define (start-atomic/no-interrupts) + (start-atomic) + (host:disable-interrupts)) + +(define (end-atomic/no-interrupts) + (host:enable-interrupts) + (end-atomic)) + +;; ---------------------------------------- + +(define end-atomic-callback #f) + +(define (set-end-atomic-callback! cb) + (set! end-atomic-callback cb)) + + +;; ---------------------------------------- + +(debug-select + #:on + [(define current-implicit-atomic (make-pthread-parameter #t)) + + (define (start-implicit-atomic-mode) + (when (current-implicit-atomic) + (internal-error "already implicitly in atomic mode?")) + (current-implicit-atomic #t)) + + (define (end-implicit-atomic-mode) + (unless (current-implicit-atomic) + (internal-error "not implicitly in atomic mode?")) + (current-implicit-atomic #f)) + + (define-syntax-rule (assert-atomic-mode) + (unless (or (current-implicit-atomic) + (positive? (current-atomic))) + (internal-error "should be in atomic mode")))] + #:off + [(define-syntax-rule (start-implicit-atomic-mode) (begin)) + (define-syntax-rule (end-implicit-atomic-mode) (begin)) + (define-syntax-rule (assert-atomic-mode) (begin))]) diff --git a/racket/src/thread/bootstrap-main.rkt b/racket/src/thread/bootstrap-main.rkt new file mode 100644 index 0000000000..055a4fcd1e --- /dev/null +++ b/racket/src/thread/bootstrap-main.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "bootstrap.rkt" ; must be before "main.rkt" + "main.rkt") + +(provide (all-from-out "main.rkt")) + diff --git a/racket/src/thread/bootstrap.rkt b/racket/src/thread/bootstrap.rkt new file mode 100644 index 0000000000..084e3136a8 --- /dev/null +++ b/racket/src/thread/bootstrap.rkt @@ -0,0 +1,190 @@ +#lang racket/base +(require '#%linklet + (only-in '#%foreign + make-stubborn-will-executor) + "../common/queue.rkt") + +;; Simulate engines by using the host system's threads. + +;; This simulation doesn't provide a `dynamic-wind` that cooperates +;; with `break-enabled-key`, and it does not support using an +;; exception handler in an engine. + +(define (make-engine thunk init-break-enabled-cell empty-config?) + (define ready-s (make-semaphore)) + (define s (make-semaphore)) + (define prefix void) + (define results (list (void))) + (define t (thread (lambda () + (define orig (uncaught-exception-handler)) + (define (run-prefix) + (prefix) + (set! prefix void)) + (call-with-exception-handler + (lambda (exn) + (if (and (exn:break? exn) + (not (exn:break/non-engine? exn))) + (with-handlers ([exn:break/non-engine? + (lambda (exn) + ;; Avoid exception-during-exception + ;; error by propagating the original, + ;; even though it's a different kind + ;; of break exn: + exn)]) + (run-prefix) + ((exn:break-continuation exn))) + (abort-current-continuation + the-root-continuation-prompt-tag + exn))) + (lambda () + (call-with-continuation-prompt + (lambda () + (with-continuation-mark + break-enabled-key + init-break-enabled-cell + (begin + (semaphore-post ready-s) + (semaphore-wait s) + (run-prefix) + (set! results + (call-with-values thunk list))))) + the-root-continuation-prompt-tag + (lambda (exn) + ((error-display-handler) (exn-message exn) exn)))))))) + (semaphore-wait ready-s) + (thread-suspend t) + (semaphore-post s) + (define (go ticks next-prefix complete expire) + (set! prefix next-prefix) + (break-thread t) + (thread-resume t) + (define t2 + (thread (lambda () + (sleep (/ ticks 1000000.0)) + (thread-suspend t)))) + ;; Limited break propagation while syncing: + (call-with-exception-handler + (lambda (exn) + (if (and (exn:break? exn) + ctl-c-handler) + (begin + (ctl-c-handler 'break) + ((exn:break-continuation exn))) + exn)) + (lambda () + (sync t t2 (thread-suspend-evt t)))) + (cond + [(thread-dead? t) + (apply complete 0 results)] + [else + (expire go)])) + go) + +(define (engine-block) + (thread-suspend (current-thread))) + +(define ctl-c-handler #f) + +(define (set-ctl-c-handler! proc) + (set! ctl-c-handler proc)) + +(define the-root-continuation-prompt-tag (make-continuation-prompt-tag 'root)) +(define (root-continuation-prompt-tag) the-root-continuation-prompt-tag) +(define break-enabled-key (gensym 'break-enabled)) + +(struct will-executor/notify (we queue notify)) + +(define will-executors null) + +(define (poll-will-executors) + (when (for/or ([w (in-list will-executors)]) + (will-try-execute w)) + (poll-will-executors))) + +(define (do-make-will-executor/notify make-will-executor notify) + (define we (make-will-executor)) + (set! will-executors (cons we will-executors)) + (will-executor/notify we (make-queue) notify)) + +(define (make-will-executor/notify notify) + (do-make-will-executor/notify make-will-executor notify)) + +(define (make-stubborn-will-executor/notify notify) + (do-make-will-executor/notify make-stubborn-will-executor notify)) + +(define (will-register/notify we/n v proc) + (will-register (will-executor/notify-we we/n) + v + (lambda (v) + ((will-executor/notify-notify we/n)) + (queue-add! (will-executor/notify-queue we/n) + (cons proc v))))) + +(define (will-try-execute/notify we/n) + (poll-will-executors) + (queue-remove! (will-executor/notify-queue we/n))) + +(define (will-executor-notification-procedure we [proc #f]) + (error "will-executor-notification-procedure not supported")) + +(struct exn:break/non-engine exn:break ()) +(struct exn:break:hang-up/non-engine exn:break/non-engine ()) +(struct exn:break:terminate/non-engine exn:break/non-engine ()) + +(define (make-pthread-parameter v) + (define x v) + (case-lambda + [() x] + [(v) (set! x v)])) + +(primitive-table '#%pthread + (hash + 'make-pthread-parameter make-pthread-parameter)) +(primitive-table '#%engine + (hash + 'make-engine make-engine + 'engine-block engine-block + 'engine-return (lambda args + (error "engine-return: not ready")) + 'current-process-milliseconds current-process-milliseconds + 'set-ctl-c-handler! set-ctl-c-handler! + 'root-continuation-prompt-tag root-continuation-prompt-tag + 'break-enabled-key break-enabled-key + 'set-break-enabled-transition-hook! void + 'continuation-marks continuation-marks ; doesn't work on engines + 'poll-will-executors poll-will-executors + 'make-will-executor make-will-executor/notify + 'make-stubborn-will-executor make-stubborn-will-executor/notify + 'will-executor? will-executor/notify? + 'will-register will-register/notify + 'will-try-execute will-try-execute/notify + 'exn:break/non-engine exn:break/non-engine + 'exn:break:hang-up/non-engine exn:break:hang-up/non-engine + 'exn:break:terminate/non-engine exn:break:terminate/non-engine + 'poll-async-callbacks (lambda () null) + 'disable-interrupts void + 'enable-interrupts void + 'fork-pthread (lambda args + (error "fork-pthread: not ready")) + 'pthread? (lambda args + (error "thread?: not ready")) + 'get-thread-id (lambda args + (error "get-pthread-id: not ready")) + 'make-condition (lambda () 'condition) + 'condition-wait (lambda args + (error "condition-wait: not ready")) + 'condition-signal (lambda args + (error "condition-signal: not ready")) + 'condition-broadcast (lambda args + (error "condition-broadcast: not ready")) + 'threaded? (lambda () #f) + 'current-engine-state (lambda args + (error "current-engine state: not ready")) + 'make-mutex (lambda () 'mutex) + 'mutex-acquire (lambda args + (error "mutex-acquire: not ready")) + 'mutex-release (lambda args + (error "mutex-release: not ready")))) + +;; add dummy definitions that implement pthreads and conditions etc. +;; dummy definitions that error diff --git a/racket/src/thread/channel.rkt b/racket/src/thread/channel.rkt new file mode 100644 index 0000000000..104d90dbe8 --- /dev/null +++ b/racket/src/thread/channel.rkt @@ -0,0 +1,214 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "parameter.rkt" + "evt.rkt" + "waiter.rkt" + "../common/queue.rkt") + +(provide make-channel + channel? + channel-put + channel-get + + channel-put-evt + channel-put-evt?) + +(module+ for-sync + (provide set-sync-on-channel!)) + +(module+ for-impersonator + (provide impersonator-prop:channel-put + channel-put-impersonator? + channel-put-impersonator-ref)) + +;; ---------------------------------------- + +(struct channel (get-queue + put-queue) + #:property + prop:evt + (poller (lambda (ch poll-ctx) + (channel-get/poll ch poll-ctx)))) + +(struct channel-put-evt* (ch v) + #:property + prop:evt + (poller (lambda (cp poll-ctx) + (channel-put/poll (channel-put-evt*-ch cp) + (channel-put-evt*-v cp) + cp + poll-ctx))) + #:reflection-name 'channel-put-evt) + +;; A channel must not match get and put from the same thread, which is +;; a danger when `sync` queues up multiple events at a time: +(struct channel-select-waiter select-waiter (thread)) + +(define (make-channel) + (channel (make-queue) (make-queue))) + +;; ---------------------------------------- + +(define/who (channel-get ch) + (check who channel? ch) + (cond + [(evt-impersonator? ch) + ;; Use the more general path to get impersonator handling: + (sync-on-channel ch)] + [else + (define b (box #f)) + (let receive () ; loop if a retry is needed + ((atomically + (define pw+v (queue-remove! (channel-put-queue ch))) + (define gw (current-thread)) + (cond + [(not pw+v) + (define gq (channel-get-queue ch)) + (define n (queue-add! gq (cons gw b))) + (waiter-suspend! gw + ;; On break/kill/suspend: + (lambda () (queue-remove-node! gq n)) + ;; On retry after break or resume: + (lambda () (receive)))] + [else + (set-box! b (cdr pw+v)) + (waiter-resume! (car pw+v) (void)) + void])))) + (unbox b)])) + +;; in atomic mode +(define (channel-get/poll ch poll-ctx) + ;; Similar to `channel-get`, but works in terms of a + ;; `select-waiter` instead of a thread + (assert-atomic-mode) + (define pq (channel-put-queue ch)) + (define pw+v (queue-fremove! pq not-matching-select-waiter)) + (cond + [pw+v + (waiter-resume! (car pw+v) (void)) + (values (list (cdr pw+v)) #f)] + [(poll-ctx-poll? poll-ctx) + (values #f never-evt)] + [else + (define b (box #f)) + (define gq (channel-get-queue ch)) + (define gw (channel-select-waiter (poll-ctx-select-proc poll-ctx) + (current-thread))) + (define n (queue-add! gq (cons gw b))) + (values #f + (wrap-evt + (control-state-evt async-evt + (lambda () (queue-remove-node! gq n)) + void + (lambda () + ;; Retry: get ready value or requeue + (define pw+v (queue-fremove! pq not-matching-select-waiter)) + (cond + [pw+v + (waiter-resume! (car pw+v) (void)) + (set-box! b (cdr pw+v)) + (values #t #t)] + [else + (set! n (queue-add! gq (cons gw b))) + (values #f #f)]))) + (lambda (v) (unbox b))))])) + +;; ---------------------------------------- + + +(define/who (channel-put ch v) + (check who channel? ch) + (cond + [(channel-put-impersonator? ch) + (channel-impersonator-put ch v channel-put)] + [else + ((atomically + (define gw+b (queue-remove! (channel-get-queue ch))) + (define pw (current-thread)) + (cond + [(not gw+b) + (define pq (channel-put-queue ch)) + (define n (queue-add! pq (cons pw v))) + (waiter-suspend! pw + ;; On break/kill/suspend: + (lambda () (queue-remove-node! pq n)) + ;; On retry after break or resume: + (lambda () (channel-put ch v)))] + [else + (set-box! (cdr gw+b) v) + (waiter-resume! (car gw+b) v) + void])))])) + +;; In atomic mode +(define (channel-put/poll ch v result poll-ctx) + ;; Similar to `channel-put`, but works in terms of a + ;; `select-waiter` instead of a thread + (assert-atomic-mode) + (define gq (channel-get-queue ch)) + (define gw+b (queue-fremove! gq not-matching-select-waiter)) + (cond + [gw+b + (set-box! (cdr gw+b) v) + (waiter-resume! (car gw+b) v) + (values (list result) #f)] + [(poll-ctx-poll? poll-ctx) + (values #f async-evt)] + [else + (define pq (channel-put-queue ch)) + (define pw (channel-select-waiter (poll-ctx-select-proc poll-ctx) + (current-thread))) + (define n (queue-add! pq (cons pw v))) + (values #f + (wrap-evt + (control-state-evt async-evt + (lambda () (queue-remove-node! pq n)) + void + (lambda () + ;; Retry: put ready value or requeue + (define gw+b (queue-fremove! gq not-matching-select-waiter)) + (cond + [gw+b + (set-box! (cdr gw+b) v) + (waiter-resume! (car gw+b) v) + (values result #t)] + [else + (set! n (queue-add! pq (cons pw v))) + (values #f #f)]))) + (lambda (v) result)))])) + +(define/who (channel-put-evt ch v) + (check who channel? ch) + (cond + [(channel-put-impersonator? ch) + (channel-impersonator-put ch v channel-put-evt)] + [else + (channel-put-evt* ch v)])) + +(define (channel-put-evt? v) + (channel-put-evt*? v)) + +(define (channel-impersonator-put ch v channel-put) + (define ch+put-proc (channel-put-impersonator-ref ch)) + (define old-ch (car ch+put-proc)) + (define new-v ((cdr ch+put-proc) old-ch v)) + (channel-put old-ch new-v)) + +;; ---------------------------------------- + +(define (not-matching-select-waiter w+b/v) + (define w (car w+b/v)) + (or (not (channel-select-waiter? w)) + (not (eq? (current-thread) + (channel-select-waiter-thread w))))) + +;; ---------------------------------------- + +;; To resolve a mutual dependency: +(define sync-on-channel #f) +(define (set-sync-on-channel! sync) + (set! sync-on-channel sync)) + +;; +(define-values (impersonator-prop:channel-put channel-put-impersonator? channel-put-impersonator-ref) + (make-impersonator-property 'channel-put-impersonator)) diff --git a/racket/src/thread/check.rkt b/racket/src/thread/check.rkt new file mode 100644 index 0000000000..8b1a845fd8 --- /dev/null +++ b/racket/src/thread/check.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require "../common/check.rkt") + +(provide (all-from-out "../common/check.rkt")) diff --git a/racket/src/thread/continuation-mark.rkt b/racket/src/thread/continuation-mark.rkt new file mode 100644 index 0000000000..efc8b3f1fe --- /dev/null +++ b/racket/src/thread/continuation-mark.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(require "check.rkt" + (submod "thread.rkt" scheduling) + "engine.rkt") + +(provide continuation-marks) + +(define/who (continuation-marks k [prompt-tag (default-continuation-prompt-tag)]) + (check who (lambda (k) (or (not k) (continuation? k) (thread? k))) + #:contract "(or/c continuation? thread? #f)" + k) + (check who continuation-prompt-tag? prompt-tag) + (cond + [(thread? k) + (define e (thread-engine k)) + (cond + [(eq? e 'done) (host:continuation-marks #f prompt-tag)] + [(eq? e 'running) (current-continuation-marks)] + [else (host:continuation-marks e prompt-tag)])] + [else + (host:continuation-marks k prompt-tag)])) diff --git a/racket/src/thread/custodian.rkt b/racket/src/thread/custodian.rkt new file mode 100644 index 0000000000..1fe3c48459 --- /dev/null +++ b/racket/src/thread/custodian.rkt @@ -0,0 +1,206 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "engine.rkt" + "evt.rkt" + "semaphore.rkt") + +(provide current-custodian + make-custodian + custodian? + custodian-shutdown-all + custodian-managed-list + make-custodian-box + custodian-box? + custodian-box-value + custodian-memory-accounting-available? + custodian-require-memory + custodian-limit-memory + custodian-shut-down? + + custodian-subordinate? + custodian-manages-reference? + custodian-reference->custodian + unsafe-make-custodian-at-root + unsafe-custodian-register + unsafe-custodian-unregister + raise-custodian-is-shut-down + set-post-shutdown-action!) + +(struct custodian (children ; weakly maps maps object to callback + [shut-down? #:mutable] + [shutdown-sema #:mutable] + [parent-reference #:mutable]) + #:authentic) + +(struct custodian-box ([v #:mutable] sema) + #:authentic + #:property prop:evt (lambda (cb) + (wrap-evt (custodian-box-sema cb) (lambda (v) cb)))) + +(struct willed-callback (proc will) + #:property prop:procedure (struct-field-index proc) + #:authentic) + +(struct at-exit-callback willed-callback () + #:authentic) + +;; Reporting registration in a custodian through this indirection +;; enables GCing custodians that aren't directly referenced, merging +;; the managed objects into the parent, although that posisbility is +;; not currently implemented +(struct custodian-reference (c) + #:authentic) + +(define (create-custodian) + (custodian (make-weak-hasheq) + #f ; shut-down? + #f ; shutdown semaphore + #f)) + +(define root-custodian (create-custodian)) + +(define/who current-custodian + (make-parameter root-custodian + (lambda (v) + (check who custodian? v) + v))) + +(define/who (make-custodian [parent (current-custodian)]) + (check who custodian? parent) + (define c (create-custodian)) + (define cref (unsafe-custodian-register parent c do-custodian-shutdown-all #f #t)) + (set-custodian-parent-reference! c cref) + (unless cref (raise-custodian-is-shut-down who parent)) + c) + +(define (unsafe-make-custodian-at-root) + (make-custodian root-custodian)) + +;; The given `callback` will be run in atomic mode. +;; Unless `weak?` is true, the given `obj` is registered with an ordered +;; finalizer, so don't supply an `obj` that is exposed to safe code +;; that might see `obj` after finalization through a weak reference +;; (and detect that `obj` is thereafter retained strongly). +(define (unsafe-custodian-register cust obj callback at-exit? weak?) + (atomically + (cond + [(custodian-shut-down? cust) #f] + [else + (define we (and (not weak?) + (host:make-stubborn-will-executor void))) + (hash-set! (custodian-children cust) + obj + (cond + [weak? callback] + [at-exit? (at-exit-callback callback we)] + [else (willed-callback callback we)])) + (when we + ;; Registering with a will executor that we never poll has the + ;; effect of turning a weak reference into a strong one when + ;; there are no other references: + (host:will-register we obj void)) + (custodian-reference cust)]))) + +(define (unsafe-custodian-unregister obj cref) + (when cref + (atomically + (define c (custodian-reference-c cref)) + (unless (custodian-shut-down? c) + (hash-remove! (custodian-children c) obj))))) + +;; Hook for thread scheduling: +(define post-shutdown-action void) +(define (set-post-shutdown-action! proc) + (set! post-shutdown-action proc)) + +(define/who (custodian-shutdown-all c) + (check who custodian? c) + (atomically + (do-custodian-shutdown-all c)) + (post-shutdown-action)) + +;; In atomic mode +(define (do-custodian-shutdown-all c) + (unless (custodian-shut-down? c) + (set-custodian-shut-down?! c #t) + (for ([(child callback) (in-hash (custodian-children c))]) + (if (procedure-arity-includes? callback 2) + (callback child c) + (callback child))) + (hash-clear! (custodian-children c)) + (let ([sema (custodian-shutdown-sema c)]) + (when sema + (semaphore-post-all sema))))) + +(define (custodian-get-shutdown-sema c) + (atomically + (or (custodian-shutdown-sema c) + (let ([sema (make-semaphore)]) + (set-custodian-shutdown-sema! c sema) + (when (custodian-shut-down? c) + (semaphore-post-all sema)) + sema)))) + +(define (custodian-subordinate? c super-c) + (let loop ([p-cref (custodian-parent-reference c)]) + (define p (and p-cref (custodian-reference-c p-cref))) + (cond + [(eq? p super-c) #t] + [(not p) #f] + [else (loop (custodian-parent-reference p))]))) + +(define (custodian-manages-reference? c cref) + (define ref-c (custodian-reference-c cref)) + (or (eq? c ref-c) + (custodian-subordinate? ref-c c))) + +(define (custodian-reference->custodian cref) + (custodian-reference-c cref)) + +(define/who (custodian-managed-list c super-c) + (check who custodian? c) + (check who custodian? super-c) + (unless (custodian-subordinate? c super-c) + (raise-arguments-error who "the second custodian does not manage the first custodian" + "first custodian" c + "second custodian" super-c)) + (hash-keys (custodian-children c))) + +(define (custodian-memory-accounting-available?) + #f) + +(define/who (custodian-require-memory limit-cust need-amt stop-cust) + (check who custodian? limit-cust) + (check who exact-nonnegative-integer? need-amt) + (check who custodian? stop-cust) + (raise (exn:fail:unsupported + "custodian-require-memory: unsupported" + (current-continuation-marks)))) + +(define/who (custodian-limit-memory limit-cust need-amt [stop-cust limit-cust]) + (check who custodian? limit-cust) + (check who exact-nonnegative-integer? need-amt) + (check who custodian? stop-cust) + (raise (exn:fail:unsupported + "custodian-limit-memory: unsupported" + (current-continuation-marks)))) + +;; ---------------------------------------- + +(define/who (make-custodian-box c v) + (check who custodian? c) + (define b (custodian-box v (custodian-get-shutdown-sema c))) + (unless (unsafe-custodian-register c b (lambda (b) (set-custodian-box-v! b #f)) #f #t) + (raise-custodian-is-shut-down who c)) + b) + +(define/who (custodian-box-value cb) + (check who custodian-box? cb) + (custodian-box-v cb)) + +;; ---------------------------------------- + +(define (raise-custodian-is-shut-down who c) + (raise-arguments-error who "the custodian has been shut down" + "custodian" c)) diff --git a/racket/src/thread/debug.rkt b/racket/src/thread/debug.rkt new file mode 100644 index 0000000000..d515bbd643 --- /dev/null +++ b/racket/src/thread/debug.rkt @@ -0,0 +1,14 @@ +#lang racket/base + +;; Change `debug-select` to enable or disable debugging mode, +;; such as assertions about the current atomicity mode. + +(provide debug-select) + +(define-syntax-rule (debug-select + #:on + [on ...] + #:off + [off ...]) + ;; Select `on` or `off` here: + (begin off ...)) diff --git a/racket/src/thread/demo.rkt b/racket/src/thread/demo.rkt new file mode 100644 index 0000000000..c1f215bd9f --- /dev/null +++ b/racket/src/thread/demo.rkt @@ -0,0 +1,506 @@ +#lang racket/base +(require "bootstrap-main.rkt") + +;; Don't use exception handlers here, because the "bootstrap.rkt" +;; implementation of engines can't support it. + +(define done? #f) + +(call-in-main-thread + (lambda () + (define-syntax-rule (check a b) + (let ([a-v a] + [b-v b]) + (unless (equal? a-v b-v) + (error 'failed "~s: ~e vs. ~e" 'b a-v b-v)))) + + ;; Check semaphores + (check #t (thread? (current-thread))) + (check #t (evt? (current-thread))) + (define s (make-semaphore)) + (define t0 (thread (lambda () (semaphore-wait s) (printf "__\n") (semaphore-post s)))) + (define t1 (thread (lambda () (semaphore-wait s) (printf "hi\n") (semaphore-post s)))) + (define t2 (thread (lambda () (printf "HI\n") (semaphore-post s)))) + (thread-wait t0) + (thread-wait t1) + (thread-wait t2) + + ;; Check channels + (define ch (make-channel)) + (define ct1 (thread (lambda () (printf "1 ~a\n" (channel-get ch))))) + (define ct2 (thread (lambda () (printf "2 ~a\n" (channel-get ch))))) + (channel-put ch 'a) + (channel-put ch 'b) + + (define cpt1 (thread (lambda () (channel-put ch 'c)))) + (define cpt2 (thread (lambda () (channel-put ch 'd)))) + (printf "3 ~a\n" (channel-get ch)) + (printf "4 ~a\n" (channel-get ch)) + + ;; Check timeout + (check #f (sync/timeout 0.1)) + (check #f (sync/timeout 0.1 never-evt)) + + ;; Check semaphore polling + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 s)) + + ;; Check more semaphore polling + (define s2 (make-semaphore 3)) + (check s2 (sync/timeout 0 s s2)) + (check s2 (sync/timeout 0 s2 s)) + (check 'got-s2 (sync s (wrap-evt s2 (lambda (v) (check v s2) 'got-s2)))) + (check #f (sync/timeout 0 s2 s)) + + ;; Choice evts + (define choice1 (choice-evt s s2)) + (semaphore-post s2) + (check s2 (sync choice1)) + (semaphore-post s) + (check s (sync choice1)) + (check #f (sync/timeout 0 choice1)) + + ;; Check channel and `sync` + (void (thread (lambda () (channel-put ch 'c2)))) + (check 'c2 (sync ch)) + + ;; Check channel-put events + (void (thread (lambda () (check 'c3 (channel-get ch))))) + (define pc (channel-put-evt ch 'c3)) + (check pc (sync pc)) + + ;; Check guard event + (define ok-evt (guard-evt + (lambda () + (define ch (make-channel)) + (thread (lambda () (channel-put ch 'ok))) + ch))) + (check 'ok (sync ok-evt)) + + ;; Check semaphore-peek events + (semaphore-post s) + (define sp (semaphore-peek-evt s)) + (check sp (sync/timeout 0 sp)) + (check sp (sync/timeout 0 sp)) + (check s (sync/timeout 0 s)) + (check #f (sync/timeout 0 sp)) + + ;; Check nacks + (define nack #f) + (check #t (semaphore? (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore 1)))))) + (check #f (sync/timeout 0 nack)) + (set! nack #f) + (let loop () + (check 'ok (sync (nack-guard-evt (lambda (n) (set! nack n) (make-semaphore))) ok-evt)) + (unless nack (loop))) + (check (void) (sync/timeout 0 nack)) + + (semaphore-post s) + (check #f (sync/timeout 0 ch (channel-put-evt ch 'oops))) + (check sp (sync/timeout #f ch (channel-put-evt ch 'oops) sp)) + + (let ([v #f]) + (check #f (sync/timeout 0 + (nack-guard-evt + (lambda (nack) + (set! v nack) + (choice-evt (make-semaphore) (make-semaphore)))))) + (check (void) (sync/timeout 0 v))) + + ;; evt chaperone + (define e1 (make-semaphore 1)) + (check #t (chaperone-of? (chaperone-evt e1 void) e1)) + (check #f (chaperone-of? e1 (chaperone-evt e1 void))) + (let ([hit #f]) + (check e1 (sync (chaperone-evt e1 (lambda (e) + (set! hit e) + (values e values))))) + (check e1 hit)) + (check #t (semaphore? (chaperone-evt e1 void))) + + (check #t (chaperone-of? (chaperone-evt ch void) ch)) + (check #t (channel? (chaperone-evt ch void))) + (check #t (channel? (chaperone-channel ch void void))) + (let ([proc (lambda (arg) arg)]) + (thread (lambda () (channel-put ch proc))) + (let ([proc2 (channel-get (chaperone-evt ch (lambda (ch) + (values ch + (lambda (proc) + (chaperone-procedure proc void))))))]) + (check #f (eq? proc2 proc)) + (check #t (chaperone-of? proc2 proc)))) + (let ([got #f]) + (define th (thread (lambda () (set! got (channel-get ch))))) + (channel-put (chaperone-evt ch void) 'ok) + (check th (sync th)) + (check got 'ok)) + (define (check-chaperone-channel channel-put) + (let ([proc (lambda (arg) arg)] + [got #f]) + (define th (thread (lambda () (set! got (channel-get ch))))) + (channel-put (chaperone-channel ch + (lambda (ch) (values ch values)) + (lambda (ch proc) + (chaperone-procedure proc void))) + proc) + (check #f (eq? got proc)) + (check #t (chaperone-of? got proc)))) + (check-chaperone-channel channel-put) + (check-chaperone-channel (lambda (ch v) (sync (channel-put-evt ch v)))) + + ;; Check sleeping in main thread + (define now1 (current-inexact-milliseconds)) + (sleep 0.1) + (check #t ((current-inexact-milliseconds) . >= . (+ now1 0.1))) + + ;; Check sleeping in other thread + (define now2 (current-inexact-milliseconds)) + (define ts (thread (lambda () (sleep 0.1)))) + (check ts (sync ts)) + (check #t ((current-inexact-milliseconds) . >= . (+ now2 0.1))) + + ;; Check `alarm-evt` + (define now2+ (current-inexact-milliseconds)) + (define alm (alarm-evt (+ 0.1 now2+))) + (check alm (sync alm)) + (check #t ((current-inexact-milliseconds) . >= . (+ now2+ 0.1))) + + ;; Check system-idle event + (define v 0) + (thread (lambda () (set! v (add1 v)))) + (sync (system-idle-evt)) + (check 1 v) + + ;; Check `replace-evt` + (check 5 (sync (replace-evt always-evt (lambda (v) (wrap-evt always-evt (lambda (v) 5)))))) + (check #f (sync/timeout 0 (replace-evt never-evt void))) + (let ([ns null]) + (check #f (sync/timeout 0 (replace-evt (choice-evt + (nack-guard-evt + (lambda (n) + (set! ns (cons n ns)) + never-evt)) + (nack-guard-evt + (lambda (n) + (set! ns (cons n ns)) + never-evt))) + void))) + (check 2 (length ns)) + (check (void) (sync (car ns))) + (check (void) (sync (cadr ns)))) + + ;; Check `thread-send` + (check (void) (thread-send (current-thread) 'sent0)) + (check (void) (thread-send (current-thread) 'sent1)) + (check 'sent0 (thread-receive)) + (check 'sent1 (thread-receive)) + (check #f (thread-try-receive)) + (check (void) (thread-send (current-thread) 'sent2)) + (check 'sent2 (thread-try-receive)) + (let ([t (current-thread)]) + (thread (lambda () + (sync (system-idle-evt)) + (thread-send t 'sent3)))) + (check 'sent3 (thread-receive)) + + (define rcv (thread-receive-evt)) + (check #f (sync/timeout 0 rcv)) + (check (void) (thread-send (current-thread) 'sent4)) + (check rcv (sync/timeout #f rcv)) + (check 'sent4 (thread-receive)) + (check #f (sync/timeout 0 rcv)) + + (let ([r #f]) + (define t (thread (lambda () + (set! r (sync rcv rcv))))) + (sync (system-idle-evt)) + (thread-send t 'ok) + (sync (system-idle-evt)) + (check t (sync/timeout 0 t)) + (check rcv r)) + + (define (check-break/kill #:kill? kill?) + (define stop-thread (if kill? kill-thread break-thread)) + (define (report-expected-exn what) + (unless kill? + (printf "[That ~a was from a thread, and it's expected]\n" what))) + (define (report-expected-break) + (report-expected-exn "break")) + + ;; Check that a loop can be abandoned + (define tinf (thread (lambda () (let loop () (loop))))) + (sleep) + (stop-thread tinf) + (check tinf (sync tinf)) + (report-expected-break) + + ;; Check that a break exception is delayed if disabled + (define now3 (current-inexact-milliseconds)) + (define tdelay (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (sleep 0.1) + (with-continuation-mark + break-enabled-key + (make-thread-cell #t) + (begin + ;(check-for-break) + (let loop () (loop)))))))) + (stop-thread tdelay) + (check tdelay (sync tdelay)) + (report-expected-break) + (unless kill? + (check #t ((current-inexact-milliseconds) . >= . (+ now3 0.1)))) + + ;; Check that a semaphore wait can be abandoned + (define tstuck (thread (lambda () (semaphore-wait (make-semaphore))))) + (sync (system-idle-evt)) + (stop-thread tstuck) + (check tstuck (sync tstuck)) + (report-expected-break) + + ;; Check that an externally abanoned `sync` posts nacks + (define nack1 #f) + (define nack2 #f) + (define tstuck2 (thread (lambda () + (sync (nack-guard-evt + (lambda (s) (set! nack1 s) never-evt)) + (nack-guard-evt + (lambda (s) (set! nack2 s) never-evt)))))) + (sync (system-idle-evt)) + (stop-thread tstuck2) + (thread-wait tstuck2) + (report-expected-break) + (check (void) (sync nack1)) + (check (void) (sync nack2)) + + ;; Make sure a `sync` can be abandoned during a guard callback + (define tfail (thread (lambda () + (sync (nack-guard-evt + (lambda (s) + (set! nack1 s) + (if kill? + (kill-thread (current-thread)) + (error "oops")))))))) + (check tfail (sync tfail)) + (report-expected-exn "oops") + (check (void) (sync nack1)) + + ;; Make sure nested abandoned `syncs` are ok + (define tfail2 (thread (lambda () + (sync (nack-guard-evt + (lambda (s) + (set! nack1 s) + (sync (nack-guard-evt + (lambda (s) + (set! nack2 s) + (if kill? + (kill-thread (current-thread)) + (error "oops"))))))))))) + (check tfail2 (sync tfail2)) + (report-expected-exn "oops") + (check (void) (sync nack1)) + (check (void) (sync nack2))) + + (check-break/kill #:kill? #f) + (check-break/kill #:kill? #t) + + ;; Check that an ignored break doesn't interfere with semaphore waiting, etc. + (define (check-ignore-break-retry make-trigger trigger-post trigger-wait) + (define s/nb (make-trigger)) + (define done?/nb #f) + (define t/nb (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (trigger-wait s/nb) + (set! done?/nb #t))))) + (sync (system-idle-evt)) + (break-thread t/nb) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/nb)) + (check #f done?/nb) + (trigger-post s/nb) + (sync (system-idle-evt)) + (check t/nb (sync/timeout 0 t/nb)) + (check #t done?/nb)) + + (check-ignore-break-retry make-semaphore semaphore-post sync) + (check-ignore-break-retry make-semaphore semaphore-post semaphore-wait) + (check-ignore-break-retry make-channel (lambda (c) (channel-put c 'go)) channel-get) + (check-ignore-break-retry make-channel channel-get (lambda (c) (channel-put c 'go))) + (check-ignore-break-retry (lambda () (box #f)) + (lambda (b) (thread-resume (unbox b))) + (lambda (b) (set-box! b (current-thread)) (thread-suspend (current-thread)))) + (check-ignore-break-retry (lambda () (box #f)) + (lambda (b) (thread-send (unbox b) 'ok)) + (lambda (b) (set-box! b (current-thread)) (thread-receive))) + + ;; Check suspending and resuming a thread that is waiting on a semaphore + (check #f (sync/timeout 0 s2)) + (define t/sw (thread + (lambda () + (sync s2)))) + (check t/sw (sync (thread-resume-evt t/sw))) + (define t/sw-s-evt (thread-suspend-evt t/sw)) + (check #f (sync/timeout 0 t/sw-s-evt)) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/sw)) + (thread-suspend t/sw) + (check t/sw (sync/timeout 0 t/sw-s-evt)) + (check #f (sync/timeout 0 t/sw)) + (semaphore-post s2) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/sw)) + (thread-resume t/sw) + (check t/sw (sync t/sw)) + (check #f (sync/timeout 0 s2)) + + ;; Check suspending and resuming a thread that is waiting on a message + (define (check-suspend-thread-receive send-after-resume?) + (define t/sr (thread + (lambda () + (channel-put ch (thread-receive))))) + (sync (system-idle-evt)) + (thread-suspend t/sr) + (unless send-after-resume? + (thread-send t/sr 'ok)) + (check #f (sync/timeout 0 ch)) + (check #f (sync/timeout 0 t/sr)) + (thread-resume t/sr) + (when send-after-resume? + (thread-send t/sr 'ok)) + (check 'ok (sync ch))) + (check-suspend-thread-receive #t) + (check-suspend-thread-receive #f) + + ;; Check sync/enable-break => break + (define tbe (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (sync/enable-break (make-semaphore)))))) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 tbe)) + (break-thread tbe) + (sync (system-idle-evt)) + (check tbe (sync/timeout 0 tbe)) + (printf "[That break was from a thread, and it's expected]\n") + + ;; Check sync/enable-break => semaphore + (check #f (sync/timeout 0 s2)) + (define tbe2 (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (thread (lambda () + (sync/enable-break s2))))) + (sync (system-idle-evt)) + (semaphore-post s2) ; => chooses `s2` in `sync/enable-break` + (break-thread tbe2) + (sync (system-idle-evt)) + (check tbe2 (sync/timeout 0 tbe2)) + (check #f (sync/timeout 0 s2)) + + ;; Check call-with-semaphore + (semaphore-post s2) + (check #f (call-with-semaphore s2 (lambda () (sync/timeout 0 s2)))) + (check s2 (sync/timeout 0 s2)) + (define t/cws (thread (lambda () (call-with-semaphore s2 (lambda () (error "shouldn't get here")))))) + (sync (system-idle-evt)) + (check #f (sync/timeout 0 t/cws)) + (break-thread t/cws) + (sync (system-idle-evt)) + (printf "[That break was from a thread, and it's expected]\n") + (check t/cws (sync/timeout 0 t/cws)) + + ;; Check call-in-nested-thread + (check 10 (call-in-nested-thread (lambda () 10))) + (check '(1 2) (call-with-values (lambda () + (call-in-nested-thread (lambda () (values 1 2)))) + list)) + + ;; Custodians + (define c (make-custodian)) + (define cb (make-custodian-box c'running)) + (check 'running (custodian-box-value cb)) + (custodian-shutdown-all c) + (check #f (custodian-box-value cb)) + (custodian-shutdown-all c) + + (define c2 (make-custodian)) + (define t/cust (parameterize ([current-custodian c2]) + (thread (lambda () (sync (make-semaphore)))))) + (sync (system-idle-evt)) + (check #t (thread-running? t/cust)) + (custodian-shutdown-all c2) + (check #f (thread-running? t/cust)) + + (define c3 (make-custodian)) + (define c4 (make-custodian c3)) + (define t/cust2 (parameterize ([current-custodian c4]) + (thread (lambda () (sync (make-semaphore)))))) + (sync (system-idle-evt)) + (check #t (thread-running? t/cust2)) + (custodian-shutdown-all c3) + (check #f (thread-running? t/cust2)) + + (define c5-1 (make-custodian)) + (define c5-2 (make-custodian)) + (define t/custs (parameterize ([current-custodian c5-1]) + (thread (lambda () (sync (make-semaphore)))))) + (thread-resume t/custs c5-2) + (sync (system-idle-evt)) + (check #t (thread-running? t/custs)) + (custodian-shutdown-all c5-1) + (check #t (thread-running? t/custs)) + (custodian-shutdown-all c5-2) + (check #f (thread-running? t/custs)) + + (define c6-1 (make-custodian)) + (define c6-2 (make-custodian)) + (define s6 (make-semaphore)) + (define r6 #f) + (define t/s2k (parameterize ([current-custodian c6-1]) + (thread/suspend-to-kill (lambda () (sync s6) (set! r6 'complete))))) + (sync (system-idle-evt)) + (check #t (thread-running? t/s2k)) + (custodian-shutdown-all c6-1) + (check #f (thread-running? t/s2k)) + (check #f (thread-dead? t/s2k)) + (thread-resume t/s2k c6-2) + (check #t (thread-running? t/s2k)) + (semaphore-post s6) + (sync t/s2k) + (check 'complete r6) + + (define t/r1 (thread (lambda () (sync (make-semaphore))))) + (define t/r2 (thread (lambda () (sync (make-semaphore))))) + (thread-resume t/r2 t/r1) + (thread-suspend t/r2) + (check #f (thread-running? t/r2)) + (check #f (thread-dead? t/r2)) + (thread-resume t/r1) + (check #f (thread-running? t/r2)) ; because `t/r1` was not suspended + (thread-suspend t/r1) + (thread-resume t/r1) + (check #t (thread-running? t/r2)) + (kill-thread t/r1) + (kill-thread t/r2) + + ;; Check will executors + (define we (make-will-executor)) + (check #t (will-executor? we)) + (check #f (will-try-execute we)) + (check (void) (will-register we (gensym) (lambda (s) s))) + (collect-garbage) + (check #t (symbol? (will-try-execute we))) + (check #f (will-try-execute we)) + (check (void) (will-register we (gensym) (lambda (s) s))) + (thread (lambda () (sync (system-idle-evt)) (collect-garbage))) + (check #t (symbol? (will-execute we))) + + (set! done? #t))) + +(unless done? + (error "main thread stopped running due to deadlock?")) diff --git a/racket/src/thread/engine.rkt b/racket/src/thread/engine.rkt new file mode 100644 index 0000000000..8ba3a65f4a --- /dev/null +++ b/racket/src/thread/engine.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require racket/private/primitive-table + "internal-error.rkt" + (only-in '#%linklet primitive-table) + (for-syntax racket/base)) + +(void (unless (primitive-table '#%engine) + (internal-error "engines not provided by host"))) +(void (unless (primitive-table '#%pthread) + (internal-error "pthreads not provided by host"))) + +(define-syntax (bounce stx) + (syntax-case stx () + [(_ table bind ...) + (with-syntax ([([orig-id here-id] ...) + (for/list ([bind (in-list (syntax->list #'(bind ...)))]) + (if (identifier? bind) + (list bind bind) + bind))]) + #'(begin + (provide here-id ...) + (import-from-primitive-table table bind ...)))])) + +;; This `#%pthread` table's entries are linked more directly +;; than `#%engine` entries: +(bounce #%pthread + make-pthread-parameter) + +(bounce #%engine + make-engine + engine-block + engine-return + current-engine-state + current-process-milliseconds + set-ctl-c-handler! + root-continuation-prompt-tag + break-enabled-key + set-break-enabled-transition-hook! + [continuation-marks host:continuation-marks] + + [poll-will-executors host:poll-will-executors] + [make-will-executor host:make-will-executor] + [make-stubborn-will-executor host:make-stubborn-will-executor] + [will-executor? host:will-executor?] + [will-register host:will-register] + [will-try-execute host:will-try-execute] + + ;; Just `exn:break`, etc., but the host may need + ;; to distinguish breaks raised by the thread + ;; implementation: + exn:break/non-engine + exn:break:hang-up/non-engine + exn:break:terminate/non-engine + + ;; Check for async foreign callbacks: + [poll-async-callbacks host:poll-async-callbacks] + + ;; Disabling interrupts prevents a race with interrupt handlers. + ;; For example, if a GC is handled as an interrupt, then disabling + ;; interrupts prevents a race with a GC handler, and aything that + ;; disables interrupts can be used from a GC handler. + [disable-interrupts host:disable-interrupts] + [enable-interrupts host:enable-interrupts] + + fork-pthread + pthread? + [get-thread-id get-pthread-id] + [make-condition chez:make-condition] + [condition-wait chez:condition-wait] + [condition-signal chez:condition-signal] + [condition-broadcast chez:condition-broadcast] + [make-mutex chez:make-mutex] + [mutex-acquire chez:mutex-acquire] + [mutex-release chez:mutex-release] + threaded?) diff --git a/racket/src/thread/evt.rkt b/racket/src/thread/evt.rkt new file mode 100644 index 0000000000..903689450e --- /dev/null +++ b/racket/src/thread/evt.rkt @@ -0,0 +1,190 @@ +#lang racket/base +(require racket/unsafe/ops + "atomic.rkt") + +(provide prop:evt + evt? + evt-poll + + (rename-out [the-never-evt never-evt] + [the-always-evt always-evt] + [the-async-evt async-evt]) + never-evt? + async-evt? + + (struct-out wrap-evt) + (struct-out handle-evt) + (struct-out control-state-evt) + (struct-out poll-guard-evt) + (struct-out choice-evt) + + (struct-out poller) + (struct-out poll-ctx) + + (struct-out delayed-poll) + + prop:secondary-evt + poller-evt + + evt-impersonator?) + +(module+ for-chaperone + (provide primary-evt? primary-evt-ref + secondary-evt? secondary-evt-ref + impersonator-prop:evt)) + +(define-values (prop:evt primary-evt? primary-evt-ref) + (make-struct-type-property 'evt + (lambda (v info) + (define who '|guard-for-prop:evt|) + (cond + [(poller? v) v] ; part of the internal API, not the safe API + [(evt? v) v] + [(and (procedure? v) + (procedure-arity-includes? v 1)) + v] + [(exact-nonnegative-integer? v) + (define init-count (cadr info)) + (unless (v . < . init-count) + (raise-arguments-error who + "index for immutable field >= initialized-field count" + "index" v + "initialized-field count" init-count)) + (unless (memv v (list-ref info 5)) + (raise-arguments-error who "field index not declared immutable" + "field index" v)) + (selector-prop-evt-value + (make-struct-field-accessor (list-ref info 3) v))] + [else + (raise-argument-error who + "(or/c evt? (procedure-arity-includes/c 1) exact-nonnegative-integer?)" + v)])))) + +(struct selector-prop-evt-value (selector) + #:authentic) + +;; `prop:secondary-evt` is for primitive property types that +;; (due to histoical, bad design choices) act like `prop:evt` +;; without implying `prop:evt`. Specifically, it's used for +;; input and output ports. +(define-values (prop:secondary-evt secondary-evt? secondary-evt-ref) + (make-struct-type-property 'secondary-evt)) + +(define (evt? v) + (or (primary-evt? v) + (secondary-evt? v))) + +;; A poller as a `prop:evt` value wraps a procedure that is called +;; in atomic mode +;; evt poll-ctx -> (values results-or-#f replacing-evt-or-#f) +;; where either a list of results is returned, indicating +;; that the event is selected, or a replacement event +;; is returned (possibly unchanged). If the replacement event +;; is a wrapper on `always-evt`, it will certainly be selected. +;; If a poller does any work that can allow some thread to +;; become unblocked, then it must tell the scheduler via +;; `schedule-info-did-work!`. +(struct poller (proc)) + +;; Provided to a `poller` function: +(struct poll-ctx (poll? ; whether events are being polled once (i.e., 0 timeout) + select-proc ; callback to asynchronously select the event being polled + sched-info ; instructions to the scheduler, such as timeouts + [incomplete? #:mutable])) ; #t => getting back the same event does not imply a completed poll +;; If a `poller` callback keeps `select-proc` for asynchronous use, +;; then it should return a `control-state-evt` to ensure that +;; `select-proc` is not called if the event is abandoned. + +(struct never-evt () + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values #f self)))) +(define the-never-evt (never-evt)) + +(struct always-evt () + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values (list self) #f)))) +(define the-always-evt (always-evt)) + +;; A placeholder for an event that will be selected through a callback +;; instead of polling: +(struct async-evt () + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values #f self)))) +(define the-async-evt (async-evt)) + +(struct wrap-evt (evt wrap) + #:property prop:evt (poller (lambda (self poll-ctx) + (assert-atomic-mode) + (values #f self))) + #:reflection-name 'evt) +(struct handle-evt wrap-evt ()) + +;; A `control-state-evt` enables (unsafe) cooperation with the +;; scheduler, normally produced by a `poller` callback. The `evt` is +;; typically a wrapper on `async-evt`. If the event is not selected, +;; the `interrupt-proc` plus `abandon-proc` will be called. If a +;; synchronization attempt is interrupted by a break signal, then +;; `interrupt-proc` is called, and then either `abandon-proc` or +;; `retry-proc` --- the latter when the synchronization attempt +;; continues, in which case a value might be ready immediately or the +;; event goes back to some waiting state. For example, a sempahore +;; uses `interrupt-proc` to get out of the semaphore's queue and +;; `rety-proc` gets back in line (or immediately returns if the +;; semaphore was meanwhile posted). As another example, a +;; `nack-guard-evt`'s result uses `abandon-proc` to post to the NACK +;; event. +(struct control-state-evt (evt + interrupt-proc ; thunk for break/kill initiated or otherwise before `abandon-proc` + abandon-proc ; thunk for not selected, including break/kill complete + retry-proc) ; thunk for resume from break; return `(values _val _ready?)` + #:property prop:evt (poller (lambda (self poll-ctx) (values #f self)))) + +(struct poll-guard-evt (proc) + #:property prop:evt (poller (lambda (self poll-ctx) (values #f self))) + #:reflection-name 'evt) + +(struct choice-evt (evts) + #:property prop:evt (poller (lambda (self poll-ctx) (values #f self))) + #:reflection-name 'evt) + +(define-values (impersonator-prop:evt evt-impersonator? evt-impersonator-ref) + (make-impersonator-property 'evt-impersonator)) + +;; Called in atomic mode +;; Checks whether an event is ready; returns the same results +;; as a poller. If getting an event requires going out of atomic mode +;; (to call a `prop:evt` procedure) then return a `delayed-poll` +;; struct. +(define (evt-poll evt poll-ctx) + (assert-atomic-mode) + (let* ([v (cond + [(evt-impersonator? evt) (evt-impersonator-ref evt)] + [(primary-evt? evt) + (primary-evt-ref evt)] + [else + (secondary-evt-ref evt)])] + [v (if (selector-prop-evt-value? v) + ((selector-prop-evt-value-selector v) evt) + v)]) + (cond + [(procedure? v) + (values #f (delayed-poll + ;; out of atomic mode: + (lambda () + (let ([v (call-with-continuation-barrier (lambda () (v evt)))]) + (cond + [(evt? v) v] + [(poller? v) (poller-evt v)] + [else (wrap-evt the-always-evt (lambda (v) evt))])))))] + [(poller? v) ((poller-proc v) evt poll-ctx)] + [(evt? v) (values #f v)] + [else (values #f the-never-evt)]))) + +;; Possible result from `evt-poll`: +(struct delayed-poll (resume)) + +(struct poller-evt (poller) + #:property prop:evt (struct-field-index poller)) diff --git a/racket/src/thread/exit.rkt b/racket/src/thread/exit.rkt new file mode 100644 index 0000000000..2af7ec30ae --- /dev/null +++ b/racket/src/thread/exit.rkt @@ -0,0 +1,29 @@ +#lang racket/base +(require (only-in racket/base + [exit host:exit]) + "../common/check.rkt" + "plumber.rkt") + +(provide exit + force-exit + exit-handler) + +(define/who exit-handler + (make-parameter (let ([root-plumber (current-plumber)]) + (lambda (v) + (plumber-flush-all root-plumber) + (force-exit v))) + (lambda (p) + (check who (procedure-arity-includes/c 1) p) + p))) + +(define (force-exit v) + (cond + [(byte? v) + (host:exit v)] + [else + (host:exit 0)])) + +(define (exit [v #t]) + ((exit-handler) v) + (void)) diff --git a/racket/src/thread/fsemaphore.rkt b/racket/src/thread/fsemaphore.rkt new file mode 100644 index 0000000000..9b2f5094ab --- /dev/null +++ b/racket/src/thread/fsemaphore.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require "check.rkt" + "semaphore.rkt") + +(provide fsemaphore? + make-fsemaphore + fsemaphore-post + fsemaphore-wait + fsemaphore-try-wait? + fsemaphore-count) + +(struct fsemaphore (sema)) + +(define/who (make-fsemaphore init) + (check who exact-nonnegative-integer? init) + (fsemaphore (make-semaphore init))) + +(define/who (fsemaphore-post fsema) + (check who fsemaphore? fsema) + (semaphore-post (fsemaphore-sema fsema))) + +(define/who (fsemaphore-wait fsema) + (check who fsemaphore? fsema) + (semaphore-wait (fsemaphore-sema fsema))) + +(define/who (fsemaphore-try-wait? fsema) + (check who fsemaphore? fsema) + (semaphore-try-wait? (fsemaphore-sema fsema))) + +(define/who (fsemaphore-count fsema) + (check who fsemaphore? fsema) + 0) diff --git a/racket/src/thread/future.rkt b/racket/src/thread/future.rkt new file mode 100644 index 0000000000..19e8f31a32 --- /dev/null +++ b/racket/src/thread/future.rkt @@ -0,0 +1,417 @@ +#lang racket/base + +(require "check.rkt" + "internal-error.rkt" + "engine.rkt" + "atomic.rkt" + "parameter.rkt" + "../common/queue.rkt" + "thread.rkt" + "lock.rkt") + +(provide futures-enabled? + processor-count + current-future + future + future? + would-be-future + touch + future-block + future-wait + current-future-prompt + future:condition-broadcast + future:condition-signal + future:condition-wait + future:make-condition + signal-future + reset-future-logs-for-tracing! + mark-future-trace-end!) + +;; not sure of order here... +(define (get-caller) + (cond + [(current-future) + (current-future)] + [(not (= 0 (get-pthread-id))) + (get-pthread-id)] + [else + (current-thread)])) + + +;; ---------------------------- futures ---------------------------------- + + +(define ID (box 1)) + +(define get-next-id + (lambda () + (let ([id (unbox ID)]) + (if (box-cas! ID id (+ 1 id)) + id + (get-next-id))))) + +(define (processor-count) + 1) + +(define futures-enabled? threaded?) + +(struct future* (id cond lock prompt + would-be? [thunk #:mutable] [engine #:mutable] + [cont #:mutable] [result #:mutable] [done? #:mutable] + [blocked? #:mutable][resumed? #:mutable] + [cond-wait? #:mutable])) + +(define (create-future would-be-future?) + (future* (get-next-id) ;; id + (future:make-condition) ;; cond + (make-lock) ;; lock + (make-continuation-prompt-tag 'future) ;; prompt + would-be-future? ;; would-be? + #f ;; thunk + #f ;; engine + #f ;; cont + #f ;; result + #f ;; done? + #f ;; blocked? + #f ;; resumed? + #f)) ;; cond-wait? + +(define future? future*?) + +(define current-future (make-pthread-parameter #f)) + +(define (current-future-prompt) + (if (current-future) + (future*-prompt (current-future)) + (internal-error "Not running in a future."))) + +(define (thunk-wrapper f thunk) + (lambda () + (call-with-continuation-prompt + (lambda () + (let ([result (thunk)]) + (with-lock ((future*-lock f) (current-future)) + (set-future*-result! f result) + (set-future*-done?! f #t) + (future:condition-broadcast (future*-cond f))))) + (future*-prompt f)))) + +(define/who (future thunk) + (check who (procedure-arity-includes/c 0) thunk) + (cond + [(not (futures-enabled?)) + (would-be-future thunk)] + [else + (let ([f (create-future #f)]) + (set-future*-engine! f (make-engine (thunk-wrapper f thunk) #f #t)) + (schedule-future f) + f)])) + +(define/who (would-be-future thunk) + (check who (procedure-arity-includes/c 0) thunk) + (let ([f (create-future #t)]) + (set-future*-thunk! f (thunk-wrapper f thunk)) + f)) + +(define/who (touch f) + (check who future*? f) + (cond + [(future*-done? f) + (future*-result f)] + [(future*-would-be? f) + ((future*-thunk f)) + (future*-result f)] + [(lock-acquire (future*-lock f) (get-caller) #f) ;; got lock + (when (or (and (not (future*-blocked? f)) (not (future*-done? f))) + (and (future*-blocked? f) (not (future*-cont f)))) + (future:condition-wait (future*-cond f) (future*-lock f))) + (future-awoken f)] + [else + (touch f)])) + +(define (future-awoken f) + (cond + [(future*-done? f) ;; someone else ran continuation + (lock-release (future*-lock f) (get-caller)) + (future*-result f)] + [(future*-blocked? f) ;; we need to run continuation + (set-future*-blocked?! f #f) + (set-future*-resumed?! f #t) + (lock-release (future*-lock f) (get-caller)) + ((future*-cont f) '()) + (future*-result f)] + [else + (internal-error "Awoken but future is neither blocked nor done.")])) + +;; called from chez layer. +(define (future-block) + (define f (current-future)) + (when (and f (not (future*-blocked? f)) (not (future*-resumed? f))) + (with-lock ((future*-lock f) f) + (set-future*-blocked?! f #t)) + (engine-block))) + +;; called from chez layer. +;; this should never be called from outside a future. +(define (future-wait) + (define f (current-future)) + (with-lock ((future*-lock f) f) + (future:condition-wait (future*-cond f) (future*-lock f)))) + +;; futures and conditions + +(define (wait-future f m) + (with-lock ((future*-lock f) f) + (set-future*-cond-wait?! f #t)) + (lock-release m (get-caller)) + (engine-block)) + +(define (awaken-future f) + (with-lock ((future*-lock f) (get-caller)) + (set-future*-cond-wait?! f #f))) + +;; --------------------------- conditions ------------------------------------ + +(struct future-condition* (queue lock)) + +(define (future:make-condition) + (future-condition* (make-queue) (make-lock))) + +(define (future:condition-wait c m) + (define caller (get-caller)) + (if (own-lock? m caller) + (begin + (with-lock ((future-condition*-lock c) caller) + (queue-add! (future-condition*-queue c) caller)) + (if (future? caller) + (wait-future caller m) + (thread-condition-wait (lambda () (lock-release m caller)))) + (lock-acquire m (get-caller))) ;; reaquire lock + (internal-error "Caller does not hold lock\n"))) + +(define (signal-future f) + (future:condition-signal (future*-cond f))) + +(define (future:condition-signal c) + (with-lock ((future-condition*-lock c) (get-caller)) + (let ([waitees (future-condition*-queue c)]) + (unless (queue-empty? waitees) + (let ([waitee (queue-remove! waitees)]) + (if (future? waitee) + (awaken-future waitee) + (thread-condition-awaken waitee))))))) + +(define (future:condition-broadcast c) + (with-lock ((future-condition*-lock c) (get-caller)) + (define waitees '()) + (queue-remove-all! (future-condition*-queue c) + (lambda (e) + (set! waitees (cons e waitees)))) + (let loop ([q waitees]) + (unless (null? q) + (let ([waitee (car q)]) + (if (future? waitee) + (awaken-future waitee) + (thread-condition-awaken waitee)) + (loop (cdr q))))))) + +;; ------------------------------------- future scheduler ---------------------------------------- + +(define THREAD-COUNT 2) +(define TICKS 1000000000) + +(define global-scheduler #f) +(define (scheduler-running?) + (not (not global-scheduler))) + +(struct worker (id lock mutex cond + [queue #:mutable] [idle? #:mutable] + [pthread #:mutable #:auto] [die? #:mutable #:auto]) + #:auto-value #f) + +(struct scheduler ([workers #:mutable #:auto]) + #:auto-value #f) + +;; I think this atomically is sufficient to guarantee scheduler is only created once. +(define (maybe-start-scheduler) + (atomically + (unless global-scheduler + (set! global-scheduler (scheduler)) + (let ([workers (create-workers)]) + (set-scheduler-workers! global-scheduler workers) + (start-workers workers))))) + +(define (kill-scheduler) + (when global-scheduler + (for-each (lambda (w) + (with-lock ((worker-lock w) (get-caller)) + (set-worker-die?! w #t))) + (scheduler-workers global-scheduler)))) + +(define (create-workers) + (let loop ([id 1]) + (cond + [(< id (+ 1 THREAD-COUNT)) + (cons (worker id (make-lock) (chez:make-mutex) (chez:make-condition) (make-queue) #t) + (loop (+ id 1)))] + [else + '()]))) + +;; When a new thread is forked it inherits the values of thread parameters from its creator +;; So, if current-atomic is set for the main thread and then new threads are forked, those new +;; threads current-atomic will be set and then never unset because they will not run code that +;; unsets it. +(define (start-workers workers) + (for-each (lambda (w) + (set-worker-pthread! w (fork-pthread (lambda () + (current-atomic 0) + (current-thread #f) + (current-engine-state #f) + (current-future #f) + ((worker-scheduler-func w)))))) + workers)) + +(define (schedule-future f) + (maybe-start-scheduler) + + (let ([w (pick-worker)]) + (with-lock ((worker-lock w) (get-caller)) + (chez:mutex-acquire (worker-mutex w)) + (queue-add! (worker-queue w) f) + (chez:condition-signal (worker-cond w)) + (chez:mutex-release (worker-mutex w))))) + +(define (pick-worker) + (define workers (scheduler-workers global-scheduler)) + (let loop ([workers* (cdr workers)] + [best (car workers)]) + (cond + [(or (null? workers*) + (queue-empty? (worker-queue best))) + best] + [(< (queue-length (worker-queue (car workers*))) + (queue-length (worker-queue best))) + (loop (cdr workers*) + (car workers*))] + [else + (loop (cdr workers*) + best)]))) + +(define (wait-for-work w) + (define m (worker-mutex w)) + (let try () + (cond + [(not (queue-empty? (worker-queue w))) ;; got work in meantime + (void)] + [(chez:mutex-acquire m #f) ;; cannot acquire lock while worker is being given work. + (chez:condition-wait (worker-cond w) m) + (chez:mutex-release m)] + [else ;; try to get lock again. + (try)]))) + +(define (worker-scheduler-func worker) + (lambda () + + (define (loop) + (lock-acquire (worker-lock worker) (get-pthread-id)) ;; block + (cond + [(worker-die? worker) ;; worker was killed + (lock-release (worker-lock worker) (get-pthread-id))] + [(queue-empty? (worker-queue worker)) ;; have lock. no work + (lock-release (worker-lock worker) (get-pthread-id)) + (cond + [(steal-work worker) + (do-work)] + [else + (wait-for-work worker)]) + (loop)] + [else + (do-work) + (loop)])) + + (define (complete ticks args) + (void)) + + (define (expire future worker) + (lambda (new-eng) + (set-future*-engine! future new-eng) + (cond + [(positive? (current-atomic)) + ((future*-engine future) TICKS (prefix future) complete (expire future worker))] + [(future*-resumed? future) ;; run to completion + ((future*-engine future) TICKS void complete (expire future worker))] + [(not (future*-cont future)) ;; don't want to reschedule future with a saved continuation + (with-lock ((worker-lock worker) (get-caller)) + (chez:mutex-acquire (worker-mutex worker)) + (queue-add! (worker-queue worker) future) + (chez:mutex-release (worker-mutex worker)))] + [else + (with-lock ((future*-lock future) (get-caller)) + (future:condition-signal (future*-cond future)))]))) + + (define (prefix f) + (lambda () + (when (future*-blocked? f) + (call-with-composable-continuation + (lambda (k) + (with-lock ((future*-lock f) (current-future)) + (set-future*-cont! f k)) + (engine-block)) + (future*-prompt f))))) + + + ;; need to have lock here. + (define (do-work) + (let ([work (queue-remove! (worker-queue worker))]) + (cond + [(future*-cond-wait? work) + (queue-add! (worker-queue worker) work) + (lock-release (worker-lock worker) (get-pthread-id))] ;; put back on queue + [else + (lock-release (worker-lock worker) (get-pthread-id)) + (current-future work) + ((future*-engine work) TICKS (prefix work) complete (expire work worker)) ;; call engine. + (current-future #f)]))) + + (loop))) + +(define (order-workers w1 w2) + (cond + [(< (worker-id w1) (worker-id w2)) + (values w1 w2)] + [else + (values w2 w1)])) + + ;; Acquire lock of peer with smallest id # first. + ;; worker is attempting to steal work from peers + (define (steal-work worker) + (let loop ([q (scheduler-workers global-scheduler)]) + (cond + [(null? q) #f] ;; failed to steal work. + [(not (eq? (worker-id worker) (worker-id (car q)))) ;; not ourselves + (let*-values ([(peer) (car q)] + [(w1 w2) (order-workers worker peer)]) ;; order them. + (lock-acquire (worker-lock w1) (get-pthread-id)) + (lock-acquire (worker-lock w2) (get-pthread-id)) + (cond + [(> (queue-length (worker-queue peer)) 2) ;; going to steal. Should likely made this # higher. + (do ([i (floor (/ (queue-length (worker-queue peer)) 2)) (- i 1)]) + [(zero? i) (void)] + (let ([work (queue-remove-end! (worker-queue peer))]) + (queue-add! (worker-queue worker) work))) + + (lock-release (worker-lock peer) (get-pthread-id)) ;; don't want to release our own lock. + #t] ;; stole work + [else ;; try a different peer + (lock-release (worker-lock worker) (get-pthread-id)) + (lock-release (worker-lock peer) (get-pthread-id)) + (loop (cdr q))]))] + [else (loop (cdr q))]))) + +;; ---------------------------------------- + +(define (reset-future-logs-for-tracing!) + (void)) + +(define (mark-future-trace-end!) + (void)) diff --git a/racket/src/thread/impersonator.rkt b/racket/src/thread/impersonator.rkt new file mode 100644 index 0000000000..f88175f26b --- /dev/null +++ b/racket/src/thread/impersonator.rkt @@ -0,0 +1,107 @@ +#lang racket/base +(require "check.rkt" + "internal-error.rkt" + "evt.rkt" + (submod "evt.rkt" for-chaperone) + "channel.rkt" + (submod "channel.rkt" for-impersonator)) + +(provide chaperone-evt + chaperone-channel + impersonate-channel) + +;; ---------------------------------------- + +(define/who (chaperone-evt evt proc . args) + (check who evt? evt) + (check proc (procedure-arity-includes/c 1) proc) + (do-chaperone-evt who "evt" #t evt proc args + (lambda (v) + (unless (evt? v) + (raise-result-error who "evt?" v))))) + +(define (do-chaperone-evt who what chaperone? evt proc args check-evt) + (check-impersonator-properties who args) + (apply chaperone-struct + evt + (cond + [(primary-evt? evt) primary-evt-ref] + [(secondary-evt? evt) secondary-evt-ref] + [else (internal-error "unrecognized evt to impersonate")]) + (lambda (evt v) v) + impersonator-prop:evt + (lambda (also-evt) + (call-with-values (lambda () (proc evt)) + (case-lambda + [(new-evt wrap) + (when chaperone? + (check-chaperone-of what new-evt evt)) + (check-evt new-evt) + (unless (and (procedure? wrap) + (procedure-arity-includes? wrap 1)) + (raise-result-error who "(procedure-arity-includes/c 1)" wrap)) + (handle-evt new-evt + (lambda (r) + (let ([new-r (wrap r)]) + (when chaperone? + (check-chaperone-of what new-r r)) + new-r)))] + [args + (raise + (exn:fail:contract:arity + (string-append + what " " (if chaperone? "chaperone" "impersonator") ": returned wrong number of values\n" + " expected count: 2\n" + " returned count: " (number->string (length args))) + (current-continuation-marks)))]))) + args)) + +;; ---------------------------------------- + +(define/who (chaperone-channel ch get-proc put-proc . args) + (do-impersonate-channel who #t ch get-proc put-proc args)) + +(define/who (impersonate-channel ch get-proc put-proc . args) + (do-impersonate-channel who #f ch get-proc put-proc args)) + +(define (do-impersonate-channel who chaperone? ch get-proc put-proc args) + (check who channel? ch) + (check who (procedure-arity-includes/c 1) get-proc) + (check who (procedure-arity-includes/c 2) put-proc) + (do-chaperone-evt who "channel" chaperone? ch get-proc + (list* impersonator-prop:channel-put + (cons ch (lambda (ch v) + (define new-v (put-proc ch v)) + (when chaperone? + (check-chaperone-of "channel" new-v v)) + new-v)) + args) + (lambda (v) + (unless (channel? v) + (raise-result-error who "channel?" v))))) + +;; ---------------------------------------- + +(define (check-chaperone-of what new-r r) + (unless (chaperone-of? new-r r) + (raise + (exn:fail:contract + (string-append + what " chaperone: non-chaperone result;\n" + " received a value that is not a chaperone of the original value\n" + " value: " ((error-value->string-handler) r) "\n" + " non-chaperone value: " + ((error-value->string-handler) new-r)) + (current-continuation-marks))))) + +(define (check-impersonator-properties who args) + (let loop ([args args]) + (unless (null? args) + (check who impersonator-property? (car args)) + (cond + [(null? args) + (raise-arguments-error who + "missing an argument after an impersonator-property argument" + "impersonator property" (car args))] + [else + (loop (cddr args))])))) diff --git a/racket/src/thread/instance.rkt b/racket/src/thread/instance.rkt new file mode 100644 index 0000000000..a8aac1dbf3 --- /dev/null +++ b/racket/src/thread/instance.rkt @@ -0,0 +1,51 @@ +#lang racket/base +(require "evt.rkt" + "sync.rkt" + "semaphore.rkt" + "schedule-info.rkt" + "sandman.rkt" + "atomic.rkt" + "custodian.rkt" + "thread.rkt" + "time.rkt") + +;; Unsafe scheduler-cooperation functions are made available to +;; clients through a `#%thread` primitive linklet instance: + +(provide #%thread-instance) + +(define #%thread-instance + (hasheq 'make-semaphore make-semaphore + 'semaphore-post semaphore-post + 'semaphore-wait semaphore-wait + 'semaphore-peek-evt semaphore-peek-evt + 'wrap-evt wrap-evt + 'always-evt always-evt + 'choice-evt choice-evt + 'sync sync + 'sync/timeout sync/timeout + 'evt? evt? + 'sync-atomic-poll-evt? sync-atomic-poll-evt? + 'prop:evt prop:evt + 'prop:secondary-evt prop:secondary-evt + 'poller poller + 'poller-evt poller-evt + 'poll-ctx-poll? poll-ctx-poll? + 'poll-ctx-select-proc poll-ctx-select-proc + 'poll-ctx-sched-info poll-ctx-sched-info + 'set-poll-ctx-incomplete?! set-poll-ctx-incomplete?! + 'control-state-evt control-state-evt + 'async-evt async-evt + 'current-sandman current-sandman + 'schedule-info-current-exts schedule-info-current-exts + 'schedule-info-did-work! schedule-info-did-work! + 'start-atomic start-atomic + 'end-atomic end-atomic + 'start-atomic/no-interrupts start-atomic/no-interrupts + 'end-atomic/no-interrupts end-atomic/no-interrupts + 'current-custodian current-custodian + 'unsafe-custodian-register unsafe-custodian-register + 'unsafe-custodian-unregister unsafe-custodian-unregister + 'thread-push-kill-callback! thread-push-kill-callback! + 'thread-pop-kill-callback! thread-pop-kill-callback! + 'set-get-subprocesses-time! set-get-subprocesses-time!)) diff --git a/racket/src/thread/internal-error.rkt b/racket/src/thread/internal-error.rkt new file mode 100644 index 0000000000..e9ec0c7342 --- /dev/null +++ b/racket/src/thread/internal-error.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(provide internal-error) + +(define (internal-error s) + (raise (exn:fail (string-append "internal error: " s) + (current-continuation-marks)))) diff --git a/racket/src/thread/lock.rkt b/racket/src/thread/lock.rkt new file mode 100644 index 0000000000..0d0bde0653 --- /dev/null +++ b/racket/src/thread/lock.rkt @@ -0,0 +1,52 @@ +#lang racket/base + +(require "internal-error.rkt") + +(provide with-lock + make-lock + lock-acquire + lock-release + own-lock?) + +(define-syntax-rule (with-lock (lock caller) expr ...) + (begin + (lock-acquire lock caller) + (begin0 + (let () expr ...) + (lock-release lock caller)))) + +(struct future-lock* (box owner)) + +(define (lock-owner lock) + (unbox (future-lock*-owner lock))) + +(define (make-lock) + (future-lock* (box 0) (box #f))) + +(define (lock-acquire lock caller [block? #t]) + (define box (future-lock*-box lock)) + (let loop () + (cond + [(and (= 0 (unbox box)) (box-cas! box 0 1)) ;; got lock + (unless (box-cas! (future-lock*-owner lock) #f caller) + (internal-error "Lock already has owner.")) + #t] + [block? + (loop)] + [else + #f]))) + +(define (lock-release lock caller) + (when (eq? caller (unbox (future-lock*-owner lock))) + (unless (box-cas! (future-lock*-owner lock) caller #f) + (internal-error "Failed to reset owner\n")) + (unless (box-cas! (future-lock*-box lock) 1 0) + (internal-error "Lock release failed\n")))) + +(define (own-lock? lock caller) + (and (eq? caller (unbox (future-lock*-owner lock))) + (begin0 + #t + (unless (= 1 (unbox (future-lock*-box lock))) + (internal-error "Caller 'owns' lock but lock is free."))))) + diff --git a/racket/src/thread/main.rkt b/racket/src/thread/main.rkt new file mode 100644 index 0000000000..db8cd4f6fc --- /dev/null +++ b/racket/src/thread/main.rkt @@ -0,0 +1,188 @@ +#lang racket/base +(require "thread.rkt" + "thread-group.rkt" + (only-in "evt.rkt" + evt? prop:evt + always-evt + never-evt) + "impersonator.rkt" + (except-in "semaphore.rkt" + semaphore-peek-evt) + "channel.rkt" + "sync.rkt" + "system-idle-evt.rkt" + "schedule.rkt" + "custodian.rkt" + "alarm.rkt" + "nested-thread.rkt" + "continuation-mark.rkt" + "api.rkt" + "will-executor.rkt" + "exit.rkt" + "plumber.rkt" + "unsafe.rkt" + "instance.rkt" + "time.rkt" + "stats.rkt" + "stack-size.rkt" + "future.rkt" + "fsemaphore.rkt" + "os-thread.rkt") + +(provide call-in-main-thread + + thread + thread/suspend-to-kill + call-in-nested-thread + thread? + current-thread + thread-running? + thread-dead? + thread-wait + thread-suspend + thread-resume + thread-suspend-evt + thread-resume-evt + thread-dead-evt + thread-dead-evt? + break-thread + kill-thread + thread-send + thread-receive + thread-try-receive + thread-rewind-receive + thread-receive-evt + + sleep + + make-thread-group + thread-group? + current-thread-group + + make-semaphore + semaphore-post + semaphore-wait + semaphore-try-wait? + semaphore? + semaphore-wait/enable-break + call-with-semaphore + call-with-semaphore/enable-break + + semaphore-peek-evt + semaphore-peek-evt? + + make-channel + channel? + channel-put + channel-get + channel-put-evt + channel-put-evt? + + sync + sync/timeout + sync/enable-break + sync/timeout/enable-break + current-evt-pseudo-random-generator + + evt? prop:evt + always-evt + never-evt + wrap-evt + handle-evt + handle-evt? + guard-evt + poll-guard-evt + nack-guard-evt + choice-evt + replace-evt + + chaperone-evt + chaperone-channel + impersonate-channel + + system-idle-evt + alarm-evt + + current-custodian + make-custodian + custodian? + custodian-shutdown-all + custodian-managed-list + make-custodian-box + custodian-box? + custodian-box-value + custodian-memory-accounting-available? + custodian-require-memory + custodian-limit-memory + custodian-shut-down? + + make-will-executor + make-stubborn-will-executor + will-executor? + will-register + will-try-execute + will-execute + + exit + exit-handler + + current-plumber + make-plumber + plumber? + plumber-flush-all + plumber-add-flush! + plumber-flush-handle? + plumber-flush-handle-remove! + + current-process-milliseconds + vector-set-performance-stats! + + current-thread-initial-stack-size + + break-enabled + check-for-break + break-enabled-key + + continuation-marks + + unsafe-start-atomic + unsafe-end-atomic + unsafe-start-breakable-atomic + unsafe-end-breakable-atomic + unsafe-in-atomic? + unsafe-set-on-atomic-timeout! + + unsafe-thread-at-root + unsafe-make-custodian-at-root + unsafe-custodian-register + unsafe-custodian-unregister + + futures-enabled? + processor-count + future + future? + touch + would-be-future + current-future + future-block + future-wait + current-future-prompt + reset-future-logs-for-tracing! + mark-future-trace-end! + + fsemaphore? + make-fsemaphore + fsemaphore-post + fsemaphore-wait + fsemaphore-try-wait? + fsemaphore-count + + unsafe-os-thread-enabled? + unsafe-call-in-os-thread + unsafe-make-os-semaphore + unsafe-os-semaphore-post + unsafe-os-semaphore-wait + + #%thread-instance) + +(module main racket/base) diff --git a/racket/src/thread/nested-thread.rkt b/racket/src/thread/nested-thread.rkt new file mode 100644 index 0000000000..1f2bc244e6 --- /dev/null +++ b/racket/src/thread/nested-thread.rkt @@ -0,0 +1,103 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "engine.rkt" + "thread.rkt" + (except-in (submod "thread.rkt" scheduling) + thread + thread-dead-evt) + "custodian.rkt" + "semaphore.rkt") + +(provide call-in-nested-thread) + +(define/who (call-in-nested-thread thunk [cust (current-custodian)]) + (check who (procedure-arity-includes/c 0) thunk) + (check who custodian? cust) + (define init-break-cell (current-break-enabled-cell)) + (define result #f) + (define result-kind #f) + (define ready-sema (make-semaphore)) + (define t + ;; Disable breaks while we set up the thread + (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (do-make-thread + 'call-in-nested-thread + (lambda () + (semaphore-wait ready-sema) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (set! result-kind 'exn) + (set! result x))]) + (with-continuation-mark + break-enabled-key + init-break-cell + (begin + ;; Breaks can only happen here, and kills + ;; can only happen after here + (set! result (call-with-continuation-barrier + (lambda () + (call-with-values (lambda () + (call-with-continuation-prompt + thunk + (default-continuation-prompt-tag) + (lambda (thunk) + (abort-current-continuation + (default-continuation-prompt-tag) + thunk)))) + list)))) + ;; Atomically decide that we have a value result and + ;; terminate the thread, so that there's not a race between + ;; detecting that the thread was killed versus deciding + ;; that the thread completed with a value + (atomically + (set! result-kind 'value) + (thread-dead! t)) + (engine-block))))) + #:custodian cust))) + (atomically + (set-thread-forward-break-to! (current-thread) t)) + (semaphore-post ready-sema) ; let the nested thread run + + ;; Wait for the nested thread to complete -- and any thread nested + ;; in that one at the time that it finished, and so on + (define pending-break + (let loop ([t t] [pending-break #f]) + (thread-wait t) + (define next-pending-break (break-max pending-break (thread-pending-break t))) + (let ([sub-t (thread-forward-break-to t)]) + (cond + [sub-t (loop sub-t next-pending-break)] + [else next-pending-break])))) + + ;; At this point, if `result-kind` is #f, then `t` was + ;; killed or aborted to the original continuation + + (atomically + (set-thread-forward-break-to! (current-thread) #f)) + + ;; Propagate any leftover break, but give a propagated + ;; exception priority over a break exception: + (with-continuation-mark + break-enabled-key + (make-thread-cell #f) + (begin + + (when pending-break + ;; Breaks are disabled at this point, so the break won't be + ;; signaled until `check-for-break` below + (break-thread (current-thread) (if (eq? pending-break 'break) #f pending-break))) + + (when (eq? result-kind 'exn) + (raise result)) + + (unless (eq? result-kind 'value) + (raise + (exn:fail + "call-in-nested-thread: the thread was killed, or it exited via the default error escape handler" + (current-continuation-marks)))))) + + (check-for-break) + (apply values result)) diff --git a/racket/src/thread/os-thread.rkt b/racket/src/thread/os-thread.rkt new file mode 100644 index 0000000000..d43f76b337 --- /dev/null +++ b/racket/src/thread/os-thread.rkt @@ -0,0 +1,56 @@ +#lang racket/base +(require "check.rkt" + "engine.rkt" + "atomic.rkt") + +(provide unsafe-os-thread-enabled? + unsafe-call-in-os-thread + unsafe-make-os-semaphore + unsafe-os-semaphore-post + unsafe-os-semaphore-wait) + +(define (unsafe-os-thread-enabled?) + (threaded?)) + +(define/who (unsafe-call-in-os-thread proc) + (check who (procedure-arity-includes/c 0) proc) + (unless threaded? (raise-unsupported who)) + (fork-pthread (lambda () + (start-atomic) ; just in case + (proc))) + (void)) + +(struct os-semaphore ([count #:mutable] mutex condition)) + +(define/who (unsafe-make-os-semaphore) + (unless threaded? (raise-unsupported who)) + (os-semaphore 0 (chez:make-mutex) (chez:make-condition))) + +(define/who (unsafe-os-semaphore-post s) + (check who os-semaphore? s) + (chez:mutex-acquire (os-semaphore-mutex s)) + (when (zero? (os-semaphore-count s)) + (chez:condition-signal (os-semaphore-condition s))) + (set-os-semaphore-count! s (add1 (os-semaphore-count s))) + (chez:mutex-release (os-semaphore-mutex s))) + +;; interrupts must be enabled when waiting on a semaphore; otherwise, +;; the wait will block GCs, likely deadlocking this thread and another +;; thread that is working toward posting the semaphore +(define/who (unsafe-os-semaphore-wait s) + (check who os-semaphore? s) + (chez:mutex-acquire (os-semaphore-mutex s)) + (let loop () + (cond + [(zero? (os-semaphore-count s)) + (chez:condition-wait (os-semaphore-condition s) (os-semaphore-mutex s)) + (loop)] + [else + (set-os-semaphore-count! s (sub1 (os-semaphore-count s)))])) + (chez:mutex-release (os-semaphore-mutex s))) + +(define (raise-unsupported who) + (raise + (exn:fail:unsupported + (string-append (symbol->string who) ": unsupported on this platform") + (current-continuation-marks)))) diff --git a/racket/src/thread/parameter.rkt b/racket/src/thread/parameter.rkt new file mode 100644 index 0000000000..5a8b235fec --- /dev/null +++ b/racket/src/thread/parameter.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "engine.rkt") + +(provide current-thread) + +(define current-thread (make-pthread-parameter #f)) diff --git a/racket/src/thread/plumber.rkt b/racket/src/thread/plumber.rkt new file mode 100644 index 0000000000..74cd85adbc --- /dev/null +++ b/racket/src/thread/plumber.rkt @@ -0,0 +1,50 @@ +#lang racket/base +(require "check.rkt") + +(provide current-plumber + make-plumber + plumber? + plumber-flush-all + plumber-add-flush! + plumber-flush-handle? + plumber-flush-handle-remove!) + +(struct plumber (callbacks ; hash table of handles -> callbacks + weak-callbacks) ; same, but weak references + #:property prop:authentic #t) + +(define (make-plumber) + (plumber (make-hasheq) + (make-weak-hasheq))) + +(define/who current-plumber + (make-parameter (make-plumber) + (lambda (v) + (check who plumber? v) + v))) + +(struct plumber-flush-handle (plumber)) + +(define/who (plumber-add-flush! p proc [weak? #f]) + (check who plumber? p) + (check who (procedure-arity-includes/c 1) proc) + (define h (plumber-flush-handle p)) + (hash-set! (if weak? + (plumber-weak-callbacks p) + (plumber-callbacks p)) + h + proc) + h) + +(define/who (plumber-flush-all p) + (check who plumber? p) + (for ([(h proc) (in-hash (plumber-callbacks p))]) + (proc h)) + (for ([(h proc) (in-hash (plumber-weak-callbacks p))]) + (proc h))) + +(define/who (plumber-flush-handle-remove! h) + (check who plumber-flush-handle? h) + (define p (plumber-flush-handle-plumber h)) + (hash-remove! (plumber-callbacks p) h) + (hash-remove! (plumber-weak-callbacks p) h)) diff --git a/racket/src/thread/sandman-struct.rkt b/racket/src/thread/sandman-struct.rkt new file mode 100644 index 0000000000..4c7e67f8fc --- /dev/null +++ b/racket/src/thread/sandman-struct.rkt @@ -0,0 +1,39 @@ +#lang racket/base + +;; In addition to its use from "sandman.rkt", this module is meant to +;; be used by a layer above the "thread" implementation, such as the +;; "io" layer. + +;; See also "sandman.rkt". + +(provide (struct-out sandman)) + +;; A `sandman` implements several methods, and the sandman implementation +;; gets to pick the representation of and , except +;; that #f is the "empty" external event set and #f cannot be a . +(struct sandman (do-sleep ; -> (void), uses plus registered threads + do-poll ; (thread -> any) -> (void), calls function on any thread to wake up + ; where is 'fast or 'slow + + do-any-sleepers? ; -> boolean + do-sleepers-external-events ; -> for sleepers + + do-add-thread! ; -> + do-remove-thread! ; -> (void) + + do-merge-external-event-sets ; -> + + do-merge-timeout ; -> + do-extract-timeout ; -> + + do-condition-wait ; set a thread to wait on a condition + + do-condition-poll ; reschedule awoken threads + + do-any-waiters? ; -> boolean + + lock + + #;...) ; sandman implementations can add more methods + + #:prefab) diff --git a/racket/src/thread/sandman.rkt b/racket/src/thread/sandman.rkt new file mode 100644 index 0000000000..07a75f58d9 --- /dev/null +++ b/racket/src/thread/sandman.rkt @@ -0,0 +1,218 @@ +#lang racket/base +(require "check.rkt" + "tree.rkt" + "internal-error.rkt" + "sandman-struct.rkt") + +;; A "sandman" manages the set of all sleeping threads that may need +;; to be awoken in response to an external event, and it implements +;; the process-wide `sleep` that waits for an external event. Timeouts +;; are the only external events recognized by the initial sandman, +;; and that is supported by the host system's `sleep` function. + +;; When a thread is registered with a sandman, the sandman provides a +;; handle representing the registration. The handle can be any value +;; except #f, and it is provided back to the sandman to unregister a +;; thread. A sandman doesn't unregister threads on its own, even when +;; it detects that an external event has happened. + +;; When `sync` determines that a thread should sleep, it accumulates +;; external-event specifications to provide to the sandman along with +;; the thread. For the initial sandman, this information is just a +;; maximum wake-up time, but a more sophisticated sandman might +;; support file-descriptor activity. Event implementations expect a +;; sandman that provides specific functionality, so all sandman +;; implementations need to support time. + +;; All sandman functions are called in atomic mode. + +;; See also "sandman-struct.rkt". + +(provide sandman-merge-timeout + sandman-merge-exts + sandman-add-sleeping-thread! + sandman-remove-sleeping-thread! + sandman-poll + sandman-sleep + sandman-any-sleepers? + sandman-sleepers-external-events + sandman-condition-wait + sandman-condition-poll + sandman-any-waiters? + + current-sandman) + +;; in atomic mode +(define (sandman-merge-timeout exts timeout) + ((sandman-do-merge-timeout the-sandman) exts timeout)) + +;; in atomic mode +(define (sandman-merge-exts a-exts b-exts) + ((sandman-do-merge-external-event-sets the-sandman) a-exts b-exts)) + +;; in atomic mode +(define (sandman-add-sleeping-thread! th exts) + ((sandman-do-add-thread! the-sandman) th exts)) + +;; in atomic mode +(define (sandman-remove-sleeping-thread! th h) + ((sandman-do-remove-thread! the-sandman) th h)) + +;; in atomic mode +(define (sandman-poll mode thread-wakeup) + ((sandman-do-poll the-sandman) mode thread-wakeup)) + +;; in atomic mode +(define (sandman-sleep exts) + ((sandman-do-sleep the-sandman) exts)) + +;; in atomic mode +(define (sandman-any-sleepers?) + ((sandman-do-any-sleepers? the-sandman))) + +;; in atomic mode +(define (sandman-sleepers-external-events) + ((sandman-do-sleepers-external-events the-sandman))) + +;; in atomic mode +(define (sandman-condition-wait thread) + ((sandman-do-condition-wait the-sandman) thread)) + +;; in atomic mode +(define (sandman-condition-poll mode thread-wakeup) + ((sandman-do-condition-poll the-sandman) mode thread-wakeup)) + +;; in atomic mode +(define (sandman-any-waiters?) + ((sandman-do-any-waiters? the-sandman))) + +;; in atomic mode +(define/who current-sandman + (case-lambda + [() the-sandman] + [(sm) + (check who sandman? sm) + (set! the-sandman sm)])) + +;; created simple lock here to avoid cycle in loading from using lock defined in future.rkt +(define (make-lock) + (box 0)) + +(define (lock-acquire box) + (let loop () + (unless (and (= 0 (unbox box)) (box-cas! box 0 1)) + (loop)))) + +(define (lock-release box) + (unless (box-cas! box 1 0) + (internal-error "Failed to release lock\n"))) + +(define waiting-threads '()) +(define awoken-threads '()) + +;; ---------------------------------------- +;; Default sandman implementation + +;; A tree mapping times (in milliseconds) to a hash table of threads +;; to wake up at that time +(define sleeping-threads empty-tree) + +(define (min* a-sleep-until b-sleep-until) + (if (and a-sleep-until b-sleep-until) + (min a-sleep-until b-sleep-until) + (or a-sleep-until b-sleep-until))) + +(define the-sandman + (sandman + ;; sleep + (lambda (timeout-at) + (sleep (/ (- (or timeout-at (distant-future)) (current-inexact-milliseconds)) 1000.0))) + + ;; poll + (lambda (mode wakeup) + ;; This check is fast, so do it in all modes + (unless (tree-empty? sleeping-threads) + (define-values (timeout-at threads) (tree-min sleeping-threads)) + (when (timeout-at . <= . (current-inexact-milliseconds)) + (unless (null? threads) + (for ([t (in-hash-keys threads)]) + (wakeup t)))))) + + ;; any-sleepers? + (lambda () + (not (tree-empty? sleeping-threads))) + + ;; sleepers-external-events + (lambda () + (and (not (tree-empty? sleeping-threads)) + (let-values ([(timeout-at threads) (tree-min sleeping-threads)]) + timeout-at))) + + ;; add-thread! + (lambda (t sleep-until) + (set! sleeping-threads + (tree-set sleeping-threads + sleep-until + (hash-set (or (tree-ref sleeping-threads sleep-until <) + #hasheq()) + t + #t) + <)) + sleep-until) + ;; remove-thread! + (lambda (t sleep-until) + (define threads (tree-ref sleeping-threads sleep-until <)) + (unless threads (internal-error "thread not found among sleeping threads")) + (define new-threads (hash-remove threads t)) + (set! sleeping-threads + (if (zero? (hash-count new-threads)) + (tree-remove sleeping-threads sleep-until <) + (tree-set sleeping-threads sleep-until new-threads <)))) + + ;; merge-exts + (lambda (a-sleep-until b-sleep-until) + (min* a-sleep-until b-sleep-until)) + + ;; merge-timeout + (lambda (sleep-until timeout-at) + (if sleep-until + (min sleep-until timeout-at) + timeout-at)) + ;; extract-timeout + (lambda (sleep-until) sleep-until) + + ;; condition-wait + (lambda (t) + (lock-acquire (sandman-lock the-sandman)) + (set! waiting-threads (cons t waiting-threads)) + (lock-release (sandman-lock the-sandman)) + ;; awoken callback. for when thread is awoken + (lambda (root-thread) + (lock-acquire (sandman-lock the-sandman)) + (if (memq t waiting-threads) + (begin + (set! waiting-threads (remove t waiting-threads eq?)) + (set! awoken-threads (cons t awoken-threads))) + (internal-error "thread is not a member of waiting-threads\n")) + (lock-release (sandman-lock the-sandman)))) + + ;; condition-poll + (lambda (mode wakeup) + (lock-acquire (sandman-lock the-sandman)) + (define at awoken-threads) + (set! awoken-threads '()) + (lock-release (sandman-lock the-sandman)) + (for-each (lambda (t) + (wakeup t)) at)) + + ;; any waiters? + (lambda () + (or (not (null? waiting-threads)) (not (null? awoken-threads)))) + + (make-lock))) + + +;; Compute an approximation to infinity: +(define (distant-future) + (+ (current-inexact-milliseconds) + (* 1000.0 60 60 24 365))) diff --git a/racket/src/thread/schedule-info.rkt b/racket/src/thread/schedule-info.rkt new file mode 100644 index 0000000000..459f877f0f --- /dev/null +++ b/racket/src/thread/schedule-info.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require "sandman.rkt") + +(provide make-schedule-info + + schedule-info-did-work? + schedule-info-exts + + schedule-info-current-exts + schedule-info-add-timeout-at! + schedule-info-did-work!) + +;; A `schedule-info` record allows an event poller to communicate +;; extra information to the scheduler when an even is not ready. + +(struct schedule-info (did-work? + exts) ; for the sandman + #:mutable) + +(define (make-schedule-info #:did-work? [did-work? #t]) + (schedule-info did-work? + #f)) + +(define schedule-info-current-exts + (case-lambda + [(sched-info) (schedule-info-exts sched-info)] + [(sched-info exts) (set-schedule-info-exts! sched-info exts)])) + +(define (schedule-info-add-timeout-at! sched-info timeout-at) + (define exts (schedule-info-exts sched-info)) + (set-schedule-info-exts! sched-info + (sandman-merge-timeout exts timeout-at))) + +(define (schedule-info-did-work! sched-info) + (set-schedule-info-did-work?! sched-info #t)) diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt new file mode 100644 index 0000000000..e48fd0c411 --- /dev/null +++ b/racket/src/thread/schedule.rkt @@ -0,0 +1,212 @@ +#lang racket/base +(require "atomic.rkt" + "engine.rkt" + "internal-error.rkt" + "sandman.rkt" + "parameter.rkt" + "thread-group.rkt" + "schedule-info.rkt" + (submod "thread.rkt" scheduling) + "system-idle-evt.rkt" + "exit.rkt" + "future.rkt") + +;; Many scheduler details are implemented in "thread.rkt", but this +;; module handles the thread selection, thread swapping, and +;; process sleeping. + +(provide call-in-main-thread + set-atomic-timeout-callback!) + +(define TICKS 100000) + +(define process-milliseconds 0) + +;; Initializes the thread system: +(define (call-in-main-thread thunk) + (make-initial-thread thunk) + (select-thread!)) + +;; ---------------------------------------- + +(define (select-thread! [pending-callbacks null]) + (let loop ([g root-thread-group] [pending-callbacks pending-callbacks] [none-k maybe-done]) + (define callbacks (if (null? pending-callbacks) + (host:poll-async-callbacks) + pending-callbacks)) + (host:poll-will-executors) + (check-external-events 'fast) + (when (and (null? callbacks) + (all-threads-poll-done?) + (waiting-on-external-or-idle?)) + (or (check-external-events 'slow) + (post-idle) + (process-sleep))) + (define child (thread-group-next! g)) + (cond + [(not child) (none-k callbacks)] + [(thread? child) + (swap-in-thread child callbacks)] + [else + (loop child callbacks (lambda (pending-callbacks) (loop g none-k pending-callbacks)))]))) + +(define (swap-in-thread t callbacks) + (define e (thread-engine t)) + (set-thread-engine! t 'running) + (set-thread-sched-info! t #f) + (current-thread t) + (run-callbacks-in-engine + e callbacks + (lambda (e) + (let loop ([e e]) + (end-implicit-atomic-mode) + (e + TICKS + (lambda () + (check-for-break) + (when atomic-timeout-callback + (when (positive? (current-atomic)) + (atomic-timeout-callback)))) + (lambda args + (start-implicit-atomic-mode) + (accum-cpu-time! t) + (current-thread #f) + (unless (zero? (current-atomic)) + (internal-error "terminated in atomic mode!")) + (thread-dead! t) + (when (eq? root-thread t) + (force-exit 0)) + (thread-did-work!) + (select-thread!)) + (lambda (e) + (start-implicit-atomic-mode) + (cond + [(zero? (current-atomic)) + (accum-cpu-time! t) + (current-thread #f) + (unless (eq? (thread-engine t) 'done) + (set-thread-engine! t e)) + (select-thread!)] + [else + ;; Swap out when the atomic region ends: + (set-end-atomic-callback! engine-block) + (loop e)]))))))) + +(define (maybe-done callbacks) + (cond + [(pair? callbacks) + ;; We have callbacks to run and no thread willing + ;; to run them. Make a new thread. + (do-make-thread 'scheduler-make-thread + void + #:custodian #f) + (select-thread! callbacks)] + [(and (not (sandman-any-sleepers?)) + (not (sandman-any-waiters?)) + (not (any-idle-waiters?))) + ;; all threads done or blocked + (cond + [(thread-running? root-thread) + ;; we shouldn't exit, because the main thread is + ;; blocked, but it's not going to become unblocked; + ;; sleep forever or until a signal changes things + (process-sleep) + (select-thread!)] + [else + (void)])] + [else + ;; try again, which should lead to `process-sleep` + (select-thread!)])) + +;; Check for threads that have been suspended until a particular time, +;; etc., as registered with the sandman +(define (check-external-events mode) + (define did? #f) + (sandman-poll mode + (lambda (t) + (thread-reschedule! t) + (set! did? #t))) + (sandman-condition-poll mode + (lambda (t) + (thread-reschedule! t) + (set! did? #t))) + (when did? + (thread-did-work!)) + did?) + +;; Run callbacks within the thread for `e`, and don't give up until +;; the callbacks are done +(define (run-callbacks-in-engine e callbacks k) + (cond + [(null? callbacks) (k e)] + [else + (define done? #f) + (let loop ([e e]) + (end-implicit-atomic-mode) + (e + TICKS + (lambda () + (run-callbacks callbacks) + (set! done? #t) + (engine-block)) + (lambda args + (internal-error "thread ended while it should run callbacks atomically")) + (lambda (e) + (start-implicit-atomic-mode) + (if done? + (k e) + (loop e)))))])) + +;; Run foreign "async-apply" callbacks, now that we're in some thread +(define (run-callbacks callbacks) + (start-atomic) + (current-break-suspend (add1 (current-break-suspend))) + (for ([callback (in-list callbacks)]) + (callback)) + (current-break-suspend (sub1 (current-break-suspend))) + (end-atomic)) + +;; ---------------------------------------- + +;; Have we tried all threads without since most recently making +;; progress on some thread? +(define (all-threads-poll-done?) + (= (hash-count poll-done-threads) + num-threads-in-groups)) + +(define (waiting-on-external-or-idle?) + (or (positive? num-threads-in-groups) + (sandman-any-sleepers?) + (any-idle-waiters?))) + +;; Stop using the CPU for a while +(define (process-sleep) + (define ts (thread-group-all-threads root-thread-group null)) + (define sleeping-exts + (sandman-sleepers-external-events)) + (define exts + (for/fold ([exts sleeping-exts]) ([t (in-list ts)]) + (define sched-info (thread-sched-info t)) + (define t-exts (and sched-info + (schedule-info-exts sched-info))) + (sandman-merge-exts exts t-exts))) + (sandman-sleep exts) + ;; Maybe some thread can proceed: + (thread-did-work!)) + +;; ---------------------------------------- + +(define (accum-cpu-time! t) + (define start process-milliseconds) + (set! process-milliseconds (current-process-milliseconds)) + (set-thread-cpu-time! t (+ (thread-cpu-time t) + (- process-milliseconds start)))) + +;; ---------------------------------------- + +(define atomic-timeout-callback #f) + +(define (set-atomic-timeout-callback! cb) + (begin0 + atomic-timeout-callback + (set! atomic-timeout-callback cb))) diff --git a/racket/src/thread/semaphore.rkt b/racket/src/thread/semaphore.rkt new file mode 100644 index 0000000000..e6aba6c0cf --- /dev/null +++ b/racket/src/thread/semaphore.rkt @@ -0,0 +1,173 @@ +#lang racket/base +(require "check.rkt" + "../common/queue.rkt" + "internal-error.rkt" + "atomic.rkt" + "parameter.rkt" + "waiter.rkt" + "evt.rkt") + +(provide make-semaphore + semaphore? + semaphore-post + semaphore-post-all + semaphore-wait + semaphore-try-wait? + + semaphore-peek-evt + semaphore-peek-evt? + + semaphore-any-waiters? + + semaphore-post/atomic + semaphore-wait/atomic) + +(struct semaphore ([count #:mutable] + queue) + #:property + prop:evt + (poller (lambda (s poll-ctx) + (semaphore-wait/poll s poll-ctx)))) + +(struct semaphore-peek-evt (sema) + #:property + prop:evt + (poller (lambda (sp poll-ctx) + (semaphore-wait/poll (semaphore-peek-evt-sema sp) + poll-ctx + #:peek? #t + #:result sp)))) + +(struct semaphore-peek-select-waiter select-waiter ()) + +(define/who (make-semaphore [init 0]) + (check who exact-nonnegative-integer? init) + (unless (fixnum? init) + (raise + (exn:fail (string-append + "make-semaphore: starting value " + (number->string init) + " is too large") + (current-continuation-marks)))) + (semaphore init (make-queue))) + +;; ---------------------------------------- + +(define/who (semaphore-post s) + (check who semaphore? s) + (atomically (semaphore-post/atomic s))) + +;; In atomic mode: +(define (semaphore-post/atomic s) + (assert-atomic-mode) + (let loop () + (define w (queue-remove! (semaphore-queue s))) + (cond + [(not w) + (set-semaphore-count! s (add1 (semaphore-count s)))] + [else + (waiter-resume! w s) + (when (semaphore-peek-select-waiter? w) + ;; Don't consume a post for a peek waiter + (loop))]))) + +(define (semaphore-post-all s) + (atomically + (set-semaphore-count! s +inf.0) + (queue-remove-all! + (semaphore-queue s) + (lambda (w) (waiter-resume! w s))))) + +;; In atomic mode: +(define (semaphore-any-waiters? s) + (assert-atomic-mode) + (not (queue-empty? (semaphore-queue s)))) + +;; ---------------------------------------- + +(define/who (semaphore-try-wait? s) + (check who semaphore? s) + (atomically + (define c (semaphore-count s)) + (cond + [(positive? c) + (set-semaphore-count! s (sub1 c)) + #t] + [else #f]))) + +(define/who (semaphore-wait s) + (check who semaphore? s) + ((atomically + (define c (semaphore-count s)) + (cond + [(positive? c) + (set-semaphore-count! s (sub1 c)) + void] + [else + (define w (current-thread)) + (define q (semaphore-queue s)) + (define n (queue-add! q w)) + (waiter-suspend! + w + ;; On break/kill/suspend: + (lambda () (queue-remove-node! q n)) + ;; This callback is used, in addition to the previous one, if + ;; the thread receives a break signal but doesn't escape + ;; (either because breaks are disabled or the handler + ;; continues), if if the interrupt was to suspend and the thread + ;; is resumed: + (lambda () (semaphore-wait s)))])))) + +;; In atomic mode +(define (semaphore-wait/poll s poll-ctx + #:peek? [peek? #f] + #:result [result s]) + ;; Similar to `semaphore-wait, but as called by `sync`, + ;; so use a select waiter instead of the current thread + (assert-atomic-mode) + (define c (semaphore-count s)) + (cond + [(positive? c) + (unless peek? + (set-semaphore-count! s (sub1 c))) + (values (list result) #f)] + [(poll-ctx-poll? poll-ctx) + (values #f never-evt)] + [else + (define w (if peek? + (semaphore-peek-select-waiter (poll-ctx-select-proc poll-ctx)) + (select-waiter (poll-ctx-select-proc poll-ctx)))) + (define q (semaphore-queue s)) + (define n (queue-add! q w)) + ;; Replace with `async-evt`, but the `sema-waiter` can select the + ;; event through a callback. Pair the event with a nack callback + ;; to get back out of line. + (values #f + (wrap-evt + (control-state-evt async-evt + (lambda () + (assert-atomic-mode) + (queue-remove-node! q n)) + void + (lambda () + ;; Retry: decrement or requeue + (assert-atomic-mode) + (define c (semaphore-count s)) + (cond + [(positive? c) + (unless peek? + (set-semaphore-count! s (sub1 c))) + (values result #t)] + [else + (set! n (queue-add! q w)) + (values #f #f)]))) + (lambda (v) result)))])) + +;; Called only when it should immediately succeed: +(define (semaphore-wait/atomic s) + (define c (semaphore-count s)) + (cond + [(positive? c) + (set-semaphore-count! s (sub1 c))] + [else + (internal-error "semaphore-wait/atomic: cannot decrement semaphore")])) diff --git a/racket/src/thread/stack-size.rkt b/racket/src/thread/stack-size.rkt new file mode 100644 index 0000000000..730b75cafc --- /dev/null +++ b/racket/src/thread/stack-size.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require "check.rkt") + +(provide current-thread-initial-stack-size) + +;; This parameter doesn't do anything, but it's provided +;; here for compatibility +(define/who current-thread-initial-stack-size + (make-parameter 64 + (lambda (v) + (check who exact-positive-integer? v) + v))) diff --git a/racket/src/thread/stats.rkt b/racket/src/thread/stats.rkt new file mode 100644 index 0000000000..d30db41714 --- /dev/null +++ b/racket/src/thread/stats.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require "check.rkt" + "thread.rkt" + "time.rkt") + +(provide vector-set-performance-stats!) + +(define/who (vector-set-performance-stats! vec [thd #f]) + (check who (lambda (v) (and (vector? v) (not (immutable? v)))) + #:contract "(and/c vector? (not/c immutable?))" + vec) + (check who thread? #:or-false thd) + (define (maybe-set! i v) + (when (< i (vector-length vec)) + (vector-set! vec i v))) + (cond + [(not thd) + (maybe-set! 0 (current-process-milliseconds)) + (maybe-set! 1 (current-milliseconds)) + (maybe-set! 2 (current-gc-milliseconds)) + (maybe-set! 3 0) ; # of GCs + (maybe-set! 4 0) ; # of thread switches + (maybe-set! 5 0) ; # of stack overflows + (maybe-set! 6 0) ; # of threads scheduled for running + (maybe-set! 7 0) ; # of syntax objects read + (maybe-set! 8 0) ; # of hash table searches + (maybe-set! 9 0) ; # of hash table collisions + (maybe-set! 10 0) ; non-GCed memory allocated for machine code + (maybe-set! 11 0) ; peak memory use before a GC + (void)] + [else + (maybe-set! 0 (thread-running? thd)) + (maybe-set! 1 (thread-dead? thd)) + (maybe-set! 2 #f) ; blocked for synchronization? + (maybe-set! 3 #f) ; continuation size in bytes + (void)])) diff --git a/racket/src/thread/sync.rkt b/racket/src/thread/sync.rkt new file mode 100644 index 0000000000..97304bb420 --- /dev/null +++ b/racket/src/thread/sync.rkt @@ -0,0 +1,639 @@ +#lang racket/base +(require "check.rkt" + "internal-error.rkt" + "evt.rkt" + "atomic.rkt" + "semaphore.rkt" + "channel.rkt" + (submod "channel.rkt" for-sync) + "thread.rkt" + (only-in (submod "thread.rkt" scheduling) + current-break-enabled-cell + thread-descheduled?) + "schedule-info.rkt") + +(provide sync + sync/timeout + sync/enable-break + sync/timeout/enable-break + sync-atomic-poll-evt? + current-evt-pseudo-random-generator + replace-evt) + +(struct syncing (selected ; #f or a syncer that has been selected + syncers ; linked list of `syncer`s + wakeup ; a callback for when something is selected + disable-break ; #f or a thunk that disables breaks + need-retry?) ; queued trigger to `syncing-retry!` + #:mutable) + +(struct syncer (evt ; the evt to sync; can get updated in sync loop + wraps ; list of wraps to apply if selected + commits ; list of thunks to run atomically when selected + interrupted? ; kill/break in progress? + interrupts ; list of thunks to run on kill/break initiation + abandons ; list of thunks to run on kill/break completion + retries ; list of thunks to run on retry: returns `(values _val _ready?)` + prev ; previous in linked list + next) ; next in linked list + #:transparent + #:mutable) + +(define (make-syncer evt wraps) + (syncer evt wraps null #f null null null #f #f)) + +(define none-syncer (make-syncer #f null)) + +(define (make-syncing syncers #:disable-break [disable-break #f]) + (syncing #f ; selected + syncers + void ; wakeup + disable-break + #f)) + +;; To support `port-commit-peeked`, the `sync/timeout` function should +;; work for polling in atomic mode for a set of constrained event +;; types: +(define (sync-atomic-poll-evt? evt) + (or (channel-put-evt? evt) + (channel? evt) + (semaphore? evt) + (semaphore-peek-evt? evt) + (eq? always-evt evt) + (eq? never-evt evt))) + +(define (do-sync who timeout args + #:enable-break? [enable-break? #f]) + (check who + (lambda (timeout) (or (not timeout) + (and (real? timeout) (timeout . >= . 0)) + (and (procedure? timeout) + (procedure-arity-includes? timeout 0)))) + #:contract "(or/c #f (and/c real? (not/c negative?)) (-> any))" + timeout) + + (define local-break-cell (and enable-break? + (make-thread-cell #t))) + + (define syncers (evts->syncers who args)) + (define s (make-syncing syncers + #:disable-break + (and local-break-cell + (let ([t (current-thread)]) + (lambda () + (thread-ignore-break-cell! t local-break-cell)))))) + + (define (go) + (dynamic-wind + (lambda () + (atomically + (thread-push-kill-callback! + (lambda () (syncing-abandon! s))) + (thread-push-suspend+resume-callbacks! + (lambda () (syncing-interrupt! s)) + (lambda () (syncing-queue-retry! s))))) + (lambda () + (when enable-break? (check-for-break)) + (cond + [(or (and (real? timeout) (zero? timeout)) + (procedure? timeout)) + (let poll-loop () + (sync-poll s #:fail-k (lambda (sched-info polled-all?) + (cond + [(not polled-all?) + (poll-loop)] + [(procedure? timeout) + timeout] + [else + (lambda () #f)])) + #:just-poll? #t))] + [else + ;; Loop to poll; if all events end up with asynchronous-select + ;; callbacks, then the loop can suspend the current thread + (define timeout-at + (and timeout + (+ (* timeout 1000) (current-inexact-milliseconds)))) + (let loop ([did-work? #t] [polled-all? #f]) + (cond + [(and polled-all? + timeout + (timeout-at . <= . (current-inexact-milliseconds))) + (start-atomic) + (syncing-done! s none-syncer) + (cond + [(syncing-selected s) + ;; Selected after all: + (end-atomic) + (loop #f #f)] + [else + ;; Return result in a thunk: + (lambda () #f)])] + [(and (all-asynchronous? s) + (not (syncing-selected s))) + (suspend-syncing-thread s timeout-at) + (set-syncing-wakeup! s void) + (loop #f #t)] + [else + (sync-poll s + #:did-work? did-work? + #:fail-k (lambda (sched-info now-polled-all?) + (when timeout-at + (schedule-info-add-timeout-at! sched-info timeout-at)) + (thread-yield sched-info) + (loop #f (or polled-all? now-polled-all?))))]))])) + (lambda () + (atomically + (thread-pop-suspend+resume-callbacks!) + (thread-pop-kill-callback!) + (when local-break-cell + (thread-remove-ignored-break-cell! (current-thread) local-break-cell)) + ;; On escape, post nacks, etc.: + (syncing-abandon! s))))) + + ;; Result thunk is called in tail position: + ((cond + [enable-break? + ;; Install a new break cell, and check for breaks at the end: + (begin0 + (with-continuation-mark + break-enabled-key + local-break-cell + (go)) + ;; In case old break cell was meanwhile enabled: + (check-for-break))] + [else + ;; Just `go`: + (go)]))) + +(define (sync . args) + (do-sync 'sync #f args)) + +(define (sync/timeout timeout . args) + (do-sync 'sync/timeout timeout args)) + +(define (sync/enable-break . args) + (do-sync 'sync/enable-break #f args #:enable-break? #t)) + +(define (sync/timeout/enable-break timeout . args) + (do-sync 'sync/timeout/enable-break timeout args #:enable-break? #t)) + +;; Resolve mutual dependency: +(void (set-sync-on-channel! sync)) + +;; ---------------------------------------- + +(define (evts->syncers who evts [wraps null] [commits null] [abandons null]) + (define-values (extended-commits guarded-abandons) + (cross-commits-and-abandons commits abandons)) + (let loop ([evts evts] [first #f] [last #f]) + (cond + [(null? evts) first] + [else + (define arg (car evts)) + (when who + (check who evt? arg)) + (cond + [(choice-evt? arg) + ;; Splice choice events eagerly to improve fairness + ;; of selection + (loop (append (choice-evt-evts arg) (cdr evts)) + first + last)] + [else + (define sr (make-syncer arg wraps)) + (unless (and (null? extended-commits) + (null? guarded-abandons)) + (set-syncer-commits! sr extended-commits) + (set-syncer-abandons! sr guarded-abandons)) + (set-syncer-prev! sr last) + (when last + (set-syncer-next! last sr)) + (loop (cdr evts) + (or first sr) + sr)])]))) + +(define (cross-commits-and-abandons commits abandons) + (cond + [(and (null? commits) (null? abandons)) + (values null null)] + [else + (define selected? #f) + (values (list + ;; in atomic mode + (lambda () + (assert-atomic-mode) + (set! selected? #t) + (for ([commit (in-list commits)]) + (commit)) + (set! commits null))) + (list + ;; in atomic mode + (lambda () + (assert-atomic-mode) + (unless selected? + (for ([abandon (in-list abandons)]) + (abandon))) + (set! abandons null))))])) + +;; in atomic mode +;; remove a syncer from its chain in `s` +(define (syncer-remove! sr s) + (assert-atomic-mode) + (if (syncer-prev sr) + (set-syncer-next! (syncer-prev sr) (syncer-next sr)) + (set-syncing-syncers! s (syncer-next sr))) + (when (syncer-next sr) + (set-syncer-prev! (syncer-next sr) (syncer-prev sr)))) + +;; in atomic mode +;; Replace one syncer with a new, non-empty chain of syncers in `s` +(define (syncer-replace! sr new-syncers s) + (assert-atomic-mode) + (let ([prev (syncer-prev sr)]) + (set-syncer-prev! new-syncers prev) + (if prev + (set-syncer-next! prev new-syncers) + (set-syncing-syncers! s new-syncers))) + (let loop ([new-syncers new-syncers]) + (cond + [(syncer-next new-syncers) + => (lambda (next) (loop next))] + [else + (let ([next (syncer-next sr)]) + (set-syncer-next! new-syncers next) + (when next + (set-syncer-prev! next new-syncers)))]))) + +;; ---------------------------------------- + +(define MAX-SYNC-TRIES-ON-ONE-EVT 10) + +;; Run through the events of a `sync` one time; returns a thunk to +;; call in tail position --- possibly one that calls `none-k`. +(define (sync-poll s + #:fail-k none-k + #:success-k [success-k (lambda (thunk) thunk)] + #:just-poll? [just-poll? #f] + #:done-after-poll? [done-after-poll? #t] + #:did-work? [did-work? #f] + #:schedule-info [sched-info (make-schedule-info #:did-work? did-work?)]) + (random-rotate-syncing! s) + (let loop ([sr (syncing-syncers s)] + [retries 0] ; count retries on `sr`, and advance if it's too many + [polled-all-so-far? #t]) + (when (syncing-need-retry? s) + (syncing-retry! s)) + ((atomically + (cond + [(syncing-selected s) + => (lambda (sr) + ;; Some concurrent synchronization happened + (make-result-thunk sr (list (syncer-evt sr)) success-k))] + [(not sr) + (when (and just-poll? done-after-poll? polled-all-so-far?) + (syncing-done! s none-syncer)) + (lambda () (none-k sched-info polled-all-so-far?))] + [(= retries MAX-SYNC-TRIES-ON-ONE-EVT) + (schedule-info-did-work! sched-info) + (lambda () (loop (syncer-next sr) 0 #f))] + [else + (define ctx (poll-ctx just-poll? + ;; Call back for asynchronous selection, + ;; such as by a semaphore when it's posted + ;; in a different thread; this callback + ;; must be invoked in atomic mode + (lambda () + (assert-atomic-mode) + (syncing-done! s sr)) + ;; Information to propagate to the thread + ;; scheduler + sched-info + ;; Set to #t if getting the same result + ;; back should not be treated as a + ;; completed poll: + #f)) + (define-values (results new-evt) + (evt-poll (syncer-evt sr) ctx)) + (cond + [results + (syncing-done! s sr) + (make-result-thunk sr results success-k)] + [(delayed-poll? new-evt) + ;; Have to go out of atomic mode to continue: + (lambda () + (let ([new-evt ((delayed-poll-resume new-evt))]) + ;; Since we left atomic mode, double-check that we're + ;; still syncing before installing the replacement event: + (atomically + (unless (syncing-selected s) + (set-syncer-evt! sr new-evt))) + (loop sr (add1 retries) polled-all-so-far?)))] + [(choice-evt? new-evt) + (when (or (pair? (syncer-interrupts sr)) + (pair? (syncer-retries sr))) + (internal-error "choice event discovered after interrupt/retry callbacks")) + (define new-syncers (random-rotate + (evts->syncers #f + (choice-evt-evts new-evt) + (syncer-wraps sr) + (syncer-commits sr) + (syncer-abandons sr)))) + (cond + [(not new-syncers) + ;; Empty choice, so drop it: + (syncer-remove! sr s) + (lambda () (loop (syncer-next sr) 0 polled-all-so-far?))] + [else + ;; Splice in new syncers, and start there + (syncer-replace! sr new-syncers s) + (lambda () (loop new-syncers (add1 retries) polled-all-so-far?))])] + [(wrap-evt? new-evt) + (set-syncer-wraps! sr (cons (wrap-evt-wrap new-evt) + (let ([l (syncer-wraps sr)]) + (if (and (null? l) + (not (handle-evt? new-evt))) + ;; Prevent wrapper from being in tail position: + (list values) + ;; Allow handler in tail position: + l)))) + (define inner-new-evt (wrap-evt-evt new-evt)) + (set-syncer-evt! sr inner-new-evt) + ;; In support of the `poller` protocol, if the new evt is + ;; `always-evt`, then select it immediately + (cond + [(eq? inner-new-evt always-evt) + (syncing-done! s sr) + (make-result-thunk sr (list always-evt) success-k)] + [else + (lambda () (loop sr (add1 retries) polled-all-so-far?))])] + [(control-state-evt? new-evt) + (set-syncer-interrupts! sr (cons-non-void (control-state-evt-interrupt-proc new-evt) (syncer-interrupts sr))) + (set-syncer-abandons! sr (cons-non-void (control-state-evt-abandon-proc new-evt) (syncer-abandons sr))) + (set-syncer-retries! sr (cons-non-void (control-state-evt-retry-proc new-evt) (syncer-retries sr))) + (set-syncer-evt! sr (control-state-evt-evt new-evt)) + (lambda () (loop sr (add1 retries) polled-all-so-far?))] + [(poll-guard-evt? new-evt) + (lambda () + ;; Out of atomic region: + (define generated ((poll-guard-evt-proc new-evt) just-poll?)) + (set-syncer-evt! sr (if (evt? generated) + generated + (wrap-evt always-evt (lambda (a) generated)))) + (loop sr (add1 retries) polled-all-so-far?))] + [(and (never-evt? new-evt) + (null? (syncer-interrupts sr)) + (null? (syncer-commits sr)) + (null? (syncer-abandons sr))) + ;; Drop this event, since it will never get selected + (syncer-remove! sr s) + (lambda () (loop (syncer-next sr) 0 polled-all-so-far?))] + [(and (eq? new-evt (syncer-evt sr)) + (not (poll-ctx-incomplete? ctx))) + ;; No progress on this evt + (lambda () (loop (syncer-next sr) 0 polled-all-so-far?))] + [else + (set-syncer-evt! sr new-evt) + (lambda () (loop sr (add1 retries) polled-all-so-far?))])]))))) + +;; Create a thunk that applies wraps immediately, while breaks are +;; potentially still disabled (but not in atomic mode), and then +;; returns another thunk to call a handler (if any) in tail position +(define (make-result-thunk sr results success-k) + (define wraps (syncer-wraps sr)) + (lambda () + (let loop ([wraps wraps] [results results]) + (cond + [(null? wraps) + (success-k + (lambda () + (apply values results)))] + [(null? (cdr wraps)) + ;; Call last one in tail position: + (let ([proc (car wraps)]) + (success-k + (lambda () + (apply proc results))))] + [else + (loop (cdr wraps) + (call-with-values (lambda () (apply (car wraps) results)) list))])))) + +(define (cons-non-void a d) + (if (eq? a void) + d + (cons a d))) + +;; ---------------------------------------- + +;; Called in atomic mode +;; Finalizes a decision for the sychronization, calling +;; interrupt+abandon (or just abandon, if already interrupted) +;; on non-selected events to indicate that they will never be +;; selected for this synchronization +(define (syncing-done! s selected-sr) + (assert-atomic-mode) + (set-syncing-selected! s selected-sr) + (for ([callback (in-list (syncer-commits selected-sr))]) + (callback)) + (let loop ([sr (syncing-syncers s)]) + (when sr + (unless (eq? sr selected-sr) + (unless (syncer-interrupted? sr) + (for ([interrupt (in-list (syncer-interrupts sr))]) + (interrupt))) + (for ([abandon (in-list (syncer-abandons sr))]) + (abandon))) + (loop (syncer-next sr)))) + (when (syncing-disable-break s) + ((syncing-disable-break s))) + ((syncing-wakeup s))) + +;; Called in atomic mode +(define (syncing-abandon! s) + (assert-atomic-mode) + (unless (syncing-selected s) + (syncing-done! s none-syncer))) + +;; Called in atomic mode +;; For each syncer that needs a notification (e.g., to get out of +;; a queue of waiters), call its `interrupt` callback +(define (syncing-interrupt! s) + (assert-atomic-mode) + (let loop ([sr (syncing-syncers s)]) + (when sr + (unless (syncer-interrupted? sr) + (set-syncer-interrupted?! sr #t) + (for ([interrupt (in-list (syncer-interrupts sr))]) + (interrupt))) + (loop (syncer-next sr))))) + +;; Called in atomic mode +;; For each syncer that needs a notification (e.g., to get back into +;; a queue of waiters), call its `retry` callback; a retry might +;; succeed immediately, moving the synchronization into "selected" +;; state +(define (syncing-retry! s) + (assert-atomic-mode) + (set-syncing-need-retry?! s #f) + (let loop ([sr (syncing-syncers s)]) + (when (and sr + (not (syncing-selected s))) + (when (syncer-interrupted? sr) + (set-syncer-interrupted?! sr #f) + ;; Although we keep a list of retries, we expect only + ;; one to be relevant + (for ([retry (in-list (syncer-retries sr))]) + (define-values (result ready?) (retry)) + (when ready? + (set-syncer-wraps! sr (cons (lambda args result) (syncer-wraps sr))) + (syncing-done! s sr)))) + (loop (syncer-next sr))))) + +;; Queue a retry when a check for breaks should happen before a retry +;; that might immediately succeed +(define (syncing-queue-retry! s) + (set-syncing-need-retry?! s #t)) + +;; ---------------------------------------- + +;; If everything we're waiting on is like a semaphore or channel, +;; where an asynchronous selection event is installed, then we can +;; completely suspend this thread +(define (all-asynchronous? s) + (atomically + (let loop ([sr (syncing-syncers s)]) + (cond + [(not sr) #t] + [else + (define e (syncer-evt sr)) + (and (or (async-evt? e) + (never-evt? e)) + (loop (syncer-next sr)))])))) + +;; Install a callback to reschedule the current thread if an +;; asynchronous selection happens, and then deschedule the thread +(define (suspend-syncing-thread s timeout-at) + ((atomically + (let retry () + (cond + [(syncing-selected s) + ;; don't suspend after all + void] + [else + (define t (current-thread)) + (set-syncing-wakeup! + s + (lambda () + (set-syncing-wakeup! s void) + ;; In case this callback is late, where the thread was + ;; already rescheduled for some reason: + (when (thread-descheduled? t) + (thread-reschedule! t)))) + ;; Suspend and resume callbacks will also + ;; interrupt and queue a retry, but it's ok + ;; to have both at this point + (thread-deschedule! t + timeout-at + (lambda () + ;; Interrupt due to break/kill/suspend + (set-syncing-wakeup! s void) + (unless (syncing-selected s) + (syncing-interrupt! s))) + (lambda () + ;; Continue from suspend or ignored break... + ;; In non-atomic mode and tail position: + ((atomically + (unless (syncing-selected s) + (syncing-retry! s)) + (retry)))))]))))) + +;; ---------------------------------------- + +(struct replacing-evt (guard) + #:property prop:evt (poller (lambda (self poll-ctx) ((replacing-evt-guard self)))) + #:reflection-name 'evt) + +(struct nested-sync-evt (s next orig-evt) + #:property prop:evt (poller (lambda (self poll-ctx) (poll-nested-sync self poll-ctx))) + #:reflection-name 'evt) + +(define/who (replace-evt evt next) + (check who evt? evt) + (check who procedure? next) + (define orig-evt + (replacing-evt + ;; called for each `sync`: + (lambda () + (define s (make-syncing (evts->syncers who (list evt)))) + (values + #f + ;; represents the instantited attempt to sync on `evt`: + (control-state-evt + (nested-sync-evt s next orig-evt) + (lambda () (syncing-interrupt! s)) + (lambda () (syncing-abandon! s)) + (lambda () (syncing-retry! s))))))) + orig-evt) + +(define (poll-nested-sync ns poll-ctx) + (sync-poll (nested-sync-evt-s ns) + #:fail-k (lambda (sched-info polled-all?) + (unless polled-all? + (set-poll-ctx-incomplete?! poll-ctx #f)) + (values #f ns)) + #:success-k (lambda (thunk) + ;; `thunk` produces the values of the evt + ;; that was provided to `replace-evt`: + (define next (nested-sync-evt-next ns)) + (define orig-evt (nested-sync-evt-orig-evt ns)) + (values #f + ;; and this is the "replace" step: + (poll-guard-evt + (lambda (poll?) + (define r (call-with-values thunk next)) + (cond + [(evt? r) r] + [else (wrap-evt always-evt (lambda (v) orig-evt))]))))) + #:just-poll? (poll-ctx-poll? poll-ctx) + #:done-after-poll? #f + #:schedule-info (poll-ctx-sched-info poll-ctx))) + +;; ---------------------------------------- + +(define/who current-evt-pseudo-random-generator + (make-parameter (make-pseudo-random-generator) + (lambda (v) + (check who pseudo-random-generator? v) + v))) + +;; rotates the order of syncers in `s` to implement fair selection: +(define (random-rotate-syncing! s) + (set-syncing-syncers! s (random-rotate (syncing-syncers s)))) + +(define (random-rotate first-sr) + (define n (let loop ([sr first-sr] [n 0]) + (cond + [(not sr) n] + [else (loop (syncer-next sr) (add1 n))]))) + (cond + [(n . <= . 1) first-sr] + [else + (define m (random n (current-evt-pseudo-random-generator))) + (cond + [(zero? m) first-sr] + [else + (let loop ([sr first-sr] [m (sub1 m)]) + (cond + [(zero? m) + (define new-first-sr (syncer-next sr)) + (set-syncer-next! sr #f) + (set-syncer-prev! new-first-sr #f) + (let loop ([next-sr new-first-sr]) + (define next-next-sr (syncer-next next-sr)) + (cond + [(not next-next-sr) + (set-syncer-next! next-sr first-sr) + (set-syncer-prev! first-sr next-sr) + new-first-sr] + [else (loop next-next-sr)]))] + [else + (loop (syncer-next sr) (sub1 m))]))])])) diff --git a/racket/src/thread/system-idle-evt.rkt b/racket/src/thread/system-idle-evt.rkt new file mode 100644 index 0000000000..7e973aa5c8 --- /dev/null +++ b/racket/src/thread/system-idle-evt.rkt @@ -0,0 +1,32 @@ +#lang racket/base +(require "evt.rkt" + "semaphore.rkt" + "internal-error.rkt") + +(provide (rename-out [get-system-idle-evt system-idle-evt]) + + any-idle-waiters? + post-idle) + +(define idle-sema (make-semaphore)) +(define wrapped-idle-sema (wrap-evt idle-sema void)) +(struct system-idle-evt () + #:property prop:evt (lambda (i) wrapped-idle-sema)) + +(define the-idle-evt (system-idle-evt)) + +(define get-system-idle-evt + (let ([system-idle-evt + (lambda () the-idle-evt)]) + system-idle-evt)) + +;; Called by the scheduler in atomic mode: +(define (any-idle-waiters?) + (semaphore-any-waiters? idle-sema)) + +;; Called by the scheduler in atomic mode: +(define (post-idle) + (and (semaphore-any-waiters? idle-sema) + (begin + (semaphore-post/atomic idle-sema) + #t))) diff --git a/racket/src/thread/thread-group.rkt b/racket/src/thread/thread-group.rkt new file mode 100644 index 0000000000..7ab1162883 --- /dev/null +++ b/racket/src/thread/thread-group.rkt @@ -0,0 +1,128 @@ +#lang racket/base +(require "engine.rkt" + "check.rkt" + "internal-error.rkt" + "atomic.rkt") + +(provide (struct-out node) + + thread-group? + make-thread-group + current-thread-group + + ;; Used by scheduler + root-thread-group + thread-group-next! + + ;; Called by thread creation and termination: + thread-group-add! + thread-group-remove! + + thread-group-all-threads + num-threads-in-groups) + +;; Threads and thread groups subtype `node`: +(struct node ([prev #:mutable] + [next #:mutable])) +(define (child-node child) child) ; a child instantiates a `node` subtype +(define (node-child n) n) + +(struct thread-group node (parent + [chain-start #:mutable] ; all children + [chain #:mutable] ; children remaining to be scheduled round-robin + [chain-end #:mutable])) + +(define root-thread-group (thread-group 'none 'none #f #f #f #f)) + +(define num-threads-in-groups 0) + +(define/who current-thread-group + (make-parameter root-thread-group + (lambda (v) + (check who thread-group? v) + v))) + +(define/who (make-thread-group [parent (current-thread-group)]) + (check who thread-group? parent) + (define tg (thread-group 'none 'none parent #f #f #f)) + tg) + +;; Called atomically in scheduler: +(define (thread-group-next! tg) + (define n (thread-group-chain tg)) + (cond + [(not n) + (define n (thread-group-chain-start tg)) + (cond + [(not n) + ;; No children + #f] + [else + (set-thread-group-chain! tg (node-next n)) + n])] + [else + (set-thread-group-chain! tg (node-next n)) + (node-child n)])) + +(define (thread-group-add! parent child) + (atomically + (let loop ([parent parent] [child child]) + ;; Adding to the start of the group tends to reverse the schedule + ;; order, but it also avoids a problem where two threads that + ;; both loop and `sleep` (which deschedules and reschedules) take + ;; turns and starve everything else. + (define t (thread-group-chain-start parent)) + (define was-empty? (not t)) + (define n (child-node child)) + (unless (and (eq? (node-prev n) 'none) + (eq? (node-next n) 'none)) + (internal-error "thread-group-add!: thread or group is added already")) + (set-node-next! n t) + (set-node-prev! n #f) + (if t + (set-node-prev! t n) + (set-thread-group-chain-end! parent n)) + (set-thread-group-chain-start! parent n) + (unless (thread-group? child) + (set! num-threads-in-groups (add1 num-threads-in-groups))) + (when was-empty? + ;; added child to formerly empty parent => add the parent + (define parent-parent (thread-group-parent parent)) + (when parent-parent + (loop parent-parent parent)))))) + +(define (thread-group-remove! parent child) + (atomically + (let loop ([parent parent] [child child]) + (define n (child-node child)) + (when (or (eq? (node-prev n) 'none) + (eq? (node-next n) 'none)) + (internal-error "thread-group-remove!: thread or group is removed already")) + (if (node-next n) + (set-node-prev! (node-next n) (node-prev n)) + (set-thread-group-chain-end! parent (node-prev n))) + (if (node-prev n) + (set-node-next! (node-prev n) (node-next n)) + (set-thread-group-chain-start! parent (node-next n))) + (when (eq? n (thread-group-chain parent)) + (set-thread-group-chain! parent (node-next n))) + (set-node-next! n 'none) + (set-node-prev! n 'none) + (unless (thread-group? child) + (set! num-threads-in-groups (sub1 num-threads-in-groups))) + (when (not (thread-group-chain-end parent)) + ;; parent thread group is now empty, so remove it, too + (define parent-parent (thread-group-parent parent)) + (when parent-parent + (loop parent-parent parent)))))) + +(define (thread-group-all-threads parent accum) + (cond + [(not (thread-group? parent)) (cons parent accum)] + [else + (let loop ([n (thread-group-chain-start parent)] [accum accum]) + (cond + [(not n) accum] + [else (loop (node-next n) + (thread-group-all-threads (node-child n) accum))]))])) + diff --git a/racket/src/thread/thread.rkt b/racket/src/thread/thread.rkt new file mode 100644 index 0000000000..536a67074d --- /dev/null +++ b/racket/src/thread/thread.rkt @@ -0,0 +1,979 @@ +#lang racket/base +(require "../common/queue.rkt" + "check.rkt" + "internal-error.rkt" + "engine.rkt" + "sandman.rkt" + "parameter.rkt" + "evt.rkt" + "waiter.rkt" + "semaphore.rkt" + "thread-group.rkt" + "atomic.rkt" + "schedule-info.rkt" + "custodian.rkt" + "exit.rkt") + +(provide (rename-out [make-thread thread]) + thread/suspend-to-kill + unsafe-thread-at-root + thread? + current-thread + + thread-running? + thread-dead? + + thread-wait + thread-suspend + thread-resume + thread-suspend-evt + thread-resume-evt + (rename-out [get-thread-dead-evt thread-dead-evt]) + thread-dead-evt? + + break-thread + kill-thread + + sleep + + break-enabled + check-for-break + break-enabled-key + current-break-suspend + + thread-push-kill-callback! + thread-pop-kill-callback! + thread-push-suspend+resume-callbacks! + thread-pop-suspend+resume-callbacks! + + thread-deschedule! + thread-reschedule! + thread-yield + + thread-ignore-break-cell! + thread-remove-ignored-break-cell! + + thread-send + thread-receive + thread-try-receive + thread-rewind-receive + thread-receive-evt + + thread-condition-awaken + thread-condition-wait) + +;; Exports needed by "schedule.rkt": +(module* scheduling #f + (provide (struct-out thread) + + make-initial-thread + do-make-thread + root-thread + thread-running? + thread-dead! + thread-did-work! + + thread-reschedule! + + poll-done-threads + + current-break-enabled-cell + check-for-break + current-break-suspend + + break-max)) + +;; ---------------------------------------- + +(struct thread node (name + [engine #:mutable] + parent + [sleeping #:mutable] ; #f or sandman sleeper handle + [sched-info #:mutable] + + [custodian-references #:mutable] ; list of custodian references + [transitive-resumes #:mutable] ; a list of `transitive-resume`s + + suspend-to-kill? + [kill-callbacks #:mutable] ; list of callbacks + + [suspend+resume-callbacks #:mutable] ; list of (cons callback callback) + [descheduled? #:mutable] + [interrupt-callback #:mutable] ; non-#f => wake up on kill + + [dead-sema #:mutable] ; created on demand + [dead-evt #:mutable] ; created on demand + [suspended-box #:mutable] ; created on demand; box contains thread if suspended + [suspended-evt #:mutable] + [resumed-evt #:mutable] + + [pending-break #:mutable] ; #f, 'break, 'hang-up, or 'terminate + [ignore-break-cells #:mutable] ; => #f, a single cell, or a set of cells + [forward-break-to #:mutable] ; #f or a thread to receive this thread's breaks + + [mailbox #:mutable] ; a queue of messages from `thread-send` + [mailbox-wakeup #:mutable] ; callback to trigger (in atomic mode) on `thread-send` + + [cpu-time #:mutable] ; accumulates CPU time in milliseconds + + [condition-wakeup #:mutable]) + #:property prop:waiter + (make-waiter-methods + #:suspend! (lambda (t i-cb r-cb) (thread-deschedule! t #f i-cb r-cb)) + #:resume! (lambda (t v) (thread-reschedule! t) v)) + #:property prop:evt (lambda (t) (wrap-evt (get-thread-dead-evt t) + (lambda (v) t)))) + +(define root-thread #f) + +;; ---------------------------------------- +;; Thread creation + +(define (do-make-thread who + proc + #:custodian [c (current-custodian)] ; can be #f + #:at-root? [at-root? #f] + #:initial? [initial? #f] + #:suspend-to-kill? [suspend-to-kill? #f]) + (check who (procedure-arity-includes/c 0) proc) + (define p (if at-root? + root-thread-group + (current-thread-group))) + (define e (make-engine (lambda () + (call-with-continuation-prompt proc)) + (if (or initial? at-root?) + break-enabled-default-cell + (current-break-enabled-cell)) + at-root?)) + (define t (thread 'none ; node prev + 'none ; node next + + (gensym) + e + p + #f ; sleeping + #f ; sched-info + + null ; custodian-references + null ; transitive-resumes + + suspend-to-kill? + null ; kill-callbacks + + null ; suspend+resume-callbacks + #f ; descheduled + #f ; interrupt-callback + + #f ; dead-sema + #f ; dead-evt + #f ; suspended-box + #f ; suspended-evt + #f ; resumed-evt + + #f ; pending-break + #f ; ignore-thread-cells + #f; forward-break-to + + (make-queue) ; mailbox + void ; mailbox-wakeup + + 0 ; cpu-time + + void ; condition-wakeup + )) + ((atomically + (define cref (and c (unsafe-custodian-register c t remove-thread-custodian #f #t))) + (cond + [(or (not c) cref) + (set-thread-custodian-references! t (list cref)) + (thread-group-add! p t) + void] + [else (lambda () (raise-custodian-is-shut-down who c))]))) + t) + +(define make-thread + (let ([thread (lambda (proc) + (do-make-thread 'thread proc))]) + thread)) + +(define (thread/suspend-to-kill proc) + (do-make-thread 'thread/suspend-to-kill proc #:suspend-to-kill? #t)) + +(define (make-initial-thread thunk) + (let ([t (do-make-thread 'thread thunk #:initial? #t)]) + (set! root-thread t) + t)) + +(define (unsafe-thread-at-root proc) + (do-make-thread 'unsafe-thread-at-root proc #:at-root? #t)) + +;; ---------------------------------------- +;; Thread status + +(define (thread-suspended? t) + (define b (thread-suspended-box t)) + (and b (unbox b) #t)) + +;; in atomic mode +(define (set-thread-suspended?! t suspended?) + (assert-atomic-mode) + (define b (or (thread-suspended-box t) + (let ([b (box #f)]) + (set-thread-suspended-box! t b) + b))) + (set-box! b (and suspended? t))) + +(define/who (thread-running? t) + (check who thread? t) + (and (not (eq? 'done (thread-engine t))) + (not (thread-suspended? t)))) + +(define/who (thread-dead? t) + (check who thread? t) + (eq? 'done (thread-engine t))) + +;; In atomic mode +;; Terminating the current thread does not suspend or exit +(define (thread-dead! t) + (assert-atomic-mode) + (set-thread-engine! t 'done) + (when (thread-dead-sema t) + (semaphore-post-all (thread-dead-sema t))) + (run-interrupt-callback t) + (unless (thread-descheduled? t) + (thread-group-remove! (thread-parent t) t)) + (remove-from-sleeping-threads! t) + (run-kill-callbacks! t) + (when (thread-forward-break-to t) + (do-break-thread (thread-forward-break-to t) 'break #f)) + (for ([cr (in-list (thread-custodian-references t))]) + (unsafe-custodian-unregister t cr)) + (set-thread-custodian-references! t null)) + +;; ---------------------------------------- +;; Thread termination + +;; Called in atomic mode: +(define (thread-push-kill-callback! cb) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-kill-callbacks! t (cons cb (thread-kill-callbacks t)))) + +;; Called in atomic mode: +(define (thread-pop-kill-callback!) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-kill-callbacks! t (cdr (thread-kill-callbacks t)))) + +(define/who (kill-thread t) + (check who thread? t) + (unless (for/and ([cr (in-list (thread-custodian-references t))]) + (custodian-manages-reference? (current-custodian) cr)) + (raise-arguments-error who + "the current custodian does not solely manage the specified thread" + "thread" t)) + (cond + [(thread-suspend-to-kill? t) + ((atomically + (do-thread-suspend t)))] + [else + (atomically + (do-kill-thread t)) + (when (eq? t (current-thread)) + (when (eq? t root-thread) + (force-exit 0)) + (engine-block)) + (check-for-break-after-kill)])) + +;; Called in atomic mode: +(define (do-kill-thread t) + (assert-atomic-mode) + (unless (thread-dead? t) + (thread-dead! t))) + +;; Called in atomic mode: +(define (remove-thread-custodian t c) + (assert-atomic-mode) + (define new-crs (for/list ([cref (in-list (thread-custodian-references t))] + #:unless (custodian-manages-reference? c cref)) + cref)) + (set-thread-custodian-references! t new-crs) + (when (null? new-crs) + (cond + [(thread-suspend-to-kill? t) + (do-thread-suspend t)] + [else + (do-kill-thread t)]))) + +;; Called in atomic mode: +(define (run-kill-callbacks! t) + (assert-atomic-mode) + (for ([cb (in-list (thread-kill-callbacks t))]) + (cb)) + (set-thread-kill-callbacks! t null)) + +(define (check-for-break-after-kill) + ;; When a thread is terminated, it might be a nesting thread and + ;; send a break to a nestee --- and the current thread might be the + ;; nestee. + (check-for-break)) + +(void (set-post-shutdown-action! + (lambda () + ;; Check whether the current thread was terminated + (let ([t (current-thread)]) + (when t ; in case custodians used (for testing) without threads + (when (thread-dead? t) + (engine-block)) + (check-for-break-after-kill)))))) + +;; ---------------------------------------- +;; Thread status events + +(define/who (thread-wait t) + (check who thread? t) + (semaphore-wait (get-thread-dead-sema t))) + +(struct dead-evt (sema) + #:property prop:evt (lambda (tde) (wrap-evt (dead-evt-sema tde) + (lambda (s) tde))) + #:reflection-name 'thread-dead-evt) + +(define (thread-dead-evt? v) + (dead-evt? v)) + +(define/who get-thread-dead-evt + (let ([thread-dead-evt + (lambda (t) + (check who thread? t) + (atomically + (unless (thread-dead-evt t) + (set-thread-dead-evt! t (dead-evt (get-thread-dead-sema t))))) + (thread-dead-evt t))]) + thread-dead-evt)) + +(define (get-thread-dead-sema t) + (atomically + (unless (thread-dead-sema t) + (set-thread-dead-sema! t (make-semaphore 0)) + (when (eq? 'done (thread-engine t)) + (semaphore-post-all (thread-dead-sema t))))) + (thread-dead-sema t)) + +;; ---------------------------------------- +;; Thread suspend and resume + +;; in atomic mode +(define (remove-from-sleeping-threads! t) + (assert-atomic-mode) + (define sleeping (thread-sleeping t)) + (when sleeping + (set-thread-sleeping! t #f) + (sandman-remove-sleeping-thread! t sleeping))) + +;; in atomic mode +(define (add-to-sleeping-threads! t ext-events) + (assert-atomic-mode) + (define sleeping (sandman-add-sleeping-thread! t ext-events)) + (set-thread-sleeping! t sleeping)) + +;; in atomic mode +;; Removes a thread from its thread group, so it won't be scheduled; +;; returns a thunk to be called in out of atomic mode to swap out the +;; thread, where the thunk returns `(void)`; +(define (do-thread-deschedule! t timeout-at) + (assert-atomic-mode) + (when (thread-descheduled? t) + (internal-error "tried to deschedule a descheduled thread")) + (set-thread-descheduled?! t #t) + (thread-group-remove! (thread-parent t) t) + (when timeout-at + (add-to-sleeping-threads! t (sandman-merge-timeout #f timeout-at))) + (when (eq? t (current-thread)) + (thread-did-work!)) + (lambda () + (when (eq? t (current-thread)) + (when (positive? (current-atomic)) + (internal-error "attempt to deschedule the current thread in atomic mode")) + (engine-block) + (check-for-break)))) + +;; Extends `do-thread-deschdule!` where `t` is always `(current-thread)`. +;; The `interrupt-callback` is called if the thread receives a break +;; signal, is killed, or is suspended; if the break signal is +;; supressed or resumed, then `retry-callback` is called to try again +;; --- but `retry-callback` will only be used if `interrupt-callback` +;; was previously called, and neither is called if the thread is +;; "internal"-resumed normally instead of by a break signal of a +;; `thread-resume`. +(define (thread-deschedule! t timeout-at interrupt-callback retry-callback) + (define needs-retry? #f) + (atomically + (set-thread-interrupt-callback! t (lambda () + ;; If the interrupt callback gets invoked, + ;; then remember that we need a retry + (set! needs-retry? #t) + (interrupt-callback))) + (define finish (do-thread-deschedule! t timeout-at)) + ;; It's ok if the thread gets interrupted + ;; outside the atomic region, because we'd + ;; swap it out anyway + (lambda () + ;; In non-atomic mode: + (finish) + (when needs-retry? + (retry-callback))))) + +;; in atomic mode +;; Add a thread back to its thread group +(define (thread-reschedule! t) + (assert-atomic-mode) + (when (thread-dead? t) + (internal-error "tried to reschedule a dead thread")) + (unless (thread-descheduled? t) + (internal-error "tried to reschedule a scheduled thread")) + (set-thread-descheduled?! t #f) + (set-thread-interrupt-callback! t #f) + (remove-from-sleeping-threads! t) + (thread-group-add! (thread-parent t) t)) + +(define/who (thread-suspend t) + (check who thread? t) + ((atomically + (do-thread-suspend t)))) + +;; in atomic mode +;; Returns a thunk to call to handle the case that +;; the current thread is suspended +(define (do-thread-suspend t) + (assert-atomic-mode) + (cond + [(thread-dead? t) void] + [else + (unless (thread-suspended? t) + (set-thread-suspended?! t #t) + ;; Suspending a thread is similar to issuing a break; + ;; the thread should get out of any queues where it's + ;; waiting, etc.: + (run-interrupt-callback t) + (run-suspend/resume-callbacks t car) + (define suspended-evt (thread-suspended-evt t)) + (when suspended-evt + (set-suspend-resume-evt-thread! suspended-evt t) + (semaphore-post-all (suspend-resume-evt-sema suspended-evt)) + (set-thread-suspended-evt! t #f))) + (cond + [(not (thread-descheduled? t)) + (do-thread-deschedule! t #f)] + [else + void])])) + +(define/who (thread-resume t [benefactor #f]) + (check who thread? t) + (check who (lambda (p) (or (not p) (thread? p) (custodian? p))) + #:contract "(or/c #f thread? custodian?)" + benefactor) + (when (and (custodian? benefactor) + (custodian-shut-down? benefactor)) + (raise-custodian-is-shut-down who benefactor)) + (atomically + (do-thread-resume t benefactor))) + +;; in atomic mode +(define (do-thread-resume t benefactor) + (assert-atomic-mode) + (unless (thread-dead? t) + (cond + [(thread? benefactor) + (for ([cr (in-list (thread-custodian-references benefactor))]) + (add-custodian-to-thread! t (custodian-reference->custodian cr))) + (add-transitive-resume-to-thread! benefactor t)] + [(custodian? benefactor) + (add-custodian-to-thread! t benefactor)]) + (when (and (thread-suspended? t) + (pair? (thread-custodian-references t))) + (define resumed-evt (thread-resumed-evt t)) + (when resumed-evt + (set-suspend-resume-evt-thread! resumed-evt t) + (semaphore-post-all (suspend-resume-evt-sema resumed-evt)) + (set-thread-resumed-evt! t #f)) + (set-thread-suspended?! t #f) + (run-suspend/resume-callbacks t cdr) + (thread-reschedule! t) + (do-resume-transitive-resumes t #f)))) + +;; in atomic mode +(define (add-custodian-to-thread! t c) + (assert-atomic-mode) + (let loop ([crs (thread-custodian-references t)] + [accum null]) + (cond + [(null? crs) + (define new-crs + (cons (unsafe-custodian-register c t remove-thread-custodian #f #t) + accum)) + (set-thread-custodian-references! t new-crs) + (do-resume-transitive-resumes t c)] + [else + (define old-c (custodian-reference->custodian (car crs))) + (cond + [(or (eq? c old-c) + (custodian-subordinate? c old-c)) + ;; no need to add new + (void)] + [(custodian-subordinate? old-c c) + ;; new one replaces old one; we can simplify forget the + ;; old reference + (loop (cdr crs) accum)] + [else + ;; keep checking + (loop (cdr crs) (cons (car crs) accum))])]))) + +(struct transitive-resume (weak-box ; weak reference to thread + box) ; box is filled as stron reference if thread is suspended + #:authentic) + +;; in atomic mode +(define (add-transitive-resume-to-thread! t b-t) + (assert-atomic-mode) + ;; Look for `b-t` in list, and also prune + ;; terminated threads + (define new-l + (let loop ([l (thread-transitive-resumes t)]) + (cond + [(null? l) + ;; Force creation of `(thread-suspended-box t)`: + (set-thread-suspended?! b-t (thread-suspended? b-t)) + (list (transitive-resume (make-weak-box b-t) + (thread-suspended-box b-t)))] + [else + (let ([o-t (weak-box-value (transitive-resume-weak-box (car l)))]) + (cond + [(not o-t) (loop (cdr l))] + [(thread-dead? o-t) (loop (cdr l))] + [(eq? b-t o-t) l] + [else (cons (car l) (loop (cdr l)))]))]))) + (set-thread-transitive-resumes! t new-l)) + +;; in atomic mode +(define (do-resume-transitive-resumes t c) + (assert-atomic-mode) + (for ([tr (in-list (thread-transitive-resumes t))]) + (define b-t (weak-box-value (transitive-resume-weak-box tr))) + (when b-t + (do-thread-resume b-t c)))) + +;; Called in atomic mode: +;; Given callbacks are also called in atomic mode +(define (thread-push-suspend+resume-callbacks! s-cb r-cb) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-suspend+resume-callbacks! t (cons (cons s-cb r-cb) + (thread-suspend+resume-callbacks t)))) + +;; Called in atomic mode: +(define (thread-pop-suspend+resume-callbacks!) + (assert-atomic-mode) + (define t (current-thread)) + (set-thread-suspend+resume-callbacks! t (cdr (thread-suspend+resume-callbacks t)))) + +;; Called in atomic mode: +(define (run-suspend/resume-callbacks t sel) + (assert-atomic-mode) + (for ([cbs (in-list (thread-suspend+resume-callbacks t))]) + ((sel cbs)))) + +;; Called in atomic mode: +(define (run-interrupt-callback t) + (assert-atomic-mode) + (define interrupt-callback (thread-interrupt-callback t)) + (when interrupt-callback + ;; The interrupt callback might remove the thread as + ;; a waiter on a semaphore of channel; if breaks + ;; turn out to be disabled, the wait will be + ;; retried through the retry callback + (set-thread-interrupt-callback! t #f) + (interrupt-callback))) + +;; ---------------------------------------- +;; Suspend and resume events + +(struct suspend-resume-evt (sema ; semaphore, `always-evt`, or `never-evt` + [thread #:mutable]) ; set lazily to avoiding retaining the thread + #:property prop:evt (lambda (se) (wrap-evt (suspend-resume-evt-sema se) + (lambda (s) (suspend-resume-evt-thread se))))) + +(struct suspend-evt suspend-resume-evt () + #:reflection-name 'thread-suspend-evt) + +(struct resume-evt suspend-resume-evt () + #:reflection-name 'thread-resume-evt) + +(define/who (thread-resume-evt t) + (check who thread? t) + (atomically + (cond + [(thread-dead? t) + (resume-evt never-evt #f)] + [(thread-suspended? t) + (or (thread-resumed-evt t) + (let ([r (resume-evt (make-semaphore) #f)]) + (set-thread-resumed-evt! t r) + r))] + [else + (resume-evt always-evt t)]))) + +(define/who (thread-suspend-evt t) + (check who thread? t) + (atomically + (cond + [(thread-dead? t) + (suspend-evt never-evt #f)] + [(thread-suspended? t) + (suspend-evt always-evt t)] + [else + (or (thread-suspended-evt t) + (let ([s (suspend-evt (make-semaphore) #f)]) + (set-thread-suspended-evt! t s) + s))]))) + +;; ---------------------------------------- +;; Thread yielding + +;; Pause the current thread to let other threads run. If all threads +;; are paused, then `sched-info` contains information (such as a +;; timeout for the current thread's sleep) needed for a global sleep +(define (thread-yield sched-info) + (atomically + (cond + [(or (not sched-info) + (schedule-info-did-work? sched-info)) + (thread-did-work!)] + [else (thread-did-no-work!)]) + (set-thread-sched-info! (current-thread) sched-info)) + (engine-block)) + +;; Sleep for a while +(define/who (sleep [secs 0]) + (check who + (lambda (c) (and (real? c) (c . >= . 0))) + #:contract "(>=/c 0)" + secs) + (define until-msecs (+ (* secs 1000.0) + (current-inexact-milliseconds))) + (let loop () + ((thread-deschedule! (current-thread) + until-msecs + void + (lambda () + ;; Woke up due to an ignored break? + ;; Try again: + (loop)))))) + +;; ---------------------------------------- +;; Tracking thread progress + +;; If a thread does work before it is swapped out, then we should poll +;; all threads again. Accumulate a table of threads that we don't need +;; to poll because we've tried them since the most recent thread +;; performed work: +(define poll-done-threads #hasheq()) + +(define (thread-did-no-work!) + (set! poll-done-threads (hash-set poll-done-threads (current-thread) #t))) + +(define (thread-did-work!) + (set! poll-done-threads #hasheq())) + +;; ---------------------------------------- +;; Breaks + +;; The host implementation of `dynamic-wind` is expected to cooperate +;; with the implementation of breaks in terms of `break-enabled-key` +;; and boolean-valued, preserved thread cells. That's cooperattion is +;; awkward, in the sense that it defies the intended layering of +;; subsystems, but it allows the pre and post thunks of `dynamic-wind` +;; to reliably run with breaks disabled (especially during the +;; transition from one thunk to another during a jump). + +;; A continuation-mark key (not made visible to regular Racket code): +(define break-enabled-default-cell (make-thread-cell #t)) + +;; For disabling breaks, such as through `unsafe-start-atomic`: +(define break-suspend 0) +(define current-break-suspend + (case-lambda + [() break-suspend] + [(v) (set! break-suspend v)])) + +(define (current-break-enabled-cell) + (continuation-mark-set-first #f + break-enabled-key + break-enabled-default-cell + (root-continuation-prompt-tag))) + +(define break-enabled + (case-lambda + [() (thread-cell-ref (current-break-enabled-cell))] + [(on?) + (thread-cell-set! (current-break-enabled-cell) on?) + (when on? + (check-for-break))])) + +;; When the continuation-mark mapping to `break-enabled-key` is +;; changed, or when a thread is just swapped in, then +;; `check-for-break` should be called. +(define (check-for-break) + (define t (current-thread)) + (when t ; allow `check-for-break` before threads are running + ((atomically + (cond + [(and (thread-pending-break t) + (break-enabled) + (not (thread-ignore-break-cell? t (current-break-enabled-cell))) + (zero? (current-break-suspend))) + (define exn:break* (case (thread-pending-break t) + [(hang-up) exn:break:hang-up/non-engine] + [(terminate) exn:break:terminate/non-engine] + [else exn:break/non-engine])) + (set-thread-pending-break! t #f) + (lambda () + ;; Out of atomic mode + (call-with-escape-continuation + (lambda (k) + (raise (exn:break* + "user break" + (current-continuation-marks) + k)))))] + [else void]))))) + +;; The break-enabled transition hook is called by the host +;; system when a control transfer (such as a continuation jump) +;; enters a place where the `break-enabled-key` continuation +;; mark has a different value. +(void + (set-break-enabled-transition-hook! check-for-break)) + +(define/who (break-thread t [kind #f]) + (check who thread? t) + (check who (lambda (k) (or (not k) (eq? k 'hang-up) (eq? k 'terminate))) + #:contract "(or/c #f 'hang-up 'terminate)" + kind) + (do-break-thread t (or kind 'break) (current-thread))) + +;; Might be called in atomic mode, but `check-t` is #f in that case +(define (do-break-thread t kind check-t) + ((atomically + (cond + [(thread-forward-break-to t) + => (lambda (other-t) + (lambda () (do-break-thread other-t kind check-t)))] + [else + (when (and (thread-pending-break t) + (break>? kind (thread-pending-break t))) + (set-thread-pending-break! t kind)) + (unless (thread-pending-break t) + (set-thread-pending-break! t kind) + (thread-did-work!) + (when (thread-descheduled? t) + (unless (thread-suspended? t) + (run-interrupt-callback t) + (thread-reschedule! t)))) + void]))) + (when (eq? t check-t) + (check-for-break))) + +(define (break>? k1 k2) + (cond + [(eq? k1 'break) #f] + [(eq? k1 'hang-up) (eq? k2 'break)] + [else (not (eq? k2 'terminate))])) + +(define (break-max k1 k2) + (cond + [(not (and k1 k2)) (or k1 k2)] + [(break>? k1 k2) k1] + [else k2])) + +(void + (set-ctl-c-handler! + (lambda (kind) + (do-break-thread root-thread kind #f)))) + +;; in atomic mode: +(define (thread-ignore-break-cell? t bc) + (assert-atomic-mode) + (let ([ignore (thread-ignore-break-cells t)]) + (or (eq? ignore bc) + (and (hash? ignore) + (hash-ref ignore bc #f))))) + +;; in atomic mode: +(define (thread-ignore-break-cell! t bc) + (assert-atomic-mode) + (let ([ignore (thread-ignore-break-cells t)]) + (set-thread-ignore-break-cells! t (cond + [(not ignore) + ;; Singleton + bc] + [(hash? ignore) + ;; Add to set + (hash-set ignore bc #t)] + [else + ;; Convert to set + (hasheq ignore #t bc #t)])))) + +;; in atomic mode +(define (thread-remove-ignored-break-cell! t bc) + (assert-atomic-mode) + (when (thread-ignore-break-cell? t bc) + (let ([ignore (thread-ignore-break-cells t)]) + (set-thread-ignore-break-cells! t (cond + [(eq? ignore bc) #f] + [else (hash-remove ignore bc)]))))) + +;; ---------------------------------------- +;; Thread mailboxes + +;; in atomic mode +(define (enqueue-mail! thd v) + (assert-atomic-mode) + (queue-add! (thread-mailbox thd) v)) + +;; in atomic mode +(define (dequeue-mail! thd) + (assert-atomic-mode) + (define mbx (thread-mailbox thd)) + (cond + [(queue-empty? mbx) + (internal-error "No Mail!\n")] + [else + (queue-remove! mbx)])) + +;; in atomic mode +(define (is-mail? thd) + (assert-atomic-mode) + (not (queue-empty? (thread-mailbox thd)))) + +;; in atomic mode +(define (push-mail! thd v) + (assert-atomic-mode) + (queue-add-front! (thread-mailbox thd) v)) + +(define/who (thread-send thd v [fail-thunk + (lambda () + (raise-arguments-error 'thread-send "target thread is not running"))]) + (check who thread? thd) + (check who (procedure-arity-includes/c 0) #:or-false fail-thunk) + ((atomically + (cond + [(not (thread-dead? thd)) + (enqueue-mail! thd v) + (define wakeup (thread-mailbox-wakeup thd)) + (set-thread-mailbox-wakeup! thd void) + (wakeup) + void] + [fail-thunk + fail-thunk] + [else + (lambda () #f)])))) + +(define/who (thread-condition-awaken thd) + (check who thread? thd) + ((atomically + (cond + [(not (thread-dead? thd)) + (define wakeup (thread-condition-wakeup thd)) + (set-thread-condition-wakeup! thd void) + wakeup] ;; should be called outside of atomic mode? + [else + (lambda () #f)])))) + +(define (thread-condition-wait lock-release) + ((atomically + (define t (current-thread)) + (set-thread-condition-wakeup! t (sandman-condition-wait t)) + (lock-release) + (define do-yield + (thread-deschedule! t + #f + void + (lambda () + ;; try again? + (do-yield)) + )) + (lambda () + (do-yield))))) + +(define (thread-receive) + ((atomically + (define t (current-thread)) + (cond + [(is-mail? t) + (define v (dequeue-mail! t)) + (lambda () v)] + [else + ;; The current wakeup callback must be `void`, since this thread + ;; can't be in the middle of a `sync` (unless interrupted by a break) + ;; or `thread-receive` + (set-thread-mailbox-wakeup! t (lambda () (thread-reschedule! t))) + (define do-yield + (thread-deschedule! t + #f + ;; Interrupted for break => not waiting for mail + (lambda () + (set-thread-mailbox-wakeup! t void)) + ;; No retry action, because we always retry: + void)) + ;; called out of atomic mode: + (lambda () + (do-yield) + (thread-receive))])))) + +(define (thread-try-receive) + (atomically + (define t (current-thread)) + (if (is-mail? t) + (dequeue-mail! t) + #f))) + +(define/who (thread-rewind-receive lst) + (check who list? lst) + (atomically + (define t (current-thread)) + (for-each (lambda (msg) + (push-mail! t msg)) + lst))) + +;; ---------------------------------------- + +(struct thread-receiver-evt () + #:property prop:evt (poller + ;; in atomic mode: + (lambda (self poll-ctx) + (assert-atomic-mode) + (define t (current-thread)) + (cond + [(is-mail? t) (values (list self) #f)] + [(poll-ctx-poll? poll-ctx) (values #f self)] + [else + (define receive (let ([select-proc (poll-ctx-select-proc poll-ctx)]) + (lambda () + (when (is-mail? t) + (select-proc))))) + (define (add-wakeup-callback!) + (define wakeup (thread-mailbox-wakeup t)) + (set-thread-mailbox-wakeup! t (lambda () (wakeup) (receive)))) + (add-wakeup-callback!) + (values #f (control-state-evt + (wrap-evt async-evt (lambda (v) self)) + ;; interrupt (all must be interrupted, so just install `void`): + (lambda () (set-thread-mailbox-wakeup! t void)) + ;; abandon: + (lambda () (set! receive void)) + ;; retry (was interrupted, but not abandoned): + (lambda () (add-wakeup-callback!))))]))) + #:reflection-name 'thread-receive-evt) + +(define/who (thread-receive-evt) + (thread-receiver-evt)) diff --git a/racket/src/thread/time.rkt b/racket/src/thread/time.rkt new file mode 100644 index 0000000000..9cd6aa2ef7 --- /dev/null +++ b/racket/src/thread/time.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require "check.rkt" + (submod "thread.rkt" scheduling) + (prefix-in engine: "engine.rkt")) + +(provide current-process-milliseconds + set-get-subprocesses-time!) + +(define/who (current-process-milliseconds [scope #f]) + (cond + [(not scope) (engine:current-process-milliseconds)] + [(thread? scope) (thread-cpu-time scope)] + [(eq? scope 'subprocesses) (get-subprocesses-time)] + [else + (raise-argument-error who "(or/c #f thread? 'subprocesses)" scope)])) + +(define get-subprocesses-time (lambda () 0)) + +(define (set-get-subprocesses-time! f) + (set! get-subprocesses-time f)) diff --git a/racket/src/thread/tree.rkt b/racket/src/thread/tree.rkt new file mode 100644 index 0000000000..2bc0cab401 --- /dev/null +++ b/racket/src/thread/tree.rkt @@ -0,0 +1,249 @@ +#lang racket/base + +;; Balanced binary tree ---- immutable and parameterized +;; over the less-than function + +(provide empty-tree + (rename-out [is-empty? tree-empty?] + [lookup tree-ref] + [insert tree-set] + [delete tree-remove] + [min-key+value tree-min] + [max-key+value tree-max])) + +(struct node (key val height left right) + #:transparent) + +(define empty-tree #f) + +(define (is-empty? t) (not t)) + +;; ---------------------------------------- + +(define (tree-height t) + (cond + [(not t) 0] + [else (node-height t)])) + +(define (tree-balance t) + (- (tree-height (node-left t)) + (tree-height (node-right t)))) + +(define (combine key val left right) + (node key + val + (add1 (max (tree-height left) (tree-height right))) + left + right)) + +(define (reverse-combine key val right left) + (combine key val left right)) + +;; ---------------------------------------- + +(define (lookup t key bool) -> tree +(define (insert t key val bool) +;; (tree-of-X -> tree-of-X) +;; (tree-of-X -> tree-of-X) +;; (X tree-of-X tree-of-X -> tree-of-X) +;; -> tree +;; Like insert, but inserts to a child, where `node-to' +;; determines the side where the child is added,`node-other' +;; is the other side, and `comb' builds the new tree gven the +;; two new children. +(define (insert-to t new-key new-val string i) string (car l)) (lookup t (car l) <)) + (define new-t (delete t (car l) <)) + (check-equal? #f (lookup new-t (car l) <)) + (check-balance? new-t) + (loop new-t (cdr l))])))) + + "tests passed") diff --git a/racket/src/thread/unsafe.rkt b/racket/src/thread/unsafe.rkt new file mode 100644 index 0000000000..805bca4f51 --- /dev/null +++ b/racket/src/thread/unsafe.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require "atomic.rkt" + "thread.rkt" + "schedule.rkt" + "evt.rkt") + +(provide unsafe-start-atomic + unsafe-end-atomic + unsafe-start-breakable-atomic + unsafe-end-breakable-atomic + unsafe-in-atomic? + unsafe-set-on-atomic-timeout!) + +(define (unsafe-start-breakable-atomic) + (start-atomic)) + +(define (unsafe-end-breakable-atomic) + (end-atomic)) + +(define (unsafe-start-atomic) + (start-atomic) + (current-break-suspend (add1 (current-break-suspend)))) + +(define (unsafe-end-atomic) + (define bs (sub1 (current-break-suspend))) + (current-break-suspend bs) + (end-atomic) + (when (zero? bs) + (check-for-break))) + +(define (unsafe-in-atomic?) + (positive? (current-atomic))) + +(define (unsafe-set-on-atomic-timeout! proc) + (set-atomic-timeout-callback! proc)) diff --git a/racket/src/thread/waiter.rkt b/racket/src/thread/waiter.rkt new file mode 100644 index 0000000000..e82f7eac82 --- /dev/null +++ b/racket/src/thread/waiter.rkt @@ -0,0 +1,42 @@ +#lang racket/base +(require "internal-error.rkt") + +(provide prop:waiter + make-waiter-methods + waiter-resume! + waiter-suspend! + + select-waiter) + +;; A waiter can be in the queue for a semaphore or +;; channel +(define-values (prop:waiter waiter? waiter-ref) + (make-struct-type-property 'waiter)) + +(struct waiter-methods (suspend resume)) + +(define (make-waiter-methods #:suspend! suspend + #:resume! resume) + (waiter-methods suspend resume)) + + +(define (waiter-resume! w s) + ((waiter-methods-resume (waiter-ref w)) w s)) + +;; `interrupt-cb` is run if the suspend is interrupted by +;; either a break or kill; `abandon-cb` is called in +;; addition if it's a kill or a bresk escape; +;; `retry-cb` is run, instead, if the suspend +;; should be retired, and it's a thunk that runs in +;; atomic mode and returns a thunk to run in tail position +;; out of atomic mode +(define (waiter-suspend! w interrupt-cb retry-cb) + ((waiter-methods-suspend (waiter-ref w)) w interrupt-cb retry-cb)) + +;; Used for semaphores and channels to run a "just selected" callback +;; when synchronized: +(struct select-waiter (proc) + #:property prop:waiter + (make-waiter-methods #:suspend! (lambda args (internal-error "should not suspend a select-waiter")) + #:resume! (lambda (w s) + ((select-waiter-proc w))))) diff --git a/racket/src/thread/will-executor.rkt b/racket/src/thread/will-executor.rkt new file mode 100644 index 0000000000..68163ac6a0 --- /dev/null +++ b/racket/src/thread/will-executor.rkt @@ -0,0 +1,60 @@ +#lang racket/base +(require "check.rkt" + "atomic.rkt" + "engine.rkt" + "evt.rkt" + "sync.rkt" + "semaphore.rkt") + +;; The core must provide `will-try-execute`. We implement +;; `will-execute` here, because it has to block when no will is ready. + +(provide make-will-executor + make-stubborn-will-executor + will-executor? + will-register + will-try-execute + will-execute) + +(struct will-executor (host-we sema) + #:authentic + #:property prop:evt (lambda (we) + (wrap-evt (semaphore-peek-evt (will-executor-sema we)) + (lambda (v) we)))) + +(define (do-make-will-executor host:make-will-executor) + (define sema (make-semaphore)) + (will-executor (host:make-will-executor + ;; called in scheduler: + (lambda () (semaphore-post/atomic sema))) + sema)) + +(define (make-will-executor) + (do-make-will-executor host:make-will-executor)) + +(define (make-stubborn-will-executor) + (do-make-will-executor host:make-stubborn-will-executor)) + +(define/who (will-register we v proc) + (check who will-executor? we) + (check who (procedure-arity-includes/c 1) proc) + (host:will-register (will-executor-host-we we) v proc)) + +(define (do-will-execute who we fail-k) + (check who will-executor? we) + ((atomically + (cond + [(host:will-try-execute (will-executor-host-we we)) + => (lambda (p) + (semaphore-wait/atomic (will-executor-sema we)) + (lambda () + ((car p) (cdr p))))] + [else fail-k])))) + +(define/who (will-execute we) + (do-will-execute who we (lambda () + (sync we) + (will-execute we)))) + +(define/who (will-try-execute we [default #f]) + (do-will-execute who we (lambda () default))) diff --git a/racket/src/worksp/.gitignore b/racket/src/worksp/.gitignore index c3b42dae89..7949a84077 100644 --- a/racket/src/worksp/.gitignore +++ b/racket/src/worksp/.gitignore @@ -7,6 +7,8 @@ */SGC */*.user +cs/*.obj + # files generated by Visual Studio */*.ncb */*.opensdf @@ -20,9 +22,17 @@ */*X.vcxproj */*X.sln +/libracket/startup.inc +/libracket/cstartup.inc +/libracket/cstartup.zo + checkvs9.obj checkvs9.exe genvsx.obj genvsx.exe rbuildmode.obj rbuildmode.exe +cstartup.obj +cstartup.exe + +/compiled diff --git a/racket/src/worksp/build.bat b/racket/src/worksp/build.bat index c95cb38468..eb78db0766 100644 --- a/racket/src/worksp/build.bat +++ b/racket/src/worksp/build.bat @@ -18,16 +18,28 @@ if not exist ..\..\share mkdir ..\..\share if not defined BUILD_CONFIG set BUILD_CONFIG=..\..\etc +cl cstartup.c +cstartup.exe ..\racket\src\startup.inc libracket\startup.inc +if errorlevel 1 exit /B 1 +if not exist libracket\cstartup.inc echo #include "startup.inc" > libracket\cstartup.inc + cd racket msbuild racket%PLTSLNVER%.sln /p:Configuration=Release /p:Platform=%BUILDMODE% if errorlevel 1 exit /B 1 +..\..\..\racketcgc -cu ..\..\racket\src\compile-startup.rkt ..\libracket\cstartup.inc ..\libracket\cstartup.zo ..\..\racket\src\startup.inc ..\..\racket\src\schvers.h +if errorlevel 1 exit /B 1 +msbuild racket%PLTSLNVER%.sln /p:Configuration=Release /p:Platform=%BUILDMODE% + cd ..\gracket msbuild gracket%PLTSLNVER%.sln /p:Configuration=Release /p:Platform=%BUILDMODE% if errorlevel 1 exit /B 1 cd .. +REM Assumes that Racket is started in a subdirectory of here: +set BOOT_SETUP=-W "info@compiler/cm error" -l- setup --boot ../../setup-go.rkt ../compiled + cd gc2 -..\..\..\racketcgc -G ..\%BUILD_CONFIG% -cu make.rkt +..\..\..\racketcgc -G ..\%BUILD_CONFIG% %BOOT_SETUP% make.none ../compiled/make.dep make.rkt if errorlevel 1 exit /B 1 cd .. @@ -45,7 +57,7 @@ if errorlevel 1 exit /B 1 cd .. cd mzcom -..\..\..\racket -G ..\%BUILD_CONFIG% -cu xform.rkt +..\..\..\racket -G ..\%BUILD_CONFIG% %BOOT_SETUP% mzcom.none ../compiled/mzcom.dep xform.rkt if errorlevel 1 exit /B 1 cd .. diff --git a/racket/src/worksp/cs/Makefile b/racket/src/worksp/cs/Makefile new file mode 100644 index 0000000000..775415a7dc --- /dev/null +++ b/racket/src/worksp/cs/Makefile @@ -0,0 +1,24 @@ + +INCS = /I.. /I..\..\rktio /I..\librktio /I$(SCHEME_DIR)\$(MACHINE)\boot\$(MACHINE) + +RKTIO_LIB = ..\..\build\librktio.lib +BASE_WIN32_LIBS = WS2_32.lib Shell32.lib User32.lib +WIN32_LIBS = $(BASE_WIN32_LIBS) RpCrt4.lib Ole32.lib + +LIBS = $(RKTIO_LIB) \ + $(SCHEME_DIR)\$(MACHINE)\boot\$(MACHINE)\$(SCHEME_LIB) \ + $(WIN32_LIBS) + +DEST = ..\..\build\raw_racketcs.exe +CSDIR = ..\..\cs\c + +$(DEST): $(CSDIR).\main.c $(CSDIR)\boot.c $(RKTIO_LIB) + cl /Fe$(DEST) /Ox /MT $(INCS) $(CSDIR)\main.c $(CSDIR)\boot.c $(LIBS) + + +# Useful for debugging: + +RKTIO_DLL = ..\..\lib\librktio.dll + +rktio-dll: + cl /Fe$(RKTIO_DLL) /LD $(RKTIO_LIB) $(BASE_WIN32_LIBS) ..\..\rktio\rktio.def /link /machine:x64 diff --git a/racket/src/worksp/cs/prep.rkt b/racket/src/worksp/cs/prep.rkt new file mode 100644 index 0000000000..7606dce059 --- /dev/null +++ b/racket/src/worksp/cs/prep.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; Do the same work that Chez Scheme's `configure` performs +;; to set up build directories for Windows. + +(provide prep-chez-scheme) + +(define (prep-chez-scheme dir machine-name) + (define (not-git? p) + (define-values (base name dir?) (split-path p)) + (not (equal? ".git" (path->string name)))) + + (define (maybe-make-directory p) + (unless (directory-exists? p) (make-directory p))) + + (define (copy-one-dir name) + (define src-dir (build-path dir name)) + (define dest-dir (build-path dir machine-name name)) + (maybe-make-directory dest-dir) + (define paths (parameterize ([current-directory src-dir]) + (for/list ([p (in-directory #f not-git?)]) + p))) + (for ([p (in-list paths)]) + (define src-p (build-path src-dir p)) + (define dest-p (build-path dest-dir p)) + (cond + [(directory-exists? src-p) + (maybe-make-directory dest-p)] + [else + (define src-ts (file-or-directory-modify-seconds src-p)) + (define dest-ts (file-or-directory-modify-seconds dest-p #f (lambda () #f))) + (unless (and dest-ts (dest-ts . >= . src-ts)) + (printf "copying ~a\n" (build-path name p)) + (copy-file src-p dest-p #t))]))) + + (maybe-make-directory (build-path dir machine-name)) + (maybe-make-directory (build-path dir machine-name "boot")) + (maybe-make-directory (build-path dir machine-name "bin")) + (maybe-make-directory (build-path dir machine-name "bin" machine-name)) + + (copy-one-dir "c") + (copy-one-dir "s") + (copy-one-dir "mats") + (copy-one-dir "nanopass") + (copy-one-dir "zlib") + (copy-one-dir (build-path "boot" machine-name)) + + (define config-h (build-path dir machine-name "c" "config.h")) + (unless (file-exists? config-h) + (printf "making ~a\n" config-h) + (call-with-output-file* + config-h + (lambda (o) + (fprintf o "#define SCHEME_SCRIPT \"scheme-script\""))))) diff --git a/racket/src/worksp/csbuild.rkt b/racket/src/worksp/csbuild.rkt new file mode 100644 index 0000000000..47df2ce815 --- /dev/null +++ b/racket/src/worksp/csbuild.rkt @@ -0,0 +1,147 @@ +#lang racket/base +(require racket/cmdline + racket/path + racket/file + compiler/find-exe + racket/system + "cs/prep.rkt") + +(define scheme-dir "..\\build\\ChezScheme") +(define machine (if (= 32 (system-type 'word)) + "ti3nt" + "ta6nt")) + +(command-line + #:once-each + [("--scheme-dir") dir "Select the Chez Scheme build directory" + (set! scheme-dir dir)] + [("--machine") mach "Select the Chez Scheme machine name" + (set! machine mach)] + #:args + () + (void)) + +(define (system*! prog . args) + (printf "{in ~a}\n" (current-directory)) + (printf "~a" prog) + (for ([arg (in-list args)]) + (printf " [~a]" arg)) + (newline) + (unless (apply system* + (if (string? prog) + (find-executable-path (path-add-extension prog #".exe")) + prog) + args) + (error 'csbuild "command failed"))) + +(define (system! cmd) + (printf "{in ~a}\n" (current-directory)) + (printf "~a\n" cmd) + (unless (system cmd) + (error 'csbuild "command failed"))) + +;; ---------------------------------------- + +(unless (directory-exists? scheme-dir) + (system*! "git" + "clone" + "git@github.com:mflatt/ChezScheme" + scheme-dir)) + +(unless (file-exists? (build-path scheme-dir "zlib" "Makefile")) + (parameterize ([current-directory scheme-dir]) + (system*! "git" "submodule" "init") + (system*! "git" "submodule" "update"))) + +(prep-chez-scheme scheme-dir machine) + +(parameterize ([current-directory (build-path scheme-dir machine "c")]) + (system*! "nmake" (format "Makefile.~a" machine))) + +;; ---------------------------------------- + +;; Run Racket in directories that reach here with "../worksp". +;; By using a relative path, we avoid problems with spaces in path names. +(define rel-racket (build-path 'up "worksp" (find-relative-path (current-directory) (find-exe)))) + +(define chain-racket + (format "~a -W info@compiler/cm -l- setup --chain ../setup-go.rkt ../build/compiled" + rel-racket)) + +(define build-dir (path->directory-path (build-path 'up "build"))) + +;; ---------------------------------------- + +(define (build-layer name + #:dir [dir name] + #:skip-make? [skip-make? #f]) + (parameterize ([current-directory (build-path 'up dir)]) + (make-directory* (build-path build-dir "compiled")) + (unless skip-make? + (system*! "nmake" + (format "~a-src-generate" name) + (format "BUILDDIR=~a" build-dir) + (format "RACKET=~a ~a ~a" chain-racket "ignored" "ignored.d"))))) + +(build-layer "expander") +(build-layer "thread") +(build-layer "io") +(build-layer "regexp") + +(build-layer "schemify") +(build-layer "known" #:dir "schemify") + +;; ---------------------------------------- + +(define scheme (build-path scheme-dir machine "bin" machine "scheme.exe")) +(define rel-scheme (build-path 'up "worksp" + (if (relative-path? scheme) + scheme + (find-relative-path (current-directory) scheme)))) + +;; Environment variable used by ".sls" files to find ".scm" files +(putenv "COMPILED_SCM_DIR" "../build/compiled/") + +(parameterize ([current-directory (build-path 'up "cs")]) + (define convert.d (build-path build-dir "compiled" "convert.d")) + (unless (file-exists? convert.d) (call-with-output-file convert.d void)) + (system*! "nmake" + (build-path "../build/racket.so") ; need forward slashes + (format "RACKET=~a" rel-racket) + (format "SCHEME=~a" rel-scheme) + (format "BUILDDIR=../build/") ; need forward slashes + (format "CONVERT_RACKET=~a" chain-racket))) + +;; ---------------------------------------- + +(system! "rktio.bat") + +;; ---------------------------------------- + +;; The library name changes with the version: +(define scheme-lib + (parameterize ([current-directory (build-path scheme-dir machine "boot" machine)]) + (for/or ([f (in-list (directory-list))] + #:when (regexp-match? #rx"^csv.*mt.lib$" f)) + f))) + +(define rel2-scheme-dir (build-path 'up + (if (relative-path? scheme-dir) + scheme-dir + (find-relative-path (current-directory) scheme-dir)))) + +(parameterize ([current-directory "cs"]) + (system*! "nmake" + "..\\..\\build\\raw_racketcs.exe" + (format "SCHEME_DIR=~a" rel2-scheme-dir) + (format "MACHINE=~a" machine) + (format "SCHEME_LIB=~a" scheme-lib))) + +;; ---------------------------------------- + +(system*! (find-exe) + "../cs/c/embed-boot.rkt" + "../build/raw_racketcs.exe" + "../../RacketCS.exe" + (build-path scheme-dir machine "boot" machine) + "../build/racket.so") diff --git a/racket/src/worksp/cstartup.c b/racket/src/worksp/cstartup.c new file mode 100644 index 0000000000..29e4b18301 --- /dev/null +++ b/racket/src/worksp/cstartup.c @@ -0,0 +1,56 @@ +#include +#include +#include + +/* 65535 characters should be enough for any string --- or so says + MSVC. Convert "startup.inc" to a character array. */ + +int main(int argc, char **argv) { + struct _stat s1, s2; + FILE *in, *out; + int c, col = 0; + + if (_stat(argv[1], &s1) == 0) { + if (_stat(argv[2], &s2) == 0) { + if (s2.st_mtime > s1.st_mtime) { + printf("Generated file is already newer than source\n"); + return 0; + } + } + } + + in = fopen(argv[1], "r"); + out = fopen(argv[2], "w"); + + fprintf(out, "#define EVAL_STARTUP EVAL_ONE_STR((char *)startup_source)\n"); + fprintf(out, "static unsigned char startup_source[] = {\n"); + + while (1) { + while (1) { + c = fgetc(in); + if (c == '"') + break; + + if (c == EOF) { + fprintf(out, "\n 0 };\n"); + return 0; + } + } + + while (1) { + c = fgetc(in); + if (c == '"') + break; + if (c == '\\') + c = fgetc(in); + fprintf(out, "%d,", c); + col++; + if (col == 20) { + fprintf(out, "\n"); + col = 0; + } + } + } + + return 0; +} diff --git a/racket/src/worksp/gc2/make.rkt b/racket/src/worksp/gc2/make.rkt index 4c125dcab6..4910d04773 100644 --- a/racket/src/worksp/gc2/make.rkt +++ b/racket/src/worksp/gc2/make.rkt @@ -1,8 +1,6 @@ #lang racket/base - -(use-compiled-file-paths null) - -(require racket/system) +(require racket/system + (for-label "../../racket/gc2/xform-mod.rkt")) (define (system- s) (eprintf "~a\n" s) @@ -34,7 +32,6 @@ '("salloc" "bignum" "bool" - "builtin" "char" "compenv" "compile" @@ -57,9 +54,9 @@ "jitstack" "jitstate" "letrec_check" + "linklet" "list" "marshal" - "module" "mzrt" "network" "numarith" @@ -78,6 +75,8 @@ "sema" "setjmpup" "sfs" + "sort" + "startup" "string" "struct" "symbol" @@ -115,13 +114,10 @@ (sync (thread (lambda () - (parameterize ([use-compiled-file-paths (list "compiled")] - [current-namespace (make-base-namespace)] + (parameterize ([current-namespace (make-base-namespace)] [current-command-line-arguments (list->vector (append - (list "--setup" - ".") (if objdest (if use-precomp (list "--precompiled" use-precomp) @@ -141,7 +137,7 @@ "-o" dest src)))]) - (dynamic-require "../../racket/gc2/xform.rkt" #f) + (dynamic-require "../../racket/gc2/xform-mod.rkt" #f) (set! success? #t))))) (unless success? (when (file-exists? dest) @@ -168,8 +164,7 @@ (unless (system- (format "~a ~a /MT /Zi /GS- ~a /c ~a /Fdxsrc/ /Fo~a" cl.exe flags opt-flags c o)) (error "failed compile")))) -(define common-deps (list "../../racket/gc2/xform.rkt" - "../../racket/gc2/xform-mod.rkt")) +(define common-deps (list "../../racket/gc2/xform-mod.rkt")) (define (find-build-file d f) (define (find-release d2) @@ -193,6 +188,7 @@ (string-append "/I../../racket/include " "/I../../rktio " "/I../librktio " + "/I../libracket " "/I.. ")) (try "precomp.c" (list* "../../racket/src/schvers.h" diff --git a/racket/src/worksp/libracket/libracket.vcproj b/racket/src/worksp/libracket/libracket.vcproj index 9c9800057f..311e464cae 100644 --- a/racket/src/worksp/libracket/libracket.vcproj +++ b/racket/src/worksp/libracket/libracket.vcproj @@ -30,7 +30,7 @@ - - @@ -488,7 +484,7 @@ > + + + + diff --git a/racket/src/worksp/libracket/libracket.vcxproj b/racket/src/worksp/libracket/libracket.vcxproj index 6b7e32b212..756ef436ef 100644 --- a/racket/src/worksp/libracket/libracket.vcxproj +++ b/racket/src/worksp/libracket/libracket.vcxproj @@ -61,7 +61,7 @@ - ..;..\..\racket\include;..\..\racket\src;..\libffi;..\..\foreign\libffi\src\x86;..\..\foreign\libffi\include;..\..\rktio;..\librktio + ..;..\..\racket\include;..\..\racket\src;..\libffi;..\..\foreign\libffi\src\x86;..\..\foreign\libffi\include;..\..\rktio;..\librktio;..\libracket true Level3 @@ -172,7 +172,6 @@ - @@ -198,7 +197,7 @@ - + @@ -220,6 +219,8 @@ + + diff --git a/racket/src/worksp/mrstart/mrstart.vcproj b/racket/src/worksp/mrstart/mrstart.vcproj index c82054adde..961006d296 100644 --- a/racket/src/worksp/mrstart/mrstart.vcproj +++ b/racket/src/worksp/mrstart/mrstart.vcproj @@ -198,7 +198,7 @@ Filter="cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;for;f90" > - + diff --git a/racket/src/worksp/mzcom/xform.rkt b/racket/src/worksp/mzcom/xform.rkt index 0ef4a30cfd..f38f0c3dd4 100644 --- a/racket/src/worksp/mzcom/xform.rkt +++ b/racket/src/worksp/mzcom/xform.rkt @@ -1,16 +1,14 @@ #lang racket/base - +(require (for-label "../../racket/gc2/xform-mod.rkt")) + (define cpp-flags "/D _CRT_SECURE_NO_DEPRECATE /D WIN32 /D _USE_DECLSPECS_FOR_SAL=0 /D _USE_ATTRIBUTES_FOR_SAL=0") (define includes "/I ../../racket/include /I . /I .. /I ../../mzcom") (define (xform src dest) - (parameterize ([use-compiled-file-paths (list "compiled")] - [current-command-line-arguments + (parameterize ([current-command-line-arguments (list->vector (append - (list "--setup" - "../gc2" - "--indirect" + (list "--indirect" "--depends") (list "--cpp" @@ -20,6 +18,6 @@ "-o" dest src)))]) - (dynamic-require "../../racket/gc2/xform.rkt" #f))) + (dynamic-require "../../racket/gc2/xform-mod.rkt" #f))) (xform "../../mzcom/mzobj.cxx" "../../mzcom/mzobj3m.cxx") diff --git a/racket/src/worksp/mzstart/mzstart.vcproj b/racket/src/worksp/mzstart/mzstart.vcproj index 841362070a..a58d38e30e 100644 --- a/racket/src/worksp/mzstart/mzstart.vcproj +++ b/racket/src/worksp/mzstart/mzstart.vcproj @@ -108,7 +108,7 @@ Filter="cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;for;f90" > - + diff --git a/racket/src/worksp/rktio.bat b/racket/src/worksp/rktio.bat new file mode 100644 index 0000000000..f26bb4e653 --- /dev/null +++ b/racket/src/worksp/rktio.bat @@ -0,0 +1,23 @@ +setlocal + +cl rbuildmode.c +rbuildmode.exe +if errorlevel 1 (set BUILDMODE=win32) else (set BUILDMODE=x64) + +cl checkvs9.c +checkvs9.exe +if errorlevel 1 (set PLTSLNVER=9) + +set VCPROJ=vcproj + +cl genvsx.c +genvsx.exe +if errorlevel 1 (set PLTSLNVER=X) +if errorlevel 1 (set VCPROJ=vcxproj) + +cd librktio +msbuild librktio%PLTSLNVER%.%VCPROJ% /p:Configuration=Release /p:Platform=%BUILDMODE% +if errorlevel 1 exit /B 1 + +copy %BUILDMODE%\Release\librktio.lib ..\..\build\librktio.lib +cd ..